diff options
Diffstat (limited to 'lisp')
258 files changed, 14728 insertions, 8303 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/abbrev.el b/lisp/abbrev.el index e1311dbc83b..1a665efb0a5 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -501,7 +501,7 @@ PROPS is a list of properties." (defun abbrev-table-p (object) "Return non-nil if OBJECT is an abbrev table." (and (obarrayp object) - (numberp (ignore-error 'wrong-type-argument + (numberp (ignore-error wrong-type-argument (abbrev-table-get object :abbrev-table-modiff))))) (defun abbrev-table-empty-p (object &optional ignore-system) 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/apropos.el b/lisp/apropos.el index 5d7fe6962a5..e95f45f1804 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -54,6 +54,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup apropos nil "Apropos commands for users and programmers." :group 'help @@ -193,9 +195,6 @@ property list, WIDGET-DOC is the widget docstring, FACE-DOC is the face docstring, and CUS-GROUP-DOC is the custom group docstring. Each docstring is either nil or a string.") -(defvar apropos-item () - "Current item in or for `apropos-accumulator'.") - (defvar apropos-synonyms '( ("find" "open" "edit") ("kill" "cut") @@ -906,6 +905,18 @@ Optional arg BUFFER (default: current buffer) is the buffer to check." ((symbolp def) (funcall f def)) ((eq 'defun (car-safe def)) (funcall f (cdr def))))))))) +(defun apropos--documentation-add (symbol doc pos) + (when (setq doc (apropos-documentation-internal doc)) + (let ((score (apropos-score-doc doc)) + (item (cdr (assq symbol apropos-accumulator)))) + (unless item + (push (cons symbol + (setq item (list (apropos-score-symbol symbol 2) + nil nil))) + apropos-accumulator)) + (setf (nth pos item) doc) + (setcar item (+ (car item) score))))) + ;;;###autoload (defun apropos-documentation (pattern &optional do-all) "Show symbols whose documentation contains matches for PATTERN. @@ -928,40 +939,28 @@ Returns list of symbols and documentation found." (setq apropos--current (list #'apropos-documentation pattern do-all)) (apropos-parse-pattern pattern t) (or do-all (setq do-all apropos-do-all)) - (setq apropos-accumulator () apropos-files-scanned ()) - (with-temp-buffer - (let ((standard-input (current-buffer)) - (apropos-sort-by-scores apropos-documentation-sort-by-scores) - f v sf sv) - (apropos-documentation-check-doc-file) - (funcall - (if do-all #'mapatoms #'apropos--map-preloaded-atoms) - (lambda (symbol) - (setq f (apropos-safe-documentation symbol) - v (get symbol 'variable-documentation)) - (if (integerp v) (setq v nil)) - (setq f (apropos-documentation-internal f) - v (apropos-documentation-internal v)) - (setq sf (apropos-score-doc f) - sv (apropos-score-doc v)) - (if (or f v) - (if (setq apropos-item - (cdr (assq symbol apropos-accumulator))) - (progn - (if f - (progn - (setcar (nthcdr 1 apropos-item) f) - (setcar apropos-item (+ (car apropos-item) sf)))) - (if v - (progn - (setcar (nthcdr 2 apropos-item) v) - (setcar apropos-item (+ (car apropos-item) sv))))) - (setq apropos-accumulator - (cons (list symbol - (+ (apropos-score-symbol symbol 2) sf sv) - f v) - apropos-accumulator)))))) - (apropos-print nil "\n----------------\n" nil t)))) + (let ((apropos-accumulator ()) + (apropos-files-scanned ()) + (delayed (make-hash-table :test #'equal))) + (with-temp-buffer + (let ((standard-input (current-buffer)) + (apropos-sort-by-scores apropos-documentation-sort-by-scores) + f v) + (apropos-documentation-check-doc-file) + (funcall + (if do-all #'mapatoms #'apropos--map-preloaded-atoms) + (lambda (symbol) + (setq f (apropos-safe-documentation symbol) + v (get symbol 'variable-documentation)) + (if (integerp v) (setq v nil)) + (if (consp f) + (push (list symbol (cdr f) 1) (gethash (car f) delayed)) + (apropos--documentation-add symbol f 1)) + (if (consp v) + (push (list symbol (cdr v) 2) (gethash (car v) delayed)) + (apropos--documentation-add symbol v 2)))) + (maphash #'apropos--documentation-add-from-elc delayed) + (apropos-print nil "\n----------------\n" nil t))))) (defun apropos-value-internal (predicate symbol function) @@ -982,11 +981,11 @@ Returns list of symbols and documentation found." symbol))) (defun apropos-documentation-internal (doc) + ;; By the time we get here, refs to DOC or to .elc files should have + ;; been converted into actual strings. + (cl-assert (not (or (consp doc) (integerp doc)))) (cond - ((consp doc) - (apropos-documentation-check-elc-file (car doc))) - ((and doc - ;; Sanity check in case bad data sneaked into the + ((and ;; Sanity check in case bad data sneaked into the ;; documentation slot. (stringp doc) (string-match apropos-all-words-regexp doc) @@ -1053,110 +1052,62 @@ non-nil." ;; So we exclude them. (cond ((= 3 type) (boundp symbol)) ((= 2 type) (fboundp symbol)))) - (or (and (setq apropos-item (assq symbol apropos-accumulator)) - (setcar (cdr apropos-item) - (apropos-score-doc doc))) - (setq apropos-item (list symbol - (+ (apropos-score-symbol symbol 2) - (apropos-score-doc doc)) - nil nil) - apropos-accumulator (cons apropos-item - apropos-accumulator))) - (when apropos-match-face - (setq doc (substitute-command-keys doc)) - (if (or (string-match apropos-pattern-quoted doc) - (string-match apropos-all-words-regexp doc)) - (put-text-property (match-beginning 0) - (match-end 0) - 'face apropos-match-face doc))) - (setcar (nthcdr type apropos-item) doc)))) + (let ((apropos-item (assq symbol apropos-accumulator))) + (or (and apropos-item + (setcar (cdr apropos-item) + (apropos-score-doc doc))) + (setq apropos-item (list symbol + (+ (apropos-score-symbol symbol 2) + (apropos-score-doc doc)) + nil nil) + apropos-accumulator (cons apropos-item + apropos-accumulator))) + (when apropos-match-face + (setq doc (substitute-command-keys doc)) + (if (or (string-match apropos-pattern-quoted doc) + (string-match apropos-all-words-regexp doc)) + (put-text-property (match-beginning 0) + (match-end 0) + 'face apropos-match-face doc))) + (setcar (nthcdr type apropos-item) doc))))) (setq sepa (goto-char sepb))))) -(defun apropos-documentation-check-elc-file (file) - ;; .elc files have the location of the file specified as #$, but for - ;; built-in files, that's a relative name (while for the rest, it's - ;; absolute). So expand the name in the former case. - (unless (file-name-absolute-p file) - (setq file (expand-file-name file lisp-directory))) - (if (or (member file apropos-files-scanned) - (not (file-exists-p file))) - nil - (let (symbol doc beg end this-is-a-variable) - (setq apropos-files-scanned (cons file apropos-files-scanned)) - (erase-buffer) - (insert-file-contents file) - (while (search-forward "#@" nil t) - ;; Read the comment length, and advance over it. - ;; This #@ may be a false positive, so don't get upset if - ;; it's not followed by the expected number of bytes to skip. - (when (and (setq end (ignore-errors (read))) (natnump end)) - (setq beg (1+ (point)) - end (+ (point) end -1)) - (forward-char) - (if (save-restriction - ;; match ^ and $ relative to doc string - (narrow-to-region beg end) - (re-search-forward apropos-all-words-regexp nil t)) - (progn - (goto-char (+ end 2)) - (setq doc (buffer-substring beg end) - end (- (match-end 0) beg) - beg (- (match-beginning 0) beg)) - (when (apropos-true-hit-doc doc) - (setq this-is-a-variable (looking-at "(def\\(var\\|const\\) ") - symbol (progn - (skip-chars-forward "(a-z") - (forward-char) - (read)) - symbol (if (consp symbol) - (nth 1 symbol) - symbol)) - (if (if this-is-a-variable - (get symbol 'variable-documentation) - (and (fboundp symbol) (apropos-safe-documentation symbol))) - (progn - (or (and (setq apropos-item (assq symbol apropos-accumulator)) - (setcar (cdr apropos-item) - (+ (cadr apropos-item) (apropos-score-doc doc)))) - (setq apropos-item (list symbol - (+ (apropos-score-symbol symbol 2) - (apropos-score-doc doc)) - nil nil) - apropos-accumulator (cons apropos-item - apropos-accumulator))) - (when apropos-match-face - (setq doc (substitute-command-keys doc)) - (if (or (string-match apropos-pattern-quoted doc) - (string-match apropos-all-words-regexp doc)) - (put-text-property (match-beginning 0) - (match-end 0) - 'face apropos-match-face doc))) - (setcar (nthcdr (if this-is-a-variable 3 2) - apropos-item) - doc))))))))))) - - +(defun apropos--documentation-add-from-elc (file defs) + (erase-buffer) + (insert-file-contents + (if (file-name-absolute-p file) file + (expand-file-name file lisp-directory))) + (pcase-dolist (`(,symbol ,begbyte ,pos) defs) + ;; We presume the file-bytes are the same as the buffer bytes, + ;; which should indeed be the case because .elc files use the + ;; `emacs-internal' encoding. + (let* ((beg (byte-to-position (+ (point-min) begbyte))) + (sizeend (1- beg)) + (size (save-excursion + (goto-char beg) + (skip-chars-backward " 0-9") + (cl-assert (looking-back "#@" (- (point) 2))) + (string-to-number (buffer-substring (point) sizeend)))) + (end (byte-to-position (+ begbyte size -1)))) + (when (save-restriction + ;; match ^ and $ relative to doc string + (narrow-to-region beg end) + (goto-char (point-min)) + (re-search-forward apropos-all-words-regexp nil t)) + (let ((doc (buffer-substring beg end))) + (when (apropos-true-hit-doc doc) + (apropos--documentation-add symbol doc pos))))))) (defun apropos-safe-documentation (function) "Like `documentation', except it avoids calling `get_doc_string'. Will return nil instead." - (while (and function (symbolp function)) - (setq function (symbol-function function))) - (if (eq (car-safe function) 'macro) - (setq function (cdr function))) - (setq function (if (byte-code-function-p function) - (if (> (length function) 4) - (aref function 4)) - (if (autoloadp function) - (nth 2 function) - (if (eq (car-safe function) 'lambda) - (if (stringp (nth 2 function)) - (nth 2 function) - (if (stringp (nth 3 function)) - (nth 3 function))))))) - (if (integerp function) - nil - function)) + (when (setq function (indirect-function function)) + ;; FIXME: `function-documentation' says not to call it, but `documentation' + ;; would turn (FILE . POS) references into strings too eagerly, so + ;; we do want to use the lower-level function. + (let ((doc (function-documentation function))) + ;; Docstrings from the DOC file are handled elsewhere. + (if (integerp doc) nil doc)))) (defcustom apropos-compact-layout nil "If non-nil, use a single line per binding." @@ -1262,14 +1213,16 @@ as a heading." (put-text-property (- (point) 3) (point) 'face 'apropos-keybinding))) (terpri)) - (apropos-print-doc 2 + (apropos-print-doc apropos-item + 2 (if (commandp symbol) 'apropos-command (if (macrop symbol) 'apropos-macro 'apropos-function)) (not nosubst)) - (apropos-print-doc 3 + (apropos-print-doc apropos-item + 3 (if (custom-variable-p symbol) 'apropos-user-option 'apropos-variable) @@ -1287,10 +1240,10 @@ as a heading." (lambda (_) (message "Value: %s" value)))) (insert "\n"))) - (apropos-print-doc 7 'apropos-group t) - (apropos-print-doc 6 'apropos-face t) - (apropos-print-doc 5 'apropos-widget t) - (apropos-print-doc 4 'apropos-plist nil)) + (apropos-print-doc apropos-item 7 'apropos-group t) + (apropos-print-doc apropos-item 6 'apropos-face t) + (apropos-print-doc apropos-item 5 'apropos-widget t) + (apropos-print-doc apropos-item 4 'apropos-plist nil)) (setq-local truncate-partial-width-windows t) (setq-local truncate-lines t))) (when help-window-select @@ -1298,7 +1251,7 @@ as a heading." (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc -(defun apropos-print-doc (i type do-keys) +(defun apropos-print-doc (apropos-item i type do-keys) (let ((doc (nth i apropos-item))) (when (stringp doc) (if apropos-compact-layout diff --git a/lisp/bindings.el b/lisp/bindings.el index f4881ac388c..c77b64c05da 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -670,6 +670,8 @@ or not." "Return the value of symbol VAR if it is bound, else nil. Note that if `lexical-binding' is in effect, this function isn't meaningful if it refers to a lexically bound variable." + (unless (symbolp var) + (signal 'wrong-type-argument (list 'symbolp var))) `(and (boundp (quote ,var)) ,var)) ;; Use mode-line-mode-menu for local minor-modes only. diff --git a/lisp/bs.el b/lisp/bs.el index 60dc74fbfce..70868591196 100644 --- a/lisp/bs.el +++ b/lisp/bs.el @@ -420,9 +420,6 @@ naming a sort behavior. Default is \"by nothing\" which means no sorting." Non-nil means to show all buffers. Otherwise show buffers defined by current configuration `bs-current-configuration'.") -(defvar bs--window-config-coming-from nil - "Window configuration before starting Buffer Selection Menu.") - (defvar bs--intern-show-never "^ \\|\\*buffer-selection\\*" "Regular expression specifying which buffers never to show. A buffer whose name matches this regular expression will never be @@ -491,6 +488,23 @@ Used internally, only.") "<mouse-2>" #'bs-mouse-select "<mouse-3>" #'bs-mouse-select-other-frame) +(defcustom bs-default-action-list '((display-buffer-reuse-window + display-buffer-below-selected) + (reusable-frames . nil) + (window-height . window-min-height)) + "Default action list for showing the '*bs-selection*' buffer. + +This list will be passed to `pop-to-buffer' as its ACTION argument. +It should be a cons cell (FUNCTIONS . ALIST), where FUNCTIONS is +an action function or a list of action functions and ALIST is an +action alist. Each such action function should accept two +arguments: a buffer to display and an alist of the same form as +ALIST. See `display-buffer' for details." + :type display-buffer--action-custom-type + :risky t + :version "30.1" + :group 'bs) + ;; ---------------------------------------------------------------------- ;; Functions ;; ---------------------------------------------------------------------- @@ -590,21 +604,6 @@ in `bs-string-current' or `bs-string-current-marked'." (format "Show buffer by configuration %S" bs-current-configuration))) -(defun bs--track-window-changes (frame) - "Track window changes to refresh the buffer list. -Used from `window-size-change-functions'." - (let ((win (get-buffer-window "*buffer-selection*" frame))) - (when win - (with-selected-window win - (bs--set-window-height))))) - -(defun bs--remove-hooks () - "Remove `bs--track-window-changes' and auxiliary hooks." - (remove-hook 'window-size-change-functions 'bs--track-window-changes) - ;; Remove itself - (remove-hook 'kill-buffer-hook 'bs--remove-hooks t) - (remove-hook 'change-major-mode-hook 'bs--remove-hooks t)) - (put 'bs-mode 'mode-class 'special) (define-derived-mode bs-mode nil "Buffer-Selection-Menu" @@ -663,25 +662,13 @@ apply it. (setq-local font-lock-defaults '(bs-mode-font-lock-keywords t)) (setq-local font-lock-verbose nil) (setq-local font-lock-global-modes '(not bs-mode)) - (setq-local revert-buffer-function 'bs-refresh) - (add-hook 'window-size-change-functions 'bs--track-window-changes) - (add-hook 'kill-buffer-hook 'bs--remove-hooks nil t) - (add-hook 'change-major-mode-hook 'bs--remove-hooks nil t)) - -(defun bs--restore-window-config () - "Restore window configuration on the current frame." - (when bs--window-config-coming-from - (let ((frame (selected-frame))) - (unwind-protect - (set-window-configuration bs--window-config-coming-from) - (select-frame frame))) - (setq bs--window-config-coming-from nil))) + (setq-local revert-buffer-function 'bs-refresh)) (defun bs-kill () "Let buffer disappear and reset window configuration." (interactive) (bury-buffer (current-buffer)) - (bs--restore-window-config)) + (quit-window)) (defun bs-abort () "Ding and leave Buffer Selection Menu without a selection." @@ -705,7 +692,9 @@ Arguments are IGNORED (for `revert-buffer')." (defun bs--set-window-height () "Change the height of the selected window to suit the current buffer list." (unless (one-window-p t) - (fit-window-to-buffer (selected-window) bs-max-window-height))) + (fit-window-to-buffer (selected-window) bs-max-window-height nil nil nil + ;; preserve-size + t))) (defun bs--current-buffer () "Return buffer on current line. @@ -742,7 +731,7 @@ Leave Buffer Selection Menu." (interactive) (let ((buffer (bs--current-buffer))) (bury-buffer (current-buffer)) - (bs--restore-window-config) + (quit-window) (switch-to-buffer buffer) (when bs--marked-buffers ;; Some marked buffers for selection @@ -765,7 +754,7 @@ Leave Buffer Selection Menu." (interactive) (let ((buffer (bs--current-buffer))) (bury-buffer (current-buffer)) - (bs--restore-window-config) + (quit-window) (switch-to-buffer-other-window buffer))) (defun bs-tmp-select-other-window () @@ -781,7 +770,7 @@ Leave Buffer Selection Menu." (interactive) (let ((buffer (bs--current-buffer))) (bury-buffer (current-buffer)) - (bs--restore-window-config) + (quit-window) (switch-to-buffer-other-frame buffer))) (defun bs-mouse-select-other-frame (event) @@ -944,7 +933,7 @@ WHAT is a value of nil, `never', or `always'." (end-of-line) (if (eobp) (point) (1+ (point))))) (when (eobp) - (backward-delete-char 1) + (delete-char -1) (beginning-of-line) (recenter -1)) (bs--set-window-height))) @@ -1165,7 +1154,18 @@ Select buffer *buffer-selection* and display buffers according to current configuration `bs-current-configuration'. Set window height, fontify buffer and move point to current buffer." (setq bs-current-list list) - (switch-to-buffer (get-buffer-create "*buffer-selection*")) + (let* ((window-combination-limit 'window-size) + (bs-buf (get-buffer-create "*buffer-selection*")) + (bs-win (progn + (pop-to-buffer bs-buf bs-default-action-list) + (selected-window)))) + ;; Delete other windows showing *buffer-selection*. + ;; Done after pop-to-buffer, instead of just calling delete-windows-on, + ;; to allow display-buffer-reuse(-mode)?-window to be used in ALIST. + (dolist (w (get-buffer-window-list bs-buf 'not t)) + (unless (eq w bs-win) + (with-demoted-errors "Error deleting window: %S" + (delete-window w))))) (bs-mode) (let* ((inhibit-read-only t) (map-fun (lambda (entry) @@ -1346,11 +1346,11 @@ ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu." 'help-echo "mouse-2: select this buffer, mouse-3: select in other frame" 'mouse-face 'highlight)) -(defun bs--get-mode-name (start-buffer _all-buffers) +(defun bs--get-mode-name (_start-buffer _all-buffers) "Return the name of mode of current buffer for Buffer Selection Menu. START-BUFFER is the buffer where we started buffer selection. ALL-BUFFERS is the list of buffers appearing in Buffer Selection Menu." - (format-mode-line mode-name nil nil start-buffer)) + (format-mode-line mode-name nil nil nil)) (defun bs--get-file-name (_start-buffer _all-buffers) "Return string for column `File' in Buffer Selection Menu. @@ -1435,21 +1435,8 @@ for buffer selection." ;; Only when not in buffer *buffer-selection* ;; we have to set the buffer we started the command (setq bs--buffer-coming-from (current-buffer))) - (let ((liste (bs-buffer-list)) - (active-window (get-window-with-predicate - (lambda (w) - (string= (buffer-name (window-buffer w)) - "*buffer-selection*")) - nil (selected-frame)))) - (if active-window - (select-window active-window) - (bs--restore-window-config) - (setq bs--window-config-coming-from (current-window-configuration)) - (when (> (window-height) 7) - ;; Errors would mess with the window configuration (bug#10882). - (ignore-errors (select-window (split-window-below))))) - (bs-show-in-buffer liste) - (bs-message-without-log "%s" (bs--current-config-message))))) + (bs-show-in-buffer (bs-buffer-list)) + (bs-message-without-log "%s" (bs--current-config-message)))) (defun bs--configuration-name-for-prefix-arg (prefix) "Convert prefix argument PREFIX to a name of a buffer configuration. diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index bb0ecd2c84f..52c0fa4f69f 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1297,12 +1297,13 @@ calc-kill calc-kill-region calc-yank)))) 0)) (let ((msg (nth calc-prefix-help-phase msgs))) (message "%s" (if msg - (concat group ": " msg ":" + (concat group ": " (substitute-command-keys msg) ":" (make-string (- (apply #'max (mapcar #'length msgs)) (length msg)) ?\s) - " [MORE]" + (substitute-command-keys + " [\\`?'=MORE]") (if key (concat " " (char-to-string key) "-") diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index d0052472836..6b3e5cd64b1 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -39,8 +39,11 @@ (or calc-dispatch-help (sit-for echo-keystrokes)) (let ((key (calc-read-key-sequence (if calc-dispatch-help - "Calc Help options: Help, Info, Tutorial, Summary; Key, Function; ?=more" - (format "%s (Type ? for a list of Calc Help options)" + (substitute-command-keys + (concat "Calc Help options: \\`h'elp, \\`i'nfo, \\`t'utorial, " + "\\`s'ummary; \\`k'ey, \\`f'unction; \\`?'=more")) + (format (substitute-command-keys + "%s (Type \\`?' for a list of Calc Help options)") (key-description (this-command-keys)))) calc-help-map))) (setq key (lookup-key calc-help-map key)) @@ -76,7 +79,10 @@ (describe-function 'calc-help-for-help) (select-window (get-buffer-window "*Help*")) (while (progn - (message "Calc Help options: Help, Info, ... press SPC, DEL to scroll, C-g to cancel") + (message (substitute-command-keys + (concat + "Calc Help options: \\`h'elp, \\`i'nfo, ... press " + "\\`SPC', \\`DEL' to scroll, \\`C-g' to cancel"))) (memq (setq key (read-event)) '(? ?\C-h ?\C-? ?\C-v ?\M-v))) (condition-case nil @@ -453,47 +459,47 @@ (defun calc-h-prefix-help () (interactive) (calc-do-prefix-help - '("Help; Bindings; Info, Tutorial, Summary; News" - "describe: Key, C (briefly), Function, Variable") + '("\\`h'elp; \\`b'indings; \\`i'nfo, \\`t'utorial, \\`s'ummary; \\`n'ews" + "describe: \\`k'ey, \\`c' (briefly), \\`f'unction, \\`v'ariable") "help" ?h)) (defun calc-inverse-prefix-help () (interactive) (calc-do-prefix-help - '("I + S (arcsin), C (arccos), T (arctan); Q (square)" - "I + E (ln), L (exp), B (alog: B^X); f E (lnp1), f L (expm1)" - "I + F (ceiling), R (truncate); a S (invert func)" - "I + a m (match-not); c h (from-hms); k n (prev prime)" - "I + f G (gamma-Q); f e (erfc); k B (etc., lower-tail dists)" - "I + V S (reverse sort); V G (reverse grade)" - "I + v s (remove subvec); v h (tail)" - "I + t + (alt sum), t M (mean with error)" - "I + t S (pop std dev), t C (pop covar)") + '("\\`I' + \\`S' (arcsin), \\`C' (arccos), \\`T' (arctan); \\`Q' (square)" + "\\`I' + \\`E' (ln), \\`L' (exp), \\`B' (alog: B^X); \\`f E' (lnp1), \\`f L' (expm1)" + "\\`I' + \\`F' (ceiling), \\`R' (truncate); \\`a S' (invert func)" + "\\`I' + \\`a m' (match-not); \\`c h' (from-hms); \\`k n' (prev prime)" + "\\`I' + \\`f G' (gamma-Q); \\`f e' (erfc); \\`k B' (etc., lower-tail dists)" + "\\`I' + \\`V S' (reverse sort); \\`V G' (reverse grade)" + "\\`I' + \\`v s' (remove subvec); \\`v h' (tail)" + "\\`I' + \\`t' + (alt sum), \\`t M' (mean with error)" + "\\`I' + \\`t S' (pop std dev), \\`t C' (pop covar)") "inverse" nil)) (defun calc-hyperbolic-prefix-help () (interactive) (calc-do-prefix-help - '("H + S (sinh), C (cosh), T (tanh); E (exp10), L (log10)" - "H + F (float floor), R (float round); P (constant \"e\")" - "H + a d (total derivative); k c (permutations)" - "H + k b (bern-poly), k e (euler-poly); k s (stirling-2)" - "H + f G (gamma-g), f B (beta-B); v h (rhead), v k (rcons)" - "H + v e (expand w/filler); V H (weighted histogram)" - "H + a S (general solve eqn), j I (general isolate)" - "H + a R (widen/root), a N (widen/min), a X (widen/max)" - "H + t M (median), t S (variance), t C (correlation coef)" - "H + c f/F/c (pervasive float/frac/clean)") + '("\\`H' + \\`S' (sinh), \\`C' (cosh), \\`T' (tanh); \\`E' (exp10), \\`L' (log10)" + "\\`H' + \\`F' (float floor), \\`R' (float round); \\`P' (constant \"e\")" + "\\`H' + \\`a d' (total derivative); \\`k c' (permutations)" + "\\`H' + \\`k b' (bern-poly), \\`k e' (euler-poly); \\`k s' (stirling-2)" + "\\`H' + \\`f G' (gamma-g), \\`f B' (beta-B); \\`v h' (rhead), \\`v k' (rcons)" + "\\`H' + \\`v e' (expand w/filler); \\`V H' (weighted histogram)" + "\\`H' + \\`a S' (general solve eqn), \\`j I' (general isolate)" + "\\`H' + \\`a R' (widen/root), \\`a N' (widen/min), \\`a X' (widen/max)" + "\\`H' + \\`t M' (median), \\`t S' (variance), \\`t C' (correlation coef)" + "\\`H' + \\`c' \\`f'/\\`F'/\\`c' (pervasive float/frac/clean)") "hyperbolic" nil)) (defun calc-inv-hyp-prefix-help () (interactive) (calc-do-prefix-help - '("I H + S (arcsinh), C (arccosh), T (arctanh)" - "I H + E (log10), L (exp10); f G (gamma-G)" - "I H + F (float ceiling), R (float truncate)" - "I H + t S (pop variance)" - "I H + a S (general invert func); v h (rtail)") + '("\\`I H' + \\`S' (arcsinh), \\`C' (arccosh), \\`T' (arctanh)" + "\\`I H' + \\`E' (log10), \\`L' (exp10); \\`f G' (gamma-G)" + "\\`I H' + \\`F' (float ceiling), \\`R' (float truncate)" + "\\`I H' + \\`t S' (pop variance)" + "\\`I H' + \\`a S' (general invert func); \\`v h' (rtail)") "inverse-hyperbolic" nil)) (defun calc-option-prefix-help () @@ -505,10 +511,10 @@ (defun calc-f-prefix-help () (interactive) (calc-do-prefix-help - '("miN, maX; Hypot; Im, Re; Sign; [, ] (incr/decr)" - "Gamma, Beta, Erf, besselJ, besselY" - "SHIFT + int-sQrt; Int-log, Exp(x)-1, Ln(x+1); arcTan2" - "SHIFT + Abssqr; Mantissa, eXponent, Scale" + '("mi\\`n', ma\\`x'; \\`h'ypot; \\`i'm, \\`r'e; \\`s'ign; \\`[', \\`]' (incr/decr)" + "\\`g'amma, \\`b'eta, \\`e'rf, bessel\\`j', bessel\\`y'" + "int-s\\`Q'rt; \\`I'nt-log, \\`E'xp(x)-1, \\`L'n(x+1); arc\\`T'an2" + "\\`A'bssqr; \\`M'antissa, e\\`X'ponent, \\`S'cale" "SHIFT + incomplete: Gamma-P, Beta-I") "functions" ?f)) @@ -516,165 +522,165 @@ (defun calc-s-prefix-help () (interactive) (calc-do-prefix-help - '("Store, inTo, Xchg, Unstore; Recall, 0-9; : (:=); = (=>)" - "Let; Copy, K=copy constant; Declare; Insert, Perm; Edit" - "Negate, +, -, *, /, ^, &, |, [, ]; Map" - "SHIFT + Decls, GenCount, TimeZone, Holidays; IntegLimit" - "SHIFT + LineStyles, PointStyles, plotRejects; Units" - "SHIFT + Eval-, AlgSimp-, ExtSimp-, FitRules") + '("\\`s'tore, in\\`t'o, \\`x'chg, \\`u'nstore; \\`r'ecall, \\`0'-\\`9'; \\`:' (:=); \\`=' (=>)" + "\\`l'et; \\`c'opy, \\`k'=copy constant; \\`d'eclare; \\`i'nsert, \\`p'erm; \\`e'dit" + "\\`n'egate, \\`+', \\`-', \\`*', \\`/', \\`^', \\`&', \\`|', \\`[', \\`]'; Map" + "\\`D'ecls, \\`G'enCount, \\`T'imeZone, \\`H'olidays; \\`I'ntegLimit" + "\\`L'ineStyles, \\`P'ointStyles, plot\\`R'ejects; \\`U'nits" + "\\`E'val-, \\`A'lgSimp-, e\\`X'tSimp-, \\`F'itRules") "store" ?s)) (defun calc-r-prefix-help () (interactive) (calc-do-prefix-help - '("digits 0-9: recall, same as `s r 0-9'" - "Save to register, Insert from register") + '("digits \\`0'-\\`9': recall, same as \\`s r' \\`0'-\\`9'" + "\\`s'ave to register, \\`i'nsert from register") "recall/register" ?r)) (defun calc-j-prefix-help () (interactive) (calc-do-prefix-help - '("Select, Additional, Once; eVal, Formula; Rewrite" - "More, Less, 1-9, Next, Previous" - "Unselect, Clear; Display; Enable; Breakable" - "\\=' (replace), \\=` (edit), +, -, *, /, RET (grab), DEL" - "SHIFT + swap: Left, Right; maybe: Select, Once" - "SHIFT + Commute, Merge, Distrib, jump-Eqn, Isolate" - "SHIFT + Negate, & (invert); Unpack") + '("\\`s'elect, \\`a'dditional, \\`o'nce; e\\`v'al, \\`f'ormula; \\`r'ewrite" + "\\`m'ore, \\`l'ess, \\`1'-\\`9', \\`n'ext, \\`p'revious" + "\\`u'nselect, \\`c'lear; \\`d'isplay; \\`e'nable; \\`b'reakable" + "\\=' (replace), \\=` (edit), \\`+', \\`-', \\`*', \\`/', \\`RET' (grab), \\`DEL'" + "swap: \\`L'eft, \\`R'ight; maybe: \\`S'elect, \\`O'nce" + "\\`C'ommute, \\`M'erge, \\`D'istrib, jump-\\`E'qn, \\`I'solate" + "\\`N'egate, \\`&' (invert); \\`U'npack") "select" ?j)) (defun calc-a-prefix-help () (interactive) (calc-do-prefix-help - '("Simplify, Extended-simplify, eVal; \" (exp-formula)" - "eXpand, Collect, Factor, Apart, Norm-rat" - "GCD, /, \\, % (polys); Polint" - "Derivative, Integral, Taylor; _ (subscr)" - "suBstitute; Rewrite, Match" - "SHIFT + Solve; Root, miN, maX; Poly-roots; Fit" - "SHIFT + Map; Tabulate, + (sum), * (prod); num-Integ" - "relations: =, # (not =), <, >, [ (< or =), ] (> or =)" - "logical: & (and), | (or), ! (not); : (if)" - "misc: { (in-set); . (rmeq)") + '("\\`s'implify, \\`e'xtended-simplify, e\\`v'al; \\`\"' (exp-formula)" + "e\\`x'pand, \\`c'ollect, \\`f'actor, \\`a'part, \\`n'orm-rat" + "\\`g' (GCD), \\`/', \\`\\', \\`%' (polys); \\`p'olint" + "\\`d'erivative, \\`i'ntegral, \\`t'aylor; \\`_' (subscr)" + "su\\`b'stitute; \\`r'ewrite, \\`m'atch" + "\\`S'olve; \\`R'oot, mi\\`N', ma\\`X'; \\`P'oly-roots; \\`F'it" + "\\`M'ap; \\`T'abulate, \\`+' (sum), \\`*' (prod); num-\\`I'nteg" + "relations: \\`=', \\`#' (not =), \\`<', \\`>', \\`[' (< or =), \\`]' (> or =)" + "logical: \\`&' (and), \\`|' (or), \\`!' (not); \\`:' (if)" + "misc: \\`{' (in-set); \\`.' (rmeq)") "algebra" ?a)) (defun calc-b-prefix-help () (interactive) (calc-do-prefix-help - '("And, Or, Xor, Diff, Not; Wordsize, Clip" - "Lshift, Rshift, roTate; SHIFT + signed Lshift, Rshift" - "SHIFT + business: Pv, Npv, Fv, pMt, #pmts, raTe, Irr" - "SHIFT + business: Sln, sYd, Ddb; %ch") + '("\\`a'nd, \\`o'r, \\`x'or, \\`d'iff, \\`n'ot; \\`w'ordsize, \\`c'lip" + "\\`l'shift, \\`r'shift, ro\\`t'ate; signed \\`L'shift, \\`R'shift" + "business: \\`P'v, \\`N'pv, \\`F'v, p\\`M't, \\`#'pmts, ra\\`T'e, \\`I'rr" + "business: \\`S'ln, s\\`Y'd, \\`D'db; \\`%'ch") "binary/bus" ?b)) (defun calc-c-prefix-help () (interactive) (calc-do-prefix-help - '("Deg, Rad, HMS; Float; Polar/rect; Clean, 0-9; %" - "SHIFT + Fraction") + '("\\`d'eg, \\`r'ad, \\`h'ms; \\`f'loat; \\`p'olar/rect; \\`c'lean, \\`0'-\\`9'; \\`%'" + "\\`F'raction") "convert" ?c)) (defun calc-d-prefix-help () (interactive) (calc-do-prefix-help - '("Group, \",\"; Normal, Fix, Sci, Eng, \".\"; Over" - "Radix, Zeros, 2, 8, 0, 6; Hms; Date; Complex, I, J" - "Why; Line-nums, line-Breaks; <, =, > (justify); Plain" - "\" (strings); Truncate, [, ]; SPC (refresh), RET, @" - "SHIFT + language: Normal, One-line, Big, Unformatted" - "SHIFT + language: C, Pascal, Fortran; TeX, LaTeX, Eqn" - "SHIFT + language: Yacas, X=Maxima, A=Giac" - "SHIFT + language: Mathematica, W=Maple") + '("\\`g'roup, \\`,'; \\`n'ormal, \\`f'ix, \\`s'ci, \\`e'ng, \\`.'; \\`o'ver" + "\\`r'adix, \\`z'eros, \\`2', \\`8', \\`0', \\`6'; \\`h'ms; \\`d'ate; \\`c'omplex, \\`i', \\`j'" + "\\`w'hy; \\`l'ine-nums, line-\\`b'reaks; \\`<', \\`=', \\`>' (justify); \\`p'lain" + "\\`\"' (strings); \\`t'runcate, \\`[', \\`]'; \\`SPC' (refresh), \\`RET', \\`@'" + "language: \\`N'ormal, \\`O'ne-line, \\`B'ig, \\`U'nformatted" + "language: \\`C', \\`P'ascal, \\`F'ortran; \\`T'eX, \\`L'aTeX, \\`E'qn" + "language: \\`Y'acas, \\`X'=Maxima, \\`A'=Giac" + "language: \\`M'athematica, \\`W'=Maple") "display" ?d)) (defun calc-g-prefix-help () (interactive) (calc-do-prefix-help - '("Fast; Add, Delete, Juggle; Plot, Clear; Quit" - "Header, Name, Grid, Border, Key; View-commands, X-display" - "x-axis: Range, Title, Log, Zero; lineStyle" - "SHIFT + y-axis: Range, Title, Log, Zero; pointStyle" - "SHIFT + Print; Device, Output-file; X-geometry" - "SHIFT + Num-pts; Command, Kill, View-trail" - "SHIFT + 3d: Fast, Add; CTRL + z-axis: Range, Title, Log") + '("\\`f'ast; \\`a'dd, \\`d'elete, \\`j'uggle; \\`p'lot, \\`c'lear; \\`q'uit" + "\\`h'eader, \\`n'ame, \\`g'rid, \\`b'order, \\`k'ey; \\`v'iew-commands, \\`x'-display" + "x-axis: \\`r'ange, \\`t'itle, \\`l'og, \\`z'ero; line\\`s'tyle" + "y-axis: \\`R'ange, \\`T'itle, \\`L'og, \\`Z'ero; point\\`S'tyle" + "\\`P'rint; \\`D'evice, \\`O'utput-file; \\`X'-geometry" + "\\`N'um-pts; \\`C'ommand, \\`K'ill, \\`V'iew-trail" + "3d: \\`F'ast, \\`A'dd; z-axis: \\`C-r' (range), \\`C-t' (title), \\`C-l' (log)") "graph" ?g)) (defun calc-k-prefix-help () (interactive) (calc-do-prefix-help - '("GCD, LCM; Choose (binomial), Double-factorial" - "Random, random-Again, sHuffle" - "Factors, Prime-test, Next-prime, Totient, Moebius" - "Bernoulli, Euler, Stirling" - "SHIFT + Extended-gcd" - "SHIFT + dists: Binomial, Chi-square, F, Normal" - "SHIFT + dists: Poisson, student's-T") + '("\\`g' (GCD), \\`l' (LCM); \\`c'hoose (binomial), \\`d'ouble-factorial" + "\\`r'andom, random-\\`a'gain, s\\`h'uffle" + "\\`f'actors, \\`p'rime-test, \\`n'ext-prime, \\`t'otient, \\`m'oebius" + "\\`b'ernoulli, \\`e'uler, \\`s'tirling" + "\\`E'xtended-gcd" + "dists: \\`B'inomial, \\`C'hi-square, \\`F', \\`N'ormal" + "dists: \\`P'oisson, student\\='s-\\`T'") "combinatorics" ?k)) (defun calc-m-prefix-help () (interactive) (calc-do-prefix-help - '("Deg, Rad, HMS; Frac; Polar; Inf; Alg, Total; Symb; Vec/mat" - "Working; Xtensions; Mode-save; preserve Embedded modes" - "SHIFT + Shifted-prefixes, mode-Filename; Record; reCompute" - "SHIFT + simplify: Off, Num, basIc, Algebraic, Bin, Ext, Units") + '("\\`d'eg, \\`r'ad, \\`h' (HMS); \\`f'rac; \\`p'olar; \\`i'nf; \\`a'lg, \\`t'otal; \\`s'ymb; \\`v'ec/mat" + "\\`w'orking; \\`x'tensions; \\`m'ode-save; preserve \\`e'mbedded modes" + "\\`S'hifted-prefixes, mode-\\`F'ilename; \\`R'ecord; re\\`C'ompute" + "simplify: \\`O'ff, \\`N'um, bas\\`I'c, \\`A'lgebraic, \\`B'in, \\`E'xt, \\`U'nits") "mode" ?m)) (defun calc-t-prefix-help () (interactive) (calc-do-prefix-help - '("Display; Fwd, Back; Next, Prev, Here, [, ]; Yank" - "Search, Rev; In, Out; <, >; Kill; Marker; . (abbrev)" - "SHIFT + time: Now; Part; Date, Julian, Unix, Czone" - "SHIFT + time: newWeek, newMonth, newYear; Incmonth" - "SHIFT + time: +, - (business days)" - "digits 0-9: store-to, same as `s t 0-9'") + '("\\`d'isplay; \\`f'wd, \\`b'ack; \\`n'ext, \\`p'rev, \\`h'ere, \\`[', \\`]'; \\`y'ank" + "\\`s'earch, \\`r'ev; \\`i'n, \\`o'ut; \\`<', \\`>'; \\`k'ill; \\`m'arker; \\`.' (abbrev)" + "time: \\`N'ow; \\`P'art; \\`D'ate, \\`J'ulian, \\`U'nix, \\`C'zone" + "time: new\\`W'eek, new\\`M'onth, new\\`Y'ear; \\`I'ncmonth" + "time: \\`+', \\`-' (business days)" + "digits \\`0'-\\`9': store-to, same as \\`s t' \\`0'-\\`9'") "trail/time" ?t)) (defun calc-u-prefix-help () (interactive) (calc-do-prefix-help - '("Simplify, Convert, coNvert exact, Temperature-convert, Base-units" - "Autorange; Remove, eXtract; Explain; View-table; 0-9" - "Define, Undefine, Get-defn, Permanent" - "SHIFT + View-table-other-window" - "SHIFT + stat: Mean, G-mean, Std-dev, Covar, maX, miN" - "SHIFT + stat: + (sum), - (asum), * (prod), # (count)") + '("\\`s'implify, \\`c'onvert, co\\`n'vert exact, \\`t'emperature-convert, \\`b'ase-units" + "\\`a'utorange; \\`r'emove, e\\`x'tract; \\`e'xplain; \\`v'iew-table; \\`0'-\\`9'" + "\\`d'efine, \\`u'ndefine, \\`g'et-defn, \\`p'ermanent" + "\\`V'iew-table-other-window" + "stat: \\`M'ean, \\`G'-mean, \\`S'td-dev, \\`C'ovar, ma\\`X', mi\\`N'" + "stat: \\`+' (sum), \\`-' (asum), \\`*' (prod), \\`#' (count)") "units/stat" ?u)) (defun calc-l-prefix-help () (interactive) (calc-do-prefix-help - '("Quantity, DB level, Np level" - "+, -, *, /" - "Scientific pitch notation, Midi number, Frequency" + '("\\`q'uantity, \\`d' (DB level), \\`n' (NP level)" + "\\`+', \\`-', \\`*', \\`/'" + "\\`s'cientific pitch notation, \\`m'idi number, \\`f'requency" ) "log units" ?l)) (defun calc-v-prefix-help () (interactive) (calc-do-prefix-help - '("Pack, Unpack, Identity, Diagonal, indeX, Build" - "Row, Column, Subvector; Length; Find; Mask, Expand" - "Transpose, Arrange, reVerse; Head, Kons; rNorm" - "SHIFT + Det, & (inverse), LUD, Trace, conJtrn, Cross" - "SHIFT + Sort, Grade, Histogram; cNorm" - "SHIFT + Apply, Map, Reduce, accUm, Inner-, Outer-prod" - "SHIFT + sets: V (union), ^ (intersection), - (diff)" - "SHIFT + sets: Xor, ~ (complement), Floor, Enum" - "SHIFT + sets: : (span), # (card), + (rdup)" - "<, =, > (justification); , (commas); [, {, ( (brackets)" - "} (matrix brackets); . (abbreviate); / (multi-lines)") + '("\\`p'ack, \\`u'npack, \\`i'dentity, \\`d'iagonal, inde\\`x', \\`b'uild" + "\\`r'ow, \\`c'olumn, \\`s'ubvector; \\`l'ength; \\`f'ind; \\`m'ask, \\`e'xpand" + "\\`t'ranspose, \\`a'rrange, re\\`v'erse; \\`h'ead, \\`k'ons; r\\`n'orm" + "\\`D'et, \\`&' (inverse), \\`L'UD, \\`T'race, con\\`J'trn, \\`C'ross" + "\\`S'ort, \\`G'rade, \\`H'istogram; c\\`N'orm" + "\\`A'pply, \\`M'ap, \\`R'educe, acc\\`U'm, \\`I'nner-, \\`O'uter-prod" + "sets: \\`V' (union), \\`^' (intersection), \\`-' (diff)" + "sets: \\`X'or, \\`~' (complement), \\`F'loor, \\`E'num" + "sets: \\`:' (span), \\`#' (card), \\`+' (rdup)" + "\\`<', \\`=', \\`>' (justification); \\`,' (commas); \\`[', \\`{', \\`(' (brackets)" + "\\`}' (matrix brackets); \\`.' (abbreviate); \\`/' (multi-lines)") "vec/mat" ?v)) (provide 'calc-help) diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index 613fb0a0154..93de04a586d 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -114,8 +114,11 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C (let (key) (select-window win) (while (progn - (message "Calc options: Calc, Keypad, ... %s" - "press SPC, DEL to scroll, C-g to cancel") + (message + (substitute-command-keys + (concat + "Calc options: \\`c'alc, \\`k'eypad, ... " + "press \\`SPC', \\`DEL' to scroll, \\`C-g' to cancel"))) (memq (setq key (read-event)) '(? ?\C-h ?\C-? ?\C-v ?\M-v))) (condition-case nil @@ -216,27 +219,26 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C (defun calc-help () (interactive) (let ((msgs - ;; FIXME: Change these to `substitute-command-keys' syntax. (mapcar #'substitute-command-keys '("Press \\`h' for complete help; press \\`?' repeatedly for a summary" - "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" - "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" - "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" - "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" - "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" - "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" - "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" - "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" - "Other keys: \\`SPC'/\\`RET' (enter/dup), LFD (over); < > (scroll horiz)" - "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); { } (scroll vert)" + "Letter keys: \\`n'egate; \\`p'recision; \\`y'ank; \\`w'hy; \\`x'tended cmd; \\`q'uit" + "Letter keys: \\`U'ndo, re\\`D'o; \\`I'nverse, \\`H'yperbolic, \\`O'ption" + "Letter keys: s\\`Q'rt; \\`S'in, \\`C'os, \\`T'an; \\`E'xp, \\`L'n, log\\`B'" + "Letter keys: \\`F'loor, \\`R'ound; \\`A'bs, con\\`J', ar\\`G'; \\`P'i" + "Letter keys: \\`N'um-eval; \\`M'ore-recn; e\\`X'ec-kbd-macro; \\`K'eep-args" + "Other keys: \\`+', \\`-', \\`*', \\`/', \\`^', \\`\\' (int div), \\`:' (frac div)" + "Other keys: \\`&' (1/x), \\`|' (concat), \\`%' (modulo), \\`!' (factorial)" + "Other keys: \\=' (alg-entry), \\`=' (eval), \\=` (edit); \\`M-RET' (last-args)" + "Other keys: \\`SPC'/\\`RET' (enter/dup), \\`LFD' (over); \\`<' \\`>' (scroll horiz)" + "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); \\`{' \\`}' (scroll vert)" "Other keys: \\`TAB' (swap/roll-dn), \\`M-TAB' (roll-up)" - "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" - "Prefix keys: Algebra, Binary/business, Convert, Display" - "Prefix keys: Functions, Graphics, Help, J (select)" - "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" - "Prefix keys: Trail/time, Units/statistics, Vector/matrix" - "Prefix keys: Z (user), SHIFT + Z (define)" - "Prefix keys: prefix + ? gives further help for that prefix" + "Other keys: \\`[' \\`,' \\`;' \\`]' (vector), \\`(' \\`,' \\`)' (complex), \\`(' \\`;' \\`)' (polar)" + "Prefix keys: \\`a'lgebra, \\`b'inary/business, \\`c'onvert, \\`d'isplay" + "Prefix keys: \\`f'unctions, \\`g'raphics, \\`h'elp, \\`j' (select)" + "Prefix keys: \\`k'ombinatorics/statistics, \\`m'odes, \\`s'tore/recall" + "Prefix keys: \\`t'rail/time, \\`u'nits/statistics, \\`v'ector/matrix" + "Prefix keys: \\`z' (user), \\`Z' (define)" + "Prefix keys: prefix + \\`?' gives further help for that prefix" " Calc by Dave Gillespie, daveg@synaptics.com")))) (if calc-full-help-flag msgs @@ -260,7 +262,7 @@ Calc user interface as before (either \\`C-x * C' or \\`C-x * K'; initially \\`C msgs)) (length msg)) ?\ ) - " [?=MORE]") + (substitute-command-keys " [\\`?'=MORE]")) "")))))))) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 5e21d506d74..988fef2fcd2 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -319,28 +319,28 @@ that the combined units table will be rebuilt.") (defvar math-unit-prefixes '( ( ?Q (^ 10 30) "quetta" ) ( ?R (^ 10 27) "ronna" ) - ( ?Y (^ 10 24) "Yotta" ) - ( ?Z (^ 10 21) "Zetta" ) - ( ?E (^ 10 18) "Exa" ) - ( ?P (^ 10 15) "Peta" ) - ( ?T (^ 10 12) "Tera" ) - ( ?G (^ 10 9) "Giga" ) - ( ?M (^ 10 6) "Mega" ) - ( ?k (^ 10 3) "Kilo" ) - ( ?K (^ 10 3) "Kilo" ) - ( ?h (^ 10 2) "Hecto" ) - ( ?H (^ 10 2) "Hecto" ) - ( ?D (^ 10 1) "Deka" ) + ( ?Y (^ 10 24) "yotta" ) + ( ?Z (^ 10 21) "zetta" ) + ( ?E (^ 10 18) "exa" ) + ( ?P (^ 10 15) "peta" ) + ( ?T (^ 10 12) "tera" ) + ( ?G (^ 10 9) "giga" ) + ( ?M (^ 10 6) "mega" ) + ( ?k (^ 10 3) "kilo" ) + ( ?K (^ 10 3) "kilo" ) + ( ?h (^ 10 2) "hecto" ) + ( ?H (^ 10 2) "hecto" ) + ( ?D (^ 10 1) "deka" ) ( 0 (^ 10 0) nil ) - ( ?d (^ 10 -1) "Deci" ) - ( ?c (^ 10 -2) "Centi" ) - ( ?m (^ 10 -3) "Milli" ) - ( ?u (^ 10 -6) "Micro" ) - ( ?μ (^ 10 -6) "Micro" ) - ( ?n (^ 10 -9) "Nano" ) - ( ?p (^ 10 -12) "Pico" ) - ( ?f (^ 10 -15) "Femto" ) - ( ?a (^ 10 -18) "Atto" ) + ( ?d (^ 10 -1) "deci" ) + ( ?c (^ 10 -2) "centi" ) + ( ?m (^ 10 -3) "milli" ) + ( ?u (^ 10 -6) "micro" ) + ( ?μ (^ 10 -6) "micro" ) + ( ?n (^ 10 -9) "nano" ) + ( ?p (^ 10 -12) "pico" ) + ( ?f (^ 10 -15) "femto" ) + ( ?a (^ 10 -18) "atto" ) ( ?z (^ 10 -21) "zepto" ) ( ?y (^ 10 -24) "yocto" ) ( ?r (^ 10 -27) "ronto" ) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index f129552c9a4..a1545edba19 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -1188,8 +1188,12 @@ Used by `calc-user-invocation'.") "Start the Calculator." (let ((key (calc-read-key-sequence (if calc-dispatch-help - "Calc options: Calc, Keypad, Quick, Embed; eXit; Info, Tutorial; Grab; ?=more" - (format "%s (Type ? for a list of Calc options)" + (substitute-command-keys + (concat + "Calc options: \\`c'alc, \\`k'eypad, \\`q'uick, \\`e'mbed; " + "e\\`x'it; \\`i'nfo, \\`t'utorial; \\`g'rab; \\`?'=more")) + (format (substitute-command-keys + "%s (Type \\`?' for a list of Calc options)") (key-description (this-command-keys)))) calc-dispatch-map))) (setq key (lookup-key calc-dispatch-map key)) @@ -2478,7 +2482,8 @@ the United States." (interactive) (cond ((eq last-command 'calcDigit-start) (erase-buffer)) - (t (backward-delete-char 1))) + (t (with-suppressed-warnings ((interactive-only backward-delete-char)) + (backward-delete-char 1)))) (if (= (calc-minibuffer-size) 0) (progn (setq last-command-event 13) diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index a209623b65e..49597739446 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -409,7 +409,7 @@ displayed in a window: 'face 'mode-line-emphasis) " "))) ;; Reset count to 0 in case we display another appt on the next cycle. - (setq appt-display-count (if (eq '(0) min-list) 0 + (setq appt-display-count (if (equal '(0) min-list) 0 (1+ prev-appt-display-count)))) ;; If we have changed the mode line string, redisplay all mode lines. (and appt-display-mode-line diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 75c29a38352..a96fb0adf7c 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -354,10 +354,10 @@ If the locale never uses daylight saving time, set this to 0." (if calendar-current-time-zone-cache (format-time-string "%z" 0 (* 60 (car calendar-current-time-zone-cache))) - "+0000") - (or (nth 2 calendar-current-time-zone-cache) "EST")) + "-0000") + (or (nth 2 calendar-current-time-zone-cache) "UTC")) "Abbreviated name of standard time zone at `calendar-location-name'. -For example, \"EST\" in New York City, \"PST\" for Los Angeles." +For example, \"-0500\" or \"EST\" in New York City." :type 'string :version "28.1" :set-after '(calendar-time-zone-style) @@ -368,10 +368,10 @@ For example, \"EST\" in New York City, \"PST\" for Los Angeles." (if calendar-current-time-zone-cache (format-time-string "%z" 0 (* 60 (cadr calendar-current-time-zone-cache))) - "+0000") - (or (nth 3 calendar-current-time-zone-cache) "EDT")) + "-0000") + (or (nth 3 calendar-current-time-zone-cache) "UTC")) "Abbreviated name of daylight saving time zone at `calendar-location-name'. -For example, \"EDT\" in New York City, \"PDT\" for Los Angeles." +For example, \"-0400\" or \"EDT\" in New York City." :type 'string :version "28.1" :set-after '(calendar-time-zone-style) diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 44fb5eb5a86..946cf0e7236 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -339,7 +339,7 @@ Returns a string using match elements 1-5, where: (t "\\1 \\2 \\3"))) ; MDY "\n \\4 %s, \\5"))) ;; TODO Sometimes the time is in a different time-zone to the one you -;; are in. Eg in PST, you might still get an email referring to: +;; are in. E.g., in Los Angeles, you might still get an email referring to: ;; "7:00 PM-8:00 PM. Greenwich Standard Time". ;; Note that it doesn't use a standard abbreviation for the timezone, ;; or anything helpful like that. diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index cd3de62afdb..d7d064d9c2a 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -129,7 +129,7 @@ well as variants like \"2008W32\" (week number) and See `decode-time' for the meaning of FORM." (if (not (iso8601-valid-p string)) - (signal 'wrong-type-argument string) + (signal 'wrong-type-argument (list string)) (let* ((date-string (match-string 1 string)) (time-string (match-string 2 string)) (zone-string (match-string 3 string)) @@ -217,7 +217,7 @@ See `decode-time' for the meaning of FORM." ((iso8601--match "---\\([0-9][0-9]\\)" string) (iso8601--decoded-time :day (string-to-number (match-string 1 string)))) (t - (signal 'wrong-type-argument string)))) + (signal 'wrong-type-argument (list string))))) (defun iso8601-parse-time (string &optional form) "Parse STRING, which should be an ISO 8601 time string. @@ -226,11 +226,11 @@ hour/minute/seconds/zone fields filled in. See `decode-time' for the meaning of FORM." (if (not (iso8601--match iso8601--full-time-match string)) - (signal 'wrong-type-argument string) + (signal 'wrong-type-argument (list string)) (let ((time (match-string 1 string)) (zone (match-string 2 string))) (if (not (iso8601--match iso8601--time-match time)) - (signal 'wrong-type-argument string) + (signal 'wrong-type-argument (list string)) (let ((hour (string-to-number (match-string 1 time))) (minute (and (match-string 2 time) (string-to-number (match-string 2 time)))) @@ -274,7 +274,7 @@ See `decode-time' for the meaning of FORM." "Parse STRING, which should be an ISO 8601 time zone. Return the number of minutes." (if (not (iso8601--match iso8601--zone-match string)) - (signal 'wrong-type-argument string) + (signal 'wrong-type-argument (list string)) (if (match-string 2 string) ;; HH:MM-ish. (let ((hour (string-to-number (match-string 3 string))) @@ -314,14 +314,14 @@ Return the number of minutes." ((iso8601--match iso8601--duration-combined-match string) (iso8601-parse (substring string 1))) (t - (signal 'wrong-type-argument string)))) + (signal 'wrong-type-argument (list string))))) (defun iso8601-parse-interval (string) "Parse ISO 8601 intervals." (let ((bits (split-string string "/")) start end duration) (if (not (= (length bits) 2)) - (signal 'wrong-type-argument string) + (signal 'wrong-type-argument (list string)) ;; The intervals may be an explicit start/end times, or either a ;; start or an end, and an accompanying duration. (cond @@ -338,7 +338,7 @@ Return the number of minutes." (setq start (iso8601-parse (car bits)) end (iso8601-parse (cadr bits)))) (t - (signal 'wrong-type-argument string)))) + (signal 'wrong-type-argument (list string))))) (unless end (setq end (decoded-time-add start duration))) (unless start diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el index 8ced4144105..5b22043102d 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -94,7 +94,7 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, (* -0.0016528 time time) (* -0.00000239 time time time)) 360.0)) - (eclipse (eclipse-check moon-lat phase)) + (eclipse (lunar-check-for-eclipse moon-lat phase)) (adjustment (if (memq phase '(0 2)) (+ (* (- 0.1734 (* 0.000393 time)) @@ -154,26 +154,22 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, ;; from "Astronomy with your Personal Computer", Subroutine Eclipse ;; Line 7000 Peter Duffett-Smith Cambridge University Press 1990 -(defun eclipse-check (moon-lat phase) - (let* ((moon-lat (* (/ float-pi 180) moon-lat)) - ;; For positions near the ascending or descending node, - ;; calculate the absolute angular distance from that node. - (moon-lat (abs (- moon-lat (* (floor (/ moon-lat float-pi)) - float-pi)))) - (moon-lat (if (> moon-lat 0.37) ; FIXME (* 0.5 float-pi) - (- float-pi moon-lat) - moon-lat)) - (phase-name (cond ((= phase 0) "Solar") - ((= phase 2) "Lunar") - (t "")))) - (cond ((string= phase-name "") - "") - ((< moon-lat 2.42600766e-1) - (concat "** " phase-name " Eclipse **")) - ((< moon-lat 0.37) - (concat "** " phase-name " Eclipse possible **")) - (t - "")))) +(defun lunar-check-for-eclipse (moon-lat phase) + "Check if a solar or lunar eclipse can occur for MOON-LAT and PHASE. +MOON-LAT is the argument of latitude. PHASE is the lunar phase: +0 new moon, 1 first quarter, 2 full moon, 3 last quarter. +Return a string describing the eclipse (empty if no eclipse)." + (let* ((node-dist (mod moon-lat 180)) + ;; Absolute angular distance from the ascending or descending + ;; node, whichever is nearer. + (node-dist (min node-dist (- 180 node-dist))) + (type (cond ((= phase 0) "Solar") + ((= phase 2) "Lunar")))) + (cond ((not type) "") + ;; Limits 13.9° and 21.0° from Meeus (1991), page 350. + ((< node-dist 13.9) (concat "** " type " Eclipse **")) + ((< node-dist 21.0) (concat "** " type " Eclipse possible **")) + (t "")))) (defconst lunar-cycles-per-year 12.3685 ; 365.25/29.530588853 "Mean number of lunar cycles per 365.25 day year.") @@ -249,10 +245,11 @@ use instead of point." (insert (mapconcat (lambda (x) - (format "%s: %s %s %s" (calendar-date-string (car x)) - (lunar-phase-name (nth 2 x)) - (cadr x) - (car (last x)))) + (let ((eclipse (nth 3 x))) + (concat (calendar-date-string (car x)) ": " + (lunar-phase-name (nth 2 x)) " " + (cadr x) (unless (string-empty-p eclipse) " ") + eclipse))) (lunar-phase-list m1 y1) "\n"))) (message "Computing phases of the moon...done")))) @@ -287,9 +284,13 @@ use when highlighting the day in the calendar." (while (calendar-date-compare phase (list date)) (setq index (1+ index) phase (lunar-phase index))) - (if (calendar-date-equal (car phase) date) - (cons mark (concat (lunar-phase-name (nth 2 phase)) " " - (cadr phase)))))) + (and (calendar-date-equal (car phase) date) + (cons mark + (let ((eclipse (nth 3 phase))) + (concat (lunar-phase-name (nth 2 phase)) " " + (cadr phase) + (unless (string-empty-p eclipse) " ") + eclipse)))))) ;; For the Chinese calendar the calculations for the new moon need to be more ;; accurate than those above, so we use more terms in the approximation. diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index 582a2b91ff6..d82215a6d35 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -839,12 +839,10 @@ This function is suitable for execution in an init file." "E" "W")))))) (calendar-standard-time-zone-name (if (< arg 16) calendar-standard-time-zone-name - (cond ((zerop calendar-time-zone) - (if (eq calendar-time-zone-style 'numeric) - "+0000" "UTC")) - ((< calendar-time-zone 0) - (format "UTC%dmin" calendar-time-zone)) - (t (format "UTC+%dmin" calendar-time-zone))))) + (if (and (zerop calendar-time-zone) + (not (eq calendar-time-zone-style 'numeric))) + "UTC" + (format-time-string "%z" 0 (* 60 calendar-time-zone))))) (calendar-daylight-savings-starts (if (< arg 16) calendar-daylight-savings-starts)) (calendar-daylight-savings-ends 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/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 6f84b83ab75..84040b572bc 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1731,7 +1731,7 @@ Display mechanism using tooltip for a list of possible completions.") ;; Add any tail info. (setq msg (concat msg msg-tail)) ;; Display tooltip. - (when (not (eq msg "")) + (when (not (equal msg "")) (semantic-displayer-tooltip-show msg))))) ;;; Compatibility diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el index 156eac46659..c83de66ef0c 100644 --- a/lisp/cedet/semantic/decorate/include.el +++ b/lisp/cedet/semantic/decorate/include.el @@ -790,9 +790,7 @@ any decorated referring includes.") ;; This is a hack. Add in something better? (semanticdb-notify-references table (lambda (tab _me) - (semantic-decoration-unparsed-include-refrence-reset tab) - )) - )) + (semantic-decoration-unparsed-include-reference-reset tab))))) (cl-defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache) new-tags) @@ -805,7 +803,7 @@ any decorated referring includes.") "Synchronize a CACHE with some NEW-TAGS." (semantic-reset cache)) -(defun semantic-decoration-unparsed-include-refrence-reset (table) +(defun semantic-decoration-unparsed-include-reference-reset (table) "Refresh any highlighting in buffers referred to by TABLE. If TABLE is not in a buffer, do nothing." ;; This cache removal may seem odd in that we are "creating one", but @@ -835,6 +833,8 @@ If TABLE is not in a buffer, do nothing." (semantic-decorate-add-decorations allinc) )))) +(define-obsolete-function-alias 'semantic-decoration-unparsed-include-refrence-reset + #'semantic-decoration-unparsed-include-reference-reset "30.1") (provide 'semantic/decorate/include) diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index b932cb999ba..6a16845ecf2 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -1243,7 +1243,7 @@ Finds the header file belonging to NAME, gets the macros from that file, and then merge the macros with our current symbol table." (when semantic-lex-spp-use-headers-flag - ;; @todo - do this someday, ok? + nil ; @todo - do this someday, ok? )) (defmacro define-lex-spp-include-analyzer (name doc regexp tokidx diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index c2d2e5e1668..5fd1fd45400 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -1108,7 +1108,7 @@ This can be done by using `semantic-lex-push-token'." (semantic-lex-analysis-bounds (cons (point) (point-max))) (semantic-lex-current-depth 0) (semantic-lex-maximum-depth semantic-lex-depth)) - (when ,condition ,@forms) + (when ,condition nil ,@forms) ; `nil' avoids an empty-body warning. semantic-lex-token-stream)))) (defmacro define-lex-regex-analyzer (name doc regexp &rest forms) diff --git a/lisp/comint.el b/lisp/comint.el index 682b555a33c..9d2c245247f 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -383,7 +383,8 @@ This variable is buffer-local." "\\(?:" (regexp-opt password-word-equivalents) "\\|Response\\)" "\\(?:\\(?:, try\\)? *again\\| (empty for no passphrase)\\| (again)\\)?" ;; "[[:alpha:]]" used to be "for", which fails to match non-English. - "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[:：៖][[:space:]]*\\'" + "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*" + "[" (apply #'string password-colon-equivalents) "][[:space:]]*\\'" ;; The ccrypt encryption dialog doesn't end with a colon, so ;; treat it specially. "\\|^Enter encryption key: (repeat) *\\'" @@ -4119,9 +4120,15 @@ function called, or nil, if no function was called (if BEG = END)." (save-restriction (let ((beg2 beg1) (end2 end1)) - (when (= beg2 beg) + (when (and (= beg2 beg) + (> beg2 (point-min)) + (eq is-output + (eq (get-text-property (1- beg2) 'field) 'output))) (setq beg2 (field-beginning beg2))) - (when (= end2 end) + (when (and (= end2 end) + (< end2 (point-max)) + (eq is-output + (eq (get-text-property (1+ end2) 'field) 'output))) (setq end2 (field-end end2))) ;; Narrow to the whole field surrounding the region (narrow-to-region beg2 end2)) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 0373842de09..dbef5f47cd6 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -903,9 +903,9 @@ This also shows the saved values in the buffer." (defun custom-reset-standard-save-and-update () "Save settings and redraw after erasing customizations." (when (or (and custom-reset-standard-variables-list - (not (eq custom-reset-standard-variables-list '(t)))) + (not (equal custom-reset-standard-variables-list '(t)))) (and custom-reset-standard-faces-list - (not (eq custom-reset-standard-faces-list '(t))))) + (not (equal custom-reset-standard-faces-list '(t))))) ;; Save settings to file. (custom-save-all) ;; Set state of and redraw variables. @@ -1238,7 +1238,7 @@ Show the buffer in another window, but don't select it." (unless (eq symbol basevar) (message "`%s' is an alias for `%s'" symbol basevar)))) -(defvar customize-changed-options-previous-release "28.2" +(defvar customize-changed-options-previous-release "29.1" "Version for `customize-changed' to refer back to by default.") ;; Packages will update this variable, so make it available. diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 054683d7cf6..6ca7d7fcafd 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -310,6 +310,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (const :tag "Off" :value nil) (const :tag "On" :value t) (const :tag "Auto-raise" :value auto-raise)) "26.1") + (yes-or-no-prompt menu string "30.1") ;; fontset.c ;; FIXME nil is the initial value, fontset.el setqs it. (vertical-centering-font-regexp display diff --git a/lisp/custom.el b/lisp/custom.el index df6db181615..083349e3591 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -667,6 +667,7 @@ If NOSET is non-nil, don't bother autoloading LOAD when setting the variable." A customizable variable is either (i) a variable whose property list contains a non-nil `standard-value' or `custom-autoload' property, or (ii) an alias for another customizable variable." + (declare (side-effect-free t)) (when (symbolp variable) (setq variable (indirect-variable variable)) (or (get variable 'standard-value) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index aea6b3e15b7..4834c2eb7ba 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -366,7 +366,7 @@ This function is semi-obsolete. Use `get-char-code-property'." ;; description is added to the category name as a tooltip (defsubst describe-char-categories (category-set) (let ((mnemonics (category-set-mnemonics category-set))) - (unless (eq mnemonics "") + (unless (equal mnemonics "") (list (mapconcat (lambda (x) (let* ((c (category-docstring x)) diff --git a/lisp/desktop.el b/lisp/desktop.el index 3d78c4cb6f8..6aacb85c12c 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -828,7 +828,7 @@ is nil, ask the user where to save the desktop." ;; If we own it, we don't anymore. (when (eq (emacs-pid) (desktop-owner)) ;; Allow exiting Emacs even if we can't delete the desktop file. - (ignore-error 'file-error + (ignore-error file-error (desktop-release-lock)))) ;; ---------------------------------------------------------------------------- diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index fc3f6f4f04d..96ac9da4508 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -3730,7 +3730,7 @@ of the target of the link instead." (process-file "file" nil t t "-L" "--" file) (process-file "file" nil t t "--" file)) (when (bolp) - (backward-delete-char 1)) + (delete-char -1)) (message "%s" (buffer-string))))) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 560eefae024..5780f1353ad 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -816,7 +816,7 @@ otherwise." (defun dired-x--string-to-number (str) "Like `string-to-number' but recognize a trailing unit prefix. For example, 2K is expanded to 2048.0. The caller should make -sure that a trailing letter in STR is one of BKkMGTPEZY." +sure that a trailing letter in STR is one of BKkMGTPEZYRQ." (let* ((val (string-to-number str)) (u (unless (zerop val) (aref str (1- (length str)))))) @@ -831,7 +831,7 @@ sure that a trailing letter in STR is one of BKkMGTPEZY." (when (and u (> u ?9)) (when (= u ?k) (setq u ?K)) - (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y))) + (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y ?R ?Q))) (while (and units (/= (pop units) u)) (setq val (* 1024.0 val))))) val))) @@ -904,7 +904,7 @@ only in the active region if `dired-mark-region' is non-nil." ;; GNU ls -hs suffixes the block count with a unit and ;; prints it as a float, FreeBSD does neither. (dired-re-inode-size "\\=\\s *\\([0-9]+\\s +\\)?\ -\\(?:\\([0-9]+\\(?:\\.[0-9]*\\)?[BkKMGTPEZY]?\\)? ?\\)")) +\\(?:\\([0-9]+\\(?:\\.[0-9]*\\)?[BkKMGTPEZYRQ]?\\)? ?\\)")) (beginning-of-line) (forward-char 2) (search-forward-regexp dired-re-inode-size nil t) diff --git a/lisp/dired.el b/lisp/dired.el index 4a4ecc901c4..d1471e993a1 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -490,6 +490,11 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used." (string :tag "Switches")) :version "29.1") +(defcustom dired-hide-details-preserved-columns nil + "List of columns which are not hidden in `dired-hide-details-mode'." + :type '(repeat integer) + :version "30.1") + ;;; Internal variables @@ -530,7 +535,7 @@ The directory name must be absolute, but need not be fully expanded.") (put 'dired-actual-switches 'safe-local-variable 'dired-safe-switches-p) -(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZY]?[ \t]*" +(defvar dired-re-inode-size "[0-9 \t]*[.,0-9]*[BkKMGTPEZYRQ]?[ \t]*" "Regexp for optional initial inode and file size as made by `ls -i -s'.") ;; These regexps must be tested at beginning-of-line, but are also @@ -922,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) @@ -1880,8 +1885,15 @@ other marked file as well. Otherwise, unmark all files." (put-text-property (line-beginning-position) (1+ (line-end-position)) 'invisible 'dired-hide-details-information)) - (put-text-property (+ (line-beginning-position) 1) (1- (point)) - 'invisible 'dired-hide-details-detail) + (save-excursion + (let ((end (1- (point))) + (opoint (goto-char (1+ (pos-bol)))) + (i 0)) + (put-text-property opoint end 'invisible 'dired-hide-details-detail) + (while (re-search-forward "[^ ]+" end t) + (when (member (cl-incf i) dired-hide-details-preserved-columns) + (put-text-property opoint (point) 'invisible nil)) + (setq opoint (point))))) (when (and dired-mouse-drag-files (fboundp 'x-begin-drag)) (put-text-property (point) (save-excursion diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 427da557d23..b14655fb274 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -209,10 +209,10 @@ are available (see Info node `(emacs)Document View')." function) :version "24.4") -(defcustom doc-view-mupdf-use-svg nil - "Whether to use SVG images for PDF files." +(defcustom doc-view-mupdf-use-svg (image-type-available-p 'svg) + "Whether to use svg images for PDF files." :type 'boolean - :version "29.1") + :version "30.1") (defcustom doc-view-imenu-enabled (and (executable-find "mutool") t) "Whether to generate an imenu outline when \"mutool\" is available." @@ -236,17 +236,14 @@ showing only titles and no page number." :type 'boolean :version "29.1") -(defcustom doc-view-svg-background "white" - "Background color for svg images. +(defface doc-view-svg-face '((t :inherit default)) + "Face used for SVG images. Only background and foreground colors +are used. See `doc-view-mupdf-use-svg'." - :type 'color - :version "29.1") + :version "30.1") -(defcustom doc-view-svg-foreground "black" - "Foreground color for svg images. -See `doc-view-mupdf-use-svg'." - :type 'color - :version "29.1") +(make-obsolete 'doc-view-svg-background 'doc-view-svg-face "30.1") +(make-obsolete 'doc-view-svg-foreground 'doc-view-svg-face "30.1") (defcustom doc-view-ghostscript-options '("-dSAFER" ;; Avoid security problems when rendering files from untrusted @@ -1602,8 +1599,8 @@ ARGS is a list of image descriptors." (unless (member :transform-smoothing args) (setq args `(,@args :transform-smoothing t))) (when (eq doc-view--image-type 'svg) - (setq args `(,@args :background ,doc-view-svg-background - :foreground ,doc-view-svg-foreground))) + (setq args `(,@args :background ,(face-background 'doc-view-svg-face) + :foreground ,(face-foreground 'doc-view-svg-face)))) (apply #'create-image file doc-view--image-type nil args)))) (slice (doc-view-current-slice)) (img-width (and image (car (image-size image)))) 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/elide-head.el b/lisp/elide-head.el index 11953299da9..f74c85fdfee 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -50,24 +50,41 @@ :group 'tools) (defcustom elide-head-headers-to-hide - `(;; GNU GPL - ("is free software[:;] you can redistribute it" . - ,(rx (or (seq "If not, see " (? "<") - "http" (? "s") "://www.gnu.org/licenses" - (? "/") (? ">") (? " ")) - (seq "Boston, MA " (? " ") - "0211" (or "1-1307" "0-1301") - (or " " ", ") "USA") - "675 Mass Ave, Cambridge, MA 02139, USA") - (? "."))) - ;; FreeBSD license / Modified BSD license (3-clause) - (,(rx (or "The Regents of the University of California. All rights reserved." - "Redistribution and use in source and binary")) - . "POSSIBILITY OF SUCH DAMAGE\\.") - ;; X11 and Expat - ("Permission is hereby granted, free of charge" . - ,(rx (or "authorization from the X Consortium." ; X11 - "THE USE OR OTHER DEALINGS IN THE SOFTWARE.")))) ; Expat + (rx-let ((delim + ;; A line break could be in a non-standard place, and the + ;; license could be in a comment. + (or + ;; Either just some spaces: + (+ " ") + ;; Or a newline and some comment starter: + (: (* (in " \t")) + "\n" + (* (in " \t")) + (* (or (syntax comment-start) (in ";#*-"))) + (* (in " \t")))))) + `(;; GNU GPL + ("is free software[:;] you can redistribute it" . + ,(rx (or (seq "If not, see " (? "<") + "http" (? "s") "://www.gnu.org/licenses" + (? "/") (? ">") (? " ")) + (seq "Boston," delim "MA" delim + (or "02111-1307" "02110-1301" "02111-1301") + (? ",") delim + "USA") + "675 Mass Ave, Cambridge, MA 02139, USA") + (? "."))) + ;; FreeBSD license / Modified BSD license (3-clause) + (,(rx (or "The Regents of the University of California. All rights reserved." + "Redistribution and use in source and binary")) + . "POSSIBILITY OF SUCH DAMAGE\\.") + ;; X11 and Expat + ("Permission is hereby granted, free of charge" . + ,(rx (or "authorization from the X Consortium." ; X11 + "THE USE OR OTHER DEALINGS IN THE SOFTWARE."))) ; Expat + ;; Apache + ("Licensed under the Apache License, Version 2.0" . + "limitations under the License.") + )) "Alist of regexps defining start and end of text to elide. The cars of elements of the list are searched for in order. Text is @@ -78,7 +95,7 @@ cdr. This affects `elide-head-mode'." :type '(alist :key-type (regexp :tag "Start regexp") :value-type (regexp :tag "End regexp")) - :version "29.1") + :version "30.1") (defvar-local elide-head-overlay nil) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 937300cf0c0..2bdd3375728 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -72,34 +72,40 @@ (require 'macroexp) (eval-when-compile (require 'subr-x)) +(defun bytecomp--log-lap-arg (arg) + ;; Convert an argument that may be a LAP operation to something printable. + (cond + ;; Symbols are just stripped of their -byte prefix if any. + ((symbolp arg) + (intern (string-remove-prefix "byte-" (symbol-name arg)))) + ;; Conses are assumed to be LAP ops or tags. + ((and (consp arg) (symbolp (car arg))) + (let* ((head (car arg)) + (tail (cdr arg)) + (op (intern (string-remove-prefix "byte-" (symbol-name head))))) + (cond + ((eq head 'TAG) + (format "%d:" (car tail))) + ((memq head byte-goto-ops) + (format "(%s %d)" op (cadr tail))) + ((memq head byte-constref-ops) + (format "(%s %s)" + (if (eq op 'constant) 'const op) + (if (numberp tail) + (format "<V%d>" tail) ; closure var reference + (format "%S" (car tail))))) ; actual constant + ;; Ops with an immediate argument. + ((memq op '( stack-ref stack-set call unbind + listN concatN insertN discardN discardN-preserve-tos)) + (format "(%s %S)" op tail)) + ;; Without immediate, print just the symbol. + (t op)))) + ;; Anything else is printed as-is. + (t arg))) + (defun byte-compile-log-lap-1 (format &rest args) (byte-compile-log-1 - (apply #'format-message format - (let (c a) - (mapcar (lambda (arg) - (if (not (consp arg)) - (if (and (symbolp arg) - (string-match "^byte-" (symbol-name arg))) - (intern (substring (symbol-name arg) 5)) - arg) - (if (integerp (setq c (car arg))) - (error "Non-symbolic byte-op %s" c)) - (if (eq c 'TAG) - (setq c arg) - (setq a (cond ((memq c byte-goto-ops) - (car (cdr (cdr arg)))) - ((memq c byte-constref-ops) - (car (cdr arg))) - (t (cdr arg)))) - (setq c (symbol-name c)) - (if (string-match "^byte-." c) - (setq c (intern (substring c 5))))) - (if (eq c 'constant) (setq c 'const)) - (if (and (eq (cdr arg) 0) - (not (memq c '(unbind call const)))) - c - (format "(%s %s)" c a)))) - args))))) + (apply #'format-message format (mapcar #'bytecomp--log-lap-arg args)))) (defmacro byte-compile-log-lap (format-string &rest args) `(and (memq byte-optimize-log '(t byte)) @@ -266,6 +272,14 @@ for speeding up processing.") . ,(cdr case))) cases))) +(defsubst byte-opt--fget (f prop) + "Simpler and faster version of `function-get'." + (let ((val nil)) + (while (and (symbolp f) f + (null (setq val (get f prop)))) + (setq f (symbol-function f))) + val)) + (defun byte-optimize-form-code-walker (form for-effect) ;; ;; For normal function calls, We can just mapcar the optimizer the cdr. But @@ -410,7 +424,10 @@ for speeding up processing.") (`(condition-case ,var ,exp . ,clauses) `(,fn ,var ;Not evaluated. - ,(byte-optimize-form exp for-effect) + ,(byte-optimize-form exp + (if (assq :success clauses) + (null var) + for-effect)) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars (and lexical-binding @@ -422,13 +439,12 @@ for speeding up processing.") (byte-optimize-body (cdr clause) for-effect)))) clauses))) - ;; `unwind-protect' is a special form which here takes the shape - ;; (unwind-protect EXPR :fun-body UNWIND-FUN). - ;; We can treat it as if it were a plain function at this point, - ;; although there are specific optimizations possible. - ;; In particular, the return value of UNWIND-FUN is never used - ;; so its body should really be compiled for-effect, but we - ;; don't do that right now. + (`(unwind-protect ,protected-expr :fun-body ,unwind-fun) + ;; FIXME: The return value of UNWIND-FUN is never used so we + ;; could potentially optimise it for-effect, but we don't do + ;; that right no. + `(,fn ,(byte-optimize-form protected-expr for-effect) + :fun-body ,(byte-optimize-form unwind-fun))) (`(catch ,tag . ,exps) `(,fn ,(byte-optimize-form tag nil) @@ -488,26 +504,18 @@ for speeding up processing.") form) ((guard (when for-effect - (if-let ((tmp (get fn 'side-effect-free))) + (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) - ;; appending a nil here might not be necessary, but it can't hurt. - (byte-optimize-form - (cons 'progn (append (cdr form) '(nil))) t)) + (byte-optimize-form (cons 'progn (cdr form)) t)) (_ ;; Otherwise, no args can be considered to be for-effect, ;; even if the called function is for-effect, because we ;; don't know anything about that function. (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) - (if (get fn 'pure) + (if (byte-opt--fget fn 'pure) (byte-optimize-constant-args form) form)))))) @@ -529,7 +537,7 @@ for speeding up processing.") ;; until a fixpoint has been reached. (and (consp form) (symbolp (car form)) - (let ((opt (function-get (car form) 'byte-optimizer))) + (let ((opt (byte-opt--fget (car form) 'byte-optimizer))) (and opt (let ((old form) (new (funcall opt form))) @@ -755,7 +763,8 @@ for speeding up processing.") ((eq head 'list) (cdr form)) ((memq head ;; FIXME: Replace this list with a function property? - '( length safe-length cons lambda + '( lambda internal-make-closure + length safe-length cons string unibyte-string make-string concat format format-message substring substring-no-properties string-replace @@ -971,17 +980,52 @@ for speeding up processing.") (t ;; Moving the constant to the end can enable some lapcode optimizations. (list (car form) (nth 2 form) (nth 1 form))))) +(defun byte-opt--nary-comparison (form) + "Optimise n-ary comparisons such as `=', `<' etc." + (let ((nargs (length (cdr form)))) + (cond + ((= nargs 1) + `(progn (cadr form) t)) + ((>= nargs 3) + ;; At least 3 arguments: transform to N-1 binary comparisons, + ;; since those have their own byte-ops which are particularly + ;; fast for fixnums. + (let* ((op (car form)) + (bindings nil) + (rev-args nil)) + (if (memq nil (mapcar #'macroexp-copyable-p (cddr form))) + ;; At least one arg beyond the first is non-constant non-variable: + ;; create temporaries for all args to guard against side-effects. + ;; The optimiser will eliminate trivial bindings later. + (let ((i 1)) + (dolist (arg (cdr form)) + (let ((var (make-symbol (format "arg%d" i)))) + (push var rev-args) + (push (list var arg) bindings) + (setq i (1+ i))))) + ;; All args beyond the first are copyable: no temporary variables + ;; required. + (setq rev-args (reverse (cdr form)))) + (let ((prev (car rev-args)) + (exprs nil)) + (dolist (arg (cdr rev-args)) + (push (list op arg prev) exprs) + (setq prev arg)) + (let ((and-expr (cons 'and exprs))) + (if bindings + (list 'let (nreverse bindings) and-expr) + and-expr))))) + (t form)))) + (defun byte-optimize-constant-args (form) - (let ((ok t) - (rest (cdr form))) - (while (and rest ok) - (setq ok (macroexp-const-p (car rest)) - rest (cdr rest))) - (if ok - (condition-case () - (list 'quote (eval form)) - (error form)) - form))) + (let ((rest (cdr form))) + (while (and rest (macroexp-const-p (car rest))) + (setq rest (cdr rest))) + (if rest + form + (condition-case () + (list 'quote (eval form t)) + (error form))))) (defun byte-optimize-identity (form) (if (and (cdr form) (null (cdr (cdr form)))) @@ -989,8 +1033,19 @@ for speeding up processing.") form)) (defun byte-optimize--constant-symbol-p (expr) - "Whether EXPR is a constant symbol." - (and (macroexp-const-p expr) (symbolp (eval expr)))) + "Whether EXPR is a constant symbol, like (quote hello), nil, t, or :keyword." + (if (consp expr) + (and (memq (car expr) '(quote function)) + (symbolp (cadr expr))) + (or (memq expr '(nil t)) + (keywordp expr)))) + +(defsubst byteopt--eval-const (expr) + "Evaluate EXPR which must be a constant (quoted or self-evaluating). +Ie, (macroexp-const-p EXPR) must be true." + (if (consp expr) + (cadr expr) ; assumed to be 'VALUE or #'SYMBOL + expr)) (defun byte-optimize--fixnump (o) "Return whether O is guaranteed to be a fixnum in all Emacsen. @@ -1027,7 +1082,7 @@ See Info node `(elisp) Integer Basics'." (byte-optimize--fixnump (nth 1 form)) (let ((arg2 (nth 2 form))) (and (macroexp-const-p arg2) - (let ((listval (eval arg2))) + (let ((listval (byteopt--eval-const arg2))) (and (listp listval) (not (memq nil (mapcar (lambda (o) @@ -1076,21 +1131,31 @@ See Info node `(elisp) Integer Basics'." form)) (defun byte-optimize-concat (form) - "Merge adjacent constant arguments to `concat'." + "Merge adjacent constant arguments to `concat' and flatten nested forms." (let ((args (cdr form)) (newargs nil)) (while args - (let ((strings nil) - val) - (while (and args (macroexp-const-p (car args)) - (progn - (setq val (eval (car args))) - (and (or (stringp val) - (and (or (listp val) (vectorp val)) - (not (memq nil - (mapcar #'characterp val)))))))) - (push val strings) - (setq args (cdr args))) + (let ((strings nil)) + (while + (and args + (let ((arg (car args))) + (pcase arg + ;; Merge consecutive constant arguments. + ((pred macroexp-const-p) + (let ((val (byteopt--eval-const arg))) + (and (or (stringp val) + (and (or (listp val) (vectorp val)) + (not (memq nil + (mapcar #'characterp val))))) + (progn + (push val strings) + (setq args (cdr args)) + t)))) + ;; Flatten nested `concat' form. + (`(concat . ,nested-args) + (setq args (append nested-args (cdr args))) + t))))) + (when strings (let ((s (apply #'concat (nreverse strings)))) (when (not (zerop (length s))) @@ -1126,13 +1191,18 @@ See Info node `(elisp) Integer Basics'." (put 'max 'byte-optimizer #'byte-optimize-min-max) (put 'min 'byte-optimizer #'byte-optimize-min-max) -(put '= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'eq 'byte-optimizer #'byte-optimize-eq) (put 'eql 'byte-optimizer #'byte-optimize-equal) (put 'equal 'byte-optimizer #'byte-optimize-equal) (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) +(put '= 'byte-optimizer #'byte-opt--nary-comparison) +(put '< 'byte-optimizer #'byte-opt--nary-comparison) +(put '<= 'byte-optimizer #'byte-opt--nary-comparison) +(put '> 'byte-optimizer #'byte-opt--nary-comparison) +(put '>= 'byte-optimizer #'byte-opt--nary-comparison) + (put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp) (put 'string> 'byte-optimizer #'byte-optimize-string-greaterp) @@ -1297,11 +1367,8 @@ See Info node `(elisp) Integer Basics'." (if else `(progn ,condition ,@else) condition)) - ;; (if X nil t) -> (not X) - ((and (eq then nil) (eq else '(t))) - `(not ,condition)) - ;; (if X t [nil]) -> (not (not X)) - ((and (eq then t) (or (null else) (eq else '(nil)))) + ;; (if X t) -> (not (not X)) + ((and (eq then t) (null else)) `(not ,(byte-opt--negate condition))) ;; (if VAR VAR X...) -> (or VAR (progn X...)) ((and (symbolp condition) (eq condition then)) @@ -1379,6 +1446,9 @@ See Info node `(elisp) Integer Basics'." ;; (apply F ... (list X Y ...)) -> (funcall F ... X Y ...) ((eq (car-safe last) 'list) `(funcall ,fn ,@(butlast (cddr form)) ,@(cdr last))) + ;; (apply F ... (cons X Y)) -> (apply F ... X Y) + ((eq (car-safe last) 'cons) + (append (butlast form) (cdr last))) (t form))) form))) @@ -1476,7 +1546,7 @@ See Info node `(elisp) Integer Basics'." (cond ((macroexp-const-p arg) ;; constant arg - (let ((val (eval arg))) + (let ((val (byteopt--eval-const arg))) (cond ;; Elide empty arguments (nil, empty string, etc). ((zerop (length val)) @@ -1486,7 +1556,7 @@ See Info node `(elisp) Integer Basics'." (loop (cdr args) (cons (list 'quote - (append (eval prev) val nil)) + (append (byteopt--eval-const prev) val nil)) (cdr newargs)))) (t (loop (cdr args) (cons arg newargs)))))) @@ -1566,106 +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 count-lines - 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-time-string frame-first-window - frame-root-window frame-selected-window - frame-visible-p fround ftruncate - get gethash get-buffer get-buffer-window getenv get-file-buffer - hash-table-count - int-to-string intern-soft isnan - keymap-parent - lax-plist-get 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 log10 logand logb logcount logior lognot logxor lsh - make-byte-code make-list make-string make-symbol mark 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 - parse-colon-path - prefix-numeric-value previous-window prin1-to-string propertize - degrees-to-radians - radians-to-degrees rassq rassoc read-from-string regexp-opt - regexp-quote region-beginning region-end reverse round - sin sqrt string string< string= string-equal string-lessp - string> string-greaterp string-empty-p string-blank-p - string-search string-to-char - string-to-number string-to-syntax substring - sxhash 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 user-original-login-name custom-variable-p - vconcat - window-absolute-pixel-edges window-at window-body-height - window-body-width window-buffer window-dedicated-p window-display-table - window-combination-limit window-edges window-frame window-fringes - window-height window-hscroll window-inside-edges - window-inside-absolute-pixel-edges window-inside-pixel-edges - 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-pixel-edges 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 - window-width zerop)) + 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 - '(always arrayp atom - bignump bobp bolp bool-vector-p - buffer-end 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 eventp - fixnump floatp following-char framep - get-largest-window get-lru-window - hash-table-p - ;; `ignore' isn't here because we don't want calls to it elided; - ;; see `byte-compile-ignore'. - identity integerp integer-or-marker-p interactive-p - invocation-directory invocation-name - keymapp keywordp - list listp - make-marker mark-marker markerp max-char - memory-limit - mouse-movement-p - natnump nlistp not null number-or-marker-p numberp - one-window-p overlayp - point point-marker point-min point-max preceding-char primary-charset - processp 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))) @@ -1690,43 +1885,34 @@ See Info node `(elisp) Integer Basics'." ;; values if a marker is moved. (let ((pure-fns - '(concat regexp-opt 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= string-equal string< string-lessp string> string-greaterp - string-empty-p string-blank-p - string-search - consp atom listp nlistp proper-list-p - sequencep arrayp vectorp stringp bool-vector-p hash-table-p - null not - numberp integerp floatp natnump characterp - integer-or-marker-p number-or-marker-p char-or-string-p - symbolp keywordp - type-of - identity ignore - - ;; 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 last 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 - lax-plist-get - 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) @@ -1904,6 +2090,7 @@ See Info node `(elisp) Integer Basics'." (defconst byte-after-unbind-ops '(byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard + byte-discardN byte-discardN-preserve-tos byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp byte-eq byte-not byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN @@ -1967,574 +2154,800 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-lapcode (lap &optional _for-effect) "Simple peephole optimizer. LAP is both modified and returned. If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." - (let (lap0 - lap1 - lap2 - (keep-going 'first-time) - (add-depth 0) - rest tmp tmp2 tmp3 - (side-effect-free (if byte-compile-delete-errors + (let ((side-effect-free (if byte-compile-delete-errors byte-compile-side-effect-free-ops - byte-compile-side-effect-and-error-free-ops))) + byte-compile-side-effect-and-error-free-ops)) + ;; Ops taking and produce a single value on the stack. + (unary-ops '( byte-not byte-length byte-list1 byte-nreverse + byte-car byte-cdr byte-car-safe byte-cdr-safe + byte-symbolp byte-consp byte-stringp + byte-listp byte-integerp byte-numberp + byte-add1 byte-sub1 byte-negate + ;; There are more of these but the list is + ;; getting long and the gain is typically small. + )) + ;; Ops producing a single result without looking at the stack. + (producer-ops '( byte-constant byte-varref + byte-point byte-point-max byte-point-min + byte-following-char byte-preceding-char + byte-current-column + byte-eolp byte-eobp byte-bolp byte-bobp + byte-current-buffer byte-widen)) + (add-depth 0) + (keep-going 'first-time) + ;; Create a cons cell as head of the list so that removing the first + ;; element does not need special-casing: `setcdr' always works. + (lap-head (cons nil lap))) (while keep-going - (or (eq keep-going 'first-time) - (byte-compile-log-lap " ---- next pass")) - (setq rest lap - keep-going nil) - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest) - lap2 (nth 2 rest)) - - ;; You may notice that sequences like "dup varset discard" are - ;; optimized but sequences like "dup varset TAG1: discard" are not. - ;; You may be tempted to change this; resist that temptation. - (cond - ;; <side-effect-free> pop --> <deleted> - ;; ...including: - ;; const-X pop --> <deleted> - ;; varref-X pop --> <deleted> - ;; dup pop --> <deleted> - ;; - ((and (eq 'byte-discard (car lap1)) - (memq (car lap0) side-effect-free)) - (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) - (setq rest (cdr rest)) - (cond ((eql tmp 1) - (byte-compile-log-lap - " %s discard\t-->\t<deleted>" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((eql tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t<deleted> discard" lap0) - (setq lap (delq lap0 lap))) - ((eql tmp -1) - (byte-compile-log-lap - " %s discard\t-->\tdiscard discard" lap0) - (setcar lap0 'byte-discard) - (setcdr lap0 0)) - (t (error "Optimizer error: too much on the stack")))) - ;; - ;; goto*-X X: --> X: - ;; - ((and (memq (car lap0) byte-goto-ops) - (eq (cdr lap0) lap1)) - (cond ((eq (car lap0) 'byte-goto) - (setq lap (delq lap0 lap)) - (setq tmp "<deleted>")) - ((memq (car lap0) byte-goto-always-pop-ops) - (setcar lap0 (setq tmp 'byte-discard)) - (setcdr lap0 0)) - ((error "Depth conflict at tag %d" (nth 2 lap0)))) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" - (nth 1 lap1) (nth 1 lap1) - tmp (nth 1 lap1))) - (setq keep-going t)) - ;; - ;; varset-X varref-X --> dup varset-X - ;; varbind-X varref-X --> dup varbind-X - ;; const/dup varset-X varref-X --> const/dup varset-X const/dup - ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup - ;; The latter two can enable other optimizations. - ;; - ;; For lexical variables, we could do the same - ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 - ;; but this is a very minor gain, since dup is stack-ref-0, - ;; i.e. it's only better if X>5, and even then it comes - ;; at the cost of an extra stack slot. Let's not bother. - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) - (not (eq (car lap0) 'byte-constant))) - nil - (setq keep-going t) - (if (memq (car lap0) '(byte-constant byte-dup)) - (progn - (setq tmp (if (or (not tmp) - (macroexp--const-symbol-p - (car (cdr lap0)))) - (cdr lap0) - (byte-compile-get-constant t))) - (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" - lap0 lap1 lap2 lap0 lap1 - (cons (car lap0) tmp)) - (setcar lap2 (car lap0)) - (setcdr lap2 tmp)) - (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) - (setcar lap2 (car lap1)) - (setcar lap1 'byte-dup) - (setcdr lap1 0) - ;; The stack depth gets locally increased, so we will - ;; increase maxdepth in case depth = maxdepth here. - ;; This can cause the third argument to byte-code to - ;; be larger than necessary. - (setq add-depth 1)))) - ;; - ;; dup varset-X discard --> varset-X - ;; dup varbind-X discard --> varbind-X - ;; dup stack-set-X discard --> stack-set-X-1 - ;; (the varbind variant can emerge from other optimizations) - ;; - ((and (eq 'byte-dup (car lap0)) - (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind - byte-stack-set))) - (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) - (setq keep-going t - rest (cdr rest)) - (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1))) - (setq lap (delq lap0 (delq lap2 lap)))) - ;; - ;; not goto-X-if-nil --> goto-X-if-non-nil - ;; not goto-X-if-non-nil --> goto-X-if-nil - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (eq 'byte-not (car lap0)) - (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) - (byte-compile-log-lap " not %s\t-->\t%s" - lap1 - (cons - (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil) - (cdr lap1))) - (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) - 'byte-goto-if-not-nil - 'byte-goto-if-nil)) - (setq lap (delq lap0 lap)) - (setq keep-going t)) - ;; - ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: - ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: - ;; - ;; it is wrong to do the same thing for the -else-pop variants. - ;; - ((and (memq (car lap0) - '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX - (eq 'byte-goto (car lap1)) ; gotoY - (eq (cdr lap0) lap2)) ; TAG X - (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) - 'byte-goto-if-not-nil 'byte-goto-if-nil))) - (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" - lap0 lap1 lap2 - (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) - (setcar lap1 inverse) - (setq keep-going t))) - ;; - ;; const goto-if-* --> whatever - ;; - ((and (eq 'byte-constant (car lap0)) - (memq (car lap1) byte-conditional-ops) - ;; If the `byte-constant's cdr is not a cons cell, it has - ;; to be an index into the constant pool); even though - ;; it'll be a constant, that constant is not known yet - ;; (it's typically a free variable of a closure, so will - ;; only be known when the closure will be built at - ;; run-time). - (consp (cdr lap0))) - (cond ((if (memq (car lap1) '(byte-goto-if-nil - byte-goto-if-nil-else-pop)) - (car (cdr lap0)) - (not (car (cdr lap0)))) - (byte-compile-log-lap " %s %s\t-->\t<deleted>" - lap0 lap1) - (setq rest (cdr rest) - lap (delq lap0 (delq lap1 lap)))) - (t - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 - (cons 'byte-goto (cdr lap1))) - (when (memq (car lap1) byte-goto-always-pop-ops) - (setq lap (delq lap0 lap))) - (setcar lap1 'byte-goto))) - (setq keep-going t)) - ;; - ;; varref-X varref-X --> varref-X dup - ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup - ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup - ;; We don't optimize the const-X variations on this here, - ;; because that would inhibit some goto optimizations; we - ;; optimize the const-X case after all other optimizations. - ;; - ((and (memq (car lap0) '(byte-varref byte-stack-ref)) - (progn - (setq tmp (cdr rest)) - (setq tmp2 0) - (while (eq (car (car tmp)) 'byte-dup) - (setq tmp2 (1+ tmp2)) - (setq tmp (cdr tmp))) - t) - (eq (if (eq 'byte-stack-ref (car lap0)) - (+ tmp2 1 (cdr lap0)) - (cdr lap0)) - (cdr (car tmp))) - (eq (car lap0) (car (car tmp)))) - (if (memq byte-optimize-log '(t byte)) - (let ((str "")) - (setq tmp2 (cdr rest)) - (while (not (eq tmp tmp2)) - (setq tmp2 (cdr tmp2) - str (concat str " dup"))) - (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" - lap0 str lap0 lap0 str))) - (setq keep-going t) - (setcar (car tmp) 'byte-dup) - (setcdr (car tmp) 0) - (setq rest tmp)) - ;; - ;; TAG1: TAG2: --> TAG1: <deleted> - ;; (and other references to TAG2 are replaced with TAG1) - ;; - ((and (eq (car lap0) 'TAG) - (eq (car lap1) 'TAG)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " adjacent tags %d and %d merged" - (nth 1 lap1) (nth 1 lap0))) - (setq tmp3 lap) - (while (setq tmp2 (rassq lap0 tmp3)) - (setcdr tmp2 lap1) - (setq tmp3 (cdr (memq tmp2 tmp3)))) - (setq lap (delq lap0 lap) - keep-going t) - ;; replace references to tag in jump tables, if any - (dolist (table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (when (equal tag lap0) - (puthash value lap1 table))) - table))) - ;; - ;; unused-TAG: --> <deleted> - ;; - ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap)) - ;; make sure this tag isn't used in a jump-table - (cl-loop for table in byte-compile-jump-tables - when (member lap0 (hash-table-values table)) - return nil finally return t)) - (and (memq byte-optimize-log '(t byte)) - (byte-compile-log " unused tag %d removed" (nth 1 lap0))) - (setq lap (delq lap0 lap) - keep-going t)) - ;; - ;; goto ... --> goto <delete until TAG or end> - ;; return ... --> return <delete until TAG or end> - ;; (unless a jump-table is being used, where deleting may affect - ;; other valid case bodies) - ;; - ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil))) - ;; FIXME: Instead of deferring simply when jump-tables are - ;; being used, keep a list of tags used for switch tags and - ;; use them instead (see `byte-compile-inline-lapcode'). - (not byte-compile-jump-tables)) - (setq tmp rest) - (let ((i 0) - (opt-p (memq byte-optimize-log '(t lap))) - str deleted) - (while (and (setq tmp (cdr tmp)) - (not (eq 'TAG (car (car tmp))))) - (if opt-p (setq deleted (cons (car tmp) deleted) - str (concat str " %s") - i (1+ i)))) - (if opt-p - (let ((tagstr - (if (eq 'TAG (car (car tmp))) - (format "%d:" (car (cdr (car tmp)))) - (or (car tmp) "")))) - (if (< i 6) - (apply 'byte-compile-log-lap-1 - (concat " %s" str - " %s\t-->\t%s <deleted> %s") - lap0 - (nconc (nreverse deleted) - (list tagstr lap0 tagstr))) - (byte-compile-log-lap - " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" - lap0 i (if (= i 1) "" "s") - tagstr lap0 tagstr)))) - (rplacd rest tmp)) - (setq keep-going t)) - ;; - ;; <safe-op> unbind --> unbind <safe-op> - ;; (this may enable other optimizations.) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) byte-after-unbind-ops)) - (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) - (setcar rest lap1) - (setcar (cdr rest) lap0) - (setq keep-going t)) - ;; - ;; varbind-X unbind-N --> discard unbind-(N-1) - ;; save-excursion unbind-N --> unbind-(N-1) - ;; save-restriction unbind-N --> unbind-(N-1) - ;; save-current-buffer unbind-N --> unbind-(N-1) - ;; - ((and (eq 'byte-unbind (car lap1)) - (memq (car lap0) '(byte-varbind byte-save-excursion - byte-save-restriction - byte-save-current-buffer)) - (< 0 (cdr lap1))) - (if (zerop (setcdr lap1 (1- (cdr lap1)))) - (delq lap1 rest)) - (if (eq (car lap0) 'byte-varbind) - (setcar rest (cons 'byte-discard 0)) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s %s" - lap0 (cons (car lap1) (1+ (cdr lap1))) - (if (eq (car lap0) 'byte-varbind) - (car rest) - (car (cdr rest))) - (if (and (/= 0 (cdr lap1)) - (eq (car lap0) 'byte-varbind)) - (car (cdr rest)) - "")) - (setq keep-going t)) - ;; - ;; goto*-X ... X: goto-Y --> goto*-Y - ;; goto-X ... X: return --> return - ;; - ((and (memq (car lap0) byte-goto-ops) - (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) - '(byte-goto byte-return))) - (cond ((and (or (eq (car lap0) 'byte-goto) - (eq (car tmp) 'byte-goto)) - (not (eq (cdr tmp) (cdr lap0)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s" - (car lap0) tmp tmp) - (if (eq (car tmp) 'byte-return) - (setcar lap0 'byte-return)) - (setcdr lap0 (cdr tmp)) - (setq keep-going t)))) - ;; - ;; goto-*-else-pop X ... X: goto-if-* --> whatever - ;; goto-*-else-pop X ... X: discard --> whatever - ;; - ((and (memq (car lap0) '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop)) - (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap0 (car tmp)))) - (setq tmp2 (car tmp)) - (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop - byte-goto-if-nil) - (byte-goto-if-not-nil-else-pop - byte-goto-if-not-nil)))) - (if (memq (car tmp2) tmp3) - (progn (setcar lap0 (car tmp2)) - (setcdr lap0 (cdr tmp2)) - (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" - (car lap0) tmp2 lap0)) - ;; Get rid of the -else-pop's and jump one step further. - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" - (car lap0) tmp2 (nth 1 tmp3)) - (setcar lap0 (nth 1 tmp3)) - (setcdr lap0 (nth 1 tmp))) - (setq keep-going t)) - ;; - ;; const goto-X ... X: goto-if-* --> whatever - ;; const goto-X ... X: discard --> whatever - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-goto) - (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) - (eval-when-compile - (cons 'byte-discard byte-conditional-ops))) - (not (eq lap1 (car tmp)))) - (setq tmp2 (car tmp)) - (cond ((when (consp (cdr lap0)) - (memq (car tmp2) - (if (null (car (cdr lap0))) - '(byte-goto-if-nil byte-goto-if-nil-else-pop) - '(byte-goto-if-not-nil - byte-goto-if-not-nil-else-pop)))) - (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" - lap0 tmp2 lap0 tmp2) - (setcar lap1 (car tmp2)) - (setcdr lap1 (cdr tmp2)) - ;; Let next step fix the (const,goto-if*) sequence. - (setq rest (cons nil rest)) - (setq keep-going t)) - ((or (consp (cdr lap0)) - (eq (car tmp2) 'byte-discard)) - ;; Jump one step further - (byte-compile-log-lap - " %s goto [%s]\t-->\t<deleted> goto <skip>" - lap0 tmp2) - (or (eq 'TAG (car (nth 1 tmp))) - (setcdr tmp (cons (byte-compile-make-tag) - (cdr tmp)))) - (setcdr lap1 (car (cdr tmp))) - (setq lap (delq lap0 lap)) - (setq keep-going t)))) - ;; - ;; X: varref-Y ... varset-Y goto-X --> - ;; X: varref-Y Z: ... dup varset-Y goto-Z - ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) - ;; (This is so usual for while loops that it is worth handling). - ;; - ;; Here again, we could do it for stack-ref/stack-set, but - ;; that's replacing a stack-ref-Y with a stack-ref-0, which - ;; is a very minor improvement (if any), at the cost of - ;; more stack use and more byte-code. Let's not do it. - ;; - ((and (eq (car lap1) 'byte-varset) - (eq (car lap2) 'byte-goto) - (not (memq (cdr lap2) rest)) ;Backwards jump - (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) - (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) - ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" - (nth 1 (cdr lap2)) (car tmp) - lap1 lap2 - (nth 1 (cdr lap2)) (car tmp) - (nth 1 newtag) 'byte-dup lap1 - (cons 'byte-goto newtag) - ) - (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) - (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) - (setq add-depth 1) - (setq keep-going t)) - ;; - ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: - ;; (This can pull the loop test to the end of the loop) - ;; - ((and (eq (car lap0) 'byte-goto) - (eq (car lap1) 'TAG) - (eq lap1 - (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) - (memq (car (car tmp)) - '(byte-goto byte-goto-if-nil byte-goto-if-not-nil - byte-goto-if-nil-else-pop))) - ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" - ;; lap0 lap1 (cdr lap0) (car tmp)) - (let ((newtag (byte-compile-make-tag))) - (byte-compile-log-lap - "%s %s: ... %s: %s\t-->\t%s ... %s:" - lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) - (cons (cdr (assq (car (car tmp)) - '((byte-goto-if-nil . byte-goto-if-not-nil) - (byte-goto-if-not-nil . byte-goto-if-nil) - (byte-goto-if-nil-else-pop . - byte-goto-if-not-nil-else-pop) - (byte-goto-if-not-nil-else-pop . - byte-goto-if-nil-else-pop)))) - newtag) - - (nth 1 newtag) - ) - (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) - (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) - ;; We can handle this case but not the -if-not-nil case, - ;; because we won't know which non-nil constant to push. - (setcdr rest (cons (cons 'byte-constant - (byte-compile-get-constant nil)) - (cdr rest)))) - (setcar lap0 (nth 1 (memq (car (car tmp)) - '(byte-goto-if-nil-else-pop - byte-goto-if-not-nil - byte-goto-if-nil - byte-goto-if-not-nil - byte-goto byte-goto)))) - ) - (setq keep-going t)) - - ;; - ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos - ;; stack-set-M [discard/discardN ...] --> discardN - ;; - ((and (eq (car lap0) 'byte-stack-set) - (memq (car lap1) '(byte-discard byte-discardN)) - (progn - ;; See if enough discard operations follow to expose or - ;; destroy the value stored by the stack-set. - (setq tmp (cdr rest)) - (setq tmp2 (1- (cdr lap0))) - (setq tmp3 0) - (while (memq (car (car tmp)) '(byte-discard byte-discardN)) - (setq tmp3 - (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) - 1 - (cdr (car tmp))))) - (setq tmp (cdr tmp))) - (>= tmp3 tmp2))) - ;; Do the optimization. - (setq lap (delq lap0 lap)) - (setcar lap1 - (if (= tmp2 tmp3) - ;; The value stored is the new TOS, so pop one more - ;; value (to get rid of the old value) using the - ;; TOS-preserving discard operator. - 'byte-discardN-preserve-tos - ;; Otherwise, the value stored is lost, so just use a - ;; normal discard. - 'byte-discardN)) - (setcdr lap1 (1+ tmp3)) - (setcdr (cdr rest) tmp) - (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" - lap0 lap1)) - - ;; - ;; discardN-preserve-tos return --> return - ;; dup return --> return - ;; stack-set-N return --> return ; where N is TOS-1 - ;; - ((and (eq (car lap1) 'byte-return) - (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) - (and (eq (car lap0) 'byte-stack-set) - (= (cdr lap0) 1)))) - (setq keep-going t) - ;; The byte-code interpreter will pop the stack for us, so - ;; we can just leave stuff on it. - (setq lap (delq lap0 lap)) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) - - ;; - ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: - ;; - ((and (eq (car lap0) 'byte-goto) - (setq tmp (cdr (memq (cdr lap0) lap))) - (memq (caar tmp) '(byte-discard byte-discardN - byte-discardN-preserve-tos))) - (byte-compile-log-lap - " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" - (car tmp) (car tmp)) - (setq keep-going t) - (let* ((newtag (byte-compile-make-tag)) - ;; Make a copy, since we sometimes modify insts in-place! - (newdiscard (cons (caar tmp) (cdar tmp))) - (newjmp (cons (car lap0) newtag))) - (push newtag (cdr tmp)) ;Push new tag after the discard. - (setcar rest newdiscard) - (push newjmp (cdr rest)))) - - ;; - ;; const discardN-preserve-tos ==> discardN const - ;; - ((and (eq (car lap0) 'byte-constant) - (eq (car lap1) 'byte-discardN-preserve-tos)) - (setq keep-going t) - (let ((newdiscard (cons 'byte-discardN (cdr lap1)))) - (byte-compile-log-lap - " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) - (setf (car rest) newdiscard) - (setf (cadr rest) lap0))) - ) - (setq rest (cdr rest))) - ) + (byte-compile-log-lap " ---- %s pass" + (if (eq keep-going 'first-time) "first" "next")) + (setq keep-going nil) + (let ((prev lap-head)) + (while (cdr prev) + (let* ((rest (cdr prev)) + (lap0 (car rest)) + (lap1 (nth 1 rest)) + (lap2 (nth 2 rest))) + + ;; You may notice that sequences like "dup varset discard" are + ;; optimized but sequences like "dup varset TAG1: discard" are not. + ;; You may be tempted to change this; resist that temptation. + + ;; Each clause in this `cond' statement must keep `prev' the + ;; predecessor of the remainder of the list for inspection. + (cond + ;; + ;; PUSH(K) discard(N) --> <deleted> discard(N-K), N>K + ;; PUSH(K) discard(N) --> <deleted>, N=K + ;; where PUSH(K) is a side-effect-free op such as + ;; const, varref, dup + ;; + ((and (memq (car lap1) '(byte-discard byte-discardN)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (let* ((pushes (aref byte-stack+-info (symbol-value (car lap0)))) + (pops (if (eq (car lap1) 'byte-discardN) (cdr lap1) 1)) + (net-pops (- pops pushes))) + (cond ((= net-pops 0) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setcdr prev (cddr rest))) + ((> net-pops 0) + (byte-compile-log-lap + " %s %s\t-->\t<deleted> discard(%d)" + lap0 lap1 net-pops) + (setcar rest (if (eql net-pops 1) + (cons 'byte-discard nil) + (cons 'byte-discardN net-pops))) + (setcdr rest (cddr rest))) + (t (error "Optimizer error: too much on the stack"))))) + ;; + ;; goto(X) X: --> X: + ;; goto-if-[not-]nil(X) X: --> discard X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (byte-compile-log-lap " %s %s\t-->\t<deleted> %s" + lap0 lap1 lap1) + (setcdr prev (cdr rest))) + ((memq (car lap0) byte-goto-always-pop-ops) + (byte-compile-log-lap " %s %s\t-->\tdiscard %s" + lap0 lap1 lap1) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ;; goto-*-else-pop(X) cannot occur here because it would + ;; be a depth conflict. + (t (error "Depth conflict at tag %d" (nth 2 lap0)))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ;; For lexical variables, we could do the same + ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2 + ;; but this is a very minor gain, since dup is stack-ref-0, + ;; i.e. it's only better if X>5, and even then it comes + ;; at the cost of an extra stack slot. Let's not bother. + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind)) + (let ((tmp (memq (car (cdr lap2)) byte-boolean-vars))) + (and + (not (and tmp (not (eq (car lap0) 'byte-constant)))) + (progn + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (let ((tmp (if (or (not tmp) + (macroexp--const-symbol-p + (car (cdr lap0)))) + (cdr lap0) + (byte-compile-get-constant t)))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" + lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)) + t))))) + ;; + ;; dup varset discard(N) --> varset discard(N-1) + ;; dup varbind discard(N) --> varbind discard(N-1) + ;; dup stack-set(M) discard(N) --> stack-set(M-1) discard(N-1), M>1 + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (memq (car lap2) '(byte-discard byte-discardN)) + (or (memq (car lap1) '(byte-varset byte-varbind)) + (and (eq (car lap1) 'byte-stack-set) + (> (cdr lap1) 1)))) + (setcdr prev (cdr rest)) ; remove dup + (let ((new1 (if (eq (car lap1) 'byte-stack-set) + (cons 'byte-stack-set (1- (cdr lap1))) + lap1)) + (n (if (eq (car lap2) 'byte-discard) 1 (cdr lap2)))) + (setcar (cdr rest) new1) + (cl-assert (> n 0)) + (cond + ((> n 1) + (let ((new2 (if (> n 2) + (cons 'byte-discardN (1- n)) + (cons 'byte-discard nil)))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 lap2 new1 new2) + (setcar (cddr rest) new2))) + (t + (byte-compile-log-lap " %s %s %s\t-->\t%s" + lap0 lap1 lap2 new1) + ;; discard(0) = nop, remove + (setcdr (cdr rest) (cdddr rest))))) + (setq keep-going t)) + + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil))) + (let ((not-goto (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 (cons not-goto (cdr lap1))) + (setcar lap1 not-goto) + (setcdr prev (cdr rest)) ; delete not + (setq keep-going t))) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (memq (car lap0) + '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setcdr prev (cdr rest)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops) + ;; Must be an actual constant, not a closure variable. + (consp (cdr lap0))) + (cond ((if (memq (car lap1) '(byte-goto-if-nil + byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + ;; Branch not taken. + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setcdr prev (cddr rest))) ; delete both + ((memq (car lap1) byte-goto-always-pop-ops) + ;; Always-pop branch taken. + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (setcdr prev (cdr rest)) ; delete const + (setcar lap1 'byte-goto)) + (t ; -else-pop branch taken: keep const + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 lap1 + lap0 (cons 'byte-goto (cdr lap1))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) + (let ((tmp (cdr rest)) + (tmp2 0)) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp2 (1+ tmp2)) + (setq tmp (cdr tmp))) + (and (eq (if (eq 'byte-stack-ref (car lap0)) + (+ tmp2 1 (cdr lap0)) + (cdr lap0)) + (cdr (car tmp))) + (eq (car lap0) (car (car tmp))) + (progn + (when (memq byte-optimize-log '(t byte)) + (let ((str "") + (tmp2 (cdr rest))) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2)) + (setq str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + t))))) + ;; + ;; TAG1: TAG2: --> <deleted> TAG2: + ;; (and other references to TAG1 are replaced with TAG2) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (byte-compile-log-lap " adjacent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0)) + (let ((tmp3 (cdr lap-head))) + (while (let ((tmp2 (rassq lap0 tmp3))) + (and tmp2 + (progn + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3))) + t)))) + (setcdr prev (cdr rest)) + (setq keep-going t) + ;; replace references to tag in jump tables, if any + (dolist (table byte-compile-jump-tables) + (maphash #'(lambda (value tag) + (when (equal tag lap0) + (puthash value lap1 table))) + table)))) + ;; + ;; unused-TAG: --> <deleted> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 (cdr lap-head))) + ;; make sure this tag isn't used in a jump-table + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) + (byte-compile-log-lap " unused tag %d removed" (nth 1 lap0)) + (setcdr prev (cdr rest)) + (setq keep-going t)) + ;; + ;; goto ... --> goto <delete until TAG or end> + ;; return ... --> return <delete until TAG or end> + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil)))) + (let ((i 0) + (tmp rest) + (opt-p (memq byte-optimize-log '(t byte))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (car (cdr (car tmp)))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s <deleted> %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (setcdr rest tmp) + (setq keep-going t))) + ;; + ;; <safe-op> unbind --> unbind <safe-op> + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0) + (setq keep-going t)) + ;; + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; save-current-buffer unbind-N --> unbind-(N-1) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction + byte-save-current-buffer)) + (< 0 (cdr lap1))) + (setcdr lap1 (1- (cdr lap1))) + (when (zerop (cdr lap1)) + (setcdr rest (cddr rest))) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setcdr prev (cddr prev))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((and (memq (car lap0) byte-goto-ops) + (let ((tmp (nth 1 (memq (cdr lap0) (cdr lap-head))))) + (and + (memq (car tmp) '(byte-goto byte-return)) + (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto)) + (not (eq (cdr tmp) (cdr lap0))) + (progn + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp + (if (eq (car tmp) 'byte-return) + tmp + (cons (car lap0) (cdr tmp)))) + (when (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t) + t))))) + + ;; + ;; OP goto(X) Y: OP X: -> Y: OP X: + ;; + ((and (eq (car lap1) 'byte-goto) + (eq (car lap2) 'TAG) + (let ((lap3 (nth 3 rest))) + (and (eq (car lap0) (car lap3)) + (eq (cdr lap0) (cdr lap3)) + (eq (cdr lap1) (nth 4 rest))))) + (byte-compile-log-lap " %s %s %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 + (nth 3 rest) (nth 4 rest) + lap2 (nth 3 rest) (nth 4 rest)) + (setcdr prev (cddr rest)) + (setq keep-going t)) + + ;; + ;; NOEFFECT PRODUCER return --> PRODUCER return + ;; where NOEFFECT lacks effects beyond stack change, + ;; PRODUCER pushes a result without looking at the stack: + ;; const, varref, point etc. + ;; + ((and (eq (car (nth 2 rest)) 'byte-return) + (memq (car lap1) producer-ops) + (or (memq (car lap0) '( byte-discard byte-discardN + byte-discardN-preserve-tos + byte-stack-set)) + (memq (car lap0) side-effect-free))) + (setq keep-going t) + (setq add-depth 1) + (setcdr prev (cdr rest)) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 (nth 2 rest) lap1 (nth 2 rest))) + + ;; + ;; (discardN-preserve-tos|dup) UNARY return --> UNARY return + ;; where UNARY takes and produces a single value on the stack + ;; + ;; FIXME: ideally we should run this backwards, so that we could do + ;; discardN-preserve-tos OP1...OPn return -> OP1..OPn return + ;; but that would require a different approach. + ;; + ((and (eq (car (nth 2 rest)) 'byte-return) + (memq (car lap1) unary-ops) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (eql (cdr lap0) 1)))) + (setq keep-going t) + (setcdr prev (cdr rest)) ; eat lap0 + (byte-compile-log-lap " %s %s %s\t-->\t%s %s" + lap0 lap1 (nth 2 rest) lap1 (nth 2 rest))) + + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head))))) + (and + (memq (caar tmp) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp))) + (let ((tmp2 (car tmp)) + (tmp3 (assq (car lap0) + '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil))))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap + " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one + ;; step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t) + t))))) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (let ((tmp (cdr (memq (cdr lap1) (cdr lap-head))))) + (and + (memq (caar tmp) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp))) + (let ((tmp2 (car tmp))) + (cond ((and (consp (cdr lap0)) + (memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil + byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop)))) + (byte-compile-log-lap + " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) seq. + (setq keep-going t)) + ((or (consp (cdr lap0)) + (eq (car tmp2) 'byte-discard)) + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t<deleted> goto <skip>" + lap0 tmp2) + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (setcdr lap1 (car (cdr tmp))) + (setcdr prev (cdr rest)) + (setq keep-going t)) + (t + (setq prev (cdr prev)))) + t))))) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ;; Here again, we could do it for stack-ref/stack-set, but + ;; that's replacing a stack-ref-Y with a stack-ref-0, which + ;; is a very minor improvement (if any), at the cost of + ;; more stack use and more byte-code. Let's not do it. + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (let ((tmp (cdr (memq (cdr lap2) (cdr lap-head))))) + (and + (eq (car (car tmp)) 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))) + (setq add-depth 1) + (setq keep-going t) + t))))) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head))))) + (and + (eq lap1 (cdar tmp)) + (memq (car (car tmp)) + '( byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s %s ... %s %s\t-->\t%s ... %s" + lap0 lap1 (cdr lap0) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil + . byte-goto-if-not-nil) + (byte-goto-if-not-nil + . byte-goto-if-nil) + (byte-goto-if-nil-else-pop + . byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop + . byte-goto-if-nil-else-pop)))) + newtag) + newtag) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (when (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the + ;; -if-not-nil case, because we won't know + ;; which non-nil constant to push. + (setcdr rest + (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + (setq keep-going t) + t))))) + + ;; + ;; discardN-preserve-tos(X) discardN-preserve-tos(Y) + ;; --> discardN-preserve-tos(X+Y) + ;; where stack-set(1) is accepted as discardN-preserve-tos(1) + ;; + ((and (or (eq (car lap0) 'byte-discardN-preserve-tos) + (and (eq (car lap0) 'byte-stack-set) + (eql (cdr lap0) 1))) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1)))) + (setq keep-going t) + (let ((new-op (cons 'byte-discardN-preserve-tos + ;; This happens to work even when either + ;; op is stack-set(1). + (+ (cdr lap0) (cdr lap1))))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new-op) + (setcar rest new-op) + (setcdr rest (cddr rest)))) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (let ((tmp2 (1- (cdr lap0))) + (tmp3 0) + (tmp (cdr rest))) + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (setq tmp3 + (+ tmp3 (if (eq (car (car tmp)) 'byte-discard) + 1 + (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (and + (>= tmp3 tmp2) + (progn + ;; Do the optimization. + (setcdr prev (cdr rest)) + (setcar lap1 + (if (= tmp2 tmp3) + ;; The value stored is the new TOS, so pop + ;; one more value (to get rid of the old + ;; value) using TOS-preserving discard. + 'byte-discardN-preserve-tos + ;; Otherwise, the value stored is lost, + ;; so just use a normal discard. + 'byte-discardN)) + (setcdr lap1 (1+ tmp3)) + (setcdr (cdr rest) tmp) + (byte-compile-log-lap + " %s [discard/discardN]...\t-->\t%s" lap0 lap1) + (setq keep-going t) + t + ))))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set(1) return --> return + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) 1)))) + (setq keep-going t) + ;; The byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it. + (setcdr prev (cdr rest)) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + + ;; + ;; stack-ref(X) discardN-preserve-tos(Y) + ;; --> discard(Y) stack-ref(X-Y), X≥Y + ;; discard(X) discardN-preserve-tos(Y-X-1), X<Y + ;; where: stack-ref(0) = dup (works both ways) + ;; discard(0) = no-op + ;; discardN-preserve-tos(0) = no-op + ;; + ((and (memq (car lap0) '(byte-stack-ref byte-dup)) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1))) + ;; Don't apply if immediately preceding a `return', + ;; since there are more effective rules for that case. + (not (eq (car lap2) 'byte-return))) + (let ((x (if (eq (car lap0) 'byte-dup) 0 (cdr lap0))) + (y (cdr lap1))) + (cl-assert (> y 0)) + (cond + ((>= x y) ; --> discard(Y) stack-ref(X-Y) + (let ((new0 (if (= y 1) + (cons 'byte-discard nil) + (cons 'byte-discardN y))) + (new1 (if (= x y) + (cons 'byte-dup nil) + (cons 'byte-stack-ref (- x y))))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 lap1 new0 new1) + (setcar rest new0) + (setcar (cdr rest) new1))) + ((= x 0) ; --> discardN-preserve-tos(Y-1) + (setcdr prev (cdr rest)) ; eat lap0 + (if (> y 1) + (let ((new (cons 'byte-discardN-preserve-tos (- y 1)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 new) + (setcar (cdr prev) new)) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1) + (setcdr prev (cddr prev)))) ; eat lap1 + ((= y (+ x 1)) ; --> discard(X) + (setcdr prev (cdr rest)) ; eat lap0 + (let ((new (if (= x 1) + (cons 'byte-discard nil) + (cons 'byte-discardN x)))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new) + (setcar (cdr prev) new))) + (t ; --> discard(X) discardN-preserve-tos(Y-X-1) + (let ((new0 (if (= x 1) + (cons 'byte-discard nil) + (cons 'byte-discardN x))) + (new1 (cons 'byte-discardN-preserve-tos (- y x 1)))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 lap1 new0 new1) + (setcar rest new0) + (setcar (cdr rest) new1))))) + (setq keep-going t)) + + ;; + ;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y: + ;; + ((and (eq (car lap0) 'byte-goto) + (let ((tmp (cdr (memq (cdr lap0) (cdr lap-head))))) + (and + tmp + (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 (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 + byte-return)) + (and (eq (car next) 'byte-stack-set) + (eql (cdr next) 1))))))) + (progn + (byte-compile-log-lap + " goto-X .. X: \t-->\t%s goto-X.. X: %s Y:" + (car tmp) (car tmp)) + (setq keep-going t) + (let* ((newtag (byte-compile-make-tag)) + ;; Make a copy, since we sometimes modify + ;; insts in-place! + (newdiscard (cons (caar tmp) (cdar tmp))) + (newjmp (cons (car lap0) newtag))) + ;; Push new tag after the discard. + (push newtag (cdr tmp)) + (setcar rest newdiscard) + (push newjmp (cdr rest))) + t))))) + + ;; + ;; UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY + ;; where UNARY takes and produces a single value on the stack + ;; + ((and (memq (car lap0) unary-ops) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1))) + ;; unless followed by return (which will eat the discard) + (not (eq (car lap2) 'byte-return))) + (setq keep-going t) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0)) + + ;; + ;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER + ;; where PRODUCER pushes a result without looking at the stack: + ;; const, varref, point etc. + ;; + ((and (memq (car lap0) producer-ops) + (or (eq (car lap1) 'byte-discardN-preserve-tos) + (and (eq (car lap1) 'byte-stack-set) + (eql (cdr lap1) 1))) + ;; unless followed by return (which will eat the discard) + (not (eq (car lap2) 'byte-return))) + (setq keep-going t) + (let ((newdiscard (if (eql (cdr lap1) 1) + (cons 'byte-discard nil) + (cons 'byte-discardN (cdr lap1))))) + (byte-compile-log-lap + " %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0) + (setf (car rest) newdiscard) + (setf (cadr rest) lap0))) + + (t + ;; If no rule matched, advance and try again. + (setq prev (cdr prev)))))))) ;; Cleanup stage: ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they @@ -2542,90 +2955,84 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) - (setq rest lap) (byte-compile-log-lap " ---- final pass") - (while rest - (setq lap0 (car rest) - lap1 (nth 1 rest)) - (if (memq (car lap0) byte-constref-ops) - (if (memq (car lap0) '(byte-constant byte-constant2)) - (unless (memq (cdr lap0) byte-compile-constants) - (setq byte-compile-constants (cons (cdr lap0) - byte-compile-constants))) - (unless (memq (cdr lap0) byte-compile-variables) - (setq byte-compile-variables (cons (cdr lap0) - byte-compile-variables))))) - (cond (;; - ;; const-C varset-X const-C --> const-C dup varset-X - ;; const-C varbind-X const-C --> const-C dup varbind-X - ;; - (and (eq (car lap0) 'byte-constant) - (eq (car (nth 2 rest)) 'byte-constant) - (eq (cdr lap0) (cdr (nth 2 rest))) - (memq (car lap1) '(byte-varbind byte-varset))) - (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" - lap0 lap1 lap0 lap0 lap1) - (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) - (setcar (cdr rest) (cons 'byte-dup 0)) - (setq add-depth 1)) - ;; - ;; const-X [dup/const-X ...] --> const-X [dup ...] dup - ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup - ;; - ((memq (car lap0) '(byte-constant byte-varref)) - (setq tmp rest - tmp2 nil) - (while (progn - (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) - (and (eq (cdr lap0) (cdr (car tmp))) - (eq (car lap0) (car (car tmp))))) - (setcar tmp (cons 'byte-dup 0)) - (setq tmp2 t)) - (if tmp2 - (byte-compile-log-lap - " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0))) - ;; - ;; unbind-N unbind-M --> unbind-(N+M) - ;; - ((and (eq 'byte-unbind (car lap0)) - (eq 'byte-unbind (car lap1))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-unbind - (+ (cdr lap0) (cdr lap1)))) - (setq lap (delq lap0 lap)) - (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) - - ;; - ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> - ;; discardN-(X+Y) - ;; - ((and (memq (car lap0) - '(byte-discard byte-discardN - byte-discardN-preserve-tos)) - (memq (car lap1) '(byte-discard byte-discardN))) - (setq lap (delq lap0 lap)) - (byte-compile-log-lap - " %s %s\t-->\t(discardN %s)" - lap0 lap1 - (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) - (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) - (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) - (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) - (setcar lap1 'byte-discardN)) - - ;; - ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> - ;; discardN-preserve-tos-(X+Y) - ;; - ((and (eq (car lap0) 'byte-discardN-preserve-tos) - (eq (car lap1) 'byte-discardN-preserve-tos)) - (setq lap (delq lap0 lap)) - (setcdr lap1 (+ (cdr lap0) (cdr lap1))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) - ) - (setq rest (cdr rest))) - (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) - lap) + (let ((prev lap-head)) + (while (cdr prev) + (let* ((rest (cdr prev)) + (lap0 (car rest)) + (lap1 (nth 1 rest))) + ;; FIXME: Would there ever be a `byte-constant2' op here? + (if (memq (car lap0) byte-constref-ops) + (if (memq (car lap0) '(byte-constant byte-constant2)) + (unless (memq (cdr lap0) byte-compile-constants) + (setq byte-compile-constants (cons (cdr lap0) + byte-compile-constants))) + (unless (memq (cdr lap0) byte-compile-variables) + (setq byte-compile-variables (cons (cdr lap0) + byte-compile-variables))))) + (cond + ;; + ;; const-C varset-X const-C --> const-C dup varset-X + ;; const-C varbind-X const-C --> const-C dup varbind-X + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car (nth 2 rest)) 'byte-constant) + (eq (cdr lap0) (cdr (nth 2 rest))) + (memq (car lap1) '(byte-varbind byte-varset))) + (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" + lap0 lap1 lap0 lap0 lap1) + (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) + (setcar (cdr rest) (cons 'byte-dup 0)) + (setq add-depth 1)) + ;; + ;; const-X [dup/const-X ...] --> const-X [dup ...] dup + ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup + ;; + ((memq (car lap0) '(byte-constant byte-varref)) + (let ((tmp rest) + (tmp2 nil)) + (while (progn + (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) + (and (eq (cdr lap0) (cdr (car tmp))) + (eq (car lap0) (car (car tmp))))) + (setcar tmp (cons 'byte-dup 0)) + (setq tmp2 t)) + (if tmp2 + (byte-compile-log-lap + " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0) + (setq prev (cdr prev))))) + ;; + ;; unbind-N unbind-M --> unbind-(N+M) + ;; + ((and (eq 'byte-unbind (car lap0)) + (eq 'byte-unbind (car lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 + (cons 'byte-unbind + (+ (cdr lap0) (cdr lap1)))) + (setcdr prev (cdr rest)) + (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setcdr prev (cdr rest)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN)) + (t + (setq prev (cdr prev))))))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)) + (cdr lap-head))) (provide 'byte-opt) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index eb7d026b146..fd9913d1be8 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -262,7 +262,8 @@ This is used by `declare'.") (interactive-form nil) (warnings nil) (warn #'(lambda (msg form) - (push (macroexp-warn-and-return msg nil nil t form) + (push (macroexp-warn-and-return + (format-message msg) nil nil t form) warnings)))) (while (and body @@ -649,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' and -`suspicious'. - -For the `mapcar' case, only the `mapcar' function can be used in -the symbol list. For `suspicious', only `set-buffer' and `lsh' can be used." +`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)) @@ -679,11 +677,11 @@ Otherwise, return nil. For internal use only." ;; This is called from lread.c and therefore needs to be preloaded. (if lread--unescaped-character-literals (let ((sorted (sort lread--unescaped-character-literals #'<))) - (format-message "unescaped character literals %s detected, %s expected!" - (mapconcat (lambda (char) (format "`?%c'" char)) - sorted ", ") - (mapconcat (lambda (char) (format "`?\\%c'" char)) - sorted ", "))))) + (format "unescaped character literals %s detected, %s expected!" + (mapconcat (lambda (char) (format-message "`?%c'" char)) + sorted ", ") + (mapconcat (lambda (char) (format-message "`?\\%c'" char)) + sorted ", "))))) (defun byte-compile-info (string &optional message type) "Format STRING in a way that looks pleasing in the compilation output. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5df1205869c..c84c70971b3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -295,7 +295,8 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings docstrings-non-ascii-quotes not-unused) + docstrings docstrings-non-ascii-quotes not-unused + empty-body) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for almost all). @@ -316,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 @@ -326,9 +329,10 @@ Elements of the list may be: docstrings-non-ascii-quotes docstrings that have non-ASCII quotes. This depends on the `docstrings' warning type. suspicious constructs that usually don't do what the coder wanted. + 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'. @@ -493,6 +497,42 @@ Return the compile-time value of FORM." (cdr form))) (funcall non-toplevel-case form))) + +(defvar bytecomp--copy-tree-seen) + +(defun bytecomp--copy-tree-1 (tree) + ;; TREE must be a cons. + (or (gethash tree bytecomp--copy-tree-seen) + (let* ((next (cdr tree)) + (result (cons nil next)) + (copy result)) + (while (progn + (puthash tree copy bytecomp--copy-tree-seen) + (let ((a (car tree))) + (setcar copy (if (consp a) + (bytecomp--copy-tree-1 a) + a))) + (and (consp next) + (let ((tail (gethash next bytecomp--copy-tree-seen))) + (if tail + (progn (setcdr copy tail) + nil) + (setq tree next) + (setq next (cdr next)) + (let ((prev copy)) + (setq copy (cons nil next)) + (setcdr prev copy) + t)))))) + result))) + +(defun bytecomp--copy-tree (tree) + "Make a copy of TREE, preserving any circular structure therein. +Only conses are traversed and duplicated, not arrays or any other structure." + (if (consp tree) + (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq))) + (bytecomp--copy-tree-1 tree)) + tree)) + (defconst byte-compile-initial-macro-environment `( ;; (byte-compiler-options . (lambda (&rest forms) @@ -528,11 +568,12 @@ Return the compile-time value of FORM." ;; or byte-compile-file-form. (let* ((print-symbols-bare t) ; Possibly redundant binding. (expanded - (byte-run-strip-symbol-positions - (macroexpand--all-toplevel - form - macroexpand-all-environment)))) - (eval expanded lexical-binding) + (macroexpand--all-toplevel + form + macroexpand-all-environment))) + (eval (byte-run-strip-symbol-positions + (bytecomp--copy-tree expanded)) + lexical-binding) expanded))))) (with-suppressed-warnings . ,(lambda (warnings &rest body) @@ -541,15 +582,19 @@ Return the compile-time value of FORM." ;; Later `internal--with-suppressed-warnings' binds it again, this ;; time in order to affect warnings emitted during the ;; compilation itself. - (let ((byte-compile--suppressed-warnings - (append warnings byte-compile--suppressed-warnings))) - ;; This function doesn't exist, but is just a placeholder - ;; symbol to hook up with the - ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. - `(internal--with-suppressed-warnings - ',warnings - ,(macroexpand-all `(progn ,@body) - macroexpand-all-environment)))))) + (if body + (let ((byte-compile--suppressed-warnings + (append warnings byte-compile--suppressed-warnings))) + ;; This function doesn't exist, but is just a placeholder + ;; symbol to hook up with the + ;; `byte-hunk-handler'/`byte-defop-compiler-1' machinery. + `(internal--with-suppressed-warnings + ',warnings + ,(macroexpand-all `(progn ,@body) + macroexpand-all-environment))) + (macroexp-warn-and-return + (format-message "`with-suppressed-warnings' with empty body") + nil '(empty-body with-suppressed-warnings) t warnings))))) "The default macro-environment passed to macroexpand by the compiler. Placing a macro here will cause a macro to have different semantics when expanded by the compiler as when expanded by the interpreter.") @@ -1569,7 +1614,7 @@ extra args." "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) -(dolist (elt '(format message error)) +(dolist (elt '(format message format-message error)) (put elt 'byte-compile-format-like t)) (defun byte-compile--suspicious-defcustom-choice (type) @@ -1766,10 +1811,16 @@ It is too wide if it has any lines longer than the largest of kind name col)) ;; There's a "naked" ' character before a symbol/list, so it ;; should probably be quoted with \=. - (when (string-match-p "\\( [\"#]\\|[ \t]\\|^\\)'[a-z(]" docs) + (when (string-match-p (rx (| (in " \t") bol) + (? (in "\"#")) + "'" + (in "A-Za-z" "(")) + docs) (byte-compile-warn-x - name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)" - kind name)) + name + (concat "%s%sdocstring has wrong usage of unescaped single quotes" + " (use \\=%c or different quoting such as %c...%c)") + kind name ?' ?` ?')) ;; There's a "Unicode quote" in the string -- it should probably ;; be an ASCII one instead. (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes) @@ -3405,7 +3456,7 @@ lambda-expression." (let* ((fn (car form)) (handler (get fn 'byte-compile)) (interactive-only - (or (get fn 'interactive-only) + (or (function-get fn 'interactive-only) (memq fn byte-compile-interactive-only-functions)))) (when (memq fn '(set symbol-value run-hooks ;; add-to-list add-hook remove-hook run-hook-with-args @@ -3432,15 +3483,98 @@ lambda-expression." (format "; %s" (substitute-command-keys interactive-only))) - ((and (symbolp 'interactive-only) + ((and (symbolp interactive-only) (not (eq interactive-only t))) (format-message "; use `%s' instead." interactive-only)) (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error - (format "`%s' defined after use in %S (missing `require' of a library file?)" + (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) @@ -3474,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)))) @@ -3736,7 +3866,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" '((0 . byte-compile-no-args) (1 . byte-compile-one-arg) (2 . byte-compile-two-args) - (2-and . byte-compile-and-folded) + (2-cmp . byte-compile-cmp) (3 . byte-compile-three-args) (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) @@ -3815,11 +3945,11 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) (byte-defop-compiler set 2) -(byte-defop-compiler (= byte-eqlsign) 2-and) -(byte-defop-compiler (< byte-lss) 2-and) -(byte-defop-compiler (> byte-gtr) 2-and) -(byte-defop-compiler (<= byte-leq) 2-and) -(byte-defop-compiler (>= byte-geq) 2-and) +(byte-defop-compiler (= byte-eqlsign) 2-cmp) +(byte-defop-compiler (< byte-lss) 2-cmp) +(byte-defop-compiler (> byte-gtr) 2-cmp) +(byte-defop-compiler (<= byte-leq) 2-cmp) +(byte-defop-compiler (>= byte-geq) 2-cmp) (byte-defop-compiler get 2) (byte-defop-compiler nth 2) (byte-defop-compiler substring 1-3) @@ -3883,18 +4013,20 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (nth 2 form)) (byte-compile-out (get (car form) 'byte-opcode) 0))) -(defun byte-compile-and-folded (form) - "Compile calls to functions like `<='. -These implicitly `and' together a bunch of two-arg bytecodes." - (let ((l (length form))) - (cond - ((< l 3) (byte-compile-form `(progn ,(nth 1 form) t))) - ((= l 3) (byte-compile-two-args form)) - ;; Don't use `cl-every' here (see comment where we require cl-lib). - ((not (memq nil (mapcar #'macroexp-copyable-p (nthcdr 2 form)))) - (byte-compile-form `(and (,(car form) ,(nth 1 form) ,(nth 2 form)) - (,(car form) ,@(nthcdr 2 form))))) - (t (byte-compile-normal-call form))))) +(defun byte-compile-cmp (form) + "Compile calls to numeric comparisons such as `<', `=' etc." + ;; Lisp-level transforms should already have reduced valid calls to 2 args. + (if (not (= (length form) 3)) + (byte-compile-subr-wrong-args form "1 or more") + (byte-compile-two-args + (if (macroexp-const-p (nth 1 form)) + ;; First argument is constant: flip it so that the constant + ;; is last, which may allow more lapcode optimisations. + (let* ((op (car form)) + (flipped-op (cdr (assq op '((< . >) (<= . >=) + (> . <) (>= . <=) (= . =)))))) + (list flipped-op (nth 2 form) (nth 1 form))) + form)))) (defun byte-compile-three-args (form) (if (not (= (length form) 4)) @@ -4049,9 +4181,15 @@ This function is never called when `lexical-binding' is nil." (byte-compile-constant 1) (byte-compile-out (get '* 'byte-opcode) 0)) (3 - (byte-compile-form (nth 1 form)) - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0)) + (let ((arg1 (nth 1 form)) + (arg2 (nth 2 form))) + (when (and (memq (car form) '(+ *)) + (macroexp-const-p arg1)) + ;; Put constant argument last for better LAP optimisation. + (cl-rotatef arg1 arg2)) + (byte-compile-form arg1) + (byte-compile-form arg2) + (byte-compile-out (get (car form) 'byte-opcode) 0))) (_ ;; >2 args: compile as a single function call. (byte-compile-normal-call form)))) @@ -4310,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. @@ -4571,6 +4710,7 @@ Return (TAIL VAR TEST CASES), where: (if switch-prefix (progn (byte-compile-cond-jump-table (cdr switch-prefix) donetag) + (setq clause nil) (setq clauses (car switch-prefix))) (setq clause (car clauses)) (cond ((or (eq (car clause) t) @@ -4835,6 +4975,11 @@ binding slots have been popped." (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) + (when (and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (byte-compile-warn-x + condition "`condition-case' condition should not be quoted: %S" + condition)) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) @@ -5055,7 +5200,10 @@ binding slots have been popped." (defun byte-compile-suppressed-warnings (form) (let ((byte-compile--suppressed-warnings (append (cadadr form) byte-compile--suppressed-warnings))) - (byte-compile-form (macroexp-progn (cddr form))))) + ;; Propagate the for-effect mode explicitly so that warnings about + ;; ignored return values can be detected and suppressed correctly. + (byte-compile-form (macroexp-progn (cddr form)) byte-compile--for-effect) + (setq byte-compile--for-effect nil))) ;; Warn about misuses of make-variable-buffer-local. (byte-defop-compiler-1 make-variable-buffer-local @@ -5487,6 +5635,83 @@ and corresponding effects." (eval form) form))) +;; Check for (in)comparable constant values in calls to `eq', `memq' etc. + +(defun bytecomp--dodgy-eq-arg-p (x number-ok) + "Whether X is a bad argument to `eq' (or `eql' if NUMBER-OK is non-nil)." + (pcase x + ((or `(quote ,(pred consp)) `(function (lambda . ,_))) t) + ((or (pred consp) (pred symbolp)) nil) + ((pred integerp) + (not (or (<= -536870912 x 536870911) number-ok))) + ((pred floatp) (not number-ok)) + (_ t))) + +(defun bytecomp--value-type-description (x) + (cond + ((proper-list-p x) "list") + ((recordp x) "record") + (t (symbol-name (type-of x))))) + +(defun bytecomp--arg-type-description (x) + (pcase x + (`(function (lambda . ,_)) "function") + (`(quote . ,val) (bytecomp--value-type-description val)) + (_ (bytecomp--value-type-description x)))) + +(defun bytecomp--warn-dodgy-eq-arg (form type parenthesis) + (macroexp-warn-and-return + (format-message "`%s' called with literal %s that may never match (%s)" + (car form) type parenthesis) + form (list 'suspicious (car form)) t)) + +(defun bytecomp--check-eq-args (form &optional a b &rest _ignore) + (let* ((number-ok (eq (car form) 'eql)) + (bad-arg (cond ((bytecomp--dodgy-eq-arg-p a number-ok) 1) + ((bytecomp--dodgy-eq-arg-p b number-ok) 2)))) + (if bad-arg + (bytecomp--warn-dodgy-eq-arg + form + (bytecomp--arg-type-description (nth bad-arg form)) + (format "arg %d" bad-arg)) + form))) + +(put 'eq 'compiler-macro #'bytecomp--check-eq-args) +(put 'eql 'compiler-macro #'bytecomp--check-eq-args) + +(defun bytecomp--check-memq-args (form &optional elem list &rest _ignore) + (let* ((fn (car form)) + (number-ok (eq fn 'memql))) + (cond + ((bytecomp--dodgy-eq-arg-p elem number-ok) + (bytecomp--warn-dodgy-eq-arg + form (bytecomp--arg-type-description elem) "arg 1")) + ((and (consp list) (eq (car list) 'quote) + (proper-list-p (cadr list))) + (named-let loop ((elts (cadr list)) (i 1)) + (if elts + (let* ((elt (car elts)) + (x (cond ((eq fn 'assq) (car-safe elt)) + ((eq fn 'rassq) (cdr-safe elt)) + (t elt)))) + (if (or (symbolp x) + (and (integerp x) + (or (<= -536870912 x 536870911) number-ok)) + (and (floatp x) number-ok)) + (loop (cdr elts) (1+ i)) + (bytecomp--warn-dodgy-eq-arg + form (bytecomp--value-type-description x) + (format "element %d of arg 2" i)))) + form))) + (t form)))) + +(put 'memq 'compiler-macro #'bytecomp--check-memq-args) +(put 'memql 'compiler-macro #'bytecomp--check-memq-args) +(put 'assq 'compiler-macro #'bytecomp--check-memq-args) +(put 'rassq 'compiler-macro #'bytecomp--check-memq-args) +(put 'remq 'compiler-macro #'bytecomp--check-memq-args) +(put 'delq 'compiler-macro #'bytecomp--check-memq-args) + (provide 'byte-compile) (provide 'bytecomp) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 5f37db3fe9b..601e2c13d61 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -236,9 +236,9 @@ Returns a form where all lambdas don't have any free variables." (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0))) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) - (format "Unused lexical %s `%S'%s" - varkind (bare-symbol var) - (if suggestions (concat "\n " suggestions) ""))))) + (format-message "Unused lexical %s `%S'%s" + varkind (bare-symbol var) + (if suggestions (concat "\n " suggestions) ""))))) (define-inline cconv--var-classification (binder form) (inline-quote @@ -463,7 +463,7 @@ places where they originally did not directly appear." ; first element is lambda expression (`(,(and `(lambda . ,_) fun) . ,args) ;; FIXME: it's silly to create a closure just to call it. - ;; Running byte-optimize-form earlier will resolve this. + ;; Running byte-optimize-form earlier would resolve this. `(funcall ,(cconv-convert `(function ,fun) env extend) ,@(mapcar (lambda (form) @@ -477,24 +477,45 @@ places where they originally did not directly appear." branch)) cond-forms))) - (`(function (lambda ,args . ,body) . ,_) + (`(function (lambda ,args . ,body) . ,rest) (let* ((docstring (if (eq :documentation (car-safe (car body))) (cconv-convert (cadr (pop body)) env extend))) (bf (if (stringp (car body)) (cdr body) body)) (if (when (eq 'interactive (car-safe (car bf))) (gethash form cconv--interactive-form-funs))) + (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t) (_ nil))) (cif (when if (cconv-convert if env extend))) - (_ (pcase cif - (`#'(lambda () ,form) (setf (cadr (car bf)) form) (setq cif nil)) - ('nil nil) - ;; The interactive form needs special treatment, so the form - ;; inside the `interactive' won't be used any further. - (_ (setf (cadr (car bf)) nil)))) - (cf (cconv--convert-function args body env form docstring))) + (cf nil)) + ;; TODO: Because we need to non-destructively modify body, this code + ;; is particularly ugly. This should ideally be moved to + ;; cconv--convert-function. + (pcase cif + ('nil (setq bf nil)) + (`#',f + (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) + (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3))) + (setq cif nil)) + ;; The interactive form needs special treatment, so the form + ;; inside the `interactive' won't be used any further. + (_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) + (setq bf `((,f1 . (nil . ,f2)) . ,f3))))) + (when bf + ;; If we modified bf, re-build body and form as + ;; copies with the modified bits. + (setq body (if (stringp (car body)) + (cons (car body) bf) + bf) + form `(function (lambda ,args . ,body) . ,rest)) + ;; Also, remove the current old entry on the alist, replacing + ;; it with the new one. + (let ((entry (pop cconv-freevars-alist))) + (push (cons body (cdr entry)) cconv-freevars-alist))) + (setq cf (cconv--convert-function args body env form docstring)) (if (not cif) ;; Normal case, the interactive form needs no special treatment. cf - `(cconv--interactive-helper ,cf ,cif)))) + `(cconv--interactive-helper + ,cf ,(if wrapped cif `(list 'quote ,cif)))))) (`(internal-make-closure . ,_) (byte-compile-report-error @@ -742,7 +763,8 @@ This function does not return anything but instead fills the (when (eq 'interactive (car-safe (car bf))) (let ((if (cadr (car bf)))) (unless (macroexp-const-p if) ;Optimize this common case. - (let ((f `#'(lambda () ,if))) + (let ((f (if (eq 'function (car-safe if)) if + `#'(lambda (&rest _cconv--dummy) ,if)))) (setf (gethash form cconv--interactive-form-funs) f) (cconv-analyze-form f env)))))) (cconv--analyze-function vrs body-forms env form)) @@ -829,10 +851,13 @@ This function does not return anything but instead fills the (define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form "25.1") (defun cconv-fv (form lexvars dynvars) - "Return the list of free variables in FORM. -LEXVARS is the list of statically scoped vars in the context -and DYNVARS is the list of dynamically scoped vars in the context. -Returns a pair (LEXV . DYNV) of those vars actually used by FORM." + "Return the free variables used in FORM. +FORM is usually a function #\\='(lambda ...), but may be any valid +form. LEXVARS is a list of symbols, each of which is lexically +bound in FORM's context. DYNVARS is a list of symbols, each of +which is dynamically bound in FORM's context. +Returns a cons (LEXV . DYNV), the car and cdr being lists of the +lexically and dynamically bound symbols actually used by FORM." (let* ((fun ;; Wrap FORM into a function because the analysis code we ;; have only computes freevars for functions. @@ -870,11 +895,26 @@ Returns a pair (LEXV . DYNV) of those vars actually used by FORM." (cons fvs dyns))))) (defun cconv-make-interpreted-closure (fun env) + "Make a closure for the interpreter. +This is intended to be called at runtime by the ELisp interpreter (when +the code has not been compiled). +FUN is the closure's source code, must be a lambda form. +ENV is the runtime representation of the lexical environment, +i.e. a list whose elements can be either plain symbols (which indicate +that this symbol should use dynamic scoping) or pairs (SYMBOL . VALUE) +for the lexical bindings." (cl-assert (eq (car-safe fun) 'lambda)) (let ((lexvars (delq nil (mapcar #'car-safe env)))) - (if (null lexvars) - ;; The lexical environment is empty, so there's no need to - ;; look for free variables. + (if (or (null lexvars) + ;; Functions with a `:closure-dont-trim-context' marker + ;; should keep their whole context untrimmed (bug#59213). + (and (eq :closure-dont-trim-context (nth 2 fun)) + ;; Check the function doesn't just return the magic keyword. + (nthcdr 3 fun))) + ;; The lexical environment is empty, or needs to be preserved, + ;; so there's no need to look for free variables. + ;; Attempting to replace ,(cdr fun) by a macroexpanded version + ;; causes bootstrap to fail. `(closure ,env . ,(cdr fun)) ;; We could try and cache the result of the macroexpansion and ;; `cconv-fv' analysis. Not sure it's worth the trouble. 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 152a1fe9434..7fee780a735 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -201,7 +201,7 @@ should return. Note that Emacs Lisp doesn't really support multiple values, so all this function does is return LIST." (unless (listp list) - (signal 'wrong-type-argument list)) + (signal 'wrong-type-argument (list list))) list) (defsubst cl-multiple-value-list (expression) @@ -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 43207ce7026..5382e0a0a52 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2052,7 +2052,8 @@ info node `(cl) Function Bindings' for details. (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding)))) (args-and-body (cdr binding))) - (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) + (if (and (= (length args-and-body) 1) + (macroexp-copyable-p (car args-and-body))) ;; Optimize (cl-flet ((fun var)) body). (setq var (car args-and-body)) (push (list var (if (= (length args-and-body) 1) @@ -2757,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 @@ -2887,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. @@ -3175,8 +3148,9 @@ To see the documentation for a defined struct type, use (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - (format "Missing value for option `%S' of slot `%s' in struct %s!" - (car (last desc)) slot name) + (format-message + "Missing value for option `%S' of slot `%s' in struct %s!" + (car (last desc)) slot name) nil nil nil (car (last desc))) forms) (when (and (keywordp (car defaults)) @@ -3184,8 +3158,9 @@ To see the documentation for a defined struct type, use (let ((kw (car defaults))) (push (macroexp-warn-and-return - (format " I'll take `%s' to be an option rather than a default value." - kw) + (format-message + " I'll take `%s' to be an option rather than a default value." + kw) nil nil nil kw) forms) (push kw desc) @@ -3238,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)) @@ -3684,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 e97832455b9..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. @@ -1241,7 +1242,7 @@ clashes." (defun comp-decrypt-arg-list (x function-name) "Decrypt argument list X for FUNCTION-NAME." (unless (fixnump x) - (signal 'native-compiler-error-dyn-func function-name)) + (signal 'native-compiler-error-dyn-func (list function-name))) (let ((rest (not (= (logand x 128) 0))) (mandatory (logand x 127)) (nonrest (ash x -8))) @@ -1285,7 +1286,7 @@ clashes." 'pure)))) (when (byte-code-function-p f) (signal 'native-compiler-error - "can't native compile an already byte-compiled function")) + '("can't native compile an already byte-compiled function"))) (setf (comp-func-byte-func func) (byte-compile (comp-func-name func))) (let ((lap (byte-to-native-lambda-lap @@ -1309,7 +1310,7 @@ clashes." "Byte-compile FORM, spilling data from the byte compiler." (unless (eq (car-safe form) 'lambda) (signal 'native-compiler-error - "Cannot native-compile, form is not a lambda")) + '("Cannot native-compile, form is not a lambda"))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) @@ -1390,7 +1391,7 @@ clashes." (alist-get 'no-native-compile byte-native-qualities)) (throw 'no-native-compile nil)) (unless byte-to-native-top-level-forms - (signal 'native-compiler-error-empty-byte filename)) + (signal 'native-compiler-error-empty-byte (list filename))) (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (comp-el-to-eln-filename filename @@ -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." @@ -1761,7 +1769,7 @@ Return value is the fall-through block name." do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func)) (setf (comp-limplify-curr-block comp-pass) ff-bb)))) (_ (signal 'native-ice - "missing previous setimm while creating a switch")))) + '("missing previous setimm while creating a switch"))))) (defun comp--func-arity (subr-name) "Like `func-arity' but invariant against primitive redefinitions. @@ -2849,7 +2857,7 @@ blocks." (first-processed (l) (if-let ((p (cl-find-if (lambda (p) (comp-block-idom p)) l))) p - (signal 'native-ice "can't find first preprocessed")))) + (signal 'native-ice '("can't find first preprocessed"))))) (when-let ((blocks (comp-func-blocks comp-func)) (entry (gethash 'entry blocks)) @@ -3748,7 +3756,7 @@ Prepare every function for final compilation and drive the C back-end." (progn (delete-file temp-file) output) - (signal 'native-compiler-error (buffer-string))) + (signal 'native-compiler-error (list (buffer-string)))) (comp-log-to-buffer (buffer-string)))))))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 0f6711209a5..84e131147cd 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -250,7 +250,8 @@ INIT-VALUE LIGHTER KEYMAP. (warnwrap (if (or (null body) (keywordp (car body))) #'identity (lambda (exp) (macroexp-warn-and-return - "Use keywords rather than deprecated positional arguments to `define-minor-mode'" + (format-message + "Use keywords rather than deprecated positional arguments to `define-minor-mode'") exp)))) keyw keymap-sym tmp) @@ -417,6 +418,8 @@ No problems result if this variable is not bound. `(defvar ,keymap-sym (let ((m ,keymap)) (cond ((keymapp m) m) + ;; FIXME: `easy-mmode-define-keymap' is obsolete, + ;; so this form should also be obsolete somehow. ((listp m) (with-suppressed-warnings ((obsolete easy-mmode-define-keymap)) @@ -690,6 +693,7 @@ Valid keywords and arguments are: :group Ignored. :suppress Non-nil to call `suppress-keymap' on keymap, `nodigits' to suppress digits as prefix arguments." + (declare (obsolete define-keymap "29.1")) (let (inherit dense suppress) (while args (let ((key (pop args)) @@ -730,9 +734,7 @@ The M, BS, and ARGS arguments are as per that function. DOC is the constant's documentation. This macro is deprecated; use `defvar-keymap' instead." - ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still - ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first. - (declare (doc-string 3) (indent 1)) + (declare (doc-string 3) (indent 1) (obsolete defvar-keymap "29.1")) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 2f7d03e9d79..9a06807bcdc 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1225,8 +1225,10 @@ purpose by adding an entry to this alist, and setting ;; But the list will just be reversed. ,@(nreverse edebug-def-args)) 'nil) - (function (lambda () ,@forms)) - )) + ;; Make sure `forms' is not nil so we don't accidentally return + ;; the magic keyword. Mark the closure so we don't throw away + ;; unused vars (bug#59213). + #'(lambda () :closure-dont-trim-context ,@(or forms '(nil))))) (defvar edebug-form-begin-marker) ; the mark for def being instrumented @@ -2851,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/eieio.el b/lisp/emacs-lisp/eieio.el index 064a55f2727..9a1f5b9db0f 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -184,8 +184,9 @@ and reference them using the function `class-option'." (when (and initarg (eq alloc :class)) (push (cons sname - (format "Meaningless :initarg for class allocated slot '%S'" - sname)) + (format-message + "Meaningless :initarg for class allocated slot `%S'" + sname)) warnings)) (let ((init (plist-get soptions :initform))) diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a175edcc671..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 @@ -296,13 +296,9 @@ reflect the change." This function displays the message produced by formatting ARGS with FORMAT-STRING on the mode line when the current buffer is a minibuffer. Otherwise, it displays the message like `message' would." - (if (minibufferp) + (if (or (bound-and-true-p edebug-mode) (minibufferp)) (progn - (add-hook 'minibuffer-exit-hook - (lambda () (setq eldoc-mode-line-string nil - ;; https://debbugs.gnu.org/16920 - eldoc-last-message nil)) - nil t) + (add-hook 'post-command-hook #'eldoc-minibuffer--cleanup) (with-current-buffer (window-buffer (or (window-in-direction 'above (minibuffer-window)) @@ -321,6 +317,13 @@ Otherwise, it displays the message like `message' would." (force-mode-line-update))) (apply #'message format-string args))) +(defun eldoc-minibuffer--cleanup () + (unless (or (bound-and-true-p edebug-mode) (minibufferp)) + (setq eldoc-mode-line-string nil + ;; https://debbugs.gnu.org/16920 + eldoc-last-message nil) + (remove-hook 'post-command-hook #'eldoc-minibuffer--cleanup))) + (make-obsolete 'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0") (defun eldoc-message (&optional string) (eldoc--message string)) @@ -388,7 +391,6 @@ Also store it in `eldoc-last-message' and return that value." (defun eldoc-display-message-no-interference-p () "Return nil if displaying a message would cause interference." (not (or executing-kbd-macro - (bound-and-true-p edebug-active) ;; The following configuration shows "Matches..." in the ;; echo area when point is after a closing bracket, which ;; conflicts with eldoc. @@ -435,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 @@ -446,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) @@ -469,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. @@ -488,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'." @@ -613,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)))))) @@ -642,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))) @@ -778,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 @@ -798,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. @@ -836,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 @@ -848,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 @@ -856,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)) @@ -868,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 6adba6c342f..ac001af06bd 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -417,9 +417,9 @@ The return value is the last VAL in the list. (lambda (do key alist &optional default remove testfn) (macroexp-let2 macroexp-copyable-p k key (gv-letplace (getter setter) alist - (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq))) - (assoc ,k ,getter ,testfn) - (assq ,k ,getter)) + (macroexp-let2 nil p (if (member testfn '(nil 'eq #'eq)) + `(assq ,k ,getter) + `(assoc ,k ,getter ,testfn)) (funcall do (if (null default) `(cdr ,p) `(if ,p (cdr ,p) ,default)) (lambda (v) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index e3ed28f097a..417c218c6d7 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -519,6 +519,7 @@ major mode's decisions about context.") "Return the \"far end\" position of the buffer, in direction ARG. If ARG is positive, that's the end of the buffer. Otherwise, that's the beginning of the buffer." + (declare (side-effect-free error-free)) (if (> arg 0) (point-max) (point-min))) (defun end-of-defun (&optional arg interactive) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168de1bf180..b05aba3e1a7 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -291,10 +291,11 @@ It should normally be a symbol with position and it defaults to FORM." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return - (format (if (eq values 'too-few) - "attempt to open-code `%s' with too few arguments" - "attempt to open-code `%s' with too many arguments") - name) + (format-message + (if (eq values 'too-few) + "attempt to open-code `%s' with too few arguments" + "attempt to open-code `%s' with too many arguments") + name) form nil nil arglist) ;; The following leads to infinite recursion when loading a @@ -338,14 +339,19 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(cond . ,clauses) (macroexp--cons fn (macroexp--all-clauses clauses) form)) (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - fn - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) + (let ((exp-body (macroexp--expand-all body))) + (if handlers + (macroexp--cons fn + (macroexp--cons + err (macroexp--cons + exp-body + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form) + (macroexp-warn-and-return + (format-message "`condition-case' without handlers") + exp-body (list 'suspicious 'condition-case) t form)))) (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) (push name macroexp--dynvars) (macroexp--all-forms form 2)) @@ -367,16 +373,21 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) + (format-message "`%s' with empty body" fun) + nil (list 'empty-body fun) 'compile-only fun)) (macroexp--all-forms body)) (cdr form)) form))) (`(while) (macroexp-warn-and-return - "missing `while' condition" + (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) @@ -392,7 +403,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((nargs (length args))) (if (/= (logand nargs 1) 0) (macroexp-warn-and-return - "odd number of arguments in `setq' form" + (format-message "odd number of arguments in `setq' form") `(signal 'wrong-number-of-arguments '(setq ,nargs)) nil 'compile-only fn) (let ((assignments nil)) @@ -457,12 +468,13 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((arg (nth funarg form))) (when (and (eq 'quote (car-safe arg)) (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg nil nil (cadr arg)))))) + (setcar + (nthcdr funarg form) + (macroexp-warn-and-return + (format + "(lambda %s ...) quoted with ' rather than with #'" + (or (nth 1 (cadr arg)) "()")) + arg nil nil (cadr arg)))))) ;; Macro expand compiler macros. This cannot be delayed to ;; byte-optimize-form because the output of the compiler-macro can ;; use macros. @@ -486,7 +498,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form (macroexp--compiler-macro handler newform)) (if (eq newform form) newform - (macroexp--expand-all newform))) + (macroexp--expand-all form))) (macroexp--expand-all newform)))))) (_ form)))) (pop byte-compile-form-stack))) @@ -494,7 +506,7 @@ Assumes the caller has bound `macroexpand-all-environment'." ;; Record which arguments expect functions, so we can warn when those ;; are accidentally quoted with ' rather than with #' (dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash - map-char-table map-keymap map-keymap-internal)) + mapcan map-char-table map-keymap map-keymap-internal)) (put f 'funarg-positions '(1))) (dolist (f '( add-hook remove-hook advice-remove advice--remove-function defalias fset global-set-key run-after-idle-timeout diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 85934d9ed0a..e457387acc9 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -178,20 +178,38 @@ DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") ;; ((functionp spec) (funcall spec)) (t (eval spec)))) +(defun advice--interactive-form-1 (function) + "Like `interactive-form' but preserves the static context if needed." + (let ((if (interactive-form function))) + (if (or (null if) (not (eq 'closure (car-safe function)))) + if + (cl-assert (eq 'interactive (car if))) + (let ((form (cadr if))) + (if (macroexp-const-p form) + if + ;; The interactive is expected to be run in the static context + ;; that the function captured. + (let ((ctx (nth 1 function))) + `(interactive + ,(let* ((f (if (eq 'function (car-safe form)) (cadr form) form))) + ;; If the form jut returns a function, preserve the fact that + ;; it just returns a function, which is an info we use in + ;; `advice--make-interactive-form'. + (if (eq 'lambda (car-safe f)) + `',(eval form ctx) + `(eval ',form ',ctx)))))))))) + (defun advice--interactive-form (function) "Like `interactive-form' but tries to avoid autoloading functions." (if (not (and (symbolp function) (autoloadp (indirect-function function)))) - (interactive-form function) + (advice--interactive-form-1 function) (when (commandp function) `(interactive (advice-eval-interactive-spec - (cadr (interactive-form ',function))))))) + (cadr (advice--interactive-form-1 ',function))))))) (defun advice--make-interactive-form (iff ifm) - ;; TODO: make it so that interactive spec can be a constant which - ;; dynamically checks the advice--car/cdr to do its job. - ;; For that, advice-eval-interactive-spec needs to be more faithful. (let* ((fspec (cadr iff))) - (when (eq 'function (car-safe fspec)) ;; Macroexpanded lambda? + (when (memq (car-safe fspec) '(function quote)) ;; Macroexpanded lambda? (setq fspec (eval fspec t))) (if (functionp fspec) `(funcall ',fspec ',(cadr ifm)) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index f5a150ac4ae..40f1f54eed0 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -568,7 +568,7 @@ This has 2 uses: (defun cconv--interactive-helper (fun if) "Add interactive \"form\" IF to FUN. Returns a new command that otherwise behaves like FUN. -IF should actually not be a form but a function of no arguments." +IF can be an ELisp form to be interpreted or a function of no arguments." (oclosure-lambda (cconv--interactive-helper (fun fun) (if if)) (&rest args) (apply (if (called-interactively-p 'any) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index af57095f8ce..a72bb084d31 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -112,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 @@ -534,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' @@ -555,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 f92afe56b76..685f983e285 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -378,10 +378,8 @@ If so, and variable `package-check-signature' is `allow-unsigned', return `allow-unsigned', otherwise return the value of variable `package-check-signature'." (if (eq package-check-signature 'allow-unsigned) - (progn - (require 'epg-config) - (and (epg-find-configuration 'OpenPGP) - 'allow-unsigned)) + (and (epg-find-configuration 'OpenPGP) + 'allow-unsigned) package-check-signature)) (defcustom package-unsigned-archives nil @@ -958,7 +956,6 @@ Newer versions are always activated, regardless of FORCE." "Untar the current buffer. This uses `tar-untar-buffer' from Tar mode. All files should untar into a directory named DIR; otherwise, signal an error." - (require 'tar-mode) (tar-mode) ;; Make sure everything extracts into DIR. (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/")) @@ -1221,15 +1218,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)) @@ -3086,8 +3082,7 @@ The most useful commands here are: `[("Package" ,package-name-column-width package-menu--name-predicate) ("Version" ,package-version-column-width package-menu--version-predicate) ("Status" ,package-status-column-width package-menu--status-predicate) - ,@(if (cdr package-archives) - `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) + ("Archive" ,package-archive-column-width package-menu--archive-predicate) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) @@ -3515,9 +3510,8 @@ Return (PKG-DESC [NAME VERSION STATUS DOC])." (package-desc-version pkg))) 'font-lock-face face) ,(propertize status 'font-lock-face face) - ,@(if (cdr package-archives) - (list (propertize (or (package-desc-archive pkg) "") - 'font-lock-face face))) + ,(propertize (or (package-desc-archive pkg) "") + 'font-lock-face face) ,(propertize (package-desc-summary pkg) 'font-lock-face 'package-description)]))) @@ -4562,6 +4556,7 @@ will be signaled in that case." (package--print-email-button maint) (string-trim (substring-no-properties (buffer-string)))))))) +;;;###autoload (defun package-report-bug (desc) "Prepare a message to send to the maintainers of a package. DESC must be a `package-desc' object." diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 810b13f61d6..1c5ce5169ab 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -947,7 +947,7 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - "Pattern t is deprecated. Use `_' instead" + (format-message "Pattern t is deprecated. Use `_' instead") code nil nil upat)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) diff --git a/lisp/emacs-lisp/range.el b/lisp/emacs-lisp/range.el index 1165fcbbd7d..f441c240a27 100644 --- a/lisp/emacs-lisp/range.el +++ b/lisp/emacs-lisp/range.el @@ -194,7 +194,7 @@ these ranges." (nreverse result))))) (defun range-add-list (ranges list) - "Return a list of ranges that has all articles from both RANGES and LIST. + "Return a list of ranges that has all numbers from both RANGES and LIST. Note: LIST has to be sorted over `<'." (if (not ranges) (range-compress-list list) @@ -249,9 +249,9 @@ Note: LIST has to be sorted over `<'." out))) (defun range-remove (range1 range2) - "Return a range that has all articles from RANGE2 removed from RANGE1. + "Return a range that has all numbers from RANGE2 removed from RANGE1. The returned range is always a list. RANGE2 can also be a unsorted -list of articles. RANGE1 is modified by side effects, RANGE2 is not +list of numbers. RANGE1 is modified by side effects, RANGE2 is not modified." (if (or (null range1) (null range2)) range1 @@ -345,7 +345,7 @@ modified." (defun range-list-intersection (list ranges) "Return a list of numbers in LIST that are members of RANGES. -oLIST is a sorted list." +LIST is a sorted list." (setq ranges (range-normalize ranges)) (let (number result) (while (setq number (pop list)) diff --git a/lisp/emacs-lisp/regexp-opt.el b/lisp/emacs-lisp/regexp-opt.el index e64a3dcea1e..fd9fbbe25a4 100644 --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@ -130,6 +130,7 @@ usually more efficient than that of a simplified version: (concat (car parens) (mapconcat \\='regexp-quote strings \"\\\\|\") (cdr parens))))" + (declare (pure t) (side-effect-free t)) (save-match-data ;; Recurse on the sorted list. (let* ((max-lisp-eval-depth 10000) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index c49960c2ee6..9a6f5dd12ce 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -1443,45 +1443,52 @@ If SAME-WINDOW, don't pop to a new window." (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (funcall (if same-window - #'pop-to-buffer-same-window - #'pop-to-buffer) - (format "*Shortdoc %s*" group)) - (let ((inhibit-read-only t) - (prev nil)) - (erase-buffer) - (shortdoc-mode) - (button-mode) - (mapc - (lambda (data) - (cond - ((stringp data) - (setq prev nil) - (unless (bobp) - (insert "\n")) - (insert (propertize - (substitute-command-keys data) - 'face 'shortdoc-heading - 'shortdoc-section t - 'outline-level 1)) - (insert (propertize - "\n\n" - 'face 'shortdoc-heading - 'shortdoc-section t))) - ;; There may be functions not yet defined in the data. - ((fboundp (car data)) - (when prev - (insert (make-separator-line) - ;; This helps with hidden outlines (bug#53981) - (propertize "\n" 'face '(:height 0)))) - (setq prev t) - (shortdoc--display-function data)))) - (cdr (assq group shortdoc--groups)))) + (let ((buf (get-buffer-create (format "*Shortdoc %s*" group)))) + (shortdoc--insert-group-in-buffer group buf) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + buf)) (goto-char (point-min)) (when function (text-property-search-forward 'shortdoc-function function t) (beginning-of-line))) +(defun shortdoc--insert-group-in-buffer (group &optional buf) + "Insert a short documentation summary for functions in GROUP in buffer BUF. +BUF defaults to the current buffer if nil or omitted." + (with-current-buffer (or buf (current-buffer)) + (let ((inhibit-read-only t) + (prev nil)) + (erase-buffer) + (shortdoc-mode) + (button-mode) + (mapc + (lambda (data) + (cond + ((stringp data) + (setq prev nil) + (unless (bobp) + (insert "\n")) + (insert (propertize + (substitute-command-keys data) + 'face 'shortdoc-heading + 'shortdoc-section t + 'outline-level 1)) + (insert (propertize + "\n\n" + 'face 'shortdoc-heading + 'shortdoc-section t))) + ;; There may be functions not yet defined in the data. + ((fboundp (car data)) + (when prev + (insert (make-separator-line) + ;; This helps with hidden outlines (bug#53981) + (propertize "\n" 'face '(:height 0)))) + (setq prev t) + (shortdoc--display-function data)))) + (cdr (assq group shortdoc--groups)))))) + ;;;###autoload (defalias 'shortdoc #'shortdoc-display-group) @@ -1521,7 +1528,8 @@ function's documentation in the Info manual")) "=>")) (single-arrow (if (char-displayable-p ?→) "→" - "->"))) + "->")) + (start-example (point))) (cl-loop for (type value) on data by #'cddr do (cl-case type @@ -1572,7 +1580,8 @@ function's documentation in the Info manual")) (:eg-result-string (insert " e.g. " double-arrow " ") (princ value (current-buffer)) - (insert "\n"))))) + (insert "\n")))) + (add-text-properties start-example (point) `(shortdoc-example ,function))) ;; Insert the arglist after doing the evals, in case that's pulled ;; in the function definition. (save-excursion @@ -1582,6 +1591,73 @@ function's documentation in the Info manual")) (insert " " (symbol-name param))) (add-face-text-property arglist-start (point) 'shortdoc-section t)))) +(defun shortdoc-function-examples (function) + "Return all shortdoc examples for FUNCTION. +The result is an alist with items of the form (GROUP . EXAMPLES), +where GROUP is a shortdoc group where FUNCTION appears, and +EXAMPLES is a string with the usage examples of FUNCTION defined +in GROUP. Return nil if FUNCTION is not a function or if it +doesn't has any shortdoc information." + (let ((groups (and (symbolp function) + (shortdoc-function-groups function))) + (examples nil)) + (mapc + (lambda (group) + (with-temp-buffer + (shortdoc--insert-group-in-buffer group) + (goto-char (point-min)) + (let ((match (text-property-search-forward + 'shortdoc-example function t))) + (push `(,group . ,(string-trim + (buffer-substring-no-properties + (prop-match-beginning match) + (prop-match-end match)))) + examples)))) + groups) + examples)) + +(defun shortdoc-help-fns-examples-function (function) + "Insert Emacs Lisp examples for FUNCTION into the current buffer. +You can add this function to the `help-fns-describe-function-functions' +hook to show examples of using FUNCTION in *Help* buffers produced +by \\[describe-function]." + (let* ((examples (shortdoc-function-examples function)) + (num-examples (length examples)) + (times 0)) + (dolist (example examples) + (when (zerop times) + (if (> num-examples 1) + (insert "\n Examples:\n\n") + ;; Some functions have more than one example per group. + ;; Count the number of arrows to know if we need to + ;; pluralize "Example". + (let* ((text (cdr example)) + (count 0) + (pos 0) + (end (length text)) + (double-arrow (if (char-displayable-p ?⇒) + " ⇒" + " =>")) + (double-arrow-example (if (char-displayable-p ?⇒) + " e.g. ⇒" + " e.g. =>")) + (single-arrow (if (char-displayable-p ?→) + " →" + " ->"))) + (while (and (< pos end) + (or (string-match double-arrow text pos) + (string-match double-arrow-example text pos) + (string-match single-arrow text pos))) + (setq count (1+ count) + pos (match-end 0))) + (if (> count 1) + (insert "\n Examples:\n\n") + (insert "\n Example:\n\n"))))) + (setq times (1+ times)) + (insert " ") + (insert (cdr example)) + (insert "\n\n")))) + (defun shortdoc-function-groups (function) "Return all shortdoc groups FUNCTION appears in." (cl-loop for group in shortdoc--groups diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 8cdbdf1ef6a..947390b3de3 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -102,6 +102,7 @@ threading." "Join all STRINGS using SEPARATOR. Optional argument SEPARATOR must be a string, a vector, or a list of characters; nil stands for the empty string." + (declare (pure t) (side-effect-free t)) (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -112,6 +113,7 @@ characters; nil stands for the empty string." When truncating, \"...\" is always prepended to the string, so the resulting string may be longer than the original if LENGTH is 3 or smaller." + (declare (pure t) (side-effect-free t)) (let ((strlen (length string))) (if (<= strlen length) string @@ -124,16 +126,19 @@ the resulting string may be longer than the original if LENGTH is "Check whether STRING is either empty or only whitespace. The following characters count as whitespace here: space, tab, newline and carriage return." + (declare (pure t) (side-effect-free t)) (string-match-p "\\`[ \t\n\r]*\\'" string)) (defsubst string-remove-prefix (prefix string) "Remove PREFIX from STRING if present." + (declare (pure t) (side-effect-free t)) (if (string-prefix-p prefix string) (substring string (length prefix)) string)) (defsubst string-remove-suffix (suffix string) "Remove SUFFIX from STRING if present." + (declare (pure t) (side-effect-free t)) (if (string-suffix-p suffix string) (substring string 0 (- (length string) (length suffix))) string)) @@ -252,6 +257,7 @@ is done. If START is nil (or not present), the padding is done to the end of the string, and if non-nil, padding is done to the start of the string." + (declare (pure t) (side-effect-free t)) (unless (natnump length) (signal 'wrong-type-argument (list 'natnump length))) (let ((pad-length (- length (length string)))) @@ -261,6 +267,7 @@ the string." (defun string-chop-newline (string) "Remove the final newline (if any) from STRING." + (declare (pure t) (side-effect-free t)) (string-remove-suffix "\n" string)) (defun replace-region-contents (beg end replace-fn diff --git a/lisp/emacs-lisp/unsafep.el b/lisp/emacs-lisp/unsafep.el index 1d3cde69392..e722cbc52dd 100644 --- a/lisp/emacs-lisp/unsafep.el +++ b/lisp/emacs-lisp/unsafep.el @@ -237,7 +237,7 @@ Otherwise result is a reason code." ((eq (car-safe fun) 'lambda) (unsafep fun unsafep-vars)) ((not (and (symbolp fun) - (or (get fun 'side-effect-free) + (or (function-get fun 'side-effect-free) (eq (get fun 'safe-function) t) (eq safe-functions t) (memq fun safe-functions)))) diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index abadefb7105..c0aa9dd7b46 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -194,9 +194,9 @@ viper-delete-backward-char viper-join-lines viper-delete-char)) - (memq (viper-event-key last-command-event) - '(up down left right (meta f) (meta b) - (control n) (control p) (control f) (control b))))) + (member (viper-event-key last-command-event) + '(up down left right (meta f) (meta b) + (control n) (control p) (control f) (control b))))) (defsubst viper-insert-state-pre-command-sentinel () (or (viper-preserve-cursor-color) @@ -466,6 +466,12 @@ ;; Viper mode-changing commands and utilities +(defcustom viper-enable-minibuffer-faces t + "If non-nil, viper uses distinct faces in the minibuffer." + :type 'boolean + :version "30.1" + :group 'viper-misc) + ;; Modifies mode-line-buffer-identification. (defun viper-refresh-mode-line () (setq-local viper-mode-string @@ -561,14 +567,14 @@ )) ;; minibuffer faces - (if (viper-has-face-support-p) + (if (and (viper-has-face-support-p) viper-enable-minibuffer-faces) (setq viper-minibuffer-current-face (cond ((eq state 'emacs-state) viper-minibuffer-emacs-face) ((eq state 'vi-state) viper-minibuffer-vi-face) ((memq state '(insert-state replace-state)) viper-minibuffer-insert-face)))) - (if (viper-is-in-minibuffer) + (if (and (viper-is-in-minibuffer) viper-enable-minibuffer-faces) (viper-set-minibuffer-overlay)) ) @@ -716,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 @@ -1705,8 +1707,8 @@ to in the global map, instead of cycling through the insertion ring." (if (eq viper-current-state 'replace-state) (undo 1) (if viper-last-inserted-string-from-insertion-ring - (backward-delete-char - (length viper-last-inserted-string-from-insertion-ring)))) + (delete-char + (- (length viper-last-inserted-string-from-insertion-ring))))) ) ;;first search through insertion history (setq viper-temp-insertion-ring (ring-copy viper-insertion-ring))) @@ -1944,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/env.el b/lisp/env.el index 33c02f6f920..faafcb6250f 100644 --- a/lisp/env.el +++ b/lisp/env.el @@ -204,6 +204,7 @@ parameter. Otherwise, this function searches `process-environment' for VARIABLE. If it is not found there, then it continues the search in the environment list of the selected frame." + (declare (side-effect-free t)) (interactive (list (read-envvar-name "Get environment variable: " t))) (let ((value (getenv-internal (if (multibyte-string-p variable) (encode-coding-string 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-alias.el b/lisp/eshell/em-alias.el index 1be070480b3..841982c3425 100644 --- a/lisp/eshell/em-alias.el +++ b/lisp/eshell/em-alias.el @@ -183,7 +183,9 @@ file named by `eshell-aliases-file'.") (pcomplete-here (eshell-alias-completions pcomplete-stub))) (defun eshell-read-aliases-list () - "Read in an aliases list from `eshell-aliases-file'." + "Read in an aliases list from `eshell-aliases-file'. +This is useful after manually editing the contents of the file." + (interactive) (let ((file eshell-aliases-file)) (when (file-readable-p file) (setq eshell-command-aliases-list diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el index 8bc497bdeb3..2bee50b80a4 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -43,7 +43,6 @@ (require 'esh-util) (require 'esh-mode) -(require 'eshell) ;;;###autoload (progn diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index bfff3bdf56e..016afe811b2 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -53,9 +53,10 @@ ;;; Code: -(require 'esh-util) -(require 'eshell) +(require 'esh-cmd) +(require 'esh-io) (require 'esh-opt) +(require 'esh-util) ;;;###autoload (progn diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 4f656b16a8e..732bbb3f1fa 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -74,9 +74,7 @@ (require 'esh-util) (require 'em-dirs) -(eval-when-compile - (require 'cl-lib) - (require 'eshell)) +(eval-when-compile (require 'cl-lib)) ;;;###autoload (progn @@ -306,15 +304,35 @@ to writing a completion function." (insert-and-inherit "\t") (throw 'pcompleted t))) +(defun eshell-complete--eval-argument-form (arg) + "Evaluate a single Eshell argument form ARG for the purposes of completion." + (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'." (when (and eshell-no-completion-during-jobs (eshell-interactive-process-p)) (eshell--pcomplete-insert-tab)) (let ((end (point-marker)) - (begin (save-excursion (eshell-bol) (point))) - (posns (list t)) - args delim) + (begin (save-excursion (beginning-of-line) (point))) + args posns delim incomplete-arg) (when (and pcomplete-allow-modifications (memq this-command '(pcomplete-expand pcomplete-expand-and-complete))) @@ -322,59 +340,88 @@ 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 ((memq (car delim) '(?\{ ?\<)) - (setq begin (1+ (cadr delim)) - args (eshell-parse-arguments begin end))) - ((eq (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 begin)) - (while (< pos end) - (if (get-text-property pos 'arg-begin) - (nconc posns (list pos))) - (setq pos (1+ pos)))) - (setq posns (cdr posns)) + (let ((pos (1- end))) + (while (>= pos begin) + (when (get-text-property pos 'arg-begin) + (push pos posns)) + (setq pos (1- pos)))) (cl-assert (= (length args) (length posns))) - (let ((a args) - (i 0) - l) + (let ((a args) (i 0) new-start) (while a - (if (and (consp (car a)) - (eq (caar a) 'eshell-operator)) - (setq l i)) - (setq a (cdr a) i (1+ i))) - (and l - (setq args (nthcdr (1+ l) args) - posns (nthcdr (1+ l) posns)))) + ;; If there's an unreplaced `eshell-operator' sigil, consider + ;; the token after it the new start of our arguments. + (when (and (consp (car a)) + (eq (caar a) 'eshell-operator)) + (setq new-start i)) + (setq a (cdr a) + i (1+ i))) + (when new-start + (setq args (nthcdr (1+ new-start) args) + posns (nthcdr (1+ new-start) posns)))) (cl-assert (= (length args) (length posns))) - (when (and args (eq (char-syntax (char-before end)) ? ) + (when (and args (not incomplete-arg) + (eq (char-syntax (char-before end)) ? ) (not (eq (char-before (1- end)) ?\\))) (nconc args (list "")) (nconc posns (list (point)))) + ;; Evaluate and expand Eshell forms. + (let (evaled-args evaled-posns) + (cl-mapc + (lambda (arg posn) + (pcase arg + (`(eshell-splice-args ,val) + (dolist (subarg (eshell-complete--eval-argument-form val)) + (push subarg evaled-args) + (push posn evaled-posns))) + ((pred listp) + (push (eshell-complete--eval-argument-form arg) evaled-args) + (push posn evaled-posns)) + (_ + (push arg evaled-args) + (push posn evaled-posns)))) + args posns) + (setq args (nreverse evaled-args) + posns (nreverse evaled-posns))) + ;; Convert arguments to forms that Pcomplete can understand. (cons (mapcar (lambda (arg) - (let ((val - (if (listp arg) - (let ((result - (eshell-do-eval - (list 'eshell-commands arg) t))) - (cl-assert (eq (car result) 'quote)) - (cadr result)) - arg))) - (cond ((numberp val) - (setq val (number-to-string val))) - ;; expand .../ etc that only eshell understands to - ;; standard ../../ - ((and (stringp val)) (string-match "\\.\\.\\.+/" val) - (setq val (eshell-expand-multiple-dots val)))) - (or val ""))) + (pcase arg + ;; Expand ".../" etc that only Eshell understands to + ;; the standard "../../". + ((rx ".." (+ ".") "/") + (propertize (eshell-expand-multiple-dots arg) + 'pcomplete-arg-value arg)) + ((pred stringp) + arg) + ('nil + (propertize "" 'pcomplete-arg-value arg)) + (_ + (propertize (eshell-stringify arg) + 'pcomplete-arg-value arg)))) args) posns))) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 0d02b64b084..5284df9ab59 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -253,11 +253,26 @@ Thus, this does not include the current directory.") (throw 'eshell-replace-command (eshell-parse-command "cd" (flatten-tree args))))) +(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) - (eq (char-after) ?~)) - (add-to-list 'eshell-current-modifiers 'expand-file-name) + (eq (char-after) ?~)) + (add-to-list 'eshell-current-modifiers #'eshell-expand-user-reference) (forward-char) (char-to-string (char-before)))) @@ -281,15 +296,32 @@ Thus, this does not include the current directory.") (let ((arg (pcomplete-actual-arg))) (when (string-match "\\`~[a-z]*\\'" arg) (setq pcomplete-stub (substring arg 1) - pcomplete-last-completion-raw t) - (throw 'pcomplete-completions - (progn - (eshell-read-user-names) - (pcomplete-uniquify-list - (mapcar - (lambda (user) - (file-name-as-directory (cdr user))) - eshell-user-names))))))) + pcomplete-last-completion-raw t) + (eshell-read-user-names) + (let ((names (pcomplete-uniquify-list + (mapcar (lambda (user) + (file-name-as-directory (cdr user))) + eshell-user-names)))) + (throw 'pcomplete-completions + ;; Provide a programmed completion table. This works + ;; just like completing over the list of names, except + ;; it always returns the completed string for + ;; `try-completion', never `t'. That's because this is + ;; only completing a directory name, and so the + ;; completion isn't actually finished yet. + (lambda (string pred action) + (pcase action + ('nil ; try-completion + (let ((result (try-completion string names pred))) + (if (eq result t) string result))) + ('t ; all-completions + (all-completions string names pred)) + ('lambda ; test-completion + (test-completion string names pred)) + ('metadata + '(metadata (category . file))) + (`(boundaries . ,suffix) + `(boundaries 0 . ,(string-search "/" suffix)))))))))) (defun eshell/pwd (&rest _args) "Change output from `pwd' to be cleaner." diff --git a/lisp/eshell/em-elecslash.el b/lisp/eshell/em-elecslash.el index 80bc0f031ef..2b003f58dc7 100644 --- a/lisp/eshell/em-elecslash.el +++ b/lisp/eshell/em-elecslash.el @@ -72,7 +72,7 @@ insertion." (delete-char -1) (let ((tilde-before (eq ?~ (char-before))) (command (save-excursion - (eshell-bol) + (beginning-of-line) (skip-syntax-forward " ") (thing-at-point 'sexp))) (prefix (file-remote-p default-directory))) diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el index 9078c44ed9f..5c9a0a85934 100644 --- a/lisp/eshell/em-extpipe.el +++ b/lisp/eshell/em-extpipe.el @@ -36,6 +36,21 @@ (eval-when-compile (require 'files-x)) +;;;###autoload +(progn +(defgroup eshell-extpipe nil + "Native shell pipelines. + +This module lets you construct pipelines that use your operating +system's shell instead of Eshell's own pipelining support. This +is especially relevant when executing commands on a remote +machine using Eshell's Tramp integration: using the remote +shell's pipelining avoids copying the data which will flow +through the pipeline to local Emacs buffers and then right back +again." + :tag "External pipelines" + :group 'eshell-module)) + ;;; Functions: (defun eshell-extpipe-initialize () ;Called from `eshell-mode' via intern-soft! diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 716f5c32b87..9402df43065 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -49,8 +49,9 @@ ;;; Code: +(require 'esh-arg) +(require 'esh-module) (require 'esh-util) -(eval-when-compile (require 'eshell)) ;;;###autoload (progn @@ -144,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 () @@ -170,7 +161,7 @@ interpretation." (end (eshell-find-delimiter delim (if (eq delim ?\[) ?\] ?\))))) (if (not end) - (throw 'eshell-incomplete delim) + (throw 'eshell-incomplete (char-to-string delim)) (if (and (eshell-using-module 'eshell-pred) (eshell-arg-delimiter (1+ end))) (ignore (goto-char here)) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 05e9598f530..2c199ec160f 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -59,8 +59,6 @@ (require 'ring) (require 'esh-opt) (require 'esh-mode) -(require 'em-pred) -(require 'eshell) ;;;###autoload (progn @@ -82,6 +80,7 @@ (remove-hook 'kill-emacs-hook 'eshell-save-some-history))) "A hook that gets run when `eshell-hist' is unloaded." :type 'hook) +(make-obsolete-variable 'eshell-hist-unload-hook nil "30.1") (defcustom eshell-history-file-name (expand-file-name "history" eshell-directory-name) @@ -555,7 +554,7 @@ See also `eshell-read-history'." (defun eshell-hist-parse-arguments (&optional b e) "Parse current command arguments in a history-code-friendly way." (let ((end (or e (point))) - (begin (or b (save-excursion (eshell-bol) (point)))) + (begin (or b (save-excursion (beginning-of-line) (point)))) (posb (list t)) (pose (list t)) (textargs (list t)) @@ -769,6 +768,8 @@ matched." (defun eshell-hist-parse-modifier (hist reference) "Parse a history modifier beginning for HIST in REFERENCE." + (cl-assert (eshell-using-module 'em-pred)) + (declare-function eshell-parse-modifiers "em-pred" ()) (let ((here (point))) (insert reference) (prog1 @@ -913,7 +914,7 @@ If N is negative, search forwards for the -Nth following match." eshell-next-matching-input-from-input))) ;; Starting a new search (setq eshell-matching-input-from-input-string - (buffer-substring (save-excursion (eshell-bol) (point)) + (buffer-substring (save-excursion (beginning-of-line) (point)) (point)) eshell-history-index nil)) (eshell-previous-matching-input @@ -933,7 +934,7 @@ If N is negative, search backwards for the -Nth previous match." (if (get-text-property (point) 'history) (progn (beginning-of-line) t) (let ((before (point))) - (eshell-bol) + (beginning-of-line) (if (and (not (bolp)) (<= (point) before)) t @@ -1037,6 +1038,9 @@ If N is negative, search backwards for the -Nth previous match." (isearch-done) (eshell-send-input)) +(defun em-hist-unload-function () + (remove-hook 'kill-emacs-hook 'eshell-save-some-history)) + (provide 'em-hist) ;; Local Variables: diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 7e2a7578ef9..56c5f262789 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -62,24 +62,27 @@ This is useful for enabling human-readable format (-h), for example." This is useful for enabling human-readable format (-h), for example." :type '(repeat :tag "Arguments" string)) +(defun eshell-ls-enable-in-dired () + "Use `eshell-ls' to read directories in Dired." + (require 'dired) + (advice-add 'insert-directory :around #'eshell-ls--insert-directory) + (advice-add 'dired :around #'eshell-ls--dired)) + +(defun eshell-ls-disable-in-dired () + "Stop using `eshell-ls' to read directories in Dired." + (advice-remove 'insert-directory #'eshell-ls--insert-directory) + (advice-remove 'dired #'eshell-ls--dired)) + (defcustom eshell-ls-use-in-dired nil "If non-nil, use `eshell-ls' to read directories in Dired. Changing this without using customize has no effect." :set (lambda (symbol value) - (cond (value - (require 'dired) - (advice-add 'insert-directory :around - #'eshell-ls--insert-directory) - (advice-add 'dired :around #'eshell-ls--dired)) - (t - (advice-remove 'insert-directory - #'eshell-ls--insert-directory) - (advice-remove 'dired #'eshell-ls--dired))) + (if value + (eshell-ls-enable-in-dired) + (eshell-ls-disable-in-dired)) (set symbol value)) :type 'boolean :require 'em-ls) -(add-hook 'eshell-ls-unload-hook #'eshell-ls-unload-function) - (defcustom eshell-ls-default-blocksize 1024 "The default blocksize to use when display file sizes with -s." @@ -954,10 +957,8 @@ to use, and each member of which is the width of that column (car file))))) (car file)) -(defun eshell-ls-unload-function () - (advice-remove 'insert-directory #'eshell-ls--insert-directory) - (advice-remove 'dired #'eshell-ls--dired) - nil) +(defun em-ls-unload-function () + (eshell-ls-disable-in-dired)) (provide 'em-ls) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 14fa27aba06..2ccca092b86 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -293,7 +293,7 @@ This function is specially for adding onto `eshell-parse-argument-hook'." (forward-char) (let ((end (eshell-find-delimiter ?\( ?\)))) (if (not end) - (throw 'eshell-incomplete ?\() + (throw 'eshell-incomplete "(") (when (eshell-arg-delimiter (1+ end)) (save-restriction (narrow-to-region (point) end) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index 575b5a595f1..9f9e58e83d7 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -27,7 +27,7 @@ ;;; Code: (require 'esh-mode) -(eval-when-compile (require 'eshell)) +(require 'text-property-search) ;;;###autoload (progn @@ -50,7 +50,7 @@ as is common with most shells." (defcustom eshell-prompt-function (lambda () (concat (abbreviate-file-name (eshell/pwd)) - (if (= (user-uid) 0) " # " " $ "))) + (if (= (file-user-uid) 0) " # " " $ "))) "A function that returns the Eshell prompt string. Make sure to update `eshell-prompt-regexp' so that it will match your prompt." @@ -58,11 +58,12 @@ prompt." :group 'eshell-prompt) (defcustom eshell-prompt-regexp "^[^#$\n]* [#$] " - "A regexp which fully matches your eshell prompt. -This setting is important, since it affects how eshell will interpret -the lines that are passed to it. -If this variable is changed, all Eshell buffers must be exited and -re-entered for it to take effect." + "A regexp which fully matches your Eshell prompt. +This is useful for navigating by paragraph using \ +\\[forward-paragraph] and \\[backward-paragraph]. + +If this variable is changed, all Eshell buffers must be exited +and re-entered for it to take effect." :type 'regexp :group 'eshell-prompt) @@ -123,7 +124,6 @@ arriving, or after." (if eshell-prompt-regexp (setq-local paragraph-start eshell-prompt-regexp)) - (setq-local eshell-skip-prompt-function #'eshell-skip-prompt) (eshell-prompt-mode))) (defun eshell-emit-prompt () @@ -134,72 +134,83 @@ arriving, or after." (if (not eshell-prompt-function) (set-marker eshell-last-output-end (point)) (let ((prompt (funcall eshell-prompt-function))) - (and eshell-highlight-prompt - (add-text-properties 0 (length prompt) - '(read-only t - font-lock-face eshell-prompt - front-sticky (font-lock-face read-only) - rear-nonsticky (font-lock-face read-only)) - prompt)) - (eshell-interactive-print prompt))) + (add-text-properties + 0 (length prompt) + (if eshell-highlight-prompt + '( read-only t + field prompt + font-lock-face eshell-prompt + front-sticky (read-only field font-lock-face) + rear-nonsticky (read-only field font-lock-face)) + '( field prompt + front-sticky (field) + rear-nonsticky (field))) + prompt) + (eshell-interactive-filter nil prompt))) (run-hooks 'eshell-after-prompt-hook)) -(defun eshell-backward-matching-input (regexp arg) - "Search backward through buffer for match for REGEXP. -Matches are searched for on lines that match `eshell-prompt-regexp'. -With prefix argument N, search for Nth previous match. -If N is negative, find the next or Nth next match." - (interactive (eshell-regexp-arg "Backward input matching (regexp): ")) - (let* ((re (concat eshell-prompt-regexp ".*" regexp)) - (pos (save-excursion (end-of-line (if (> arg 0) 0 1)) - (if (re-search-backward re nil t arg) - (point))))) - (if (null pos) - (progn (message "Not found") - (ding)) - (goto-char pos) - (eshell-bol)))) - (defun eshell-forward-matching-input (regexp arg) - "Search forward through buffer for match for REGEXP. -Matches are searched for on lines that match `eshell-prompt-regexp'. -With prefix argument N, search for Nth following match. -If N is negative, find the previous or Nth previous match." + "Search forward through buffer for command input that matches REGEXP. +With prefix argument N, search for Nth next match. If N is +negative, find the Nth previous match." (interactive (eshell-regexp-arg "Forward input matching (regexp): ")) - (eshell-backward-matching-input regexp (- arg))) + (let ((direction (if (> arg 0) 1 -1)) + (count (abs arg))) + (unless (catch 'found + (while (> count 0) + (eshell-next-prompt direction) + (when (and (string-match regexp (field-string)) + (= (setq count (1- count)) 0)) + (throw 'found t)))) + (message "Not found") + (ding)))) + +(defun eshell-backward-matching-input (regexp arg) + "Search backward through buffer for command input that matches REGEXP. +With prefix argument N, search for Nth previous match. If N is +negative, find the Nth next match." + (interactive (eshell-regexp-arg "Backward input matching (regexp): ")) + (eshell-forward-matching-input regexp (- arg))) (defun eshell-next-prompt (n) - "Move to end of Nth next prompt in the buffer. -See `eshell-prompt-regexp'." + "Move to end of Nth next prompt in the buffer." (interactive "p") - (if eshell-highlight-prompt - (progn - (while (< n 0) - (while (and (re-search-backward eshell-prompt-regexp nil t) - (not (get-text-property (match-beginning 0) 'read-only)))) - (setq n (1+ n))) - (while (> n 0) - (while (and (re-search-forward eshell-prompt-regexp nil t) - (not (get-text-property (match-beginning 0) 'read-only)))) - (setq n (1- n)))) - (re-search-forward eshell-prompt-regexp nil t n)) - (eshell-skip-prompt)) + (if (natnump n) + (while (and (> n 0) + (text-property-search-forward 'field 'prompt t)) + (setq n (1- n))) + (let (match this-match) + (forward-line 0) ; Don't count prompt on current line. + (while (and (< n 0) + (setq this-match (text-property-search-backward + 'field 'prompt t))) + (setq match this-match + n (1+ n))) + (when match + (goto-char (prop-match-end match)))))) (defun eshell-previous-prompt (n) - "Move to end of Nth previous prompt in the buffer. -See `eshell-prompt-regexp'." + "Move to end of Nth previous prompt in the buffer." (interactive "p") - (forward-line 0) ; Don't count prompt on current line. (eshell-next-prompt (- n))) (defun eshell-skip-prompt () "Skip past the text matching regexp `eshell-prompt-regexp'. If this takes us past the end of the current line, don't skip at all." + (declare (obsolete nil "30.1")) (let ((eol (line-end-position))) (if (and (looking-at eshell-prompt-regexp) (<= (match-end 0) eol)) (goto-char (match-end 0))))) +(defun eshell-bol-ignoring-prompt (arg) + "Move point to the beginning of the current line, past the prompt (if any). +With argument ARG not nil or 1, move forward ARG - 1 lines +first (see `move-beginning-of-line' for more information)." + (interactive "^p") + (let ((inhibit-field-text-motion t)) + (move-beginning-of-line arg))) + (provide 'em-prompt) ;; Local Variables: diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index 2c95d4fdffb..75a2848a9d5 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -24,7 +24,6 @@ ;;; Code: (require 'esh-mode) -(eval-when-compile (require 'eshell)) ;;;###autoload (progn @@ -50,9 +49,7 @@ the behavior of normal shells while the user editing new input text." :group 'eshell-rebind) (defcustom eshell-rebind-keys-alist - '(([(control ?a)] . eshell-bol) - ([home] . eshell-bol) - ([(control ?d)] . eshell-delchar-or-maybe-eof) + '(([(control ?d)] . eshell-delchar-or-maybe-eof) ([backspace] . eshell-delete-backward-char) ([delete] . eshell-delete-backward-char) ([(control ?w)] . backward-kill-word) @@ -190,7 +187,7 @@ lock it at that." (and eshell-remap-previous-input (setq begin (save-excursion - (eshell-bol) + (beginning-of-line) (and (not (bolp)) (point)))) (>= pos begin) (<= pos (line-end-position)) diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el index ca04c429785..d8b7fadc2c2 100644 --- a/lisp/eshell/em-smart.el +++ b/lisp/eshell/em-smart.el @@ -69,7 +69,6 @@ ;;; Code: (require 'esh-mode) -(eval-when-compile (require 'eshell)) ;;;###autoload (progn @@ -100,6 +99,7 @@ it to get a real sense of how it works." "A hook that gets run when `eshell-smart' is unloaded." :type 'hook :group 'eshell-smart) +(make-obsolete-variable 'eshell-smart-unload-hook nil "30.1") (defcustom eshell-review-quick-commands nil "If t, always review commands. @@ -322,6 +322,9 @@ and the end of the buffer are still visible." (if clear (remove-hook 'pre-command-hook 'eshell-smart-display-move t)))) +(defun em-smart-unload-hook () + (remove-hook 'window-configuration-change-hook #'eshell-refresh-windows)) + (provide 'em-smart) ;; Local Variables: diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el index a4d777e4a0d..ab26da857b7 100644 --- a/lisp/eshell/em-term.el +++ b/lisp/eshell/em-term.el @@ -34,7 +34,6 @@ (require 'cl-lib) (require 'esh-util) (require 'esh-ext) -(eval-when-compile (require 'eshell)) (require 'term) ;;;###autoload diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index 13dd62e1617..94eb9797033 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -29,8 +29,7 @@ (require 'esh-cmd) (eval-when-compile - (require 'esh-mode) - (require 'eshell)) + (require 'esh-mode)) (require 'tramp) diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index f88a06d2e95..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) @@ -786,10 +791,14 @@ external command." (defun eshell-complete-host-reference () "If there is a host reference, complete it." - (let ((arg (pcomplete-actual-arg)) - index) - (when (setq index (string-match "@[a-z.]*\\'" arg)) - (setq pcomplete-stub (substring arg (1+ index)) + (let ((arg (pcomplete-actual-arg))) + (when (string-match + (rx ;; Match an "@", but not immediately following a "$". + (or string-start (not "$")) "@" + (group (* (any "a-z."))) + string-end) + arg) + (setq pcomplete-stub (substring arg (match-beginning 1)) pcomplete-last-completion-raw t) (throw 'pcomplete-completions (pcomplete-read-host-names))))) diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el index defaa7b2887..45c3ea3c0fc 100644 --- a/lisp/eshell/em-xtra.el +++ b/lisp/eshell/em-xtra.el @@ -25,8 +25,6 @@ (require 'cl-lib) (require 'esh-util) -(eval-when-compile - (require 'eshell)) ;; There are no items in this custom group, but eshell modules (ab)use ;; custom groups. diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 9aab3af9b47..aa1e8f77ea5 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -28,6 +28,9 @@ ;;; Code: (require 'esh-util) +(require 'esh-module) + +(require 'pcomplete) (eval-when-compile (require 'cl-lib)) @@ -175,7 +178,11 @@ treated as a literal character." "Initialize the argument parsing code." (eshell-arg-mode) (setq-local eshell-inside-quote-regexp nil) - (setq-local eshell-outside-quote-regexp nil)) + (setq-local eshell-outside-quote-regexp nil) + + (when (eshell-using-module 'eshell-cmpl) + (add-hook 'pcomplete-try-first-hook + #'eshell-complete-special-reference nil t))) (defun eshell-insert-buffer-name (buffer-name) "Insert BUFFER-NAME into the current buffer at point." @@ -238,13 +245,53 @@ convert the result to a number as well." (eshell-convert-to-number result) result))) +(defun eshell-concat-groups (quoted &rest args) + "Concatenate groups of arguments in ARGS and return the result. +QUOTED is passed to `eshell-concat' (which see) and, if non-nil, +allows values to be converted to numbers where appropriate. + +ARGS should be a list of lists of arguments, such as that +produced by `eshell-prepare-slice'. \"Adjacent\" values of +consecutive arguments will be passed to `eshell-concat'. For +example, if ARGS is + + ((list a) (list b) (list c d e) (list f g)), + +then the result will be: + + ((eshell-concat QUOTED a b c) + d + (eshell-concat QUOTED e f) + g)." + (let (result current-arg) + (dolist (arg args) + (when arg + (push (car arg) current-arg) + (when (length> arg 1) + (push (apply #'eshell-concat quoted (nreverse current-arg)) + result) + (dolist (inner (butlast (cdr arg))) + (push inner result)) + (setq current-arg (list (car (last arg))))))) + (when current-arg + (push (apply #'eshell-concat quoted (nreverse current-arg)) + result)) + (nreverse result))) + (defun eshell-resolve-current-argument () "If there are pending modifications to be made, make them now." (when eshell-current-argument (when eshell-arg-listified - (setq eshell-current-argument - (append (list 'eshell-concat eshell-current-quoted) - eshell-current-argument)) + (if-let ((grouped-terms (eshell-prepare-splice + eshell-current-argument))) + (setq eshell-current-argument + `(eshell-splice-args + (eshell-concat-groups ,eshell-current-quoted + ,@grouped-terms))) + ;; If no terms are spliced, use a simpler command form. + (setq eshell-current-argument + (append (list 'eshell-concat eshell-current-quoted) + eshell-current-argument))) (setq eshell-arg-listified nil)) (while eshell-current-modifiers (setq eshell-current-argument @@ -261,7 +308,8 @@ argument list in place of the value of the current argument." (setq eshell-current-argument (car arguments)) (cl-assert (and (not eshell-arg-listified) (not eshell-current-modifiers))) - (setq eshell-current-argument (cons 'eshell-flatten-args arguments)))) + (setq eshell-current-argument + (cons 'eshell-splice-immediately arguments)))) (throw 'eshell-arg-done t)) (defun eshell-quote-argument (string) @@ -302,7 +350,8 @@ Point is left at the end of the arguments." (buffer-substring here (point-max)))) (when arg (nconc args - (if (eq (car-safe arg) 'eshell-flatten-args) + (if (eq (car-safe arg) + 'eshell-splice-immediately) (cdr arg) (list arg)))))))) (throw 'eshell-incomplete (if (listp delim) @@ -348,6 +397,10 @@ Point is left at the end of the arguments." "A stub function that generates an error if a floating operator is found." (error "Unhandled operator in input text")) +(defsubst eshell-splice-args (&rest _args) + "A stub function that generates an error if a floating splice is found." + (error "Splice operator is not permitted in this context")) + (defsubst eshell-looking-at-backslash-return (pos) "Test whether a backslash-return sequence occurs at POS." (and (eq (char-after pos) ?\\) @@ -375,29 +428,33 @@ backslash is in a quoted string, the backslash and the character after are both returned." (when (eq (char-after) ?\\) (when (eshell-looking-at-backslash-return (point)) - (throw 'eshell-incomplete ?\\)) + (throw 'eshell-incomplete "\\")) (forward-char 2) ; Move one char past the backslash. - (if (eq (char-before) ?\n) - ;; Escaped newlines are extra-special: they expand to an empty - ;; token to allow for continuing Eshell commands across - ;; multiple lines. - 'eshell-empty-token - ;; If the char is in a quote, backslash only has special meaning - ;; if it is escaping a special char. - (if eshell-current-quoted - (if (memq (char-before) eshell-special-chars-inside-quoting) - (list 'eshell-escape-arg (char-to-string (char-before))) - (concat "\\" (char-to-string (char-before)))) - (if (memq (char-before) eshell-special-chars-outside-quoting) - (list 'eshell-escape-arg (char-to-string (char-before))) - (char-to-string (char-before))))))) + (let ((special-chars (if eshell-current-quoted + eshell-special-chars-inside-quoting + eshell-special-chars-outside-quoting))) + (cond + ;; Escaped newlines are extra-special: they expand to an empty + ;; token to allow for continuing Eshell commands across + ;; multiple lines. + ((eq (char-before) ?\n) + 'eshell-empty-token) + ((memq (char-before) special-chars) + (list 'eshell-escape-arg (char-to-string (char-before)))) + ;; If the char is in a quote, backslash only has special + ;; meaning if it is escaping a special char. Otherwise, the + ;; result is the literal string "\c". + (eshell-current-quoted + (concat "\\" (char-to-string (char-before)))) + (t + (char-to-string (char-before))))))) (defun eshell-parse-literal-quote () "Parse a literally quoted string. Nothing has special meaning!" (if (eq (char-after) ?\') (let ((end (eshell-find-delimiter ?\' ?\'))) (if (not end) - (throw 'eshell-incomplete ?\') + (throw 'eshell-incomplete "'") (let ((string (buffer-substring-no-properties (1+ (point)) end))) (goto-char (1+ end)) (while (string-match "''" string) @@ -410,7 +467,7 @@ after are both returned." (let* ((end (eshell-find-delimiter ?\" ?\" nil nil t)) (eshell-current-quoted t)) (if (not end) - (throw 'eshell-incomplete ?\") + (throw 'eshell-incomplete "\"") (prog1 (save-restriction (forward-char) @@ -456,21 +513,28 @@ If the form has no `type', the syntax is parsed as if `type' were \"buffer\"." (when (and (not eshell-current-argument) (not eshell-current-quoted) - (looking-at "#<\\(\\(buffer\\|process\\)\\s-\\)?")) + (looking-at (rx "#<" (? (group (or "buffer" "process")) + space)))) (let ((here (point))) (goto-char (match-end 0)) ;; Go to the end of the match. - (let ((buffer-p (if (match-string 1) - (string= (match-string 2) "buffer") - t)) ;; buffer-p is non-nil by default. + (let ((buffer-p (if (match-beginning 1) + (equal (match-string 1) "buffer") + t)) ; With no type keyword, assume we want a buffer. (end (eshell-find-delimiter ?\< ?\>))) (when (not end) - (throw 'eshell-incomplete ?\<)) + (when (match-beginning 1) + (goto-char (match-beginning 1))) + (throw 'eshell-incomplete "#<")) (if (eshell-arg-delimiter (1+ end)) (prog1 - (list (if buffer-p 'get-buffer-create 'get-process) - (replace-regexp-in-string - (rx "\\" (group (or "\\" "<" ">"))) "\\1" - (buffer-substring-no-properties (point) end))) + (list (if buffer-p #'get-buffer-create #'get-process) + ;; FIXME: We should probably parse this as a + ;; real Eshell argument so that we get the + ;; benefits of quoting, variable-expansion, etc. + (string-trim-right + (replace-regexp-in-string + (rx "\\" (group anychar)) "\\1" + (buffer-substring-no-properties (point) end)))) (goto-char (1+ end))) (ignore (goto-char here))))))) @@ -496,5 +560,69 @@ If the form has no `type', the syntax is parsed as if `type' were (char-to-string (char-after))))) (goto-char end))))))) +(defun eshell-prepare-splice (args) + "Prepare a list of ARGS for splicing, if any arg requested a splice. +This looks for `eshell-splice-args' as the CAR of each argument, +and if found, returns a grouped list like: + + ((list arg-1) (list arg-2) spliced-arg-3 ...) + +This allows callers of this function to build the final spliced +list by concatenating each element together, e.g. with + + (apply #\\='append grouped-list) + +If no argument requested a splice, return nil." + (let* ((splicep nil) + ;; Group each arg like ((list arg-1) (list arg-2) ...), + ;; splicing in `eshell-splice-args' args. This lets us + ;; apply spliced args correctly elsewhere. + (grouped-args + (mapcar (lambda (i) + (if (eq (car-safe i) 'eshell-splice-args) + (progn + (setq splicep t) + (cadr i)) + `(list ,i))) + args))) + (when splicep + grouped-args))) + +;;;_* Special ref completion + +(defun eshell-complete-special-reference () + "If there is a special reference, complete it." + (let ((arg (pcomplete-actual-arg))) + (when (string-match + (rx string-start + "#<" (? (group (or "buffer" "process")) space) + (group (* anychar)) + string-end) + arg) + (let ((all-results (if (equal (match-string 1 arg) "process") + (mapcar #'process-name (process-list)) + (mapcar #'buffer-name (buffer-list)))) + (saw-type (match-beginning 1))) + (unless saw-type + ;; Include the special reference types as completion options. + (setq all-results (append '("buffer" "process") all-results))) + (setq pcomplete-stub (replace-regexp-in-string + (rx "\\" (group anychar)) "\\1" + (substring arg (match-beginning 2)))) + ;; When finished with completion, add a trailing ">" (unless + ;; we just completed the initial "buffer" or "process" + ;; keyword). + (add-function + :before (var pcomplete-exit-function) + (lambda (value status) + (when (and (eq status 'finished) + (or saw-type + (not (member value '("buffer" "process"))))) + (if (looking-at ">") + (goto-char (match-end 0)) + (insert ">"))))) + (throw 'pcomplete-completions + (all-completions pcomplete-stub all-results)))))) + (provide 'esh-arg) ;;; esh-arg.el ends here diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 706477a5f45..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 () @@ -343,7 +354,7 @@ This only returns external (non-Lisp) processes." #'eshell-complete-lisp-symbols nil t))) (defun eshell-complete-lisp-symbols () - "If there is a user reference, complete it." + "If there is a Lisp symbol, complete it." (let ((arg (pcomplete-actual-arg))) (when (string-match (concat "\\`" eshell-lisp-regexp) arg) (setq pcomplete-stub (substring arg (match-end 0)) @@ -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 @@ -418,8 +430,11 @@ hooks should be run before and after the command." (eshell-separate-commands terms "[&;]" nil 'eshell--sep-terms)))) (let ((cmd commands)) (while cmd - (if (cdr cmd) - (setcar cmd `(eshell-commands ,(car cmd)))) + ;; Copy I/O handles so each full statement can manipulate them + ;; if they like. Steal the handles for the last command in + ;; the list; we won't use the originals again anyway. + (setcar cmd `(eshell-with-copied-handles + ,(car cmd) ,(not (cdr cmd)))) (setq cmd (cdr cmd)))) (if toplevel `(eshell-commands (progn @@ -480,14 +495,19 @@ hooks should be run before and after the command." (let ((sym (if eshell-in-pipeline-p 'eshell-named-command* 'eshell-named-command)) - (cmd (car terms)) - (args (cdr terms))) - (if args - (list sym cmd `(list ,@(cdr terms))) - (list sym cmd)))) - -(defvar eshell-command-body) -(defvar eshell-test-body) + (grouped-terms (eshell-prepare-splice terms))) + (cond + (grouped-terms + `(let ((terms (nconc ,@grouped-terms))) + (,sym (car terms) (cdr terms)))) + ;; If no terms are spliced, use a simpler command form. + ((cdr terms) + (list sym (car terms) `(list ,@(cdr terms)))) + (t + (list sym (car terms)))))) + +(defvar eshell--command-body) +(defvar eshell--test-body) (defsubst eshell-invokify-arg (arg &optional share-output silent) "Change ARG so it can be invoked from a structured command. @@ -523,27 +543,24 @@ 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 - (copy-tree - (append - ,@(mapcar - (lambda (elem) - (if (listp elem) - elem - `(list ,elem))) - (cdr (cddr terms)))))) - (eshell-command-body '(nil)) - (eshell-test-body '(nil))) - (while (car for-items) - (let ((,(intern (cadr terms)) (car for-items)) + `(let ((,for-items + (append + ,@(mapcar + (lambda (elem) + (if (listp elem) + elem + `(list ,elem))) + (nthcdr 3 terms))))) + (while ,for-items + (let ((,(intern (cadr terms)) (car ,for-items)) (eshell--local-vars (cons ',(intern (cadr terms)) - eshell--local-vars))) + eshell--local-vars))) (eshell-protect ,(eshell-invokify-arg body t))) - (setcar for-items (cadr for-items)) - (setcdr for-items (cddr for-items))) + (setq ,for-items (cdr ,for-items))) (eshell-close-handles))))) (defun eshell-structure-basic-command (func names keyword test body @@ -573,8 +590,7 @@ function." ;; finally, create the form that represents this structured ;; command - `(let ((eshell-command-body '(nil)) - (eshell-test-body '(nil))) + `(progn (,func ,test ,body ,else) (eshell-close-handles))) @@ -672,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." @@ -690,7 +706,7 @@ This means an exit code of 0." (condition-case nil (read (current-buffer)) (end-of-file - (throw 'eshell-incomplete ?\())))) + (throw 'eshell-incomplete "("))))) (if (eshell-arg-delimiter) `(eshell-command-to-value (eshell-lisp-command (quote ,obj))) @@ -733,18 +749,20 @@ if none)." ;; The structure of the following macros is very important to ;; `eshell-do-eval' [Iterative evaluation]: ;; -;; @ Don't use forms that conditionally evaluate their arguments, such -;; as `setq', `if', `while', `let*', etc. The only special forms -;; that can be used are `let', `condition-case' and -;; `unwind-protect'. -;; -;; @ The main body of a `let' can contain only one form. Use `progn' -;; if necessary. +;; @ Don't use special forms that conditionally evaluate their +;; arguments, such as `let*', unless Eshell explicitly supports +;; them. Eshell supports the following special forms: `catch', +;; `condition-case', `if', `let', `prog1', `progn', `quote', `setq', +;; `unwind-protect', and `while'. ;; ;; @ The two `special' variables are `eshell-current-handles' and ;; `eshell-current-subjob-p'. Bind them locally with a `let' if you ;; need to change them. Change them directly only if your intention ;; is to change the calling environment. +;; +;; These rules likewise apply to any other code that generates forms +;; that `eshell-do-eval' will evaluated, such as command rewriting +;; hooks (see `eshell-rewrite-command-hook' and friends). (defmacro eshell-do-subjob (object) "Evaluate a command OBJECT as a subjob. @@ -783,16 +801,17 @@ this grossness will be made to disappear by using `call/cc'..." (defvar eshell-output-handle) ;Defined in esh-io.el. (defvar eshell-error-handle) ;Defined in esh-io.el. -(defmacro eshell-copy-handles (object) - "Duplicate current I/O handles, so OBJECT works with its own copy." +(defmacro eshell-with-copied-handles (object &optional steal-p) + "Duplicate current I/O handles, so OBJECT works with its own copy. +If STEAL-P is non-nil, these new handles will be stolen from the +current ones (see `eshell-duplicate-handles')." `(let ((eshell-current-handles - (eshell-create-handles - (car (aref eshell-current-handles - eshell-output-handle)) nil - (car (aref eshell-current-handles - eshell-error-handle)) nil))) + (eshell-duplicate-handles eshell-current-handles ,steal-p))) ,object)) +(define-obsolete-function-alias 'eshell-copy-handles + #'eshell-with-copied-handles "30.1") + (defmacro eshell-protect (object) "Protect I/O handles, so they aren't get closed after eval'ing OBJECT." `(progn @@ -803,7 +822,7 @@ this grossness will be made to disappear by using `call/cc'..." "Execute the commands in PIPELINE, connecting each to one another. This macro calls itself recursively, with NOTFIRST non-nil." (when (setq pipeline (cadr pipeline)) - `(eshell-copy-handles + `(eshell-with-copied-handles (progn ,(when (cdr pipeline) `(let ((nextproc @@ -828,7 +847,9 @@ This macro calls itself recursively, with NOTFIRST non-nil." (let ((proc ,(car pipeline))) (set headproc (or proc (symbol-value headproc))) (set tailproc (or (symbol-value tailproc) proc)) - proc)))))) + proc))) + ;; Steal handles if this is the last item in the pipeline. + ,(null (cdr pipeline))))) (defmacro eshell-do-pipelines-synchronously (pipeline) "Execute the commands in PIPELINE in sequence synchronously. @@ -873,40 +894,42 @@ 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-create-handles - (car (aref eshell-current-handles - ,eshell-output-handle)) nil - (car (aref eshell-current-handles - ,eshell-error-handle)) nil))) + `(let ((tail-handles (eshell-duplicate-handles + eshell-current-handles))) (eshell-do-pipelines-synchronously ,pipeline))) (eshell-process-identity (cons (symbol-value headproc) (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 ;; @@ -1014,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. @@ -1030,22 +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)) - (val-is-process (or (eshell-processp val) - (eshell-process-pair-p val)))) - ;; 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 val-is-process) - (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 val-is-process 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." @@ -1087,9 +1105,17 @@ produced by `eshell-parse-command'." (eshell-debug-command ,(concat "done " (eval tag)) form)))) (defun eshell-do-eval (form &optional synchronous-p) - "Evaluate form, simplifying it as we go. + "Evaluate FORM, simplifying it as we go. Unless SYNCHRONOUS-P is non-nil, throws `eshell-defer' if it needs to -be finished later after the completion of an asynchronous subprocess." +be finished later after the completion of an asynchronous subprocess. + +As this function evaluates FORM, it will gradually replace +subforms with the (quoted) result of evaluating them. For +example, a function call is replaced with the result of the call. +This allows us to resume evaluation of FORM after something +inside throws `eshell-defer' simply by calling this function +again. Any forms preceding one that throw `eshell-defer' will +have been replaced by constants." (cond ((not (listp form)) (list 'quote (eval form))) @@ -1110,42 +1136,46 @@ be finished later after the completion of an asynchronous subprocess." (let ((args (cdr form))) (cond ((eq (car form) 'while) + ;; Wrap the `while' form with let-bindings for the command and + ;; test bodies. This helps us resume evaluation midway + ;; through the loop. + (let ((new-form (copy-tree `(let ((eshell--command-body nil) + (eshell--test-body nil)) + (eshell--wrapped-while ,@args))))) + (eshell-manipulate "modifying while form" + (setcar form (car new-form)) + (setcdr form (cdr new-form))) + (eshell-do-eval form synchronous-p))) + ((eq (car form) 'eshell--wrapped-while) + (when eshell--command-body + (cl-assert (not synchronous-p)) + (eshell-do-eval eshell--command-body) + (setq eshell--command-body nil + eshell--test-body nil)) ;; `copy-tree' is needed here so that the test argument - ;; doesn't get modified and thus always yield the same result. - (when (car eshell-command-body) - (cl-assert (not synchronous-p)) - (eshell-do-eval (car eshell-command-body)) - (setcar eshell-command-body nil) - (setcar eshell-test-body nil)) - (unless (car eshell-test-body) - (setcar eshell-test-body (copy-tree (car args)))) - (while (cadr (eshell-do-eval (car eshell-test-body) synchronous-p)) - (setcar eshell-command-body - (if (cddr args) - `(progn ,@(copy-tree (cdr args))) - (copy-tree (cadr args)))) - (eshell-do-eval (car eshell-command-body) synchronous-p) - (setcar eshell-command-body nil) - (setcar eshell-test-body (copy-tree (car args)))) - (setcar eshell-command-body nil)) + ;; doesn't get modified and thus always yield the same result. + (unless eshell--test-body + (setq eshell--test-body (copy-tree (car args)))) + (while (cadr (eshell-do-eval eshell--test-body synchronous-p)) + (setq eshell--command-body + (if (cddr args) + `(progn ,@(copy-tree (cdr args))) + (copy-tree (cadr args)))) + (eshell-do-eval eshell--command-body synchronous-p) + (setq eshell--command-body nil + eshell--test-body (copy-tree (car args))))) ((eq (car form) 'if) - ;; `copy-tree' is needed here so that the test argument - ;; doesn't get modified and thus always yield the same result. - (if (car eshell-command-body) - (progn - (cl-assert (not synchronous-p)) - (eshell-do-eval (car eshell-command-body))) - (unless (car eshell-test-body) - (setcar eshell-test-body (copy-tree (car args)))) - (setcar eshell-command-body - (copy-tree - (if (cadr (eshell-do-eval (car eshell-test-body) - synchronous-p)) - (cadr args) - (car (cddr args))))) - (eshell-do-eval (car eshell-command-body) synchronous-p)) - (setcar eshell-command-body nil) - (setcar eshell-test-body nil)) + (eshell-manipulate "evaluating if condition" + (setcar args (eshell-do-eval (car args) synchronous-p))) + (eshell-do-eval + (cond + ((eval (car args)) ; COND is non-nil + (cadr args)) + ((cdddr args) ; Multiple ELSE forms + `(progn ,@(cddr args))) + (t ; Zero or one ELSE forms + (caddr args))) + synchronous-p)) ((eq (car form) 'setcar) (setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)) (eval form)) @@ -1153,21 +1183,48 @@ be finished later after the completion of an asynchronous subprocess." (setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)) (eval form)) ((eq (car form) 'let) - (if (not (eq (car (cadr args)) 'eshell-do-eval)) - (eshell-manipulate "evaluating let args" - (dolist (letarg (car args)) - (if (and (listp letarg) - (not (eq (cadr letarg) 'quote))) - (setcdr letarg - (list (eshell-do-eval - (cadr letarg) synchronous-p))))))) + (unless (eq (car-safe (cadr args)) 'eshell-do-eval) + (eshell-manipulate "evaluating let args" + (dolist (letarg (car args)) + (when (and (listp letarg) + (not (eq (cadr letarg) 'quote))) + (setcdr letarg + (list (eshell-do-eval + (cadr letarg) synchronous-p))))))) (cl-progv - (mapcar (lambda (binding) (if (consp binding) (car binding) binding)) + (mapcar (lambda (binding) + (if (consp binding) (car binding) binding)) (car args)) ;; These expressions should all be constants now. - (mapcar (lambda (binding) (if (consp binding) (eval (cadr binding)))) + (mapcar (lambda (binding) + (when (consp binding) (eval (cadr binding)))) (car args)) - (eshell-do-eval (macroexp-progn (cdr args)) synchronous-p))) + (let (deferred result) + ;; Evaluate the `let' body, catching `eshell-defer' so we + ;; can handle it below. + (setq deferred + (catch 'eshell-defer + (ignore (setq result (eshell-do-eval + (macroexp-progn (cdr args)) + synchronous-p))))) + ;; If something threw `eshell-defer', we need to update + ;; the let-bindings' values so that those values are + ;; correct when we resume evaluation of this form. + (when deferred + (eshell-manipulate "rebinding let args after `eshell-defer'" + (let ((bindings (car args))) + (while bindings + (let ((binding (if (consp (car bindings)) + (caar bindings) + (car bindings)))) + (setcar bindings + (list binding + (list 'quote (symbol-value binding))))) + (pop bindings)))) + (throw 'eshell-defer deferred)) + ;; If we get here, there was no `eshell-defer' thrown, so + ;; just return the `let' body's result. + result))) ((memq (car form) '(catch condition-case unwind-protect)) ;; `condition-case' and `unwind-protect' have to be ;; handled specially, because we only want to call @@ -1286,6 +1343,8 @@ be finished later after the completion of an asynchronous subprocess." (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) @@ -1423,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-io.el b/lisp/eshell/esh-io.el index 26a8530fe54..cccdb49ce2a 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -74,6 +74,8 @@ (eval-when-compile (require 'cl-lib)) +(declare-function eshell-interactive-print "esh-mode" (string)) + (defgroup eshell-io nil "Eshell's I/O management code provides a scheme for treating many different kinds of objects -- symbols, files, buffers, etc. -- as @@ -116,16 +118,22 @@ from executing while Emacs is redisplaying." :group 'eshell-io) (defcustom eshell-virtual-targets - '(("/dev/eshell" eshell-interactive-print nil) + '(;; The literal string "/dev/null" is intentional here. It just + ;; provides compatibility so that users can redirect to + ;; "/dev/null" no matter the actual value of `null-device'. + ("/dev/null" (lambda (_mode) (throw 'eshell-null-device t)) t) + ("/dev/eshell" eshell-interactive-print nil) ("/dev/kill" (lambda (mode) - (if (eq mode 'overwrite) - (kill-new "")) - 'eshell-kill-append) t) + (when (eq mode 'overwrite) + (kill-new "")) + #'eshell-kill-append) + t) ("/dev/clip" (lambda (mode) - (if (eq mode 'overwrite) - (let ((select-enable-clipboard t)) - (kill-new ""))) - 'eshell-clipboard-append) t)) + (when (eq mode 'overwrite) + (let ((select-enable-clipboard t)) + (kill-new ""))) + #'eshell-clipboard-append) + t)) "Map virtual devices name to Emacs Lisp functions. If the user specifies any of the filenames above as a redirection target, the function in the second element will be called. @@ -138,10 +146,8 @@ function. The output function is then called repeatedly with single strings, which represents successive pieces of the output of the command, until nil -is passed, meaning EOF. - -NOTE: /dev/null is handled specially as a virtual target, and should -not be added to this variable." +is passed, meaning EOF." + :version "30.1" :type '(repeat (list (string :tag "Target") function @@ -291,25 +297,58 @@ describing the mode, e.g. for using with `eshell-get-target'.") (defun eshell-create-handles (stdout output-mode &optional stderr error-mode) "Create a new set of file handles for a command. -The default location for standard output and standard error will go to -STDOUT and STDERR, respectively. -OUTPUT-MODE and ERROR-MODE are either `overwrite', `append' or `insert'; -a nil value of mode defaults to `insert'." +The default target for standard output and standard error will +go to STDOUT and STDERR, respectively. OUTPUT-MODE and +ERROR-MODE are either `overwrite', `append' or `insert'; a nil +value of mode defaults to `insert'. + +The result is a vector of file handles. Each handle is of the form: + + ((TARGETS . REF-COUNT) DEFAULT) + +TARGETS is a list of destinations for output. REF-COUNT is the +number of references to this handle (initially 1); see +`eshell-protect-handles' and `eshell-close-handles'. DEFAULT is +non-nil if handle has its initial default value (always t after +calling this function)." (let* ((handles (make-vector eshell-number-of-handles nil)) - (output-target (eshell-get-target stdout output-mode)) - (error-target (if stderr - (eshell-get-target stderr error-mode) - output-target))) - (aset handles eshell-output-handle (cons output-target 1)) - (aset handles eshell-error-handle (cons error-target 1)) + (output-target + (let ((target (eshell-get-target stdout output-mode))) + (cons (when target (list target)) 1))) + (error-target + (if stderr + (let ((target (eshell-get-target stderr error-mode))) + (cons (when target (list target)) 1)) + (cl-incf (cdr output-target)) + output-target))) + (aset handles eshell-output-handle (list output-target t)) + (aset handles eshell-error-handle (list error-target t)) handles)) +(defun eshell-duplicate-handles (handles &optional steal-p) + "Create a duplicate of the file handles in HANDLES. +This uses the targets of each handle in HANDLES, incrementing its +reference count by one (unless STEAL-P is non-nil). These +targets are shared between the original set of handles and the +new one, so the targets are only closed when the reference count +drops to 0 (see `eshell-close-handles'). + +This function also sets the DEFAULT field for each handle to +t (see `eshell-create-handles'). Unlike the targets, this value +is not shared with the original handles." + (let ((dup-handles (make-vector eshell-number-of-handles nil))) + (dotimes (idx eshell-number-of-handles) + (when-let ((handle (aref handles idx))) + (unless steal-p + (cl-incf (cdar handle))) + (aset dup-handles idx (list (car handle) t)))) + dup-handles)) + (defun eshell-protect-handles (handles) "Protect the handles in HANDLES from a being closed." (dotimes (idx eshell-number-of-handles) - (when (aref handles idx) - (setcdr (aref handles idx) - (1+ (cdr (aref handles idx)))))) + (when-let ((handle (aref handles idx))) + (cl-incf (cdar handle)))) handles) (defun eshell-close-handles (&optional exit-code result handles) @@ -327,46 +366,56 @@ the value already set in `eshell-last-command-result'." (when result (cl-assert (eq (car result) 'quote)) (setq eshell-last-command-result (cadr result))) - (let ((handles (or handles eshell-current-handles))) + (let ((handles (or handles eshell-current-handles)) + (succeeded (= eshell-last-command-status 0))) (dotimes (idx eshell-number-of-handles) - (when-let ((handle (aref handles idx))) - (setcdr handle (1- (cdr handle))) - (when (= (cdr handle) 0) - (dolist (target (ensure-list (car (aref handles idx)))) - (eshell-close-target target (= eshell-last-command-status 0))) - (setcar handle nil)))))) + (eshell-close-handle (aref handles idx) succeeded)))) + +(defun eshell-close-handle (handle status) + "Close a single HANDLE, taking refcounts into account. +This will pass STATUS to each target for the handle, which should +be a non-nil value on successful termination." + (when handle + (cl-assert (> (cdar handle) 0) + "Attempted to close a handle with 0 references") + (when (and (> (cdar handle) 0) + (= (cl-decf (cdar handle)) 0)) + (dolist (target (caar handle)) + (eshell-close-target target status)) + (setcar (car handle) nil)))) (defun eshell-set-output-handle (index mode &optional target handles) "Set handle INDEX for the current HANDLES to point to TARGET using MODE. -If HANDLES is nil, use `eshell-current-handles'." +If HANDLES is nil, use `eshell-current-handles'. + +If the handle is currently set to its default value (see +`eshell-create-handles'), this will overwrite the targets with +the new target. Otherwise, it will append the new target to the +current list of targets." (when target - (let ((handles (or handles eshell-current-handles))) - (if (and (stringp target) - ;; The literal string "/dev/null" is intentional here. - ;; It just provides compatibility so that users can - ;; redirect to "/dev/null" no matter the actual value - ;; of `null-device'. - (string= target "/dev/null")) - (aset handles index nil) - (let ((where (eshell-get-target target mode)) - (current (car (aref handles index)))) - (if (listp current) - (unless (member where current) - (setq current (append current (list where)))) - (setq current (list where))) - (if (not (aref handles index)) - (aset handles index (cons nil 1))) - (setcar (aref handles index) current)))))) + (let* ((handles (or handles eshell-current-handles)) + (handle (or (aref handles index) + (aset handles index (list (cons nil 1) nil)))) + (defaultp (cadr handle))) + (when defaultp + (cl-decf (cdar handle)) + (setcar handle (cons nil 1))) + (catch 'eshell-null-device + (let ((current (caar handle)) + (where (eshell-get-target target mode))) + (unless (member where current) + (setcar (car handle) (append current (list where)))))) + (setcar (cdr handle) nil)))) (defun eshell-copy-output-handle (index index-to-copy &optional handles) "Copy the handle INDEX-TO-COPY to INDEX for the current HANDLES. If HANDLES is nil, use `eshell-current-handles'." (let* ((handles (or handles eshell-current-handles)) (handle-to-copy (car (aref handles index-to-copy)))) - (setcar (aref handles index) - (if (listp handle-to-copy) - (copy-sequence handle-to-copy) - handle-to-copy)))) + (when handle-to-copy + (cl-incf (cdr handle-to-copy))) + (eshell-close-handle (aref handles index) nil) + (setcar (aref handles index) handle-to-copy))) (defun eshell-set-all-output-handles (mode &optional target handles) "Set output and error HANDLES to point to TARGET using MODE. @@ -497,9 +546,9 @@ INDEX is the handle index to check. If nil, check (let ((handles (or handles eshell-current-handles)) (index (or index eshell-output-handle))) (if (eq index 'all) - (and (eq (car (aref handles eshell-output-handle)) t) - (eq (car (aref handles eshell-error-handle)) t)) - (eq (car (aref handles index)) t)))) + (and (equal (caar (aref handles eshell-output-handle)) '(t)) + (equal (caar (aref handles eshell-error-handle)) '(t))) + (equal (caar (aref handles index)) '(t))))) (defvar eshell-print-queue nil) (defvar eshell-print-queue-count -1) @@ -550,8 +599,6 @@ after all printing is over with no argument." (eshell-print object) (eshell-print "\n")) -(autoload 'eshell-output-filter "esh-mode") - (defun eshell-output-object-to-target (object target) "Insert OBJECT into TARGET. Returns what was actually sent, or nil if nothing was sent." @@ -561,7 +608,7 @@ Returns what was actually sent, or nil if nothing was sent." ((symbolp target) (if (eq target t) ; means "print to display" - (eshell-output-filter nil (eshell-stringify object)) + (eshell-interactive-print (eshell-stringify object)) (if (not (symbol-value target)) (set target object) (setq object (eshell-stringify object)) @@ -606,15 +653,10 @@ Returns what was actually sent, or nil if nothing was sent." If HANDLE-INDEX is nil, output to `eshell-output-handle'. HANDLES is the set of file handles to use; if nil, use `eshell-current-handles'." - (let ((target (car (aref (or handles eshell-current-handles) - (or handle-index eshell-output-handle))))) - (if (listp target) - (while target - (eshell-output-object-to-target object (car target)) - (setq target (cdr target))) - (eshell-output-object-to-target object target) - ;; Explicitly return nil to match the list case above. - nil))) + (let ((targets (caar (aref (or handles eshell-current-handles) + (or handle-index eshell-output-handle))))) + (dolist (target targets) + (eshell-output-object-to-target object target)))) (provide 'esh-io) ;;; esh-io.el ends here diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index d80f1d1f390..0c381dbb86a 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -58,10 +58,16 @@ ;;; Code: -(require 'esh-util) -(require 'esh-module) +;; Load the core Eshell modules; we'll call their initialization +;; functions below in `eshell-mode'. +(require 'esh-arg) (require 'esh-cmd) -(require 'esh-arg) ;For eshell-parse-arguments +(require 'esh-ext) +(require 'esh-io) +(require 'esh-module) +(require 'esh-proc) +(require 'esh-util) +(require 'esh-var) (defgroup eshell-mode nil "This module contains code for handling input from the user." @@ -73,6 +79,7 @@ (defcustom eshell-mode-unload-hook nil "A hook that gets run when `eshell-mode' is unloaded." :type 'hook) +(make-obsolete-variable 'eshell-mode-unload-hook nil "30.1") (defcustom eshell-mode-hook nil "A hook that gets run when `eshell-mode' is entered." @@ -155,7 +162,8 @@ number, if the function `eshell-truncate-buffer' is on eshell-watch-for-password-prompt) "Functions to call before output is displayed. These functions are only called for output that is displayed -interactively, and not for output which is redirected." +interactively (see `eshell-interactive-filter'), and not for +output which is redirected." :type 'hook) (defcustom eshell-preoutput-filter-functions nil @@ -165,7 +173,10 @@ inserted. They return the string as it should be inserted." :type 'hook) (defcustom eshell-password-prompt-regexp - (format "\\(%s\\)[^:：៖]*[:：៖]\\s *\\'" (regexp-opt password-word-equivalents)) + (format "%s[^%s]*[%s]\\s *\\'" + (regexp-opt password-word-equivalents t) + (apply #'string password-colon-equivalents) + (apply #'string password-colon-equivalents)) "Regexp matching prompts for passwords in the inferior process. This is used by `eshell-watch-for-password-prompt'." :type 'regexp @@ -175,6 +186,8 @@ This is used by `eshell-watch-for-password-prompt'." "A function called from beginning of line to skip the prompt." :type '(choice (const nil) function)) +(make-obsolete-variable 'eshell-skip-prompt-function nil "30.1") + (defcustom eshell-status-in-mode-line t "If non-nil, let the user know a command is running in the mode line." :type 'boolean) @@ -188,6 +201,11 @@ This is used by `eshell-watch-for-password-prompt'." (defvar eshell-first-time-p t "A variable which is non-nil the first time Eshell is loaded.") +(defvar eshell-non-interactive-p nil + "A variable which is non-nil when Eshell is not running interactively. +Modules should use this variable so that they don't clutter +non-interactive sessions, such as when using `eshell-command'.") + ;; Internal Variables: ;; these are only set to nil initially for the sake of the @@ -261,14 +279,13 @@ This is used by `eshell-watch-for-password-prompt'." "C-c" 'eshell-command-map "RET" #'eshell-send-input "M-RET" #'eshell-queue-input - "C-M-l" #'eshell-show-output - "C-a" #'eshell-bol) + "C-M-l" #'eshell-show-output) (defvar-keymap eshell-command-map :prefix 'eshell-command-map "M-o" #'eshell-mark-output "M-d" #'eshell-toggle-direct-send - "C-a" #'eshell-bol + "C-a" #'move-beginning-of-line "C-b" #'eshell-backward-argument "C-e" #'eshell-show-maximum-output "C-f" #'eshell-forward-argument @@ -471,7 +488,7 @@ and the hook `eshell-exit-hook'." (defun eshell-move-argument (limit func property arg) "Move forward ARG arguments." (catch 'eshell-incomplete - (eshell-parse-arguments (save-excursion (eshell-bol) (point)) + (eshell-parse-arguments (save-excursion (beginning-of-line) (point)) (line-end-position))) (let ((pos (save-excursion (funcall func 1) @@ -504,12 +521,7 @@ and the hook `eshell-exit-hook'." (kill-ring-save begin (point)) (yank))) -(defun eshell-bol () - "Go to the beginning of line, then skip past the prompt, if any." - (interactive) - (beginning-of-line) - (and eshell-skip-prompt-function - (funcall eshell-skip-prompt-function))) +(define-obsolete-function-alias 'eshell-bol #'beginning-of-line "30.1") (defsubst eshell-push-command-mark () "Push a mark at the end of the last input text." @@ -525,9 +537,11 @@ Putting this function on `eshell-pre-command-hook' will mimic Plan 9's (custom-add-option 'eshell-pre-command-hook #'eshell-goto-input-start) -(defsubst eshell-interactive-print (string) +(defun eshell-interactive-print (string) "Print STRING to the eshell display buffer." - (eshell-output-filter nil string)) + (when string + (eshell--mark-as-output 0 (length string) string) + (eshell-interactive-filter nil string))) (defsubst eshell-begin-on-new-line () "This function outputs a newline if not at beginning of line." @@ -566,7 +580,7 @@ will return the parsed command." (setq command (eshell-parse-command (cons beg end) args t))))) (ignore - (message "Expecting completion of delimiter %c ..." + (message "Expecting completion of delimiter %s ..." (if (listp delim) (car delim) delim))) @@ -687,14 +701,14 @@ newline." (custom-add-option 'eshell-input-filter-functions 'eshell-kill-new) -(defun eshell-output-filter (process string) - "Send the output from PROCESS (STRING) to the interactive display. +(defun eshell-interactive-filter (buffer string) + "Send output (STRING) to the interactive display, using BUFFER. This is done after all necessary filtering has been done." - (let ((oprocbuf (if process (process-buffer process) - (current-buffer))) - (inhibit-modification-hooks t)) - (when (and string oprocbuf (buffer-name oprocbuf)) - (with-current-buffer oprocbuf + (unless buffer + (setq buffer (current-buffer))) + (when (and string (buffer-live-p buffer)) + (let ((inhibit-modification-hooks t)) + (with-current-buffer buffer (let ((functions eshell-preoutput-filter-functions)) (while (and functions string) (setq string (funcall (car functions) string)) @@ -851,7 +865,7 @@ With a prefix argument, narrows region to last command output." (if (> (point) eshell-last-output-end) (kill-region eshell-last-output-end (point)) (let ((here (point))) - (eshell-bol) + (beginning-of-line) (kill-region (point) here)))) (defun eshell-show-maximum-output (&optional interactive) @@ -879,17 +893,18 @@ If SCROLLBACK is non-nil, clear the scrollback contents." (erase-buffer))) (defun eshell-get-old-input (&optional use-current-region) - "Return the command input on the current line." + "Return the command input on the current line. +If USE-CURRENT-REGION is non-nil, return the current region." (if use-current-region (buffer-substring (min (point) (mark)) (max (point) (mark))) (save-excursion - (beginning-of-line) - (and eshell-skip-prompt-function - (funcall eshell-skip-prompt-function)) - (let ((beg (point))) - (end-of-line) - (buffer-substring beg (point)))))) + (let ((inhibit-field-text-motion t)) + (end-of-line)) + (let ((inhibit-field-text-motion) + (end (point))) + (beginning-of-line) + (buffer-substring-no-properties (point) end))))) (defun eshell-copy-old-input () "Insert after prompt old input at point as new input to be edited." diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el index 651e793ad98..7fc74d38796 100644 --- a/lisp/eshell/esh-module.el +++ b/lisp/eshell/esh-module.el @@ -47,6 +47,7 @@ customizing the variable `eshell-modules-list'." "A hook run when `eshell-module' is unloaded." :type 'hook :group 'eshell-module) +(make-obsolete-variable 'eshell-module-unload-hook nil "30.1") (defcustom eshell-modules-list '(eshell-alias @@ -85,20 +86,37 @@ Changes will only take effect in future Eshell buffers." ;;; Code: +(defsubst eshell-module--feature-name (module &optional kind) + "Get the feature name for the specified Eshell MODULE." + (let ((module-name (symbol-name module)) + (prefix (cond ((eq kind 'core) "esh-") + ((memq kind '(extension nil)) "em-") + (t (error "unknown module kind %s" kind))))) + (if (string-match "^eshell-\\(.*\\)" module-name) + (concat prefix (match-string 1 module-name)) + (error "Invalid Eshell module name: %s" module)))) + (defsubst eshell-using-module (module) "Return non-nil if a certain Eshell MODULE is in use. The MODULE should be a symbol corresponding to that module's customization group. Example: `eshell-cmpl' for that module." (memq module eshell-modules-list)) +(defun eshell-unload-modules (modules &optional kind) + "Try to unload the specified Eshell MODULES." + (dolist (module modules) + (let ((module-feature (intern (eshell-module--feature-name module kind)))) + (when (featurep module-feature) + (message "Unloading %s..." (symbol-name module)) + (condition-case-unless-debug _ + (progn + (unload-feature module-feature) + (message "Unloading %s...done" (symbol-name module))) + (error (message "Unloading %s...failed" (symbol-name module)))))))) + (defun eshell-unload-extension-modules () - "Unload any memory resident extension modules." - (dolist (module (eshell-subgroups 'eshell-module)) - (if (featurep module) - (ignore-errors - (message "Unloading %s..." (symbol-name module)) - (unload-feature module) - (message "Unloading %s...done" (symbol-name module)))))) + "Try to unload all currently-loaded Eshell extension modules." + (eshell-unload-modules (eshell-subgroups 'eshell-module))) (provide 'esh-module) ;;; esh-module.el ends here diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index e8da847e184..09c19767a19 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -29,6 +29,11 @@ ;; defined in esh-util. (require 'esh-util) +(defgroup eshell-opt nil + "Functions for argument parsing in Eshell commands." + :tag "Option parsing" + :group 'eshell) + (defmacro eshell-eval-using-options (name macro-args options &rest body-forms) "Process NAME's MACRO-ARGS using a set of command line OPTIONS. After doing so, stores settings in local symbols as declared by OPTIONS; @@ -132,7 +137,7 @@ This code doesn't really need to be macro expanded everywhere." (setq args (eshell--process-args name args options)) nil)))) (when usage-msg - (error "%s" usage-msg)))))) + (user-error "%s" usage-msg)))))) (if ext-command (throw 'eshell-external (eshell-external-command ext-command orig-args)) @@ -237,7 +242,7 @@ remaining characters in SWITCH to be processed later as further short options. If no matching handler is found, and an :external command is defined -(and available), it will be called; otherwise, an error will be +\(and available), it will be called; otherwise, an error will be triggered to say that the switch is unrecognized." (let ((switch (eshell--split-switch switch kind)) (opts options) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index fcd59ab9f37..00e0c8014e1 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -24,6 +24,7 @@ ;;; Code: (require 'esh-io) +(require 'esh-util) (defgroup eshell-proc nil "When Eshell invokes external commands, it always does so @@ -96,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 @@ -295,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) @@ -309,7 +313,7 @@ Used only on systems which do not support async subprocesses.") :name (concat (file-name-nondirectory command) "-stderr") :buffer (current-buffer) :filter (if (eshell-interactive-output-p eshell-error-handle) - #'eshell-output-filter + #'eshell-interactive-process-filter #'eshell-insertion-filter) :sentinel #'eshell-sentinel)) (eshell-record-process-properties stderr-proc eshell-error-handle)) @@ -325,7 +329,7 @@ Used only on systems which do not support async subprocesses.") :buffer (current-buffer) :command (cons command args) :filter (if (eshell-interactive-output-p) - #'eshell-output-filter + #'eshell-interactive-process-filter #'eshell-insertion-filter) :sentinel #'eshell-sentinel :connection-type conn-type @@ -366,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) @@ -386,15 +392,11 @@ Used only on systems which do not support async subprocesses.") line (buffer-substring-no-properties lbeg lend)) (set-buffer oldbuf) (if interact-p - (eshell-output-filter nil line) + (eshell-interactive-process-filter nil line) (eshell-output-object line)) (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) @@ -407,6 +409,20 @@ Used only on systems which do not support async subprocesses.") (setq proc t)))) proc)) +(defun eshell-interactive-process-filter (process string) + "Send the output from PROCESS (STRING) to the interactive display. +This is done after all necessary filtering has been done." + (when string + (eshell--mark-as-output 0 (length string) string) + (require 'esh-mode) + (declare-function eshell-interactive-filter "esh-mode" (buffer string)) + (eshell-interactive-filter (if process (process-buffer process) + (current-buffer)) + string))) + +(define-obsolete-function-alias 'eshell-output-filter + #'eshell-interactive-process-filter "30.1") + (defun eshell-insertion-filter (proc string) "Insert a string into the eshell buffer, or a process/file/buffer. PROC is the process for which we're inserting output. STRING is the @@ -472,7 +488,7 @@ PROC is the process that's exiting. STRING is the exit message." (if (process-get proc :eshell-busy) (run-at-time 0 nil finish-io) (when data - (ignore-error 'eshell-pipe-broken + (ignore-error eshell-pipe-broken (eshell-output-object data index handles))) (eshell-close-handles diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index d003148dc96..c0685757789 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -94,13 +94,6 @@ a non-nil value, will be passed strings, not numbers, even when an argument matches `eshell-number-regexp'." :type 'boolean) -(defcustom eshell-number-regexp "-?\\([0-9]*\\.\\)?[0-9]+\\(e[-0-9.]+\\)?" - "Regular expression used to match numeric arguments. -If `eshell-convert-numeric-arguments' is non-nil, and an argument -matches this regexp, it will be converted to a Lisp number, using the -function `string-to-number'." - :type 'regexp) - (defcustom eshell-ange-ls-uids nil "List of user/host/id strings, used to determine remote ownership." :type '(repeat (cons :tag "Host for User/UID map" @@ -111,6 +104,22 @@ function `string-to-number'." ;;; Internal Variables: +(defvar eshell-number-regexp + (rx (? "-") + (or (seq (+ digit) (? "." (* digit))) + (seq (* digit) "." (+ digit))) + ;; Optional exponent + (? (or "e" "E") + (or "+INF" "+NaN" + (seq (? (or "+" "-")) (+ digit))))) + "Regular expression used to match numeric arguments. +If `eshell-convert-numeric-arguments' is non-nil, and an argument +matches this regexp, it will be converted to a Lisp number, using the +function `string-to-number'.") + +(defvar eshell-integer-regexp (rx (? "-") (+ digit)) + "Regular expression used to match integer arguments.") + (defvar eshell-group-names nil "A cache to hold the names of groups.") @@ -123,6 +132,19 @@ function `string-to-number'." (defvar eshell-user-timestamp nil "A timestamp of when the user file was read.") +(defvar eshell-command-output-properties + `( field command-output + front-sticky (field) + rear-nonsticky (field) + ;; Text inserted by a user in the middle of process output + ;; should be marked as output. This is needed for commands + ;; such as `yank' or `just-one-space' which don't use + ;; `insert-and-inherit' and thus bypass default text property + ;; inheritance. + insert-in-front-hooks (,#'eshell--mark-as-output + ,#'eshell--mark-yanked-as-output)) + "A list of text properties to apply to command output.") + ;;; Obsolete variables: (define-obsolete-variable-alias 'eshell-host-names @@ -148,6 +170,27 @@ Otherwise, evaluates FORM with no error handling." ,@handlers) form)) +(defun eshell--mark-as-output (start end &optional object) + "Mark the text from START to END as Eshell output. +OBJECT can be a buffer or string. If nil, mark the text in the +current buffer." + (with-silent-modifications + (add-text-properties start end eshell-command-output-properties + object))) + +(defun eshell--mark-yanked-as-output (start end) + "Mark yanked text from START to END as Eshell output." + ;; `yank' removes the field text property from the text it inserts + ;; due to `yank-excluded-properties', so arrange for this text + ;; property to be reapplied in the `after-change-functions'. + (letrec ((hook + (lambda (start1 end1 _len1) + (remove-hook 'after-change-functions hook t) + (when (and (= start start1) + (= end end1)) + (eshell--mark-as-output start1 end1))))) + (add-hook 'after-change-functions hook nil t))) + (defun eshell-find-delimiter (open close &optional bound reverse-p backslash-p) "From point, find the CLOSE delimiter corresponding to OPEN. @@ -362,9 +405,13 @@ Prepend remote identification of `default-directory', if any." "Convert each element of ARGS into a string value." (mapcar #'eshell-stringify args)) +(defsubst eshell-list-to-string (list) + "Convert LIST into a single string separated by spaces." + (mapconcat #'eshell-stringify list " ")) + (defsubst eshell-flatten-and-stringify (&rest args) "Flatten and stringify all of the ARGS into a single string." - (mapconcat #'eshell-stringify (flatten-tree args) " ")) + (eshell-list-to-string (flatten-tree args))) (defsubst eshell-directory-files (regexp &optional directory) "Return a list of files in the given DIRECTORY matching REGEXP." diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index dfc52083acb..7dcaff1e24f 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -86,6 +86,13 @@ ;; Returns the length of the value of $EXPR. This could also be ;; done using the `length' Lisp function. ;; +;; $@EXPR +;; +;; Splices the value of $EXPR in-place into the current list of +;; arguments. This is analogous to the `,@' token in Elisp +;; backquotes, and works as if the user typed '$EXPR[0] $EXPR[1] +;; ... $EXPR[N]'. +;; ;; There are also a few special variables defined by Eshell. '$$' is ;; the value of the last command (t or nil, in the case of an external ;; command). This makes it possible to chain results: @@ -155,6 +162,7 @@ if they are quoted with a backslash." ("COLUMNS" ,(lambda () (window-body-width nil 'remap)) t t) ("LINES" ,(lambda () (window-body-height nil 'remap)) t t) ("INSIDE_EMACS" eshell-inside-emacs t) + ("UID" ,(lambda () (file-user-uid)) nil t) ;; for esh-ext.el ("PATH" (,(lambda () (string-join (eshell-get-path t) (path-separator))) @@ -320,10 +328,9 @@ copied (a.k.a. \"exported\") to the environment of created subprocesses." "Parse a variable interpolation. This function is explicit for adding to `eshell-parse-argument-hook'." (when (and (eq (char-after) ?$) - (/= (1+ (point)) (point-max))) + (/= (1+ (point)) (point-max))) (forward-char) - (list 'eshell-escape-arg - (eshell-parse-variable)))) + (eshell-parse-variable))) (defun eshell/define (var-alias definition) "Define a VAR-ALIAS using DEFINITION." @@ -427,9 +434,14 @@ the values of nil for each." (defun eshell-envvar-names (&optional environment) "Return a list of currently visible environment variable names." - (mapcar (lambda (x) - (substring x 0 (string-search "=" x))) - (or environment process-environment))) + (delete-dups + (append + ;; Real environment variables + (mapcar (lambda (x) + (substring x 0 (string-search "=" x))) + (or environment process-environment)) + ;; Eshell variable aliases + (mapcar #'car eshell-variable-aliases-list)))) (defun eshell-environment-variables () "Return a `process-environment', fully updated. @@ -453,18 +465,24 @@ Its purpose is to call `eshell-parse-variable-ref', and then to process any indices that come after the variable reference." (let* ((get-len (when (eq (char-after) ?#) (forward-char) t)) + (splice (when (eq (char-after) ?@) + (forward-char) t)) value indices) (setq value (eshell-parse-variable-ref get-len) indices (and (not (eobp)) (eq (char-after) ?\[) (eshell-parse-indices)) - ;; This is an expression that will be evaluated by `eshell-do-eval', - ;; which only support let-binding of dynamically-scoped vars - value `(let ((indices (eshell-eval-indices ',indices))) ,value)) + value `(let ((indices ,(eshell-prepare-indices indices))) ,value)) (when get-len (setq value `(length ,value))) (when eshell-current-quoted - (setq value `(eshell-stringify ,value))) + (if splice + (setq value `(eshell-list-to-string ,value) + splice nil) + (setq value `(eshell-stringify ,value)))) + (setq value `(eshell-escape-arg ,value)) + (when splice + (setq value `(eshell-splice-args ,value))) value)) (defun eshell-parse-variable-ref (&optional modifier-p) @@ -481,7 +499,7 @@ Possible variable references are: NAME an environment or Lisp variable value \"LONG-NAME\" disambiguates the length of the name - `LONG-NAME' as above + \\='LONG-NAME\\=' as above {COMMAND} result of command is variable's value (LISP-FORM) result of Lisp form is variable's value <COMMAND> write the output of command to a temporary file; @@ -489,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 @@ -547,15 +566,19 @@ Possible variable references are: (current-buffer))))) indices ,eshell-current-quoted) (end-of-file - (throw 'eshell-incomplete ?\()))) + (throw 'eshell-incomplete "$(")))) ((looking-at (rx-to-string `(or "'" ,(if eshell-current-quoted "\\\"" "\"")))) (eshell-with-temp-command (or (eshell-unescape-inner-double-quote (point-max)) (cons (point) (point-max))) - (let ((name (if (eq (char-after) ?\') - (eshell-parse-literal-quote) - (eshell-parse-double-quote)))) + (let (name) + (when-let ((delim + (catch 'eshell-incomplete + (ignore (setq name (if (eq (char-after) ?\') + (eshell-parse-literal-quote) + (eshell-parse-double-quote))))))) + (throw 'eshell-incomplete (concat "$" delim))) (when name `(eshell-get-variable ,(eval name) indices ,eshell-current-quoted))))) ((assoc (char-to-string (char-after)) @@ -574,14 +597,17 @@ Possible variable references are: (defun eshell-parse-indices () "Parse and return a list of index-lists. +This produces a series of Lisp forms to be processed by +`eshell-prepare-indices' and ultimately evaluated by +`eshell-do-eval'. For example, \"[0 1][2]\" becomes: - ((\"0\" \"1\") (\"2\")." + ((\"0\" \"1\") (\"2\"))." (let (indices) (while (eq (char-after) ?\[) (let ((end (eshell-find-delimiter ?\[ ?\]))) (if (not end) - (throw 'eshell-incomplete ?\[) + (throw 'eshell-incomplete "[") (forward-char) (eshell-with-temp-command (or (eshell-unescape-inner-double-quote end) (cons (point) end)) @@ -592,10 +618,46 @@ For example, \"[0 1][2]\" becomes: (goto-char (1+ end))))) (nreverse indices))) +(defun eshell-parse-index (index) + "Parse a single INDEX in string form. +If INDEX looks like a number, return that number. + +If INDEX looks like \"[BEGIN]..[END]\", where BEGIN and END look +like integers, return a cons cell of BEGIN and END as numbers; +BEGIN and/or END can be omitted here, in which case their value +in the cons is nil. + +Otherwise (including if INDEX is not a string), return +the original value of INDEX." + (save-match-data + (cond + ((and (stringp index) (get-text-property 0 'number index)) + (string-to-number index)) + ((and (stringp index) + (not (text-property-any 0 (length index) 'escaped t index)) + (string-match (rx string-start + (group-n 1 (? (regexp eshell-integer-regexp))) + ".." + (group-n 2 (? (regexp eshell-integer-regexp))) + string-end) + index)) + (let ((begin (match-string 1 index)) + (end (match-string 2 index))) + (cons (unless (string-empty-p begin) (string-to-number begin)) + (unless (string-empty-p end) (string-to-number end))))) + (t + index)))) + (defun eshell-eval-indices (indices) "Evaluate INDICES, a list of index-lists generated by `eshell-parse-indices'." + (declare (obsolete eshell-prepare-indices "30.1")) (mapcar (lambda (i) (mapcar #'eval i)) indices)) +(defun eshell-prepare-indices (indices) + "Prepare INDICES to be evaluated by Eshell. +INDICES is a list of index-lists generated by `eshell-parse-indices'." + `(list ,@(mapcar (lambda (idx-list) (cons 'list idx-list)) indices))) + (defun eshell-get-variable (name &optional indices quoted) "Get the value for the variable NAME. INDICES is a list of index-lists (see `eshell-parse-indices'). @@ -697,98 +759,123 @@ For example, to retrieve the second element of a user's record in '/etc/passwd', the variable reference would look like: ${grep johnw /etc/passwd}[: 2]" - (while indices - (let ((refs (car indices))) - (when (stringp value) - (let (separator (index (caar indices))) - (when (and (stringp index) - (not (get-text-property 0 'number index))) - (setq separator index - refs (cdr refs))) - (setq value (split-string value separator)) - (unless quoted - (setq value (mapcar #'eshell-convert-to-number value))))) - (cond - ((< (length refs) 0) - (error "Invalid array variable index: %s" - (eshell-stringify refs))) - ((= (length refs) 1) - (setq value (eshell-index-value value (car refs)))) - (t - (let ((new-value (list t))) - (while refs - (nconc new-value - (list (eshell-index-value value - (car refs)))) - (setq refs (cdr refs))) - (setq value (cdr new-value)))))) - (setq indices (cdr indices))) - value) + (dolist (refs indices value) + ;; For string values, check if the first index looks like a + ;; regexp, and if so, use that to split the string. + (when (stringp value) + (let (separator (first (car refs))) + (when (stringp (eshell-parse-index first)) + (setq separator first + refs (cdr refs))) + (setq value (split-string value separator)) + (unless quoted + (setq value (mapcar #'eshell-convert-to-number value))))) + (cond + ((< (length refs) 0) + (error "Invalid array variable index: %s" + (eshell-stringify refs))) + ((= (length refs) 1) + (setq value (eshell-index-value value (car refs)))) + (t + (let (new-value) + (dolist (ref refs) + (push (eshell-index-value value ref) new-value)) + (setq value (nreverse new-value))))))) + +(pcase-defmacro eshell-index-range (start end) + "A pattern that matches an Eshell index range. +EXPVAL should be a cons cell, with each slot containing either an +integer or nil. If this matches, bind the values of the sltos to +START and END." + (list '\` (cons (list '\, `(and (or (pred integerp) (pred null)) ,start)) + (list '\, `(and (or (pred integerp) (pred null)) ,end))))) (defun eshell-index-value (value index) "Reference VALUE using the given INDEX." - (when (and (stringp index) (get-text-property 0 'number index)) - (setq index (string-to-number index))) - (if (integerp index) - (cond - ((ring-p value) - (if (> index (ring-length value)) - (error "Index exceeds length of ring") - (ring-ref value index))) - ((listp value) - (if (> index (length value)) - (error "Index exceeds length of list") - (nth index value))) - ((vectorp value) - (if (> index (length value)) - (error "Index exceeds length of vector") - (aref value index))) - (t - (error "Invalid data type for indexing"))) - ;; INDEX is some non-integer value, so treat VALUE as an alist. - (cdr (assoc index value)))) + (let ((parsed-index (eshell-parse-index index))) + (if (ring-p value) + (pcase parsed-index + ((pred integerp) + (ring-ref value parsed-index)) + ((eshell-index-range start end) + (let* ((len (ring-length value)) + (real-start (mod (or start 0) len)) + (real-end (mod (or end len) len))) + (when (and (eq real-end 0) + (not (eq end 0))) + (setq real-end len)) + (ring-convert-sequence-to-ring + (seq-subseq (ring-elements value) real-start real-end)))) + (_ + (error "Invalid index for ring: %s" index))) + (pcase parsed-index + ((pred integerp) + (when (< parsed-index 0) + (setq parsed-index (+ parsed-index (length value)))) + (seq-elt value parsed-index)) + ((eshell-index-range start end) + (seq-subseq value (or start 0) end)) + (_ + ;; INDEX is some non-integer value, so treat VALUE as an alist. + (cdr (assoc parsed-index value))))))) ;;;_* Variable name completion (defun eshell-complete-variable-reference () "If there is a variable reference, complete it." - (let ((arg (pcomplete-actual-arg)) index) - (when (setq index - (string-match - (concat "\\$\\(" eshell-variable-name-regexp - "\\)?\\'") arg)) - (setq pcomplete-stub (substring arg (1+ index))) + (let ((arg (pcomplete-actual-arg))) + (when (string-match + (rx "$" (? (or "#" "@")) + (? (or (group-n 1 (regexp eshell-variable-name-regexp) + string-end) + (seq (group-n 2 (or "'" "\"")) + (group-n 1 (+ anychar)))))) + arg) + (setq pcomplete-stub (substring arg (match-beginning 1))) + (let ((delimiter (match-string 2 arg))) + ;; When finished with completion, insert the trailing + ;; delimiter, if any, and add a trailing slash if the variable + ;; refers to a directory. + (add-function + :before-until (var pcomplete-exit-function) + (lambda (variable status) + (when (eq status 'finished) + (when delimiter + (if (looking-at (regexp-quote delimiter)) + (goto-char (match-end 0)) + (insert delimiter))) + (let ((non-essential t) + (value (eshell-get-variable variable))) + (when (and (stringp value) (file-directory-p value)) + (insert "/") + ;; Tell Pcomplete not to insert its own termination + ;; string. + t)))))) (throw 'pcomplete-completions (eshell-variables-list))))) (defun eshell-variables-list () "Generate list of applicable variables." - (let ((argname pcomplete-stub) - completions) - (dolist (alias eshell-variable-aliases-list) - (if (string-match (concat "^" argname) (car alias)) - (setq completions (cons (car alias) completions)))) + (let ((argname pcomplete-stub)) (sort - (append - (mapcar - (lambda (varname) - (let ((value (eshell-get-variable varname))) - (if (and value - (stringp value) - (file-directory-p value)) - (concat varname "/") - varname))) - (eshell-envvar-names (eshell-environment-variables))) - (all-completions argname obarray 'boundp) - completions) - 'string-lessp))) + (append (eshell-envvar-names) + (all-completions argname obarray #'boundp)) + #'string-lessp))) (defun eshell-complete-variable-assignment () "If there is a variable assignment, allow completion of entries." - (let ((arg (pcomplete-actual-arg)) pos) - (when (string-match (concat "\\`" eshell-variable-name-regexp "=") arg) - (setq pos (match-end 0)) - (if (string-match "\\(:\\)[^:]*\\'" arg) - (setq pos (match-end 1))) + (catch 'not-assignment + ;; The current argument can only be a variable assignment if all + ;; arguments leading up to it are also variable assignments. See + ;; `eshell-handle-local-variables'. + (dotimes (offset (1+ pcomplete-index)) + (unless (string-match (concat "\\`" eshell-variable-name-regexp "=") + (pcomplete-actual-arg 'first offset)) + (throw 'not-assignment nil))) + ;; We have a variable assignment. Handle it. + (let ((arg (pcomplete-actual-arg)) + (pos (match-end 0))) + (when (string-match "\\(:\\)[^:]*\\'" arg) + (setq pos (match-end 1))) (setq pcomplete-stub (substring arg pos)) (throw 'pcomplete-completions (pcomplete-entries))))) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 7a7ece5cb7c..15fc2ae6310 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -199,10 +199,11 @@ shells such as bash, zsh, rc, 4dos." :type 'hook :group 'eshell) -(defcustom eshell-unload-hook '(eshell-unload-all-modules) +(defcustom eshell-unload-hook nil "A hook run when Eshell is unloaded from memory." :type 'hook :group 'eshell) +(make-obsolete-variable 'eshell-unload-hook nil "30.1") (defcustom eshell-buffer-name "*eshell*" "The basename used for Eshell buffers. @@ -267,50 +268,42 @@ information on Eshell, see Info node `(eshell)Top'." (define-obsolete-function-alias 'eshell-return-exits-minibuffer #'eshell-command-mode "28.1") -(defvar eshell-non-interactive-p nil - "A variable which is non-nil when Eshell is not running interactively. -Modules should use this variable so that they don't clutter -non-interactive sessions, such as when using `eshell-command'.") +(defvar eshell-non-interactive-p) ; Defined in esh-mode.el. (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*"))) @@ -328,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 @@ -373,28 +366,14 @@ corresponding to a successful execution." (set status-var eshell-last-command-status)) (cadr result)))))) -;;; Code: - -(defun eshell-unload-all-modules () - "Unload all modules that were loaded by Eshell, if possible. -If the user has require'd in any of the modules, or customized a -variable with a :require tag (such as `eshell-prefer-to-shell'), it -will be impossible to unload Eshell completely without restarting -Emacs." - ;; if the user set `eshell-prefer-to-shell' to t, but never loaded - ;; Eshell, then `eshell-subgroups' will be unbound - (when (fboundp 'eshell-subgroups) - (dolist (module (eshell-subgroups 'eshell)) - ;; this really only unloads as many modules as possible, - ;; since other `require' references (such as by customizing - ;; `eshell-prefer-to-shell' to a non-nil value) might make it - ;; impossible to unload Eshell completely - (if (featurep module) - (ignore-errors - (message "Unloading %s..." (symbol-name module)) - (unload-feature module) - (message "Unloading %s...done" (symbol-name module))))) - (message "Unloading eshell...done"))) +(defun eshell-unload-function () + (eshell-unload-extension-modules) + ;; Wait to unload core modules until after `eshell' has finished + ;; unloading. `eshell' depends on several of them, so they can't be + ;; unloaded immediately. + (run-at-time 0 nil #'eshell-unload-modules + (reverse (eshell-subgroups 'eshell)) 'core) + nil) (run-hooks 'eshell-load-hook) diff --git a/lisp/files.el b/lisp/files.el index d325729bf4d..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) @@ -4025,6 +4025,7 @@ major-mode." (forward-line 1) (let ((startpos (point)) endpos + (selective-p (eq selective-display t)) (thisbuf (current-buffer))) (save-excursion (unless (let ((case-fold-search t)) @@ -4041,7 +4042,8 @@ major-mode." (with-temp-buffer (insert-buffer-substring thisbuf startpos endpos) (goto-char (point-min)) - (subst-char-in-region (point) (point-max) ?\^m ?\n) + (if selective-p + (subst-char-in-region (point) (point-max) ?\r ?\n)) (while (not (eobp)) ;; Discard the prefix. (if (looking-at prefix) @@ -6207,11 +6209,11 @@ instance of such commands." (rename-buffer (generate-new-buffer-name base-name)) (force-mode-line-update)))) -(defun files--ensure-directory (mkdir dir) - "Use function MKDIR to make directory DIR if it is not already a directory. +(defun files--ensure-directory (dir) + "Make directory DIR if it is not already a directory. Return non-nil if DIR is already a directory." (condition-case err - (funcall mkdir dir) + (make-directory-internal dir) (error (or (file-directory-p dir) (signal (car err) (cdr err)))))) @@ -6237,32 +6239,27 @@ Signal an error if unsuccessful." ;; If default-directory is a remote directory, ;; make sure we find its make-directory handler. (setq dir (expand-file-name dir)) - (let ((mkdir (if-let ((handler (find-file-name-handler dir 'make-directory))) - #'(lambda (dir) - ;; Use 'ignore' since the handler might be designed for - ;; Emacs 28-, so it might return an (undocumented) - ;; non-nil value, whereas the Emacs 29+ convention is - ;; to return nil here. - (ignore (funcall handler 'make-directory dir))) - #'make-directory-internal))) - (if (not parents) - (funcall mkdir dir) - (let ((dir (directory-file-name (expand-file-name dir))) - already-dir create-list parent) - (while (progn - (setq parent (directory-file-name - (file-name-directory dir))) - (condition-case () - (ignore (setq already-dir - (files--ensure-directory mkdir dir))) - (error - ;; Do not loop if root does not exist (Bug#2309). - (not (string= dir parent))))) - (setq create-list (cons dir create-list) - dir parent)) - (dolist (dir create-list) - (setq already-dir (files--ensure-directory mkdir dir))) - already-dir)))) + (let ((handler (find-file-name-handler dir 'make-directory))) + (if handler + (funcall handler 'make-directory dir parents) + (if (not parents) + (make-directory-internal dir) + (let ((dir (directory-file-name (expand-file-name dir))) + already-dir create-list parent) + (while (progn + (setq parent (directory-file-name + (file-name-directory dir))) + (condition-case () + (ignore (setq already-dir + (files--ensure-directory dir))) + (error + ;; Do not loop if root does not exist (Bug#2309). + (not (string= dir parent))))) + (setq create-list (cons dir create-list) + dir parent)) + (dolist (dir create-list) + (setq already-dir (files--ensure-directory dir))) + already-dir))))) (defun make-empty-file (filename &optional parents) "Create an empty file FILENAME. @@ -6355,6 +6352,12 @@ RECURSIVE if DIRECTORY is nonempty." directory-exists)) (files--force recursive #'delete-directory-internal directory)))))) +(defcustom remote-file-name-inhibit-delete-by-moving-to-trash nil + "Whether remote files shall be moved to the Trash. +This overrules any setting of `delete-by-moving-to-trash'." + :version "30.1" + :type 'boolean) + (defun file-equal-p (file1 file2) "Return non-nil if files FILE1 and FILE2 name the same file. If FILE1 or FILE2 does not exist, the return value is unspecified." @@ -7118,10 +7121,11 @@ specifies the list of buffers to kill, asking for approval for each one." (setq list (cdr list)))) (defun kill-matching-buffers (regexp &optional internal-too no-ask) - "Kill buffers whose name matches the specified REGEXP. -Ignores buffers whose name starts with a space, unless optional -prefix argument INTERNAL-TOO is non-nil. Asks before killing -each buffer, unless NO-ASK is non-nil." + "Kill buffers whose names match the regular expression REGEXP. +Interactively, prompt for REGEXP. +Ignores buffers whose names start with a space, unless optional +prefix argument INTERNAL-TOO(interactively, the prefix argument) +is non-nil. Asks before killing each buffer, unless NO-ASK is non-nil." (interactive "sKill buffers matching this regular expression: \nP") (dolist (buffer (buffer-list)) (let ((name (buffer-name buffer))) @@ -7130,6 +7134,17 @@ each buffer, unless NO-ASK is non-nil." (string-match regexp name)) (funcall (if no-ask 'kill-buffer 'kill-buffer-ask) buffer))))) +(defun kill-matching-buffers-no-ask (regexp &optional internal-too) + "Kill buffers whose names match the regular expression REGEXP. +Interactively, prompt for REGEXP. +Like `kill-matching-buffers', but doesn't ask for confirmation +before killing each buffer. +Ignores buffers whose names start with a space, unless the +optional argument INTERNAL-TOO (interactively, the prefix argument) +is non-nil." + (interactive "sKill buffers matching this regular expression: \nP") + (kill-matching-buffers regexp internal-too t)) + (defun rename-auto-save-file () "Adjust current buffer's auto save file name for current conditions. @@ -7675,7 +7690,7 @@ If DIR's free space cannot be obtained, this function returns nil." ;; This avoids recognizing `1 may 1997' as a date in the line: ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README - ;; The "[BkKMGTPEZY]?" below supports "ls -alh" output. + ;; The "[BkKMGTPEZYRQ]?" below supports "ls -alh" output. ;; For non-iso date formats, we add the ".*" in order to find ;; the last possible match. This avoids recognizing @@ -7687,8 +7702,8 @@ If DIR's free space cannot be obtained, this function returns nil." ;; parentheses: ;; -rw-r--r-- (modified) 2005-10-22 21:25 files.el ;; This is not supported yet. - (purecopy (concat "\\([0-9][BkKMGTPEZY]? " iso - "\\|.*[0-9][BkKMGTPEZY]? " + (purecopy (concat "\\([0-9][BkKMGTPEZYRQ]? " iso + "\\|.*[0-9][BkKMGTPEZYRQ]? " "\\(" western "\\|" western-comma "\\|" DD-MMM-YYYY "\\|" east-asian "\\)" "\\) +"))) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index af029fb2074..db2f5e7d026 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -50,10 +50,13 @@ than the latter." :group 'find-dired :type 'string) +(defvar find-gnu-find-p + (eq 0 (ignore-errors + (process-file find-program nil nil nil null-device "--version"))) + "Non-nil if `find-program' is a GNU Find, nil otherwise.") + (defvar find-ls-option-default-ls - (cons "-ls" (if (memq system-type '(berkeley-unix darwin)) - "-dgils" - "-dilsb"))) + (cons "-ls" (if find-gnu-find-p "-dilsb" "-dgils"))) (defvar find-ls-option-default-exec (cons (format "-exec ls -ld {} %s" find-exec-terminator) "-ld")) diff --git a/lisp/frame.el b/lisp/frame.el index bf984da0d62..39e8a4c88b8 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -239,7 +239,8 @@ that's not the whole story: see `after-focus-change-function'." This function runs the abnormal hook `move-frame-functions'." (interactive "e") (let ((frame (posn-window (event-start event)))) - (run-hook-with-args 'move-frame-functions frame))) + (when (frame-live-p frame) ;Experience shows it can die in the meantime. + (run-hook-with-args 'move-frame-functions frame)))) ;;;; Arrangement of frames at startup @@ -1193,7 +1194,7 @@ e.g. (mapc \\='frame-set-background-mode (frame-list))." (defvar inhibit-frame-set-background-mode nil) -(defun frame--current-backround-mode (frame) +(defun frame--current-background-mode (frame) (let* ((frame-default-bg-mode (frame-terminal-default-bg-mode frame)) (bg-color (frame-parameter frame 'background-color)) (tty-type (tty-type frame)) @@ -1223,7 +1224,7 @@ If optional arg KEEP-FACE-SPECS is non-nil, don't recalculate face specs for the new background mode." (unless inhibit-frame-set-background-mode (let* ((bg-mode - (frame--current-backround-mode frame)) + (frame--current-background-mode frame)) (display-type (cond ((null (window-system frame)) (if (tty-display-color-p frame) 'color 'mono)) @@ -1302,7 +1303,7 @@ the `background-mode' terminal parameter." ;; :global t ;; :group 'faces ;; (when (eq dark-mode -;; (eq 'light (frame--current-backround-mode (selected-frame)))) +;; (eq 'light (frame--current-background-mode (selected-frame)))) ;; ;; FIXME: Change the face's SPEC instead? ;; (set-face-attribute 'default nil ;; :foreground (face-attribute 'default :background) @@ -3111,6 +3112,9 @@ If FRAME isn't maximized, show the title bar." frame 'undecorated (eq (alist-get 'fullscreen (frame-parameters frame)) 'maximized))) +(define-obsolete-function-alias 'frame--current-backround-mode + #'frame--current-background-mode "30.1") + (provide 'frame) ;;; frame.el ends here 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-registry.el b/lisp/gnus/gnus-registry.el index 45771e7a204..d9834031b80 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -394,7 +394,7 @@ This is not required after changing `gnus-registry-cache-file'." (with-no-warnings (eieio-persistent-read file 'registry-db)) ;; Older EIEIO versions do not check the class name. - ('wrong-number-of-arguments + (wrong-number-of-arguments (eieio-persistent-read file))))) (gnus-message 5 "Reading Gnus registry from %s...done" file)) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 27c71fa6c6a..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 @@ -1330,9 +1332,10 @@ elements are present." (1- nyear) nyear)) (setq dmonth 1)))) - (format-time-string - "%e-%b-%Y" - (encode-time 0 0 0 dday dmonth dyear)))) + (with-locale-environment "C" + (format-time-string + "%e-%b-%Y" + (encode-time 0 0 0 dday dmonth dyear))))) (cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) (str string)) @@ -2173,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/message.el b/lisp/gnus/message.el index f4cfffa2e8a..8d3fe010af4 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -6862,10 +6862,9 @@ are not included." (defun message-setup-1 (headers &optional yank-action actions return-action) (dolist (action actions) - (condition-case nil - ;; FIXME: Use functions rather than expressions! - (add-to-list 'message-send-actions - `(apply #',(car action) ',(cdr action))))) + ;; FIXME: Use functions rather than expressions! + (add-to-list 'message-send-actions + `(apply #',(car action) ',(cdr action)))) (setq message-return-action return-action) (setq message-reply-buffer (if (and (consp yank-action) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 60ee5d82e18..6025ca7e72a 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -1484,10 +1484,12 @@ Ask for type, description or disposition according to (setq disposition (mml-minibuffer-read-disposition type nil file))) (mml-attach-file file type description disposition))))) -(defun mml-attach-buffer (buffer &optional type description disposition) +(defun mml-attach-buffer (buffer &optional type description disposition filename) "Attach a buffer to the outgoing MIME message. BUFFER is the name of the buffer to attach. See -`mml-attach-file' for details of operation." +`mml-attach-file' regarding TYPE, DESCRIPTION and DISPOSITION. +FILENAME is a suggested file name for the attachment should a +recipient wish to save a copy separate from the message." (interactive (let* ((buffer (read-buffer "Attach buffer: ")) (type (mml-minibuffer-read-type buffer "text/plain")) @@ -1497,9 +1499,10 @@ BUFFER is the name of the buffer to attach. See ;; If in the message header, attach at the end and leave point unchanged. (let ((head (unless (message-in-body-p) (point)))) (if head (goto-char (point-max))) - (mml-insert-empty-tag 'part 'type type 'buffer buffer - 'disposition disposition - 'description description) + (apply #'mml-insert-empty-tag + 'part 'type type 'buffer buffer + 'disposition disposition 'description description + (and filename `(filename ,filename))) ;; When using Mail mode, make sure it does the mime encoding ;; when you send the message. (or (eq mail-user-agent 'message-user-agent) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index c7a75105c08..8728aab1def 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -339,8 +339,15 @@ all. This may very well take some time.") ;; for this header) or one list (specifying all the possible values for this ;; header). In the latter case, the list does NOT include the unspecified ;; spec (*). + ;; For time zone values, we have symbolic time zone names associated with ;; the (relative) number of seconds ahead GMT. + ;; The list of time zone values is obsolescent, and new code should + ;; not rely on it. Many of the time zone abbreviations are wrong; + ;; in particular, all single-letter abbreviations other than "Z" have + ;; been wrong since Internet RFC 2822 (2001). However, the + ;; abbreviations have not been changed due to backward compatibility + ;; concerns. ) (defsubst nndiary-schedule () @@ -1366,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 a1fc2267564..a939cc0b509 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -769,7 +769,7 @@ the C sources, too." (and (symbolp function) (not (eq (car-safe (symbol-function function)) 'macro)) (let* ((interactive-only - (or (get function 'interactive-only) + (or (function-get function 'interactive-only) (if (boundp 'byte-compile-interactive-only-functions) (memq function byte-compile-interactive-only-functions))))) @@ -778,7 +778,7 @@ the C sources, too." ;; Cf byte-compile-form. (cond ((stringp interactive-only) (format ";\n in Lisp code %s" interactive-only)) - ((and (symbolp 'interactive-only) + ((and (symbolp interactive-only) (not (eq interactive-only t))) (format-message ";\n in Lisp code use `%s' instead." interactive-only)) @@ -996,7 +996,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (symbol-name function))))))) (real-def (cond ((and aliased (not (subrp def))) - (car (function-alias-p real-function t))) + (car (function-alias-p real-function))) ((subrp def) (intern (subr-name def))) (t def)))) @@ -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) @@ -2004,8 +2004,8 @@ variable with value KEYMAP." (mapatoms (lambda (symb) (when (and (boundp symb) (eq (symbol-value symb) keymap) - (not (eq symb 'keymap)) - (throw 'found-keymap symb))))) + (not (eq symb 'keymap))) + (throw 'found-keymap symb)))) nil))) ;; Follow aliasing. (or (ignore-errors (indirect-variable name)) name)))) 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 f46127a20e0..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. @@ -137,10 +138,11 @@ See `icomplete-delay-completions-threshold'." "Maximum number of initial chars to apply `icomplete-compute-delay'." :type 'integer) -(defvar icomplete-in-buffer nil +(defcustom icomplete-in-buffer nil "If non-nil, also use Icomplete when completing in non-mini buffers. This affects commands like `completion-in-region', but not commands -that use their own completions setup.") +that use their own completions setup." + :type 'boolean) (defcustom icomplete-minibuffer-setup-hook nil "Icomplete-specific customization of minibuffer setup. @@ -714,11 +716,13 @@ If it's on, just add the vertical display." Should be run via minibuffer `post-command-hook'. See `icomplete-mode' and `minibuffer-setup-hook'." (when (and icomplete-mode + ;; Check if still in the right buffer (bug#61308) + (or (window-minibuffer-p) completion-in-region--data) (icomplete-simple-completing-p)) ;Shouldn't be necessary. (let ((saved-point (point))) (save-excursion (goto-char (icomplete--field-end)) - ; Insert the match-status information: + ;; Insert the match-status information: (when (and (or icomplete-show-matches-on-no-input (not (equal (icomplete--field-string) icomplete--initial-input))) diff --git a/lisp/ido.el b/lisp/ido.el index 98633d5d798..00a2e57f7ba 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -565,11 +565,12 @@ the `ido-work-directory-list' list." (defcustom ido-use-filename-at-point nil "Non-nil means that Ido shall look for a filename at point. -May use `ffap-guesser' to guess whether text at point is a filename. -If found, use that as the starting point for filename selection." +Value `guess' means use `ffap-guesser' to guess whether text at +point is a filename. If found, use that as the starting point +for filename selection." :type '(choice (const :tag "Disabled" nil) - (const :tag "Guess filename" guess) + (const :tag "Guess filename using ffap-guesser" guess) (other :tag "Use literal filename" t))) diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 1820defa195..fa28c1bf7a5 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -1086,7 +1086,7 @@ Otherwise, display the image by calling `image-mode'." (unwind-protect (progn (setq-local image-fit-to-window-lock t) - (ignore-error 'remote-file-error + (ignore-error remote-file-error (image-toggle-display-image))) (setq image-fit-to-window-lock nil))))))))))) diff --git a/lisp/image.el b/lisp/image.el index 104fea407ff..08190cf86bc 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -449,7 +449,7 @@ type if we can't otherwise guess it." (require 'image-converter) (image-convert-p source)))))) (unless type - (signal 'unknown-image-type "Cannot determine image type"))) + (signal 'unknown-image-type '("Cannot determine image type")))) (when (and (not (eq type 'image-convert)) (not (memq type (and (boundp 'image-types) image-types)))) (error "Invalid image type `%s'" type)) diff --git a/lisp/image/exif.el b/lisp/image/exif.el index 503e3ffadc7..4807df0fbbb 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -151,7 +151,7 @@ If the orientation isn't present in the data, return nil." (defun exif--parse-jpeg () (unless (= (exif--read-number-be 2) #xffd8) ; SOI (start of image) - (signal 'exif-error "Not a valid JPEG file")) + (signal 'exif-error '("Not a valid JPEG file"))) (cl-loop for segment = (exif--read-number-be 2) for size = (exif--read-number-be 2) ;; Stop parsing when we get to SOS (start of stream); @@ -168,7 +168,7 @@ If the orientation isn't present in the data, return nil." ;; The Exif data is in the APP1 JPEG chunk and starts with ;; "Exif\0\0". (unless (equal (exif--read-chunk 6) (string ?E ?x ?i ?f ?\0 ?\0)) - (signal 'exif-error "Not a valid Exif chunk")) + (signal 'exif-error '("Not a valid Exif chunk"))) (delete-region (point-min) (point)) (let* ((endian-marker (exif--read-chunk 2)) (le (cond @@ -180,14 +180,15 @@ If the orientation isn't present in the data, return nil." t) (t (signal 'exif-error - (format "Invalid endian-ness %s" endian-marker)))))) + (list (format "Invalid endian-ness %s" + endian-marker))))))) ;; Another magical number. (unless (= (exif--read-number 2 le) #x002a) - (signal 'exif-error "Invalid TIFF header length")) + (signal 'exif-error '("Invalid TIFF header length"))) (let ((offset (exif--read-number 4 le))) ;; Jump to where the IFD (directory) starts and parse it. (when (> (1+ offset) (point-max)) - (signal 'exif-error "Invalid IFD (directory) offset")) + (signal 'exif-error '("Invalid IFD (directory) offset"))) (goto-char (1+ offset)) (exif--parse-directory le))))) @@ -230,7 +231,7 @@ If the orientation isn't present in the data, return nil." (when (> (+ (1+ value) length) (point-max)) (signal 'exif-error - "Premature end of file")) + '("Premature end of file"))) (buffer-substring (1+ value) (+ (1+ value) length))) @@ -248,7 +249,7 @@ If the orientation isn't present in the data, return nil." ;; keep parsing. (progn (when (> (1+ next) (point-max)) - (signal 'exif-error "Invalid IFD (directory) next-offset")) + (signal 'exif-error '("Invalid IFD (directory) next-offset"))) (goto-char (1+ next)) (nconc dir (exif--parse-directory le))) ;; We've reached the end of the directories. @@ -287,7 +288,7 @@ VALUE is little-endian, otherwise it is big-endian." "Return BYTES octets from the current buffer and advance point that much. This function assumes that the current buffer is unibyte." (when (> (+ (point) bytes) (point-max)) - (signal 'exif-error "Premature end of file")) + (signal 'exif-error '("Premature end of file"))) (prog1 (buffer-substring (point) (+ (point) bytes)) (forward-char bytes))) @@ -297,7 +298,7 @@ This function assumes that the current buffer is unibyte." Advance point to after the read bytes. This function assumes that the current buffer is unibyte." (when (> (+ (point) bytes) (point-max)) - (signal 'exif-error "Premature end of file")) + (signal 'exif-error '("Premature end of file"))) (let ((sum 0)) (dotimes (_ bytes) (setq sum (+ (* sum 256) (following-char))) @@ -309,7 +310,7 @@ This function assumes that the current buffer is unibyte." Advance point to after the read bytes. This function assumes that the current buffer is unibyte." (when (> (+ (point) bytes) (point-max)) - (signal 'exif-error "Premature end of file")) + (signal 'exif-error '("Premature end of file"))) (let ((sum 0)) (dotimes (i bytes) (setq sum (+ (* (following-char) (expt 256 i)) sum)) diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index 6ecb307ce12..b13b3e08ce2 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -424,11 +424,10 @@ This affects the following commands: (file-name-nondirectory thumb-file))) thumb-file)) -(defun image-dired-insert-thumbnail ( file original-file-name - associated-dired-buffer image-number) +(defun image-dired-insert-thumbnail (file original-file-name + associated-dired-buffer) "Insert thumbnail image FILE. -Add text properties ORIGINAL-FILE-NAME, ASSOCIATED-DIRED-BUFFER -and IMAGE-NUMBER." +Add text properties ORIGINAL-FILE-NAME, ASSOCIATED-DIRED-BUFFER." (let (beg end) (setq beg (point)) (image-dired-insert-image @@ -452,7 +451,6 @@ and IMAGE-NUMBER." 'keymap nil 'original-file-name original-file-name 'associated-dired-buffer associated-dired-buffer - 'image-number image-number 'tags (image-dired-list-tags original-file-name) 'mouse-face 'highlight 'comment (image-dired-get-comment original-file-name))))) @@ -587,8 +585,8 @@ thumbnail buffer to be selected." (dolist (file files) (when (string-match-p (image-dired--file-name-regexp) file) (image-dired-insert-thumbnail - (image-dired--get-create-thumbnail-file file) file dired-buf - (cl-incf image-dired--number-of-thumbnails))))) + (image-dired--get-create-thumbnail-file file) file dired-buf) + (cl-incf image-dired--number-of-thumbnails)))) (if (> image-dired--number-of-thumbnails 0) (if do-not-pop (display-buffer buf) @@ -789,7 +787,10 @@ comment." (let ((file-name (image-dired-original-file-name)) (dired-buf (buffer-name (image-dired-associated-dired-buffer))) (image-count (format "%s/%s" - (get-text-property (point) 'image-number) + ;; Line-up adds one space between two + ;; images: this formula takes this into + ;; account. + (1+ (/ (point) 2)) image-dired--number-of-thumbnails)) (props (string-join (get-text-property (point) 'tags) ", ")) (comment (get-text-property (point) 'comment)) @@ -1127,10 +1128,12 @@ With a negative prefix argument, prompt user for the delay." "Remove current thumbnail from thumbnail buffer and line up." (interactive nil image-dired-thumbnail-mode) (let ((inhibit-read-only t)) - (delete-char 1)) + (delete-char 1) + (cl-decf image-dired--number-of-thumbnails)) (let ((pos (point))) (image-dired--line-up-with-method) - (goto-char pos))) + (goto-char pos) + (image-dired--update-header-line))) (defun image-dired-line-up () "Line up thumbnails according to `image-dired-thumbs-per-row'. diff --git a/lisp/imenu.el b/lisp/imenu.el index 25a02004570..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) @@ -756,9 +756,11 @@ Returns t for rescan and otherwise an element or subelement of INDEX-ALIST." (setq index-alist (imenu--split-submenus index-alist)) (let* ((menu (imenu--split-menu index-alist (or title (buffer-name)))) (map (imenu--create-keymap (car menu) - (cdr (if (< 1 (length (cdr menu))) - menu - (car (cdr menu))))))) + (cdr (if (and (null (cddr menu)) + (stringp (caadr menu)) + (consp (cdadr menu))) + (cadr menu) + menu))))) (popup-menu map event))) (defun imenu-choose-buffer-index (&optional prompt alist) @@ -854,13 +856,12 @@ A trivial interface to `imenu-add-to-menubar' suitable for use in a hook." (buffer-name))) (menu1 (imenu--create-keymap (car menu) - (cdr (if (or (< 1 (length (cdr menu))) - ;; Have we a non-nested single entry? - (atom (cdadr menu)) - (atom (cadadr menu))) - menu - (car (cdr menu)))) - 'imenu--menubar-select))) + (cdr (if (and (null (cddr menu)) + (stringp (caadr menu)) + (consp (cdadr menu))) + (cadr menu) + menu)) + 'imenu--menubar-select))) (setcdr imenu--menubar-keymap (cdr menu1))))))) (defun imenu--menubar-select (item) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index 04854ede6be..856c405b545 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -68,38 +68,86 @@ representing names. For instance: (defvar emoji--all-bases nil) (defvar emoji--derived nil) (defvar emoji--names (make-hash-table :test #'equal)) -(defvar emoji--done-derived nil) (define-multisession-variable emoji--recent (list "😀" "😖")) (defvar emoji--insert-buffer) -;;;###autoload -(defun emoji-insert () +;;;###autoload (autoload 'emoji-insert "emoji" nil t) +(transient-define-prefix emoji-insert () "Choose and insert an emoji glyph." + :variable-pitch t + [:class transient-columns + :setup-children emoji--setup-suffixes + :description emoji--group-description] (interactive "*") (emoji--init) - (unless (fboundp 'emoji--command-Emoji) - (emoji--define-transient)) - (funcall (intern "emoji--command-Emoji"))) + (emoji--setup-prefix 'emoji-insert "Emoji" nil + `(("Recent" ,@(multisession-value emoji--recent)) + ,@emoji--labels))) -;;;###autoload -(defun emoji-recent () +;;;###autoload (autoload 'emoji-recent "emoji" nil t) +(transient-define-prefix emoji-recent () "Choose and insert one of the recently-used emoji glyphs." + :variable-pitch t + [:class transient-columns + :setup-children emoji--setup-suffixes + :description emoji--group-description] (interactive "*") (emoji--init) - (unless (fboundp 'emoji--command-Emoji) - (emoji--define-transient)) - (funcall (emoji--define-transient - (cons "Recent" (multisession-value emoji--recent)) t))) + (emoji--setup-prefix 'emoji-recent "Recent" t + (multisession-value emoji--recent))) -;;;###autoload -(defun emoji-search () +;;;###autoload (autoload 'emoji-search "emoji" nil t) +(transient-define-prefix emoji-search () "Choose and insert an emoji glyph by typing its Unicode name. This command prompts for an emoji name, with completion, and inserts it. It recognizes the Unicode Standard names of emoji, and also consults the `emoji-alternate-names' alist." + :variable-pitch t + [:class transient-columns + :setup-children emoji--setup-suffixes + :description emoji--group-description] (interactive "*") (emoji--init) - (emoji--choose-emoji)) + (pcase-let ((`(,glyph . ,derived) (emoji--read-emoji))) + (if derived + (emoji--setup-prefix 'emoji-search "Choose Emoji" + (list glyph) + (cons glyph derived)) + (emoji--add-recent glyph) + (insert glyph)))) + +(defclass emoji--narrow (transient-suffix) + ((title :initarg :title) + (done-derived :initarg :done-derived) + (children :initarg :children))) + +(defun emoji--setup-prefix (command title done-derived spec) + (transient-setup + command nil nil + :scope (if (eq transient-current-command command) + (cons (oref (transient-suffix-object) title) + (oref (transient-suffix-object) done-derived)) + (cons title done-derived)) + :value (if (eq transient-current-command command) + (oref (transient-suffix-object) children) + spec))) + +(defun emoji--setup-suffixes (_) + (transient-parse-suffixes + (oref transient--prefix command) + (pcase-let ((`(,title . ,done-derived) (oref transient--prefix scope))) + (emoji--layout (oref transient--prefix command) title + (oref transient--prefix value) done-derived)))) + +(defun emoji--group-description () + (car (oref transient--prefix scope))) + +(transient-define-suffix emoji-insert-glyph () + "Insert the emoji you selected." + (interactive nil not-a-mode) + (let ((glyph (oref (transient-suffix-object) description))) + (emoji--add-recent glyph) + (insert glyph))) ;;;###autoload (defun emoji-list () @@ -179,11 +227,10 @@ the name is not known." 'help-echo (emoji--name glyph)))) (insert "\n\n")))) -(defun emoji--fontify-glyph (glyph &optional inhibit-derived) +(defun emoji--fontify-glyph (glyph &optional done-derived) (propertize glyph 'face - (if (and (not inhibit-derived) - (or (null emoji--done-derived) - (not (gethash glyph emoji--done-derived))) + (if (and (not (or (eq done-derived t) + (member glyph done-derived))) (gethash glyph emoji--derived)) ;; If this emoji has derivations, use a special face ;; to tell the user. @@ -206,33 +253,30 @@ the name is not known." :interactive nil (setq-local truncate-lines t)) -(defun emoji-list-select (event) +;;;###autoload (autoload 'emoji-list-select "emoji" nil t) +(transient-define-prefix emoji-list-select (event) "Select the emoji under point." + :variable-pitch t + [:class transient-columns + :setup-children emoji--setup-suffixes + :description emoji--group-description] (interactive (list last-nonmenu-event) emoji-list-mode) (mouse-set-point event) (let ((glyph (get-text-property (point) 'emoji-glyph))) (unless glyph (error "No emoji under point")) - (let ((derived (gethash glyph emoji--derived)) - (end-func - (lambda () - (let ((buf emoji--insert-buffer)) - (quit-window) - (if (buffer-live-p buf) - (switch-to-buffer buf) - (error "Buffer disappeared")))))) - (if (not derived) - ;; Glyph without derivations. - (progn - (emoji--add-recent glyph) - (funcall end-func) - (insert glyph)) - ;; Pop up a transient to choose between derivations. - (let ((emoji--done-derived (make-hash-table :test #'equal))) - (setf (gethash glyph emoji--done-derived) t) - (funcall - (emoji--define-transient (cons "Choose Emoji" (cons glyph derived)) - nil end-func))))))) + (let ((buf emoji--insert-buffer)) + (quit-window) + (if (buffer-live-p buf) + (switch-to-buffer buf) + (error "Buffer disappeared"))) + (let ((derived (gethash glyph emoji--derived))) + (if derived + (emoji--setup-prefix 'emoji-list-select "Choose Emoji" + (list glyph) + (cons glyph derived)) + (emoji--add-recent glyph) + (insert glyph))))) (defun emoji-list-help () "Display the name of the emoji at point." @@ -476,97 +520,51 @@ the name is not known." (setq parent elem)) (nconc elem (list glyph))))) -(defun emoji--define-transient (&optional alist inhibit-derived - end-function) - (unless alist - (setq alist (cons "Emoji" emoji--labels))) - (let* ((mname (pop alist)) - (name (intern (format "emoji--command-%s" mname))) - (emoji--done-derived (or emoji--done-derived - (make-hash-table :test #'equal))) - (has-subs (consp (cadr alist))) - (layout - (if has-subs - ;; Define sub-maps. - (cl-loop for entry in - (emoji--compute-prefix - (if (equal mname "Emoji") - (cons (list "Recent") alist) - alist)) - collect (list - (car entry) - (emoji--compute-name (cdr entry)) - (if (equal (cadr entry) "Recent") - (emoji--recent-transient end-function) - (emoji--define-transient - (cons (concat mname " > " (cadr entry)) - (cddr entry)))))) - ;; Insert an emoji. - (cl-loop for glyph in alist - for i in (append (number-sequence ?a ?z) - (number-sequence ?A ?Z) - (number-sequence ?0 ?9) - (number-sequence ?! ?/)) - collect (let ((this-glyph glyph)) - (list - (string i) - (emoji--fontify-glyph - glyph inhibit-derived) - (let ((derived - (and (not inhibit-derived) - (not (gethash glyph - emoji--done-derived)) - (gethash glyph emoji--derived)))) - (if derived - ;; We have a derived glyph, so add - ;; another level. - (progn - (setf (gethash glyph - emoji--done-derived) - t) - (emoji--define-transient - (cons (concat mname " " glyph) - (cons glyph derived)) - t end-function)) - ;; Insert the emoji. - (lambda () - (interactive nil not-a-mode) - ;; Allow switching to the correct - ;; buffer. - (when end-function - (funcall end-function)) - (emoji--add-recent this-glyph) - (insert this-glyph))))))))) - (args (apply #'vector mname - (emoji--columnize layout - (if has-subs 2 8))))) - ;; There's probably a better way to do this... - (setf (symbol-function name) - (lambda () - (interactive nil not-a-mode) - (transient-setup name))) - (pcase-let ((`(,class ,slots ,suffixes ,docstr ,_body) - (transient--expand-define-args (list args)))) - (put name 'interactive-only t) - (put name 'function-documentation docstr) - (put name 'transient--prefix - (apply (or class 'transient-prefix) :command name - (cons :variable-pitch (cons t slots)))) - (put name 'transient--layout - (transient-parse-suffixes name suffixes))) - name)) - -(defun emoji--recent-transient (end-function) - "Create a function to display a dynamically generated menu." - (lambda () - (interactive) - (funcall (emoji--define-transient - (cons "Recent" (multisession-value emoji--recent)) - t end-function)))) +(defun emoji--layout (command title spec done-derived) + (let ((has-subs (consp (cadr spec)))) + (emoji--columnize + (if has-subs + (cl-loop for (key desc . glyphs) in (emoji--compute-prefix spec) + collect + (list key + (emoji--compute-name (cons desc glyphs)) + command + :class 'emoji--narrow + :title (concat title " > " desc) + :done-derived (or (string-suffix-p "Recent" desc) + done-derived) + :children glyphs)) + (cl-loop for glyph in spec + for char in (emoji--char-sequence) + for key = (string char) + for derived = (and (not (or (eq done-derived t) + (member glyph done-derived))) + (gethash glyph emoji--derived)) + collect + (if derived + (list key + (emoji--fontify-glyph glyph done-derived) + command + :class 'emoji--narrow + :title (concat title " " glyph) + :done-derived (or (eq done-derived t) + (cons glyph done-derived)) + :children (cons glyph derived)) + (list key + (emoji--fontify-glyph glyph done-derived) + 'emoji-insert-glyph)))) + (if has-subs 2 8)))) + +(defun emoji--char-sequence () + (append (number-sequence ?a ?z) + (number-sequence ?A ?Z) + (number-sequence ?0 ?9) + (number-sequence ?! ?/))) (defun emoji--add-recent (glyph) "Add GLYPH to the set of recently used emojis." (let ((recent (multisession-value emoji--recent))) + (set-text-properties 0 (length glyph) nil glyph) (setq recent (delete glyph recent)) (push glyph recent) ;; Shorten the list. @@ -684,20 +682,6 @@ We prefer the earliest unique letter." (gethash name emoji--all-bases)))) (cons glyph (gethash glyph emoji--derived)))))) -(defun emoji--choose-emoji () - (pcase-let ((`(,glyph . ,derived) (emoji--read-emoji))) - (if (not derived) - ;; Simple glyph with no derivations. - (progn - (emoji--add-recent glyph) - (insert glyph)) - ;; Choose a derived version. - (let ((emoji--done-derived (make-hash-table :test #'equal))) - (setf (gethash glyph emoji--done-derived) t) - (funcall - (emoji--define-transient - (cons "Choose Emoji" (cons glyph derived)))))))) - (defvar-keymap emoji-zoom-map "+" #'emoji-zoom-increase "-" #'emoji-zoom-decrease diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index 979e685e32a..a27aaf9e522 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -1734,6 +1734,20 @@ included; callers should bind `case-fold-search' to t." :version "27.1" :group 'processes) +;; (describe-char-fold-equivalences ?:) +;; The last entry is taken from history. +(defcustom password-colon-equivalents + '(?\u003a ; ?\N{COLON} + ?\uff1a ; ?\N{FULLWIDTH COLON} + ?\ufe55 ; ?\N{SMALL COLON} + ?\ufe13 ; ?\N{PRESENTATION FORM FOR VERTICAL COLON} + ?\u17d6 ; ?\N{KHMER SIGN CAMNUC PII KUUH} + ) + "List of characters equivalent to trailing colon in \"password\" prompts." + :type '(repeat character) + :version "30.1" + :group 'processes) + ;; The old code-pages library is obsoleted by coding systems based on ;; the charsets defined in this file but might be required by user ;; code. diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el index 1540f806e3b..e69e7c19842 100644 --- a/lisp/international/textsec.el +++ b/lisp/international/textsec.el @@ -320,7 +320,8 @@ affected by bidi controls in STRING." ;; state at end of STRING which could then affect the following ;; text. (insert string "a1א:!") - (let ((pos (bidi-find-overridden-directionality 1 (point-max) nil))) + (let ((pos (bidi-find-overridden-directionality + (point-min) (point-max) nil))) (and (fixnump pos) (1- pos))))) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 3f9d4a7e818..ccf0f966574 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: processes, languages, extensions -;; Version: 1.0.16 +;; Version: 1.0.17 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -43,7 +43,6 @@ (eval-when-compile (require 'subr-x)) (require 'warnings) (require 'pcase) -(require 'ert) ; to escape a `condition-case-unless-debug' ;;; Public API @@ -154,6 +153,14 @@ immediately." "Stop waiting for responses from the current JSONRPC CONNECTION." (clrhash (jsonrpc--request-continuations connection))) +(defvar jsonrpc-inhibit-debug-on-error nil + "Inhibit `debug-on-error' when answering requests. +Some extensions, notably ert.el, set `debug-on-error' to non-nil, +which makes it hard to test the behaviour of catching the Elisp +error and replying to the endpoint with an JSONRPC-error. This +variable can be set around calls like `jsonrpc-request' to +circumvent that.") + (defun jsonrpc-connection-receive (connection message) "Process MESSAGE just received from CONNECTION. This function will destructure MESSAGE and call the appropriate @@ -166,7 +173,8 @@ dispatcher in CONNECTION." (cond (;; A remote request (and method id) - (let* ((debug-on-error (and debug-on-error (not (ert-running-test)))) + (let* ((debug-on-error (and debug-on-error + (not jsonrpc-inhibit-debug-on-error))) (reply (condition-case-unless-debug _ignore (condition-case oops diff --git a/lisp/kmacro.el b/lisp/kmacro.el index aec4b805474..64aa7a27bde 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -376,14 +376,22 @@ and `kmacro-counter-format'.") (defvar kmacro-view-last-item nil) (defvar kmacro-view-item-no 0) +(defun kmacro--to-vector (object) + "Normalize an old-style key sequence to the vector form." + (if (not (stringp object)) + object + (let ((vec (string-to-vector object))) + (unless (multibyte-string-p object) + (dotimes (i (length vec)) + (let ((k (aref vec i))) + (when (> k 127) + (setf (aref vec i) (+ k ?\M-\C-@ -128)))))) + vec))) -(autoload 'macro--string-to-vector "macros") (defun kmacro-ring-head () "Return pseudo head element in macro ring." (and last-kbd-macro - (kmacro (if (stringp last-kbd-macro) - (macro--string-to-vector last-kbd-macro) - last-kbd-macro) + (kmacro (kmacro--to-vector last-kbd-macro) kmacro-counter kmacro-counter-format-start))) @@ -843,10 +851,8 @@ KEYS should be a vector or a string that obeys `key-valid-p'." (setq format (nth 2 mac)) (setq counter (nth 1 mac)) (setq mac (nth 0 mac))) - (when (stringp mac) - ;; `kmacro' interprets a string according to `key-parse'. - (setq mac (macro--string-to-vector mac))) - (kmacro mac counter format))) + ;; `kmacro' interprets a string according to `key-parse'. + (kmacro (kmacro--to-vector mac) counter format))) (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." @@ -862,8 +868,6 @@ KEYS should be a vector or a string that obeys `key-valid-p'." (cl-defmethod cl-print-object ((object kmacro) stream) (princ "#f(kmacro " stream) - (require 'macros) - (declare-function macros--insert-vector-macro "macros" (definition)) (let ((vecdef (kmacro--keys object)) (counter (kmacro--counter object)) (format (kmacro--format object))) @@ -945,20 +949,15 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command (put symbol 'kmacro t)) -(cl-defstruct (kmacro-register - (:constructor nil) - (:constructor kmacro-make-register (macro))) - macro) +(cl-defmethod register-val-jump-to ((km kmacro) arg) + (funcall km arg)) ;FIXME: η-reduce? -(cl-defmethod register-val-jump-to ((data kmacro-register) _arg) - (kmacro-call-macro current-prefix-arg nil nil (kmacro-register-macro data))) +(cl-defmethod register-val-describe ((km kmacro) _verbose) + (princ (format "a keyboard macro:\n %s" + (key-description (kmacro--keys km))))) -(cl-defmethod register-val-describe ((data kmacro-register) _verbose) - (princ (format "a keyboard macro:\n %s" - (key-description (kmacro-register-macro data))))) - -(cl-defmethod register-val-insert ((data kmacro-register)) - (insert (format-kbd-macro (kmacro-register-macro data)))) +(cl-defmethod register-val-insert ((km kmacro)) + (insert (key-description (kmacro--keys km)))) (defun kmacro-to-register (r) "Store the last keyboard macro in register R. @@ -968,7 +967,7 @@ Interactively, reads the register using `register-read-with-preview'." (progn (or last-kbd-macro (error "No keyboard macro defined")) (list (register-read-with-preview "Save to register: ")))) - (set-register r (kmacro-make-register last-kbd-macro))) + (set-register r (kmacro-ring-head))) (defun kmacro-view-macro (&optional _arg) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 15308c298f8..acf8a1d2556 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -2021,7 +2021,7 @@ other modes. See `override-global-mode'. (fn &rest ARGS)" nil t) (autoload 'describe-personal-keybindings "bind-key" "\ Display all the personal keybindings defined by `bind-key'." t) -(register-definition-prefixes "bind-key" '("bind-key" "compare-keybindings" "get-binding-description" "override-global-m" "personal-keybindings")) +(register-definition-prefixes "bind-key" '("bind-key" "override-global-m" "personal-keybindings")) ;;; Generated autoloads from emacs-lisp/bindat.el @@ -2780,7 +2780,7 @@ it is disabled. ;;; Generated autoloads from emacs-lisp/byte-opt.el -(register-definition-prefixes "byte-opt" '("byte-" "disassemble-offset")) +(register-definition-prefixes "byte-opt" '("byte" "disassemble-offset")) ;;; Generated autoloads from emacs-lisp/bytecomp.el @@ -2965,10 +2965,6 @@ To use tree-sitter C/C++ modes by default, evaluate 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. - (fn)" t) (autoload 'c-or-c++-ts-mode "c-ts-mode" "\ Analyze buffer and enable either C or C++ mode. @@ -8295,6 +8291,7 @@ Valid keywords and arguments are: `nodigits' to suppress digits as prefix arguments. (fn BS &optional NAME M ARGS)") +(make-obsolete 'easy-mmode-define-keymap 'define-keymap "29.1") (autoload 'easy-mmode-defmap "easy-mmode" "\ Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is @@ -8305,6 +8302,7 @@ This macro is deprecated; use `defvar-keymap' instead. (fn M BS DOC &rest ARGS)" nil t) (function-put 'easy-mmode-defmap 'doc-string-elt 3) (function-put 'easy-mmode-defmap 'lisp-indent-function 1) +(make-obsolete 'easy-mmode-defmap 'defvar-keymap "29.1") (autoload 'easy-mmode-defsyntax "easy-mmode" "\ Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX). @@ -9232,6 +9230,7 @@ Turn on EDT Emulation." t) ;;; Generated autoloads from progmodes/eglot.el +(push (purecopy '(eglot 1 13)) package--builtin-versions) (autoload 'eglot "eglot" "\ Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE. @@ -9528,6 +9527,15 @@ optional prefix argument REINIT is non-nil. (register-definition-prefixes "elint" '("elint-")) +;;; Generated autoloads from progmodes/elixir-ts-mode.el + +(autoload 'elixir-ts-mode "elixir-ts-mode" "\ +Major mode for editing Elixir, powered by tree-sitter. + +(fn)" t) +(register-definition-prefixes "elixir-ts-mode" '("elixir-ts-")) + + ;;; Generated autoloads from emacs-lisp/elp.el (autoload 'elp-instrument-function "elp" "\ @@ -9594,6 +9602,16 @@ displayed." t) ;;; Generated autoloads from eshell/em-extpipe.el +(defgroup eshell-extpipe nil "\ +Native shell pipelines. + +This module lets you construct pipelines that use your operating +system's shell instead of Eshell's own pipelining support. This +is especially relevant when executing commands on a remote +machine using Eshell's Tramp integration: using the remote +shell's pipelining avoids copying the data which will flow +through the pipeline to local Emacs buffers and then right back +again." :tag "External pipelines" :group 'eshell-module) (register-definition-prefixes "em-extpipe" '("eshell-")) @@ -9604,12 +9622,12 @@ displayed." t) ;;; Generated autoloads from eshell/em-hist.el -(register-definition-prefixes "em-hist" '("eshell")) +(register-definition-prefixes "em-hist" '("em-hist-unload-function" "eshell")) ;;; Generated autoloads from eshell/em-ls.el -(register-definition-prefixes "em-ls" '("eshell")) +(register-definition-prefixes "em-ls" '("em-ls-unload-function" "eshell")) ;;; Generated autoloads from eshell/em-pred.el @@ -9634,7 +9652,7 @@ displayed." t) ;;; Generated autoloads from eshell/em-smart.el -(register-definition-prefixes "em-smart" '("eshell-")) +(register-definition-prefixes "em-smart" '("em-smart-unload-hook" "eshell-")) ;;; Generated autoloads from eshell/em-term.el @@ -9782,15 +9800,9 @@ Emerge two RCS revisions of a file, with another revision as ancestor. ;;; Generated autoloads from international/emoji.el -(autoload 'emoji-insert "emoji" "\ -Choose and insert an emoji glyph." t) -(autoload 'emoji-recent "emoji" "\ -Choose and insert one of the recently-used emoji glyphs." t) -(autoload 'emoji-search "emoji" "\ -Choose and insert an emoji glyph by typing its Unicode name. -This command prompts for an emoji name, with completion, and -inserts it. It recognizes the Unicode Standard names of emoji, -and also consults the `emoji-alternate-names' alist." t) + (autoload 'emoji-insert "emoji" nil t) + (autoload 'emoji-recent "emoji" nil t) + (autoload 'emoji-search "emoji" nil t) (autoload 'emoji-list "emoji" "\ List emojis and insert the one that's selected. Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture. @@ -9806,6 +9818,7 @@ If called from Lisp, return the name as a string; return nil if the name is not known. (fn GLYPH &optional INTERACTIVE)" t) + (autoload 'emoji-list-select "emoji" nil t) (autoload 'emoji--init "emoji" "\ @@ -9817,8 +9830,6 @@ FACTOR is the multiplication factor for the size. (fn &optional FACTOR)" t) (autoload 'emoji-zoom-decrease "emoji" "\ Decrease the size of the character under point." t) -(autoload 'emoji-zoom-reset "emoji" "\ -Reset the size of the character under point." t) (register-definition-prefixes "emoji" '("emoji-")) @@ -11364,8 +11375,10 @@ For more information, see Info node `(eww) Top'. (defalias 'browse-web 'eww) (autoload 'eww-open-file "eww" "\ Render FILE using EWW. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer. -(fn FILE)" t) +(fn FILE &optional NEW-BUFFER)" t) (autoload 'eww-search-words "eww" "\ Search the web for the text in the region. If region is active (and not whitespace), search the web for @@ -14451,6 +14464,8 @@ Add the window configuration CONF to `gnus-buffer-configuration'. (autoload 'go-ts-mode "go-ts-mode" "\ Major mode for editing Go, powered by tree-sitter. +\\{go-ts-mode-map} + (fn)" t) (autoload 'go-mod-ts-mode "go-ts-mode" "\ Major mode for editing go.mod files, powered by tree-sitter. @@ -15113,6 +15128,15 @@ Prefix arg sets default accept amount temporarily. (register-definition-prefixes "hashcash" '("hashcash-")) +;;; Generated autoloads from progmodes/heex-ts-mode.el + +(autoload 'heex-ts-mode "heex-ts-mode" "\ +Major mode for editing HEEx, powered by tree-sitter. + +(fn)" t) +(register-definition-prefixes "heex-ts-mode" '("heex-ts-")) + + ;;; Generated autoloads from help-at-pt.el (autoload 'help-at-pt-string "help-at-pt" "\ @@ -16283,6 +16307,15 @@ values. (register-definition-prefixes "semantic/html" '("semantic-")) +;;; Generated autoloads from textmodes/html-ts-mode.el + +(autoload 'html-ts-mode "html-ts-mode" "\ +Major mode for editing Html, powered by tree-sitter. + +(fn)" t) +(register-definition-prefixes "html-ts-mode" '("html-ts-mode-")) + + ;;; Generated autoloads from htmlfontify.el (push (purecopy '(htmlfontify 0 21)) package--builtin-versions) @@ -17238,8 +17271,8 @@ Put image IMAGE in front of POS in the current buffer. 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 defaults to \"x\" if it's nil or omitted. -The overlay created by this function has the `put-image' property set to t. +image. STRING is defaulted if you omit it. +The overlay created will have 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 @@ -17373,31 +17406,14 @@ 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. -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. - (fn &optional COLOR)" t) (autoload 'image-crop "image-crop" "\ Crop the image under point. -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. +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. -While moving/resizing the cropping area, the following key bindings -are available: +While cropping the image, the following key bindings are available: `q': Exit without changing anything. `RET': Crop/cut the image. @@ -17405,13 +17421,9 @@ are available: rectangle shape. `s': Same as `m', but make the rectangle into a square first. -After cropping the image, you can save it by `M-x image-save' or +After cropping an 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. - (fn &optional CUT)" t) (register-definition-prefixes "image-crop" '("image-c")) @@ -18766,7 +18778,7 @@ Major mode for editing JSON, powered by tree-sitter. ;;; Generated autoloads from jsonrpc.el -(push (purecopy '(jsonrpc 1 0 16)) package--builtin-versions) +(push (purecopy '(jsonrpc 1 0 17)) package--builtin-versions) (register-definition-prefixes "jsonrpc" '("jsonrpc-")) @@ -19478,7 +19490,7 @@ If called with an optional prefix argument ARG, prompts for month and year. This function is suitable for execution in an init file. (fn &optional ARG)" t) -(register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "eclipse-check" "lunar-")) +(register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-")) ;;; Generated autoloads from progmodes/m4-mode.el @@ -19571,7 +19583,7 @@ and then select the region of un-tablified names and use (fn TOP BOTTOM &optional MACRO)" t) (define-key ctl-x-map "q" 'kbd-macro-query) -(register-definition-prefixes "macros" '("macro")) +(register-definition-prefixes "macros" '("macros--insert-vector-macro")) ;;; Generated autoloads from mail/mail-extr.el @@ -22454,7 +22466,7 @@ Coloring: ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 6 3)) 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'. @@ -23541,6 +23553,11 @@ the `Version:' header.") (defcustom package-quickstart-file (locate-user-emacs-file "package-quickstart.el") "\ Location of the file used to speed up activation of packages at startup." :type 'file :group 'applications :initialize #'custom-initialize-delay :version "27.1") (custom-autoload 'package-quickstart-file "package" t) +(autoload 'package-report-bug "package" "\ +Prepare a message to send to the maintainers of a package. +DESC must be a `package-desc' object. + +(fn DESC)" '(package-menu-mode)) (register-definition-prefixes "package" '("bad-signature" "define-package" "describe-package-1" "package-")) @@ -26478,6 +26495,8 @@ usually more efficient than that of a simplified version: (cdr parens)))) (fn STRINGS &optional PAREN)") +(function-put 'regexp-opt 'pure 't) +(function-put 'regexp-opt 'side-effect-free 't) (autoload 'regexp-opt-depth "regexp-opt" "\ Return the depth of REGEXP. This means the number of non-shy regexp grouping constructs @@ -28354,29 +28373,17 @@ With ARG non-nil, silently save all file-visiting buffers, then kill. If emacsclient was started with a list of filenames to edit, then only these files will be asked to be saved. +When running Emacs as a daemon and with +`server-stop-automatically' (which see) set to `kill-terminal' or +`delete-frame', this function may call `save-buffers-kill-emacs' +if there are no other active clients. + (fn ARG)") (autoload 'server-stop-automatically "server" "\ -Automatically stop server as specified by ARG. - -If ARG is the symbol `empty', stop the server when it has no -remaining clients, no remaining unsaved file-visiting buffers, -and no running processes with a `query-on-exit' flag. - -If ARG is the symbol `delete-frame', ask the user when the last -frame is deleted whether each unsaved file-visiting buffer must -be saved and each running process with a `query-on-exit' flag -can be stopped, and if so, stop the server itself. - -If ARG is the symbol `kill-terminal', ask the user when the -terminal is killed with \\[save-buffers-kill-terminal] whether each unsaved file-visiting -buffer must be saved and each running process with a `query-on-exit' -flag can be stopped, and if so, stop the server itself. - -Any other value of ARG will cause this function to signal an error. +Automatically stop the Emacs server as specified by VALUE. +This sets the variable `server-stop-automatically' (which see). -This function is meant to be called from the user init file. - -(fn ARG)") +(fn VALUE)") (register-definition-prefixes "server" '("server-")) @@ -30301,7 +30308,7 @@ Studlify-case the current buffer." t) (defsubst string-join (strings &optional separator) "\ Join all STRINGS using SEPARATOR. Optional argument SEPARATOR must be a string, a vector, or a list of -characters; nil stands for the empty string." (mapconcat #'identity strings separator)) +characters; nil stands for the empty string." (declare (pure t) (side-effect-free t)) (mapconcat #'identity strings separator)) (autoload 'string-truncate-left "subr-x" "\ If STRING is longer than LENGTH, return a truncated version. When truncating, \"...\" is always prepended to the string, so @@ -30309,10 +30316,12 @@ the resulting string may be longer than the original if LENGTH is 3 or smaller. (fn STRING LENGTH)") +(function-put 'string-truncate-left 'pure 't) +(function-put 'string-truncate-left 'side-effect-free 't) (defsubst string-blank-p (string) "\ Check whether STRING is either empty or only whitespace. The following characters count as whitespace here: space, tab, newline and -carriage return." (string-match-p "\\`[ \11\n\15]*\\'" string)) +carriage return." (declare (pure t) (side-effect-free t)) (string-match-p "\\`[ \11\n\15]*\\'" string)) (autoload 'string-clean-whitespace "subr-x" "\ Clean up whitespace in STRING. All sequences of whitespaces in STRING are collapsed into a @@ -32713,7 +32722,7 @@ It must be supported by libarchive(3).") List of suffixes which indicate a compressed file. It must be supported by libarchive(3).") (defmacro tramp-archive-autoload-file-name-regexp nil "\ -Regular expression matching archive file names." (if (<= emacs-major-version 26) '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'") `(rx bos (group (+ nonl) "." (| ,@tramp-archive-suffixes) (32 "." (| ,@tramp-archive-compression-suffixes))) (group "/" (* nonl)) eos))) +Regular expression matching archive file names." `(rx bos (group (+ nonl) "." (| ,@tramp-archive-suffixes) (32 "." (| ,@tramp-archive-compression-suffixes))) (group "/" (* nonl)) eos)) (defun tramp-archive-autoload-file-name-handler (operation &rest args) "\ Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (let ((default-directory temporary-file-directory) (tramp-archive-autoload tramp-archive-enabled)) (apply #'tramp-autoload-file-name-handler operation args))) (defun tramp-register-archive-autoload-file-name-handler nil "\ @@ -32735,7 +32744,6 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from net/tramp-compat.el - (defalias 'tramp-compat-rx #'rx) (register-definition-prefixes "tramp-compat" '("tramp-")) @@ -32801,7 +32809,7 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 6 0 29 1)) package--builtin-versions) +(push (purecopy '(tramp 2 7 0 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) @@ -33149,15 +33157,7 @@ Major mode for editing TypeScript. (fn)" t) (autoload 'tsx-ts-mode "typescript-ts-mode" "\ -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). +Major mode for editing TypeScript. (fn)" t) (register-definition-prefixes "typescript-ts-mode" '("typescript-ts-mode-")) @@ -34577,7 +34577,7 @@ revision, with SUBJECT derived from each revision subject. When invoked with a numerical prefix argument, use the last N revisions. When invoked interactively in a Log View buffer with -marked revisions, use those these. +marked revisions, use those. (fn ADDRESSEE SUBJECT REVISIONS)" t) (register-definition-prefixes "vc" '("vc-" "with-vc-properties")) @@ -34846,7 +34846,7 @@ Key bindings: ;;; Generated autoloads from progmodes/verilog-mode.el -(push (purecopy '(verilog-mode 2021 10 14 127365406)) package--builtin-versions) +(push (purecopy '(verilog-mode 2022 12 18 181110314)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. \\<verilog-mode-map> @@ -34880,6 +34880,11 @@ Variables controlling indentation/edit style: function keyword. `verilog-indent-level-directive' (default 1) Indentation of \\=`ifdef/\\=`endif blocks. + `verilog-indent-ignore-multiline-defines' (default t) + Non-nil means ignore indentation on lines that are part of a multiline + define. + `verilog-indent-ignore-regexp' (default nil + Regexp that matches lines that should be ignored for indentation. `verilog-cexp-indent' (default 1) Indentation of Verilog statements broken across lines i.e.: if (a) @@ -34903,6 +34908,9 @@ Variables controlling indentation/edit style: otherwise you get: if (a) begin + `verilog-indent-class-inside-pkg' (default t) + Non-nil means indent classes inside packages. + Otherwise, classes have zero indentation. `verilog-auto-endcomments' (default t) Non-nil means a comment /* ... */ is set after the ends which ends cases, tasks, functions and modules. @@ -34912,6 +34920,17 @@ Variables controlling indentation/edit style: will be inserted. Setting this variable to zero results in every end acquiring a comment; the default avoids too many redundant comments in tight quarters. + `verilog-align-decl-expr-comments' (default t) + Non-nil means align declaration and expressions comments. + `verilog-align-comment-distance' (default 1) + Distance (in spaces) between longest declaration and comments. + Only works if `verilog-align-decl-expr-comments' is non-nil. + `verilog-align-assign-expr' (default nil) + Non-nil means align expressions of continuous assignments. + `verilog-align-typedef-regexp' (default nil) + Regexp that matches user typedefs for declaration alignment. + `verilog-align-typedef-words' (default nil) + List of words that match user typedefs for declaration alignment. `verilog-auto-lineup' (default `declarations') List of contexts where auto lineup of code should be done. @@ -34935,17 +34954,20 @@ Some other functions are: \\[verilog-mark-defun] Mark function. \\[verilog-beg-of-defun] Move to beginning of current function. \\[verilog-end-of-defun] Move to end of current function. - \\[verilog-label-be] Label matching begin ... end, fork ... join, etc statements. + \\[verilog-label-be] Label matching begin ... end, fork ... join, etc + statements. \\[verilog-comment-region] Put marked area in a comment. - \\[verilog-uncomment-region] Uncomment an area commented with \\[verilog-comment-region]. + \\[verilog-uncomment-region] Uncomment an area commented with + \\[verilog-comment-region]. \\[verilog-insert-block] Insert begin ... end. \\[verilog-star-comment] Insert /* ... */. \\[verilog-sk-always] Insert an always @(AS) begin .. end block. \\[verilog-sk-begin] Insert a begin .. end block. \\[verilog-sk-case] Insert a case block, prompting for details. - \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for details. + \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for + details. \\[verilog-sk-generate] Insert a generate .. endgenerate block. \\[verilog-sk-header] Insert a header block at the top of file. \\[verilog-sk-initial] Insert an initial begin .. end block. @@ -34968,14 +34990,17 @@ Some other functions are: \\[verilog-sk-else-if] Insert an else if (..) begin .. end block. \\[verilog-sk-comment] Insert a comment block. \\[verilog-sk-assign] Insert an assign .. = ..; statement. - \\[verilog-sk-function] Insert a function .. begin .. end endfunction block. + \\[verilog-sk-function] Insert a function .. begin .. end endfunction + block. \\[verilog-sk-input] Insert an input declaration, prompting for details. \\[verilog-sk-output] Insert an output declaration, prompting for details. - \\[verilog-sk-state-machine] Insert a state machine definition, prompting for details. + \\[verilog-sk-state-machine] Insert a state machine definition, prompting + for details. \\[verilog-sk-inout] Insert an inout declaration, prompting for details. \\[verilog-sk-wire] Insert a wire declaration, prompting for details. \\[verilog-sk-reg] Insert a register declaration, prompting for details. - \\[verilog-sk-define-signal] Define signal under point as a register at the top of the module. + \\[verilog-sk-define-signal] Define signal under point as a register at + the top of the module. All key bindings can be seen in a Verilog-buffer with \\[describe-bindings]. Key bindings specific to `verilog-mode-map' are: @@ -36094,6 +36119,7 @@ The mode's hook is called both when the mode is enabled and when it is disabled. (fn &optional ARG)" t) +(put 'global-whitespace-mode 'globalized-minor-mode t) (defvar global-whitespace-mode nil "\ Non-nil if Global Whitespace mode is enabled. See the `global-whitespace-mode' command @@ -36103,25 +36129,18 @@ either customize it (see the info node `Easy Customization') or call the function `global-whitespace-mode'.") (custom-autoload 'global-whitespace-mode "whitespace" nil) (autoload 'global-whitespace-mode "whitespace" "\ -Toggle whitespace visualization globally (Global Whitespace mode). - -See also `whitespace-style', `whitespace-newline' and -`whitespace-display-mappings'. - -This is a global minor mode. If called interactively, toggle the -`Global Whitespace mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable -the mode. +Toggle Whitespace mode in all buffers. +With prefix ARG, enable Global Whitespace mode if ARG is positive; +otherwise, disable it. -If called from Lisp, toggle the mode if ARG is `toggle'. Enable -the mode if ARG is nil, omitted, or is a positive number. +If called from Lisp, toggle the mode if ARG is `toggle'. +Enable the mode if ARG is nil, omitted, or is a positive number. Disable the mode if ARG is a negative number. -To check whether the minor mode is enabled in the current buffer, -evaluate `(default-value \\='global-whitespace-mode)'. +Whitespace mode is enabled in all buffers where +`whitespace-turn-on-if-enabled' would do it. -The mode's hook is called both when the mode is enabled and when -it is disabled. +See `whitespace-mode' for more information on Whitespace mode. (fn &optional ARG)" t) (defvar global-whitespace-newline-mode nil "\ diff --git a/lisp/macros.el b/lisp/macros.el index 59c7796551f..98ee3dc52f9 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -46,16 +46,6 @@ " ") ?\])) -(defun macro--string-to-vector (str) - "Convert an old-style string key sequence to the vector form." - (let ((vec (string-to-vector str))) - (unless (multibyte-string-p str) - (dotimes (i (length vec)) - (let ((k (aref vec i))) - (when (> k 127) - (setf (aref vec i) (+ k ?\M-\C-@ -128)))))) - vec)) - ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) "Insert in buffer the definition of kbd macro MACRONAME, as Lisp code. @@ -88,10 +78,8 @@ use this command, and then save the file." (insert "(defalias '")) (prin1 macroname (current-buffer)) (insert "\n ") - (when (stringp definition) - (setq definition (macro--string-to-vector definition))) - (if (vectorp definition) - (setq definition (kmacro definition))) + (when (or (stringp definition) (vectorp definition)) + (setq definition (kmacro (kmacro--to-vector definition)))) (if (kmacro-p definition) (let ((vecdef (kmacro--keys definition)) (counter (kmacro--counter definition)) 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/rmail.el b/lisp/mail/rmail.el index 659649b5d42..c56f4ce62dc 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -4580,6 +4580,9 @@ Argument MIME is non-nil if this is a mime message." (current-buffer)))) (error nil)) + ;; Decode any base64-encoded material in what we just decrypted. + (rmail-epa-decode armor-start after-end) + (list armor-start (- (point-max) after-end) mime armor-end-regexp (buffer-substring armor-start (- (point-max) after-end))))) @@ -4622,9 +4625,6 @@ Argument MIME is non-nil if this is a mime message." "> ") (push (rmail-epa-decrypt-1 mime) decrypts)))) - ;; Decode any base64-encoded mime sections. - (rmail-epa-decode) - (when (and decrypts (rmail-buffers-swapped-p)) (when (y-or-n-p "Replace the original message? ") (when (eq major-mode 'rmail-mode) @@ -4689,12 +4689,14 @@ Argument MIME is non-nil if this is a mime message." (unless decrypts (error "Nothing to decrypt"))))) -;; Decode all base64-encoded mime sections, so that this change -;; is made in the Rmail file, not just in the viewing buffer. -(defun rmail-epa-decode () +;; Decode all base64-encoded mime sections from BEG to (Z - BACK-FROM-END), +;; so that we save the decoding permanently in the Rmail buffer +;; if we permanently save the decryption. +(defun rmail-epa-decode (beg back-from-end) (save-excursion - (goto-char (point-min)) - (while (re-search-forward "--------------[0-9a-zA-Z]+\n" nil t) + (goto-char beg) + (while (re-search-forward "--------------[0-9a-zA-Z]+\n" + (- (point-max) back-from-end) t) ;; The ending delimiter is a start delimiter if another section follows. ;; Otherwise it is an end delimiter, with -- affixed. (let ((delim (concat (substring (match-string 0) 0 -1) "\\(\\|--\\)\n"))) diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index d0c0efec53b..6d61dcd8208 100644 --- a/lisp/mail/rmailout.el +++ b/lisp/mail/rmailout.el @@ -327,15 +327,14 @@ Replaces the From line with a \"Mail-from\" header. Adds \"Date\" and "Date: \\2, \\4 \\3 \\9 \\5 " ;; The timezone could be matched by group 7 or group 10. - ;; If neither of them matched, assume EST, since only - ;; Easterners would be so sloppy. + ;; If neither matched, use "-0000" for an unknown zone. ;; It's a shame the substitution can't use "\\10". (cond ((/= (match-beginning 7) (match-end 7)) "\\7") ((/= (match-beginning 10) (match-end 10)) (buffer-substring (match-beginning 10) (match-end 10))) - (t "EST")) + (t "-0000")) "\n")) ;; Keep and reformat the sender if we don't ;; have a From: field. 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/man.el b/lisp/man.el index 286edf9314e..479bf9f9a3c 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -97,6 +97,14 @@ :group 'external :group 'help) +(defcustom Man-prefer-synchronous-call nil + "Whether to call the Un*x \"man\" program synchronously. +When this is non-nil, call the \"man\" program synchronously +(rather than asynchronously, which is the default behavior)." + :type 'boolean + :group 'man + :version "30.1") + (defcustom Man-filter-list nil "Manpage cleaning filter command phrases. This variable contains a list of the following form: @@ -1118,7 +1126,8 @@ Return the buffer in which the manpage will appear." "[cleaning...]") 'face 'mode-line-emphasis))) (Man-start-calling - (if (fboundp 'make-process) + (if (and (fboundp 'make-process) + (not Man-prefer-synchronous-call)) (let ((proc (start-process manual-program buffer (if (memq system-type '(cygwin windows-nt)) @@ -1262,21 +1271,21 @@ Same for the ANSI bold and normal escape sequences." (progn (goto-char (point-min)) (while (and (search-forward "__\b\b" nil t) (not (eobp))) - (backward-delete-char 4) + (delete-char -4) (put-text-property (point) (1+ (point)) 'font-lock-face 'Man-underline)) (goto-char (point-min)) (while (search-forward "\b\b__" nil t) - (backward-delete-char 4) + (delete-char -4) (put-text-property (1- (point)) (point) 'font-lock-face 'Man-underline)))) (goto-char (point-min)) (while (and (search-forward "_\b" nil t) (not (eobp))) - (backward-delete-char 2) + (delete-char -2) (put-text-property (point) (1+ (point)) 'font-lock-face 'Man-underline)) (goto-char (point-min)) (while (search-forward "\b_" nil t) - (backward-delete-char 2) + (delete-char -2) (put-text-property (1- (point)) (point) 'font-lock-face 'Man-underline)) (goto-char (point-min)) (while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t) @@ -1294,7 +1303,7 @@ Same for the ANSI bold and normal escape sequences." ;; condense it to a shorter line interspersed with ^H. Remove ^H with ;; their preceding chars (but don't put Man-overstrike). (Bug#5566) (goto-char (point-min)) - (while (re-search-forward ".\b" nil t) (backward-delete-char 2)) + (while (re-search-forward ".\b" nil t) (delete-char -2)) (goto-char (point-min)) ;; Try to recognize common forms of cross references. (Man-highlight-references) @@ -1375,9 +1384,9 @@ script would have done them." (if (or interactive (not Man-sed-script)) (progn (goto-char (point-min)) - (while (search-forward "_\b" nil t) (backward-delete-char 2)) + (while (search-forward "_\b" nil t) (delete-char -2)) (goto-char (point-min)) - (while (search-forward "\b_" nil t) (backward-delete-char 2)) + (while (search-forward "\b_" nil t) (delete-char -2)) (goto-char (point-min)) (while (re-search-forward "\\(.\\)\\(\b\\1\\)+" nil t) (replace-match "\\1")) @@ -1392,7 +1401,7 @@ script would have done them." ;; condense it to a shorter line interspersed with ^H. Remove ^H with ;; their preceding chars (but don't put Man-overstrike). (Bug#5566) (goto-char (point-min)) - (while (re-search-forward ".\b" nil t) (backward-delete-char 2)) + (while (re-search-forward ".\b" nil t) (delete-char -2)) (Man-softhyphen-to-minus)) (defun Man-bgproc-filter (process string) diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index 502036f78b7..307c7fcf9c7 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -141,7 +141,7 @@ See `mh-identity-list'." (cons '("None") (mapcar #'list (mapcar #'car mh-identity-list))) nil t default nil default)) - (if (eq identity "None") + (if (equal identity "None") nil identity))) 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 be91987d635..a3dc1b0cfbf 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1107,11 +1107,7 @@ and DOC describes the way this style of completion works.") The available styles are listed in `completion-styles-alist'. Note that `completion-category-overrides' may override these -styles for specific categories, such as files, buffers, etc. - -Note that Tramp host name completion (e.g., \"/ssh:ho<TAB>\") -currently doesn't work if this list doesn't contain at least one -of `basic', `emacs22' or `emacs21'." +styles for specific categories, such as files, buffers, etc." :type completion--styles-type :version "23.1") diff --git a/lisp/mouse.el b/lisp/mouse.el index 60542e47448..3c30361ad7d 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -105,6 +105,15 @@ point at the click position." :type 'boolean :version "22.1") +(defcustom mouse-1-double-click-prefer-symbols nil + "If non-nil, double-clicking Mouse-1 attempts to select the symbol at click. + +If nil, the default, double-clicking Mouse-1 on a word-constituent +character will select only the word at click location, which could +select fewer characters than the symbol at click." + :type 'boolean + :version "30.1") + (defcustom mouse-drag-and-drop-region-scroll-margin nil "If non-nil, the scroll margin inside a window when dragging text. If the mouse moves this many lines close to the top or bottom of @@ -1801,10 +1810,17 @@ The region will be defined with mark and point." ;; Commands to handle xterm-style multiple clicks. (defun mouse-skip-word (dir) "Skip over word, over whitespace, or over identical punctuation. +If `mouse-1-double-click-prefer-symbols' is non-nil, skip over symbol. If DIR is positive skip forward; if negative, skip backward." (let* ((char (following-char)) - (syntax (char-to-string (char-syntax char)))) - (cond ((string= syntax "w") + (syntax (char-to-string (char-syntax char))) + sym) + (cond ((and mouse-1-double-click-prefer-symbols + (setq sym (bounds-of-thing-at-point 'symbol))) + (goto-char (if (< dir 0) + (car sym) + (cdr sym)))) + ((string= syntax "w") ;; Here, we can't use skip-syntax-forward/backward because ;; they don't pay attention to word-separating-categories, ;; and thus they will skip over a true word boundary. So, 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/ange-ftp.el b/lisp/net/ange-ftp.el index 4bf87c14f31..e21367135d3 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -3534,7 +3534,8 @@ system TYPE.") (setq file (expand-file-name file)) (let ((parsed (ange-ftp-ftp-name file))) (if parsed - (if (and delete-by-moving-to-trash trash) + (if (and delete-by-moving-to-trash trash + (not remote-file-name-inhibit-delete-by-moving-to-trash)) (move-file-to-trash file) (let* ((host (nth 0 parsed)) (user (nth 1 parsed)) @@ -4129,7 +4130,7 @@ directory, so that Emacs will know its current contents." (or (file-exists-p parent) (ange-ftp-make-directory parent parents)))) (if (file-exists-p dir) - (unless parents + (if parents t (signal 'file-already-exists (list "Cannot make directory: file already exists" dir))) @@ -4158,7 +4159,8 @@ directory, so that Emacs will know its current contents." (format "Could not make directory %s: %s" dir (cdr result)))) - (ange-ftp-add-file-entry dir t)) + (ange-ftp-add-file-entry dir t) + nil) (ange-ftp-real-make-directory dir))))) (defun ange-ftp-delete-directory (dir &optional recursive trash) @@ -4377,6 +4379,10 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; or return nil meaning don't make a backup. (if ange-ftp-make-backup-files (ange-ftp-real-find-backup-file-name fn))) + +(defun ange-ftp-file-user-uid () + ;; Return "don't know" value. + -1) ;;; Define the handler for special file names ;;; that causes ange-ftp to be invoked. @@ -4498,6 +4504,28 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'process-file 'ange-ftp 'ange-ftp-process-file) (put 'start-file-process 'ange-ftp 'ignore) (put 'shell-command 'ange-ftp 'ange-ftp-shell-command) + +;; Do not execute system information functions. +(put 'file-system-info 'ange-ftp 'ignore) +(put 'list-system-processes 'ange-ftp 'ignore) +(put 'memory-info 'ange-ftp 'ignore) +(put 'process-attributes 'ange-ftp 'ignore) + +;; There aren't ACLs. `file-selinux-context' shall return '(nil nil +;; nil nil) if the file is nonexistent, so we let the default file +;; name handler do the job. +(put 'file-acl 'ange-ftp 'ignore) +;; (put 'file-selinux-context 'ange-ftp 'ignore) +(put 'set-file-acl 'ange-ftp 'ignore) +(put 'set-file-selinux-context 'ange-ftp 'ignore) + +;; There aren't file notifications. +(put 'file-notify-add-watch 'ange-ftp 'ignore) +(put 'file-notify-rm-watch 'ange-ftp 'ignore) +(put 'file-notify-valid-p 'ange-ftp 'ignore) + +;; Return the "don't know' value for remote user uid. +(put 'file-user-uid 'ange-ftp 'ange-ftp-file-user-uid) ;;; Define ways of getting at unmodified Emacs primitives, ;;; turning off our handler. 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 eac47e592b2..11be20b68db 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -495,14 +495,17 @@ For more information, see Info node `(eww) Top'." ;;;###autoload (defalias 'browse-web 'eww) ;;;###autoload -(defun eww-open-file (file) - "Render FILE using EWW." - (interactive "fFile: ") +(defun eww-open-file (file &optional new-buffer) + "Render FILE using EWW. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing the default EWW buffer." + (interactive "fFile: \nP") (let ((url-allow-non-local-files t)) (eww (concat "file://" (and (memq system-type '(windows-nt ms-dos)) "/") - (expand-file-name file))))) + (expand-file-name file)) + new-buffer))) (defun eww--file-buffer (file) (with-current-buffer (generate-new-buffer " *eww file*") @@ -2505,10 +2508,10 @@ Otherwise, the restored buffer will contain a prompt to do so by using (when (plist-get eww-data :url) (cl-case eww-restore-desktop ((t auto) (eww (plist-get eww-data :url))) - ((zerop (buffer-size)) - (let ((inhibit-read-only t)) - (insert (substitute-command-keys - eww-restore-reload-prompt))))))) + ((nil) (when (zerop (buffer-size)) + (let ((inhibit-read-only t)) + (insert (substitute-command-keys + eww-restore-reload-prompt)))))))) ;; . (current-buffer))) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index f7361f38130..36b1654222a 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -262,6 +262,7 @@ For the meaning of the rest of the parameters, see `gnutls-boot-parameters'." &key type hostname priority-string trustfiles crlfiles keylist min-prime-bits verify-flags verify-error verify-hostname-error + pass flags &allow-other-keys) "Return a keyword list of parameters suitable for passing to `gnutls-boot'. @@ -278,6 +279,13 @@ default. VERIFY-HOSTNAME-ERROR is a backwards compatibility option for putting `:hostname' in VERIFY-ERROR. +PASS is a string, the password of the key. It may also be nil, +for a NULL password. + +FLAGS is a list of symbols corresponding to the equivalent ORed +bitflag of the gnutls_pkcs_encrypt_flags_t enum of GnuTLS. The +empty list corresponds to the bitflag with value 0. + When VERIFY-ERROR is t or a list containing `:trustfiles', an error will be raised when the peer certificate verification fails as per GnuTLS' gnutls_certificate_verify_peers2. Otherwise, only @@ -355,6 +363,8 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." :keylist ,keylist :verify-flags ,verify-flags :verify-error ,verify-error + :pass ,pass + :flags ,flags :callbacks nil))) (defun gnutls--get-files (files) diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 722e98be2fc..10c5a7744c1 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -510,7 +510,7 @@ If SOURCE, mark the entry with this as the source." (skip-chars-forward "^;\n") ;; skip \; (while (eq (char-before) ?\\) - (backward-delete-char 1) + (delete-char -1) (forward-char) (skip-chars-forward "^;\n")) (if (eq (or (char-after save-pos) 0) ?') diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 1afcd1db3c4..a68a6bf1a24 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1623,7 +1623,7 @@ Sat, 07 Sep 2002 00:00:01 GMT ":\\([0-9]\\{2\\}\\)" ;; second "\\(:\\([0-9]\\{2\\}\\)\\)?" - ;; zone -- fixme + ;; zone "\\(\\s-+\\(" "UT\\|GMT\\|EST\\|EDT\\|CST\\|CDT\\|MST\\|MDT\\|PST\\|PDT" "\\|\\([-+]\\)\\([0-9]\\{2\\}\\)\\([0-9]\\{2\\}\\)" @@ -1642,16 +1642,26 @@ Sat, 07 Sep 2002 00:00:01 GMT (offset-hour (read (or (match-string 14 rfc822-string) "0"))) (offset-minute (read (or (match-string 15 rfc822-string) - "0"))) - ;;FIXME - ) + "0")))) (when zone (cond ((string= sign "+") (setq hour (- hour offset-hour)) (setq minute (- minute offset-minute))) ((string= sign "-") (setq hour (+ hour offset-hour)) - (setq minute (+ minute offset-minute))))) + (setq minute (+ minute offset-minute))) + ((or (string= zone "UT") (string= zone "GMT")) + nil) + ((string= zone "EDT") + (setq hour (+ hour 4))) + ((or (string= zone "EST") (string= zone "CDT")) + (setq hour (+ hour 5))) + ((or (string= zone "CST") (string= zone "MDT")) + (setq hour (+ hour 6))) + ((or (string= zone "MST") (string= zone "PDT")) + (setq hour (+ hour 7))) + ((string= zone "PST") + (setq hour (+ hour 8))))) (condition-case error-data (let ((i 1)) (dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el index 5477ad946ba..064b72f02c2 100644 --- a/lisp/net/newst-ticker.el +++ b/lisp/net/newst-ticker.el @@ -44,8 +44,10 @@ "Last message that the newsticker displayed.") (defvar newsticker--scrollable-text "" "The text which is scrolled smoothly in the echo area.") +(defvar newsticker--ticker-period-timer nil + "Timer for newsticker ticker display.") (defvar newsticker--ticker-timer nil - "Timer for newsticker ticker.") + "Timer for newsticker ticker scrolling.") ;;;###autoload (defun newsticker-ticker-running-p () @@ -77,7 +79,7 @@ value effective." (defcustom newsticker-ticker-interval 0.3 - "Time interval for displaying news items in the echo area (seconds). + "Time interval for scrolling news items in the echo area (seconds). If equal or less than 0 no messages are shown in the echo area. For smooth display (see `newsticker-scroll-smoothly') a value of 0.3 seems reasonable. For non-smooth display a value of 10 is a good starting @@ -86,6 +88,17 @@ point." :set #'newsticker--set-customvar-ticker :group 'newsticker-ticker) +(defcustom newsticker-ticker-period + 0 + "Time interval for displaying news items in the echo area (seconds). +If equal or less than 0 messages are shown continuously. In order not +to miss new items, a value of equal or less than the shortest feed +retrieval interval (or the global `newsticker-retrieval-interval`) is +recommended." + :type 'number + :set #'newsticker--set-customvar-ticker + :group 'newsticker-ticker) + (defcustom newsticker-scroll-smoothly t "Decides whether to flash or scroll news items. @@ -129,9 +142,16 @@ If t the echo area will not show obsolete items. See also "Called from the display timer. This function calls a display function, according to the variable `newsticker-scroll-smoothly'." - (if newsticker-scroll-smoothly - (newsticker--display-scroll) - (newsticker--display-jump))) + (when (not newsticker--ticker-timer) + (if newsticker-scroll-smoothly + (setq newsticker--ticker-timer + (run-at-time 1 + newsticker-ticker-interval + #'newsticker--display-scroll)) + (setq newsticker--ticker-timer + (run-at-time nil + newsticker-ticker-interval + #'newsticker--display-jump))))) (defsubst newsticker--echo-area-clean-p () "Check whether somebody is using the echo area / minibuffer. @@ -149,7 +169,12 @@ there is another message displayed or the minibuffer is active." (when (newsticker--echo-area-clean-p) (setq newsticker--item-position (1+ newsticker--item-position)) (when (>= newsticker--item-position (length newsticker--item-list)) - (setq newsticker--item-position 0)) + (setq newsticker--item-position 0) + (when (> newsticker-ticker-period 0) + (cancel-timer newsticker--ticker-timer) + (setq newsticker--ticker-timer nil) + (run-at-time newsticker-ticker-interval nil + (lambda () (message ""))))) (setq newsticker--prev-message (nth newsticker--item-position newsticker--item-list)) (message "%s" newsticker--prev-message)))) @@ -192,7 +217,12 @@ there is another message displayed or the minibuffer is active." (setq newsticker--prev-message subtext) (setq newsticker--item-position (1+ i)) (when (>= newsticker--item-position l) - (setq newsticker--item-position 0)))))) + (setq newsticker--item-position 0) + (when (> newsticker-ticker-period 0) + (cancel-timer newsticker--ticker-timer) + (setq newsticker--ticker-timer nil) + (run-at-time newsticker-ticker-interval nil + (lambda () (message ""))))))))) ;;;###autoload (defun newsticker-start-ticker () @@ -200,19 +230,26 @@ there is another message displayed or the minibuffer is active." Start display timer for the actual ticker if wanted and not running already." (interactive) - (if (and (> newsticker-ticker-interval 0) - (not newsticker--ticker-timer)) - (setq newsticker--ticker-timer - (run-at-time newsticker-ticker-interval - newsticker-ticker-interval - #'newsticker--display-tick)))) + (when (and (> newsticker-ticker-interval 0) + (not newsticker--ticker-period-timer) + (not newsticker--ticker-timer)) + (if (> newsticker-ticker-period 0) + (setq newsticker--ticker-period-timer + (run-at-time nil + newsticker-ticker-period + #'newsticker--display-tick)) + (newsticker--display-tick)))) (defun newsticker-stop-ticker () "Stop newsticker's ticker (but not the news retrieval)." (interactive) - (when newsticker--ticker-timer - (cancel-timer newsticker--ticker-timer) - (setq newsticker--ticker-timer nil))) + (progn + (when newsticker--ticker-timer + (cancel-timer newsticker--ticker-timer) + (setq newsticker--ticker-timer nil)) + (when newsticker--ticker-period-timer + (cancel-timer newsticker--ticker-period-timer) + (setq newsticker--ticker-period-timer nil)))) ;; ====================================================================== ;;; Manipulation of ticker text diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 97a314eb8ab..5e4aa5e1198 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -1396,10 +1396,10 @@ inserted." (interactive "P") (rcirc-format "\^_" replace)) -(defun rcirc-format-strike-trough (replace) - "Insert strike-trough formatting. +(defun rcirc-format-strike-through (replace) + "Insert strike-through formatting. If REPLACE is non-nil or a prefix argument is given, any prior -formatting will be replaced before the strike-trough formatting +formatting will be replaced before the strike-through formatting is inserted." (interactive "P") (rcirc-format "\^^" replace)) @@ -1421,7 +1421,7 @@ inserted." "C-c C-f C-b" #'rcirc-format-bold "C-c C-f C-i" #'rcirc-format-italic "C-c C-f C-u" #'rcirc-format-underline - "C-c C-f C-s" #'rcirc-format-strike-trough + "C-c C-f C-s" #'rcirc-format-strike-through "C-c C-f C-f" #'rcirc-format-fixed-width "C-c C-f C-t" #'rcirc-format-fixed-width ;as in AucTeX "C-c C-f C-d" #'rcirc-unformat @@ -1807,7 +1807,7 @@ extracted." "C-c C-f C-b" #'rcirc-format-bold "C-c C-f C-i" #'rcirc-format-italic "C-c C-f C-u" #'rcirc-format-underline - "C-c C-f C-s" #'rcirc-format-strike-trough + "C-c C-f C-s" #'rcirc-format-strike-through "C-c C-f C-f" #'rcirc-format-fixed-width "C-c C-f C-t" #'rcirc-format-fixed-width ;as in AucTeX "C-c C-f C-d" #'rcirc-unformat @@ -2370,9 +2370,11 @@ This function does not alter the INPUT string." "C-c C-@" #'rcirc-next-active-buffer "C-c C-SPC" #'rcirc-next-active-buffer) -(defcustom rcirc-track-abbrevate-flag t +(define-obsolete-variable-alias 'rcirc-track-abbrevate-flag + 'rcirc-track-abbreviate-flag "30.1") +(defcustom rcirc-track-abbreviate-flag t "Non-nil means `rcirc-track-minor-mode' should abbreviate names." - :version "28.1" + :version "30.1" :type 'boolean) ;;;###autoload @@ -2558,7 +2560,7 @@ activity. Only run if the buffer is not visible and (funcall rcirc-channel-filter (replace-regexp-in-string "@.*?\\'" "" - (or (and rcirc-track-abbrevate-flag + (or (and rcirc-track-abbreviate-flag rcirc-short-buffer-name) (buffer-name)))))) @@ -4001,6 +4003,9 @@ PROCESS is the process object for the current connection." (string-equal (downcase (car setting)) parameter)) return (cadr setting))) +(define-obsolete-function-alias 'rcirc-format-strike-trough + 'rcirc-format-strike-through "30.1") + (provide 'rcirc) ;;; rcirc.el ends here diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 4866f788bff..5bee4f4c4ad 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -168,25 +168,19 @@ Valid states are `closed', `initial', `nonauth', and `auth'.") ;; Internal utility functions (defun sieve-manage--append-to-log (&rest args) - "Append ARGS to `sieve-manage-log' buffer. + "Append ARGS to sieve-manage log buffer. ARGS can be a string or a list of strings. -The buffer to use for logging is specifified via `sieve-manage-log'. -If it is nil, logging is disabled. - -When the `sieve-manage-log' buffer doesn't exist, it gets created (and -configured with some initial settings)." +The buffer to use for logging is specifified via +`sieve-manage-log'. If it is nil, logging is disabled." (when sieve-manage-log - (let* ((existing-log-buffer (get-buffer sieve-manage-log)) - (log-buffer (or existing-log-buffer - (get-buffer-create sieve-manage-log)))) - (with-current-buffer log-buffer - (unless existing-log-buffer - ;; Do this only once, when creating the log buffer. - (set-buffer-multibyte nil) - (buffer-disable-undo)) - (goto-char (point-max)) - (apply #'insert args))))) + (with-current-buffer (or (get-buffer sieve-manage-log) + (with-current-buffer + (get-buffer-create sieve-manage-log) + (set-buffer-multibyte nil) + (buffer-disable-undo))) + (goto-char (point-max)) + (apply #'insert args)))) (defun sieve-manage--message (format-string &rest args) "Wrapper around `message' which also logs to sieve manage log. diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 73974f864b3..e4b8bbd9cb5 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -1317,7 +1317,7 @@ See also `soap-wsdl-resolve-references'." "Validate VALUE against the basic type TYPE." (let* ((kind (soap-xs-basic-type-kind type))) (cl-case kind - ((anyType Array byte[]) + ((anyType Array byte\[\]) value) (t (let ((convert (get kind 'rng-xsd-convert))) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 4578f1fe073..14c63ba5834 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -55,7 +55,7 @@ It is used for TCP/IP devices." (defconst tramp-adb-method "adb" "When this method name is used, forward all calls to Android Debug Bridge.") -(defcustom tramp-adb-prompt (rx bol (* (not (any "#$\n\r"))) (any "#$") blank) +(defcustom tramp-adb-prompt (rx bol (* (not (any "#$\r\n"))) (any "#$") blank) "Regexp used as prompt in almquist shell." :type 'regexp :version "28.1" @@ -71,14 +71,14 @@ It is used for TCP/IP devices." "Regexp for date time format in ls output.")) (defconst tramp-adb-ls-date-regexp - (tramp-compat-rx + (rx blank (regexp tramp-adb-ls-date-year-regexp) blank (regexp tramp-adb-ls-date-time-regexp) blank) "Regexp for date format in ls output.") (defconst tramp-adb-ls-toolbox-regexp - (tramp-compat-rx + (rx bol (* blank) (group (+ (any ".-" alpha))) ; \1 permissions (? (+ blank) (+ digit)) ; links (Android 7/toybox) (* blank) (group (+ (not blank))) ; \2 username @@ -153,6 +153,7 @@ It is used for TCP/IP devices." (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-adb-handle-file-system-info) (file-truename . tramp-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -327,8 +328,7 @@ arguments to pass to the OPERATION." (tramp-shell-quote-argument (tramp-compat-file-name-concat localname "..")))) (tramp-compat-replace-regexp-in-region - (tramp-compat-rx (literal (tramp-compat-file-name-unquote - (file-name-as-directory localname)))) + (rx (literal (file-name-unquote (file-name-as-directory localname)))) "" (point-min)) (widen))) (tramp-adb-sh-fix-ls-output) @@ -366,14 +366,12 @@ Emacs dired can't find files." (goto-char (point-min)) (while (search-forward-regexp - (tramp-compat-rx - blank (group blank (regexp tramp-adb-ls-date-year-regexp) blank)) + (rx blank (group blank (regexp tramp-adb-ls-date-year-regexp) blank)) nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". (when (looking-at-p - (tramp-compat-rx - (regexp tramp-adb-ls-date-time-regexp) (+ blank) eol)) + (rx (regexp tramp-adb-ls-date-time-regexp) (+ blank) eol)) (end-of-line) (insert "/"))) ;; Sort entries. @@ -393,12 +391,10 @@ Emacs dired can't find files." (defun tramp-adb-ls-output-time-less-p (a b) "Sort \"ls\" output by time, descending." (let (time-a time-b) - ;; Once we can assume Emacs 27 or later, the two calls - ;; (apply #'encode-time X) can be replaced by (encode-time X). (string-match tramp-adb-ls-date-regexp a) - (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) + (setq time-a (encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) - (setq time-b (apply #'encode-time (parse-time-string (match-string 0 b)))) + (setq time-b (encode-time (parse-time-string (match-string 0 b)))) (time-less-p time-b time-a))) (defun tramp-adb-ls-output-name-less-p (a b) @@ -411,20 +407,11 @@ Emacs dired can't find files." (defun tramp-adb-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - (when parents - (let ((par (expand-file-name ".." dir))) - (unless (file-directory-p par) - (make-directory par parents)))) - (tramp-flush-directory-properties v localname) - (unless (or (tramp-adb-send-command-and-check - v (format "mkdir -m %#o %s" - (default-file-modes) - (tramp-shell-quote-argument localname))) - (and parents (file-directory-p dir))) + (tramp-skeleton-make-directory dir parents + (unless (tramp-adb-send-command-and-check + v (format "mkdir -m %#o %s" + (default-file-modes) + (tramp-shell-quote-argument localname))) (tramp-error v 'file-error "Couldn't make directory %s" dir)))) (defun tramp-adb-handle-delete-directory (directory &optional recursive trash) @@ -438,42 +425,39 @@ Emacs dired can't find files." (defun tramp-adb-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (if (and delete-by-moving-to-trash trash) - (move-file-to-trash filename) - (tramp-adb-barf-unless-okay - v (format "rm %s" (tramp-shell-quote-argument localname)) - "Couldn't delete %s" filename)))) + (tramp-skeleton-delete-file filename trash + (tramp-adb-barf-unless-okay + v (format "rm %s" (tramp-shell-quote-argument localname)) + "Couldn't delete %s" filename))) (defun tramp-adb-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (tramp-adb-send-command - v (format "%s -a %s | cat" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname))) - (mapcar - (lambda (f) - (if (file-directory-p (expand-file-name f directory)) - (file-name-as-directory f) - f)) - (with-current-buffer (tramp-get-buffer v) - (delete-dups - (append - ;; On some file systems like "sdcard", "." and ".." are - ;; not included. We fix this by `delete-dups'. - '("." "..") - (delq - nil - (mapcar - (lambda (l) - (and (not (string-match-p (rx bol (* blank) eol) l)) l)) - (split-string (buffer-string) "\n"))))))))))) + (ignore-error file-missing + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (tramp-adb-send-command + v (format "%s -a %s | cat" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (mapcar + (lambda (f) + (if (file-directory-p (expand-file-name f directory)) + (file-name-as-directory f) + f)) + (with-current-buffer (tramp-get-buffer v) + (delete-dups + (append + ;; On some file systems like "sdcard", "." and ".." are + ;; not included. We fix this by `delete-dups'. + '("." "..") + (delq + nil + (mapcar + (lambda (l) + (and (not (string-match-p (rx bol (* blank) eol) l)) l)) + (split-string (buffer-string) "\n")))))))))))) (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -483,7 +467,7 @@ Emacs dired can't find files." ;; "adb pull ..." does not always return an error code. (unless (and (tramp-adb-execute-adb-command - v "pull" (tramp-compat-file-name-unquote localname) tmpfile) + v "pull" (file-name-unquote localname) tmpfile) (file-exists-p tmpfile)) (ignore-errors (delete-file tmpfile)) (tramp-error @@ -504,16 +488,9 @@ Emacs dired can't find files." (defun tramp-adb-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." - ;; `file-exists-p' is used as predicate in file name completion. - ;; We don't want to run it when `non-essential' is t, or there is - ;; no connection process yet. - (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-exists-p" - (if (tramp-file-property-p v localname "file-attributes") - (not (null (tramp-get-file-property v localname "file-attributes"))) - (tramp-adb-send-command-and-check - v (format "test -e %s" (tramp-shell-quote-argument localname)))))))) + (tramp-skeleton-file-exists-p filename + (tramp-adb-send-command-and-check + v (format "test -e %s" (tramp-shell-quote-argument localname))))) (defun tramp-adb-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -563,8 +540,7 @@ Emacs dired can't find files." "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect (unless (tramp-adb-execute-adb-command - v "push" tmpfile - (tramp-compat-file-name-unquote localname)) + v "push" tmpfile (file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))))))) @@ -579,11 +555,7 @@ Emacs dired can't find files." (defun tramp-adb-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (tramp-skeleton-set-file-modes-times-uid-gid filename - (let ((time (if (or (null time) - (tramp-compat-time-equal-p time tramp-time-doesnt-exist) - (tramp-compat-time-equal-p time tramp-time-dont-know)) - (current-time) - time)) + (let ((time (tramp-defined-time time)) (nofollow (if (eq flag 'nofollow) "-h" "")) (quoted-name (tramp-shell-quote-argument localname))) ;; Older versions of toybox 'touch' mishandle nanoseconds and/or @@ -669,8 +641,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-flush-file-properties v localname) (unless (tramp-adb-execute-adb-command v "push" - (tramp-compat-file-name-unquote filename) - (tramp-compat-file-name-unquote localname)) + (file-name-unquote filename) + (file-name-unquote localname)) (tramp-error v 'file-error "Cannot copy `%s' `%s'" filename newname))))))))) @@ -736,11 +708,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Strings to return by `process-file' in case of signals." (with-tramp-connection-property vec "signal-strings" (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) - ;; `shell-file-name' and `shell-command-switch' are needed - ;; for Emacs < 27.1, which doesn't support connection-local - ;; variables in `shell-command'. - (shell-file-name "/system/bin/sh") - (shell-command-switch "-c") process-file-return-signal-string signals result) (dotimes (i 128) (push (format "Signal %d" i) result)) (setq result (reverse result) @@ -773,7 +740,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) + (setq infile (file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-unquote-file-local-name infile)) @@ -949,7 +916,7 @@ implementation will be used." (i 0) p) - (when (string-match-p (tramp-compat-rx multibyte) command) + (when (string-match-p (rx multibyte) command) (tramp-error v 'file-error "Cannot apply multi-byte command `%s'" command)) @@ -1023,7 +990,7 @@ implementation will be used." (progn (goto-char (point-min)) (not (search-forward "\n" nil t))) - (tramp-accept-process-output p 0)) + (tramp-accept-process-output p)) (delete-region (point-min) (point))) ;; Provide error buffer. This shows only ;; initial error messages; messages @@ -1032,17 +999,19 @@ implementation will be used." ;; file will exist until the process is ;; deleted. (when (bufferp stderr) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit)) + (ignore-errors + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit))) ;; Delete tmpstderr file. (add-function :after (process-sentinel p) (lambda (_proc _msg) - (with-current-buffer stderr - (insert-file-contents-literally - remote-tmpstderr 'visit nil nil 'replace)) - (delete-file remote-tmpstderr)))) + (ignore-errors + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr))))) ;; Return process. p)))) @@ -1106,11 +1075,12 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (format "%s:%s" host port)) ;; An empty host name shall be mapped as well, when there ;; is exactly one entry in `devices'. - ((and (zerop (length host)) (= (length devices) 1)) + ((and (tramp-string-empty-or-nil-p host) + (tramp-compat-length= devices 1)) (car devices)) ;; Try to connect device. ((and tramp-adb-connect-if-not-connected - (not (zerop (length host))) + (tramp-compat-length> host 0) (tramp-adb-execute-adb-command vec "connect" (tramp-compat-string-replace @@ -1127,7 +1097,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" "Execute an adb command. Insert the result into the connection buffer. Return nil on error and non-nil on success." - (when (and (> (length (tramp-file-name-host vec)) 0) + (when (and (tramp-compat-length> (tramp-file-name-host vec) 0) ;; The -s switch is only available for ADB device commands. (not (member (car args) '("connect" "disconnect")))) (setq args (append (list "-s" (tramp-adb-get-device vec)) args))) @@ -1141,7 +1111,7 @@ error and non-nil on success." (defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (if (string-match-p (tramp-compat-rx multibyte) command) + (if (string-match-p (rx multibyte) command) ;; Multibyte codepoints with four bytes are not supported at ;; least by toybox. @@ -1165,7 +1135,7 @@ error and non-nil on success." ;; We can't use stty to disable echo of command. stty is said ;; to be added to toybox 0.7.6. busybox shall have it, but this ;; isn't used any longer for Android. - (delete-matching-lines (tramp-compat-rx bol (literal command) eol)) + (delete-matching-lines (rx bol (literal command) eol)) ;; When the local machine is W32, there are still trailing ^M. ;; There must be a better solution by setting the correct coding ;; system, but this requires changes in core Tramp. @@ -1254,7 +1224,7 @@ connection if a previous connection has died for some reason." (unless (process-live-p p) (save-match-data (when (and p (processp p)) (delete-process p)) - (if (zerop (length device)) + (if (tramp-string-empty-or-nil-p device) (tramp-error vec 'file-error "Device %s not connected" host)) (with-tramp-progress-reporter vec 3 "Opening adb shell connection" (let* ((coding-system-for-read 'utf-8-dos) ; Is this correct? @@ -1279,7 +1249,7 @@ connection if a previous connection has died for some reason." ;; Set sentinel and query flag. Initialize variables. (set-process-sentinel p #'tramp-process-sentinel) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) @@ -1288,7 +1258,7 @@ connection if a previous connection has died for some reason." ;; Change prompt. (tramp-set-connection-property - p "prompt" (tramp-compat-rx "///" (literal prompt) "#$")) + p "prompt" (rx "///" (literal prompt) "#$")) (tramp-adb-send-command vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 36992014e13..c2175612fa8 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -110,12 +110,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -;; Sometimes, compilation fails with "Variable binding depth exceeds -;; max-specpdl-size". Shall be fixed in Emacs 27. -(with-no-warnings ;; max-specpdl-size - (eval-and-compile - (let ((max-specpdl-size (* 2 max-specpdl-size))) - (require 'tramp-gvfs)))) +(require 'tramp-gvfs) (autoload 'dired-uncache "dired") (autoload 'url-tramp-convert-url-to-tramp "url-tramp") @@ -183,20 +178,9 @@ It must be supported by libarchive(3).") ;; The definition of `tramp-archive-file-name-regexp' contains calls ;; to `regexp-opt', which cannot be autoloaded while loading ;; loaddefs.el. So we use a macro, which is evaluated only when needed. -;; Emacs 26 and earlier cannot use the autoload form -;; `tramp-compat-rx'. So we refrain from using `rx'. ;;;###autoload (progn (defmacro tramp-archive-autoload-file-name-regexp () "Regular expression matching archive file names." - (if (<= emacs-major-version 26) - '(concat - "\\`" "\\(" ".+" "\\." - ;; Default suffixes ... - (regexp-opt tramp-archive-suffixes) - ;; ... with compression. - "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" - "\\)" ;; \1 - "\\(" "/" ".*" "\\)" "\\'") ;; \2 `(rx bos ;; This group is used in `tramp-archive-file-name-archive'. @@ -208,13 +192,10 @@ It must be supported by libarchive(3).") (? "." (| ,@tramp-archive-compression-suffixes))) ;; This group is used in `tramp-archive-file-name-localname'. (group "/" (* nonl)) - eos)))) + eos))) (put #'tramp-archive-autoload-file-name-regexp 'tramp-autoload t) -;; In older Emacs (prior 27.1), `tramp-archive-autoload-file-name-regexp' -;; is not autoloaded. So we cannot expect it to be known in -;; tramp-loaddefs.el. But it exists, when tramp-archive.el is loaded. ;; We must wrap it into `eval-when-compile'. Otherwise, there could ;; be an "Eager macro-expansion failure" when unloading/reloading Tramp. ;;;###tramp-autoload @@ -222,11 +203,6 @@ It must be supported by libarchive(3).") (eval-when-compile (ignore-errors (tramp-archive-autoload-file-name-regexp))) "Regular expression matching archive file names.") -;; The value above is nil for Emacs 26. Set it now. -(if (<= emacs-major-version 26) - (setq tramp-archive-file-name-regexp - (ignore-errors (tramp-archive-autoload-file-name-regexp)))) - ;;;###tramp-autoload (defconst tramp-archive-method "archive" "Method name for archives in GVFS.") @@ -289,6 +265,7 @@ It must be supported by libarchive(3).") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-archive-handle-file-system-info) (file-truename . tramp-archive-handle-file-truename) + (file-user-uid . tramp-archive-handle-file-user-uid) (file-writable-p . ignore) (find-backup-file-name . ignore) ;; `get-file-buffer' performed by default handler. @@ -299,7 +276,7 @@ It must be supported by libarchive(3).") (lock-file . ignore) (make-auto-save-file-name . ignore) (make-directory . tramp-archive-handle-not-implemented) - (make-directory-internal . tramp-archive-handle-not-implemented) + (make-directory-internal . ignore) (make-lock-file-name . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) @@ -360,13 +337,9 @@ arguments to pass to the OPERATION." (tramp-register-file-name-handlers) (tramp-archive-run-real-handler operation args)) - (with-no-warnings ;; max-specpdl-size (let* ((filename (apply #'tramp-archive-file-name-for-operation operation args)) - (archive (tramp-archive-file-name-archive filename)) - ;; Sometimes, it fails with "Variable binding depth exceeds - ;; max-specpdl-size". Shall be fixed in Emacs 27. - (max-specpdl-size (* 2 max-specpdl-size))) + (archive (tramp-archive-file-name-archive filename))) ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. @@ -394,7 +367,7 @@ arguments to pass to the OPERATION." (setq args (cons operation args))) (if fn (save-match-data (apply (cdr fn) args)) - (tramp-archive-run-real-handler operation args)))))))) + (tramp-archive-run-real-handler operation args))))))) ;;;###autoload (progn (defun tramp-archive-autoload-file-name-handler (operation &rest args) @@ -432,10 +405,6 @@ arguments to pass to the OPERATION." (remove-hook 'after-init-hook #'tramp-register-archive-autoload-file-name-handler)))) -;; In older Emacsen (prior 27.1), the autoload above does not exist. -;; So we call it again; it doesn't hurt. -(tramp-register-archive-autoload-file-name-handler) - ;; Mark `operations' the handler is responsible for. (put #'tramp-archive-file-name-handler 'operations (mapcar #'car tramp-archive-file-name-handler-alist)) @@ -458,7 +427,7 @@ arguments to pass to the OPERATION." "Return t if NAME is a string with archive file name syntax." (and (stringp name) ;; `tramp-archive-file-name-regexp' does not suppress quoted file names. - (not (tramp-compat-file-name-quoted-p name t)) + (not (file-name-quoted-p name t)) ;; We cannot use `string-match-p', the matches are used. (string-match tramp-archive-file-name-regexp name) t)) @@ -511,7 +480,6 @@ name is kept in slot `hop'" ;; http://... ((and url-handler-mode - tramp-compat-use-url-tramp-p (string-match-p url-handler-regexp archive) (string-match-p "https?" (url-type (url-generic-parse-url archive)))) @@ -631,7 +599,7 @@ offered." (defun tramp-archive-handle-directory-file-name (directory) "Like `directory-file-name' for file archives." (with-parsed-tramp-archive-file-name directory nil - (if (and (not (zerop (length localname))) + (if (and (tramp-compat-length> localname 0) (eq (aref localname (1- (length localname))) ?/) (not (string= localname "/"))) (substring directory 0 -1) @@ -643,23 +611,22 @@ offered." (defun tramp-archive-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." - (unless (file-exists-p directory) - (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let ((temp (nreverse (file-name-all-completions "" directory))) - result item) - - (while temp - (setq item (directory-file-name (pop temp))) - (when (or (null match) (string-match-p match item)) - (push (if full (concat directory item) item) - result))) - (unless nosort - (setq result (sort result #'string<))) - (when (and (natnump count) (> count 0)) - (setq result (tramp-compat-ntake count result))) - result))) + (tramp-barf-if-file-missing (tramp-dissect-file-name directory) directory + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let ((temp (nreverse (file-name-all-completions "" directory))) + result item) + + (while temp + (setq item (directory-file-name (pop temp))) + (when (or (null match) (string-match-p match item)) + (push (if full (concat directory item) item) + result))) + (unless nosort + (setq result (sort result #'string<))) + (when (and (natnump count) (> count 0)) + (setq result (tramp-compat-ntake count result))) + result)))) (defun tramp-archive-handle-dired-uncache (dir) "Like `dired-uncache' for file archives." @@ -683,7 +650,9 @@ offered." (defun tramp-archive-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for file archives." - (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + (ignore-error file-missing + (file-name-all-completions + filename (tramp-archive-gvfs-file-name directory)))) (defun tramp-archive-handle-file-readable-p (filename) "Like `file-readable-p' for file archives." @@ -702,6 +671,13 @@ offered." (setq local (expand-file-name local (file-name-directory localname)))) (concat (file-truename archive) local)))) +(defun tramp-archive-handle-file-user-uid () + "Like `user-uid' for file archives." + (with-parsed-tramp-archive-file-name default-directory nil + (let ((default-directory (file-name-directory archive))) + ;; `file-user-uid' exists since Emacs 30.1. + (tramp-compat-funcall 'file-user-uid)))) + (defun tramp-archive-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for file archives." diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 09e43a99039..c5864e7fa5e 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -267,8 +267,7 @@ Return VALUE." (defun tramp-flush-directory-properties (key directory) "Remove all properties of DIRECTORY in the cache context of KEY. Remove also properties of all files in subdirectories." - (let* ((directory - (directory-file-name (tramp-compat-file-name-unquote directory))) + (let* ((directory (directory-file-name (file-name-unquote directory))) (truename (tramp-get-file-property key directory "file-truename"))) (tramp-message key 8 "%s" directory) (dolist (key (hash-table-keys tramp-cache-data)) @@ -677,4 +676,8 @@ for all methods. Resulting data are derived from connection history." (provide 'tramp-cache) +;;; TODO: +;; +;; * Use multisession.el, starting with Emacs 29.1. + ;;; tramp-cache.el ends here diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index bf7d45d2a5a..1a9d8003530 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -123,11 +123,11 @@ When called interactively, a Tramp connection has to be selected." ;; Delete processes. (dolist (key (hash-table-keys tramp-cache-data)) (when (and (processp key) - (tramp-file-name-equal-p (process-get key 'vector) vec) + (tramp-file-name-equal-p (process-get key 'tramp-vector) vec) (or (not keep-processes) (eq key (tramp-get-process vec)))) (tramp-flush-connection-properties key) - (delete-process key))) + (ignore-errors (delete-process key)))) ;; Remove buffers. (dolist @@ -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. @@ -359,7 +359,7 @@ The remote connection identified by SOURCE is flushed by (dir (tramp-rename-read-file-name-dir default)) (init (tramp-rename-read-file-name-init default)) (tramp-ignored-file-name-regexp - (tramp-compat-rx (literal (file-remote-p source))))) + (rx (literal (file-remote-p source))))) (read-file-name-default "Enter new Tramp connection: " dir default 'confirm init #'file-directory-p))))) @@ -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. @@ -470,7 +470,7 @@ For details, see `tramp-rename-files'." (dir (tramp-rename-read-file-name-dir default)) (init (tramp-rename-read-file-name-init default)) (tramp-ignored-file-name-regexp - (tramp-compat-rx (literal (file-remote-p source))))) + (rx (literal (file-remote-p source))))) (read-file-name-default (format "Change Tramp connection `%s': " source) dir default 'confirm init #'file-directory-p))))) @@ -625,7 +625,7 @@ buffer in your bug report. (unless (hash-table-p val) ;; Remove string quotation. (when (looking-at - (tramp-compat-rx + (rx bol (group (* anychar)) "\"" ;; \1 " (group "(base64-decode-string ") "\\" ;; \2 \ (group "\"" (* anychar)) "\\" ;; \3 \ diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index f176476a73a..420d6cadb9c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,9 +23,9 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 29. This -;; package provides compatibility functions for Emacs 26, Emacs 27 and -;; Emacs 28. +;; Tramp's main Emacs version for development is Emacs 30. This +;; package provides compatibility functions for Emacs 27, Emacs 28 and +;; Emacs 29. ;;; Code: @@ -36,9 +36,7 @@ (require 'shell) (require 'subr-x) -(declare-function tramp-compat-rx "tramp") (declare-function tramp-error "tramp") -(declare-function tramp-file-name-handler "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -85,153 +83,6 @@ Add the extension of F, if existing." tramp-temp-name-prefix tramp-compat-temporary-file-directory) dir-flag (file-name-extension f t))) -;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got -;; a second argument in Emacs 27.1. -;;;###tramp-autoload -(defalias 'tramp-compat-file-name-quoted-p - (if (equal (func-arity #'file-name-quoted-p) '(1 . 2)) - #'file-name-quoted-p - (lambda (name &optional top) - "Whether NAME is quoted with prefix \"/:\". -If NAME is a remote file name and TOP is nil, check the local part of NAME." - (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (string-prefix-p "/:" (file-local-name name)))))) - -(defalias 'tramp-compat-file-name-quote - (if (equal (func-arity #'file-name-quote) '(1 . 2)) - #'file-name-quote - (lambda (name &optional top) - "Add the quotation prefix \"/:\" to file NAME. -If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." - (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (if (tramp-compat-file-name-quoted-p name top) - name - (concat (file-remote-p name) "/:" (file-local-name name))))))) - -(defalias 'tramp-compat-file-name-unquote - (if (equal (func-arity #'file-name-unquote) '(1 . 2)) - #'file-name-unquote - (lambda (name &optional top) - "Remove quotation prefix \"/:\" from file NAME. -If NAME is a remote file name and TOP is nil, the local part of -NAME is unquoted." - (let* ((file-name-handler-alist (unless top file-name-handler-alist)) - (localname (file-local-name name))) - (when (tramp-compat-file-name-quoted-p localname top) - (setq - localname (if (= (length localname) 2) "/" (substring localname 2)))) - (concat (file-remote-p name) localname))))) - -;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still -;; support old settings. -(defsubst tramp-compat-tramp-syntax () - "Return proper value of `tramp-syntax'." - (defvar tramp-syntax) - (cond ((eq tramp-syntax 'ftp) 'default) - ((eq tramp-syntax 'sep) 'separate) - (t tramp-syntax))) - -;; The signature of `tramp-make-tramp-file-name' has been changed. -;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior -;; Emacs 26.1. We use `temporary-file-directory' as indicator. -(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) - "Whether to use url-tramp.el.") - -;; `exec-path' is new in Emacs 27.1. -(defalias 'tramp-compat-exec-path - (if (fboundp 'exec-path) - #'exec-path - (lambda () - "List of directories to search programs to run in remote subprocesses." - (if (tramp-tramp-file-p default-directory) - (tramp-file-name-handler 'exec-path) - exec-path)))) - -;; `time-equal-p' has appeared in Emacs 27.1. -(defalias 'tramp-compat-time-equal-p - (if (fboundp 'time-equal-p) - #'time-equal-p - (lambda (t1 t2) - "Return non-nil if time value T1 is equal to time value T2. -A nil value for either argument stands for the current time." - (equal (or t1 (current-time)) (or t2 (current-time)))))) - -;; `flatten-tree' has appeared in Emacs 27.1. -(defalias 'tramp-compat-flatten-tree - (if (fboundp 'flatten-tree) - #'flatten-tree - (lambda (tree) - "Take TREE and \"flatten\" it." - (let (elems) - (setq tree (list tree)) - (while (let ((elem (pop tree))) - (cond ((consp elem) - (setq tree (cons (car elem) (cons (cdr elem) tree)))) - (elem - (push elem elems))) - tree)) - (nreverse elems))))) - -;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. -(defalias 'tramp-compat-progress-reporter-update - (if (equal (func-arity #'progress-reporter-update) '(1 . 3)) - #'progress-reporter-update - (lambda (reporter &optional value _suffix) - (progress-reporter-update reporter value)))) - -;; `ignore-error' is new in Emacs 27.1. -(defmacro tramp-compat-ignore-error (condition &rest body) - "Execute BODY; if the error CONDITION occurs, return nil. -Otherwise, return result of last form in BODY. - -CONDITION can also be a list of error conditions." - (declare (debug t) (indent 1)) - `(condition-case nil (progn ,@body) (,condition nil))) - -;; `rx' in Emacs 26 doesn't know the `literal', `anychar' and -;; `multibyte' constructs. The `not' construct requires an `any' -;; construct as argument. The `regexp' construct requires a literal -;; string. -(defvar tramp-compat-rx--runtime-params) - -(defun tramp-compat-rx--transform-items (items) - (mapcar #'tramp-compat-rx--transform-item items)) - -;; There is an error in Emacs 26. `(rx "a" (? ""))' => "a?". -;; We must protect the string in regexp and literal, therefore. -(defun tramp-compat-rx--transform-item (item) - (pcase item - ('anychar 'anything) - ('multibyte 'nonascii) - (`(not ,expr) - (if (consp expr) item (list 'not (list 'any expr)))) - (`(regexp ,expr) - (setq tramp-compat-rx--runtime-params t) - `(regexp ,(list '\, `(concat "\\(?:" ,expr "\\)")))) - (`(literal ,expr) - (setq tramp-compat-rx--runtime-params t) - `(regexp ,(list '\, `(concat "\\(?:" (regexp-quote ,expr) "\\)")))) - (`(eval . ,_) item) - (`(,head . ,rest) (cons head (tramp-compat-rx--transform-items rest))) - (_ item))) - -(defun tramp-compat-rx--transform (items) - (let* ((tramp-compat-rx--runtime-params nil) - (new-rx (cons ': (tramp-compat-rx--transform-items items)))) - (if tramp-compat-rx--runtime-params - `(rx-to-string ,(list '\` new-rx) t) - (rx-to-string new-rx t)))) - -(if (ignore-errors (rx-to-string '(literal "a"))) ;; Emacs 27+. - (defalias 'tramp-compat-rx #'rx) - (defmacro tramp-compat-rx (&rest items) - (tramp-compat-rx--transform items))) - -;; This is needed for compilation in the Emacs source tree. -;;;###autoload (defalias 'tramp-compat-rx #'rx) - -(put #'tramp-compat-rx 'tramp-autoload t) - ;; `file-modes', `set-file-modes' and `set-file-times' got argument ;; FLAG in Emacs 28.1. (defalias 'tramp-compat-file-modes @@ -326,6 +177,48 @@ CONDITION can also be a list of error conditions." (car components)) (cdr components))))))) +;; Function `replace-regexp-in-region' is new in Emacs 28.1. +(defalias 'tramp-compat-replace-regexp-in-region + (if (fboundp 'replace-regexp-in-region) + #'replace-regexp-in-region + (lambda (regexp replacement &optional start end) + (if start + (when (< start (point-min)) + (error "Start before start of buffer")) + (setq start (point))) + (if end + (when (> end (point-max)) + (error "End after end of buffer")) + (setq end (point-max))) + (save-excursion + (let ((matches 0) + (case-fold-search nil)) + (goto-char start) + (while (re-search-forward regexp end t) + (replace-match replacement t) + (setq matches (1+ matches))) + (and (not (zerop matches)) + matches)))))) + +;; `length<', `length>' and `length=' are added to Emacs 28.1. +(defalias 'tramp-compat-length< + (if (fboundp 'length<) + #'length< + (lambda (sequence length) + (< (length sequence) length)))) + +(defalias 'tramp-compat-length> + (if (fboundp 'length>) + #'length> + (lambda (sequence length) + (> (length sequence) length)))) + +(defalias 'tramp-compat-length= + (if (fboundp 'length=) + #'length= + (lambda (sequence length) + (= (length sequence) length)))) + ;; `permission-denied' is introduced in Emacs 29.1. (defconst tramp-permission-denied (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error) @@ -353,7 +246,7 @@ CONDITION can also be a list of error conditions." #'take (lambda (n list) (when (and (natnump n) (> n 0)) - (if (>= n (length list)) + (if (tramp-compat-length< list n) list (butlast list (- (length list) n))))))) ;; Function `ntake' is new in Emacs 29.1. @@ -362,7 +255,7 @@ CONDITION can also be a list of error conditions." #'ntake (lambda (n list) (when (and (natnump n) (> n 0)) - (if (>= n (length list)) + (if (tramp-compat-length< list n) list (nbutlast list (- (length list) n))))))) ;; Function `string-equal-ignore-case' is new in Emacs 29.1. @@ -382,28 +275,18 @@ CONDITION can also be a list of error conditions." (autoload 'netrc-parse "netrc") (netrc-parse file)))) -;; Function `replace-regexp-in-region' is new in Emacs 28.1. -(defalias 'tramp-compat-replace-regexp-in-region - (if (fboundp 'replace-regexp-in-region) - #'replace-regexp-in-region - (lambda (regexp replacement &optional start end) - (if start - (when (< start (point-min)) - (error "Start before start of buffer")) - (setq start (point))) - (if end - (when (> end (point-max)) - (error "End after end of buffer")) - (setq end (point-max))) - (save-excursion - (let ((matches 0) - (case-fold-search nil)) - (goto-char start) - (while (re-search-forward regexp end t) - (replace-match replacement t) - (setq matches (1+ matches))) - (and (not (zerop matches)) - matches)))))) +;; User option `password-colon-equivalents' is new in Emacs 30.1. +(if (boundp 'password-colon-equivalents) + (defvaralias + 'tramp-compat-password-colon-equivalents + 'password-colon-equivalents) + (defvar tramp-compat-password-colon-equivalents + '(?\N{COLON} + ?\N{FULLWIDTH COLON} + ?\N{SMALL COLON} + ?\N{PRESENTATION FORM FOR VERTICAL COLON} + ?\N{KHMER SIGN CAMNUC PII KUUH}) + "List of characters equivalent to trailing colon in \"password\" prompts.")) (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -419,8 +302,5 @@ CONDITION can also be a list of error conditions." ;; ;; * Starting with Emacs 27.1, there's no need to escape open ;; parentheses with a backslash in docstrings anymore. -;; -;; * Starting with Emacs 27.1, there's `make-empty-file'. Could be -;; used instead of `(write-region "" ...)'. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el index 6cdd6c654ea..5ae9ebaefb2 100644 --- a/lisp/net/tramp-container.el +++ b/lisp/net/tramp-container.el @@ -41,6 +41,7 @@ ;; CONTAINER is the container to connect to ;; ;; +;; ;; Open file in a Kubernetes container: ;; ;; C-x C-f /kubernetes:POD:/path/to/file @@ -54,6 +55,18 @@ ;; namespace, use this command to change it: ;; ;; "kubectl config set-context --current --namespace=<name>" +;; +;; +;; +;; Open a file on an existing toolbox container via Toolbox: +;; +;; C-x C-f /toolbox:CONTAINER:/path/to/file +;; +;; Where: +;; CONTAINER is the container to connect to (optional) +;; +;; If the container is not running, it is started. If no container is +;; specified, the default Toolbox container is used. ;;; Code: @@ -84,6 +97,14 @@ (string))) ;;;###tramp-autoload +(defcustom tramp-toolbox-program "toolbox" + "Name of the Toolbox client program." + :group 'tramp + :version "30.1" + :type '(choice (const "toolbox") + (string))) + +;;;###tramp-autoload (defconst tramp-docker-method "docker" "Tramp method name to use to connect to Docker containers.") @@ -96,15 +117,20 @@ "Tramp method name to use to connect to Kubernetes containers.") ;;;###tramp-autoload -(defun tramp-docker--completion-function (&rest _args) - "List Docker-like containers available for connection. +(defconst tramp-toolbox-method "toolbox" + "Tramp method name to use to connect to Toolbox containers.") + +;;;###tramp-autoload +(defun tramp-container--completion-function (program) + "List running containers available for connection. +PROGRAM is the program to be run for \"ps\", either +`tramp-docker-program' or `tramp-podman-program'. This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (when-let ((default-directory tramp-compat-temporary-file-directory) (raw-list (shell-command-to-string - (concat tramp-docker-program - " ps --format '{{.ID}}\t{{.Names}}'"))) + (concat program " ps --format '{{.ID}}\t{{.Names}}'"))) (lines (split-string raw-list "\n" 'omit)) (names (mapcar (lambda (line) @@ -114,7 +140,7 @@ see its function help for a description of the format." line) (or (match-string 2 line) (match-string 1 line)))) lines))) - (mapcar (lambda (m) (list nil m)) (delq nil names)))) + (mapcar (lambda (name) (list nil name)) (delq nil names)))) ;;;###tramp-autoload (defun tramp-kubernetes--completion-function (&rest _args) @@ -128,9 +154,7 @@ see its function help for a description of the format." " get pods --no-headers " "-o custom-columns=NAME:.metadata.name"))) (names (split-string raw-list "\n" 'omit))) - (mapcar (lambda (name) - (list nil name)) - names))) + (mapcar (lambda (name) (list nil name)) (delq nil names)))) (defun tramp-kubernetes--current-context-data (vec) "Return Kubernetes current context data as JSON string." @@ -151,6 +175,27 @@ see its function help for a description of the format." (buffer-string)))))) ;;;###tramp-autoload +(defun tramp-toolbox--completion-function (&rest _args) + "List Toolbox containers available for connection. + +This function is used by `tramp-set-completion-function', please +see its function help for a description of the format." + (when-let ((default-directory tramp-compat-temporary-file-directory) + (raw-list (shell-command-to-string + (concat tramp-toolbox-program " list -c"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + (names (mapcar + (lambda (line) + (when (string-match + (rx bol (1+ (not space)) + (1+ space) (group (1+ (not space))) space) + line) + (match-string 1 line))) + lines))) + (mapcar (lambda (name) (list nil name)) (delq nil names)))) + +;;;###tramp-autoload (defvar tramp-default-remote-shell) ;; Silence byte compiler. ;;;###tramp-autoload @@ -167,6 +212,7 @@ see its function help for a description of the format." (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-i" "-c")))) + (add-to-list 'tramp-methods `(,tramp-podman-method (tramp-login-program ,tramp-podman-program) @@ -179,6 +225,7 @@ see its function help for a description of the format." (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-i" "-c")))) + (add-to-list 'tramp-methods `(,tramp-kubernetes-method (tramp-login-program ,tramp-kubernetes-program) @@ -193,17 +240,36 @@ see its function help for a description of the format." (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-i" "-c")))) + (add-to-list 'tramp-methods + `(,tramp-toolbox-method + (tramp-login-program ,tramp-toolbox-program) + (tramp-login-args (("run") + ("-c" "%h") + ("%l"))) + (tramp-direct-async (,tramp-default-remote-shell "-c")) + (tramp-remote-shell ,tramp-default-remote-shell) + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")))) + + (add-to-list 'tramp-default-host-alist `(,tramp-toolbox-method nil "")) + (tramp-set-completion-function tramp-docker-method - '((tramp-docker--completion-function ""))) + `((tramp-container--completion-function + ,(executable-find tramp-docker-program)))) (tramp-set-completion-function tramp-podman-method - '((tramp-docker--completion-function ""))) + `((tramp-container--completion-function + ,(executable-find tramp-podman-program)))) (tramp-set-completion-function tramp-kubernetes-method - '((tramp-kubernetes--completion-function "")))) + '((tramp-kubernetes--completion-function ""))) + + (tramp-set-completion-function + tramp-toolbox-method + '((tramp-toolbox--completion-function "")))) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index c7696a51dae..4d15695ccbf 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -146,7 +146,7 @@ They are completed by \"M-x TAB\" only when encryption support is enabled." If NAME doesn't belong to an encrypted remote directory, return nil." (catch 'crypt-file-name-p (and tramp-crypt-enabled (stringp name) - (not (tramp-compat-file-name-quoted-p name)) + (not (file-name-quoted-p name)) (not (string-suffix-p tramp-crypt-encfs-config name)) (dolist (dir tramp-crypt-directories) (and (string-prefix-p @@ -204,6 +204,7 @@ If NAME doesn't belong to an encrypted remote directory, return nil." (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-crypt-handle-file-system-info) ;; `file-truename' performed by default handler. + ;; `file-user-uid' performed by default-handler. (file-writable-p . tramp-crypt-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -315,7 +316,7 @@ connection if a previous connection has died for some reason." :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (set-process-query-on-exit-flag p nil))) ;; The following operations must be performed without @@ -435,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)) @@ -470,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))))) @@ -494,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)) - (when (tramp-compat-file-name-quoted-p name) - (tramp-user-error nil "%s must not be quoted." 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)) (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))) @@ -517,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 @@ -556,7 +557,7 @@ localname." (defun tramp-crypt-handle-access-file (filename string) "Like `access-file' for Tramp files." (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) - (encrypt-regexp (tramp-compat-rx (literal encrypt-filename) eos)) + (encrypt-regexp (rx (literal encrypt-filename) eos)) tramp-crypt-enabled) (condition-case err (access-file encrypt-filename string) @@ -689,17 +690,17 @@ absolute file names." (directory &optional recursive _trash) "Like `delete-directory' for Tramp files." (with-parsed-tramp-file-name (expand-file-name directory) nil - (tramp-flush-directory-properties v localname) (let (tramp-crypt-enabled) - (delete-directory (tramp-crypt-encrypt-file-name directory) recursive)))) + (delete-directory (tramp-crypt-encrypt-file-name directory) recursive)) + (tramp-flush-directory-properties v localname))) ;; Encrypted files won't be trashed. (defun tramp-crypt-handle-delete-file (filename &optional _trash) "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-flush-file-properties v localname) (let (tramp-crypt-enabled) - (delete-file (tramp-crypt-encrypt-file-name filename))))) + (delete-file (tramp-crypt-encrypt-file-name filename))) + (tramp-flush-file-properties v localname))) (defun tramp-crypt-handle-directory-files (directory &optional full match nosort count) @@ -709,8 +710,7 @@ absolute file names." (mapcar (lambda (x) (replace-regexp-in-string - (tramp-compat-rx bos (literal directory)) "" - (tramp-crypt-decrypt-file-name x))) + (rx bos (literal directory)) "" (tramp-crypt-decrypt-file-name x))) (directory-files (tramp-crypt-encrypt-file-name directory) 'full))))) (defun tramp-crypt-handle-file-attributes (filename &optional id-format) @@ -730,18 +730,19 @@ absolute file names." (defun tramp-crypt-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (let* (completion-regexp-list - tramp-crypt-enabled - (directory (file-name-as-directory directory)) - (enc-dir (tramp-crypt-encrypt-file-name directory))) - (mapcar - (lambda (x) - (substring - (tramp-crypt-decrypt-file-name (concat enc-dir x)) - (length directory))) - (file-name-all-completions "" enc-dir))))) + (ignore-error file-missing + (all-completions + filename + (let* (completion-regexp-list + tramp-crypt-enabled + (directory (file-name-as-directory directory)) + (enc-dir (tramp-crypt-encrypt-file-name directory))) + (mapcar + (lambda (x) + (substring + (tramp-crypt-decrypt-file-name (concat enc-dir x)) + (length directory))) + (file-name-all-completions "" enc-dir)))))) (defun tramp-crypt-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -756,9 +757,7 @@ absolute file names." (defun tramp-crypt-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (let (tramp-crypt-enabled) - ;; `file-system-info' exists since Emacs 27.1. - (tramp-compat-funcall - 'file-system-info (tramp-crypt-encrypt-file-name filename)))) + (file-system-info (tramp-crypt-encrypt-file-name filename)))) (defun tramp-crypt-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -769,27 +768,26 @@ absolute file names." (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files. WILDCARD is not supported." - ;; This package has been added to Emacs 27.1. - (when (load "text-property-search" 'noerror 'nomessage) - (let (tramp-crypt-enabled) - (tramp-handle-insert-directory - (tramp-crypt-encrypt-file-name filename) - switches wildcard full-directory-p) - (let* ((filename (file-name-as-directory filename)) - (enc (tramp-crypt-encrypt-file-name filename)) - match string) - (goto-char (point-min)) - (while (setq match (text-property-search-forward 'dired-filename t t)) - (setq string - (buffer-substring - (prop-match-beginning match) (prop-match-end match)) - string (if (file-name-absolute-p string) - (tramp-crypt-decrypt-file-name string) - (substring - (tramp-crypt-decrypt-file-name (concat enc string)) - (length filename)))) - (delete-region (prop-match-beginning match) (prop-match-end match)) - (insert (propertize string 'dired-filename t))))))) + (require 'text-property-search) + (let (tramp-crypt-enabled) + (tramp-handle-insert-directory + (tramp-crypt-encrypt-file-name filename) + switches wildcard full-directory-p) + (let* ((filename (file-name-as-directory filename)) + (enc (tramp-crypt-encrypt-file-name filename)) + match string) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'dired-filename t t)) + (setq string + (buffer-substring + (prop-match-beginning match) (prop-match-end match)) + string (if (file-name-absolute-p string) + (tramp-crypt-decrypt-file-name string) + (substring + (tramp-crypt-decrypt-file-name (concat enc string)) + (length filename)))) + (delete-region (prop-match-beginning match) (prop-match-end match)) + (insert (propertize string 'dired-filename t)))))) (defun tramp-crypt-handle-lock-file (filename) "Like `lock-file' for Tramp files." @@ -800,16 +798,9 @@ WILDCARD is not supported." (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name dir) nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) + (tramp-skeleton-make-directory dir parents (let (tramp-crypt-enabled) - (make-directory (tramp-crypt-encrypt-file-name dir) parents)) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole cache. - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))))) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)))) (defun tramp-crypt-handle-rename-file (filename newname &optional ok-if-already-exists) diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index e1ad0c2e5d2..8112e564a2c 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -34,15 +34,13 @@ (defun tramp-fuse-handle-delete-directory (directory &optional recursive trash) "Like `delete-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name directory) nil - (tramp-flush-directory-properties v localname) + (tramp-skeleton-delete-directory directory recursive trash (delete-directory (tramp-fuse-local-file-name directory) recursive trash))) (defun tramp-fuse-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (delete-file (tramp-fuse-local-file-name filename) trash) - (tramp-flush-file-properties v localname))) + (tramp-skeleton-delete-file filename trash + (delete-file (tramp-fuse-local-file-name filename) trash))) (defvar tramp-fuse-remove-hidden-files nil "Remove hidden files from directory listings.") @@ -69,15 +67,15 @@ (tramp-fuse-local-file-name directory)))))))) (if full ;; Massage the result. - (let ((local (tramp-compat-rx + (let ((local (rx bol (literal (tramp-fuse-mount-point (tramp-dissect-file-name directory))))) (remote (directory-file-name (funcall - (if (tramp-compat-file-name-quoted-p directory) - #'tramp-compat-file-name-quote #'identity) + (if (file-name-quoted-p directory) + #'file-name-quote #'identity) (file-remote-p directory))))) (mapcar (lambda (x) (replace-regexp-in-string local remote x)) @@ -100,20 +98,21 @@ (defun tramp-fuse-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (tramp-fuse-remove-hidden-files - (all-completions - filename - (delete-dups - (append - (file-name-all-completions - filename (tramp-fuse-local-file-name directory)) - ;; Some storage systems do not return "." and "..". - (let (result) - (dolist (item '(".." ".") result) - (when (string-prefix-p filename item) - (catch 'match - (dolist (elt completion-regexp-list) - (unless (string-match-p elt item) (throw 'match nil))) - (setq result (cons (concat item "/") result))))))))))) + (ignore-error file-missing + (all-completions + filename + (delete-dups + (append + (file-name-all-completions + filename (tramp-fuse-local-file-name directory)) + ;; Some storage systems do not return "." and "..". + (let (result) + (dolist (item '(".." ".") result) + (when (string-prefix-p filename item) + (catch 'match + (dolist (elt completion-regexp-list) + (unless (string-match-p elt item) (throw 'match nil))) + (setq result (cons (concat item "/") result)))))))))))) ;; This function isn't used. (defun tramp-fuse-handle-insert-directory @@ -127,14 +126,8 @@ (defun tramp-fuse-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name dir) nil - (make-directory (tramp-fuse-local-file-name dir) parents) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole file cache. - (tramp-flush-file-properties v localname) - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))))) + (tramp-skeleton-make-directory dir parents + (make-directory (tramp-fuse-local-file-name dir) parents))) ;; File name helper functions. @@ -180,8 +173,7 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") (tramp-set-file-property vec "/" "mounted" (when (string-match - (tramp-compat-rx - bol (group (literal (tramp-fuse-mount-spec vec))) blank) + (rx bol (group (literal (tramp-fuse-mount-spec vec))) blank) mount) (match-string 1 mount))))))) @@ -211,7 +203,7 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") (defun tramp-fuse-local-file-name (filename) "Return local mount name of FILENAME." - (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (setq filename (file-name-unquote (expand-file-name filename))) (with-parsed-tramp-file-name filename nil ;; As long as we call `tramp-*-maybe-open-connection' here, ;; we cache the result. @@ -220,10 +212,10 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") (intern (format "tramp-%s-maybe-open-connection" (tramp-file-name-method v))) v) - (let ((quoted (tramp-compat-file-name-quoted-p localname)) - (localname (tramp-compat-file-name-unquote localname))) + (let ((quoted (file-name-quoted-p localname)) + (localname (file-name-unquote localname))) (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (if (file-name-absolute-p localname) (substring localname 1) localname) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 0273c28beca..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 @@ -414,7 +446,7 @@ It has been changed in GVFS 1.14.") ;; </interface> (defconst tramp-goa-identity-regexp - (tramp-compat-rx + (rx bol (? (group (regexp tramp-user-regexp))) "@" (? (group (regexp tramp-host-regexp))) (? ":" (group (regexp tramp-port-regexp)))) @@ -716,13 +748,13 @@ It has been changed in GVFS 1.14.") "GVFS file attributes.")) (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp - (tramp-compat-rx + (rx blank (group (regexp (regexp-opt tramp-gvfs-file-attributes))) "=" (group (+? nonl))) "Regexp to parse GVFS file attributes with `gvfs-ls'.") (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp - (tramp-compat-rx + (rx bol (* blank) (group (regexp (regexp-opt tramp-gvfs-file-attributes))) ":" (+ blank) (group (* nonl)) eol) "Regexp to parse GVFS file attributes with `gvfs-info'.") @@ -734,7 +766,7 @@ It has been changed in GVFS 1.14.") "GVFS file system attributes.") (defconst tramp-gvfs-file-system-attributes-regexp - (tramp-compat-rx + (rx bol (* blank) (group (regexp (regexp-opt tramp-gvfs-file-system-attributes))) ":" (+ blank) (group (* nonl)) eol) @@ -744,7 +776,7 @@ It has been changed in GVFS 1.14.") "Default prefix for owncloud / nextcloud methods.") (defconst tramp-gvfs-nextcloud-default-prefix-regexp - (tramp-compat-rx (literal tramp-gvfs-nextcloud-default-prefix) eol) + (rx (literal tramp-gvfs-nextcloud-default-prefix) eol) "Regexp of default prefix for owncloud / nextcloud methods.") @@ -798,6 +830,7 @@ It has been changed in GVFS 1.14.") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-gvfs-handle-file-system-info) (file-truename . tramp-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -871,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. @@ -1079,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 @@ -1139,25 +1180,23 @@ file names." (defun tramp-gvfs-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-flush-file-properties v localname) - (if (and delete-by-moving-to-trash trash) - (move-file-to-trash filename) - (unless (and (tramp-gvfs-send-command - v "gvfs-rm" (tramp-gvfs-url-file-name filename)) - (not (tramp-gvfs-info filename))) - ;; Propagate the error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (tramp-error-with-buffer - nil v 'file-error "Couldn't delete %s" filename)))))) + (tramp-skeleton-delete-file filename trash + (unless (and (tramp-gvfs-send-command + v "gvfs-rm" (tramp-gvfs-url-file-name filename)) + (not (tramp-gvfs-info filename))) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error "Couldn't delete %s" filename))))) (defun tramp-gvfs-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (setq dir (or dir default-directory "/")) ;; Handle empty NAME. - (when (zerop (length name)) (setq name ".")) + (when (string-empty-p name) + (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) @@ -1168,12 +1207,11 @@ file names." (with-parsed-tramp-file-name name nil ;; If there is a default location, expand tilde. (when (string-match - (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) - localname) + (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) hname) - (when (zerop (length uname)) + (when (tramp-string-empty-or-nil-p uname) (setq uname user)) (when (setq hname (tramp-get-home-directory v uname)) (setq localname (concat hname fname))))) @@ -1186,8 +1224,7 @@ file names." ;; We do not pass "/..". (if (string-match-p (rx bos (| "afp" (: "dav" (? "s")) "smb") eos) method) (when (string-match - (tramp-compat-rx bos "/" (+ (not "/")) (group "/.." (? "/"))) - localname) + (rx bos "/" (+ (not "/")) (group "/.." (? "/"))) localname) (setq localname (replace-match "/" t t localname 1))) (when (string-match (rx bol "/.." (? "/")) localname) (setq localname (replace-match "/" t t localname)))) @@ -1222,7 +1259,7 @@ file names." (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (while (looking-at - (tramp-compat-rx + (rx bol (group (+ nonl)) blank (group (+ digit)) blank "(" (group (+? nonl)) ")" @@ -1232,7 +1269,7 @@ file names." (cons "name" (match-string 1))))) (goto-char (1+ (match-end 3))) (while (looking-at - (tramp-compat-rx + (rx (regexp tramp-gvfs-file-attributes-with-gvfs-ls-regexp) (group (| (regexp @@ -1281,11 +1318,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Return GVFS attributes association list of FILENAME." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil - (setq localname (tramp-compat-file-name-unquote localname)) + (setq localname (file-name-unquote localname)) (if (or (and (string-match-p (rx bol (| "afp" (: "dav" (? "s")) "smb") eol) method) - (string-match-p - (tramp-compat-rx bol (? "/") (+ (not "/")) eol) localname)) + (string-match-p (rx bol (? "/") (+ (not "/")) eol) localname)) (string-equal localname "/")) (tramp-gvfs-get-root-attributes filename) (assoc @@ -1422,16 +1458,19 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (unless (tramp-compat-string-search "/" filename) - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (let ((result '("./" "../"))) - ;; Get a list of directories and files. - (dolist (item (tramp-gvfs-get-directory-attributes directory) result) - (if (string-equal (cdr (assoc "type" item)) "directory") - (push (file-name-as-directory (car item)) result) - (push (car item) result))))))))) + (ignore-error file-missing + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (let ((result '("./" "../"))) + ;; Get a list of directories and files. + (dolist (item + (tramp-gvfs-get-directory-attributes directory) + result) + (if (string-equal (cdr (assoc "type" item)) "directory") + (push (file-name-as-directory (car item)) result) + (push (car item) result)))))))))) (defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -1461,16 +1500,16 @@ If FILE-SYSTEM is non-nil, return file system attributes." v 'file-notify-error "Monitoring not supported for `%s'" file-name) (tramp-message v 6 "Run `%s', %S" (string-join (process-command p) " ") p) - (process-put p 'vector v) - (process-put p 'events events) - (process-put p 'watch-name localname) + (process-put p 'tramp-vector v) + (process-put p 'tramp-events events) + (process-put p 'tramp-watch-name localname) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) (set-process-filter p #'tramp-gvfs-monitor-process-filter) (set-process-sentinel p #'tramp-file-notify-process-sentinel) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. - (while (tramp-accept-process-output p 0)) + (while (tramp-accept-process-output p)) (unless (process-live-p p) (tramp-error p 'file-notify-error "Monitoring not supported for `%s'" file-name)) @@ -1482,10 +1521,10 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-monitor-process-filter (proc string) "Read output from \"gvfs-monitor-file\" and add corresponding \ `file-notify' events." - (let* ((events (process-get proc 'events)) - (rest-string (process-get proc 'rest-string)) + (let* ((events (process-get proc 'tramp-events)) + (rest-string (process-get proc 'tramp-rest-string)) (dd (tramp-get-default-directory (process-buffer proc))) - (ddu (tramp-compat-rx (literal (tramp-gvfs-url-file-name dd))))) + (ddu (rx (literal (tramp-gvfs-url-file-name dd))))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) @@ -1504,7 +1543,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (delete-process proc)) (while (string-match - (tramp-compat-rx + (rx bol (+ nonl) ":" blank (group (+ nonl)) ":" blank (group (regexp (regexp-opt tramp-gio-events))) @@ -1526,7 +1565,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (setq file1 (url-unhex-string file1))) ;; Remove watch when file or directory to be watched is deleted. (when (and (member action '(moved deleted)) - (string-equal file (process-get proc 'watch-name))) + (string-equal file (process-get proc 'tramp-watch-name))) (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at @@ -1536,9 +1575,9 @@ If FILE-SYSTEM is non-nil, return file system attributes." 'file-notify-callback (list proc action file file1))))) ;; Save rest of the string. - (when (zerop (length string)) (setq string nil)) + (when (string-empty-p string) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) - (process-put proc 'rest-string string))) + (process-put proc 'tramp-rest-string string))) (defun tramp-gvfs-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -1560,27 +1599,13 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (directory-file-name (expand-file-name dir))) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - (tramp-flush-directory-properties v localname) + (tramp-skeleton-make-directory dir parents (save-match-data - (let ((ldir (file-name-directory dir))) - ;; Make missing directory parts. "gvfs-mkdir -p ..." does not - ;; work robust. - (when (and parents (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (or (when-let ((mkdir-succeeded - (and - (tramp-gvfs-send-command - v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) - (tramp-gvfs-info dir)))) - (set-file-modes dir (default-file-modes)) - mkdir-succeeded) - (and parents (file-directory-p dir)) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) + (if (and (tramp-gvfs-send-command + v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) + (tramp-gvfs-info dir)) + (set-file-modes dir (default-file-modes)) + (tramp-error v 'file-error "Couldn't make directory %s" dir))))) (defun tramp-gvfs-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -1621,12 +1646,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-gvfs-set-attribute v (if (eq flag 'nofollow) "-nt" "-t") "uint64" (tramp-gvfs-url-file-name filename) "time::modified" - (format-time-string - "%s" (if (or (null time) - (tramp-compat-time-equal-p time tramp-time-doesnt-exist) - (tramp-compat-time-equal-p time tramp-time-dont-know)) - nil - time))))) + (format-time-string "%s" (tramp-defined-time time))))) (defun tramp-gvfs-handle-get-home-directory (vec &optional _user) "The remote home directory for connection VEC as local file name. @@ -1636,7 +1656,7 @@ VEC or USER, or if there is no home directory, return nil." (let ((localname (tramp-get-connection-property vec "default-location")) result) (cond - ((zerop (length localname)) + ((tramp-string-empty-or-nil-p localname) (tramp-get-connection-property (tramp-get-process vec) "share")) ;; Google-drive. ((not (string-prefix-p "/" localname)) @@ -1719,7 +1739,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - (setq filename (tramp-compat-file-name-unquote filename)) + (setq filename (file-name-unquote filename)) (let* (;; "/" must NOT be hexified. (url-unreserved-chars (cons ?/ url-unreserved-chars)) (result @@ -1739,8 +1759,7 @@ ID-FORMAT valid values are `string' and `integer'." "Retrieve file name from D-Bus OBJECT-PATH." (dbus-unescape-from-identifier (replace-regexp-in-string - (tramp-compat-rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1" - object-path))) + (rx bol (* nonl) "/" (group (+ (not "/"))) eol) "\\1" object-path))) (defun tramp-gvfs-url-host (url) "Return the host name part of URL, a string. @@ -1769,11 +1788,11 @@ a downcased host name only." (condition-case nil (with-parsed-tramp-file-name filename l - (when (and (zerop (length user)) + (when (and (tramp-string-empty-or-nil-p user) (not (zerop (logand flags tramp-gvfs-password-need-username)))) (setq user (read-string "User name: "))) - (when (and (zerop (length domain)) + (when (and (tramp-string-empty-or-nil-p domain) (not (zerop (logand flags tramp-gvfs-password-need-domain)))) (setq domain (read-string "Domain name: "))) @@ -2016,7 +2035,7 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) (string-match-p - (tramp-compat-rx bol "/" (literal (or share ""))) + (rx bol "/" (literal (or share ""))) (tramp-file-name-unquote-localname vec))) ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) @@ -2061,8 +2080,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match - (tramp-compat-rx bol (? "/") (group (+ (not "/")))) - localname) + (rx bol (? "/") (group (+ (not "/")))) localname) (match-string 1 localname))) (ssl (if (string-match-p (rx bol (| "davs" "nextcloud")) method) "true" "false")) @@ -2105,8 +2123,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref (if (and (string-match-p (rx bol "dav") method) - (string-match - (tramp-compat-rx bol (? "/") (+ (not "/"))) localname)) + (string-match (rx bol (? "/") (+ (not "/"))) localname)) (match-string 0 localname) (tramp-gvfs-get-remote-prefix vec)))) @@ -2167,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? @@ -2175,7 +2204,7 @@ connection if a previous connection has died for some reason." :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (set-process-query-on-exit-flag p nil) ;; Set connection-local variables. @@ -2212,7 +2241,7 @@ connection if a previous connection has died for some reason." (with-tramp-progress-reporter vec 3 - (if (zerop (length user)) + (if (tramp-string-empty-or-nil-p user) (format "Opening connection for %s using %s" host method) (format "Opening connection for %s@%s using %s" user host method)) @@ -2262,7 +2291,7 @@ connection if a previous connection has died for some reason." (with-timeout ((or (tramp-get-method-parameter vec 'tramp-connection-timeout) tramp-connection-timeout) - (if (zerop (length (tramp-file-name-user vec))) + (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) (tramp-error vec 'file-error "Timeout reached mounting %s using %s" host method) @@ -2441,7 +2470,7 @@ VEC is used only for traces." ;; Adapt default host name, supporting /mtp:: when possible. (setq tramp-default-host-alist (append - `(("mtp" nil ,(if (= (length devices) 1) (car devices) ""))) + `(("mtp" nil ,(if (tramp-compat-length= devices 1) (car devices) ""))) (delete (assoc "mtp" tramp-default-host-alist) tramp-default-host-alist))))) @@ -2493,63 +2522,62 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (delete-dups (mapcar (lambda (x) - (let* ((list (split-string x ";")) - (host (nth 6 list)) - (text (split-string (nth 9 list) "\" \"" 'omit "\"")) - user) - ;; A user is marked in a TXT field like "u=guest". - (while text - (when (string-match (rx "u=" (group (+ nonl)) eol) (car text)) - (setq user (match-string 1 (car text)))) - (setq text (cdr text))) - (list user host))) + (ignore-errors + (let* ((list (split-string x ";")) + (host (nth 6 list)) + (text (split-string (nth 9 list) "\" \"" 'omit "\"")) + user) + ;; A user is marked in a TXT field like "u=guest". + (while text + (when (string-match (rx "u=" (group (+ nonl)) eol) (car text)) + (setq user (match-string 1 (car text)))) + (setq text (cdr text))) + (list user host)))) result)))) (when tramp-gvfs-enabled - (with-no-warnings ;; max-specpdl-size ;; Suppress D-Bus error messages and Tramp traces. - (let (;; Sometimes, it fails with "Variable binding depth exceeds - ;; max-specpdl-size". Shall be fixed in Emacs 27. - (max-specpdl-size (* 2 max-specpdl-size)) - (tramp-verbose 0) + (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) @@ -2564,7 +2592,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." "mtp" (mapcar (lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method))) - tramp-media-methods))))) + tramp-media-methods)))) (add-hook 'tramp-unload-hook (lambda () @@ -2579,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 cff0877555e..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) @@ -53,7 +54,7 @@ (defvar shortdoc--groups) (defvar tramp-current-connection) (defvar tramp-postfix-host-format) -(defvar tramp-use-ssh-controlmaster-options) +(defvar tramp-use-connection-share) ;;; Fontification of `read-file-name': @@ -133,8 +134,7 @@ been set up by `rfn-eshadow-setup-minibuffer'." ;; Use `path-separator' as it does eshell. (setq eshell-path-env (if (file-remote-p default-directory) - (mapconcat - #'identity (butlast (tramp-compat-exec-path)) path-separator) + (string-join (butlast (exec-path)) path-separator) (getenv "PATH")))) (with-eval-after-load 'esh-util @@ -303,7 +303,7 @@ NAME must be equal to `tramp-current-connection'." ;; Bug#45518. So we don't use ssh ControlMaster options. (defun tramp-compile-disable-ssh-controlmaster-options () "Don't allow ssh ControlMaster while compiling." - (setq-local tramp-use-ssh-controlmaster-options nil)) + (setq-local tramp-use-connection-share 'suppress)) (with-eval-after-load 'compile (add-hook 'compilation-mode-hook @@ -346,8 +346,7 @@ NAME must be equal to `tramp-current-connection'." (defconst tramp-bsd-process-attributes-ps-args `("-acxww" "-o" - ,(mapconcat - #'identity + ,(string-join '("pid" "euid" "user" @@ -356,8 +355,7 @@ NAME must be equal to `tramp-current-connection'." "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") ",") "-o" - ,(mapconcat - #'identity + ,(string-join '("state" "ppid" "pgid" @@ -420,8 +418,7 @@ See `tramp-process-attributes-ps-format'.") ;; Tested with BusyBox v1.24.1. (defconst tramp-busybox-process-attributes-ps-args `("-o" - ,(mapconcat - #'identity + ,(string-join '("pid" "user" "group" @@ -429,8 +426,7 @@ See `tramp-process-attributes-ps-format'.") ",") "-o" "stat=abcde" "-o" - ,(mapconcat - #'identity + ,(string-join '("ppid" "pgid" "tty" @@ -473,8 +469,7 @@ See `tramp-process-attributes-ps-format'.") (defconst tramp-darwin-process-attributes-ps-args `("-acxww" "-o" - ,(mapconcat - #'identity + ,(string-join '("pid" "uid" "user" @@ -483,8 +478,7 @@ See `tramp-process-attributes-ps-format'.") ",") "-o" "state=abcde" "-o" - ,(mapconcat - #'identity + ,(string-join '("ppid" "pgid" "sess" @@ -556,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-rclone.el b/lisp/net/tramp-rclone.el index 2360abfb1dd..ec6a1da684f 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -118,6 +118,7 @@ (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-rclone-handle-file-system-info) (file-truename . tramp-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -337,7 +338,7 @@ file names." (defun tramp-rclone-remote-file-name (filename) "Return FILENAME as used in the `rclone' command." - (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) + (setq filename (file-name-unquote (expand-file-name filename))) (if (tramp-rclone-file-name-p filename) (with-parsed-tramp-file-name filename nil ;; As long as we call `tramp-rclone-maybe-open-connection' here, @@ -361,7 +362,7 @@ connection if a previous connection has died for some reason." (let ((host (tramp-file-name-host vec))) (when (rassoc `(,host) (tramp-rclone-parse-device-names nil)) - (if (zerop (length host)) + (if (tramp-string-empty-or-nil-p host) (tramp-error vec 'file-error "Storage %s not connected" host)) ;; We need a process bound to the connection buffer. Therefore, ;; we create a dummy process. Maybe there is a better solution? @@ -370,7 +371,7 @@ connection if a previous connection has died for some reason." :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (set-process-query-on-exit-flag p nil) ;; Set connection-local variables. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 392a654df21..2df3006c1d9 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -106,13 +106,24 @@ 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.") -(defcustom tramp-use-ssh-controlmaster-options (not (eq system-type 'windows-nt)) - "Whether to use `tramp-ssh-controlmaster-options'. +(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 +are `tramp-ssh-controlmaster-options' for ssh, and \"-share\" for PuTTY. Set it to nil, if you use Control* or Proxy* options in your ssh -configuration." +configuration. +Set it to `suppress' if you want to disable settings in your +\"~/.ssh/config\" file or in your PuTTY session." :group 'tramp - :version "28.1" - :type 'boolean) + :version "30.1" + :type '(choice (const :tag "Set ControlMaster" t) + (const :tag "Don't set ControlMaster" nil) + (const :tag "Suppress ControlMaster" suppress)) + ;; Check with (safe-local-variable-p 'tramp-use-connection-share 'suppress) + :safe (lambda (val) (and (memq val '(t nil suppress)) t))) (defvar tramp-ssh-controlmaster-options nil "Which ssh Control* arguments to use. @@ -123,8 +134,8 @@ If it is a string, it should have the form spec must be doubled, because the string is used as format string. Otherwise, it will be auto-detected by Tramp, if -`tramp-use-ssh-controlmaster-options' is non-nil. The value -depends on the installed local ssh version. +`tramp-use-connection-share' is t. The value depends on the +installed local ssh version. The string is used in `tramp-methods'.") @@ -341,7 +352,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-methods `("plink" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") ("-t") ("%h") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" @@ -354,7 +365,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-methods `("plinkx" (tramp-login-program "plink") - (tramp-login-args (("-load") ("%h") ("-t") ("\"") + (tramp-login-args (("-load") ("%h") ("%c") ("-t") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" tramp-terminal-type @@ -366,7 +377,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-methods `("pscp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") ("-t") ("%h") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" @@ -384,7 +395,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-methods `("psftp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%c") ("-t") ("%h") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" @@ -396,7 +407,7 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "pscp") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") - ("-p" "%k") ("-q"))) + ("-p" "%k"))) (tramp-copy-keep-date t))) (add-to-list 'tramp-methods `("fcp" @@ -411,7 +422,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-default-method-alist `(,tramp-local-host-regexp - ,(tramp-compat-rx bos (literal tramp-root-id-string) eos) "su")) + ,(rx bos (literal tramp-root-id-string) eos) "su")) (add-to-list 'tramp-default-user-alist `(,(rx bos (| "su" "sudo" "doas" "ksu") eos) @@ -631,7 +642,6 @@ foreach $f (@files) { print \"$f\\n\"; } } -print \"ok\\n\" ' \"$1\" %n" "Perl script to produce output suitable for use with `file-name-all-completions' on the remote file system. @@ -1086,6 +1096,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-sh-handle-file-system-info) (file-truename . tramp-sh-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-sh-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -1131,140 +1142,67 @@ Operations not mentioned here will be handled by the normal Emacs functions.") (defun tramp-sh-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If TARGET is a non-Tramp file, it is used verbatim as the target -of the symlink. If TARGET is a Tramp file, only the localname -component is used as the target of the symlink." - (with-parsed-tramp-file-name (expand-file-name linkname) nil - ;; If TARGET is a Tramp name, use just the localname component. - ;; Don't check for a proper method. - (let ((non-essential t)) - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target)))) - ;; There could be a cyclic link. - (tramp-flush-file-properties - v (expand-file-name target (tramp-file-local-name default-directory)))) - - ;; If TARGET is still remote, quote it. - (if (tramp-tramp-file-p target) - (make-symbolic-link - (tramp-compat-file-name-quote target 'top) - linkname ok-if-already-exists) - - (let ((ln (tramp-get-remote-ln v)) - (cwd (tramp-run-real-handler - #'file-name-directory (list localname)))) - (unless ln - (tramp-error - v 'file-error - (concat "Making a symbolic link. " - "ln(1) does not exist on the remote host."))) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not - (yes-or-no-p - (format - "File %s already exists; make it a link anyway?" - localname))))) - (tramp-error v 'file-already-exists localname) - (delete-file linkname))) - - (tramp-flush-file-properties v localname) - - ;; Right, they are on the same host, regardless of user, - ;; method, etc. We now make the link on the remote machine. - ;; This will occur as the user that TARGET belongs to. - (and (tramp-send-command-and-check - v (format "cd %s" (tramp-shell-quote-argument cwd))) - (tramp-send-command-and-check - v (format - "%s -sf %s %s" ln - (tramp-shell-quote-argument target) - ;; The command could exceed PATH_MAX, so we use - ;; relative file names. However, relative file names - ;; could start with "-". - ;; `tramp-shell-quote-argument' does not handle this, - ;; we must do it ourselves. - (tramp-shell-quote-argument - (concat "./" (file-name-nondirectory localname)))))))))) + "Like `make-symbolic-link' for Tramp files." + (let ((v (tramp-dissect-file-name (expand-file-name linkname)))) + (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")))) + + (tramp-skeleton-handle-make-symbolic-link target linkname ok-if-already-exists + (and (tramp-send-command-and-check + v (format + "cd %s" + (tramp-shell-quote-argument (file-name-directory localname)))) + (tramp-send-command-and-check + v (format + "%s -sf %s %s" (tramp-get-remote-ln v) + (tramp-shell-quote-argument target) + ;; The command could exceed PATH_MAX, so we use relative + ;; file names. + (tramp-shell-quote-argument + (concat "./" (file-name-nondirectory localname)))))))) (defun tramp-sh-handle-file-truename (filename) "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (directory-name-p filename) #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (with-parsed-tramp-file-name - (tramp-compat-file-name-unquote (expand-file-name filename)) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (tramp-message v 4 "Finding true name for `%s'" filename) - (let ((result - (cond - ;; Use GNU readlink --canonicalize-missing where available. - ((tramp-get-remote-readlink v) - (tramp-send-command-and-check - v (format "%s --canonicalize-missing %s" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (buffer-substring (point-min) (line-end-position)))) - - ;; Use Perl implementation. - ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec") - (tramp-get-connection-property v "perl-cwd-realpath")) - (tramp-maybe-send-script - v tramp-perl-file-truename "tramp_perl_file_truename") - (tramp-send-command-and-read - v (format "tramp_perl_file_truename %s" - (tramp-shell-quote-argument localname)))) - - ;; Do it yourself. - (t (tramp-file-local-name - (tramp-handle-file-truename filename)))))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (file-remote-p result) - (setq result (tramp-compat-file-name-quote result 'top))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))))) + (tramp-skeleton-file-truename filename + (cond + ;; Use GNU readlink --canonicalize-missing where available. + ((tramp-get-remote-readlink v) + (tramp-send-command-and-check + v (format "%s --canonicalize-missing %s" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (buffer-substring (point-min) (line-end-position)))) + + ;; Use Perl implementation. + ((and (tramp-get-remote-perl v) + (tramp-get-connection-property v "perl-file-spec") + (tramp-get-connection-property v "perl-cwd-realpath")) + (tramp-maybe-send-script + v tramp-perl-file-truename "tramp_perl_file_truename") + (tramp-send-command-and-read + v (format "tramp_perl_file_truename %s" + (tramp-shell-quote-argument localname)))) + + ;; Do it yourself. + (t (tramp-file-local-name + (tramp-handle-file-truename filename)))))) ;; Basic functions. (defun tramp-sh-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." - ;; `file-exists-p' is used as predicate in file name completion. - ;; We don't want to run it when `non-essential' is t, or there is - ;; no connection process yet. - (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-exists-p" - (if (tramp-file-property-p v localname "file-attributes") - (not (null (tramp-get-file-property v localname "file-attributes"))) - (tramp-send-command-and-check - v - (format - "%s %s" - (tramp-get-file-exists-command v) - (tramp-shell-quote-argument localname)))))))) + (tramp-skeleton-file-exists-p filename + (tramp-send-command-and-check + v + (format + "%s %s" + (tramp-get-file-exists-command v) + (tramp-shell-quote-argument localname))))) (defun tramp-sh-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -1438,7 +1376,7 @@ component is used as the target of the symlink." (modtime (or (file-attribute-modification-time attr) tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) - (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) + (if (not (time-equal-p modtime tramp-time-dont-know)) (tramp-run-real-handler #'set-visited-file-modtime (list modtime)) (progn (tramp-send-command @@ -1478,9 +1416,7 @@ of." (cond ;; File exists, and has a known modtime. - ((and attr - (not - (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + ((and attr (not (time-equal-p modtime tramp-time-dont-know))) (< (abs (tramp-time-diff modtime mt)) 2)) ;; Modtime has the don't know value. (attr @@ -1497,7 +1433,7 @@ of." v localname "visited-file-modtime-ild" ""))) ;; If file does not exist, say it is not modified if and ;; only if that agrees with the buffer's record. - (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) + (t (time-equal-p mt tramp-time-doesnt-exist))))))))) (defun tramp-sh-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -1519,21 +1455,17 @@ of." "Like `set-file-times' for Tramp files." (tramp-skeleton-set-file-modes-times-uid-gid filename (when (tramp-get-remote-touch v) - (let ((time - (if (or (null time) - (tramp-compat-time-equal-p time tramp-time-doesnt-exist) - (tramp-compat-time-equal-p time tramp-time-dont-know)) - nil - time))) - (tramp-send-command-and-check - v (format - "env TZ=UTC0 %s %s %s %s" - (tramp-get-remote-touch v) - (if (tramp-get-connection-property v "touch-t") - (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) - "") - (if (eq flag 'nofollow) "-h" "") - (tramp-shell-quote-argument localname))))))) + (tramp-send-command-and-check + v (format + "env TZ=UTC0 %s %s %s %s" + (tramp-get-remote-touch v) + (if (tramp-get-connection-property v "touch-t") + (format + "-t %s" + (format-time-string "%Y%m%d%H%M.%S" (tramp-defined-time time) t)) + "") + (if (eq flag 'nofollow) "-h" "") + (tramp-shell-quote-argument localname)))))) (defun tramp-sh-handle-get-home-directory (vec &optional user) "The remote home directory for connection VEC as local file name. @@ -1631,7 +1563,7 @@ ID-FORMAT valid values are `string' and `integer'." (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (tramp-compat-rx + (regexp (rx (group (+ (any "_" alnum))) ":" (group (+ (any "_" alnum))) ":" (group (+ (any "_" alnum))) ":" @@ -1723,7 +1655,7 @@ ID-FORMAT valid values are `string' and `integer'." (if (tramp-file-property-p v localname "file-attributes") (or (tramp-check-cached-permissions v ?x) (tramp-check-cached-permissions v ?s)) - (tramp-run-test "-x" filename))))) + (tramp-run-test v "-x" localname))))) (defun tramp-sh-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -1733,7 +1665,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; satisfied without remote operation. (if (tramp-file-property-p v localname "file-attributes") (tramp-handle-file-readable-p filename) - (tramp-run-test "-r" filename))))) + (tramp-run-test v "-r" localname))))) ;; Functions implemented using the basic functions above. @@ -1744,7 +1676,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; Sometimes, when a connection is not established yet, it is ;; desirable to return t immediately for "/method:foo:". It can ;; be expected that this is always a directory. - (or (zerop (length localname)) + (or (tramp-string-empty-or-nil-p localname) (with-tramp-file-property v localname "file-directory-p" (if-let ((truename (tramp-get-file-property v localname "file-truename")) @@ -1754,7 +1686,7 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-file-property v (tramp-file-local-name truename) "file-attributes")) t) - (tramp-run-test "-d" filename)))))) + (tramp-run-test v "-d" localname)))))) (defun tramp-sh-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -1765,7 +1697,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; Examine `file-attributes' cache to see if request can ;; be satisfied without remote operation. (tramp-check-cached-permissions v ?w) - (tramp-run-test "-w" filename)) + (tramp-run-test v "-w" localname)) ;; If file doesn't exist, check if directory is writable. (and (file-directory-p (file-name-directory filename)) @@ -1839,64 +1771,43 @@ ID-FORMAT valid values are `string' and `integer'." (with-parsed-tramp-file-name (expand-file-name directory) nil (when (and (not (tramp-compat-string-search "/" filename)) (tramp-connectable-p v)) - (all-completions - filename - (with-tramp-file-property v localname "file-name-all-completions" - (let (result) - ;; Get a list of directories and files, including reliably - ;; tagging the directories with a trailing "/". Because I - ;; rock. --daniel@danann.net - (tramp-send-command - v - (if (tramp-get-remote-perl v) - (progn - (tramp-maybe-send-script - v tramp-perl-file-name-all-completions - "tramp_perl_file_name_all_completions") - (format "tramp_perl_file_name_all_completions %s" - (tramp-shell-quote-argument localname))) - - (format (concat - "(cd %s 2>&1 && %s -a 2>%s" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>%s;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command v) - (tramp-get-remote-null-device v) - (tramp-get-test-command v) - (tramp-get-remote-null-device v)))) - - ;; Now grab the output. - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-max)) - - ;; Check result code, found in last line of output. - (forward-line -1) - (if (looking-at-p (rx bol "fail" eol)) - (progn - ;; Grab error message from line before last line - ;; (it was put there by `cd 2>&1'). - (forward-line -1) - (tramp-error - v 'file-error - "tramp-sh-handle-file-name-all-completions: %s" - (buffer-substring (point) (line-end-position)))) - ;; For peace of mind, if buffer doesn't end in `fail' - ;; then it should end in `ok'. If neither are in the - ;; buffer something went seriously wrong on the remote - ;; side. - (unless (looking-at-p (rx bol "ok" eol)) - (tramp-error - v 'file-error - (concat "tramp-sh-handle-file-name-all-completions: " - "internal error accessing `%s': `%s'") - (tramp-shell-quote-argument localname) (buffer-string)))) - - (while (zerop (forward-line -1)) - (push (buffer-substring (point) (line-end-position)) result))) - result)))))) + (unless (tramp-compat-string-search "/" filename) + (ignore-error file-missing + (all-completions + filename + (with-tramp-file-property v localname "file-name-all-completions" + (let (result) + ;; Get a list of directories and files, including + ;; reliably tagging the directories with a trailing "/". + ;; Because I rock. --daniel@danann.net + (when (tramp-send-command-and-check + v + (if (tramp-get-remote-perl v) + (progn + (tramp-maybe-send-script + v tramp-perl-file-name-all-completions + "tramp_perl_file_name_all_completions") + (format "tramp_perl_file_name_all_completions %s" + (tramp-shell-quote-argument localname))) + + (format (concat + "cd %s 2>&1 && %s -a 2>%s" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>%s;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi;" + " done") + (tramp-shell-quote-argument localname) + (tramp-get-ls-command v) + (tramp-get-remote-null-device v) + (tramp-get-test-command v) + (tramp-get-remote-null-device v)))) + + ;; Now grab the output. + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-max)) + (while (zerop (forward-line -1)) + (push (buffer-substring (point) (line-end-position)) result))) + result))))))))) ;; cp, mv and ln @@ -2239,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. @@ -2294,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 @@ -2327,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 @@ -2357,7 +2268,7 @@ The method used must be an out-of-band method." copy-program copy-args copy-env copy-keep-date listener spec options source target remote-copy-program remote-copy-args p) - (if (and v1 v2 (zerop (length (tramp-scp-direct-remote-copying v1 v2)))) + (if (and v1 v2 (string-empty-p (tramp-scp-direct-remote-copying v1 v2))) ;; Both are Tramp files. We cannot use direct remote copying. (let* ((dir-flag (file-directory-p filename)) @@ -2389,10 +2300,10 @@ The method used must be an out-of-band method." #'identity) (if v1 (tramp-make-copy-program-file-name v1) - (tramp-compat-file-name-unquote filename))) + (file-name-unquote filename))) target (if v2 (tramp-make-copy-program-file-name v2) - (tramp-compat-file-name-unquote newname))) + (file-name-unquote newname))) ;; Check for listener port. (when (tramp-get-method-parameter v 'tramp-remote-copy-args) @@ -2436,7 +2347,7 @@ The method used must be an out-of-band method." ;; `tramp-ssh-controlmaster-options' is a string instead ;; of a list. Unflatten it. copy-args - (tramp-compat-flatten-tree + (flatten-tree (mapcar (lambda (x) (if (tramp-compat-string-search " " x) (split-string x) x)) @@ -2463,8 +2374,7 @@ The method used must be an out-of-band method." v 'file-error "Cannot find remote listener: %s" remote-copy-program)) (setq remote-copy-program - (mapconcat - #'identity + (string-join (append (list remote-copy-program) remote-copy-args (list (if v1 (concat "<" source) (concat ">" target)) "&")) @@ -2517,7 +2427,11 @@ The method used must be an out-of-band method." (tramp-get-connection-buffer v) copy-program copy-args))) (tramp-message v 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector v) + (process-put p 'tramp-vector v) + ;; This is neded for ssh or PuTTY based processes, and + ;; only if the respective options are set. Perhaps, + ;; the setting could be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) @@ -2557,19 +2471,10 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole cache. - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))) + (tramp-skeleton-make-directory dir parents (tramp-barf-unless-okay v (format "%s -m %#o %s" - (if parents "mkdir -p" "mkdir") - (default-file-modes) + "mkdir" (default-file-modes) (tramp-shell-quote-argument localname)) "Couldn't make directory %s" dir))) @@ -2584,14 +2489,10 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (setq filename (expand-file-name (expand-file-name filename))) - (with-parsed-tramp-file-name filename nil - (if (and delete-by-moving-to-trash trash) - (move-file-to-trash filename) - (tramp-barf-unless-okay - v (format "rm -f %s" (tramp-shell-quote-argument localname)) - "Couldn't delete %s" filename)) - (tramp-flush-file-properties v localname))) + (tramp-skeleton-delete-file filename trash + (tramp-barf-unless-okay + v (format "rm -f %s" (tramp-shell-quote-argument localname)) + "Couldn't delete %s" filename))) ;; Dired. @@ -2705,9 +2606,9 @@ The method used must be an out-of-band method." (tramp-get-ls-command v) switches (if (or wildcard - (zerop (length - (tramp-run-real-handler - #'file-name-nondirectory (list localname))))) + (tramp-string-empty-or-nil-p + (tramp-run-real-handler + #'file-name-nondirectory (list localname)))) "" (tramp-shell-quote-argument (tramp-run-real-handler @@ -2824,14 +2725,14 @@ the result will be a local, non-Tramp, file name." ;; If DIR is not given, use `default-directory' or "/". (setq dir (or dir default-directory "/")) ;; Handle empty NAME. - (when (zerop (length name)) (setq name ".")) + (when (string-empty-p name) + (setq name ".")) ;; On MS Windows, some special file names are not returned properly ;; by `file-name-absolute-p'. If `tramp-syntax' is `simplified', ;; there could be the false positive "/:". (if (or (and (eq system-type 'windows-nt) (string-match-p - (tramp-compat-rx bol (| (: alpha ":") (: (literal null-device) eol))) - name)) + (rx bol (| (: alpha ":") (: (literal null-device) eol))) name)) (and (not (tramp-tramp-file-p name)) (not (tramp-tramp-file-p dir)))) (tramp-run-real-handler #'expand-file-name (list name dir)) @@ -2850,9 +2751,7 @@ the result will be a local, non-Tramp, file name." ;; supposed to find such a shell on the remote host. Please ;; tell me about it when this doesn't work on your system. (when (string-match - (tramp-compat-rx - bos "~" (group (* (not "/"))) (group (* nonl)) eos) - localname) + (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) hname) @@ -2862,7 +2761,7 @@ the result will be a local, non-Tramp, file name." ;; the default user name for tilde expansion is not ;; appropriate either, because ssh and companions might ;; use a user name from the config file. - (when (and (zerop (length uname)) + (when (and (tramp-string-empty-or-nil-p uname) (string-match-p (rx bos "su" (? "do") eos) method)) (setq uname user)) (when (setq hname (tramp-get-home-directory v uname)) @@ -2963,7 +2862,7 @@ implementation will be used." (heredoc (and (not (bufferp stderr)) (stringp program) (string-match-p (rx "sh" eol) program) - (= (length args) 2) + (tramp-compat-length= args 2) (string-equal "-c" (car args)) ;; Don't if there is a quoted string. (not @@ -2973,7 +2872,7 @@ implementation will be used." ;; When PROGRAM is nil, we just provide a tty. (args (if (not heredoc) args (let ((i 250)) - (while (and (< i (length (cadr args))) + (while (and (not (tramp-compat-length< (cadr args) i)) (string-match " " (cadr args) i)) (setcdr args @@ -3089,13 +2988,20 @@ implementation will be used." (process-put p 'remote-pid pid) (tramp-set-connection-property p "remote-pid" pid)) - ;; Disable carriage return to newline - ;; translation. This does not work on - ;; macOS, see Bug#50748. - (when (and (memq connection-type '(nil pipe)) - (not - (tramp-check-remote-uname v "Darwin"))) - (tramp-send-command v "stty -icrnl")) + (when (memq connection-type '(nil pipe)) + ;; Disable carriage return to newline + ;; translation. This does not work on + ;; macOS, see Bug#50748. + ;; We must also disable buffering, + ;; otherwise strings larger than 4096 + ;; bytes, sent by the process, could + ;; block, see termios(3) and Bug#61341. + ;; FIXME: Shall we rather use "stty raw"? + (if (tramp-check-remote-uname v "Darwin") + (tramp-send-command + v "stty -icanon min 1 time 0") + (tramp-send-command + v "stty -icrnl -icanon min 1 time 0"))) ;; `tramp-maybe-open-connection' and ;; `tramp-send-command-and-read' could ;; have trashed the connection buffer. @@ -3196,8 +3102,7 @@ implementation will be used." (format "%s %s %s" (tramp-get-method-parameter vec 'tramp-remote-shell) - (mapconcat - #'identity + (string-join (tramp-get-method-parameter vec 'tramp-remote-shell-args) " ") (tramp-shell-quote-argument (format "kill -%d $$" i)))) @@ -3244,7 +3149,7 @@ implementation will be used." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) + (setq infile (file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-unquote-file-local-name infile)) @@ -3855,16 +3760,20 @@ Fall back to normal file name handler if no Tramp handler exists." "`%s' failed to start on remote host" (string-join sequence " ")) (tramp-message v 6 "Run `%s', %S" (string-join sequence " ") p) - (process-put p 'vector v) + (process-put p 'tramp-vector v) + ;; This is neded for ssh or PuTTY based processes, and only if + ;; the respective options are set. Perhaps, the setting could + ;; be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) ;; Needed for process filter. - (process-put p 'events events) - (process-put p 'watch-name localname) + (process-put p 'tramp-events events) + (process-put p 'tramp-watch-name localname) (set-process-query-on-exit-flag p nil) (set-process-filter p filter) (set-process-sentinel p #'tramp-file-notify-process-sentinel) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. - (while (tramp-accept-process-output p 0)) + (while (tramp-accept-process-output p)) (unless (process-live-p p) (tramp-error p 'file-notify-error "Monitoring not supported for `%s'" file-name)) @@ -3872,10 +3781,10 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-sh-gio-monitor-process-filter (proc string) "Read output from \"gio monitor\" and add corresponding `file-notify' events." - (let ((events (process-get proc 'events)) + (let ((events (process-get proc 'tramp-events)) (remote-prefix (file-remote-p (tramp-get-default-directory (process-buffer proc)))) - (rest-string (process-get proc 'rest-string)) + (rest-string (process-get proc 'tramp-rest-string)) pos) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) @@ -3925,7 +3834,7 @@ Fall back to normal file name handler if no Tramp handler exists." (setq string (tramp-compat-string-replace "\n\n" "\n" string)) (while (string-match - (tramp-compat-rx + (rx bol (+ (not ":")) ":" blank (group (+ (not ":"))) ":" blank (group (regexp (regexp-opt tramp-gio-events))) @@ -3955,15 +3864,15 @@ Fall back to normal file name handler if no Tramp handler exists." ;; Save rest of the string. (while (string-match (rx bol "\n") string) (setq string (replace-match "" nil nil string))) - (when (zerop (length string)) (setq string nil)) + (when (string-empty-p string) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) - (process-put proc 'rest-string string))) + (process-put proc 'tramp-rest-string string))) (defun tramp-sh-inotifywait-process-filter (proc string) "Read output from \"inotifywait\" and add corresponding `file-notify' events." - (let ((events (process-get proc 'events))) + (let ((events (process-get proc 'tramp-events))) (tramp-message proc 6 "%S\n%s" proc string) - (dolist (line (split-string string "[\n\r]+" 'omit)) + (dolist (line (split-string string (rx (+ (any "\r\n"))) 'omit)) ;; Check, whether there is a problem. (unless (string-match (rx bol (+ (not blank)) (+ blank) (group (+ (not blank))) @@ -3980,7 +3889,8 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-compat-string-replace "_" "-" (downcase x)))) (split-string (match-string 1 line) "," 'omit)) (or (match-string 2 line) - (file-name-nondirectory (process-get proc 'watch-name)))))) + (file-name-nondirectory + (process-get proc 'tramp-watch-name)))))) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the handler directly. @@ -4028,66 +3938,55 @@ commands. \"%n\" is replaced by \"2>/dev/null\", and \"%t\" is replaced by a temporary file name. If VEC is nil, the respective local commands are used. If there is a format specifier which cannot be expanded, this function returns nil." - (if (not (string-match-p - (tramp-compat-rx (| bol (not "%")) "%" (any "ahlnoprsty")) script)) + (if (not (string-match-p (rx (| bol (not "%")) "%" (any "ahlnoprsty")) script)) script (catch 'wont-work - (let ((awk (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%a") script) + (let ((awk (when (string-match-p (rx (| bol (not "%")) "%a") script) (or (if vec (tramp-get-remote-awk vec) (executable-find "awk")) (throw 'wont-work nil)))) - (hdmp (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%h") script) + (hdmp (when (string-match-p (rx (| bol (not "%")) "%h") script) (or (if vec (tramp-get-remote-hexdump vec) (executable-find "hexdump")) (throw 'wont-work nil)))) - (dev (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%n") script) + (dev (when (string-match-p (rx (| bol (not "%")) "%n") script) (or (if vec (concat "2>" (tramp-get-remote-null-device vec)) (if (eq system-type 'windows-nt) "" (concat "2>" null-device))) (throw 'wont-work nil)))) - (ls (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%l") script) + (ls (when (string-match-p (rx (| bol (not "%")) "%l") script) (format "%s %s" (or (tramp-get-ls-command vec) (throw 'wont-work nil)) (tramp-sh--quoting-style-options vec)))) - (od (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%o") script) + (od (when (string-match-p (rx (| bol (not "%")) "%o") script) (or (if vec (tramp-get-remote-od vec) (executable-find "od")) (throw 'wont-work nil)))) - (perl (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%p") script) + (perl (when (string-match-p (rx (| bol (not "%")) "%p") script) (or (if vec (tramp-get-remote-perl vec) (executable-find "perl")) (throw 'wont-work nil)))) - (python (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%y") script) - (or - (if vec - (tramp-get-remote-python vec) - (executable-find "python")) - (throw 'wont-work nil)))) - (readlink (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%r") script) + (python (when (string-match-p (rx (| bol (not "%")) "%y") script) + (or + (if vec + (tramp-get-remote-python vec) + (executable-find "python")) + (throw 'wont-work nil)))) + (readlink (when (string-match-p (rx (| bol (not "%")) "%r") script) (or (if vec - (tramp-get-remote-readlink vec) - (executable-find "readlink")) - (throw 'wont-work nil)))) - (stat (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%s") script) + (tramp-get-remote-readlink vec) + (executable-find "readlink")) + (throw 'wont-work nil)))) + (stat (when (string-match-p (rx (| bol (not "%")) "%s") script) (or (if vec (tramp-get-remote-stat vec) (executable-find "stat")) (throw 'wont-work nil)))) - (tmp (when (string-match-p - (tramp-compat-rx (| bol (not "%")) "%t") script) + (tmp (when (string-match-p (rx (| bol (not "%")) "%t") script) (or (if vec (tramp-file-local-name (tramp-make-tramp-temp-name vec)) @@ -4126,17 +4025,14 @@ Only send the definition if it has not already been done." (tramp-set-connection-property (tramp-get-connection-process vec) "scripts" (cons name scripts)))))) -(defun tramp-run-test (switch filename) - "Run `test' on the remote system, given a SWITCH and a FILENAME. +(defun tramp-run-test (vec switch localname) + "Run `test' on the remote system VEC, given a SWITCH and a LOCALNAME. Returns the exit code of the `test' program." - (with-parsed-tramp-file-name filename nil - (tramp-send-command-and-check - v - (format - "%s %s %s" - (tramp-get-test-command v) - switch - (tramp-shell-quote-argument localname))))) + (tramp-send-command-and-check + vec + (format + "%s %s %s" + (tramp-get-test-command vec) switch (tramp-shell-quote-argument localname)))) (defun tramp-find-executable (vec progname dirlist &optional ignore-tilde ignore-path) @@ -4211,7 +4107,7 @@ variable PATH." 'noerror))) tmpfile chunk chunksize) (tramp-message vec 5 "Setting $PATH environment variable") - (if (< (length command) pipe-buf) + (if (tramp-compat-length< command pipe-buf) (tramp-send-command vec command) ;; Use a temporary file. We cannot use `write-region' because ;; setting the remote path happens in the early connection @@ -4348,8 +4244,7 @@ file exists and nonzero exit status otherwise." "Couldn't find remote shell prompt for %s" shell) (unless (tramp-check-for-regexp - (tramp-get-connection-process vec) - (tramp-compat-rx (literal tramp-end-of-output))) + (tramp-get-connection-process vec) (rx (literal tramp-end-of-output))) (tramp-wait-for-output (tramp-get-connection-process vec)) (tramp-message vec 5 "Setting shell prompt") (tramp-send-command @@ -4390,8 +4285,7 @@ file exists and nonzero exit status otherwise." (tramp-send-command vec (format "echo ~%s" tramp-root-id-string) t) (if (or (string-match-p - (tramp-compat-rx - bol "~" (literal tramp-root-id-string) eol) + (rx bol "~" (literal tramp-root-id-string) eol) (buffer-string)) ;; The default shell (ksh93) of OpenSolaris ;; and Solaris is buggy. We've got reports @@ -4426,11 +4320,11 @@ file exists and nonzero exit status otherwise." "Wait for shell prompt and barf if none appears. Looks at process PROC to see if a shell prompt appears in TIMEOUT seconds. If not, it produces an error message with the given ERROR-ARGS." - (let ((vec (process-get proc 'vector))) + (let ((vec (process-get proc 'tramp-vector))) (condition-case nil (tramp-wait-for-regexp proc timeout - (tramp-compat-rx + (rx (| (regexp shell-prompt-pattern) (regexp tramp-shell-prompt-pattern)) eos)) (error @@ -4602,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 (zerop (length tty)) + (unless (tramp-string-empty-or-nil-p tty) (process-put proc 'remote-tty tty) (tramp-set-connection-property proc "remote-tty" tty))) @@ -4817,7 +4711,7 @@ Goes through the list `tramp-local-coding-commands' and (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (unless (looking-at-p (tramp-compat-rx (literal magic))) + (unless (looking-at-p (rx (literal magic))) (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. @@ -4903,7 +4797,7 @@ Goes through the list `tramp-inline-compress-commands'." nil t)) (throw 'next nil)) (goto-char (point-min)) - (unless (looking-at-p (tramp-compat-rx (literal magic))) + (unless (looking-at-p (rx (literal magic))) (throw 'next nil))) (tramp-message vec 5 @@ -4914,7 +4808,7 @@ Goes through the list `tramp-inline-compress-commands'." (throw 'next nil)) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (unless (looking-at-p (tramp-compat-rx (literal magic))) + (unless (looking-at-p (rx (literal magic))) (throw 'next nil))) (setq found t))) @@ -4936,49 +4830,55 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) +(defun tramp-ssh-option-exists-p (vec option) + "Check, whether local ssh OPTION is applicable." + ;; We don't want to cache it persistently. + (with-tramp-connection-property nil option + ;; We use a non-existing IP address for check, in order to avoid + ;; useless connections, and DNS timeouts. + (zerop + (tramp-call-process vec "ssh" nil nil nil "-G" "-o" option "0.0.0.1")))) + (defun tramp-ssh-controlmaster-options (vec) "Return the Control* arguments of the local ssh." (cond ;; No options to be computed. - ((or (null tramp-use-ssh-controlmaster-options) + ((or (null tramp-use-connection-share) (null (assoc "%c" (tramp-get-method-parameter vec 'tramp-login-args)))) "") + ;; Use plink option. + ((string-match-p + (rx "plink" (? ".exe") eol) + (tramp-get-method-parameter vec 'tramp-login-program)) + (if (eq tramp-use-connection-share 'suppress) + "-noshare" "-share")) + ;; There is already a value to be used. - ((stringp tramp-ssh-controlmaster-options) tramp-ssh-controlmaster-options) + ((and (eq tramp-use-connection-share t) + (stringp tramp-ssh-controlmaster-options)) + tramp-ssh-controlmaster-options) ;; Determine the options. - (t (setq tramp-ssh-controlmaster-options "") - (let ((case-fold-search t)) - (ignore-errors - (with-tramp-progress-reporter - vec 4 "Computing ControlMaster options" - ;; We use a non-existing IP address, in order to avoid - ;; useless connections, and DNS timeouts. - (when (zerop - (tramp-call-process - vec "ssh" nil nil nil - "-G" "-o" "ControlMaster=auto" "0.0.0.1")) - (setq tramp-ssh-controlmaster-options - "-o ControlMaster=auto") - (if (zerop - (tramp-call-process - vec "ssh" nil nil nil - "-G" "-o" "ControlPath=tramp.%C" "0.0.0.1")) - (setq tramp-ssh-controlmaster-options - (concat tramp-ssh-controlmaster-options - " -o ControlPath=tramp.%%C")) - (setq tramp-ssh-controlmaster-options - (concat tramp-ssh-controlmaster-options - " -o ControlPath=tramp.%%r@%%h:%%p"))) - (when (zerop - (tramp-call-process - vec "ssh" nil nil nil - "-G" "-o" "ControlPersist=no" "0.0.0.1")) - (setq tramp-ssh-controlmaster-options - (concat tramp-ssh-controlmaster-options - " -o ControlPersist=no"))))))) - tramp-ssh-controlmaster-options))) + (t (ignore-errors + ;; ControlMaster and ControlPath options are introduced in OpenSSH 3.9. + (when (tramp-ssh-option-exists-p vec "ControlMaster=auto") + (concat + "-o ControlMaster=" + (if (eq tramp-use-connection-share 'suppress) + "no" "auto") + + " -o ControlPath=" + (if (eq tramp-use-connection-share 'suppress) + "none" + ;; Hashed tokens are introduced in OpenSSH 6.7. + (if (tramp-ssh-option-exists-p vec "ControlPath=tramp.%C") + "tramp.%%C" "tramp.%%r@%%h:%%p")) + + ;; ControlPersist option is introduced in OpenSSH 5.6. + (when (and (not (eq tramp-use-connection-share 'suppress)) + (tramp-ssh-option-exists-p vec "ControlPersist=no")) + " -o ControlPersist=no"))))))) (defun tramp-scp-strict-file-name-checking (vec) "Return the strict file name checking argument of the local scp." @@ -5063,7 +4963,7 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-call-process vec1 tramp-encoding-shell nil t nil tramp-encoding-command-switch - (mapconcat #'identity command " ")) + (string-join command " ")) (goto-char (point-min)) (not (search-forward "remotecommand" nil 'noerror))))) @@ -5082,11 +4982,11 @@ Goes through the list `tramp-inline-compress-commands'." found string) (with-temp-buffer ;; Check hostkey of VEC2, seen from VEC1. - (tramp-send-command vec1 (mapconcat #'identity command " ")) + (tramp-send-command vec1 (string-join command " ")) ;; Check hostkey of VEC2, seen locally. (tramp-call-process vec1 tramp-encoding-shell nil t nil tramp-encoding-command-switch - (mapconcat #'identity command " ")) + (string-join command " ")) (goto-char (point-min)) (while (and (not found) (not (eobp))) (setq string @@ -5175,7 +5075,7 @@ connection if a previous connection has died for some reason." (unless (process-live-p p) (with-tramp-progress-reporter vec 3 - (if (zerop (length (tramp-file-name-user vec))) + (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec)) (format "Opening connection %s for %s using %s" process-name (tramp-file-name-host vec) @@ -5232,7 +5132,11 @@ connection if a previous connection has died for some reason." ;; Set sentinel and query flag. Initialize variables. (set-process-sentinel p #'tramp-process-sentinel) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) + ;; This is neded for ssh or PuTTY based processes, and + ;; only if the respective options are set. Perhaps, + ;; the setting could be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) (setq tramp-current-connection (cons vec (current-time))) @@ -5259,7 +5163,7 @@ connection if a previous connection has died for some reason." (tramp-get-method-parameter hop 'tramp-remote-shell)) (extra-args (tramp-get-sh-extra-args remote-shell)) (async-args - (tramp-compat-flatten-tree + (flatten-tree (tramp-get-method-parameter hop 'tramp-async-args))) (connection-timeout (tramp-get-method-parameter @@ -5310,8 +5214,7 @@ connection if a previous connection has died for some reason." ;; Replace `login-args' place holders. (setq command - (mapconcat - #'identity + (string-join (append ;; We do not want to see the trailing local ;; prompt in `start-file-process'. @@ -5403,7 +5306,7 @@ function waits for output unless NOOUTPUT is set." ;; Busyboxes built with the EDITING_ASK_TERMINAL config ;; option send also escape sequences, which must be ;; ignored. - (regexp (tramp-compat-rx + (regexp (rx (* (not (any "#$\n"))) (literal tramp-end-of-output) (? (regexp tramp-device-escape-sequence-regexp)) @@ -5411,7 +5314,7 @@ function waits for output unless NOOUTPUT is set." ;; Sometimes, the commands do not return a newline but a ;; null byte before the shell prompt, for example "git ;; ls-files -c -z ...". - (regexp1 (tramp-compat-rx (| bol "\000") (regexp regexp))) + (regexp1 (rx (| bol "\000") (regexp regexp))) (found (tramp-wait-for-regexp proc timeout regexp1))) (if found (let ((inhibit-read-only t)) @@ -5451,8 +5354,7 @@ the exit status." (let (cmd data) (if (and (stringp command) (string-match - (tramp-compat-rx - (* nonl) "<<'" (literal tramp-end-of-heredoc) "'" (* nonl)) + (rx (* nonl) "<<'" (literal tramp-end-of-heredoc) "'" (* nonl)) command)) (setq cmd (match-string 0 command) data (substring command (match-end 0))) @@ -5549,7 +5451,7 @@ raises an error." (cond ((tramp-get-method-parameter vec 'tramp-remote-copy-program) localname) - ((zerop (length user)) (format "%s:%s" host localname)) + ((tramp-string-empty-or-nil-p user) (format "%s:%s" host localname)) (t (format "%s@%s:%s" user host localname))))) (defun tramp-method-out-of-band-p (vec size) @@ -5613,16 +5515,14 @@ Nonexistent directories are removed from spec." (format "%s %s %s 'echo %s \\\"$PATH\\\"'" (tramp-get-method-parameter vec 'tramp-remote-shell) - (mapconcat - #'identity + (string-join (tramp-get-method-parameter vec 'tramp-remote-shell-login) " ") - (mapconcat - #'identity + (string-join (tramp-get-method-parameter vec 'tramp-remote-shell-args) " ") (tramp-shell-quote-argument tramp-end-of-heredoc)) - 'noerror (tramp-compat-rx (literal tramp-end-of-heredoc))) + 'noerror (rx (literal tramp-end-of-heredoc))) (progn (tramp-message vec 2 "Could not retrieve `tramp-own-remote-path'") @@ -5672,8 +5572,7 @@ Nonexistent directories are removed from spec." (while candidates (goto-char (point-min)) (if (string-match-p - (tramp-compat-rx bol (literal (car candidates)) (? "\r") eol) - (buffer-string)) + (rx bol (literal (car candidates)) (? "\r") eol) (buffer-string)) (setq locale (car candidates) candidates nil) (setq candidates (cdr candidates))))) @@ -5751,7 +5650,7 @@ Nonexistent directories are removed from spec." vec (format "( %s / -nt / )" (tramp-get-test-command vec))) (with-current-buffer (tramp-get-buffer vec) (goto-char (point-min)) - (when (looking-at-p (tramp-compat-rx (literal tramp-end-of-output))) + (when (looking-at-p (rx (literal tramp-end-of-output))) (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) (progn (tramp-send-command @@ -5834,14 +5733,6 @@ Nonexistent directories are removed from spec." vec (format "%s --canonicalize-missing /" result))) result)))) -(defun tramp-get-remote-trash (vec) - "Determine remote `trash' command. -This command is returned only if `delete-by-moving-to-trash' is non-nil." - (and delete-by-moving-to-trash - (with-tramp-connection-property vec "trash" - (tramp-message vec 5 "Finding a suitable `trash' command") - (tramp-find-executable vec "trash" (tramp-get-remote-path vec))))) - (defun tramp-get-remote-touch (vec) "Determine remote `touch' command." (with-tramp-connection-property vec "touch" diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index cad6cb335cc..13d5e17a9ff 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -53,7 +53,7 @@ ;;;###tramp-autoload (tramp--with-startup (add-to-list 'tramp-default-user-alist - `(,(tramp-compat-rx bos (literal tramp-smb-method) eos) nil nil)) + `(,(rx bos (literal tramp-smb-method) eos) nil nil)) ;; Add completion function for SMB method. (tramp-set-completion-function @@ -92,9 +92,9 @@ this variable \"client min protocol=NT1\"." "Version string of the SMB client.") (defconst tramp-smb-server-version - (tramp-compat-rx "Domain=[" (* (not "]")) "] " - "OS=[" (* (not "]")) "] " - "Server=[" (* (not "]")) "]") + (rx "Domain=[" (* (not "]")) "] " + "OS=[" (* (not "]")) "] " + "Server=[" (* (not "]")) "]") "Regexp of SMB server identification.") (defconst tramp-smb-prompt @@ -269,6 +269,7 @@ See `tramp-actions-before-shell' for more info.") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-smb-handle-file-system-info) (file-truename . tramp-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-smb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -487,9 +488,9 @@ arguments to pass to the OPERATION." (args (list (concat "//" host "/" share) "-E")) (options tramp-smb-options)) - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) + (if (tramp-string-empty-or-nil-p user) + (setq args (append args (list "-N"))) + (setq args (append args (list "-U" user)))) (when domain (setq args (append args (list "-W" domain)))) (when port (setq args (append args (list "-p" port)))) @@ -558,7 +559,7 @@ arguments to pass to the OPERATION." (tramp-message v 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector v) + (process-put p 'tramp-vector v) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) @@ -691,35 +692,29 @@ 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." - (setq filename (expand-file-name filename)) - (when (file-exists-p filename) - (with-parsed-tramp-file-name filename nil - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - (if (and delete-by-moving-to-trash trash) - (move-file-to-trash filename) - (unless (tramp-smb-send-command - v (format - "%s %s" - (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm") - (tramp-smb-shell-quote-localname v))) - ;; Error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (search-forward-regexp tramp-smb-errors nil t) - (tramp-error v 'file-error "%s `%s'" (match-string 0) filename))))))) + (tramp-skeleton-delete-file filename trash + (unless (tramp-smb-send-command + v (format + "%s %s" + (if (tramp-smb-get-cifs-capabilities v) "posix_unlink" "rm") + (tramp-smb-shell-quote-localname v))) + ;; Error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (search-forward-regexp tramp-smb-errors nil t) + (tramp-error v 'file-error "%s `%s'" (match-string 0) filename))))) (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (setq dir (or dir default-directory "/")) ;; Handle empty NAME. - (when (zerop (length name)) (setq name ".")) + (when (string-empty-p name) + (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) @@ -730,12 +725,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name name nil ;; Tilde expansion if necessary. (when (string-match - (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) - localname) + (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) hname) - (when (zerop (length uname)) + (when (tramp-string-empty-or-nil-p uname) (setq uname user)) (when (setq hname (tramp-get-home-directory v uname)) (setq localname (concat hname fname))))) @@ -789,9 +783,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (args (list (concat "//" host "/" share) "-E")) (options tramp-smb-options)) - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) + (if (tramp-string-empty-or-nil-p user) + (setq args (append args (list "-N"))) + (setq args (append args (list "-U" user)))) (when domain (setq args (append args (list "-W" domain)))) (when port (setq args (append args (list "-p" port)))) @@ -806,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 '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." @@ -982,18 +975,20 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; files. (defun tramp-smb-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (delete-dups - (mapcar - (lambda (x) - (list - (if (tramp-compat-string-search "d" (nth 1 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - (tramp-smb-get-file-entries directory))))))) + (ignore-error file-missing + (all-completions + filename + (when (file-directory-p directory) + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (delete-dups + (mapcar + (lambda (x) + (list + (if (tramp-compat-string-search "d" (nth 1 x)) + (file-name-as-directory (nth 0 x)) + (nth 0 x)))) + (tramp-smb-get-file-entries directory))))))))) (defun tramp-smb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -1079,12 +1074,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq entries (delq nil - (if (or wildcard (zerop (length base))) + (if (or wildcard (string-empty-p base)) ;; Check for matching entries. (mapcar (lambda (x) - (when (string-match-p - (tramp-compat-rx bol (literal base)) (nth 0 x)) + (when (string-match-p (rx bol (literal base)) (nth 0 x)) x)) entries) ;; We just need the only and only entry FILENAME. @@ -1105,7 +1099,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (tramp-compat-string-search "F" switches) (mapc (lambda (x) - (unless (zerop (length (car x))) + (unless (string-empty-p (car x)) (cond ((char-equal ?d (string-to-char (nth 1 x))) (setcar x (concat (car x) "/"))) @@ -1125,7 +1119,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Print entries. (mapc (lambda (x) - (unless (zerop (length (nth 0 x))) + (unless (string-empty-p (nth 0 x)) (let ((attr (when (tramp-smb-get-stat-capability v) (ignore-errors @@ -1172,98 +1166,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (directory-file-name (expand-file-name dir))) - (unless (file-name-absolute-p dir) - (setq dir (expand-file-name dir default-directory))) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists dir)) - (let* ((ldir (file-name-directory dir))) - ;; Make missing directory parts. - (when (and parents - (tramp-smb-get-share v) - (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it. - (when (file-directory-p ldir) - (tramp-smb-send-command - v (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir %s %o" - (tramp-smb-shell-quote-localname v) (default-file-modes)) - (format "mkdir %s" (tramp-smb-shell-quote-localname v)))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir))))) - -;; This is not used anymore. -(defun tramp-smb-handle-make-directory-internal (directory) - "Like `make-directory-internal' for Tramp files." - (declare (obsolete nil "29.1")) - (setq directory (directory-file-name (expand-file-name directory))) - (unless (file-name-absolute-p directory) - (setq directory (expand-file-name directory default-directory))) - (with-parsed-tramp-file-name directory nil - (when (file-directory-p (file-name-directory directory)) - (tramp-smb-send-command - v (if (tramp-smb-get-cifs-capabilities v) - (format "posix_mkdir %s %o" - (tramp-smb-shell-quote-localname v) (default-file-modes)) - (format "mkdir %s" (tramp-smb-shell-quote-localname v)))) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname)) - (unless (file-directory-p directory) - (tramp-error v 'file-error "Couldn't make directory %s" directory)))) + (tramp-skeleton-make-directory dir parents + (tramp-smb-send-command + v (if (tramp-smb-get-cifs-capabilities v) + (format "posix_mkdir %s %o" + (tramp-smb-shell-quote-localname v) (default-file-modes)) + (format "mkdir %s" (tramp-smb-shell-quote-localname v)))) + (unless (file-directory-p dir) + (tramp-error v 'file-error "Couldn't make directory %s" dir)))) (defun tramp-smb-handle-make-symbolic-link - (target linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If TARGET is a non-Tramp file, it is used verbatim as the target -of the symlink. If TARGET is a Tramp file, only the localname -component is used as the target of the symlink." - (with-parsed-tramp-file-name linkname nil - ;; If TARGET is a Tramp name, use just the localname component. - ;; Don't check for a proper method. - (let ((non-essential t)) - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target))))) - - ;; If TARGET is still remote, quote it. - (if (tramp-tramp-file-p target) - (make-symbolic-link - (tramp-compat-file-name-quote target 'top) - linkname ok-if-already-exists) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway?" - localname))))) - (tramp-error v 'file-already-exists localname) - (delete-file linkname))) - - (unless (tramp-smb-get-cifs-capabilities v) - (tramp-error v 'file-error "make-symbolic-link not supported")) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - - (unless (tramp-smb-send-command - v (format "symlink %s %s" - (tramp-smb-shell-quote-argument target) - (tramp-smb-shell-quote-localname v))) - (tramp-error - v 'file-error - "error with make-symbolic-link, see buffer `%s' for details" - (tramp-get-connection-buffer v)))))) + (target linkname &optional ok-if-already-exists) + "Like `make-symbolic-link' for Tramp files." + (let ((v (tramp-dissect-file-name (expand-file-name linkname)))) + (unless (tramp-smb-get-cifs-capabilities v) + (tramp-error v 'file-error "make-symbolic-link not supported"))) + + (tramp-skeleton-handle-make-symbolic-link target linkname ok-if-already-exists + (unless (tramp-smb-send-command + v (format "symlink %s %s" + (tramp-smb-shell-quote-argument target) + (tramp-smb-shell-quote-localname v))) + (tramp-error + v 'file-error + "error with make-symbolic-link, see buffer `%s' for details" + (tramp-get-connection-buffer v))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) @@ -1280,7 +1207,7 @@ component is used as the target of the symlink." ;; Determine input. (when infile - (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) + (setq infile (file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-unquote-file-local-name infile)) @@ -1455,9 +1382,9 @@ component is used as the target of the symlink." "\n" "," acl-string))) (options tramp-smb-options)) - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) + (if (tramp-string-empty-or-nil-p user) + (setq args (append args (list "-N"))) + (setq args (append args (list "-U" user)))) (when domain (setq args (append args (list "-W" domain)))) (when port (setq args (append args (list "-p" port)))) @@ -1473,44 +1400,43 @@ component is used as the target of the symlink." "&&" "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 '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." @@ -1588,7 +1514,7 @@ component is used as the target of the symlink." \"//\" substitutes only in the local filename part. Catches errors for shares like \"C$/\", which are common in Microsoft Windows." ;; Check, whether the local part is a quoted file name. - (if (tramp-compat-file-name-quoted-p filename) + (if (file-name-quoted-p filename) filename (with-parsed-tramp-file-name filename nil ;; Ignore in LOCALNAME everything before "//". @@ -1607,7 +1533,7 @@ If USER is a string, return its home directory instead of the user identified by VEC. If there is no user specified in either VEC or USER, or if there is no home directory, return nil." (let ((user (or user (tramp-file-name-user vec)))) - (unless (zerop (length user)) + (unless (tramp-string-empty-or-nil-p user) (concat "/" user)))) (defun tramp-smb-handle-write-region @@ -1639,8 +1565,7 @@ VEC or USER, or if there is no home directory, return nil." "Return the share name of LOCALNAME." (save-match-data (let ((localname (tramp-file-name-unquote-localname vec))) - (when (string-match - (tramp-compat-rx bol (? "/") (group (+ (not "/"))) "/") localname) + (when (string-match (rx bol (? "/") (group (+ (not "/"))) "/") localname) (match-string 1 localname))))) (defun tramp-smb-get-localname (vec) @@ -1651,8 +1576,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (setq localname (if (string-match - (tramp-compat-rx bol (? "/") (+ (not "/")) (group "/" (* nonl))) - localname) + (rx bol (? "/") (+ (not "/")) (group "/" (* nonl))) localname) ;; There is a share, separated by "/". (if (not (tramp-smb-get-cifs-capabilities vec)) (mapconcat @@ -1660,8 +1584,7 @@ If VEC has no cifs capabilities, exchange \"/\" by \"\\\\\"." (match-string 1 localname) "") (match-string 1 localname)) ;; There is just a share. - (if (string-match - (tramp-compat-rx bol (? "/") (group (+ (not "/"))) eol) localname) + (if (string-match (rx bol (? "/") (group (+ (not "/"))) eol) localname) (match-string 1 localname) ""))) @@ -1789,8 +1712,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (if (not share) ;; Read share entries. - (when (string-match - (tramp-compat-rx bol "Disk|" (group (+ (not "|"))) "|") line) + (when (string-match (rx bol "Disk|" (group (+ (not "|"))) "|") line) (setq localname (match-string 1 line) mode "dr-xr-xr-x" size 0)) @@ -1956,7 +1878,7 @@ If ARGUMENT is non-nil, use it as argument for (setq tramp-smb-version (shell-command-to-string command)) (tramp-message vec 6 command) (tramp-message vec 6 "\n%s" tramp-smb-version) - (if (string-match (rx (+ (any " \t\n\r")) eos) tramp-smb-version) + (if (string-match (rx (+ (any " \t\r\n")) eos) tramp-smb-version) (setq tramp-smb-version (replace-match "" nil nil tramp-smb-version)))) @@ -2009,9 +1931,9 @@ If ARGUMENT is non-nil, use it as argument for (t (setq args (list "-g" "-L" host )))) - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) + (if (tramp-string-empty-or-nil-p user) + (setq args (append args (list "-N"))) + (setq args (append args (list "-U" user)))) (when domain (setq args (append args (list "-W" domain)))) (when port (setq args (append args (list "-p" port)))) @@ -2026,7 +1948,8 @@ If ARGUMENT is non-nil, use it as argument for (with-tramp-progress-reporter vec 3 (format "Opening connection for //%s%s/%s" - (if (not (zerop (length user))) (concat user "@") "") + (if (tramp-string-empty-or-nil-p user) + "" (concat user "@")) host (or share "")) (let* (coding-system-for-read @@ -2044,7 +1967,7 @@ If ARGUMENT is non-nil, use it as argument for args)))) (tramp-message vec 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) @@ -2098,7 +2021,7 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; Read pending output. (while (not (re-search-forward tramp-smb-prompt nil t)) - (while (tramp-accept-process-output p 0)) + (while (tramp-accept-process-output p)) (goto-char (point-min))) (tramp-message vec 6 "\n%s" (buffer-string)) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 2d3c436632f..a4f6246ec23 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -124,6 +124,7 @@ (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-sshfs-handle-file-system-info) (file-truename . tramp-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-sshfs-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -228,8 +229,7 @@ arguments to pass to the OPERATION." (defun tramp-sshfs-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." - ;;`file-system-info' exists since Emacs 27.1. - (tramp-compat-funcall 'file-system-info (tramp-fuse-local-file-name filename))) + (file-system-info (tramp-fuse-local-file-name filename))) (defun tramp-sshfs-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -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) @@ -266,7 +266,7 @@ arguments to pass to the OPERATION." ;; Determine input. (if (null infile) (setq input (tramp-get-remote-null-device v)) - (setq infile (tramp-compat-file-name-unquote (expand-file-name infile))) + (setq infile (file-name-unquote (expand-file-name infile))) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. (setq input (tramp-unquote-file-local-name infile)) @@ -399,7 +399,7 @@ connection if a previous connection has died for some reason." :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (set-process-query-on-exit-flag p nil) ;; Set connection-local variables. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 88dacdc7893..defd4f430bc 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -49,7 +49,7 @@ (tramp-password-previous-hop t))) (add-to-list 'tramp-default-user-alist - `(,(tramp-compat-rx bos (literal tramp-sudoedit-method) eos) + `(,(rx bos (literal tramp-sudoedit-method) eos) nil ,tramp-root-id-string)) (tramp-set-completion-function @@ -114,6 +114,7 @@ See `tramp-actions-before-shell' for more info.") (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-sudoedit-handle-file-system-info) (file-truename . tramp-sudoedit-handle-file-truename) + (file-user-uid . tramp-handle-file-user-uid) (file-writable-p . tramp-sudoedit-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -212,8 +213,8 @@ arguments to pass to the OPERATION." (unless (tramp-sudoedit-send-command v1 "ln" - (tramp-compat-file-name-unquote v1-localname) - (tramp-compat-file-name-unquote v2-localname)) + (file-name-unquote v1-localname) + (file-name-unquote v2-localname)) (tramp-error v1 'file-error "error with add-name-to-file, see buffer `%s' for details" @@ -342,22 +343,19 @@ absolute file names." (tramp-skeleton-delete-directory directory recursive trash (unless (tramp-sudoedit-send-command v (if recursive '("rm" "-rf") "rmdir") - (tramp-compat-file-name-unquote localname)) + (file-name-unquote localname)) (tramp-error v 'file-error "Couldn't delete %s" directory)))) (defun tramp-sudoedit-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-flush-file-properties v localname) - (if (and delete-by-moving-to-trash trash) - (move-file-to-trash filename) - (unless (tramp-sudoedit-send-command - v "rm" "-f" (tramp-compat-file-name-unquote localname)) - ;; Propagate the error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (tramp-error-with-buffer - nil v 'file-error "Couldn't delete %s" filename)))))) + (tramp-skeleton-delete-file filename trash + (unless (tramp-sudoedit-send-command + v "rm" "-f" (file-name-unquote localname)) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error "Couldn't delete %s" filename))))) (defun tramp-sudoedit-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files. @@ -366,7 +364,8 @@ the result will be a local, non-Tramp, file name." ;; If DIR is not given, use `default-directory' or "/". (setq dir (or dir default-directory "/")) ;; Handle empty NAME. - (when (zerop (length name)) (setq name ".")) + (when (string-empty-p name) + (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) @@ -377,17 +376,16 @@ the result will be a local, non-Tramp, file name." ;; Tilde expansion if necessary. We cannot accept "~/", because ;; under sudo "~/" is expanded to the local user home directory ;; but to the root home directory. - (when (zerop (length localname)) + (when (tramp-string-empty-or-nil-p localname) (setq localname "~")) (unless (file-name-absolute-p localname) (setq localname (format "~%s/%s" user localname))) (when (string-match - (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) - localname) + (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) hname) - (when (zerop (length uname)) + (when (tramp-string-empty-or-nil-p uname) (setq uname user)) (when (setq hname (tramp-get-home-directory v uname)) (setq localname (concat hname fname))))) @@ -413,7 +411,7 @@ the result will be a local, non-Tramp, file name." (let ((result (and (tramp-sudoedit-remote-acl-p v) (tramp-sudoedit-send-command-string v "getfacl" "-acp" - (tramp-compat-file-name-unquote localname))))) + (file-name-unquote localname))))) ;; The acl string must have a trailing \n, which is not ;; provided by `tramp-sudoedit-send-command-string'. Add it. (and (stringp result) (concat result "\n")))))) @@ -440,8 +438,7 @@ the result will be a local, non-Tramp, file name." (tramp-convert-file-attributes v localname id-format (tramp-sudoedit-send-command-and-read v "env" "QUOTING_STYLE=locale" "stat" "-c" - tramp-sudoedit-file-attributes - (tramp-compat-file-name-unquote localname))))) + tramp-sudoedit-file-attributes (file-name-unquote localname))))) (defun tramp-sudoedit-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." @@ -453,43 +450,37 @@ the result will be a local, non-Tramp, file name." (or (tramp-check-cached-permissions v ?x) (tramp-check-cached-permissions v ?s)) (tramp-sudoedit-send-command - v "test" "-x" (tramp-compat-file-name-unquote localname)))))) + v "test" "-x" (file-name-unquote localname)))))) (defun tramp-sudoedit-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." - ;; `file-exists-p' is used as predicate in file name completion. - ;; We don't want to run it when `non-essential' is t, or there is - ;; no connection process yet. - (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-exists-p" - (if (tramp-file-property-p v localname "file-attributes") - (not (null (tramp-get-file-property v localname "file-attributes"))) - (tramp-sudoedit-send-command - v "test" "-e" (tramp-compat-file-name-unquote localname))))))) + (tramp-skeleton-file-exists-p filename + (tramp-sudoedit-send-command + v "test" "-e" (file-name-unquote localname)))) (defun tramp-sudoedit-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property v localname "file-name-all-completions" - (tramp-sudoedit-send-command - v "ls" "-a1" "--quoting-style=literal" "--show-control-chars" - (if (zerop (length localname)) - "" (tramp-compat-file-name-unquote localname))) - (mapcar - (lambda (f) - (if (file-directory-p (expand-file-name f directory)) - (file-name-as-directory f) - f)) - (delq - nil + (ignore-error file-missing + (all-completions + filename + (with-parsed-tramp-file-name (expand-file-name directory) nil + (with-tramp-file-property v localname "file-name-all-completions" + (tramp-sudoedit-send-command + v "ls" "-a1" "--quoting-style=literal" "--show-control-chars" + (if (tramp-string-empty-or-nil-p localname) + "" (file-name-unquote localname))) (mapcar - (lambda (l) (and (not (string-match-p (rx bol (* blank) eol) l)) l)) - (split-string - (tramp-get-buffer-string (tramp-get-connection-buffer v)) - "\n" 'omit)))))))) + (lambda (f) + (if (ignore-errors (file-directory-p (expand-file-name f directory))) + (file-name-as-directory f) + f)) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p (rx bol (* blank) eol) l)) l)) + (split-string + (tramp-get-buffer-string (tramp-get-connection-buffer v)) + "\n" 'omit))))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -500,7 +491,7 @@ the result will be a local, non-Tramp, file name." (if (tramp-file-property-p v localname "file-attributes") (tramp-handle-file-readable-p filename) (tramp-sudoedit-send-command - v "test" "-r" (tramp-compat-file-name-unquote localname)))))) + v "test" "-r" (file-name-unquote localname)))))) (defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -508,8 +499,7 @@ the result will be a local, non-Tramp, file name." (unless (and (eq flag 'nofollow) (file-symlink-p filename)) (tramp-skeleton-set-file-modes-times-uid-gid filename (unless (tramp-sudoedit-send-command - v "chmod" (format "%o" mode) - (tramp-compat-file-name-unquote localname)) + v "chmod" (format "%o" mode) (file-name-unquote localname)) (tramp-error v 'file-error "Error while changing file's mode %s" filename))))) @@ -523,15 +513,14 @@ the result will be a local, non-Tramp, file name." (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (tramp-compat-rx + (regexp (rx (group (+ (any "_" alnum))) ":" (group (+ (any "_" alnum))) ":" (group (+ (any "_" alnum))) ":" (group (+ (any "_" alnum)))))) (when (and (tramp-sudoedit-remote-selinux-p v) (tramp-sudoedit-send-command - v "ls" "-d" "-Z" - (tramp-compat-file-name-unquote localname))) + v "ls" "-d" "-Z" (file-name-unquote localname))) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (when (re-search-forward regexp (line-end-position) t) @@ -547,7 +536,7 @@ the result will be a local, non-Tramp, file name." (tramp-message v 5 "file system info: %s" localname) (when (tramp-sudoedit-send-command v "df" "--block-size=1" "--output=size,used,avail" - (tramp-compat-file-name-unquote localname)) + (file-name-unquote localname)) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (forward-line) @@ -565,48 +554,17 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (tramp-skeleton-set-file-modes-times-uid-gid filename - (let ((time - (if (or (null time) - (tramp-compat-time-equal-p time tramp-time-doesnt-exist) - (tramp-compat-time-equal-p time tramp-time-dont-know)) - nil - time))) - (tramp-sudoedit-send-command - v "env" "TZ=UTC0" "touch" "-t" - (format-time-string "%Y%m%d%H%M.%S" time t) - (if (eq flag 'nofollow) "-h" "") - (tramp-compat-file-name-unquote localname))))) + (tramp-sudoedit-send-command + v "env" "TZ=UTC0" "touch" "-t" + (format-time-string "%Y%m%d%H%M.%S" (tramp-defined-time time) t) + (if (eq flag 'nofollow) "-h" "") + (file-name-unquote localname)))) (defun tramp-sudoedit-handle-file-truename (filename) "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (directory-name-p filename) #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (with-parsed-tramp-file-name - (tramp-compat-file-name-unquote (expand-file-name filename)) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let (result) - (tramp-message v 4 "Finding true name for `%s'" filename) - (setq result (tramp-sudoedit-send-command-string - v "readlink" "--canonicalize-missing" localname)) - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (file-remote-p result) - (setq result (tramp-compat-file-name-quote result 'top))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))))) + (tramp-skeleton-file-truename filename + (tramp-sudoedit-send-command-string + v "readlink" "--canonicalize-missing" localname))) (defun tramp-sudoedit-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -618,7 +576,7 @@ the result will be a local, non-Tramp, file name." ;; be satisfied without remote operation. (tramp-check-cached-permissions v ?w) (tramp-sudoedit-send-command - v "test" "-w" (tramp-compat-file-name-unquote localname))) + v "test" "-w" (file-name-unquote localname))) ;; If file doesn't exist, check if directory is writable. (and (file-directory-p (file-name-directory filename)) @@ -626,59 +584,20 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (when (and (null parents) (file-exists-p dir)) - (tramp-error v 'file-already-exists "Directory already exists %s" dir)) - ;; When PARENTS is non-nil, DIR could be a chain of non-existent - ;; directories a/b/c/... Instead of checking, we simply flush the - ;; whole cache. - (tramp-flush-directory-properties - v (if parents "/" (file-name-directory localname))) + (tramp-skeleton-make-directory dir parents (unless (tramp-sudoedit-send-command - v (if parents '("mkdir" "-p") "mkdir") - "-m" (format "%#o" (default-file-modes)) - (tramp-compat-file-name-unquote localname)) + v "mkdir" "-m" (format "%#o" (default-file-modes)) + (file-name-unquote localname)) (tramp-error v 'file-error "Couldn't make directory %s" dir)))) (defun tramp-sudoedit-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If TARGET is a non-Tramp file, it is used verbatim as the target -of the symlink. If TARGET is a Tramp file, only the localname -component is used as the target of the symlink." - (with-parsed-tramp-file-name (expand-file-name linkname) nil - ;; If TARGET is a Tramp name, use just the localname component. - ;; Don't check for a proper method. - (let ((non-essential t)) - (when (and (tramp-tramp-file-p target) - (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target (tramp-file-local-name (expand-file-name target))))) - - ;; If TARGET is still remote, quote it. - (if (tramp-tramp-file-p target) - (make-symbolic-link - (tramp-compat-file-name-quote target 'top) - linkname ok-if-already-exists) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not - (yes-or-no-p - (format - "File %s already exists; make it a link anyway?" - localname))))) - (tramp-error v 'file-already-exists localname) - (delete-file linkname))) - - (tramp-flush-file-properties v localname) - (tramp-sudoedit-send-command - v "ln" "-sf" - (tramp-compat-file-name-unquote target) - (tramp-compat-file-name-unquote localname))))) + "Like `make-symbolic-link' for Tramp files." + (tramp-skeleton-handle-make-symbolic-link target linkname ok-if-already-exists + (tramp-sudoedit-send-command + v "ln" "-sf" + (file-name-unquote target) + (file-name-unquote localname)))) (defun tramp-sudoedit-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -702,8 +621,7 @@ component is used as the target of the symlink." (setq acl-string (string-join (split-string acl-string "\n" 'omit) ",")) (prog1 (tramp-sudoedit-send-command - v "setfacl" "-m" - acl-string (tramp-compat-file-name-unquote localname)) + v "setfacl" "-m" acl-string (file-name-unquote localname)) (tramp-flush-file-property v localname "file-acl"))))) (defun tramp-sudoedit-handle-set-file-selinux-context (filename context) @@ -721,7 +639,7 @@ component is used as the target of the symlink." (when role (format "--role=%s" role)) (when type (format "--type=%s" type)) (when range (format "--range=%s" range)) - (tramp-compat-file-name-unquote localname)) + (file-name-unquote localname)) (if (and user role type range) (tramp-set-file-property v localname "file-selinux-context" context) @@ -774,7 +692,7 @@ ID-FORMAT valid values are `string' and `integer'." "Check, whether a sudo process has finished. Remove unneeded output." ;; There might be pending output for the exit status. (unless (process-live-p proc) - (while (tramp-accept-process-output proc 0)) + (while (tramp-accept-process-output proc)) ;; Delete narrowed region, it would be in the way reading a Lisp form. (goto-char (point-min)) (widen) @@ -802,7 +720,7 @@ connection if a previous connection has died for some reason." :name (tramp-get-connection-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (set-process-query-on-exit-flag p nil) ;; Set connection-local variables. @@ -829,7 +747,7 @@ in case of error, t otherwise." vec 'tramp-sudo-login ?h (or (tramp-file-name-host vec) "") ?u (or (tramp-file-name-user vec) "")) - (tramp-compat-flatten-tree args)))) + (flatten-tree args)))) ;; We suppress the messages `Waiting for prompts from remote shell'. (tramp-verbose (if (= tramp-verbose 3) 2 tramp-verbose)) ;; The password shall be cached also in case of "emacs -Q". @@ -840,7 +758,7 @@ in case of error, t otherwise." (tramp-message vec 6 "%s" (string-join (process-command p) " ")) ;; Avoid process status message in output buffer. (set-process-sentinel p #'ignore) - (process-put p 'vector vec) + (process-put p 'tramp-vector vec) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) (tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index df2f0850b83..3420bb76d14 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -82,6 +82,7 @@ (progn (defvar tramp--startup-hook nil "Forms to be executed at the end of tramp.el.") + (put 'tramp--startup-hook 'tramp-suppress-trace t) (defmacro tramp--with-startup (&rest body) @@ -440,12 +441,12 @@ See `tramp-methods' for a list of possibilities for METHOD." (defconst tramp-default-method-marker "-" "Marker for default method in remote file names.") +(add-to-list 'tramp-methods `(,tramp-default-method-marker)) + (defcustom tramp-default-user nil "Default user to use for transferring files. It is nil by default; otherwise settings in configuration files like -\"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'. - -This variable is regarded as obsolete, and will be removed soon." +\"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'." :type '(choice (const nil) string)) ;;;###tramp-autoload @@ -525,7 +526,7 @@ interpreted as a regular expression which always matches." (defcustom tramp-restricted-shell-hosts-alist (when (and (eq system-type 'windows-nt) (not (string-match-p (rx "sh" eol) tramp-encoding-shell))) - (list (tramp-compat-rx + (list (rx bos (| (literal (downcase tramp-system-name)) (literal (upcase tramp-system-name))) eos))) @@ -539,7 +540,7 @@ host runs a restricted shell, it shall be added to this list, too." ;;;###tramp-autoload (defcustom tramp-local-host-regexp - (tramp-compat-rx + (rx bos (| (literal tramp-system-name) (| "localhost" "localhost4" "localhost6" "127.0.0.1" "::1")) @@ -640,10 +641,11 @@ This regexp must match both `tramp-initial-end-of-output' and :type 'regexp) (defcustom tramp-password-prompt-regexp - (tramp-compat-rx - bol (* nonl) - (group (regexp (regexp-opt password-word-equivalents))) - (* nonl) (any ":：៖") (? "\^@") (* blank)) + (rx-to-string + `(: bol (* nonl) + (group (| . ,password-word-equivalents)) + (* nonl) (any . ,tramp-compat-password-colon-equivalents) + (? "\^@") (* blank))) "Regexp matching password-like prompts. The regexp should match at end of buffer. @@ -659,14 +661,13 @@ The `sudo' program appears to insert a `^@' character into the prompt." (defcustom tramp-wrong-passwd-regexp (rx bol (* nonl) (| "Permission denied" - (: "Login " (| "Incorrect" "incorrect")) - "Connection refused" - "Connection closed" "Timeout, server not responding." "Sorry, try again." "Name or service not known" "Host key verification failed." "No supported authentication methods left to try!" + (: "Login " (| "Incorrect" "incorrect")) + (: "Connection " (| "refused" "closed")) (: "Received signal " (+ digit))) (* nonl)) "Regexp matching a `login failed' message. @@ -724,7 +725,8 @@ The regexp should match at end of buffer." ;; A security key requires the user physically to touch the device ;; with their finger. We must tell it to the user. -;; Added in OpenSSH 8.2. I've tested it with yubikey. +;; Added in OpenSSH 8.2. I've tested it with yubikey. Nitrokey, +;; which has also passed the tests, does not show such a message. (defcustom tramp-security-key-confirm-regexp (rx bol (* "\r") "Confirm user presence for key " (* nonl) (* (any "\r\n"))) "Regular expression matching security key confirmation message. @@ -789,6 +791,7 @@ It shall be used in combination with `generate-new-buffer-name'.") (defvar tramp-temp-buffer-file-name nil "File name of a persistent local temporary file. Useful for \"rsync\" like methods.") + (make-variable-buffer-local 'tramp-temp-buffer-file-name) (put 'tramp-temp-buffer-file-name 'permanent-local t) @@ -899,18 +902,17 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-regexp () "Return `tramp-prefix-regexp'." - (tramp-compat-rx bol (literal (tramp-build-prefix-format)))) + (rx bol (literal (tramp-build-prefix-format)))) (defvar tramp-prefix-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching the very beginning of Tramp file names. Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp-alist - `((default . ,(tramp-compat-rx - (| (literal tramp-default-method-marker) (>= 2 alnum)))) + `((default . ,(rx (| (literal tramp-default-method-marker) (>= 2 alnum)))) (simplified . "") - (separate . ,(tramp-compat-rx - (? (| (literal tramp-default-method-marker) (>= 2 alnum)))))) + (separate + . ,(rx (? (| (literal tramp-default-method-marker) (>= 2 alnum)))))) "Alist mapping Tramp syntax to regexps matching methods identifiers.") (defun tramp-build-method-regexp () @@ -938,7 +940,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-method-regexp () "Return `tramp-postfix-method-regexp'." - (tramp-compat-rx (literal (tramp-build-postfix-method-format)))) + (rx (literal (tramp-build-postfix-method-format)))) (defvar tramp-postfix-method-regexp nil ; Init'd when defining `tramp-syntax'! "Regexp matching delimiter between method and user or host names. @@ -950,8 +952,7 @@ Derived from `tramp-postfix-method-format'.") (defconst tramp-prefix-domain-format "%" "String matching delimiter between user and domain names.") -(defconst tramp-prefix-domain-regexp - (tramp-compat-rx (literal tramp-prefix-domain-format)) +(defconst tramp-prefix-domain-regexp (rx (literal tramp-prefix-domain-format)) "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") @@ -959,7 +960,7 @@ Derived from `tramp-prefix-domain-format'.") "Regexp matching domain names.") (defconst tramp-user-with-domain-regexp - (tramp-compat-rx + (rx (group (regexp tramp-user-regexp)) (regexp tramp-prefix-domain-regexp) (group (regexp tramp-domain-regexp))) @@ -969,8 +970,7 @@ Derived from `tramp-prefix-domain-format'.") "String matching delimiter between user and host names. Used in `tramp-make-tramp-file-name'.") -(defconst tramp-postfix-user-regexp - (tramp-compat-rx (literal tramp-postfix-user-format)) +(defconst tramp-postfix-user-regexp (rx (literal tramp-postfix-user-format)) "Regexp matching delimiter between user and host names. Derived from `tramp-postfix-user-format'.") @@ -993,7 +993,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-prefix-ipv6-regexp () "Return `tramp-prefix-ipv6-regexp'." - (tramp-compat-rx (literal tramp-prefix-ipv6-format))) + (rx (literal tramp-prefix-ipv6-format))) (defvar tramp-prefix-ipv6-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching left hand side of IPv6 addresses. @@ -1021,7 +1021,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-ipv6-regexp () "Return `tramp-postfix-ipv6-regexp'." - (tramp-compat-rx (literal tramp-postfix-ipv6-format))) + (rx (literal tramp-postfix-ipv6-format))) (defvar tramp-postfix-ipv6-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching right hand side of IPv6 addresses. @@ -1030,8 +1030,7 @@ Derived from `tramp-postfix-ipv6-format'.") (defconst tramp-prefix-port-format "#" "String matching delimiter between host names and port numbers.") -(defconst tramp-prefix-port-regexp - (tramp-compat-rx (literal tramp-prefix-port-format)) +(defconst tramp-prefix-port-regexp (rx (literal tramp-prefix-port-format)) "Regexp matching delimiter between host names and port numbers. Derived from `tramp-prefix-port-format'.") @@ -1039,7 +1038,7 @@ Derived from `tramp-prefix-port-format'.") "Regexp matching port numbers.") (defconst tramp-host-with-port-regexp - (tramp-compat-rx + (rx (group (regexp tramp-host-regexp)) (regexp tramp-prefix-port-regexp) (group (regexp tramp-port-regexp))) @@ -1048,8 +1047,7 @@ Derived from `tramp-prefix-port-format'.") (defconst tramp-postfix-hop-format "|" "String matching delimiter after ad-hoc hop definitions.") -(defconst tramp-postfix-hop-regexp - (tramp-compat-rx (literal tramp-postfix-hop-format)) +(defconst tramp-postfix-hop-regexp (rx (literal tramp-postfix-hop-format)) "Regexp matching delimiter after ad-hoc hop definitions. Derived from `tramp-postfix-hop-format'.") @@ -1069,7 +1067,7 @@ Used in `tramp-make-tramp-file-name'.") (defun tramp-build-postfix-host-regexp () "Return `tramp-postfix-host-regexp'." - (tramp-compat-rx (literal tramp-postfix-host-format))) + (rx (literal tramp-postfix-host-format))) (defvar tramp-postfix-host-regexp nil ; Initialized when defining `tramp-syntax'! "Regexp matching delimiter between host names and localnames. @@ -1096,7 +1094,7 @@ Derived from `tramp-postfix-host-format'.") (defun tramp-build-remote-file-name-spec-regexp () "Construct a regexp matching a Tramp file name for a Tramp syntax. It is expected, that `tramp-syntax' has the proper value." - (tramp-compat-rx + (rx ;; Method. (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) ;; Optional user. This includes domain. @@ -1118,7 +1116,7 @@ It is expected, that `tramp-syntax' has the proper value." It is expected, that `tramp-syntax' has the proper value. See `tramp-file-name-structure'." (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (? (group (+ (regexp tramp-remote-file-name-spec-regexp) (regexp tramp-postfix-hop-regexp)))) @@ -1178,11 +1176,9 @@ initial value is overwritten by the car of `tramp-file-name-structure'.") ;; `tramp-method-regexp' needs at least two characters, in order to ;; distinguish from volume letter. This is in the way when completing. (defconst tramp-completion-method-regexp-alist - `((default . ,(tramp-compat-rx - (| (literal tramp-default-method-marker) (+ alnum)))) + `((default . ,(rx (| (literal tramp-default-method-marker) (+ alnum)))) (simplified . "") - (separate . ,(tramp-compat-rx - (| (literal tramp-default-method-marker) (* alnum))))) + (separate . ,(rx (| (literal tramp-default-method-marker) (* alnum))))) "Alist mapping Tramp syntax to regexps matching completion methods.") (defun tramp-build-completion-method-regexp () @@ -1198,8 +1194,8 @@ The `ftp' syntax does not support methods.") "Return `tramp-completion-file-name-regexp' according to `tramp-syntax'." (if (eq tramp-syntax 'separate) ;; FIXME: This shouldn't be necessary. - (tramp-compat-rx bos "/" (? "[" (* (not "]"))) eos) - (tramp-compat-rx + (rx bos "/" (? "[" (* (not "]"))) eos) + (rx bos ;; `file-name-completion' uses absolute paths for matching. ;; This means that on W32 systems, something like @@ -1217,9 +1213,12 @@ The `ftp' syntax does not support methods.") (? (regexp tramp-completion-method-regexp) ;; Method separator, user name and host name. (? (regexp tramp-postfix-method-regexp) - ;; This is a little bit lax, but it serves. - (? (regexp tramp-host-regexp)))) - + (? (regexp tramp-user-regexp) + (regexp tramp-postfix-user-regexp)) + (? (| (regexp tramp-host-regexp) ;; This includes a user. + (: (regexp tramp-prefix-ipv6-regexp) + (? (regexp tramp-ipv6-regexp) + (? (regexp tramp-postfix-ipv6-regexp)))))))) eos))) (defvar tramp-completion-file-name-regexp @@ -1404,20 +1403,6 @@ based on the Tramp and Emacs versions, and should not be set here." :version "26.1" :type '(repeat string)) -(defcustom tramp-completion-reread-directory-timeout 10 - "Defines seconds since last remote command before rereading a directory. -A remote directory might have changed its contents. In order to -make it visible during file name completion in the minibuffer, -Tramp flushes its cache and rereads the directory contents when -more than `tramp-completion-reread-directory-timeout' seconds -have been gone since last remote command execution. A value of t -would require an immediate reread during filename completion, nil -means to use always cached values for the directory contents." - :type '(choice (const nil) (const t) integer)) -(make-obsolete-variable - 'tramp-completion-reread-directory-timeout - 'remote-file-name-inhibit-cache "27.2") - ;;; Internal Variables: (defvar tramp-current-connection nil @@ -1429,6 +1414,7 @@ the (optional) timestamp of last activity on this connection.") "Password save function. Will be called once the password has been verified by successful authentication.") + (put 'tramp-password-save-function 'tramp-suppress-trace t) (defvar tramp-password-prompt-not-unique nil @@ -1437,9 +1423,13 @@ This shouldn't be set explicitly. It is let-bound, for example during direct remote copying with scp.") (defconst tramp-completion-file-name-handler-alist - '((file-name-all-completions + '((expand-file-name . tramp-completion-handle-expand-file-name) + (file-exists-p . tramp-completion-handle-file-exists-p) + (file-name-all-completions . tramp-completion-handle-file-name-all-completions) - (file-name-completion . tramp-completion-handle-file-name-completion)) + (file-name-completion . tramp-completion-handle-file-name-completion) + (file-name-directory . tramp-completion-handle-file-name-directory) + (file-name-nondirectory . tramp-completion-handle-file-name-nondirectory)) "Alist of completion handler functions. Used for file names matching `tramp-completion-file-name-regexp'. Operations not mentioned here will be handled by Tramp's file @@ -1527,8 +1517,7 @@ same connection. Make a copy in order to avoid side effects." (setq vec (copy-tramp-file-name vec)) (setf (tramp-file-name-localname vec) (and (stringp localname) - (tramp-compat-file-name-unquote - (directory-file-name localname))) + (file-name-unquote (directory-file-name localname))) (tramp-file-name-hop vec) nil)) vec)) @@ -1561,7 +1550,7 @@ entry does not exist, return nil." ;; The localname can be quoted with "/:". Extract this. (defun tramp-file-name-unquote-localname (vec) "Return unquoted localname component of VEC." - (tramp-compat-file-name-unquote (tramp-file-name-localname vec))) + (file-name-unquote (tramp-file-name-localname vec))) ;;;###tramp-autoload (defun tramp-tramp-file-p (name) @@ -1599,7 +1588,7 @@ of `process-file', `start-file-process', or `shell-command'." ;; The localname can be quoted with "/:". Extract this. (defun tramp-unquote-file-local-name (name) "Return unquoted localname of NAME." - (tramp-compat-file-name-unquote (tramp-file-local-name name))) + (file-name-unquote (tramp-file-local-name name))) (defun tramp-find-method (method user host) "Return the right method string to use depending on USER and HOST. @@ -1656,7 +1645,7 @@ This is USER, if non-nil. Otherwise, do a lookup in This is HOST, if non-nil. Otherwise, do a lookup in `tramp-default-host-alist' and `tramp-default-host'." (let ((result - (or (and (> (length host) 0) host) + (or (and (tramp-compat-length> host 0) host) (let ((choices tramp-default-host-alist) lhost item) (while choices @@ -1668,7 +1657,7 @@ This is HOST, if non-nil. Otherwise, do a lookup in lhost) tramp-default-host))) ;; We must mark, whether a default value has been used. - (if (or (> (length host) 0) (null result)) + (if (or (tramp-compat-length> host 0) (null result)) result (propertize result 'tramp-default t)))) @@ -1731,14 +1720,13 @@ default values are used." :port port :localname localname :hop hop)) ;; The method must be known. (unless (or nodefault non-essential - (string-equal method tramp-default-method-marker) (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) @@ -1761,27 +1749,31 @@ See `tramp-dissect-file-name' for details." (let ((v (tramp-dissect-file-name (concat tramp-prefix-format (replace-regexp-in-string - (tramp-compat-rx (regexp tramp-postfix-hop-regexp) eos) + (rx (regexp tramp-postfix-hop-regexp) eos) tramp-postfix-host-format name)) nodefault))) ;; 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)) (put #'tramp-dissect-hop-name 'tramp-suppress-trace t) +(defsubst tramp-string-empty-or-nil-p (string) + "Check whether STRING is empty or nil." + (or (null string) (string= string ""))) + (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." (let ((method (tramp-file-name-method vec)) (user-domain (tramp-file-name-user-domain vec)) (host-port (tramp-file-name-host-port vec))) - (if (not (zerop (length user-domain))) - (format "*tramp/%s %s@%s*" method user-domain host-port) - (format "*tramp/%s %s*" method host-port)))) + (if (tramp-string-empty-or-nil-p user-domain) + (format "*tramp/%s %s*" method host-port) + (format "*tramp/%s %s@%s*" method user-domain host-port)))) (put #'tramp-buffer-name 'tramp-suppress-trace t) @@ -1826,23 +1818,23 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." hop (nth 6 args)))) ;; Unless `tramp-syntax' is `simplified', we need a method. - (when (and (not (zerop (length tramp-postfix-method-format))) - (zerop (length method))) + (when (and (not (string-empty-p tramp-postfix-method-format)) + (tramp-string-empty-or-nil-p method)) (signal 'wrong-type-argument (list #'stringp method))) (concat tramp-prefix-format hop - (unless (zerop (length tramp-postfix-method-format)) + (unless (string-empty-p tramp-postfix-method-format) (concat method tramp-postfix-method-format)) user - (unless (zerop (length domain)) + (unless (tramp-string-empty-or-nil-p domain) (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) + (unless (tramp-string-empty-or-nil-p user) tramp-postfix-user-format) (when host (if (string-match-p tramp-ipv6-regexp host) (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host)) - (unless (zerop (length port)) + (unless (tramp-string-empty-or-nil-p port) (concat tramp-prefix-port-format port)) tramp-postfix-host-format localname))) @@ -1857,8 +1849,7 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." (replace-regexp-in-string tramp-prefix-regexp "" (replace-regexp-in-string - (tramp-compat-rx - (regexp tramp-postfix-host-regexp) eos) + (rx (regexp tramp-postfix-host-regexp) eos) tramp-postfix-hop-format (tramp-make-tramp-file-name vec 'noloc))))) @@ -1867,12 +1858,12 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format - (unless (or (zerop (length method)) - (zerop (length tramp-postfix-method-format))) + (unless (or (tramp-string-empty-or-nil-p method) + (string-empty-p tramp-postfix-method-format)) (concat method tramp-postfix-method-format)) - (unless (zerop (length user)) + (unless (tramp-string-empty-or-nil-p user) (concat user tramp-postfix-user-format)) - (unless (zerop (length host)) + (unless (tramp-string-empty-or-nil-p host) (concat (if (string-match-p tramp-ipv6-regexp host) (concat @@ -1919,7 +1910,7 @@ Return `tramp-cache-undefined' in case it doesn't exist." (or (and (tramp-file-name-p vec-or-proc) (get-buffer-process (tramp-buffer-name vec-or-proc))) (and (processp vec-or-proc) - (tramp-get-process (process-get vec-or-proc 'vector))) + (tramp-get-process (process-get vec-or-proc 'tramp-vector))) tramp-cache-undefined)) (defun tramp-get-connection-process (vec) @@ -1967,9 +1958,9 @@ of `current-buffer'." (let ((method (tramp-file-name-method vec)) (user-domain (tramp-file-name-user-domain vec)) (host-port (tramp-file-name-host-port vec))) - (if (not (zerop (length user-domain))) - (format "*debug tramp/%s %s@%s*" method user-domain host-port) - (format "*debug tramp/%s %s*" method host-port)))) + (if (tramp-string-empty-or-nil-p user-domain) + (format "*debug tramp/%s %s*" method host-port) + (format "*debug tramp/%s %s@%s*" method user-domain host-port)))) (put #'tramp-debug-buffer-name 'tramp-suppress-trace t) @@ -1988,7 +1979,7 @@ of `current-buffer'." ;; Also, in `font-lock-defaults' you can specify a function name for ;; the "KEYWORDS" part, so font-lock calls it to get the actual keywords! '(list - (tramp-compat-rx bol (regexp tramp-debug-outline-regexp) (+ nonl)) + (rx bol (regexp tramp-debug-outline-regexp) (+ nonl)) '(1 font-lock-warning-face t t) '(0 (outline-font-lock-face) keep t)) "Used for highlighting Tramp debug buffers in `outline-mode'.") @@ -2199,7 +2190,7 @@ applicable)." vec-or-proc 'dont-create)))))))) ;; Translate proc to vec. (when (processp vec-or-proc) - (setq vec-or-proc (process-get vec-or-proc 'vector)))) + (setq vec-or-proc (process-get vec-or-proc 'tramp-vector)))) ;; Do it. (when (tramp-file-name-p vec-or-proc) (apply #'tramp-debug-message @@ -2322,12 +2313,12 @@ the resulting error message." (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) -;; This macro shall optimize the cases where an `file-exists-p' call -;; is invoked first. Often, the file exists, so the remote command is +;; This macro shall optimize the cases where a `file-exists-p' call is +;; invoked first. Often, the file exists, so the remote command is ;; superfluous. (defmacro tramp-barf-if-file-missing (vec filename &rest body) "Execute BODY and return the result. -In case if an error, raise a `file-missing' error if FILENAME +In case of an error, raise a `file-missing' error if FILENAME does not exist, otherwise propagate the error." (declare (indent 2) (debug (symbolp form body))) (let ((err (make-symbol "err"))) @@ -2402,7 +2393,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (let* ((parameters (cdr reporter)) (message (aref parameters 3))) (when (tramp-compat-string-search message (or (current-message) "")) - (tramp-compat-progress-reporter-update reporter value suffix)))) + (progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode. @@ -2440,13 +2431,12 @@ locally on a remote file name. When the local system is a W32 system but the remote system is Unix, this introduces a superfluous drive letter into the file name. This function removes it." (save-match-data - (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) - (result (tramp-compat-file-name-unquote name 'top))) + (let ((quoted (file-name-quoted-p name 'top)) + (result (file-name-unquote name 'top))) (setq result (replace-regexp-in-string - (tramp-compat-rx (regexp tramp-volume-letter-regexp) "/") - "/" result)) - (if quoted (tramp-compat-file-name-quote result 'top) result)))) + (rx (regexp tramp-volume-letter-regexp) "/") "/" result)) + (if quoted (file-name-quote result 'top) result)))) ;;; Config Manipulation Functions: @@ -2480,13 +2470,14 @@ Example: (setcdr v (delete (car v) (cdr v)))) ;; Check for function and file or registry key. (unless (and (functionp (nth 0 (car v))) + (stringp (nth 1 (car v))) (cond ;; Windows registry. ((string-prefix-p "HKEY_CURRENT_USER" (nth 1 (car v))) (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process - v "reg" nil nil nil "query" (nth 1 (car v)))))) + nil "reg" nil nil nil "query" (nth 1 (car v)))))) ;; DNS-SD service type. ((string-match-p tramp-dns-sd-service-regexp (nth 1 (car v)))) @@ -2554,7 +2545,7 @@ coding system might not be determined. This function repairs it." ;; We found a matching entry in `file-coding-system-alist'. ;; So we add a similar entry, but with the temporary file name ;; as regexp. - (push (cons (tramp-compat-rx (literal tmpname)) (cdr elt)) result))))) + (push (cons (rx (literal tmpname)) (cdr elt)) result))))) (defun tramp-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. @@ -2604,15 +2595,13 @@ Must be handled by the callers." file-name-nondirectory file-name-sans-versions file-notify-add-watch file-ownership-preserved-p file-readable-p file-regular-p file-remote-p - file-selinux-context file-symlink-p file-truename - file-writable-p find-backup-file-name get-file-buffer - insert-directory insert-file-contents load - make-directory set-file-acl set-file-modes + file-selinux-context file-symlink-p file-system-info + file-truename file-writable-p find-backup-file-name + get-file-buffer insert-directory insert-file-contents + load make-directory set-file-acl set-file-modes set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered - ;; Emacs 27+ only. - file-system-info ;; Emacs 28- only. make-directory-internal ;; Emacs 28+ only. @@ -2655,12 +2644,12 @@ Must be handled by the callers." (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - '(make-nearby-temp-file process-file shell-command - start-file-process temporary-file-directory - ;; Emacs 27+ only. - exec-path make-process + '(exec-path make-nearby-temp-file make-process process-file + shell-command start-file-process temporary-file-directory ;; Emacs 29+ only. - list-system-processes memory-info process-attributes)) + list-system-processes memory-info process-attributes + ;; Emacs 30+ only. + file-user-uid)) default-directory) ;; PROC. ((member operation '(file-notify-rm-watch file-notify-valid-p)) @@ -2791,7 +2780,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." (if-let - ((fn (and tramp-mode + ((fn (and tramp-mode minibuffer-completing-file-name (assoc operation tramp-completion-file-name-handler-alist)))) (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args))) @@ -2839,7 +2828,7 @@ remote file names." #'file-name-sans-extension (directory-files dir nil (rx bos "tramp" (+ nonl) ".el" (? "c") eos))))) - (files-regexp (tramp-compat-rx bol (regexp (regexp-opt files)) eol))) + (files-regexp (rx bol (regexp (regexp-opt files)) eol))) (mapatoms (lambda (atom) (when (and (functionp atom) @@ -2876,7 +2865,7 @@ remote file names." (put #'tramp-completion-file-name-handler 'operations (mapcar #'car tramp-completion-file-name-handler-alist)) - ;; Integrated in Emacs 27. + ;; After unloading, `tramp-archive-enabled' might not be defined. (when (bound-and-true-p tramp-archive-enabled) (add-to-list 'file-name-handler-alist (cons tramp-archive-file-name-regexp @@ -2961,9 +2950,76 @@ not in completion mode." (or ;; We check this for the process related to ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. - (and vec (process-live-p (get-process (tramp-buffer-name vec)))) + (process-live-p (tramp-get-process vec)) (not non-essential)))) +(defun tramp-completion-handle-expand-file-name (filename &optional directory) + "Like `expand-file-name' for partial Tramp files." + ;; We need special handling only when a method is needed. Then we + ;; check, whether DIRECTORY is "/method:" or "/[method/". + (let ((dir (or directory default-directory "/"))) + (cond + ((file-name-absolute-p filename) filename) + ((and (eq tramp-syntax 'simplified) + (string-match-p (rx (regexp tramp-postfix-host-regexp) eos) dir)) + (concat dir filename)) + ((string-match-p + (rx bos (regexp tramp-prefix-regexp) + (* (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)) + (? (regexp tramp-method-regexp) (regexp tramp-postfix-method-regexp) + (? (regexp tramp-user-regexp) (regexp tramp-postfix-user-regexp))) + eos) + dir) + (concat dir filename)) + (t (tramp-run-real-handler #'expand-file-name (list filename directory)))))) + +(defun tramp-completion-handle-file-exists-p (filename) + "Like `file-exists-p' for partial Tramp files." + ;; We need special handling only when a method is needed. Then we + ;; regard all files "/method:" or "/[method/" as existent, if + ;; "method" is a valid Tramp method. And we regard all files + ;; "/method:user@", "/user@" or "/[method/user@" as existent, if + ;; "user@" is a valid file name completion. Host completion is + ;; performed in the respective backen operation. + (or (and (cond + ;; Completion styles like `flex' and `substring' check for + ;; the file name "/". This does exist. + ((string-equal filename "/")) + ;; Is it a valid method? + ((and (not (string-empty-p tramp-postfix-method-format)) + (string-match + (rx + (regexp tramp-prefix-regexp) + (* (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)) + (group-n 9 (regexp tramp-method-regexp)) + (? (regexp tramp-postfix-method-regexp)) + eos) + filename)) + (assoc (match-string 9 filename) tramp-methods)) + ;; Is it a valid user? + ((string-match + (rx + (regexp tramp-prefix-regexp) + (* (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)) + (group-n 10 + (regexp tramp-method-regexp) + (regexp tramp-postfix-method-regexp)) + (group-n 11 + (regexp tramp-user-regexp) + (regexp tramp-postfix-user-regexp)) + eos) + filename) + (member + (match-string 11 filename) + (file-name-all-completions + "" (concat tramp-prefix-format (match-string 10 filename)))))) + t) + + (tramp-run-real-handler #'file-exists-p (list filename)))) + ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of ;; `tramp-file-name' structures. For all of them we return possible @@ -2974,10 +3030,10 @@ not in completion mode." (tramp-drop-volume-letter (expand-file-name filename directory))) ;; When `tramp-syntax' is `simplified', we need a default method. (tramp-default-method - (and (zerop (length tramp-postfix-method-format)) + (and (string-empty-p tramp-postfix-method-format) tramp-default-method)) (tramp-default-method-alist - (and (zerop (length tramp-postfix-method-format)) + (and (string-empty-p tramp-postfix-method-format) tramp-default-method-alist)) tramp-default-user tramp-default-user-alist tramp-default-host tramp-default-host-alist @@ -2985,7 +3041,7 @@ not in completion mode." ;; Suppress hop from completion. (when (string-match - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (+ (regexp tramp-remote-file-name-spec-regexp) (regexp tramp-postfix-hop-regexp)))) @@ -3037,11 +3093,12 @@ not in completion mode." result1))) ;; Complete local parts. - (append - result1 - (ignore-errors - (tramp-run-real-handler - #'file-name-all-completions (list filename directory)))))) + (delete-dups + (append + result1 + (ignore-errors + (tramp-run-real-handler + #'file-name-all-completions (list filename directory))))))) ;; Method, host name and user name completion for a file. (defun tramp-completion-handle-file-name-completion @@ -3078,14 +3135,14 @@ They are collected by `tramp-completion-dissect-file-name1'." (let (;; "/method" "/[method" (tramp-completion-file-name-structure1 (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (? (regexp tramp-completion-method-regexp))) eol) 1 nil nil nil)) ;; "/method:user" "/[method/user" (tramp-completion-file-name-structure2 (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) @@ -3094,7 +3151,7 @@ They are collected by `tramp-completion-dissect-file-name1'." ;; "/method:host" "/[method/host" (tramp-completion-file-name-structure3 (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) @@ -3103,7 +3160,7 @@ They are collected by `tramp-completion-dissect-file-name1'." ;; "/method:[ipv6" "/[method/ipv6" (tramp-completion-file-name-structure4 (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) @@ -3113,7 +3170,7 @@ They are collected by `tramp-completion-dissect-file-name1'." ;; "/method:user@host" "/[method/user@host" (tramp-completion-file-name-structure5 (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) @@ -3124,7 +3181,7 @@ They are collected by `tramp-completion-dissect-file-name1'." ;; "/method:user@[ipv6" "/[method/user@ipv6" (tramp-completion-file-name-structure6 (list - (tramp-compat-rx + (rx (regexp tramp-prefix-regexp) (group (regexp tramp-method-regexp)) (regexp tramp-postfix-method-regexp) @@ -3199,6 +3256,45 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (unless (zerop (+ (length user) (length host))) (tramp-completion-make-tramp-file-name method user host nil))) +(defun tramp-completion-handle-file-name-directory (filename) + "Like `file-name-directory' for partial Tramp files." + ;; We need special handling only when a method is needed. Then we + ;; return "/method:" or "/[method/", if "method" is a valid Tramp + ;; method. In the `separate' file name syntax, we return "/[" when + ;; `filename' is "/[string" w/o a trailing method separator "/". + (cond + ((string-match + (rx (group (regexp tramp-prefix-regexp) + (* (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp))) + (? (regexp tramp-completion-method-regexp)) eos) + filename) + (match-string 1 filename)) + ((and (string-match + (rx (group + (regexp tramp-prefix-regexp) + (* (regexp tramp-remote-file-name-spec-regexp) + (regexp tramp-postfix-hop-regexp)) + (group (regexp tramp-method-regexp)) + (regexp tramp-postfix-method-regexp) + (? (regexp tramp-user-regexp) + (regexp tramp-postfix-user-regexp))) + (? (| (regexp tramp-host-regexp) + (: (regexp tramp-prefix-ipv6-regexp) + (? (regexp tramp-ipv6-regexp) + (? (regexp tramp-postfix-ipv6-regexp)))))) + eos) + filename) + ;; Is it a valid method? + (or (tramp-string-empty-or-nil-p (match-string 2 filename)) + (assoc (match-string 2 filename) tramp-methods))) + (match-string 1 filename)) + (t (tramp-run-real-handler #'file-name-directory (list filename))))) + +(defun tramp-completion-handle-file-name-nondirectory (filename) + "Like `file-name-nondirectory' for partial Tramp files." + (tramp-compat-string-replace (file-name-directory filename) "" filename)) + (defun tramp-parse-default-user-host (method) "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' @@ -3257,7 +3353,7 @@ Either user or host may be nil." Either user or host may be nil." (let (result (regexp - (tramp-compat-rx + (rx bol (group (regexp tramp-host-regexp)) (? (+ blank) (group (regexp tramp-user-regexp)))))) (when (re-search-forward regexp (line-end-position) t) @@ -3273,8 +3369,7 @@ User is always nil." (defun tramp-parse-shosts-group () "Return a (user host) tuple allowed to access. User is always nil." - (tramp-parse-group - (tramp-compat-rx bol (group (regexp tramp-host-regexp))) 1 ",")) + (tramp-parse-group (rx bol (group (regexp tramp-host-regexp))) 1 ",")) (defun tramp-parse-sconfig (filename) "Return a list of (user host) tuples allowed to access. @@ -3285,7 +3380,7 @@ User is always nil." "Return a (user host) tuple allowed to access. User is always nil." (tramp-parse-group - (tramp-compat-rx + (rx (| (: bol (* blank) "Host") (: bol (+ nonl)) ;; ??? (group (regexp tramp-host-regexp)))) @@ -3310,15 +3405,14 @@ User is always nil." User is always nil." (tramp-parse-shostkeys-sknownhosts dirname - (tramp-compat-rx - bol "key_" (+ digit) "_" (group (regexp tramp-host-regexp)) ".pub" eol))) + (rx bol "key_" (+ digit) "_" (group (regexp tramp-host-regexp)) ".pub" eol))) (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts dirname - (tramp-compat-rx + (rx bol (group (regexp tramp-host-regexp)) ".ssh-" (| "dss" "rsa") ".pub" eol))) (defun tramp-parse-hosts (filename) @@ -3330,8 +3424,7 @@ User is always nil." "Return a (user host) tuple allowed to access. User is always nil." (tramp-parse-group - (tramp-compat-rx - bol (group (| (regexp tramp-ipv6-regexp) (regexp tramp-host-regexp)))) + (rx bol (group (| (regexp tramp-ipv6-regexp) (regexp tramp-host-regexp)))) 1 (rx blank))) (defun tramp-parse-passwd (filename) @@ -3350,7 +3443,7 @@ Host is always \"localhost\"." "Return a (user host) tuple allowed to access. Host is always \"localhost\"." (let (result - (regexp (tramp-compat-rx bol (group (regexp tramp-user-regexp)) ":"))) + (regexp (rx bol (group (regexp tramp-user-regexp)) ":"))) (when (re-search-forward regexp (line-end-position) t) (setq result (list (match-string 1) "localhost"))) (forward-line 1) @@ -3401,14 +3494,13 @@ User is always nil." (tramp-parse-putty-group registry-or-dirname))))) ;; UNIX case. (tramp-parse-shostkeys-sknownhosts - registry-or-dirname - (tramp-compat-rx bol (group (regexp tramp-host-regexp)) eol)))) + registry-or-dirname (rx bol (group (regexp tramp-host-regexp)) eol)))) (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." (let (result - (regexp (tramp-compat-rx (literal registry) "\\" (group (+ nonl))))) + (regexp (rx (literal registry) "\\" (group (+ nonl))))) (when (re-search-forward regexp (line-end-position) t) (setq result (list nil (match-string 1)))) (forward-line 1) @@ -3435,15 +3527,35 @@ BODY is the backend specific code." BODY is the backend specific code." (declare (indent 3) (debug t)) `(with-parsed-tramp-file-name (expand-file-name ,directory) nil - (if (and delete-by-moving-to-trash ,trash) - ;; Move non-empty dir to trash only if recursive deletion was - ;; requested. - (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) - (tramp-error - v 'file-error "Directory is not empty, not moving to trash") - (move-file-to-trash ,directory)) - ,@body) - (tramp-flush-directory-properties v localname))) + (let ((delete-by-moving-to-trash + (and delete-by-moving-to-trash + ;; This variable exists since Emacs 30.1. + (not (bound-and-true-p + remote-file-name-inhibit-delete-by-moving-to-trash))))) + (if (and delete-by-moving-to-trash ,trash) + ;; Move non-empty dir to trash only if recursive deletion was + ;; requested. + (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) + (tramp-error + v 'file-error "Directory is not empty, not moving to trash") + (move-file-to-trash ,directory)) + ,@body) + (tramp-flush-directory-properties v localname)))) + +(defmacro tramp-skeleton-delete-file (filename &optional trash &rest body) + "Skeleton for `tramp-*-handle-delete-file'. +BODY is the backend specific code." + (declare (indent 2) (debug t)) + `(with-parsed-tramp-file-name (expand-file-name ,filename) nil + (let ((delete-by-moving-to-trash + (and delete-by-moving-to-trash + ;; This variable exists since Emacs 30.1. + (not (bound-and-true-p + remote-file-name-inhibit-delete-by-moving-to-trash))))) + (if (and delete-by-moving-to-trash ,trash) + (move-file-to-trash ,filename) + ,@body) + (tramp-flush-file-properties v localname)))) (defmacro tramp-skeleton-directory-files (directory &optional full match nosort count &rest body) @@ -3524,6 +3636,25 @@ BODY is the backend specific code." (tramp-dissect-file-name ,directory) 'file-missing ,directory) nil))) +(defmacro tramp-skeleton-file-exists-p (filename &rest body) + "Skeleton for `tramp-*-handle-file-exists-p'. +BODY is the backend specific code." + (declare (indent 1) (debug t)) + ;; `file-exists-p' is used as predicate in file name completion. + `(or (and minibuffer-completing-file-name + (file-name-absolute-p ,filename) + (tramp-string-empty-or-nil-p + (tramp-file-name-localname (tramp-dissect-file-name ,filename)))) + ;; We don't want to run it when `non-essential' is t, or there + ;; is no connection process yet. + (when (tramp-connectable-p ,filename) + (with-parsed-tramp-file-name (expand-file-name ,filename) nil + (with-tramp-file-property v localname "file-exists-p" + (if (tramp-file-property-p v localname "file-attributes") + (not + (null (tramp-get-file-property v localname "file-attributes"))) + ,@body)))))) + (defmacro tramp-skeleton-file-local-copy (filename &rest body) "Skeleton for `tramp-*-handle-file-local-copy'. BODY is the backend specific code." @@ -3539,6 +3670,99 @@ BODY is the backend specific code." ;; Trigger the `file-missing' error. (signal 'error nil))))) +(defmacro tramp-skeleton-file-truename (filename &rest body) + "Skeleton for `tramp-*-handle-file-truename'. +BODY is the backend specific code." + (declare (indent 1) (debug (form body))) + ;; Preserve trailing "/". + `(funcall + (if (directory-name-p ,filename) #'file-name-as-directory #'identity) + ;; Quote properly. + (funcall + (if (file-name-quoted-p ,filename) #'file-name-quote #'identity) + (with-parsed-tramp-file-name + (file-name-unquote (expand-file-name ,filename)) nil + (tramp-make-tramp-file-name + v + (with-tramp-file-property v localname "file-truename" + (let (result) + (setq result (progn ,@body)) + ;; Detect cycle. + (when (and (file-symlink-p ,filename) + (string-equal result localname)) + (tramp-error + v 'file-error + "Apparent cycle of symbolic links for %s" ,filename)) + ;; If the resulting localname looks remote, we must quote + ;; it for security reasons. + (when (file-remote-p result) + (setq result (file-name-quote result 'top))) + result))))))) + +(defmacro tramp-skeleton-make-directory (dir &optional parents &rest body) + "Skeleton for `tramp-*-handle-make-directory'. +BODY is the backend specific code." + ;; Since Emacs 29.1, PARENTS isn't propagated to the handlers + ;; anymore. And the return values are specified since then as well. + (declare (indent 2) (debug t)) + `(let* ((dir (directory-file-name (expand-file-name ,dir))) + (par (file-name-directory dir))) + (with-parsed-tramp-file-name dir nil + (when (and (null ,parents) (file-exists-p dir)) + (tramp-error v 'file-already-exists dir)) + ;; Make missing directory parts. + (when ,parents + (unless (file-directory-p par) + (make-directory par ,parents))) + ;; Just do it. + (if (file-exists-p dir) t + (tramp-flush-file-properties v localname) + ,@body + nil)))) + +(defmacro tramp-skeleton-handle-make-symbolic-link + (target linkname &optional ok-if-already-exists &rest body) + "Skeleton for `tramp-*-handle-make-symbolic-link'. +BODY is the backend specific code. +If TARGET is a non-Tramp file, it is used verbatim as the target +of the symlink. If TARGET is a Tramp file, only the localname +component is used as the target of the symlink if it is located +on the same host. Otherwise, TARGET is quoted." + (declare (indent 3) (debug t)) + `(with-parsed-tramp-file-name (expand-file-name ,linkname) nil + ;; If TARGET is a Tramp name, use just the localname component. + ;; Don't check for a proper method. + (let ((non-essential t)) + (when (and (tramp-tramp-file-p ,target) + (tramp-file-name-equal-p v (tramp-dissect-file-name ,target))) + (setq ,target (tramp-file-local-name (expand-file-name ,target)))) + ;; There could be a cyclic link. + (tramp-flush-file-properties + v (expand-file-name ,target (tramp-file-local-name default-directory)))) + + ;; If TARGET is still remote, quote it. + (if (tramp-tramp-file-p ,target) + (make-symbolic-link + (file-name-quote ,target 'top) ,linkname ,ok-if-already-exists) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p ,linkname) + ;; What to do? + (if (or (null ,ok-if-already-exists) ; not allowed to exist + (and (numberp ,ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway?" + localname))))) + (tramp-error v 'file-already-exists localname) + (delete-file ,linkname))) + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + + ,@body))) + (defmacro tramp-skeleton-set-file-modes-times-uid-gid (filename &rest body) "Skeleton for `tramp-*-set-file-{modes,times,uid-gid}'. @@ -3705,6 +3929,15 @@ Let-bind it when necessary.") vec (concat "~" (substring filename (match-beginning 1)))) (tramp-make-tramp-file-name (tramp-dissect-file-name filename))))) +(defun tramp-handle-file-user-uid () + "Like `user-uid' for Tramp files." + (let ((v (tramp-dissect-file-name default-directory))) + (or (tramp-get-remote-uid v 'integer) + ;; Some handlers for `tramp-get-remote-uid' return nil if they + ;; can't get the UID; always return -1 in this case for + ;; consistency. + tramp-unknown-id-integer))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3763,7 +3996,7 @@ Let-bind it when necessary.") ;; Otherwise, remove any trailing slash from localname component. ;; Method, host, etc, are unchanged. (while (with-parsed-tramp-file-name directory nil - (and (not (zerop (length localname))) + (and (tramp-compat-length> localname 0) (eq (aref localname (1- (length localname))) ?/) (not (string= localname "/")))) (setq directory (substring directory 0 -1))) @@ -3794,7 +4027,8 @@ Let-bind it when necessary.") ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". (setq dir (or dir default-directory "/")) ;; Handle empty NAME. - (when (zerop (length name)) (setq name ".")) + (when (string-empty-p name) + (setq name ".")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) @@ -3809,12 +4043,11 @@ Let-bind it when necessary.") ;; not support tilde expansion. But users could declare a ;; respective connection property. (Bug#53847) (when (string-match - (tramp-compat-rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) - localname) + (rx bos "~" (group (* (not "/"))) (group (* nonl)) eos) localname) (let ((uname (match-string 1 localname)) (fname (match-string 2 localname)) hname) - (when (zerop (length uname)) + (when (tramp-string-empty-or-nil-p uname) (setq uname user)) (when (setq hname (tramp-get-home-directory v uname)) (setq localname (concat hname fname))))) @@ -3843,9 +4076,10 @@ Let-bind it when necessary.") (defun tramp-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." ;; `file-truename' could raise an error, for example due to a cyclic - ;; symlink. - (ignore-errors - (eq (file-attribute-type (file-attributes (file-truename filename))) t))) + ;; symlink. We don't protect this despite it, because other errors + ;; might be worth to be visible, for example impossibility to mount + ;; in tramp-gvfs.el. + (eq (file-attribute-type (file-attributes (file-truename filename))) t)) (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." @@ -3858,13 +4092,8 @@ Let-bind it when necessary.") (defun tramp-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." - ;; `file-exists-p' is used as predicate in file name completion. - ;; We don't want to run it when `non-essential' is t, or there is - ;; no connection process yet. - (when (tramp-connectable-p filename) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-exists-p" - (not (null (file-attributes filename))))))) + (tramp-skeleton-file-exists-p filename + (not (null (file-attributes filename))))) (defun tramp-handle-file-in-directory-p (filename directory) "Like `file-in-directory-p' for Tramp files." @@ -3897,7 +4126,7 @@ Let-bind it when necessary.") ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - v (or (and (zerop (length (tramp-file-name-localname v))) + v (or (and (tramp-string-empty-or-nil-p (tramp-file-name-localname v)) (not (tramp-connectable-p file))) (tramp-run-real-handler #'file-name-as-directory @@ -3960,7 +4189,8 @@ Let-bind it when necessary.") ;; "." and ".." are never interesting as completions, and are ;; actually in the way in a directory with only one file. See ;; file_name_completion() in dired.c. - (when (and (consp fnac) (= (length (delete "./" (delete "../" fnac))) 1)) + (when (and (consp fnac) + (tramp-compat-length= (delete "./" (delete "../" fnac)) 1)) (setq fnac (delete "./" (delete "../" fnac)))) (or (try-completion @@ -3971,9 +4201,7 @@ Let-bind it when necessary.") (and completion-ignored-extensions (string-match-p - (tramp-compat-rx - (regexp (regexp-opt completion-ignored-extensions)) eos) - x) + (rx (regexp (regexp-opt completion-ignored-extensions)) eos) x) ;; We remember the hit. (push x hits-ignored-extensions)))))) ;; No match. So we try again for ignored files. @@ -4004,18 +4232,11 @@ Let-bind it when necessary.") ((not (file-exists-p file2)) t) ;; Tramp reads and writes timestamps on second level. So we round ;; the timestamps to seconds without fractions. - ;; `time-convert' has been introduced with Emacs 27.1. - ((fboundp 'time-convert) - (time-less-p - (tramp-compat-funcall - 'time-convert - (file-attribute-modification-time (file-attributes file2)) 'integer) - (tramp-compat-funcall - 'time-convert - (file-attribute-modification-time (file-attributes file1)) 'integer))) (t (time-less-p - (file-attribute-modification-time (file-attributes file2)) - (file-attribute-modification-time (file-attributes file1)))))) + (time-convert + (file-attribute-modification-time (file-attributes file2)) 'integer) + (time-convert + (file-attribute-modification-time (file-attributes file1)) 'integer))))) (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -4079,14 +4300,8 @@ Let-bind it when necessary.") (defun tramp-handle-file-truename (filename) "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (directory-name-p filename) #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (let ((result (tramp-compat-file-name-unquote (expand-file-name filename))) + (tramp-skeleton-file-truename filename + (let ((result (directory-file-name localname)) (numchase 0) ;; Don't make the following value larger than necessary. ;; People expect an error message in a timely fashion when @@ -4096,31 +4311,21 @@ Let-bind it when necessary.") ;; Unquoting could enable encryption. tramp-crypt-enabled symlink-target) - (with-parsed-tramp-file-name result v1 - ;; We cache only the localname. - (tramp-make-tramp-file-name - v1 - (with-tramp-file-property v1 v1-localname "file-truename" - (while (and (setq symlink-target (file-symlink-p result)) - (< numchase numchase-limit)) - (setq numchase (1+ numchase) - result - (with-parsed-tramp-file-name (expand-file-name result) v2 - (tramp-make-tramp-file-name - v2 - (if (stringp symlink-target) - (if (file-remote-p symlink-target) - (tramp-compat-file-name-quote symlink-target 'top) - (tramp-drop-volume-letter - (expand-file-name - symlink-target - (file-name-directory v2-localname)))) - v2-localname)))) - (when (>= numchase numchase-limit) - (tramp-error - v1 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (tramp-file-local-name (directory-file-name result))))))))) + (while (and (setq symlink-target + (file-symlink-p (tramp-make-tramp-file-name v result))) + (< numchase numchase-limit)) + (setq numchase (1+ numchase) + result + (if (file-remote-p symlink-target) + (file-name-quote symlink-target 'top) + (tramp-drop-volume-letter + (expand-file-name + symlink-target (file-name-directory result))))) + (when (>= numchase numchase-limit) + (tramp-error + v 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit))) + (directory-file-name result)))) (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -4343,8 +4548,7 @@ Return it as number of seconds. Used in `tramp-process-attributes-ps-format'." (defconst tramp-process-attributes-ps-args `("-eww" "-o" - ,(mapconcat - #'identity + ,(string-join '("pid" "euid" "euser" @@ -4420,53 +4624,49 @@ Parsing the remote \"ps\" output is controlled by It is not guaranteed, that all process attributes as described in `process-attributes' are returned. The additional attribute `pid' shall be returned always." - ;; Since Emacs 27.1. - (when (fboundp 'connection-local-criteria-for-default-directory) - (with-tramp-file-property vec "/" "process-attributes" - (ignore-errors - (with-temp-buffer - (hack-connection-local-variables-apply - (connection-local-criteria-for-default-directory)) - ;; (pop-to-buffer (current-buffer)) - (when (zerop - (apply - #'process-file - "ps" nil t nil tramp-process-attributes-ps-args)) - (let (result res) - (goto-char (point-min)) - (while (not (eobp)) - ;; (tramp-test-message - ;; "%s" (buffer-substring (point) (line-end-position))) - (when (save-excursion - (search-forward-regexp - (rx digit) (line-end-position) 'noerror)) - (setq res nil) - (dolist (elt tramp-process-attributes-ps-format) - (push - (cons - (car elt) - (cond - ((eq (cdr elt) 'number) (read (current-buffer))) - ((eq (cdr elt) 'string) - (search-forward-regexp (rx (+ (not blank)))) - (match-string 0)) - ((numberp (cdr elt)) - (search-forward-regexp (rx (+ blank))) - (search-forward-regexp - (rx (+ nonl)) (+ (point) (cdr elt))) - (string-trim (match-string 0))) - ((fboundp (cdr elt)) - (funcall (cdr elt))) - ((null (cdr elt)) - (search-forward-regexp (rx (+ blank))) - (buffer-substring (point) (line-end-position))))) - res)) - ;; `nice' could be `-'. - (setq res (rassq-delete-all '- res)) - (push (append res) result)) - (forward-line)) - ;; Return result. - result))))))) + (with-tramp-file-property vec "/" "process-attributes" + (ignore-errors + (with-temp-buffer + (hack-connection-local-variables-apply + (connection-local-criteria-for-default-directory)) + ;; (pop-to-buffer (current-buffer)) + (when (zerop + (apply + #'process-file "ps" nil t nil tramp-process-attributes-ps-args)) + (let (result res) + (goto-char (point-min)) + (while (not (eobp)) + ;; (tramp-test-message + ;; "%s" (buffer-substring (point) (line-end-position))) + (when (save-excursion + (search-forward-regexp + (rx digit) (line-end-position) 'noerror)) + (setq res nil) + (dolist (elt tramp-process-attributes-ps-format) + (push + (cons + (car elt) + (cond + ((eq (cdr elt) 'number) (read (current-buffer))) + ((eq (cdr elt) 'string) + (search-forward-regexp (rx (+ (not blank)))) + (match-string 0)) + ((numberp (cdr elt)) + (search-forward-regexp (rx (+ blank))) + (search-forward-regexp (rx (+ nonl)) (+ (point) (cdr elt))) + (string-trim (match-string 0))) + ((fboundp (cdr elt)) + (funcall (cdr elt))) + ((null (cdr elt)) + (search-forward-regexp (rx (+ blank))) + (buffer-substring (point) (line-end-position))))) + res)) + ;; `nice' could be `-'. + (setq res (rassq-delete-all '- res)) + (push (append res) result)) + (forward-line)) + ;; Return result. + result)))))) (defun tramp-handle-list-system-processes () "Like `list-system-processes' for Tramp files." @@ -4581,11 +4781,22 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defun tramp-handle-unlock-file (file) "Like `unlock-file' for Tramp files." - (when-let ((lockname (tramp-compat-make-lock-file-name file))) - (condition-case err - (delete-file lockname) - ;; `userlock--handle-unlock-error' exists since Emacs 28.1. - (error (tramp-compat-funcall 'userlock--handle-unlock-error err))))) + (condition-case err + ;; When there is no connection, we don't do it. Otherwise, + ;; functions like `kill-buffer' would try to reestablish the + ;; connection. See Bug#61663. + (if-let ((v (tramp-dissect-file-name file)) + ((process-live-p (tramp-get-process v))) + (lockname (tramp-compat-make-lock-file-name file))) + (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. 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." @@ -4627,9 +4838,9 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") tramp-prefix-format proxy tramp-postfix-host-format)) (entry (list (and (stringp host-port) - (tramp-compat-rx bol (literal host-port) eol)) + (rx bol (literal host-port) eol)) (and (stringp user-domain) - (tramp-compat-rx bol (literal user-domain) eol)) + (rx bol (literal user-domain) eol)) (propertize proxy 'tramp-ad-hoc t)))) (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) ;; Add the hop. @@ -4687,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 @@ -4702,14 +4913,14 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (or ;; The host name is used for the remote shell command. (member - "%h" (tramp-compat-flatten-tree + "%h" (flatten-tree (tramp-get-method-parameter item 'tramp-login-args))) ;; The host name must match previous hop. (string-match-p previous-host host)) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error vec "Host name `%s' does not match `%s'" host previous-host)) - (setq previous-host (tramp-compat-rx bol (literal host) eol))))) + (setq previous-host (rx bol (literal host) eol))))) ;; Result. target-alist)) @@ -4723,7 +4934,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (let ((args (tramp-get-method-parameter vec parameter)) (spec (apply 'format-spec-make spec-list))) ;; Expand format spec. - (tramp-compat-flatten-tree + (flatten-tree (mapcar (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) @@ -4741,7 +4952,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (tramp-get-connection-property v "direct-async-process") ;; There's no multi-hop. (or (not (tramp-multi-hop-p v)) - (= (length (tramp-compute-multi-hops v)) 1)) + (null (cdr (tramp-compute-multi-hops v)))) ;; There's no remote stdout or stderr file. (or (not (stringp buffer)) (not (tramp-tramp-file-p buffer))) (or (not (stringp stderr)) (not (tramp-tramp-file-p stderr)))))) @@ -4822,7 +5033,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (if (consp (tramp-get-method-parameter v 'tramp-direct-async)) (append (tramp-get-method-parameter v 'tramp-direct-async) - `(,(mapconcat #'identity command " "))) + `(,(string-join command " "))) command))) ;; Check for `tramp-sh-file-name-handler', because something @@ -4860,9 +5071,8 @@ substitution. SPEC-LIST is a list of char/value pairs used for (setq login-args (append - (tramp-compat-flatten-tree - (tramp-get-method-parameter v 'tramp-async-args)) - (tramp-compat-flatten-tree + (flatten-tree (tramp-get-method-parameter v 'tramp-async-args)) + (flatten-tree (mapcar (lambda (x) (split-string x " ")) (tramp-expand-args @@ -4880,6 +5090,11 @@ substitution. SPEC-LIST is a list of char/value pairs used for ;; t. See Bug#51177. (when filter (set-process-filter p filter)) + (process-put p 'tramp-vector v) + ;; This is neded for ssh or PuTTY based processes, and + ;; only if the respective options are set. Perhaps, the + ;; setting could be more fine-grained. + ;; (process-put p 'tramp-shared-socket t) (process-put p 'remote-command orig-command) (tramp-set-connection-property p "remote-command" orig-command) @@ -5064,19 +5279,11 @@ support symbolic links." (when current-buffer-p (barf-if-buffer-read-only) (push-mark nil t)) - ;; `shell-command-save-pos-or-erase' has been introduced with - ;; Emacs 27.1. - (if (fboundp 'shell-command-save-pos-or-erase) - (tramp-compat-funcall - 'shell-command-save-pos-or-erase current-buffer-p) - (setq buffer-read-only nil) - (erase-buffer))) + (shell-command-save-pos-or-erase current-buffer-p)) (if (integerp asynchronous) (let ((tramp-remote-process-environment - ;; `async-shell-command-width' has been introduced with - ;; Emacs 27.1. - (if (natnump (bound-and-true-p async-shell-command-width)) + (if (natnump async-shell-command-width) (cons (format "COLUMNS=%d" (bound-and-true-p async-shell-command-width)) tramp-remote-process-environment) @@ -5097,17 +5304,19 @@ support symbolic links." (add-function :after (process-sentinel p) (lambda (_proc _string) - (with-current-buffer error-buffer - (insert-file-contents-literally - error-file nil nil nil 'replace)) - (delete-file error-file)))) + (ignore-errors + (with-current-buffer error-buffer + (insert-file-contents-literally + error-file nil nil nil 'replace)) + (delete-file error-file))))) (display-buffer output-buffer '(nil (allow-no-window . t))))) ;; Insert error messages if they were separated. (when (and error-file (not (process-live-p p))) - (with-current-buffer error-buffer - (insert-file-contents-literally error-file)) - (delete-file error-file)))) + (ignore-errors + (with-current-buffer error-buffer + (insert-file-contents-literally error-file)) + (delete-file error-file))))) ;; Synchronous case. (prog1 @@ -5115,9 +5324,10 @@ support symbolic links." (process-file-shell-command command nil buffer) ;; Insert error messages if they were separated. (when error-file - (with-current-buffer error-buffer - (insert-file-contents-literally error-file)) - (delete-file error-file)) + (ignore-errors + (with-current-buffer error-buffer + (insert-file-contents-literally error-file)) + (delete-file error-file))) (if current-buffer-p ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, @@ -5127,11 +5337,7 @@ support symbolic links." (goto-char (prog1 (mark t) (set-marker (mark-marker) (point) (current-buffer)))) - ;; `shell-command-set-point-after-cmd' has been - ;; introduced with Emacs 27.1. - (if (fboundp 'shell-command-set-point-after-cmd) - (tramp-compat-funcall - 'shell-command-set-point-after-cmd))) + (shell-command-set-point-after-cmd)) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) @@ -5139,10 +5345,7 @@ support symbolic links." (defun tramp-handle-start-file-process (name buffer program &rest args) "Like `start-file-process' for Tramp files. BUFFER might be a list, in this case STDERR is separated." - ;; `make-process' knows the `:file-handler' argument since Emacs - ;; 27.1 only. Therefore, we invoke it via `tramp-file-name-handler'. - (tramp-file-name-handler - 'make-process + (make-process :name name :buffer (if (consp buffer) (car buffer) buffer) :command (and program (cons program args)) @@ -5155,7 +5358,7 @@ BUFFER might be a list, in this case STDERR is separated." "Like `substitute-in-file-name' for Tramp files. \"//\" and \"/~\" substitute only in the local filename part." ;; Check, whether the local part is a quoted file name. - (if (tramp-compat-file-name-quoted-p filename) + (if (file-name-quoted-p filename) filename ;; First, we must replace environment variables. (setq filename (tramp-replace-environment-variables filename)) @@ -5186,6 +5389,12 @@ BUFFER might be a list, in this case STDERR is separated." (defconst tramp-time-doesnt-exist '(-1 65535) "An invalid time value, used as \"Doesn't exist\" value.") +(defsubst tramp-defined-time (time) + "Return TIME or nil (when TIME is not a time spec)." + (unless (or (time-equal-p time tramp-time-doesnt-exist) + (time-equal-p time tramp-time-dont-know)) + time)) + (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." (unless (buffer-file-name) @@ -5197,7 +5406,7 @@ BUFFER might be a list, in this case STDERR is separated." (or (file-attribute-modification-time (file-attributes (buffer-file-name))) tramp-time-doesnt-exist)))) - (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) + (unless (time-equal-p time-list tramp-time-dont-know) (tramp-run-real-handler #'set-visited-file-modtime (list time-list)))) (defun tramp-handle-verify-visited-file-modtime (&optional buf) @@ -5223,14 +5432,13 @@ of." (cond ;; File exists, and has a known modtime. - ((and attr - (not (tramp-compat-time-equal-p modtime tramp-time-dont-know))) + ((and attr (not (time-equal-p modtime tramp-time-dont-know))) (< (abs (tramp-time-diff modtime mt)) 2)) ;; Modtime has the don't know value. (attr t) ;; If file does not exist, say it is not modified if and ;; only if that agrees with the buffer's record. - (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist)))))))) + (t (time-equal-p mt tramp-time-doesnt-exist)))))))) (defun tramp-handle-write-region (start end filename &optional append visit lockname mustbenew) @@ -5289,7 +5497,7 @@ of." ;; There might be pending output. Avoid problems with reentrant ;; call of Tramp. (ignore-errors - (while (tramp-accept-process-output proc 0))) + (while (tramp-accept-process-output proc))) (tramp-message proc 6 "Kill %S" proc) (delete-process proc)) @@ -5301,7 +5509,7 @@ of." (with-current-buffer (process-buffer proc) (file-exists-p (concat (file-remote-p default-directory) - (process-get proc 'watch-name)))))) + (process-get proc 'tramp-watch-name)))))) (defun tramp-file-notify-process-sentinel (proc event) "Call `file-notify-rm-watch'." @@ -5427,7 +5635,7 @@ Wait, until the connection buffer changes." ;; Hide message in buffer. (narrow-to-region (point-max) (point-max)) ;; Wait for new output. - (while (not (tramp-compat-ignore-error 'file-error + (while (not (ignore-error file-error (tramp-wait-for-regexp proc 0.1 tramp-security-key-confirmed-regexp))) (when (tramp-check-for-regexp proc tramp-security-key-timeout-regexp) @@ -5441,13 +5649,13 @@ Wait, until the connection buffer changes." "Check, whether a process has finished." (unless (process-live-p proc) ;; There might be pending output. - (while (tramp-accept-process-output proc 0)) + (while (tramp-accept-process-output proc)) (throw 'tramp-action 'process-died))) (defun tramp-action-out-of-band (proc vec) "Check, whether an out-of-band copy has finished." ;; There might be pending output for the exit status. - (while (tramp-accept-process-output proc 0)) + (while (tramp-accept-process-output proc)) (cond ((and (not (process-live-p proc)) (zerop (process-exit-status proc))) (tramp-message vec 3 "Process has finished.") @@ -5478,7 +5686,7 @@ See `tramp-process-actions' for the format of ACTIONS." (while (not found) ;; Reread output once all actions have been performed. ;; Obviously, the output was not complete. - (while (tramp-accept-process-output proc 0)) + (while (tramp-accept-process-output proc)) (setq todo actions) (while todo (setq item (pop todo) @@ -5521,7 +5729,7 @@ performed successfully. Any other value means an error." ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property (tramp-get-connection-property - proc "password-vector" (process-get proc 'vector)) + proc "password-vector" (process-get proc 'tramp-vector)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -5595,11 +5803,22 @@ Mostly useful to protect BODY from being interrupted by timers." ,@body) (tramp-flush-connection-property ,proc "locked")))) -(defun tramp-accept-process-output (proc &optional timeout) +(defun tramp-accept-process-output (proc &optional _timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set for process communication also. If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." + (declare (advertised-calling-convention (proc) "29.2")) + ;; There could be other processes which use the same socket for + ;; communication. This could block the output for the current + ;; process. Read such output first. (Bug#61350) + ;; The process property isn't set anymore due to Bug#62194. + (when-let (((process-get proc 'tramp-shared-socket)) + (v (process-get proc 'tramp-vector))) + (dolist (p (delq proc (process-list))) + (when (tramp-file-name-equal-p v (process-get p 'tramp-vector)) + (with-local-quit (accept-process-output p 0 nil t))))) + (with-current-buffer (process-buffer proc) (let ((inhibit-read-only t) last-coding-system-used @@ -5609,10 +5828,10 @@ If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." ;; JUST-THIS-ONE is set due to Bug#12145. `with-local-quit' ;; returns t in order to report success. (if (with-local-quit - (setq result (accept-process-output proc timeout nil t)) t) + (setq result (accept-process-output proc 0 nil t)) t) (tramp-message - proc 10 "%s %s %s %s\n%s" - proc timeout (process-status proc) result (buffer-string)) + proc 10 "%s %s %s\n%s" + proc (process-status proc) result (buffer-string)) ;; Propagate quit. (keyboard-quit))) result))) @@ -5726,8 +5945,7 @@ the remote host use line-endings as defined in the variable (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) ;; Replace "\n" by `tramp-rsh-end-of-line'. (setq string - (mapconcat - #'identity (split-string string "\n") tramp-rsh-end-of-line)) + (string-join (split-string string "\n") tramp-rsh-end-of-line)) (unless (or (string-empty-p string) (string-equal (substring string -1) tramp-rsh-end-of-line)) (setq string (concat string tramp-rsh-end-of-line))) @@ -5750,7 +5968,7 @@ the remote host use line-endings as defined in the variable (defun tramp-process-sentinel (proc event) "Flush file caches and remove shell prompt." (unless (process-live-p proc) - (let ((vec (process-get proc 'vector)) + (let ((vec (process-get proc 'tramp-vector)) (buf (process-buffer proc)) (prompt (tramp-get-connection-property proc "prompt"))) (when vec @@ -5759,8 +5977,7 @@ the remote host use line-endings as defined in the variable (tramp-flush-directory-properties vec "/")) (when (buffer-live-p buf) (with-current-buffer buf - (when (and prompt - (tramp-search-regexp (tramp-compat-rx (literal prompt)))) + (when (and prompt (tramp-search-regexp (rx (literal prompt)))) (delete-region (point) (point-max)))))))) (defun tramp-get-inode (vec) @@ -5945,9 +6162,7 @@ ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property nil (format "gid-%s" id-format) (cond ((equal id-format 'integer) (group-gid)) - ;; `group-name' has been introduced with Emacs 27.1. - ((and (fboundp 'group-name) (equal id-format 'string)) - (tramp-compat-funcall 'group-name (group-gid))) + ((equal id-format 'string) (group-name (group-gid))) ((file-attribute-group-id (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) @@ -5964,7 +6179,7 @@ VEC is used for tracing." (while candidates (goto-char (point-min)) (if (string-match-p - (tramp-compat-rx bol (literal (car candidates)) (? "\r") eol) + (rx bol (literal (car candidates)) (? "\r") eol) (buffer-string)) (setq locale (car candidates) candidates nil) @@ -6295,7 +6510,7 @@ this file, if that variable is non-nil." ("|" . "__") ("[" . "_l") ("]" . "_r")) - (tramp-compat-file-name-unquote (buffer-file-name))) + (file-name-unquote (buffer-file-name))) tramp-auto-save-directory))) result) (prog1 ;; Run plain `make-auto-save-file-name'. @@ -6324,7 +6539,7 @@ ALIST is of the form ((FROM . TO) ...)." (let* ((pr (car alist)) (from (car pr)) (to (cdr pr))) - (while (string-match (tramp-compat-rx (literal from)) string) + (while (string-match (rx (literal from)) string) (setq string (replace-match to t t string))) (setq alist (cdr alist)))) string)) @@ -6353,6 +6568,7 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory tramp-compat-temporary-file-directory) + (temporary-file-directory tramp-compat-temporary-file-directory) (process-environment (default-toplevel-value 'process-environment)) (destination (if (eq destination t) (current-buffer) destination)) (vec (or vec (car tramp-current-connection))) @@ -6373,7 +6589,7 @@ are written with verbosity of 6." (error (setq error (error-message-string err) result 1))) - (if (zerop (length error)) + (if (tramp-string-empty-or-nil-p error) (tramp-message vec 6 "%s\n%s" result output) (tramp-message vec 6 "%s\n%s\n%s" result output error)) result)) @@ -6385,6 +6601,7 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory tramp-compat-temporary-file-directory) + (temporary-file-directory tramp-compat-temporary-file-directory) (process-environment (default-toplevel-value 'process-environment)) (buffer (if (eq buffer t) (current-buffer) buffer)) result) @@ -6426,7 +6643,7 @@ verbosity of 6." (apply #'process-lines program args) (error (tramp-error vec (car err) (cdr err))))) - (tramp-message vec 6 "\n%s" (mapconcat #'identity result "\n")) + (tramp-message vec 6 "\n%s" (string-join result "\n")) result)) (defun tramp-process-running-p (process-name) @@ -6458,7 +6675,7 @@ Consults the auth-source package." ;; In tramp-sh.el, we must use "password-vector" due to ;; multi-hop. (vec (tramp-get-connection-property - proc "password-vector" (process-get proc 'vector))) + proc "password-vector" (process-get proc 'tramp-vector))) (key (tramp-make-tramp-file-name vec 'noloc)) (method (tramp-file-name-method vec)) (user (or (tramp-file-name-user-domain vec) @@ -6509,7 +6726,7 @@ Consults the auth-source package." ;; Workaround. Prior Emacs 28.1, auth-source has saved empty ;; passwords. See discussion in Bug#50399. - (when (zerop (length auth-passwd)) + (when (tramp-string-empty-or-nil-p auth-passwd) (setq tramp-password-save-function nil)) (tramp-set-connection-property vec "first-password-request" nil) @@ -6559,7 +6776,7 @@ T1 and T2 are time values (as returned by `current-time' for example)." Suppress `shell-file-name'. This is needed on w32 systems, which would use a wrong quoting for local file names. See `w32-shell-name'." (let (shell-file-name) - (shell-quote-argument (tramp-compat-file-name-unquote s)))) + (shell-quote-argument (file-name-unquote s)))) ;; Currently (as of Emacs 20.5), the function `shell-quote-argument' ;; does not deal well with newline characters. Newline is replaced by @@ -6592,7 +6809,7 @@ Only works for Bourne-like shells." (string= (substring result 0 2) "\\~")) (setq result (substring result 1))) (replace-regexp-in-string - (tramp-compat-rx "\\" (literal tramp-rsh-end-of-line)) + (rx "\\" (literal tramp-rsh-end-of-line)) (format "'%s'" tramp-rsh-end-of-line) result))))) ;;; Signal handling. This works for remote processes, which have set @@ -6621,13 +6838,14 @@ name of a process or buffer, or nil to default to the current buffer." ;; negative pid, so we try both variants. (tramp-compat-funcall 'tramp-send-command - (process-get proc 'vector) + (process-get proc 'tramp-vector) (format "(\\kill -2 -%d || \\kill -2 %d) 2>%s" pid pid - (tramp-get-remote-null-device (process-get proc 'vector)))) + (tramp-get-remote-null-device + (process-get proc 'tramp-vector)))) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. - (while (tramp-accept-process-output proc 0)) + (while (tramp-accept-process-output proc)) (not (process-live-p proc)))))) (add-hook 'interrupt-process-functions #'tramp-interrupt-process) @@ -6650,7 +6868,7 @@ SIGCODE may be an integer, or a symbol whose name is a signal name." (cond ((processp process) (setq pid (process-get process 'remote-pid) - vec (process-get process 'vector))) + vec (process-get process 'tramp-vector))) ((numberp process) (setq pid process vec (and (stringp remote) (tramp-dissect-file-name remote)))) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 0d27829b915..ad7bf94cdcd 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.6.0.29.1 -;; Package-Requires: ((emacs "26.1")) +;; Version: 2.7.0-pre +;; Package-Requires: ((emacs "27.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.6.0.29.1" +(defconst tramp-version "2.7.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -55,11 +55,9 @@ (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory)) debug-on-error) - ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. - (with-no-warnings - (and (stringp dir) (file-directory-p dir) - (executable-find "git") - (emacs-repository-get-branch dir))))) + (and (stringp dir) (file-directory-p dir) + (executable-find "git") + (emacs-repository-get-branch dir)))) "The repository branch of the Tramp sources.") (defconst tramp-repository-version @@ -76,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-version-lessp emacs-version "26.1")) +(let ((x (if (not (string-version-lessp emacs-version "27.1")) "ok" - (format "Tramp 2.6.0.29.1 is not fit for %s" + (format "Tramp 2.7.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) 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/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index 7d270ea789f..1553c3efed7 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -184,6 +184,86 @@ Return the new list." (when (and (not ,exist) (buffer-live-p ,buf)) (kill-buffer ,buf)))))) +(defvar pcmpl-gnu--tar-long-options + ;; FIXME: Extract this list from "tar --help". + '("--absolute-names" + "--after-date=" + "--append" + "--atime-preserve" + "--backup" + "--block-number" + "--blocking-factor=" + "--catenate" + "--checkpoint" + "--compare" + "--compress" + "--concatenate" + "--confirmation" + "--create" + "--delete" + "--dereference" + "--diff" + "--directory=" + "--exclude=" + "--exclude-from=" + "--extract" + "--file=" + "--files-from=" + "--force-local" + "--get" + "--group=" + "--gzip" + "--help" + "--ignore-failed-read" + "--ignore-zeros" + "--incremental" + "--info-script=" + "--interactive" + "--keep-old-files" + "--label=" + "--list" + "--listed-incremental" + "--mode=" + "--modification-time" + "--multi-volume" + "--new-volume-script=" + "--newer=" + "--newer-mtime" + "--no-recursion" + "--null" + "--numeric-owner" + "--old-archive" + "--one-file-system" + "--owner=" + "--portability" + "--posix" + "--preserve" + "--preserve-order" + "--preserve-permissions" + "--read-full-records" + "--record-size=" + "--recursive-unlink" + "--remove-files" + "--rsh-command=" + "--same-order" + "--same-owner" + "--same-permissions" + "--sparse" + "--starting-file=" + "--suffix=" + "--tape-length=" + "--to-stdout" + "--totals" + "--uncompress" + "--ungzip" + "--unlink-first" + "--update" + "--use-compress-program=" + "--verbose" + "--verify" + "--version" + "--volno-file=")) + ;;;###autoload (defun pcomplete/tar () "Completion for the GNU tar utility." @@ -192,148 +272,53 @@ Return the new list." (while (pcomplete-match "^-" 0) (setq saw-option t) (if (pcomplete-match "^--" 0) - (if (pcomplete-match "^--\\([^= \t\n\f]*\\)\\'" 0) - ;; FIXME: Extract this list from "tar --help". - (pcomplete-here* - '("--absolute-names" - "--after-date=" - "--append" - "--atime-preserve" - "--backup" - "--block-number" - "--blocking-factor=" - "--catenate" - "--checkpoint" - "--compare" - "--compress" - "--concatenate" - "--confirmation" - "--create" - "--delete" - "--dereference" - "--diff" - "--directory=" - "--exclude=" - "--exclude-from=" - "--extract" - "--file=" - "--files-from=" - "--force-local" - "--get" - "--group=" - "--gzip" - "--help" - "--ignore-failed-read" - "--ignore-zeros" - "--incremental" - "--info-script=" - "--interactive" - "--keep-old-files" - "--label=" - "--list" - "--listed-incremental" - "--mode=" - "--modification-time" - "--multi-volume" - "--new-volume-script=" - "--newer=" - "--newer-mtime" - "--no-recursion" - "--null" - "--numeric-owner" - "--old-archive" - "--one-file-system" - "--owner=" - "--portability" - "--posix" - "--preserve" - "--preserve-order" - "--preserve-permissions" - "--read-full-records" - "--record-size=" - "--recursive-unlink" - "--remove-files" - "--rsh-command=" - "--same-order" - "--same-owner" - "--same-permissions" - "--sparse" - "--starting-file=" - "--suffix=" - "--tape-length=" - "--to-stdout" - "--totals" - "--uncompress" - "--ungzip" - "--unlink-first" - "--update" - "--use-compress-program=" - "--verbose" - "--verify" - "--version" - "--volno-file="))) - (pcomplete-opt "01234567ABCFGKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz")) - (cond - ((pcomplete-match "\\`-\\'" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--after-date=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--backup=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--blocking-factor=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--directory=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-dirs) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--exclude-from=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--exclude=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--\\(extract\\|list\\)\\'" 0) - (setq complete-within t)) - ((pcomplete-match "\\`--file=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-dirs-or-entries pcmpl-gnu-tarfile-regexp) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--files-from=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--group=\\(.*\\)" 0) - (pcomplete-here* (pcmpl-unix-group-names) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--info-script=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--label=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--mode=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--new-volume-script=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--newer=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--owner=\\(.*\\)" 0) - (pcomplete-here* (pcmpl-unix-user-names) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--record-size=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--rsh-command=\\(.*\\)" 0) - (pcomplete-here* (funcall pcomplete-command-completion-function) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--starting-file=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--suffix=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--tape-length=" 0) - (pcomplete-here*)) - ((pcomplete-match "\\`--use-compress-program=\\(.*\\)" 0) - (pcomplete-here* (funcall pcomplete-command-completion-function) - (pcomplete-match-string 1 0))) - ((pcomplete-match "\\`--volno-file=\\(.*\\)" 0) - (pcomplete-here* (pcomplete-entries) - (pcomplete-match-string 1 0))))) + (cond + ((pcomplete-match "^--\\([^= \t\n\f]*\\)\\'" 0) + (pcomplete-here* pcmpl-gnu--tar-long-options)) + ((pcomplete-match "\\`--directory=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-dirs) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--exclude-from=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--\\(extract\\|list\\)\\'" 0) + (setq complete-within t)) + ((pcomplete-match "\\`--file=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-dirs-or-entries + pcmpl-gnu-tarfile-regexp) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--files-from=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--group=\\(.*\\)" 0) + (pcomplete-here* (pcmpl-unix-group-names) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--info-script=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--new-volume-script=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--owner=\\(.*\\)" 0) + (pcomplete-here* (pcmpl-unix-user-names) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--rsh-command=\\(.*\\)" 0) + (pcomplete-here* (funcall pcomplete-command-completion-function) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--starting-file=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--use-compress-program=\\(.*\\)" 0) + (pcomplete-here* (funcall pcomplete-command-completion-function) + (pcomplete-match-string 1 0))) + ((pcomplete-match "\\`--volno-file=\\(.*\\)" 0) + (pcomplete-here* (pcomplete-entries) + (pcomplete-match-string 1 0))) + (t + (pcomplete-here*))) + (pcomplete-opt "01234567ABCFGKLMNOPRSTUVWXZbcdfghiklmoprstuvwxz") + (when (pcomplete-match "\\`-\\'" 0) + (pcomplete-here*)))) (unless saw-option (pcomplete-here (mapcar #'char-to-string diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 1ca7a213361..36f68f1af57 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -362,6 +362,32 @@ modified to be an empty string, or the desired separation string." ;;; User Functions: +(defun pcomplete-default-exit-function (_s status) + "The default exit function to use in `pcomplete-completions-at-point'. +This just adds `pcomplete-termination-string' after the +completion if STATUS is `finished'." + (unless (zerop (length pcomplete-termination-string)) + (when (eq status 'finished) + (if (looking-at + (regexp-quote pcomplete-termination-string)) + (goto-char (match-end 0)) + (insert pcomplete-termination-string))))) + +(defvar pcomplete-exit-function #'pcomplete-default-exit-function + "The exit function to call in `pcomplete-completions-at-point'. + +This variable is let-bound in `pcomplete-completions-at-point', +so you can modify or advise it in order to adjust the behavior +for a specific completion. For example, you might do the +following in a `pcomplete-try-first-hook' function to insert a +trailing slash after a completion: + + (add-function + :before (var pcomplete-exit-function) + (lambda (_ status) + (when (eq status \\='finished) + (insert \"/\"))))") + ;;; Alternative front-end using the standard completion facilities. ;; The way pcomplete-parse-arguments and pcomplete-stub work only @@ -406,6 +432,7 @@ Same as `pcomplete' but using the standard completion UI." (if pcomplete-allow-modifications buffer-read-only t)) pcomplete-seen pcomplete-norm-func pcomplete-args pcomplete-last pcomplete-index + (pcomplete-exit-function pcomplete-exit-function) (pcomplete-autolist pcomplete-autolist) (pcomplete-suffix-list pcomplete-suffix-list) ;; Apparently the vars above are global vars modified by @@ -494,16 +521,7 @@ Same as `pcomplete' but using the standard completion UI." (get-text-property 0 'pcomplete-help cand))) :predicate pred :exit-function - ;; If completion is finished, add a terminating space. - ;; We used to also do this if STATUS is `sole', but - ;; that does not work right when completion cycling. - (unless (zerop (length pcomplete-termination-string)) - (lambda (_s status) - (when (eq status 'finished) - (if (looking-at - (regexp-quote pcomplete-termination-string)) - (goto-char (match-end 0)) - (insert pcomplete-termination-string))))))))))) + pcomplete-exit-function)))))) ;; I don't think such commands are usable before first setting up buffer-local ;; variables to parse args, so there's no point autoloading it. diff --git a/lisp/proced.el b/lisp/proced.el index a9c7ef9ef3d..03a7f1bebdf 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -656,6 +656,14 @@ Important: the match ends just after the marker.") ) (put 'proced-mark :advertised-binding "m") +(defvar-local proced-refinements nil + "Information about the current buffer refinements. + +It should be a list of elements of the form (REFINER PID KEY GRAMMAR), where +REFINER and GRAMMAR are as described in `proced-grammar-alist', PID is the +process ID of the process used to create the refinement, and KEY the attribute +of the process. A value of nil indicates that there are no active refinements.") + (easy-menu-define proced-menu proced-mode-map "Proced Menu." `("Proced" @@ -784,6 +792,52 @@ Return nil if point is not on a process line." (if (looking-at "^. .") (get-text-property (match-end 0) 'proced-pid)))) +(defun proced--position-info (pos) + "Return information of the process at POS. + +The returned information will have the form `(PID KEY COLUMN)' where +PID is the process ID of the process at point, KEY is the value of the +proced-key text property at point, and COLUMN is the column for which the +current value of the proced-key text property starts, or 0 if KEY is nil." + ;; If point is on a field, we try to return point to that field. + ;; Otherwise we try to return to the same column + (save-excursion + (goto-char pos) + (let ((pid (proced-pid-at-point)) + (key (get-text-property (point) 'proced-key))) + (list pid key ; can both be nil + (if key + (if (get-text-property (1- (point)) 'proced-key) + (- (point) (previous-single-property-change + (point) 'proced-key)) + 0) + (current-column)))))) + +(defun proced--determine-pos (key column) + "Return position of point in the current line using KEY and COLUMN. + +Attempt to find the first position on the current line where the +text property proced-key is equal to KEY. If this is not possible, return +the position of point of column COLUMN on the current line." + (save-excursion + (let (new-pos) + (if key + (let ((limit (line-end-position)) pos) + (while (and (not new-pos) + (setq pos (next-property-change (point) nil limit))) + (goto-char pos) + (when (eq key (get-text-property (point) 'proced-key)) + (forward-char (min column (- (next-property-change (point)) + (point)))) + (setq new-pos (point)))) + (unless new-pos + ;; we found the process, but the field of point + ;; is not listed anymore + (setq new-pos (proced-move-to-goal-column)))) + (setq new-pos (min (+ (line-beginning-position) column) + (line-end-position)))) + new-pos))) + ;; proced mode (define-derived-mode proced-mode special-mode "Proced" @@ -839,6 +893,7 @@ normal hook `proced-post-display-hook'. (setq-local revert-buffer-function #'proced-revert) (setq-local font-lock-defaults '(proced-font-lock-keywords t nil nil beginning-of-line)) + (setq-local switch-to-buffer-preserve-window-point nil) (if (and (not proced-auto-update-timer) proced-auto-update-interval) (setq proced-auto-update-timer (run-at-time t proced-auto-update-interval @@ -1337,20 +1392,7 @@ a certain refinement, consider defining a new filter in `proced-filter-alist'." (let* ((grammar (assq key proced-grammar-alist)) (refiner (nth 7 grammar))) (when refiner - (cond ((functionp (car refiner)) - (setq proced-process-alist (funcall (car refiner) pid))) - ((consp refiner) - (let ((predicate (nth 4 grammar)) - (ref (cdr (assq key (cdr (assq pid proced-process-alist))))) - val new-alist) - (dolist (process proced-process-alist) - (setq val (funcall predicate (cdr (assq key (cdr process))) ref)) - (if (cond ((not val) (nth 2 refiner)) - ((eq val 'equal) (nth 1 refiner)) - (val (car refiner))) - (push process new-alist))) - (setq proced-process-alist new-alist)))) - ;; Do not revert listing. + (add-to-list 'proced-refinements (list refiner pid key grammar) t) (proced-update))) (message "No refiner defined here.")))) @@ -1859,10 +1901,29 @@ After updating a displayed Proced buffer run the normal hook "Updating process display..."))) (if revert ;; evaluate all processes (setq proced-process-alist (proced-process-attributes))) - ;; filtering and sorting + ;; filtering + (setq proced-process-alist (proced-filter proced-process-alist proced-filter)) + ;; refinements + (pcase-dolist (`(,refiner ,pid ,key ,grammar) proced-refinements) + ;; It's possible the process has exited since the refinement was made + (when (assq pid proced-process-alist) + (cond ((functionp (car refiner)) + (setq proced-process-alist (funcall (car refiner) pid))) + ((consp refiner) + (let ((predicate (nth 4 grammar)) + (ref (cdr (assq key (cdr (assq pid proced-process-alist))))) + val new-alist) + (dolist (process proced-process-alist) + (setq val (funcall predicate (cdr (assq key (cdr process))) ref)) + (when (cond ((not val) (nth 2 refiner)) + ((eq val 'equal) (nth 1 refiner)) + (val (car refiner))) + (push process new-alist))) + (setq proced-process-alist new-alist)))))) + + ;; sorting (setq proced-process-alist - (proced-sort (proced-filter proced-process-alist proced-filter) - proced-sort proced-descend)) + (proced-sort proced-process-alist proced-sort proced-descend)) ;; display as process tree? (setq proced-process-alist @@ -1875,17 +1936,10 @@ After updating a displayed Proced buffer run the normal hook (if (consp buffer-undo-list) (setq buffer-undo-list nil)) (let ((buffer-undo-list t) - ;; If point is on a field, we try to return point to that field. - ;; Otherwise we try to return to the same column - (old-pos (let ((pid (proced-pid-at-point)) - (key (get-text-property (point) 'proced-key))) - (list pid key ; can both be nil - (if key - (if (get-text-property (1- (point)) 'proced-key) - (- (point) (previous-single-property-change - (point) 'proced-key)) - 0) - (current-column))))) + (window-pos-infos + (mapcar (lambda (w) `(,w . ,(proced--position-info (window-point w)))) + (get-buffer-window-list (current-buffer) nil t))) + (old-pos (proced--position-info (point))) buffer-read-only mp-list) ;; remember marked processes (whatever the mark was) (goto-char (point-min)) @@ -1918,7 +1972,8 @@ After updating a displayed Proced buffer run the normal hook ;; Sometimes this puts point in the middle of the proced buffer ;; where it is not interesting. Is there a better / more flexible solution? (goto-char (point-min)) - (let (pid mark new-pos) + + (let (pid mark new-pos win-points) (if (or mp-list (car old-pos)) (while (not (eobp)) (setq pid (proced-pid-at-point)) @@ -1927,28 +1982,25 @@ After updating a displayed Proced buffer run the normal hook (delete-char 1) (beginning-of-line)) (when (eq (car old-pos) pid) - (if (nth 1 old-pos) - (let ((limit (line-end-position)) pos) - (while (and (not new-pos) - (setq pos (next-property-change (point) nil limit))) - (goto-char pos) - (when (eq (nth 1 old-pos) - (get-text-property (point) 'proced-key)) - (forward-char (min (nth 2 old-pos) - (- (next-property-change (point)) - (point)))) - (setq new-pos (point)))) - (unless new-pos - ;; we found the process, but the field of point - ;; is not listed anymore - (setq new-pos (proced-move-to-goal-column)))) - (setq new-pos (min (+ (line-beginning-position) (nth 2 old-pos)) - (line-end-position))))) + (setq new-pos (proced--determine-pos (nth 1 old-pos) + (nth 2 old-pos)))) + (mapc (lambda (w-pos) + (when (eq (cadr w-pos) pid) + (push `(,(car w-pos) . ,(proced--determine-pos + (nth 1 (cdr w-pos)) + (nth 2 (cdr w-pos)))) + win-points))) + window-pos-infos) (forward-line))) - (if new-pos - (goto-char new-pos) - (goto-char (point-min)) - (proced-move-to-goal-column))) + (let ((fallback (save-excursion (goto-char (point-min)) + (proced-move-to-goal-column) + (point)))) + (goto-char (or new-pos fallback)) + ;; Update window points + (mapc (lambda (w-pos) + (set-window-point (car w-pos) + (alist-get (car w-pos) win-points fallback))) + window-pos-infos))) ;; update mode line ;; Does the long `mode-name' clutter the mode line? It would be nice ;; to have some other location for displaying the values of the various @@ -1976,7 +2028,9 @@ After updating a displayed Proced buffer run the normal hook (defun proced-revert (&rest _args) "Reevaluate the process listing based on the currently running processes. -Preserves point and marks." +Preserves point and marks, but not refinements (see `proced-refine' for +information on refinements)." + (setq proced-refinements nil) (proced-update t)) (defun proced-marked-processes () diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el index 7574ef86a6e..a54df19425a 100644 --- a/lisp/progmodes/antlr-mode.el +++ b/lisp/progmodes/antlr-mode.el @@ -2147,7 +2147,7 @@ command `antlr-show-makefile-rules' for detail." (antlr-makefile-insert-variable i " $(" ")")) (insert "\n" (car antlr-makefile-specification)))) (if (string-equal (car antlr-makefile-specification) "\n") - (backward-delete-char 1)) + (delete-char -1)) (when with-error (goto-char (point-min)) (insert antlr-help-unknown-file-text)) diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 2d54577cb09..5a38d714e5a 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -322,7 +322,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)) @@ -912,6 +912,35 @@ the semicolon. This function skips the semicolon." (setq-local treesit-defun-skipper #'c-ts-mode--defun-skipper) (setq-local treesit-defun-name-function #'c-ts-mode--defun-name) + (setq-local treesit-sentence-type-regexp + ;; compound_statement makes us jump over too big units + ;; of code, so skip that one, and include the other + ;; statements. + (regexp-opt '("preproc" + "declaration" + "specifier" + "attributed_statement" + "labeled_statement" + "expression_statement" + "if_statement" + "switch_statement" + "do_statement" + "while_statement" + "for_statement" + "return_statement" + "break_statement" + "continue_statement" + "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 + ;; 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) @@ -1022,15 +1051,23 @@ recommended to enable `electric-pair-mode' with this mode." :after-hook (c-ts-mode-set-modeline) (when (treesit-ready-p 'cpp) + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" + "raw_string_literal"))) + (treesit-parser-create 'cpp) + ;; Syntax. (setq-local syntax-propertize-function #'c-ts-mode--syntax-propertize) + ;; Indent. (setq-local treesit-simple-indent-rules (c-ts-mode--get-indent-style 'cpp)) + ;; Font-lock. (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'cpp)) + (treesit-major-mode-setup))) (easy-menu-define c-ts-mode-menu (list c-ts-mode-map c++-ts-mode-map) 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 2631c24f8db..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. @@ -1651,7 +1646,7 @@ This function does not do any hidden buffer changes." ;; comment, but XEmacs doesn't. We depend on the Emacs ;; behavior (which also is symmetric). (if (and (eolp) (elt (parse-partial-sexp start (point)) 7)) - (condition-case nil (forward-char 1))) + (forward-char 1)) t)))) @@ -5915,19 +5910,21 @@ comment at the start of cc-engine.el for more info." (cond ((> pos start) ; Nothing but literals base) - ((> base (point-min)) + ((and + (> base (point-min)) + (> (- base try-size) (point-min))) ; prevent infinite recursion. (c-determine-limit how-far-back base (* 2 try-size) org-start)) (t base))) ((>= count how-far-back) (c-determine-limit-no-macro - (+ (car elt) (- count how-far-back)) - org-start)) + (+ (car elt) (- count how-far-back)) + org-start)) ((eq base (point-min)) (point-min)) ((> base (- start try-size)) ; Can only happen if we hit point-min. (c-determine-limit-no-macro - (car elt) - org-start)) + (car elt) + org-start)) (t (c-determine-limit (- how-far-back count) base (* 2 try-size) org-start)))))) @@ -6170,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. @@ -8288,10 +8291,17 @@ multi-line strings (but not C++, for example)." (setq c-record-ref-identifiers (cons range c-record-ref-identifiers)))))) -(defmacro c-forward-keyword-prefixed-id (type) +(defmacro c-forward-keyword-prefixed-id (type &optional stop-at-end) ;; Used internally in `c-forward-keyword-clause' to move forward ;; over a type (if TYPE is 'type) or a name (otherwise) which ;; possibly is prefixed by keywords and their associated clauses. + ;; Point should be at the type/name or a preceding keyword at the start of + ;; the macro, and it is left at the first token following the type/name, + ;; or (when STOP-AT-END is non-nil) immediately after that type/name. + ;; + ;; Note that both parameters are evaluated at compile time, not run time, + ;; so they must be constants. + ;; ;; Try with a type/name first to not trip up on those that begin ;; with a keyword. Return t if a known or found type is moved ;; over. The point is clobbered if nil is returned. If range @@ -8300,51 +8310,84 @@ multi-line strings (but not C++, for example)." ;; ;; This macro might do hidden buffer changes. (declare (debug t)) - `(let (res) + `(let (res pos) (setq c-last-identifier-range nil) (while (if (setq res ,(if (eq type 'type) - '(c-forward-type) - '(c-forward-name))) - nil - (cond ((looking-at c-keywords-regexp) - (c-forward-keyword-clause 1)) - ((and c-opt-cpp-prefix - (looking-at c-noise-macro-with-parens-name-re)) - (c-forward-noise-clause))))) + `(c-forward-type nil ,stop-at-end) + `(c-forward-name ,stop-at-end))) + (progn + (setq pos (point)) + nil) + (and + (cond ((looking-at c-keywords-regexp) + (c-forward-keyword-clause 1 t)) + ((and c-opt-cpp-prefix + (looking-at c-noise-macro-with-parens-name-re)) + (c-forward-noise-clause t))) + (progn + (setq pos (point)) + (c-forward-syntactic-ws) + t)))) (when (memq res '(t known found prefix maybe)) (when c-record-type-identifiers - ,(if (eq type 'type) - '(c-record-type-id c-last-identifier-range) - '(c-record-ref-id c-last-identifier-range))) + ,(if (eq type 'type) + '(c-record-type-id c-last-identifier-range) + '(c-record-ref-id c-last-identifier-range))) + (when pos + (goto-char pos) + ,(unless stop-at-end + `(c-forward-syntactic-ws))) t))) -(defmacro c-forward-id-comma-list (type update-safe-pos) +(defmacro c-forward-id-comma-list (type update-safe-pos &optional stop-at-end) ;; Used internally in `c-forward-keyword-clause' to move forward ;; over a comma separated list of types or names using - ;; `c-forward-keyword-prefixed-id'. + ;; `c-forward-keyword-prefixed-id'. Point should start at the first token + ;; after the already scanned type/name, or (if STOP-AT-END is non-nil) + ;; immediately after that type/name. Point is left either before or + ;; after the whitespace following the last type/name in the list, depending + ;; on whether STOP-AT-END is non-nil or nil. The return value is without + ;; significance. + ;; + ;; Note that all three parameters are evaluated at compile time, not run + ;; time, so they must be constants. ;; ;; This macro might do hidden buffer changes. (declare (debug t)) - `(while (and (progn - ,(when update-safe-pos - '(setq safe-pos (point))) - (eq (char-after) ?,)) - (progn - (forward-char) - (c-forward-syntactic-ws) - (c-forward-keyword-prefixed-id ,type))))) + `(let ((pos (point))) + (while (and (progn + ,(when update-safe-pos + `(setq safe-pos (point))) + (setq pos (point)) + (c-forward-syntactic-ws) + (eq (char-after) ?,)) + (progn + (forward-char) + (setq pos (point)) + (c-forward-syntactic-ws) + (c-forward-keyword-prefixed-id ,type t)))) + (goto-char pos) + ,(unless stop-at-end + `(c-forward-syntactic-ws)))) -(defun c-forward-noise-clause () +(defun c-forward-noise-clause (&optional stop-at-end) ;; Point is at a c-noise-macro-with-parens-names macro identifier. Go ;; forward over this name, any parenthesis expression which follows it, and - ;; any syntactic WS, ending up at the next token or EOB. If there is an + ;; any syntactic WS, ending up either at the next token or EOB or (when + ;; STOP-AT-END is non-nil) directly after the clause. If there is an ;; unbalanced paren expression, leave point at it. Always Return t. - (or (zerop (c-forward-token-2)) - (goto-char (point-max))) - (if (and (eq (char-after) ?\() - (c-go-list-forward)) + (let (pos) + (or (c-forward-over-token) + (goto-char (point-max))) + (setq pos (point)) + (c-forward-syntactic-ws) + (when (and (eq (char-after) ?\() + (c-go-list-forward)) + (setq pos (point))) + (goto-char pos) + (unless stop-at-end (c-forward-syntactic-ws)) - t) + t)) (defun c-forward-noise-clause-not-macro-decl (maybe-parens) ;; Point is at a noise macro identifier, which, when MAYBE-PARENS is @@ -8378,11 +8421,12 @@ multi-line strings (but not C++, for example)." (goto-char here) nil))) -(defun c-forward-keyword-clause (match) +(defun c-forward-keyword-clause (match &optional stop-at-end) ;; Submatch MATCH in the current match data is assumed to surround a ;; token. If it's a keyword, move over it and any immediately - ;; following clauses associated with it, stopping at the start of - ;; the next token. t is returned in that case, otherwise the point + ;; following clauses associated with it, stopping either at the start + ;; of the next token, or (when STOP-AT-END is non-nil) at the end + ;; of the clause. t is returned in that case, otherwise the point ;; stays and nil is returned. The kind of clauses that are ;; recognized are those specified by `c-type-list-kwds', ;; `c-ref-list-kwds', `c-colon-type-list-kwds', @@ -8412,19 +8456,23 @@ multi-line strings (but not C++, for example)." (when kwd-sym (goto-char (match-end match)) - (c-forward-syntactic-ws) (setq safe-pos (point)) + (c-forward-syntactic-ws) (cond ((and (c-keyword-member kwd-sym 'c-type-list-kwds) - (c-forward-keyword-prefixed-id type)) + (c-forward-keyword-prefixed-id type t)) ;; There's a type directly after a keyword in `c-type-list-kwds'. - (c-forward-id-comma-list type t)) + (setq safe-pos (point)) + (c-forward-syntactic-ws) + (c-forward-id-comma-list type t t)) ((and (c-keyword-member kwd-sym 'c-ref-list-kwds) - (c-forward-keyword-prefixed-id ref)) + (c-forward-keyword-prefixed-id ref t)) ;; There's a name directly after a keyword in `c-ref-list-kwds'. - (c-forward-id-comma-list ref t)) + (setq safe-pos (point)) + (c-forward-syntactic-ws) + (c-forward-id-comma-list ref t t)) ((and (c-keyword-member kwd-sym 'c-paren-any-kwds) (eq (char-after) ?\()) @@ -8444,20 +8492,20 @@ multi-line strings (but not C++, for example)." (goto-char (match-end 0))))) (goto-char pos) - (c-forward-syntactic-ws) - (setq safe-pos (point)))) + (setq safe-pos (point))) + (c-forward-syntactic-ws)) ((and (c-keyword-member kwd-sym 'c-<>-sexp-kwds) (eq (char-after) ?<) (c-forward-<>-arglist (c-keyword-member kwd-sym 'c-<>-type-kwds))) - (c-forward-syntactic-ws) - (setq safe-pos (point))) + (setq safe-pos (point)) + (c-forward-syntactic-ws)) ((and (c-keyword-member kwd-sym 'c-nonsymbol-sexp-kwds) (not (looking-at c-symbol-start)) (c-safe (c-forward-sexp) t)) - (c-forward-syntactic-ws) - (setq safe-pos (point))) + (setq safe-pos (point)) + (c-forward-syntactic-ws)) ((and (c-keyword-member kwd-sym 'c-protection-kwds) (or (null c-post-protection-token) @@ -8467,8 +8515,8 @@ multi-line strings (but not C++, for example)." (not (c-end-of-current-token)))))) (if c-post-protection-token (goto-char (match-end 0))) - (c-forward-syntactic-ws) - (setq safe-pos (point)))) + (setq safe-pos (point)) + (c-forward-syntactic-ws))) (when (c-keyword-member kwd-sym 'c-colon-type-list-kwds) (if (eq (char-after) ?:) @@ -8477,8 +8525,10 @@ multi-line strings (but not C++, for example)." (progn (forward-char) (c-forward-syntactic-ws) - (when (c-forward-keyword-prefixed-id type) - (c-forward-id-comma-list type t))) + (when (c-forward-keyword-prefixed-id type t) + (setq safe-pos (point)) + (c-forward-syntactic-ws) + (c-forward-id-comma-list type t t))) ;; Not at the colon, so stop here. But the identifier ;; ranges in the type list later on should still be ;; recorded. @@ -8488,15 +8538,18 @@ multi-line strings (but not C++, for example)." ;; this one, we move forward to the colon following the ;; clause matched above. (goto-char safe-pos) + (c-forward-syntactic-ws) (c-forward-over-colon-type-list)) (progn (c-forward-syntactic-ws) - (c-forward-keyword-prefixed-id type)) + (c-forward-keyword-prefixed-id type t)) ;; There's a type after the `c-colon-type-list-re' match ;; after a keyword in `c-colon-type-list-kwds'. (c-forward-id-comma-list type nil)))) (goto-char safe-pos) + (unless stop-at-end + (c-forward-syntactic-ws)) t))) ;; cc-mode requires cc-fonts. @@ -8578,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) @@ -8679,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. @@ -8827,11 +8877,12 @@ multi-line strings (but not C++, for example)." (/= (point) start)))) -(defun c-forward-name () - ;; Move forward over a complete name if at the beginning of one, - ;; stopping at the next following token. A keyword, as such, - ;; doesn't count as a name. If the point is not at something that - ;; is recognized as a name then it stays put. +(defun c-forward-name (&optional stop-at-end) + ;; Move forward over a complete name if at the beginning of one, stopping + ;; either at the next following token or (when STOP-AT-END is non-nil) at + ;; the end of the name. A keyword, as such, doesn't count as a name. If + ;; the point is not at something that is recognized as a name then it stays + ;; put. ;; ;; A name could be something as simple as "foo" in C or something as ;; complex as "X<Y<class A<int>::B, BIT_MAX >> b>, ::operator<> :: @@ -8853,7 +8904,7 @@ multi-line strings (but not C++, for example)." ;; ;; This function might do hidden buffer changes. - (let ((pos (point)) (start (point)) res id-start id-end + (let ((pos (point)) pos2 pos3 (start (point)) res id-start id-end ;; Turn off `c-promote-possible-types' here since we might ;; call `c-forward-<>-arglist' and we don't want it to promote ;; every suspect thing in the arglist to a type. We're @@ -8895,7 +8946,7 @@ multi-line strings (but not C++, for example)." (c-forward-syntactic-ws lim+) (cond ((eq (char-before id-end) ?e) ;; Got "... ::template". - (let ((subres (c-forward-name))) + (let ((subres (c-forward-name t))) (when subres (setq pos (point) res subres)))) @@ -8907,7 +8958,7 @@ multi-line strings (but not C++, for example)." (and (eq (c-forward-token-2) 0) (not (eq (char-after) ?\()))))) ;; Got a cast operator. - (when (c-forward-type) + (when (c-forward-type nil t) (setq pos (point) res 'operator) ;; Now we should match a sequence of either @@ -8931,8 +8982,8 @@ multi-line strings (but not C++, for example)." (forward-char) t))))) (while (progn - (c-forward-syntactic-ws lim+) (setq pos (point)) + (c-forward-syntactic-ws lim+) (and (<= (point) lim+) (looking-at c-opt-type-modifier-key))) @@ -8947,30 +8998,34 @@ multi-line strings (but not C++, for example)." ;; operator"" has an (?)optional tag after it. (progn (goto-char (match-end 0)) + (setq pos2 (point)) (c-forward-syntactic-ws lim+) (when (c-on-identifier) - (c-forward-token-2 1 nil lim+))) - (goto-char (match-end 0)) - (c-forward-syntactic-ws lim+)) - (setq pos (point) + (c-forward-over-token nil lim+))) + (goto-char (match-end 0)) + (setq pos2 (point)) + (c-forward-syntactic-ws lim+)) + (setq pos pos2 res 'operator))) nil) ;; `id-start' is equal to `id-end' if we've jumped over ;; an identifier that doesn't end with a symbol token. - ;; That can occur e.g. for Java import directives on the + ;; That can occur e.g. for Java import directives of the ;; form "foo.bar.*". (when (and id-start (/= id-start id-end)) (setq c-last-identifier-range (cons id-start id-end))) (goto-char id-end) + (setq pos (point)) (c-forward-syntactic-ws lim+) - (setq pos (point) - res t))) + (setq res t))) (progn (goto-char pos) + (c-forward-syntactic-ws lim+) + (setq pos3 (point)) (when (or c-opt-identifier-concat-key c-recognize-<>-arglists) @@ -8981,7 +9036,6 @@ multi-line strings (but not C++, for example)." ;; cases with tricky syntactic whitespace that aren't ;; covered in `c-identifier-key'. (goto-char (match-end 0)) - (c-forward-syntactic-ws lim+) t) ((and c-recognize-<>-arglists @@ -8993,11 +9047,12 @@ multi-line strings (but not C++, for example)." ;; `lim+'. (setq lim+ (c-determine-+ve-limit 500)) + (setq pos2 (point)) (c-forward-syntactic-ws lim+) (unless (eq (char-after) ?\() (setq c-last-identifier-range nil) - (c-add-type start (1+ pos))) - (setq pos (point)) + (c-add-type start (1+ pos3))) + (setq pos pos2) (if (and c-opt-identifier-concat-key (looking-at c-opt-identifier-concat-key)) @@ -9007,7 +9062,7 @@ multi-line strings (but not C++, for example)." (progn (when (and c-record-type-identifiers id-start) (c-record-ref-id (cons id-start id-end))) - (forward-char 2) + (goto-char (match-end 0)) (c-forward-syntactic-ws lim+) t) @@ -9019,11 +9074,14 @@ multi-line strings (but not C++, for example)." ))))) (goto-char pos) + (unless stop-at-end + (c-forward-syntactic-ws lim+)) res)) -(defun c-forward-type (&optional brace-block-too) +(defun c-forward-type (&optional brace-block-too stop-at-end) ;; Move forward over a type spec if at the beginning of one, - ;; stopping at the next following token. The keyword "typedef" + ;; stopping at the next following token (if STOP-AT-END is nil) or + ;; at the end of the type spec (otherwise). The keyword "typedef" ;; isn't part of a type spec here. ;; ;; BRACE-BLOCK-TOO, when non-nil, means move over the brace block in @@ -9062,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. @@ -9072,6 +9130,8 @@ 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) (setq res 'prefix)))) @@ -9080,32 +9140,41 @@ multi-line strings (but not C++, for example)." (cond ((looking-at c-typeof-key) ; e.g. C++'s "decltype". (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws) (setq res (and (eq (char-after) ?\() (c-safe (c-forward-sexp)) 'decltype)) (if res - (c-forward-syntactic-ws) + (progn + (setq pos (point)) + (c-forward-syntactic-ws)) (goto-char start))) ((looking-at c-type-prefix-key) ; e.g. "struct", "class", but NOT ; "typedef". (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws) (while (cond ((looking-at c-decl-hangon-key) - (c-forward-keyword-clause 1)) + (c-forward-keyword-clause 1 t) + (setq pos (point)) + (c-forward-syntactic-ws)) ((looking-at c-pack-key) (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws)) ((and c-opt-cpp-prefix (looking-at c-noise-macro-with-parens-name-re)) - (c-forward-noise-clause)))) + (c-forward-noise-clause t) + (setq pos (point)) + (c-forward-syntactic-ws)))) + (setq id-start (point)) + (setq name-res (c-forward-name t)) (setq pos (point)) - - (setq name-res (c-forward-name)) (setq res (not (null name-res))) (when (eq name-res t) ;; With some keywords the name can be used without the prefix, so we @@ -9113,21 +9182,21 @@ multi-line strings (but not C++, for example)." (when (save-excursion (goto-char post-prefix-pos) (looking-at c-self-contained-typename-key)) - (c-add-type pos (save-excursion - (c-backward-syntactic-ws) - (point)))) + (c-add-type id-start + (point))) (when (and c-record-type-identifiers c-last-identifier-range) (c-record-type-id c-last-identifier-range))) + (c-forward-syntactic-ws) (when (and brace-block-too (memq res '(t nil)) (eq (char-after) ?\{) (save-excursion (c-safe (progn (c-forward-sexp) - (c-forward-syntactic-ws) (setq pos (point)))))) (goto-char pos) + (c-forward-syntactic-ws) (setq res t)) (unless res (goto-char start))) ; invalid syntax @@ -9141,7 +9210,7 @@ multi-line strings (but not C++, for example)." (if (looking-at c-identifier-start) (save-excursion (setq id-start (point) - name-res (c-forward-name)) + name-res (c-forward-name t)) (when name-res (setq id-end (point) id-range c-last-identifier-range)))) @@ -9154,8 +9223,9 @@ multi-line strings (but not C++, for example)." (>= (save-excursion (save-match-data (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws) - (setq pos (point)))) + pos)) id-end) (setq res nil))))) ;; Looking at a primitive or known type identifier. We've @@ -9173,57 +9243,67 @@ multi-line strings (but not C++, for example)." (looking-at c-opt-type-component-key))) ;; There might be more keywords for the type. (let (safe-pos) - (c-forward-keyword-clause 1) + (c-forward-keyword-clause 1 t) (while (progn (setq safe-pos (point)) + (c-forward-syntactic-ws) (looking-at c-opt-type-component-key)) (when (and c-record-type-identifiers (looking-at c-primitive-type-key)) (c-record-type-id (cons (match-beginning 1) (match-end 1)))) - (c-forward-keyword-clause 1)) + (c-forward-keyword-clause 1 t)) (if (looking-at c-primitive-type-key) (progn (when c-record-type-identifiers (c-record-type-id (cons (match-beginning 1) (match-end 1)))) - (c-forward-keyword-clause 1) + (c-forward-keyword-clause 1 t) (setq res t)) (goto-char safe-pos) - (setq res 'prefix))) - (unless (save-match-data (c-forward-keyword-clause 1)) + (setq res 'prefix)) + (setq pos (point))) + (if (save-match-data (c-forward-keyword-clause 1 t)) + (setq pos (point)) (if pos (goto-char pos) (goto-char (match-end 1)) - (c-forward-syntactic-ws))))) + (setq pos (point))))) + (c-forward-syntactic-ws)) ((and (eq name-res t) (eq res 'prefix) (c-major-mode-is 'c-mode) (save-excursion (goto-char id-end) + (setq pos (point)) + (c-forward-syntactic-ws) (and (not (looking-at c-symbol-start)) (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 (cond ((eq name-res t) ;; 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)) - (c-add-type id-start (save-excursion - (goto-char id-end) - (c-backward-syntactic-ws) - (point)))) + (c-add-type id-start id-end)) (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. @@ -9233,6 +9313,7 @@ multi-line strings (but not C++, for example)." ((eq name-res 'template) ;; A template is sometimes a type. (goto-char id-end) + (setq pos (point)) (c-forward-syntactic-ws) (setq res (if (eq (char-after) ?\() @@ -9258,6 +9339,7 @@ multi-line strings (but not C++, for example)." (when c-opt-type-modifier-key (while (looking-at c-opt-type-modifier-key) ; e.g. "const", "volatile" (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws) (setq res t))) @@ -9268,11 +9350,13 @@ multi-line strings (but not C++, for example)." (when c-opt-type-suffix-key ; e.g. "..." (while (looking-at c-opt-type-suffix-key) (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws))) ;; Skip any "WS" identifiers (e.g. "final" or "override" in C++) (while (looking-at c-type-decl-suffix-ws-ids-key) (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws) (setq res t)) @@ -9296,7 +9380,8 @@ multi-line strings (but not C++, for example)." (progn (goto-char (match-end 1)) (c-forward-syntactic-ws) - (setq subres (c-forward-type)))) + (setq subres (c-forward-type nil t)) + (setq pos (point)))) (progn ;; If either operand certainly is a type then both are, but we @@ -9332,9 +9417,11 @@ multi-line strings (but not C++, for example)." ;; `nconc' doesn't mind that the tail of ;; `c-record-found-types' is t. (nconc c-record-found-types - c-record-type-identifiers)))) + c-record-type-identifiers))))))) - (goto-char pos)))) + (goto-char pos) + (unless stop-at-end + (c-forward-syntactic-ws)) (when (and c-record-found-types (memq res '(known found)) id-range) (setq c-record-found-types @@ -9373,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) @@ -9400,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 () @@ -9573,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) @@ -9587,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 @@ -9621,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, @@ -9737,7 +9855,7 @@ point unchanged and return nil." ;; (e.g. "," or ";" or "}"). (let ((here (point)) id-start id-end brackets-after-id paren-depth decorated - got-init arglist double-double-quote) + got-init arglist double-double-quote pos) (or limit (setq limit (point-max))) (if (and (< (point) limit) @@ -9771,6 +9889,7 @@ point unchanged and return nil." (eq (char-after (1+ (point))) ?\")) (setq double-double-quote t)) (goto-char (match-end 0)) + (setq pos (point)) (c-forward-syntactic-ws limit) (setq got-identifier t) nil) @@ -9783,7 +9902,10 @@ point unchanged and return nil." ;; prefix only if it specifies a member pointer. (progn (setq id-start (point)) - (when (c-forward-name) + (when (c-forward-name t) + (setq pos (point)) + (c-forward-syntactic-ws limit) + (if (save-match-data (looking-at "\\(::\\)")) ;; We only check for a trailing "::" and @@ -9812,10 +9934,12 @@ point unchanged and return nil." (setq id-start (point))) (cond ((or got-identifier - (c-forward-name)) - (save-excursion - (c-backward-syntactic-ws) - (setq id-end (point)))) + (c-forward-name t)) + (setq id-end + (or pos + (point))) + (c-forward-syntactic-ws limit) + t) (accept-anon (setq id-start nil id-end nil) t) @@ -9846,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) @@ -10060,6 +10186,24 @@ This function might do hidden buffer changes." ;; This identifier is bound only in the inner let. '(setq start id-start)))) +(defmacro c-fdoc-assymetric-space-about-asterisk () + ;; We've got a "*" at `id-start' between two identifiers, the first at + ;; `type-start'. Return non-nil when there is either whitespace between the + ;; first id and the "*" or between the "*" and the second id, but not both. + `(let ((space-before-id + (save-excursion + (goto-char id-start) ; Position of "*". + (and (> (skip-chars-forward "* \t\n\r") 0) + (memq (char-before) '(?\ ?\t ?\n ?\r))))) + (space-after-type + (save-excursion + (goto-char type-start) + (and (c-forward-type nil t) + (or (eolp) + (memq (char-after) '(?\ ?\t))))))) + (not (eq (not space-before-id) + (not space-after-type))))) + (defun c-forward-decl-or-cast-1 (preceding-token-end context last-cast-end &optional inside-macro) ;; Move forward over a declaration or a cast if at the start of one. @@ -10282,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 @@ -10569,11 +10715,11 @@ This function might do hidden buffer changes." (or got-identifier (and (looking-at c-identifier-start) (setq pos (point)) - (setq got-identifier (c-forward-name)) + (setq got-identifier (c-forward-name t)) (save-excursion - (c-backward-syntactic-ws) (c-simple-skip-symbol-backward) (setq identifier-start (point))) + (progn (c-forward-syntactic-ws) t) (setq name-start pos)) (when (looking-at "[0-9]") (setq got-number t)) ; We probably have an arithmetic expression. @@ -10632,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)) @@ -10796,8 +10944,7 @@ This function might do hidden buffer changes." type-start (progn (goto-char type-start) - (c-forward-type) - (c-backward-syntactic-ws) + (c-forward-type nil t) (point))))))))) ;; Got a declaration of the form "foo bar (gnu);" or "bar ;; (gnu);" where we've recognized "bar" as the type and "gnu" @@ -11081,19 +11228,25 @@ This function might do hidden buffer changes." ;; CASE 16 (when (and got-prefix-before-parens at-type - (or at-decl-end (looking-at "=[^=]")) (memq context '(nil top)) (or (not got-suffix) at-decl-start)) ;; Got something like "foo * bar;". Since we're not inside ;; an arglist it would be a meaningless expression because ;; the result isn't used. We therefore choose to recognize - ;; it as a declaration. We only allow a suffix (which makes - ;; the construct look like a function call) when - ;; `at-decl-start' provides additional evidence that we do - ;; have a declaration. + ;; it as a declaration when there's "symmetrical WS" around + ;; the "*" or the flag `c-assymetry-fontification-flag' is + ;; not set. We only allow a suffix (which makes the + ;; construct look like a function call) when `at-decl-start' + ;; provides additional evidence that we do have a + ;; declaration. (setq maybe-expression t) - (throw 'at-decl-or-cast t)) + (when (or (not c-asymmetry-fontification-flag) + (looking-at "=\\([^=]\\|$\\)\\|;") + (c-fdoc-assymetric-space-about-asterisk)) + (when (eq at-type 'maybe) + (setq unsafe-maybe t)) + (throw 'at-decl-or-cast t))) ;; CASE 17 (when (and (or got-suffix-after-parens @@ -11112,25 +11265,12 @@ This function might do hidden buffer changes." got-prefix-before-parens at-type (or (not got-suffix) - at-decl-start)) - (let ((space-before-id - (save-excursion - (goto-char id-start) ; Position of "*". - (and (> (skip-chars-forward "* \t\n\r") 0) - (memq (char-before) '(?\ ?\t ?\n ?\r))))) - (space-after-type - (save-excursion - (goto-char type-start) - (and (c-forward-type) - (progn (c-backward-syntactic-ws) t) - (or (eolp) - (memq (char-after) '(?\ ?\t))))))) - (when (not (eq (not space-before-id) - (not space-after-type))) - (when (eq at-type 'maybe) - (setq unsafe-maybe t)) - (setq maybe-expression t) - (throw 'at-decl-or-cast t))))) + at-decl-start) + (c-fdoc-assymetric-space-about-asterisk)) + (when (eq at-type 'maybe) + (setq unsafe-maybe t)) + (setq maybe-expression t) + (throw 'at-decl-or-cast t))) ;; CASE 18 (when (and at-decl-end @@ -12763,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) @@ -12778,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)) @@ -13109,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 @@ -13305,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".) @@ -13856,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 @@ -14271,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 @@ -14441,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 @@ -14474,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>" @@ -14493,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) @@ -14544,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 @@ -14583,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 @@ -14813,7 +15106,59 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'topmost-intro-cont (c-point 'boi))) )) - ;; (CASE 6 has been removed.) + ;; 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 + (eq (char-after containing-sexp) ?\() + (progn (setq tmp-pos (c-safe-scan-lists + containing-sexp 1 0 + (min (+ (point) 2000) (point-max)))) + t) + (save-excursion + (and + (progn (goto-char containing-sexp) + (zerop (c-backward-token-2))) + (looking-at c-generic-key) + (progn (goto-char (1+ containing-sexp)) + (c-syntactic-re-search-forward + "," indent-point 'bound t t)) + (setq placeholder (point))))) + (let ((res (c-syntactic-re-search-forward + "[,:)]" + (or tmp-pos (min (+ (point) 2000) (point-max))) + 'bound t t))) + (cond + ((and res + (eq (char-before) ?\)) + (save-excursion + (backward-char) + (c-backward-syntactic-ws indent-point) + (eq (point) indent-point))) + (c-add-stmt-syntax + 'arglist-close (list containing-sexp) t + (c-most-enclosing-brace paren-state indent-point) paren-state)) + ((or (not res) + (eq (char-before) ?\))) + (backward-char) + (c-syntactic-skip-backward "^,:" containing-sexp t) + (c-add-syntax (if (eq (char-before) ?:) + 'statement-case-intro + 'case-label) + (1+ containing-sexp))) + (t (c-add-syntax (if (eq (char-before) ?:) + 'case-label + 'statement-case-intro) + (1+ containing-sexp)))))) ;; CASE 7: line is an expression, not a statement. Most ;; likely we are either in a function prototype or a function @@ -15154,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 @@ -15304,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 e6c6c65f59c..9118e3253c2 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -259,14 +259,14 @@ (defmacro c-fontify-types-and-refs (varlist &rest body) (declare (indent 1) (debug let*)) - ;; Like `let', but additionally activates `c-record-type-identifiers' + ;; Like `let*', but additionally activates `c-record-type-identifiers' ;; and `c-record-ref-identifiers', and fontifies the recorded ranges ;; accordingly on exit. ;; ;; This function does hidden buffer changes. - `(let ((c-record-type-identifiers t) - c-record-ref-identifiers - ,@varlist) + `(let* ((c-record-type-identifiers t) + c-record-ref-identifiers + ,@varlist) (prog1 (progn ,@body) (c-fontify-recorded-types-and-refs)))) @@ -1219,6 +1219,7 @@ casts and declarations are fontified. Used on level 2 and higher." ;; inside a function declaration arglist). ;; '<> In an angle bracket arglist. ;; 'arglist Some other type of arglist. + ;; 'generic In a C11 _Generic construct. ;; 'top Some other context and point is at the top-level (either ;; outside any braces or directly inside a class or namespace, ;; etc.) @@ -1345,6 +1346,15 @@ casts and declarations are fontified. Used on level 2 and higher." (c-back-over-member-initializers))) (c-put-char-property (1- match-pos) 'c-type 'c-not-decl) (cons 'not-decl nil)) + ;; In a C11 _Generic construct. + ((and c-generic-key + (eq (char-before match-pos) ?,) + (save-excursion + (and (c-go-up-list-backward match-pos + (max (- (point) 2000) (point-min))) + (zerop (c-backward-token-2)) + (looking-at c-generic-key)))) + (cons 'generic nil)) ;; At start of a declaration inside a declaration paren. ((save-excursion (goto-char match-pos) @@ -1378,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)) @@ -1616,13 +1627,16 @@ casts and declarations are fontified. Used on level 2 and higher." (c-forward-syntactic-ws)) ;; Now analyze the construct. - (if (eq context 'not-decl) - (progn - (setq decl-or-cast nil) - (if (c-syntactic-re-search-forward - "," (min limit (point-max)) 'at-limit t) - (c-put-char-property (1- (point)) 'c-type 'c-not-decl)) - nil) + (cond + ((eq context 'not-decl) + (setq decl-or-cast nil) + (if (c-syntactic-re-search-forward + "," (min limit (point-max)) 'at-limit t) + (c-put-char-property (1- (point)) 'c-type 'c-not-decl)) + nil) + ((eq context 'generic) + (c-font-lock-c11-generic-clause)) + (t (setq decl-or-cast (c-forward-decl-or-cast-1 match-pos context last-cast-end inside-macro)) @@ -1683,7 +1697,7 @@ casts and declarations are fontified. Used on level 2 and higher." context (or toplev (nth 4 decl-or-cast)))) - (t t)))) + (t t))))) ;; It was a false alarm. Check if we're in a label (or other ;; construct with `:' except bitfield) instead. @@ -1713,6 +1727,28 @@ casts and declarations are fontified. Used on level 2 and higher." nil)))) +(defun c-font-lock-c11-generic-clause () + ;; Fontify a type inside the C11 _Generic clause. Point will be at the + ;; type and will be left at the next comma of the clause (if any) or the + ;; closing parenthesis, if any, or at the end of the type, otherwise. + ;; The return value is always nil. + (c-fontify-types-and-refs + ((here (point)) + (type-type (c-forward-type t)) + (c-promote-possible-types (if (eq type-type 'maybe) 'just-one t)) + (pos (point)) pos1) + (when (and type-type (eq (char-after) ?:)) + (goto-char here) + (c-forward-type t)) ; Fontify the type. + (cond + ((c-syntactic-re-search-forward "," nil t t t) + (backward-char)) + ((and (setq pos1 (c-up-list-forward)) + (eq (char-before pos1) ?\))) + (goto-char (1- pos1))) + (t (goto-char pos)))) + nil) + (defun c-font-lock-enum-body (limit) ;; Fontify the identifiers of each enum we find by searching forward. ;; @@ -2643,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 1749a2dfa7a..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)) @@ -3085,6 +3089,17 @@ Keywords here should also be in `c-block-stmt-1-kwds'." t (c-make-keywords-re t (c-lang-const c-block-stmt-2-kwds))) (c-lang-defvar c-block-stmt-2-key (c-lang-const c-block-stmt-2-key)) +(c-lang-defconst c-generic-kwds + "The keyword \"_Generic\" which introduces a C11 generic statement." + t nil + c '("_Generic")) + +(c-lang-defconst c-generic-key + ;; Regexp matching the keyword(s) in `c-generic-kwds'. + t (if (c-lang-const c-generic-kwds) + (c-make-keywords-re t (c-lang-const c-generic-kwds)))) +(c-lang-defvar c-generic-key (c-lang-const c-generic-key)) + (c-lang-defconst c-block-stmt-kwds ;; Union of `c-block-stmt-1-kwds' and `c-block-stmt-2-kwds'. t (c--delete-duplicates (append (c-lang-const c-block-stmt-1-kwds) 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/compile.el b/lisp/progmodes/compile.el index ccf64fb670b..6d151db8a83 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1706,7 +1706,7 @@ to `compilation-error-regexp-alist' if RULES is nil." (set-marker (make-marker) (save-excursion (goto-char (point-min)) - (text-property-search-forward 'compilation-header-end) + (text-property-search-forward 'compilation-annotation) ;; If we have no end marker, this will be ;; `point-min' still. (point))))) @@ -1854,6 +1854,14 @@ If nil, don't hide anything." ;; buffers when it changes from nil to non-nil or vice-versa. (unless compilation-in-progress (force-mode-line-update t))) +(defun compilation-insert-annotation (&rest args) + "Insert ARGS at point, adding the `compilation-annotation' text property. +This property is used to distinguish output of the compilation +process from additional information inserted by Emacs." + (let ((start (point))) + (apply #'insert args) + (put-text-property start (point) 'compilation-annotation t))) + ;;;###autoload (defun compilation-start (command &optional mode name-function highlight-regexp continue) @@ -1975,17 +1983,16 @@ Returns the compilation buffer created." (setq-local compilation-auto-jump-to-next t)) (when (zerop (buffer-size)) ;; Output a mode setter, for saving and later reloading this buffer. - (insert "-*- mode: " name-of-mode - "; default-directory: " - (prin1-to-string (abbreviate-file-name default-directory)) - " -*-\n")) - (insert (format "%s started at %s\n\n" - mode-name - (substring (current-time-string) 0 19)) - command "\n") - ;; Mark the end of the header so that we don't interpret - ;; anything in it as an error. - (put-text-property (1- (point)) (point) 'compilation-header-end t) + (compilation-insert-annotation + "-*- mode: " name-of-mode + "; default-directory: " + (prin1-to-string (abbreviate-file-name default-directory)) + " -*-\n")) + (compilation-insert-annotation + (format "%s started at %s\n\n" + mode-name + (substring (current-time-string) 0 19)) + command "\n") (setq thisdir default-directory)) (set-buffer-modified-p nil)) ;; Pop up the compilation buffer. @@ -2467,13 +2474,13 @@ commands of Compilation major mode are available. See (cur-buffer (current-buffer))) ;; Record where we put the message, so we can ignore it later on. (goto-char omax) - (insert ?\n mode-name " " (car status)) + (compilation-insert-annotation ?\n mode-name " " (car status)) (if (and (numberp compilation-window-height) (zerop compilation-window-height)) (message "%s" (cdr status))) (if (bolp) (forward-char -1)) - (insert " at " (substring (current-time-string) 0 19)) + (compilation-insert-annotation " at " (substring (current-time-string) 0 19)) (goto-char (point-max)) ;; Prevent that message from being recognized as a compilation error. (add-text-properties omax (point) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 412283f3488..b6f0e9bca41 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -2918,8 +2918,9 @@ and closing parentheses and brackets." ;; ((eq 'REx-part2 (elt i 0)) ;; [self start] start of /REP in s//REP/x (goto-char (elt i 1)) - (condition-case nil ; Use indentation of the 1st part - (forward-sexp -1)) + (condition-case nil + (forward-sexp -1) ; Use indentation of the 1st part + (error nil)) (current-column)) ((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc (cond ;;; [indentable terminator start-pos is-block] diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 47cd13e7fdb..ea4977254ce 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -942,6 +942,11 @@ Key bindings: ;; Comments. (c-ts-common-comment-setup) + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" + "verbatim_string-literal" + "interpolated_verbatim_string-text"))) + ;; Indent. (setq-local treesit-simple-indent-rules csharp-ts-mode--indent-rules) diff --git a/lisp/progmodes/dockerfile-ts-mode.el b/lisp/progmodes/dockerfile-ts-mode.el index f2f30cf2617..c9125bc6cbd 100644 --- a/lisp/progmodes/dockerfile-ts-mode.el +++ b/lisp/progmodes/dockerfile-ts-mode.el @@ -173,6 +173,10 @@ the subtrees." (setq-local treesit-simple-indent-rules dockerfile-ts-mode--indent-rules) + ;; Navigation + (setq-local treesit-sentence-type-regexp + "instruction") + ;; Font-lock. (setq-local treesit-font-lock-settings dockerfile-ts-mode--font-lock-settings) 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 a0581126b28..c4f773c8426 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2,11 +2,12 @@ ;; Copyright (C) 2018-2023 Free Software Foundation, Inc. -;; Version: 1.12.29 +;; 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.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 @@ -96,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) @@ -183,7 +180,7 @@ chosen (interactively or automatically)." when probe return (cons probe args) finally (funcall err))))))) -(defvar eglot-server-programs `(((rust-ts-mode rust-mode) . ,(eglot-alternatives '("rust-analyzer" "rls"))) +(defvar eglot-server-programs `(((rust-ts-mode rust-mode) . ("rust-analyzer")) ((cmake-mode cmake-ts-mode) . ("cmake-language-server")) (vimrc-mode . ("vim-language-server" "--stdio")) ((python-mode python-ts-mode) @@ -220,7 +217,11 @@ chosen (interactively or automatically)." ((java-mode java-ts-mode) . ("jdtls")) (dart-mode . ("dart" "language-server" "--client-id" "emacs.eglot-dart")) - (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"))) @@ -241,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 @@ -389,14 +390,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. @@ -441,6 +448,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 ;;; @@ -476,9 +487,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) ()) @@ -771,14 +780,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 @@ -837,12 +844,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 +881,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 +914,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 +972,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 +1027,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 +1078,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 +1096,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 +1132,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 +1144,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 +1158,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 +1231,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 +1305,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 +1326,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 +1471,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 +1532,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. @@ -1648,10 +1675,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 +1783,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 +1866,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 +1899,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) @@ -1957,8 +1995,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" @@ -2038,7 +2076,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 @@ -2075,7 +2113,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 "] "))) @@ -2123,8 +2169,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) @@ -2134,13 +2180,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) @@ -2156,28 +2203,39 @@ COMMAND is a symbol naming the command." (_server (_method (eql telemetry/event)) &rest _any) "Handle notification telemetry/event.") ;; noop, use events buffer +(defalias 'eglot--reporter-update + (if (> emacs-major-version 26) #'progress-reporter-update + (lambda (a b &optional _c) (progress-reporter-update a b)))) + (cl-defmethod eglot-handle-notification (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 " ")) + (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)))) - (when pr (progress-reporter-update pr pcnt msg)))) + (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))) - (upd percentage (fmt title message) - (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))))) - ("report" (upd percentage (fmt title message))) - ("end" (upd (or percentage 100) (fmt title message)) - (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 @@ -2194,7 +2252,7 @@ COMMAND is a symbol naming the command." (buffer (find-buffer-visiting path))) (with-current-buffer buffer (cl-loop - initially (assoc-delete-all path flymake-list-only-diagnostics #'string=) + initially (assoc-delete-all path flymake-list-only-diagnostics) for diag-spec across diagnostics collect (eglot--dbind ((Diagnostic) range code message severity source tags) diag-spec @@ -2248,7 +2306,7 @@ COMMAND is a symbol naming the command." into diags finally (setq flymake-list-only-diagnostics - (assoc-delete-all path flymake-list-only-diagnostics #'string=)) + (assoc-delete-all path flymake-list-only-diagnostics)) (push (cons path diags) flymake-list-only-diagnostics))))) (cl-defun eglot--register-unregister (server things how) @@ -2303,7 +2361,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)))))) @@ -2416,16 +2474,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. @@ -2578,8 +2626,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." @@ -2691,8 +2739,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." @@ -2748,7 +2796,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) @@ -2811,9 +2859,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." @@ -2845,7 +2893,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* @@ -2854,8 +2902,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." @@ -2872,41 +2926,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, @@ -2917,13 +2980,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 @@ -2994,7 +3065,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 @@ -3002,6 +3073,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 @@ -3025,17 +3097,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))) @@ -3058,62 +3125,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." @@ -3124,13 +3185,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)) @@ -3145,7 +3211,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)) @@ -3179,49 +3246,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." @@ -3292,9 +3365,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 () @@ -3320,7 +3393,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) @@ -3332,8 +3405,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) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 6fbb87fa3a8..45e3848362e 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -944,6 +944,10 @@ namespace but with lower confidence." cl-defmethod cl-defgeneric))) ;; (defun FUNC (... IDENT 'variable) + ((and (eql j 2) + (eq j-head 'defclass)) + ;; (defclass CLASS (... IDENT + 'function) ((eq j-head 'cond) ;; (cond ... (... IDENT 'variable) diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el new file mode 100644 index 00000000000..c58854c41c3 --- /dev/null +++ b/lisp/progmodes/elixir-ts-mode.el @@ -0,0 +1,681 @@ +;;; elixir-ts-mode.el --- Major mode for Elixir with tree-sitter support -*- lexical-binding: t; -*- + +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. + +;; Author: Wilhelm H Kirschbaum <wkirschbaum@gmail.com> +;; Created: November 2022 +;; Keywords: elixir languages tree-sitter + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package provides `elixir-ts-mode' which is a major mode for editing +;; Elixir files and embedded HEEx templates that uses Tree Sitter to parse +;; the language. +;; +;; This package is compatible with and was tested against the tree-sitter grammar +;; for Elixir found at https://github.com/elixir-lang/tree-sitter-elixir. +;; +;; Features +;; +;; * Indent +;; +;; `elixir-ts-mode' tries to replicate the indentation provided by +;; mix format, but will come with some minor differences. +;; +;; * IMenu +;; * Navigation +;; * Which-fun + +;;; Code: + +(require 'treesit) +(eval-when-compile (require 'rx)) + +(declare-function treesit-parser-create "treesit.c") +(declare-function treesit-node-child "treesit.c") +(declare-function treesit-node-type "treesit.c") +(declare-function treesit-node-child-by-field-name "treesit.c") +(declare-function treesit-parser-language "treesit.c") +(declare-function treesit-parser-included-ranges "treesit.c") +(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") + +(defgroup elixir-ts nil + "Major mode for editing Elixir code." + :prefix "elixir-ts-" + :group 'languages) + +(defcustom elixir-ts-indent-offset 2 + "Indentation of Elixir statements." + :version "30.1" + :type 'integer + :safe 'integerp + :group 'elixir-ts) + +(defface elixir-ts-font-comment-doc-identifier-face + '((t (:inherit font-lock-doc-face))) + "Face used for @comment.doc tags in Elixir files.") + +(defface elixir-ts-font-comment-doc-attribute-face + '((t (:inherit font-lock-doc-face))) + "Face used for @comment.doc.__attribute__ tags in Elixir files.") + +(defface elixir-ts-font-sigil-name-face + '((t (:inherit font-lock-string-face))) + "Face used for @__name__ tags in Elixir files.") + +(defconst elixir-ts--sexp-regexp + (rx bol + (or "call" "stab_clause" "binary_operator" "list" "tuple" "map" "pair" + "sigil" "string" "atom" "alias" "arguments" "identifier" + "boolean" "quoted_content") + eol)) + +(defconst elixir-ts--test-definition-keywords + '("describe" "test")) + +(defconst elixir-ts--definition-keywords + '("def" "defdelegate" "defexception" "defguard" "defguardp" + "defimpl" "defmacro" "defmacrop" "defmodule" "defn" "defnp" + "defoverridable" "defp" "defprotocol" "defstruct")) + +(defconst elixir-ts--definition-keywords-re + (concat "^" (regexp-opt elixir-ts--definition-keywords) "$")) + +(defconst elixir-ts--kernel-keywords + '("alias" "case" "cond" "else" "for" "if" "import" "quote" + "raise" "receive" "require" "reraise" "super" "throw" "try" + "unless" "unquote" "unquote_splicing" "use" "with")) + +(defconst elixir-ts--kernel-keywords-re + (concat "^" (regexp-opt elixir-ts--kernel-keywords) "$")) + +(defconst elixir-ts--builtin-keywords + '("__MODULE__" "__DIR__" "__ENV__" "__CALLER__" "__STACKTRACE__")) + +(defconst elixir-ts--builtin-keywords-re + (concat "^" (regexp-opt elixir-ts--builtin-keywords) "$")) + +(defconst elixir-ts--doc-keywords + '("moduledoc" "typedoc" "doc")) + +(defconst elixir-ts--doc-keywords-re + (concat "^" (regexp-opt elixir-ts--doc-keywords) "$")) + +(defconst elixir-ts--reserved-keywords + '("when" "and" "or" "not" "in" + "not in" "fn" "do" "end" "catch" "rescue" "after" "else")) + +(defconst elixir-ts--reserved-keywords-re + (concat "^" (regexp-opt elixir-ts--reserved-keywords) "$")) + +(defconst elixir-ts--reserved-keywords-vector + (apply #'vector elixir-ts--reserved-keywords)) + +(defvar elixir-ts--capture-anonymous-function-end + (when (treesit-available-p) + (treesit-query-compile 'elixir '((anonymous_function "end" @end))))) + +(defvar elixir-ts--capture-operator-parent + (when (treesit-available-p) + (treesit-query-compile 'elixir '((binary_operator operator: _ @val))))) + +(defvar elixir-ts--syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?| "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?* "." table) + (modify-syntax-entry ?/ "." table) + (modify-syntax-entry ?< "." table) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?_ "_" table) + (modify-syntax-entry ?? "w" table) + (modify-syntax-entry ?~ "w" table) + (modify-syntax-entry ?! "_" table) + (modify-syntax-entry ?' "\"" table) + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?# "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + (modify-syntax-entry ?\{ "(}" table) + (modify-syntax-entry ?\} "){" table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (modify-syntax-entry ?: "'" table) + (modify-syntax-entry ?@ "'" table) + table) + "Syntax table for `elixir-ts-mode'.") + +(defun elixir-ts--argument-indent-offset (node _parent &rest _) + "Return the argument offset position for NODE." + (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." + (let ((first-sibling (treesit-node-child parent 0 t))) + (if (and first-sibling (not (treesit-node-eq first-sibling node))) + (treesit-node-start first-sibling) + (elixir-ts--parent-expression-start node parent)))) + +(defun elixir-ts--parent-expression-start (_node parent &rest _) + "Return the indentation expression start for NODE and PARENT." + ;; If the parent is the first expression on the line return the + ;; parent start of node position, otherwise use the parent call + ;; start if available. + (if (eq (treesit-node-start parent) + (save-excursion + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point))) + (treesit-node-start parent) + (let ((expr-parent + (treesit-parent-until + parent + (lambda (n) + (member (treesit-node-type n) + '("call" "binary_operator" "keywords" "list")))))) + (save-excursion + (goto-char (treesit-node-start expr-parent)) + (back-to-indentation) + (if (looking-at "|>") + (point) + (treesit-node-start expr-parent)))))) + +(defvar elixir-ts--indent-rules + (let ((offset elixir-ts-indent-offset)) + `((elixir + ((parent-is "^source$") column-0 0) + ((parent-is "^string$") parent-bol 0) + ((parent-is "^quoted_content$") + (lambda (_n parent bol &rest _) + (save-excursion + (back-to-indentation) + (if (bolp) + (progn + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point)) + (point)))) + 0) + ((node-is "^|>$") parent-bol 0) + ((node-is "^|$") parent-bol 0) + ((node-is "^]$") ,'elixir-ts--parent-expression-start 0) + ((node-is "^}$") ,'elixir-ts--parent-expression-start 0) + ((node-is "^)$") ,'elixir-ts--parent-expression-start 0) + ((node-is "^else_block$") grand-parent 0) + ((node-is "^catch_block$") grand-parent 0) + ((node-is "^rescue_block$") grand-parent 0) + ((node-is "^after_block$") grand-parent 0) + ((parent-is "^else_block$") parent ,offset) + ((parent-is "^catch_block$") parent ,offset) + ((parent-is "^rescue_block$") parent ,offset) + ((parent-is "^rescue_block$") parent ,offset) + ((parent-is "^after_block$") parent ,offset) + ((parent-is "^access_call$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ((parent-is "^tuple$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ((parent-is "^list$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ((parent-is "^pair$") parent ,offset) + ((parent-is "^map_content$") parent-bol 0) + ((parent-is "^map$") ,'elixir-ts--parent-expression-start ,offset) + ((node-is "^stab_clause$") parent-bol ,offset) + ((query ,elixir-ts--capture-operator-parent) grand-parent 0) + ((node-is "^when$") parent 0) + ((node-is "^keywords$") parent-bol ,offset) + ((parent-is "^body$") + (lambda (node parent _) + (save-excursion + ;; The grammar adds a comment outside of the body, so we have to indent + ;; to the grand-parent if it is available. + (goto-char (treesit-node-start + (or (treesit-node-parent parent) (parent)))) + (back-to-indentation) + (point))) + ,offset) + ((parent-is "^arguments$") + ,'elixir-ts--argument-indent-anchor + ,'elixir-ts--argument-indent-offset) + ;; 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 ,offset) + ((node-is "^binary_operator$") + (lambda (node parent &rest _) + (let ((top-level + (treesit-parent-while + node + (lambda (node) + (equal (treesit-node-type node) + "binary_operator"))))) + (if (treesit-node-eq top-level node) + (elixir-ts--parent-expression-start node parent) + (treesit-node-start top-level)))) + (lambda (node parent _) + (cond + ((equal (treesit-node-type parent) "do_block") + ,offset) + ((equal (treesit-node-type parent) "binary_operator") + ,offset) + (t 0)))) + ((parent-is "^binary_operator$") + (lambda (node parent bol &rest _) + (treesit-node-start + (treesit-parent-while + parent + (lambda (node) + (equal (treesit-node-type node) "binary_operator"))))) + ,offset) + ((node-is "^pair$") first-sibling 0) + ((query ,elixir-ts--capture-anonymous-function-end) parent-bol 0) + ((node-is "^end$") standalone-parent 0) + ((parent-is "^do_block$") grand-parent ,offset) + ((parent-is "^anonymous_function$") + elixir-ts--treesit-anchor-grand-parent-bol ,offset) + ((parent-is "^else_block$") parent ,offset) + ((parent-is "^rescue_block$") parent ,offset) + ((parent-is "^catch_block$") parent ,offset) + ((parent-is "^keywords$") parent-bol 0) + ((node-is "^call$") parent-bol ,offset) + ((node-is "^comment$") parent-bol ,offset))))) + +(defvar elixir-ts--font-lock-settings + (treesit-font-lock-rules + :language 'elixir + :feature 'elixir-comment + '((comment) @font-lock-comment-face) + + :language 'elixir + :feature 'elixir-string + :override t + '([(string) (charlist)] @font-lock-string-face) + + :language 'elixir + :feature 'elixir-string-interpolation + :override t + '((string + [ + quoted_end: _ @font-lock-string-face + quoted_start: _ @font-lock-string-face + (quoted_content) @font-lock-string-face + (interpolation + "#{" @font-lock-regexp-grouping-backslash "}" + @font-lock-regexp-grouping-backslash) + ]) + (charlist + [ + quoted_end: _ @font-lock-string-face + quoted_start: _ @font-lock-string-face + (quoted_content) @font-lock-string-face + (interpolation + "#{" @font-lock-regexp-grouping-backslash "}" + @font-lock-regexp-grouping-backslash) + ])) + + :language 'elixir + :feature 'elixir-keyword + `(,elixir-ts--reserved-keywords-vector + @font-lock-keyword-face + (binary_operator + operator: _ @font-lock-keyword-face + (:match ,elixir-ts--reserved-keywords-re @font-lock-keyword-face))) + + :language 'elixir + :feature 'elixir-doc + :override t + `((unary_operator + operator: "@" @elixir-ts-font-comment-doc-attribute-face + operand: (call + target: (identifier) @elixir-ts-font-comment-doc-identifier-face + ;; Arguments can be optional, so adding another + ;; entry without arguments. + ;; If we don't handle then we don't apply font + ;; and the non doc fortification query will take specify + ;; a more specific font which takes precedence. + (arguments + [ + (string) @font-lock-doc-face + (charlist) @font-lock-doc-face + (sigil) @font-lock-doc-face + (boolean) @font-lock-doc-face + ])) + (:match ,elixir-ts--doc-keywords-re + @elixir-ts-font-comment-doc-identifier-face)) + (unary_operator + operator: "@" @elixir-ts-font-comment-doc-attribute-face + operand: (call + target: (identifier) @elixir-ts-font-comment-doc-identifier-face) + (:match ,elixir-ts--doc-keywords-re + @elixir-ts-font-comment-doc-identifier-face))) + + :language 'elixir + :feature 'elixir-unary-operator + `((unary_operator operator: "@" @font-lock-preprocessor-face + operand: [ + (identifier) @font-lock-preprocessor-face + (call target: (identifier) + @font-lock-preprocessor-face) + (boolean) @font-lock-preprocessor-face + (nil) @font-lock-preprocessor-face + ]) + + (unary_operator operator: "&") @font-lock-function-name-face + (operator_identifier) @font-lock-operator-face) + + :language 'elixir + :feature 'elixir-operator + '((binary_operator operator: _ @font-lock-operator-face) + (dot operator: _ @font-lock-operator-face) + (stab_clause operator: _ @font-lock-operator-face) + + [(boolean) (nil)] @font-lock-constant-face + [(integer) (float)] @font-lock-number-face + (alias) @font-lock-type-face + (call target: (dot left: (atom) @font-lock-type-face)) + (char) @font-lock-constant-face + [(atom) (quoted_atom)] @font-lock-type-face + [(keyword) (quoted_keyword)] @font-lock-builtin-face) + + :language 'elixir + :feature 'elixir-call + `((call + target: (identifier) @font-lock-keyword-face + (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face)) + (call + target: (identifier) @font-lock-keyword-face + (:match ,elixir-ts--kernel-keywords-re @font-lock-keyword-face)) + (call + target: [(identifier) @font-lock-function-name-face + (dot right: (identifier) @font-lock-keyword-face)]) + (call + target: (identifier) @font-lock-keyword-face + (arguments + [ + (identifier) @font-lock-keyword-face + (binary_operator + left: (identifier) @font-lock-keyword-face + operator: "when") + ]) + (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face)) + (call + target: (identifier) @font-lock-keyword-face + (arguments + (binary_operator + operator: "|>" + right: (identifier))) + (:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face))) + + :language 'elixir + :feature 'elixir-constant + `((binary_operator operator: "|>" right: (identifier) + @font-lock-function-name-face) + ((identifier) @font-lock-keyword-face + (:match ,elixir-ts--builtin-keywords-re + @font-lock-keyword-face)) + ((identifier) @font-lock-comment-face + (:match "^_" @font-lock-comment-face)) + (identifier) @font-lock-function-name-face + ["%"] @font-lock-keyward-face + ["," ";"] @font-lock-keyword-face + ["(" ")" "[" "]" "{" "}" "<<" ">>"] @font-lock-keyword-face) + + :language 'elixir + :feature 'elixir-sigil + :override t + `((sigil + (sigil_name) @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 + (:match "^[rR]$" @elixir-ts-font-sigil-name-face)) + @font-lock-regexp-face + (sigil + "~" @font-lock-string-face + (sigil_name) @elixir-ts-font-sigil-name-face + quoted_start: _ @font-lock-string-face + quoted_end: _ @font-lock-string-face + (:match "^[HF]$" @elixir-ts-font-sigil-name-face))) + + :language 'elixir + :feature 'elixir-string-escape + :override t + `((escape_sequence) @font-lock-regexp-grouping-backslash)) + "Tree-sitter font-lock settings.") + +(defvar elixir-ts--treesit-range-rules + (when (treesit-available-p) + (treesit-range-rules + :embed 'heex + :host 'elixir + '((sigil (sigil_name) @name (:match "^[HF]$" @name) (quoted_content) @heex))))) + +(defvar heex-ts--sexp-regexp) +(defvar heex-ts--indent-rules) +(defvar heex-ts--font-lock-settings) + +(defun elixir-ts--forward-sexp (&optional arg) + "Move forward across one balanced expression (sexp). +With ARG, do it many times. Negative ARG means move backward." + (or arg (setq arg 1)) + (funcall + (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing) + (if (eq (treesit-language-at (point)) 'heex) + heex-ts--sexp-regexp + elixir-ts--sexp-regexp) + (abs arg))) + +(defun elixir-ts--treesit-anchor-grand-parent-bol (_n parent &rest _) + "Return the beginning of non-space characters for the parent node of PARENT." + (save-excursion + (goto-char (treesit-node-start (treesit-node-parent parent))) + (back-to-indentation) + (point))) + +(defun elixir-ts--treesit-language-at-point (point) + "Return the language at POINT." + (let* ((range nil) + (language-in-range + (cl-loop + for parser in (treesit-parser-list) + do (setq range + (cl-loop + for range in (treesit-parser-included-ranges parser) + if (and (>= point (car range)) (<= point (cdr range))) + return parser)) + if range + return (treesit-parser-language parser)))) + (if (null language-in-range) + (when-let ((parser (car (treesit-parser-list)))) + (treesit-parser-language parser)) + language-in-range))) + +(defun elixir-ts--defun-p (node) + "Return non-nil when NODE is a defun." + (member (treesit-node-text + (treesit-node-child-by-field-name node "target")) + (append + elixir-ts--definition-keywords + elixir-ts--test-definition-keywords))) + +(defun elixir-ts--defun-name (node) + "Return the name of the defun NODE. +Return nil if NODE is not a defun node or doesn't have a name." + (pcase (treesit-node-type node) + ("call" (let ((node-child + (treesit-node-child (treesit-node-child node 1) 0))) + (pcase (treesit-node-type node-child) + ("alias" (treesit-node-text node-child t)) + ("call" (treesit-node-text + (treesit-node-child-by-field-name node-child "target") t)) + ("binary_operator" + (treesit-node-text + (treesit-node-child-by-field-name + (treesit-node-child-by-field-name node-child "left") "target") + t)) + ("identifier" + (treesit-node-text node-child t)) + (_ 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. + (setq-local comment-start "# ") + (setq-local comment-start-skip + (rx "#" (* (syntax whitespace)))) + + (setq-local comment-end "") + (setq-local comment-end-skip + (rx (* (syntax whitespace)) + (group (or (syntax comment-end) "\n")))) + + ;; 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. + (when (treesit-ready-p 'heex) + ;; Require heex-ts-mode only when we load elixir-ts-mode + ;; so that we don't get a tree-sitter compilation warning for + ;; elixir-ts-mode. + (require 'heex-ts-mode) + (treesit-parser-create 'heex)) + + (treesit-parser-create 'elixir) + + (setq-local treesit-language-at-point-function + 'elixir-ts--treesit-language-at-point) + + ;; Font-lock. + (setq-local treesit-font-lock-settings elixir-ts--font-lock-settings) + (setq-local treesit-font-lock-feature-list + '(( elixir-comment elixir-constant elixir-doc ) + ( elixir-string elixir-keyword elixir-unary-operator + elixir-call elixir-operator ) + ( elixir-sigil elixir-string-escape elixir-string-interpolation))) + + ;; Imenu. + (setq-local treesit-simple-imenu-settings + '((nil "\\`call\\'" elixir-ts--defun-p nil))) + + ;; Indent. + (setq-local treesit-simple-indent-rules elixir-ts--indent-rules) + + ;; 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. + (when (treesit-ready-p 'heex) + (setq-local treesit-range-settings elixir-ts--treesit-range-rules) + + (setq-local treesit-simple-indent-rules + (append treesit-simple-indent-rules heex-ts--indent-rules)) + + (setq-local treesit-font-lock-settings + (append treesit-font-lock-settings + heex-ts--font-lock-settings)) + + (setq-local treesit-simple-indent-rules + (append treesit-simple-indent-rules + heex-ts--indent-rules)) + + (setq-local treesit-font-lock-feature-list + '(( elixir-comment elixir-constant elixir-doc + heex-comment heex-keyword heex-doctype ) + ( elixir-string elixir-keyword elixir-unary-operator + elixir-call elixir-operator + heex-component heex-tag heex-attribute heex-string) + ( elixir-sigil elixir-string-escape + elixir-string-interpolation )))) + + (treesit-major-mode-setup) + (setq-local syntax-propertize-function #'elixir-ts--syntax-propertize))) + +(if (treesit-ready-p 'elixir) + (progn + (add-to-list 'auto-mode-alist '("\\.elixir\\'" . elixir-ts-mode)) + (add-to-list 'auto-mode-alist '("\\.ex\\'" . elixir-ts-mode)) + (add-to-list 'auto-mode-alist '("\\.exs\\'" . elixir-ts-mode)) + (add-to-list 'auto-mode-alist '("mix\\.lock" . elixir-ts-mode)))) + +(provide 'elixir-ts-mode) + +;;; elixir-ts-mode.el ends here diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 6f293acca5e..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 @@ -1635,6 +1715,7 @@ buffer." (define-derived-mode flymake-diagnostics-buffer-mode tabulated-list-mode "Flymake diagnostics" "A mode for listing Flymake diagnostics." + :interactive nil (setq tabulated-list-format flymake--diagnostics-base-tabulated-list-format) (setq tabulated-list-entries 'flymake--diagnostics-buffer-entries) @@ -1692,6 +1773,7 @@ some of this variable's contents the diagnostic listings.") (define-derived-mode flymake-project-diagnostics-mode tabulated-list-mode "Flymake diagnostics" "A mode for listing Flymake diagnostics." + :interactive nil (setq tabulated-list-format (vconcat [("File" 25 t)] flymake--diagnostics-base-tabulated-list-format)) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 8db16729163..060957eac29 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1167,13 +1167,13 @@ no input, and GDB is waiting for input." (process-live-p proc) (not gud-running) (= (point) (marker-position (process-mark proc)))) - ;; Sending an EOF does not work with GDB-MI; submit an - ;; explicit quit command. - (progn - (if (> gdb-control-level 0) - (process-send-eof proc) - (insert "quit") - (comint-send-input t t))) + ;; Exit a recursive reading loop or quit. + (if (> gdb-control-level 0) + (process-send-eof proc) + ;; Sending an EOF does not work with GDB-MI; submit an + ;; explicit quit command. + (insert "quit") + (comint-send-input t t)) (delete-char arg)))) (defvar gdb-define-alist nil "Alist of #define directives for GUD tooltips.") @@ -4404,6 +4404,24 @@ member." :group 'gud :version "29.1") +(defcustom gdb-locals-table-row-config `((name . 20) + (type . 20) + (value . ,gdb-locals-value-limit)) + "Configuration for table rows in the local variable display. + +An alist that controls the display of the name, type and value of +local variables inside the currently active stack-frame. The key +controls which column to change whereas the value determines the +maximum number of characters to display in each column. A value +of 0 means there is no limit. + +Additionally, the order the element in the alist determines the +left-to-right display order of the properties." + :type '(alist :key-type symbol :value-type integer) + :group 'gud + :version "30.1") + + (defvar gdb-locals-values-table (make-hash-table :test #'equal) "Mapping of local variable names to a string with their value.") @@ -4433,12 +4451,9 @@ member." (defun gdb-locals-value-filter (value) "Filter function for the local variable VALUE." - (let* ((no-nl (replace-regexp-in-string "\n" " " value)) - (str (replace-regexp-in-string "[[:space:]]+" " " no-nl)) - (limit gdb-locals-value-limit)) - (if (>= (length str) limit) - (concat (substring str 0 limit) "...") - str))) + (let* ((no-nl (replace-regexp-in-string "\n" " " (or value "<Unknown>"))) + (str (replace-regexp-in-string "[[:space:]]+" " " no-nl))) + str)) (defun gdb-edit-locals-value (&optional event) "Assign a value to a variable displayed in the locals buffer." @@ -4452,6 +4467,22 @@ member." (gud-basic-call (concat "-gdb-set variable " var " = " value))))) + +(defun gdb-locals-table-columns-list (alist) + "Format and arrange the columns in locals display based on ALIST." + (let (columns) + (dolist (config gdb-locals-table-row-config columns) + (let* ((key (car config)) + (max (cdr config)) + (prop (alist-get key alist))) + (when prop + (if (and (> max 0) (length> prop max)) + (push (propertize (string-truncate-left prop max) 'help-echo prop) + columns) + (push prop columns))))) + (nreverse columns))) + + ;; Complex data types are looked up in `gdb-locals-values-table'. (defun gdb-locals-handler-custom () "Handler to rebuild the local variables table buffer." @@ -4480,12 +4511,14 @@ member." help-echo "mouse-2: edit value" local-map ,gdb-edit-locals-map-1) value)) + (setf (gdb-table-right-align table) t) + (setq name (propertize name 'font-lock-face font-lock-variable-name-face)) + (setq type (propertize type 'font-lock-face font-lock-type-face)) (gdb-table-add-row table - (list - (propertize type 'font-lock-face font-lock-type-face) - (propertize name 'font-lock-face font-lock-variable-name-face) - value) + (gdb-locals-table-columns-list `((name . ,name) + (type . ,type) + (value . ,value))) `(gdb-local-variable ,local)))) (insert (gdb-table-string table " ")) (setq mode-name @@ -5173,6 +5206,8 @@ This arrangement depends on the values of variable (defun gdb-reset () "Exit a debugging session cleanly. Kills the gdb buffers, and resets variables and the source buffers." + ;; Save GDB history + (comint-write-input-ring) ;; The gdb-inferior buffer has a pty hooked up to the main gdb ;; process. This pty must be deleted explicitly. (let ((pty (get-process "gdb-inferior"))) diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el index 77c97ffac11..fda6a36e42d 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -35,6 +35,7 @@ (declare-function treesit-node-child "treesit.c") (declare-function treesit-node-child-by-field-name "treesit.c") (declare-function treesit-node-start "treesit.c") +(declare-function treesit-node-end "treesit.c") (declare-function treesit-node-type "treesit.c") (declare-function treesit-search-subtree "treesit.c") @@ -196,9 +197,16 @@ '((ERROR) @font-lock-warning-face)) "Tree-sitter font-lock settings for `go-ts-mode'.") +(defvar-keymap go-ts-mode-map + :doc "Keymap used in Go mode, powered by tree-sitter" + :parent prog-mode-map + "C-c C-d" #'go-ts-mode-docstring) + ;;;###autoload (define-derived-mode go-ts-mode prog-mode "Go" - "Major mode for editing Go, powered by tree-sitter." + "Major mode for editing Go, powered by tree-sitter. + +\\{go-ts-mode-map}" :group 'go :syntax-table go-ts-mode--syntax-table @@ -247,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 @@ -258,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 @@ -295,6 +303,32 @@ Return nil if there is no name or if NODE is not a defun node." (not (go-ts-mode--struct-node-p node)) (not (go-ts-mode--alias-node-p node)))) +(defun go-ts-mode-docstring () + "Add a docstring comment for the current defun. +The added docstring is prefilled with the defun's name. If the +comment already exists, jump to it." + (interactive) + (when-let ((defun-node (treesit-defun-at-point))) + (goto-char (treesit-node-start defun-node)) + (if (go-ts-mode--comment-on-previous-line-p) + ;; go to top comment line + (while (go-ts-mode--comment-on-previous-line-p) + (forward-line -1)) + (insert "// " (go-ts-mode--defun-name defun-node t)) + (newline) + (backward-char)))) + +(defun go-ts-mode--comment-on-previous-line-p () + "Return t if the previous line is a comment." + (when-let ((point (- (pos-bol) 1)) + ((> point 0)) + (node (treesit-node-at point))) + (and + ;; check point is actually inside the found node + ;; treesit-node-at can return nodes after point + (<= (treesit-node-start node) point (treesit-node-end node)) + (string-equal "comment" (treesit-node-type node))))) + ;; go.mod support. (defvar go-mod-ts-mode--syntax-table diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 0da16b44dda..82e9c5d8edf 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -457,6 +457,33 @@ buffer `default-directory'." :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) +(defcustom grep-use-headings nil + "If non-nil, subdivide grep output into sections, one per file." + :type 'boolean + :version "30.1") + +(defface grep-heading `((t :inherit ,grep-hit-face)) + "Face of headings when `grep-use-headings' is non-nil." + :version "30.1") + +(defvar grep-heading-regexp + (rx bol + (or + (group-n 2 + (group-n 1 (+ (not (any 0 ?\n)))) + 0) + (group-n 2 + (group-n 1 (+? nonl)) + (any ?: ?- ?=))) + (+ digit) + (any ?: ?- ?=)) + "Regexp used to create headings from grep output lines. +It should be anchored at beginning of line. The first capture +group, if present, should match the heading associated to the +line. The buffer range of the second capture, if present, is +made invisible (presumably because displaying it would be +redundant).") + (defvar grep-find-abbreviate-properties (let ((ellipsis (if (char-displayable-p ?…) "[…]" "[...]")) (map (make-sparse-keymap))) @@ -612,6 +639,40 @@ This function is called from `compilation-filter-hook'." (while (re-search-forward "\033\\[[0-9;]*[mK]" end 1) (replace-match "" t t)))))) +(defvar grep--heading-format + (eval-when-compile + (let ((title (propertize "%s" + 'font-lock-face 'grep-heading + 'outline-level 1))) + (propertize (concat title "\n") 'compilation-annotation t))) + "Format string of grep headings. +This is passed to `format' with one argument, the text of the +first capture group of `grep-heading-regexp'.") + +(defvar-local grep--heading-state nil + "Variable to keep track of the `grep--heading-filter' state.") + +(defun grep--heading-filter () + "Filter function to add headings to output of a grep process." + (unless grep--heading-state + (setq grep--heading-state (cons (point-min-marker) nil))) + (save-excursion + (let ((limit (car grep--heading-state))) + ;; Move point to the old limit and update limit marker. + (move-marker limit (prog1 (pos-bol) (goto-char limit))) + (while (re-search-forward grep-heading-regexp limit t) + (unless (get-text-property (point) 'compilation-annotation) + (let ((heading (match-string-no-properties 1)) + (start (match-beginning 2)) + (end (match-end 2))) + (when start + (put-text-property start end 'invisible t)) + (when (and heading (not (equal heading (cdr grep--heading-state)))) + (save-excursion + (goto-char (pos-bol)) + (insert-before-markers (format grep--heading-format heading))) + (setf (cdr grep--heading-state) heading)))))))) + (defun grep-probe (command args &optional func result) (let (process-file-side-effects) (equal (condition-case nil @@ -906,6 +967,11 @@ The value depends on `grep-command', `grep-template', (add-function :filter-return (local 'kill-transform-function) (lambda (string) (string-replace "\0" ":" string))) + (when grep-use-headings + (add-hook 'compilation-filter-hook #'grep--heading-filter 80 t) + (setq-local outline-search-function #'outline-search-level + outline-level (lambda () (get-text-property + (point) 'outline-level)))) (add-hook 'compilation-filter-hook #'grep-filter nil t)) (defun grep--save-buffers () diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 3b792354cbc..d5c8e37a37b 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -135,9 +135,9 @@ Used to gray out relevant toolbar icons.") (defun gud-goto-info () "Go to relevant Emacs info node." (interactive) - (if (eq gud-minor-mode 'gdbmi) - (info-other-window "(emacs)GDB Graphical Interface") - (info-other-window "(emacs)Debuggers"))) + (info-other-window (if (eq gud-minor-mode 'gdbmi) + "(emacs)GDB Graphical Interface" + "(emacs)Debuggers"))) (defun gud-tool-bar-item-visible-no-fringe () (not (or (eq (buffer-local-value 'major-mode (window-buffer)) 'speedbar-mode) @@ -159,143 +159,145 @@ Used to gray out relevant toolbar icons.") (t (comint-interrupt-subjob))))) -(easy-mmode-defmap gud-menu-map - '(([help] "Info (debugger)" . gud-goto-info) - ([tooltips] menu-item "Show GUD tooltips" gud-tooltip-mode - :enable (and (not emacs-basic-display) - (display-graphic-p) - (fboundp 'x-show-tip)) - :visible (memq gud-minor-mode - '(gdbmi guiler dbx sdb xdb pdb)) - :button (:toggle . gud-tooltip-mode)) - ([refresh] "Refresh" . gud-refresh) - ([run] menu-item "Run" gud-run - :enable (not gud-running) - :visible (or (memq gud-minor-mode '(gdb dbx jdb)) - (and (eq gud-minor-mode 'gdbmi) - (or (not (gdb-show-run-p)) - (bound-and-true-p - gdb-active-process))))) - ([go] . (menu-item (if (bound-and-true-p gdb-active-process) - "Continue" "Run") - gud-go - :visible (and (eq gud-minor-mode 'gdbmi) - (gdb-show-run-p)))) - ([stop] menu-item "Stop" gud-stop-subjob - :visible (or (not (memq gud-minor-mode '(gdbmi pdb))) - (and (eq gud-minor-mode 'gdbmi) - (gdb-show-stop-p)))) - ([until] menu-item "Continue to selection" gud-until - :enable (not gud-running) - :visible (and (memq gud-minor-mode '(gdbmi gdb perldb)) - (gud-tool-bar-item-visible-no-fringe))) - ([remove] menu-item "Remove Breakpoint" gud-remove - :enable (not gud-running) - :visible (gud-tool-bar-item-visible-no-fringe)) - ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak - :enable (not gud-running) - :visible (memq gud-minor-mode - '(gdbmi gdb sdb xdb))) - ([break] menu-item "Set Breakpoint" gud-break - :enable (not gud-running) - :visible (gud-tool-bar-item-visible-no-fringe)) - ([up] menu-item "Up Stack" gud-up - :enable (not gud-running) - :visible (memq gud-minor-mode - '(gdbmi gdb guiler dbx xdb jdb pdb))) - ([down] menu-item "Down Stack" gud-down - :enable (not gud-running) - :visible (memq gud-minor-mode - '(gdbmi gdb guiler dbx xdb jdb pdb))) - ([pp] menu-item "Print S-expression" gud-pp - :enable (and (not gud-running) - (bound-and-true-p gdb-active-process)) - :visible (and (string-equal - (buffer-local-value - 'gud-target-name gud-comint-buffer) - "emacs") - (eq gud-minor-mode 'gdbmi))) - ([print*] . (menu-item (if (eq gud-minor-mode 'jdb) - "Dump object" - "Print Dereference") - gud-pstar - :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb jdb)))) - ([print] menu-item "Print Expression" gud-print - :enable (not gud-running)) - ([watch] menu-item "Watch Expression" gud-watch - :enable (not gud-running) - :visible (eq gud-minor-mode 'gdbmi)) - ([finish] menu-item "Finish Function" gud-finish - :enable (not gud-running) - :visible (memq gud-minor-mode - '(gdbmi gdb guiler xdb jdb pdb))) - ([stepi] menu-item "Step Instruction" gud-stepi - :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb dbx))) - ([nexti] menu-item "Next Instruction" gud-nexti - :enable (not gud-running) - :visible (memq gud-minor-mode '(gdbmi gdb dbx))) - ([step] menu-item "Step Line" gud-step - :enable (not gud-running)) - ([next] menu-item "Next Line" gud-next - :enable (not gud-running)) - ([cont] menu-item "Continue" gud-cont - :enable (not gud-running) - :visible (not (eq gud-minor-mode 'gdbmi)))) - "Menu for `gud-mode'." - :name "Gud") - -(easy-mmode-defmap gud-minor-mode-map - (append - `(([menu-bar debug] . ("Gud" . ,gud-menu-map))) - ;; Get tool bar like functionality from the menu bar on a text only - ;; terminal. - (unless window-system - `(([menu-bar down] - . (,(propertize "down" 'face 'font-lock-doc-face) . gud-down)) - ([menu-bar up] - . (,(propertize "up" 'face 'font-lock-doc-face) . gud-up)) - ([menu-bar finish] - . (,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish)) - ([menu-bar step] - . (,(propertize "step" 'face 'font-lock-doc-face) . gud-step)) - ([menu-bar next] - . (,(propertize "next" 'face 'font-lock-doc-face) . gud-next)) - ([menu-bar until] menu-item - ,(propertize "until" 'face 'font-lock-doc-face) gud-until - :visible (memq gud-minor-mode '(gdbmi gdb perldb))) - ([menu-bar cont] menu-item - ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont - :visible (not (eq gud-minor-mode 'gdbmi))) - ([menu-bar run] menu-item - ,(propertize "run" 'face 'font-lock-doc-face) gud-run - :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) - ([menu-bar go] menu-item - ,(propertize " go " 'face 'font-lock-doc-face) gud-go - :visible (and (eq gud-minor-mode 'gdbmi) - (gdb-show-run-p))) - ([menu-bar stop] menu-item - ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob - :visible (or (and (eq gud-minor-mode 'gdbmi) - (gdb-show-stop-p)) - (not (eq gud-minor-mode 'gdbmi)))) - ([menu-bar print] - . (,(propertize "print" 'face 'font-lock-doc-face) . gud-print)) - ([menu-bar tools] . undefined) - ([menu-bar buffer] . undefined) - ([menu-bar options] . undefined) - ([menu-bar edit] . undefined) - ([menu-bar file] . undefined)))) - "Map used in visited files.") - -(setf (alist-get 'gud-minor-mode minor-mode-map-alist) - gud-minor-mode-map) +(defvar-keymap gud-text-menu-bar-map + :doc "Menu-bar keymap used in GUD buffers on text frames." + ;; Use the menu-bar as a pseudo-tool-bar. + "<down>" `(,(propertize "down" 'face 'font-lock-doc-face) . gud-down) + "<up>" `(,(propertize "up" 'face 'font-lock-doc-face) . gud-up) + "<finish>" `(,(propertize "finish" 'face 'font-lock-doc-face) . gud-finish) + "<step>" `(,(propertize "step" 'face 'font-lock-doc-face) . gud-step) + "<next>" `(,(propertize "next" 'face 'font-lock-doc-face) . gud-next) + "<until>" `(menu-item + ,(propertize "until" 'face 'font-lock-doc-face) gud-until + :visible (memq gud-minor-mode '(gdbmi gdb perldb))) + "<cont>" `(menu-item + ,(propertize "cont" 'face 'font-lock-doc-face) gud-cont + :visible (not (eq gud-minor-mode 'gdbmi))) + "<run>" `(menu-item + ,(propertize "run" 'face 'font-lock-doc-face) gud-run + :visible (memq gud-minor-mode '(gdbmi gdb dbx jdb))) + "<go>" `(menu-bar-item + ,(propertize " go " 'face 'font-lock-doc-face) gud-go + :visible (and (eq gud-minor-mode 'gdbmi) + (gdb-show-run-p))) + "<stop>" `(menu-item + ,(propertize "stop" 'face 'font-lock-doc-face) gud-stop-subjob + :visible (or (and (eq gud-minor-mode 'gdbmi) + (gdb-show-stop-p)) + (not (eq gud-minor-mode 'gdbmi)))) + "<print>" `(,(propertize "print" 'face 'font-lock-doc-face) . gud-print) + ;; Hide the usual menus to make room. + "<tools>" #'undefined + "<buffer>" #'undefined + "<options>" #'undefined + "<edit>" #'undefined + "<file>" #'undefined) + +(defvar-keymap gud-menu-mode-map + :doc "Keymap shared between `gud-mode' and `gud-minor-mode'.") + +(defvar-keymap gud-mode-map + :doc "`gud-mode' keymap." + ;; BEWARE: `gud-mode-map' does not inherit from something like + ;; `gud-menu-mode-map' because the `gud-mode' buffer is also in + ;; `gud-minor-mode'. + ;;:parent (make-composed-keymap gud-menu-mode-map comint-mode-map) + ) -(defvar gud-mode-map - ;; Will inherit from comint-mode via define-derived-mode. - (make-sparse-keymap) - "`gud-mode' keymap.") +(defvar-keymap gud-minor-mode-map + ;; Part of the menu is dynamic, so we use 2 keymaps: `gud-menu-mode-map' + ;; is the static/normal menu defined with easy-menu, and + ;; `gud-text-menu-bar-map' is the part that's only used on text frames. + ;; We then merge them here into `gud-minor-mode-map'. + :parent gud-menu-mode-map + "<menu-bar>" `(menu-item nil ,gud-text-menu-bar-map + ;; Be careful to return an empty keymap rather than nil + ;; so as not to hide the parent's menus. + :filter ,(lambda (map) (if window-system '(keymap) map)))) + +(easy-menu-define gud-menu-map gud-menu-mode-map + "Menu for `gud-mode'." + '("Gud" + ["Continue" gud-cont + :enable (not gud-running) + :visible (not (eq gud-minor-mode 'gdbmi))] + ["Next Line" gud-next + :enable (not gud-running)] + ["Step Line" gud-step + :enable (not gud-running)] + ["Next Instruction" gud-nexti + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdb dbx))] + ["Step Instruction" gud-stepi + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdb dbx))] + ["Finish Function" gud-finish + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdb guiler xdb jdb pdb))] + ["Watch Expression" gud-watch + :enable (not gud-running) + :visible (eq gud-minor-mode 'gdbmi)] + ["Print Expression" gud-print + :enable (not gud-running)] + ["Dump object-Derefenrece" gud-pstar + :label (if (eq gud-minor-mode 'jdb) + "Dump object" + "Print Dereference") + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdb jdb))] + ["Print S-expression" gud-pp + :enable (and (not gud-running) + (bound-and-true-p gdb-active-process)) + :visible (and (string-equal + (buffer-local-value + 'gud-target-name gud-comint-buffer) + "emacs") + (eq gud-minor-mode 'gdbmi))] + ["Down Stack" gud-down + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdb guiler dbx xdb jdb pdb))] + ["Up Stack" gud-up + :enable (not gud-running) + :visible (memq gud-minor-mode + '(gdbmi gdb guiler dbx xdb jdb pdb))] + ["Set Breakpoint" gud-break + :enable (not gud-running) + :visible (gud-tool-bar-item-visible-no-fringe)] + ["Temporary Breakpoint" gud-tbreak + :enable (not gud-running) + :visible (memq gud-minor-mode '(gdbmi gdb sdb xdb))] + ["Remove Breakpoint" gud-remove + :enable (not gud-running) + :visible (gud-tool-bar-item-visible-no-fringe)] + ["Continue to selection" gud-until + :enable (not gud-running) + :visible (and (memq gud-minor-mode '(gdbmi gdb perldb)) + (gud-tool-bar-item-visible-no-fringe))] + ["Stop" gud-stop-subjob + :visible (or (not (memq gud-minor-mode '(gdbmi pdb))) + (and (eq gud-minor-mode 'gdbmi) + (gdb-show-stop-p)))] + ["Continue-Run" gud-go + :label (if (bound-and-true-p gdb-active-process) + "Continue" "Run") + :visible (and (eq gud-minor-mode 'gdbmi) + (gdb-show-run-p))] + ["Run" gud-run + :enable (not gud-running) + :visible (or (memq gud-minor-mode '(gdb dbx jdb)) + (and (eq gud-minor-mode 'gdbmi) + (or (not (gdb-show-run-p)) + (bound-and-true-p + gdb-active-process))))] + ["Refresh" gud-refresh] + ["Show GUD tooltips" gud-tooltip-mode + :enable (and (not emacs-basic-display) + (display-graphic-p) + (fboundp 'x-show-tip)) + :visible (memq gud-minor-mode + '(gdbmi guiler dbx sdb xdb pdb)) + :button (:toggle . gud-tooltip-mode)] + ["Info (debugger)" gud-goto-info])) (setf (alist-get 'gud-minor-mode minor-mode-map-alist) gud-minor-mode-map) @@ -323,7 +325,7 @@ Used to gray out relevant toolbar icons.") (gud-goto-info . "info")) map) (tool-bar-local-item-from-menu - (car x) (cdr x) map gud-minor-mode-map)))) + (car x) (cdr x) map gud-menu-mode-map)))) (defvar gud-gdb-repeat-map (let ((map (make-sparse-keymap))) @@ -582,9 +584,9 @@ required by the caller." (value (nth 4 var)) (status (nth 5 var)) (has-more (nth 6 var))) (put-text-property - 0 (length expr) 'face font-lock-variable-name-face expr) + 0 (length expr) 'face 'font-lock-variable-name-face expr) (put-text-property - 0 (length type) 'face font-lock-type-face type) + 0 (length type) 'face 'font-lock-type-face type) (while (string-match "\\." varnum start) (setq depth (1+ depth) start (1+ (match-beginning 0)))) @@ -1307,7 +1309,7 @@ whereby $stopformat=1 produces an output format compatible with (define-key map key cmd)) (when (or gud-mips-p gud-irix-p) - (define-key map "f" 'gud-finish)) + (define-key map "f" #'gud-finish)) map) "Keymap to repeat `dbx' stepping instructions \\`C-x C-a C-n n n'. Used in `repeat-mode'.") @@ -3469,9 +3471,9 @@ class of the file (using s to separate nested class ids)." (defun gdb-script-font-lock-syntactic-face (state) (cond - ((nth 3 state) font-lock-string-face) - ((nth 7 state) font-lock-doc-face) - (t font-lock-comment-face))) + ((nth 3 state) 'font-lock-string-face) + ((nth 7 state) 'font-lock-doc-face) + (t 'font-lock-comment-face))) (defvar gdb-script-basic-indent 2) @@ -3502,7 +3504,7 @@ class of the file (using s to separate nested class ids)." (defun gdb-script-indent-line () "Indent current line of GDB script." (interactive) - (if (and (eq (get-text-property (point) 'face) font-lock-doc-face) + (if (and (eq (get-text-property (point) 'face) 'font-lock-doc-face) (save-excursion (forward-line 0) (skip-chars-forward " \t") diff --git a/lisp/progmodes/heex-ts-mode.el b/lisp/progmodes/heex-ts-mode.el new file mode 100644 index 00000000000..68a537b9229 --- /dev/null +++ b/lisp/progmodes/heex-ts-mode.el @@ -0,0 +1,185 @@ +;;; heex-ts-mode.el --- Major mode for Heex with tree-sitter support -*- lexical-binding: t; -*- + +;; Copyright (C) 2022-2023 Free Software Foundation, Inc. + +;; Author: Wilhelm H Kirschbaum <wkirschbaum@gmail.com> +;; Created: November 2022 +;; Keywords: elixir languages tree-sitter + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package provides `heex-ts-mode' which is a major mode for editing +;; HEEx files that uses Tree Sitter to parse the language. +;; +;; This package is compatible with and was tested against the tree-sitter grammar +;; for HEEx found at https://github.com/phoenixframework/tree-sitter-heex. + +;;; Code: + +(require 'treesit) +(eval-when-compile (require 'rx)) + +(declare-function treesit-parser-create "treesit.c") +(declare-function treesit-node-child "treesit.c") +(declare-function treesit-node-type "treesit.c") +(declare-function treesit-node-start "treesit.c") + +(defgroup heex-ts nil + "Major mode for editing HEEx code." + :prefix "heex-ts-" + :group 'langauges) + +(defcustom heex-ts-indent-offset 2 + "Indentation of HEEx statements." + :version "30.1" + :type 'integer + :safe 'integerp + :group 'heex-ts) + +(defconst heex-ts--sexp-regexp + (rx bol + (or "directive" "tag" "component" "slot" + "attribute" "attribute_value" "quoted_attribute_value") + eol)) + +;; There seems to be no parent directive block for tree-sitter-heex, +;; so we ignore them for now until we learn how to query them. +;; https://github.com/phoenixframework/tree-sitter-heex/issues/28 +(defvar heex-ts--indent-rules + (let ((offset heex-ts-indent-offset)) + `((heex + ((parent-is "fragment") + (lambda (node parent &rest _) + ;; If HEEx is embedded indent to parent + ;; otherwise indent to the bol. + (if (eq (treesit-language-at (point-min)) 'heex) + (point-min) + (save-excursion + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point)) + )) 0) + ((node-is "end_tag") parent-bol 0) + ((node-is "end_component") parent-bol 0) + ((node-is "end_slot") parent-bol 0) + ((node-is "/>") parent-bol 0) + ((node-is ">") parent-bol 0) + ((parent-is "comment") prev-adaptive-prefix 0) + ((parent-is "component") parent-bol ,offset) + ((parent-is "tag") parent-bol ,offset) + ((parent-is "start_tag") parent-bol ,offset) + ((parent-is "component") parent-bol ,offset) + ((parent-is "start_component") parent-bol ,offset) + ((parent-is "slot") parent-bol ,offset) + ((parent-is "start_slot") parent-bol ,offset) + ((parent-is "self_closing_tag") parent-bol ,offset) + (no-node parent-bol ,offset))))) + +(defvar heex-ts--font-lock-settings + (when (treesit-available-p) + (treesit-font-lock-rules + :language 'heex + :feature 'heex-comment + '((comment) @font-lock-comment-face) + :language 'heex + :feature 'heex-doctype + '((doctype) @font-lock-doc-face) + :language 'heex + :feature 'heex-tag + `([(tag_name) (slot_name)] @font-lock-function-name-face) + :language 'heex + :feature 'heex-attribute + `((attribute_name) @font-lock-variable-name-face) + :language 'heex + :feature 'heex-keyword + `((special_attribute_name) @font-lock-keyword-face) + :language 'heex + :feature 'heex-string + `([(attribute_value) (quoted_attribute_value)] @font-lock-constant-face) + :language 'heex + :feature 'heex-component + `([ + (component_name) @font-lock-function-name-face + (module) @font-lock-keyword-face + (function) @font-lock-keyword-face + "." @font-lock-keyword-face + ]))) + "Tree-sitter font-lock settings.") + +(defun heex-ts--defun-name (node) + "Return the name of the defun NODE. +Return nil if NODE is not a defun node or doesn't have a name." + (pcase (treesit-node-type node) + ((or "component" "slot" "tag") + (string-trim + (treesit-node-text + (treesit-node-child (treesit-node-child node 0) 1) nil))) + (_ nil))) + +(defun heex-ts--forward-sexp (&optional arg) + "Move forward across one balanced expression (sexp). +With ARG, do it many times. Negative ARG means move backward." + (or arg (setq arg 1)) + (funcall + (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing) + heex-ts--sexp-regexp + (abs arg))) + +;;;###autoload +(define-derived-mode heex-ts-mode html-mode "HEEx" + "Major mode for editing HEEx, powered by tree-sitter." + :group 'heex-ts + + (when (treesit-ready-p 'heex) + (treesit-parser-create 'heex) + + ;; Comments + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" "text"))) + + (setq-local forward-sexp-function #'heex-ts--forward-sexp) + + ;; Navigation. + (setq-local treesit-defun-type-regexp + (rx bol (or "component" "tag" "slot") eol)) + (setq-local treesit-defun-name-function #'heex-ts--defun-name) + + ;; Imenu + (setq-local treesit-simple-imenu-settings + '(("Component" "\\`component\\'" nil nil) + ("Slot" "\\`slot\\'" nil nil) + ("Tag" "\\`tag\\'" nil nil))) + + (setq-local treesit-font-lock-settings heex-ts--font-lock-settings) + + (setq-local treesit-simple-indent-rules heex-ts--indent-rules) + + (setq-local treesit-font-lock-feature-list + '(( heex-comment heex-keyword heex-doctype ) + ( heex-component heex-tag heex-attribute heex-string ) + () ())) + + (treesit-major-mode-setup))) + +(if (treesit-ready-p 'heex) + ;; Both .heex and the deprecated .leex files should work + ;; with the tree-sitter-heex grammar. + (add-to-list 'auto-mode-alist '("\\.[hl]?eex\\'" . heex-ts-mode))) + +(provide 'heex-ts-mode) +;;; heex-ts-mode.el ends here diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 30893638f0d..836db83c2f3 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -113,6 +113,7 @@ ;; Various floating point types and operations are also supported but the ;; actual precision is limited by the Emacs internal floating representation, ;; which is the C data type "double" or IEEE binary64 format. +;; C99 and GNU style variadic arguments support is completed in 2022/E. ;;; Code: @@ -392,8 +393,10 @@ If there is a marked region from START to END it only shows the symbols within." (add-hook 'after-revert-hook 'hif-after-revert-function) (defun hif-end-of-line () + "Find the end-point of line concatenation." (end-of-line) - (while (= (logand 1 (skip-chars-backward "\\\\")) 1) + (while (progn (skip-chars-backward " \t" (line-beginning-position)) + (= ?\\ (char-before))) (end-of-line 2))) (defun hif-merge-ifdef-region (start end) @@ -536,10 +539,10 @@ that form should be displayed.") ;;===%%SF%% parsing (Start) === ;;; The code that understands what ifs and ifdef in files look like. -(defconst hif-cpp-prefix "\\(^\\|\r\\)[ \t]*#[ \t]*") +(defconst hif-cpp-prefix "\\(^\\|\r\\)?[ \t]*#[ \t]*") (defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def")) (defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef")) -(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\(n?def\\)?[ \t]+")) +(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[ \t]+\\)")) (defconst hif-elif-regexp (concat hif-cpp-prefix "elif")) (defconst hif-else-regexp (concat hif-cpp-prefix "else")) (defconst hif-endif-regexp (concat hif-cpp-prefix "endif")) @@ -547,18 +550,23 @@ that form should be displayed.") (concat hif-ifx-regexp "\\|" hif-elif-regexp "\\|" hif-else-regexp "\\|" hif-endif-regexp)) (defconst hif-macro-expr-prefix-regexp - (concat hif-cpp-prefix "\\(if\\(n?def\\)?\\|elif\\|define\\)[ \t]+")) + (concat hif-cpp-prefix "\\(if(\\|if\\(n?def\\)?[ \t]+\\|elif\\|define[ \t]+\\)")) -(defconst hif-white-regexp "[ \t]*") +(defconst hif-line-concat "\\\\[ \t]*[\n\r]") +;; If `hif-white-regexp' is modified, `hif-tokenize' might need to be modified +;; accordingly. +(defconst hif-white-regexp (concat "\\(?:[ \t]\\|/\\*.*?\\*/" + "\\|\\(?:" hif-line-concat "\\)\\)*")) (defconst hif-define-regexp (concat hif-cpp-prefix "\\(define\\|undef\\)")) (defconst hif-id-regexp (concat "[[:alpha:]_][[:alnum:]_]*")) +(defconst hif-etc-regexp "\\.\\.\\.") (defconst hif-macroref-regexp (concat hif-white-regexp "\\(" hif-id-regexp "\\)" "\\(" "(" hif-white-regexp "\\(" hif-id-regexp "\\)?" hif-white-regexp "\\(" "," hif-white-regexp hif-id-regexp hif-white-regexp "\\)*" - "\\(\\.\\.\\.\\)?" hif-white-regexp + "\\(" "," hif-white-regexp "\\)?" "\\(" hif-etc-regexp "\\)?" hif-white-regexp ")" "\\)?" )) @@ -936,7 +944,11 @@ Assuming we've just performed a `hif-token-regexp' lookup." (defun hif-tokenize (start end) "Separate string between START and END into a list of tokens." (let ((token-list nil) - (white-regexp "[ \t]+") + ;; Similar to `hif-white-regexp' but keep the spaces if there are + (white-regexp (concat "\\(?:" + "\\([ \t]+\\)\\|/\\*.*?\\*/" + "\\|\\(?:" hif-line-concat "\\)" + "\\)*")) token) (setq hif-simple-token-only t) (with-syntax-table hide-ifdef-syntax-table @@ -956,29 +968,31 @@ Assuming we've just performed a `hif-token-regexp' lookup." (forward-char 2)) ((looking-at hif-string-literal-regexp) - (setq token (substring-no-properties (match-string 1))) + (setq token (match-string-no-properties 1)) (goto-char (match-end 0)) (when (looking-at white-regexp) - (add-text-properties 0 1 '(hif-space t) token) + (if (not (zerop (length (match-string-no-properties 1)))) + (add-text-properties 0 1 '(hif-space t) token)) (goto-char (match-end 0))) (push token token-list)) ((looking-at hif-token-regexp) (goto-char (match-end 0)) - (setq token (hif-strtok - (substring-no-properties (match-string 0)))) + (setq token (hif-strtok (match-string-no-properties 0))) (push token token-list) (when (looking-at white-regexp) - ;; We can't just append a space to the token string, otherwise - ;; `0xf0 ' ## `01' will become `0xf0 01' instead of the expected - ;; `0xf001', hence a standalone `hif-space' is placed instead. - (push 'hif-space token-list) + (if (not (zerop (length (match-string-no-properties 1)))) + ;; We can't just append a space to the token string, + ;; otherwise `0xf0 ' ## `01' will become `0xf0 01' instead + ;; of the expected `0xf001', hence a standalone `hif-space' + ;; is placed instead. + (push 'hif-space token-list)) (goto-char (match-end 0)))) ((looking-at "\r") ; Sometimes MS-Windows user will leave CR in (forward-char 1)) ; the source code. Let's not get stuck here. - (t (error "Bad #if expression: %s" (buffer-string))))))) + (t (error "Bad preprocessor expression: %s" (buffer-string))))))) (if (eq 'hif-space (car token-list)) (setq token-list (cdr token-list))) ;; remove trailing white space (nreverse token-list)))) @@ -1126,7 +1140,7 @@ this is to emulate the stringification behavior of C++ preprocessor." (and (eq (car remains) 'hif-space) (eq (cadr remains) 'hif-lparen) (setq remains (cdr remains))))) - ;; No argument, no invocation + ;; No argument list, no invocation tok ;; Argumented macro, get arguments and invoke it. ;; Dynamically bind `hif-token-list' and `hif-token' @@ -1369,8 +1383,9 @@ factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' | (parmlist nil) ; A "token" list of parameters, will later be parsed (parm nil)) - (while (or (not (eq (hif-nexttoken keep-space) 'hif-rparen)) - (/= nest 0)) + (while (and (or (not (eq (hif-nexttoken keep-space) 'hif-rparen)) + (/= nest 0)) + hif-token) (if (eq (car (last parm)) 'hif-comma) (setq parm nil)) (cond @@ -1384,6 +1399,8 @@ factor : `!' factor | `~' factor | `(' exprlist `)' | `defined(' id `)' | (setq parm nil))) (push hif-token parm)) + (if (equal parm '(hif-comma)) ;; missing the last argument + (setq parm '(nil))) (push (nreverse parm) parmlist) ; Okay even if PARM is nil (hif-nexttoken keep-space) ; Drop the `hif-rparen', get next token (nreverse parmlist))) @@ -1609,11 +1626,21 @@ and `+='...)." ;; no need to reassemble the list if no `##' presents l)) -(defun hif-delimit (lis atom) - (nconc (mapcan (lambda (l) (list l atom)) +(defun hif-delimit (lis elem) + (nconc (mapcan (lambda (l) (list l elem)) (butlast lis)) (last lis))) +(defun hif-delete-nth (n lst) + "Non-destructively delete the nth item from a list." + (if (zerop n) + (cdr lst) + ;; non-destructive + (let* ((duplst (copy-sequence lst)) + (node (nthcdr (1- n) duplst))) + (setcdr node (cddr node)) + duplst))) + ;; Perform token replacement: (defun hif-macro-supply-arguments (macro-name actual-parms) "Expand a macro call, replace ACTUAL-PARMS in the macro body." @@ -1633,49 +1660,160 @@ and `+='...)." ;; For each actual parameter, evaluate each one and associate it ;; with an actual parameter, put it into local table and finally ;; evaluate the macro body. - (if (setq etc (eq (car formal-parms) 'hif-etc)) + (if (setq etc (or (eq (car formal-parms) 'hif-etc) + (and (eq (car formal-parms) 'hif-etc-c99) 'c99))) ;; Take care of `hif-etc' first. Prefix `hif-comma' back if needed. (setq formal-parms (cdr formal-parms))) (setq formal-count (length formal-parms) actual-count (length actual-parms)) - (if (> formal-count actual-count) - (error "Too few parameters for macro %S" macro-name) - (if (< formal-count actual-count) - (or etc - (error "Too many parameters for macro %S" macro-name)))) + ;; Fix empty arguments applied + (if (and (= formal-count 1) + (null (car formal-parms))) + (setq formal-parms nil + formal-count (1- formal-count))) + (if (and (= actual-count 1) + (or (null (car actual-parms)) + ;; white space as the only argument + (equal '(hif-space) (car actual-parms)))) + (setq actual-parms nil + actual-count (1- actual-count))) + + ;; Basic error checking + (if etc + (if (eq etc 'c99) + (if (and (> formal-count 1) ; f(a,b,...) + (< actual-count formal-count)) + (error "C99 variadic argument macro %S need at least %d arguments" + macro-name formal-count)) + ;; GNU style variadic argument + (if (and (> formal-count 1) + (< actual-count (1- formal-count))) + (error "GNU variadic argument macro %S need at least %d arguments" + macro-name (1- formal-count)))) + (if (> formal-count actual-count) + (error "Too few parameters for macro %S; %d instead of %d" + macro-name actual-count formal-count) + (if (< formal-count actual-count) + (error "Too many parameters for macro %S; %d instead of %d" + macro-name actual-count formal-count)))) ;; Perform token replacement on the MACRO-BODY with the parameters - (while (setq formal (pop formal-parms)) - ;; Prevent repetitive substitution, thus cannot use `subst' - ;; for example: - ;; #define mac(a,b) (a+b) - ;; #define testmac mac(b,y) - ;; testmac should expand to (b+y): replace of argument a and b - ;; occurs simultaneously, not sequentially. If sequentially, - ;; according to the argument order, it will become: - ;; 1. formal parm #1 'a' replaced by actual parm 'b', thus (a+b) - ;; becomes (b+b) - ;; 2. formal parm #2 'b' replaced by actual parm 'y', thus (b+b) - ;; becomes (y+y). - (setq macro-body - ;; Unlike `subst', `substitute' replace only the top level - ;; instead of the whole tree; more importantly, it's not - ;; destructive. - (cl-substitute (if (and etc (null formal-parms)) - (hif-delimit actual-parms 'hif-comma) - (car actual-parms)) - formal macro-body)) - (setq actual-parms (cdr actual-parms))) - - ;; Replacement completed, stringifiy and concatenate the token list. - ;; Stringification happens must take place before flattening, otherwise - ;; only the first token will be stringified. - (setq macro-body - (flatten-tree (hif-token-stringification macro-body))) - - ;; Token concatenation happens here, keep single 'hif-space - (hif-keep-single (hif-token-concatenation macro-body) 'hif-space)))) + + ;; Every substituted argument in the macro-body must be in list form so + ;; that it won't again be substituted incorrectly in later iterations. + ;; Finally we will flatten the list to fix that. + (cl-loop + do + ;; Note that C99 '...' and GNU 'x...' allow empty match + (setq formal (pop formal-parms)) + ;; + ;; Prevent repetitive substitution, thus cannot use `subst' + ;; for example: + ;; #define mac(a,b) (a+b) + ;; #define testmac mac(b,y) + ;; testmac should expand to (b+y): replace of argument a and b + ;; occurs simultaneously, not sequentially. If sequentially, + ;; according to the argument order, it will become: + ;; 1. formal parm #1 'a' replaced by actual parm 'b', thus (a+b) + ;; becomes (b+b) + ;; 2. formal parm #2 'b' replaced by actual parm 'y', thus (b+b) + ;; becomes (y+y). + ;; Unlike `subst', `cl-substitute' replace only the top level + ;; instead of the whole tree; more importantly, it's not + ;; destructive. + ;; + (if (not (and (null formal-parms) etc)) + ;; One formal with one actual + (setq macro-body + (cl-substitute (car actual-parms) formal macro-body)) + ;; `formal-parms' used up, now take care of '...' + (cond + + ((eq etc 'c99) ; C99 __VA_ARGS__ style '...' + (when formal + (setq macro-body + (cl-substitute (car actual-parms) formal macro-body)) + ;; Now the whole __VA_ARGS__ represents the whole + ;; remaining actual params + (pop actual-parms)) + ;; Replace if __VA_ARGS__ presents: + ;; if yes, see if it's prefixed with ", ##" or not, + ;; if yes, remove the "##", then if actual-params is + ;; exhausted, remove the prefixed ',' as well. + ;; Prepare for destructive operation + (let ((rem-body (copy-sequence macro-body)) + new-body va left part) + ;; Find each __VA_ARGS__ and remove its immediate prefixed '##' + ;; and comma if presents and if `formal_param' is exhausted + (while (setq va (cl-position '__VA_ARGS__ rem-body)) + ;; Split REM-BODY @ __VA_ARGS__ into LEFT and right + (setq part nil) + (if (zerop va) + (setq left nil ; __VA_ARGS__ trimed + rem-body (cdr rem-body)) + (setq left rem-body + rem-body (cdr (nthcdr va rem-body))) ; _V_ removed + (setcdr (nthcdr va left) nil) ; now _V_ be the last in LEFT + ;; now LEFT=(, w? ## w? _V_) rem=(W X Y) where w = white space + (setq left (cdr (nreverse left)))) ; left=(w? ## w? ,) + + ;; Try to recognize w?##w? and remove ", ##" if found + ;; (remember head = __VA_ARGS__ is temporarily removed) + (while (and left (eq 'hif-space (car left))) ; skip whites + (setq part (cons 'hif-space part) + left (cdr left))) + + (if (eq (car left) 'hif-token-concat) ; match '##' + (if actual-parms + ;; Keep everything + (setq part (append part (cdr left))) + ;; `actual-params' exhausted, delete ',' if presents + (while (and left (eq 'hif-space (car left))) ; skip whites + (setq part (cons 'hif-space part) + left (cdr left))) + (setq part + (append part + (if (eq (car left) 'hif-comma) ; match ',' + (cdr left) + left)))) + ;; No immediate '##' found + (setq part (append part left))) + + ;; Insert __VA_ARGS__ as a list + (push (hif-delimit actual-parms 'hif-comma) part) + ;; Reverse `left' back + (setq left (nreverse part) + new-body (append new-body left))) + + ;; Replacement of __VA_ARGS__ done here, add rem-body back + (setq macro-body (append new-body rem-body) + actual-parms nil))) + + (etc ; GNU style '...', substitute last argument + (if (null actual-parms) + ;; Must be non-destructive otherwise the original function + ;; definition defined in `hide-ifdef-env' will be destroyed. + (setq macro-body (remove formal macro-body)) + (setq macro-body + (cl-substitute (hif-delimit actual-parms 'hif-comma) + formal macro-body) + actual-parms nil))) + + (t + (error "Interal error: impossible case.")))) + + (pop actual-parms) + while actual-parms) ; end cl-loop + + ;; Replacement completed, stringifiy and concatenate the token list. + ;; Stringification happens must take place before flattening, otherwise + ;; only the first token will be stringified. + (setq macro-body + (flatten-tree (hif-token-stringification macro-body)))) + + ;; Token concatenation happens here, keep single 'hif-space + (hif-keep-single (hif-token-concatenation macro-body) 'hif-space))) (defun hif-invoke (macro-name actual-parms) "Invoke a macro by expanding it, reparse macro-body and finally invoke it." @@ -1710,7 +1848,9 @@ and `+='...)." Do this when cursor is at the beginning of `regexp' (i.e. #ifX)." (let ((case-fold-search nil)) (save-excursion - (re-search-forward regexp) + (if (re-search-forward regexp) + (if (= ?\( (char-before)) ;; "#if(" found + (goto-char (1- (point))))) (let* ((curr-regexp (match-string 0)) (defined (string-match hif-ifxdef-regexp curr-regexp)) (negate (and defined @@ -1724,29 +1864,48 @@ Do this when cursor is at the beginning of `regexp' (i.e. #ifX)." (setq tokens (list 'hif-not tokens))) (hif-parse-exp tokens))))) +(defun hif-is-in-comment () + "Check if we're currently within a C(++) comment." + (or (nth 4 (syntax-ppss)) + (looking-at "/[/*]"))) + +(defun hif-search-ifX-regexp (hif-regexp &optional backward) + "Search for a valid ifX regexp defined in hideif." + (let ((start (point)) + (re-search-func (if backward + #'re-search-backward + #'re-search-forward)) + (limit (if backward (point-min) (point-max))) + found) + (while (and (setq found + (funcall re-search-func hif-regexp limit t)) + (hif-is-in-comment))) + ;; Jump to the pattern if found + (if found + (unless backward + (setq found + (goto-char (- (point) (length (match-string 0)))))) + (goto-char start)) + found)) + (defun hif-find-any-ifX () "Move to next #if..., or #ifndef, at point or after." ;; (message "find ifX at %d" (point)) - (prog1 - (re-search-forward hif-ifx-regexp (point-max) t) - (beginning-of-line))) - + (hif-search-ifX-regexp hif-ifx-regexp)) (defun hif-find-next-relevant () "Move to next #if..., #elif..., #else, or #endif, after the current line." ;; (message "hif-find-next-relevant at %d" (point)) (end-of-line) - ;; Avoid infinite recursion by only going to line-beginning if match found - (if (re-search-forward hif-ifx-else-endif-regexp (point-max) t) - (beginning-of-line))) + ;; Avoid infinite recursion by going to the pattern only if a match is found + (hif-search-ifX-regexp hif-ifx-else-endif-regexp)) (defun hif-find-previous-relevant () "Move to previous #if..., #else, or #endif, before the current line." ;; (message "hif-find-previous-relevant at %d" (point)) (beginning-of-line) - ;; Avoid infinite recursion by only going to line-beginning if match found - (if (re-search-backward hif-ifx-else-endif-regexp (point-min) t) - (beginning-of-line))) + ;; Avoid infinite recursion by going to the pattern only if a match is found + (hif-search-ifX-regexp hif-ifx-else-endif-regexp 't)) (defun hif-looking-at-ifX () @@ -1931,6 +2090,7 @@ Point is left unchanged." ((hif-looking-at-else) (setq else (point))) (t + (beginning-of-line) ; otherwise #endif line will be hidden (setq end (point))))) ;; If found #else, look for #endif. (when else @@ -1940,6 +2100,7 @@ Point is left unchanged." (hif-ifdef-to-endif)) (if (hif-looking-at-else) (error "Found two elses in a row? Broken!")) + (beginning-of-line) ; otherwise #endif line will be hidden (setq end (point))) ; (line-end-position) (hif-make-range start end else elif)))) @@ -2085,16 +2246,20 @@ Refer to `hide-ifdef-expand-reinclusion-guard' for more details." (eq (car def) 'hif-define-macro)) (let ((cdef (concat "#define " name)) (parmlist (cadr def)) - s) + p s etc) (setq def (caddr def)) ;; parmlist (when parmlist (setq cdef (concat cdef "(")) - (while (car parmlist) - (setq cdef (concat cdef (symbol-name (car parmlist)) - (if (cdr parmlist) ",")) + (if (setq etc (or (eq (setq p (car parmlist)) 'hif-etc) + (and (eq p 'hif-etc-c99) 'c99))) + (pop parmlist)) + (while (setq p (car parmlist)) + (setq cdef (concat cdef (symbol-name p) (if (cdr parmlist) ",")) parmlist (cdr parmlist))) - (setq cdef (concat cdef ")"))) + (setq cdef (concat cdef + (if etc (concat (if (eq etc 'c99) ",") "...")) + ")"))) (setq cdef (concat cdef " ")) ;; body (while def @@ -2221,25 +2386,38 @@ however, when this command is prefixed, it will display the error instead." result)))) (defun hif-parse-macro-arglist (str) - "Parse argument list formatted as `( arg1 [ , argn] [...] )'. + "Parse argument list formatted as `( arg1 [ , argn] [,] [...] )'. The `...' is also included. Return a list of the arguments, if `...' exists the first arg will be `hif-etc'." (let* ((hif-simple-token-only nil) ; Dynamic binding var for `hif-tokenize' (tokenlist (cdr (hif-tokenize (- (point) (length str)) (point)))) ; Remove `hif-lparen' - etc result token) - (while (not (eq (setq token (pop tokenlist)) 'hif-rparen)) + etc result token prevtok prev2tok) + (while (not (eq (setq prev2tok prevtok + prevtok token + token (pop tokenlist)) 'hif-rparen)) (cond ((eq token 'hif-etc) - (setq etc t)) + ;; GNU type "..." or C99 type + (setq etc (if (or (null prevtok) + (eq prevtok 'hif-comma) + (and (eq prevtok 'hif-space) + (eq prev2tok 'hif-comma))) + 'c99 t))) ((eq token 'hif-comma) - t) + (if etc + (error "Syntax error: no comma allowed after `...'."))) (t (push token result)))) - (if etc - (cons 'hif-etc (nreverse result)) - (nreverse result)))) + (setq result (nreverse result)) + (cond + ((eq etc 'c99) + (cons 'hif-etc-c99 result)) + ((eq etc t) + (cons 'hif-etc result)) + (t + result)))) ;; The original version of hideif evaluates the macro early and store the ;; final values for the defined macro into the symbol database (aka @@ -2280,9 +2458,11 @@ first arg will be `hif-etc'." (let* ((defining (string= "define" (match-string 2))) (name (and (re-search-forward hif-macroref-regexp max t) (match-string 1))) - (parmlist (or (and (match-string 3) ; First arg id found + (parmlist (or (and (or (match-string 3) ; First arg id found + (match-string 6)) ; '...' found (delq 'hif-space - (hif-parse-macro-arglist (match-string 2)))) + (hif-parse-macro-arglist + (match-string 2)))) (and (match-string 2) ; empty arglist (list nil))))) (if defining @@ -2325,7 +2505,8 @@ first arg will be `hif-etc'." (expr (and tokens ;; `hif-simple-token-only' is checked only ;; here. - (or (and hif-simple-token-only + (or (and (null parmlist) + hif-simple-token-only (listp tokens) (= (length tokens) 1) (hif-parse-exp tokens)) @@ -2354,13 +2535,22 @@ first arg will be `hif-etc'." (save-excursion (save-restriction ;; (mark-region min max) ;; for debugging + (and min (goto-char min)) (setq hif-verbose-define-count 0) (forward-comment (point-max)) - (while (hif-find-define min max) - (forward-comment (point-max)) - (setf min (point))) + (setq min (point)) + (let ((breakloop nil)) + (while (and (not breakloop) + (hif-find-define min max)) + (forward-comment (point-max)) + (if (and max + (> (point) max)) + (setq max (point) + breakloop t)) + (setq min (point)))) (if max (goto-char max) - (goto-char (point-max)))))) + (goto-char (point-max)) + nil)))) (defun hide-ifdef-guts () "Does most of the work of `hide-ifdefs'. @@ -2376,7 +2566,7 @@ It does not do the work that's pointless to redo on a recursive entry." min max) (setq hif-__COUNTER__ 0) (goto-char (point-min)) - (setf min (point)) + (setq min (point)) ;; Without this `condition-case' it would be easier to see which ;; operation went wrong thru the backtrace `iff' user realize ;; the underlying meaning of all hif-* operation; for example, @@ -2384,11 +2574,11 @@ It does not do the work that's pointless to redo on a recursive entry." ;; operation arguments would be invalid. (condition-case err (cl-loop do - (setf max (hif-find-any-ifX)) - (hif-add-new-defines min max) + (setq max (hif-find-any-ifX)) + (setq max (hif-add-new-defines min max)) (if max (hif-possibly-hide expand-header)) - (setf min (point)) + (setq min (point)) while max) (error (error "Error: failed at line %d %S" (line-number-at-pos) err)))))) diff --git a/lisp/progmodes/java-ts-mode.el b/lisp/progmodes/java-ts-mode.el index fca00cdce4f..47d87112ffb 100644 --- a/lisp/progmodes/java-ts-mode.el +++ b/lisp/progmodes/java-ts-mode.el @@ -314,6 +314,11 @@ Return nil if there is no name or if NODE is not a defun node." ;; Comments. (c-ts-common-comment-setup) + (setq-local treesit-text-type-regexp + (regexp-opt '("line_comment" + "block_comment" + "text_block"))) + ;; Indent. (setq-local c-ts-common-indent-type-regexp-alist `((block . ,(rx (or "class_body" @@ -352,6 +357,29 @@ Return nil if there is no name or if NODE is not a defun node." "constructor_declaration"))) (setq-local treesit-defun-name-function #'java-ts-mode--defun-name) + (setq-local treesit-sentence-type-regexp + (regexp-opt '("statement" + "local_variable_declaration" + "field_declaration" + "module_declaration" + "package_declaration" + "import_declaration"))) + + (setq-local treesit-sexp-type-regexp + (regexp-opt '("annotation" + "parenthesized_expression" + "argument_list" + "identifier" + "modifiers" + "block" + "body" + "literal" + "access" + "reference" + "_type" + "true" + "false"))) + ;; Font-lock. (setq-local treesit-font-lock-settings java-ts-mode--font-lock-settings) (setq-local treesit-font-lock-feature-list diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 52ed19cc682..f68ecb6fa6c 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3801,6 +3801,54 @@ Currently there are `js-mode' and `js-ts-mode'." ;;(syntax-propertize (point-max)) ) +(defvar js--treesit-sentence-nodes + '("import_statement" + "debugger_statement" + "expression_statement" + "if_statement" + "switch_statement" + "for_statement" + "for_in_statement" + "while_statement" + "do_statement" + "try_statement" + "with_statement" + "break_statement" + "continue_statement" + "return_statement" + "throw_statement" + "empty_statement" + "labeled_statement" + "variable_declaration" + "lexical_declaration" + "jsx_element" + "jsx_self_closing_element") + "Nodes that designate sentences in JavaScript. +See `treesit-sentence-type-regexp' for more information.") + +(defvar js--treesit-sexp-nodes + '("expression" + "pattern" + "array" + "function" + "string" + "escape" + "template" + "regex" + "number" + "identifier" + "this" + "super" + "true" + "false" + "null" + "undefined" + "arguments" + "pair" + "jsx") + "Nodes that designate sexps in JavaScript. +See `treesit-sexp-type-regexp' for more information.") + ;;;###autoload (define-derived-mode js-ts-mode js-base-mode "JavaScript" "Major mode for editing JavaScript. @@ -3817,6 +3865,11 @@ Currently there are `js-mode' and `js-ts-mode'." ;; Comment. (c-ts-common-comment-setup) (setq-local comment-multi-line t) + + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" + "template_string"))) + ;; Electric-indent. (setq-local electric-indent-chars (append "{}():;,<>/" electric-indent-chars)) ;FIXME: js2-mode adds "[]*". @@ -3835,6 +3888,13 @@ Currently there are `js-mode' and `js-ts-mode'." "function_declaration" "lexical_declaration"))) (setq-local treesit-defun-name-function #'js--treesit-defun-name) + + (setq-local treesit-sentence-type-regexp + (regexp-opt js--treesit-sentence-nodes)) + + (setq-local treesit-sexp-type-regexp + (regexp-opt js--treesit-sexp-nodes)) + ;; Fontification. (setq-local treesit-font-lock-settings js--treesit-font-lock-settings) (setq-local treesit-font-lock-feature-list diff --git a/lisp/progmodes/json-ts-mode.el b/lisp/progmodes/json-ts-mode.el index 6272c0073e1..f56d118c0fe 100644 --- a/lisp/progmodes/json-ts-mode.el +++ b/lisp/progmodes/json-ts-mode.el @@ -147,6 +147,8 @@ Return nil if there is no name or if NODE is not a defun node." (rx (or "pair" "object"))) (setq-local treesit-defun-name-function #'json-ts-mode--defun-name) + (setq-local treesit-sentence-type-regexp "pair") + ;; Font-lock. (setq-local treesit-font-lock-settings json-ts-mode--font-lock-settings) (setq-local treesit-font-lock-feature-list 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/prog-mode.el b/lisp/progmodes/prog-mode.el index 0f3a477abe5..04071703184 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -30,7 +30,12 @@ ;;; Code: (eval-when-compile (require 'cl-lib) - (require 'subr-x)) + (require 'subr-x) + (require 'treesit)) + +(declare-function treesit-available-p "treesit.c") +(declare-function treesit-parser-list "treesit.c") +(declare-function treesit-node-type "treesit.c") (defgroup prog-mode nil "Generic programming mode, from which others derive." @@ -102,7 +107,8 @@ (defvar-keymap prog-mode-map :doc "Keymap used for programming modes." - "C-M-q" #'prog-indent-sexp) + "C-M-q" #'prog-indent-sexp + "M-q" #'prog-fill-reindent-defun) (defvar prog-indentation-context nil "When non-nil, provides context for indenting embedded code chunks. @@ -140,6 +146,31 @@ instead." (end (progn (forward-sexp 1) (point)))) (indent-region start end nil)))) +(defun prog-fill-reindent-defun (&optional argument) + "Refill or reindent the paragraph or defun that contains point. + +If the point is in a string or a comment, fill the paragraph that +contains point or follows point. + +Otherwise, reindent the function definition that contains point +or follows point." + (interactive "P") + (save-excursion + (let ((treesit-text-node + (and (treesit-available-p) + (treesit-parser-list) + (string-match-p + treesit-text-type-regexp + (treesit-node-type (treesit-node-at (point))))))) + (if (or treesit-text-node + (nth 8 (syntax-ppss)) + (re-search-forward "\\s-*\\s<" (line-end-position) t)) + (fill-paragraph argument (region-active-p)) + (beginning-of-defun) + (let ((start (point))) + (end-of-defun) + (indent-region start (point) nil)))))) + (defun prog-first-column () "Return the indentation column normally used for top-level constructs." (or (car prog-indentation-context) 0)) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index a18b918db62..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 @@ -1251,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) "*")) @@ -1264,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"))) @@ -1616,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")) @@ -1640,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." @@ -1827,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/ruby-mode.el b/lisp/progmodes/ruby-mode.el index b252826680c..e441ffbbfe3 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -1850,93 +1850,92 @@ For example: File.open See `add-log-current-defun-function'." - (condition-case nil - (save-excursion - (let* ((indent (ruby--add-log-current-indent)) - mname mlist - (start (point)) - (make-definition-re - (lambda (re &optional method-name?) - (concat "^[ \t]*" re "[ \t]+" - "\\(" - ;; \\. and :: for class methods - "\\([A-Za-z_]" ruby-symbol-re "*[?!]?" - "\\|" - (if method-name? ruby-operator-re "\\.") - "\\|::" "\\)" - "+\\)"))) - (definition-re (funcall make-definition-re ruby-defun-beg-re t)) - (module-re (funcall make-definition-re "\\(class\\|module\\)"))) - ;; Get the current method definition (or class/module). - (when (catch 'found - (while (and (re-search-backward definition-re nil t) - (if (if (string-equal "def" (match-string 1)) - ;; We're inside a method. - (if (ruby-block-contains-point (1- start)) - t - ;; Try to match a method only once. - (setq definition-re module-re) - nil) - ;; Class/module. For performance, - ;; comparing indentation. - (or (not (numberp indent)) - (> indent (current-indentation)))) - (throw 'found t) - t)))) - (goto-char (match-beginning 1)) - (if (not (string-equal "def" (match-string 1))) - (setq mlist (list (match-string 2))) - (setq mname (match-string 2))) - (setq indent (current-column)) - (beginning-of-line)) - ;; Walk up the class/module nesting. - (while (and indent - (> indent 0) - (re-search-backward module-re nil t)) - (goto-char (match-beginning 1)) - (when (< (current-column) indent) - (setq mlist (cons (match-string 2) mlist)) - (setq indent (current-column)) - (beginning-of-line))) - ;; Process the method name. - (when mname - (let ((mn (split-string mname "\\.\\|::"))) - (if (cdr mn) - (progn - (unless (string-equal "self" (car mn)) ; def self.foo - ;; def C.foo - (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)) - (setq ml (cdr ml)))) - (if mlist - (setcdr (last mlist) (butlast mn)) - (setq mlist (butlast mn)))) - (setq mname (concat "." (car (last mn))))) - ;; See if the method is in singleton class context. - (let ((in-singleton-class - (when (re-search-forward ruby-singleton-class-re start t) - (goto-char (match-beginning 0)) - ;; FIXME: Optimize it out, too? - ;; This can be slow in a large file, but - ;; unlike class/module declaration - ;; indentations, method definitions can be - ;; intermixed with these, and may or may not - ;; be additionally indented after visibility - ;; keywords. - (ruby-block-contains-point start)))) - (setq mname (concat - (if in-singleton-class "." "#") - mname)))))) - ;; Generate the string. - (if (consp mlist) - (setq mlist (mapconcat (function identity) mlist "::"))) - (if mname - (if mlist (concat mlist mname) mname) - mlist))))) + (save-excursion + (let* ((indent (ruby--add-log-current-indent)) + mname mlist + (start (point)) + (make-definition-re + (lambda (re &optional method-name?) + (concat "^[ \t]*" re "[ \t]+" + "\\(" + ;; \\. and :: for class methods + "\\([A-Za-z_]" ruby-symbol-re "*[?!]?" + "\\|" + (if method-name? ruby-operator-re "\\.") + "\\|::" "\\)" + "+\\)"))) + (definition-re (funcall make-definition-re ruby-defun-beg-re t)) + (module-re (funcall make-definition-re "\\(class\\|module\\)"))) + ;; Get the current method definition (or class/module). + (when (catch 'found + (while (and (re-search-backward definition-re nil t) + (if (if (string-equal "def" (match-string 1)) + ;; We're inside a method. + (if (ruby-block-contains-point (1- start)) + t + ;; Try to match a method only once. + (setq definition-re module-re) + nil) + ;; Class/module. For performance, + ;; comparing indentation. + (or (not (numberp indent)) + (> indent (current-indentation)))) + (throw 'found t) + t)))) + (goto-char (match-beginning 1)) + (if (not (string-equal "def" (match-string 1))) + (setq mlist (list (match-string 2))) + (setq mname (match-string 2))) + (setq indent (current-column)) + (beginning-of-line)) + ;; Walk up the class/module nesting. + (while (and indent + (> indent 0) + (re-search-backward module-re nil t)) + (goto-char (match-beginning 1)) + (when (< (current-column) indent) + (setq mlist (cons (match-string 2) mlist)) + (setq indent (current-column)) + (beginning-of-line))) + ;; Process the method name. + (when mname + (let ((mn (split-string mname "\\.\\|::"))) + (if (cdr mn) + (progn + (unless (string-equal "self" (car mn)) ; def self.foo + ;; def C.foo + (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)) + (setq ml (cdr ml)))) + (if mlist + (setcdr (last mlist) (butlast mn)) + (setq mlist (butlast mn)))) + (setq mname (concat "." (car (last mn))))) + ;; See if the method is in singleton class context. + (let ((in-singleton-class + (when (re-search-forward ruby-singleton-class-re start t) + (goto-char (match-beginning 0)) + ;; FIXME: Optimize it out, too? + ;; This can be slow in a large file, but + ;; unlike class/module declaration + ;; indentations, method definitions can be + ;; intermixed with these, and may or may not + ;; be additionally indented after visibility + ;; keywords. + (ruby-block-contains-point start)))) + (setq mname (concat + (if in-singleton-class "." "#") + mname)))))) + ;; Generate the string. + (if (consp mlist) + (setq mlist (mapconcat (function identity) mlist "::"))) + (if mname + (if mlist (concat mlist mname) mname) + mlist)))) (defun ruby-block-contains-point (pt) (save-excursion diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el index 91d65a2777b..7a00977f14a 100644 --- a/lisp/progmodes/ruby-ts-mode.el +++ b/lisp/progmodes/ruby-ts-mode.el @@ -1086,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 @@ -1113,6 +1122,45 @@ leading double colon is not added." ;; Navigation. (setq-local treesit-defun-type-regexp ruby-ts--method-regex) + (setq-local treesit-sexp-type-regexp + (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 54da1e0468e..0cde1f387e0 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1042,7 +1042,9 @@ subshells can nest." ;; Maybe we've bumped into an escaped newline. (sh-is-quoted-p (point))) (backward-char 1)) - (when (eq (char-before) ?|) + (when (and + (eq (char-before) ?|) + (not (eq (char-before (1- (point))) ?\;))) (backward-char 1) t))) (and (> (point) (1+ (point-min))) (progn (backward-char 2) @@ -1053,7 +1055,7 @@ subshells can nest." ;; a normal command rather than the real `in' keyword. ;; I.e. we should look back to try and find the ;; corresponding `case'. - (and (looking-at ";[;&]\\|\\_<in") + (and (looking-at ";\\(?:;&?\\|[&|]\\)\\|\\_<in") ;; ";; esac )" is a case that looks ;; like a case-pattern but it's really just a close ;; paren after a case statement. I.e. if we skipped @@ -1628,6 +1630,10 @@ not written in Bash or sh." ( bracket delimiter misc-punctuation operator))) (setq-local treesit-font-lock-settings sh-mode--treesit-settings) + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" + "heredoc_start" + "heredoc_body"))) (setq-local treesit-defun-type-regexp "function_definition") (treesit-major-mode-setup))) @@ -1785,8 +1791,9 @@ before the newline and in that case point should be just before the token." (pattern (rpattern) ("case-(" rpattern)) (branches (branches ";;" branches) (branches ";&" branches) (branches ";;&" branches) ;bash. + (branches ";|" branches) ;zsh. (pattern "case-)" cmd))) - '((assoc ";;" ";&" ";;&")) + '((assoc ";;" ";&" ";;&" ";|")) '((assoc ";" "&") (assoc "&&" "||") (assoc "|" "|&"))))) (defconst sh-smie--sh-operators @@ -2011,7 +2018,7 @@ May return nil if the line should not be treated as continued." (forward-line -1) (if (sh-smie--looking-back-at-continuation-p) (current-indentation) - (+ (current-indentation) sh-basic-offset)))) + (+ (current-indentation) (sh-var-value 'sh-indent-for-continuation))))) (t ;; Just make sure a line-continuation is indented deeper. (save-excursion @@ -2032,7 +2039,10 @@ May return nil if the line should not be treated as continued." ;; check the line before that one. (> ci indent)) (t ;Previous line is the beginning of the continued line. - (setq indent (min (+ ci sh-basic-offset) max)) + (setq + indent + (min + (+ ci (sh-var-value 'sh-indent-for-continuation)) max)) nil))))) indent)))))) @@ -2056,11 +2066,11 @@ May return nil if the line should not be treated as continued." `(column . ,(smie-indent-virtual)))))) ;; FIXME: Maybe this handling of ;; should be made into ;; a smie-rule-terminator function that takes the substitute ";" as arg. - (`(:before . ,(or ";;" ";&" ";;&")) - (if (and (smie-rule-bolp) (looking-at ";;?&?[ \t]*\\(#\\|$\\)")) + (`(:before . ,(or ";;" ";&" ";;&" ";|")) + (if (and (smie-rule-bolp) (looking-at ";\\(?:;&?\\|[&|]\\)?[ \t]*\\(#\\|$\\)")) (cons 'column (smie-indent-keyword ";")) (smie-rule-separator kind))) - (`(:after . ,(or ";;" ";&" ";;&")) + (`(:after . ,(or ";;" ";&" ";;&" ";|")) (with-demoted-errors "SMIE rule error: %S" (smie-backward-sexp token) (cons 'column @@ -2149,8 +2159,9 @@ May return nil if the line should not be treated as continued." (pattern (pattern "|" pattern)) (branches (branches ";;" branches) (branches ";&" branches) (branches ";;&" branches) ;bash. + (branches ";|" branches) ;zsh. (pattern "case-)" cmd))) - '((assoc ";;" ";&" ";;&")) + '((assoc ";;" ";&" ";;&" ";|")) '((assoc "case") (assoc ";" "&") (assoc "&&" "||") (assoc "|" "|&"))))) (defun sh-smie--rc-after-special-arg-p () diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index 11f20add3ee..3f198e9f180 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -330,6 +330,52 @@ Argument LANGUAGE is either `typescript' or `tsx'." :override t '((escape_sequence) @font-lock-escape-face))) +(defvar typescript-ts-mode--sentence-nodes + '("import_statement" + "debugger_statement" + "expression_statement" + "if_statement" + "switch_statement" + "for_statement" + "for_in_statement" + "while_statement" + "do_statement" + "try_statement" + "with_statement" + "break_statement" + "continue_statement" + "return_statement" + "throw_statement" + "empty_statement" + "labeled_statement" + "variable_declaration" + "lexical_declaration" + "property_signature") + "Nodes that designate sentences in TypeScript. +See `treesit-sentence-type-regexp' for more information.") + +(defvar typescript-ts-mode--sexp-nodes + '("expression" + "pattern" + "array" + "function" + "string" + "escape" + "template" + "regex" + "number" + "identifier" + "this" + "super" + "true" + "false" + "null" + "undefined" + "arguments" + "pair") + "Nodes that designate sexps in TypeScript. +See `treesit-sexp-type-regexp' for more information.") + ;;;###autoload (define-derived-mode typescript-ts-base-mode prog-mode "TypeScript" "Major mode for editing TypeScript." @@ -338,6 +384,11 @@ Argument LANGUAGE is either `typescript' or `tsx'." ;; Comments. (c-ts-common-comment-setup) + (setq-local treesit-defun-prefer-top-level t) + + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" + "template_string"))) ;; Electric (setq-local electric-indent-chars @@ -352,6 +403,12 @@ Argument LANGUAGE is either `typescript' or `tsx'." "lexical_declaration"))) (setq-local treesit-defun-name-function #'js--treesit-defun-name) + (setq-local treesit-sentence-type-regexp + (regexp-opt typescript-ts-mode--sentence-nodes)) + + (setq-local treesit-sexp-type-regexp + (regexp-opt typescript-ts-mode--sexp-nodes)) + ;; Imenu (same as in `js-ts-mode'). (setq-local treesit-simple-imenu-settings `(("Function" "\\`function_declaration\\'" nil nil) @@ -421,6 +478,18 @@ at least 3 (which is the default value)." (setq-local treesit-simple-indent-rules (typescript-ts-mode--indent-rules 'tsx)) + ;; Navigation + (setq-local treesit-sentence-type-regexp + (regexp-opt (append + typescript-ts-mode--sentence-nodes + '("jsx_element" + "jsx_self_closing_element")))) + + (setq-local treesit-sexp-type-regexp + (regexp-opt (append + typescript-ts-mode--sexp-nodes + '("jsx")))) + ;; Font-lock. (setq-local treesit-font-lock-settings (typescript-ts-mode--font-lock-settings 'tsx)) diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 3134a09c44f..ac6fd382a46 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -9,7 +9,7 @@ ;; Keywords: languages ;; The "Version" is the date followed by the decimal rendition of the Git ;; commit hex. -;; Version: 2021.10.14.127365406 +;; Version: 2022.12.18.181110314 ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -124,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2021-10-14-797711e-vpo-GNU" +(defconst verilog-mode-version "2022-12-18-acb862a-vpo-GNU" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -370,7 +370,8 @@ wherever possible, since it is slow." (unless (fboundp 'ignore-errors) (defmacro ignore-errors (&rest body) (declare (debug t) (indent 0)) - `(condition-case nil (progn ,@body) (error nil))))) + `(condition-case nil (progn ,@body) (error nil)))) + (error nil)) ;; Added in Emacs 24.1 (condition-case nil (unless (fboundp 'prog-mode) @@ -455,11 +456,11 @@ This function may be removed when Emacs 21 is no longer supported." last-command-event))) (defvar verilog-no-change-functions nil - "True if `after-change-functions' is disabled. + "Non-nil if `after-change-functions' is disabled. Use of `syntax-ppss' may break, as ppss's cache may get corrupted.") (defvar verilog-in-hooks nil - "True when within a `verilog-run-hooks' block.") + "Non-nil when within a `verilog-run-hooks' block.") (defmacro verilog-run-hooks (&rest hooks) "Run each hook in HOOKS using `run-hooks'. @@ -505,8 +506,14 @@ Set `verilog-in-hooks' during this time, to assist AUTO caches." (defvar verilog-debug nil "Non-nil means enable debug messages for `verilog-mode' internals.") -(defvar verilog-warn-fatal nil - "Non-nil means `verilog-warn-error' warnings are fatal `error's.") +(defcustom verilog-warn-fatal nil + "Non-nil means `verilog-warn-error' warnings are fatal `error's." + :group 'verilog-mode-auto + :type 'boolean) +(put 'verilog-warn-fatal 'safe-local-variable #'verilog-booleanp) + +;; Internal use similar to `verilog-warn-fatal' +(defvar verilog-warn-fatal-internal t) (defcustom verilog-linter "echo 'No verilog-linter set, see \"M-x describe-variable verilog-linter\"'" @@ -679,6 +686,18 @@ Set to 0 to have all directives start at the left side of the screen." :type 'integer) (put 'verilog-indent-level-directive 'safe-local-variable #'integerp) +(defcustom verilog-indent-ignore-multiline-defines t + "Non-nil means ignore indentation on lines that are part of a multiline define." + :group 'verilog-mode-indent + :type 'boolean) +(put 'verilog-indent-ignore-multiline-defines 'safe-local-variable #'verilog-booleanp) + +(defcustom verilog-indent-ignore-regexp nil + "Regexp that matches lines that should be ignored for indentation." + :group 'verilog-mode-indent + :type 'boolean) +(put 'verilog-indent-ignore-regexp 'safe-local-variable #'stringp) + (defcustom verilog-cexp-indent 2 "Indentation of Verilog statements split across lines." :group 'verilog-mode-indent @@ -723,6 +742,13 @@ Otherwise, line them up." :type 'boolean) (put 'verilog-indent-begin-after-if 'safe-local-variable #'verilog-booleanp) +(defcustom verilog-indent-class-inside-pkg t + "Non-nil means indent classes inside packages. +Otherwise, classes have zero indentation." + :group 'verilog-mode-indent + :type 'boolean) +(put 'verilog-indent-class-inside-pkg 'safe-local-variable #'verilog-booleanp) + (defcustom verilog-align-ifelse nil "Non-nil means align `else' under matching `if'. Otherwise else is lined up with first character on line holding matching if." @@ -730,6 +756,38 @@ Otherwise else is lined up with first character on line holding matching if." :type 'boolean) (put 'verilog-align-ifelse 'safe-local-variable #'verilog-booleanp) +(defcustom verilog-align-decl-expr-comments t + "Non-nil means align declaration and expressions comments." + :group 'verilog-mode-indent + :type 'boolean) +(put 'verilog-align-decl-expr-comments 'safe-local-variable #'verilog-booleanp) + +(defcustom verilog-align-comment-distance 1 + "Distance (in spaces) between longest declaration/expression and comments. +Only works if `verilog-align-decl-expr-comments' is non-nil." + :group 'verilog-mode-indent + :type 'integer) +(put 'verilog-align-comment-distance 'safe-local-variable #'integerp) + +(defcustom verilog-align-assign-expr nil + "Non-nil means align expressions of continuous assignments." + :group 'verilog-mode-indent + :type 'boolean) +(put 'verilog-align-assign-expr 'safe-local-variable #'verilog-booleanp) + +(defcustom verilog-align-typedef-regexp nil + "Regexp that matches user typedefs for declaration alignment." + :group 'verilog-mode-indent + :type '(choice (regexp :tag "Regexp") + (const :tag "None" nil))) +(put 'verilog-align-typedef-regexp 'safe-local-variable #'stringp) + +(defcustom verilog-align-typedef-words nil + "List of words that match user typedefs for declaration alignment." + :group 'verilog-mode-indent + :type '(repeat string)) +(put 'verilog-align-typedef-words 'safe-local-variable #'listp) + (defcustom verilog-minimum-comment-distance 10 "Minimum distance (in lines) between begin and end required before a comment. Setting this variable to zero results in every end acquiring a comment; the @@ -876,6 +934,12 @@ always be saved." :type 'boolean) (put 'verilog-auto-star-save 'safe-local-variable #'verilog-booleanp) +(defcustom verilog-fontify-variables t + "Non-nil means fontify declaration variables." + :group 'verilog-mode-actions + :type 'boolean) +(put 'verilog-fontify-variables 'safe-local-variable #'verilog-booleanp) + (defvar verilog-auto-update-tick nil "Modification tick at which autos were last performed.") @@ -1052,7 +1116,7 @@ You might want these defined in each file; put at the *END* of your file something like: // Local Variables: - // verilog-library-files:(\"/some/path/technology.v\" \"/some/path/tech2.v\") + // verilog-library-files:(\"/path/technology.v\" \"/path2/tech2.v\") // End: Verilog-mode attempts to detect changes to this local variable, but they @@ -1124,7 +1188,7 @@ those temporaries reset. See example in `verilog-auto-reset'." (put 'verilog-auto-reset-blocking-in-non 'safe-local-variable #'verilog-booleanp) (defcustom verilog-auto-reset-widths t - "True means AUTORESET should determine the width of signals. + "Non-nil means AUTORESET should determine the width of signals. This is then used to set the width of the zero (32'h0 for example). This is required by some lint tools that aren't smart enough to ignore widths of the constant zero. This may result in ugly code when parameters determine @@ -1264,7 +1328,7 @@ See `verilog-auto-inst-param-value'." Also affects AUTOINSTPARAM. Declaration order is the default for backward compatibility, and as some teams prefer signals that are declared together to remain together. Sorted order reduces -changes when declarations are moved around in a file. Sorting is +changes when declarations are moved around in a file. Sorting is within input/output/inout groupings, there is intentionally no option to intermix between input/output/inouts. @@ -1275,7 +1339,7 @@ See also `verilog-auto-arg-sort'." (put 'verilog-auto-inst-sort 'safe-local-variable #'verilog-booleanp) (defcustom verilog-auto-inst-vector t - "True means when creating default ports with AUTOINST, use bus subscripts. + "Non-nil means when creating default ports with AUTOINST, use bus subscripts. If nil, skip the subscript when it matches the entire bus as declared in the module (AUTOWIRE signals always are subscripted, you must manually declare the wire to have the subscripts removed.) Setting this to nil may @@ -1515,10 +1579,9 @@ If set will become buffer local.") (define-key map "\C-c/" #'verilog-star-comment) (define-key map "\C-c\C-c" #'verilog-comment-region) (define-key map "\C-c\C-u" #'verilog-uncomment-region) - (when (featurep 'xemacs) - (define-key map [(meta control h)] #'verilog-mark-defun) - (define-key map "\M-\C-a" #'verilog-beg-of-defun) - (define-key map "\M-\C-e" #'verilog-end-of-defun)) + (define-key map "\M-\C-h" #'verilog-mark-defun) + (define-key map "\M-\C-a" #'verilog-beg-of-defun) + (define-key map "\M-\C-e" #'verilog-end-of-defun) (define-key map "\C-c\C-d" #'verilog-goto-defun) (define-key map "\C-c\C-k" #'verilog-delete-auto) (define-key map "\C-c\C-a" #'verilog-auto) @@ -2028,11 +2091,11 @@ Where __FLAGS__ appears in the string `verilog-current-flags' will be substituted. Where __FILE__ appears in the string, the current buffer's file-name, without the directory portion, will be substituted." - (setq command (verilog-string-replace-matches + (setq command (verilog-string-replace-matches ;; Note \\b only works if under verilog syntax table "\\b__FLAGS__\\b" (verilog-current-flags) t t command)) - (setq command (verilog-string-replace-matches + (setq command (verilog-string-replace-matches "\\b__FILE__\\b" (file-name-nondirectory (or (buffer-file-name) "")) t t command)) @@ -2468,13 +2531,8 @@ find the errors." ;; ;; Regular expressions used to calculate indent, etc. ;; -(defconst verilog-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>") -;; Want to match -;; aa : -;; aa,bb : -;; a[34:32] : -;; a, -;; b : +(defconst verilog-identifier-re "[a-zA-Z_][a-zA-Z_0-9]*") +(defconst verilog-identifier-sym-re (concat "\\<" verilog-identifier-re "\\>")) (defconst verilog-assignment-operator-re (eval-when-compile (verilog-regexp-opt @@ -2492,12 +2550,11 @@ find the errors." ) 't ))) (defconst verilog-assignment-operation-re - (concat - ;; "\\(^\\s-*[A-Za-z0-9_]+\\(\\[\\([A-Za-z0-9_]+\\)\\]\\)*\\s-*\\)" - ;; "\\(^\\s-*[^=<>+-*/%&|^:\\s-]+[^=<>+-*/%&|^\n]*?\\)" - "\\(^.*?\\)" "\\B" verilog-assignment-operator-re "\\B" )) + (concat "\\(^.*?\\)" verilog-assignment-operator-re)) +(defconst verilog-assignment-operation-re-2 + (concat "\\(.*?\\)" verilog-assignment-operator-re)) -(defconst verilog-label-re (concat verilog-symbol-re "\\s-*:\\s-*")) +(defconst verilog-label-re (concat verilog-identifier-sym-re "\\s-*:\\s-*")) (defconst verilog-property-re (concat "\\(" verilog-label-re "\\)?" ;; "\\(assert\\|assume\\|cover\\)\\s-+property\\>" @@ -2732,6 +2789,9 @@ find the errors." "\\|\\(\\<clocking\\>\\)" ;17 "\\|\\(\\<`[ou]vm_[a-z_]+_begin\\>\\)" ;18 "\\|\\(\\<`vmm_[a-z_]+_member_begin\\>\\)" + "\\|\\(\\<`ifn?def\\>\\)" ;20, matched end can be: `else `elsif `endif + "\\|\\(\\<`else\\>\\)" ;21, matched end can be: `endif + "\\|\\(\\<`elsif\\>\\)" ;22, matched end can be: `else `endif ;; )) @@ -2817,40 +2877,54 @@ find the errors." "localparam" "parameter" "var" ;; misc "string" "event" "chandle" "virtual" "enum" "genvar" - "struct" "union" + "struct" "union" "type" ;; builtin classes "mailbox" "semaphore" )))) -(defconst verilog-declaration-re - (concat "\\(" verilog-declaration-prefix-re "\\s-*\\)?" verilog-declaration-core-re)) (defconst verilog-range-re "\\(\\[[^]]*\\]\\s-*\\)+") (defconst verilog-optional-signed-re "\\s-*\\(\\(un\\)?signed\\)?") (defconst verilog-optional-signed-range-re - (concat - "\\s-*\\(\\<\\(reg\\|wire\\)\\>\\s-*\\)?\\(\\<\\(un\\)?signed\\>\\s-*\\)?\\(" verilog-range-re "\\)?")) + (concat "\\s-*\\(\\<\\(reg\\|wire\\)\\>\\s-*\\)?\\(\\<\\(un\\)?signed\\>\\s-*\\)?\\(" verilog-range-re "\\)?")) (defconst verilog-macroexp-re "`\\sw+") - (defconst verilog-delay-re "#\\s-*\\(\\([0-9_]+\\('s?[hdxbo][0-9a-fA-F_xz]+\\)?\\)\\|\\(([^()]*)\\)\\|\\(\\sw+\\)\\)") -(defconst verilog-declaration-re-2-no-macro - (concat "\\s-*" verilog-declaration-re - "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)" - "\\)")) -(defconst verilog-declaration-re-2-macro - (concat "\\s-*" verilog-declaration-re - "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)" - "\\|\\(" verilog-macroexp-re "\\)" - "\\)")) -(defconst verilog-declaration-re-1-macro - (concat "^" verilog-declaration-re-2-macro)) - -(defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro)) +(defconst verilog-interface-modport-re "\\(\\s-*\\([a-zA-Z0-9`_$]+\\.[a-zA-Z0-9`_$]+\\)[ \t\f]+\\)") +(defconst verilog-comment-start-regexp "//\\|/\\*" "Dual comment value for `comment-start-regexp'.") +(defconst verilog-typedef-enum-re + (concat "^\\s-*\\(typedef\\s-+\\)?enum\\(\\s-+" verilog-declaration-core-re verilog-optional-signed-range-re "\\)?")) + +(defconst verilog-declaration-simple-re + (concat "\\(" verilog-declaration-prefix-re "\\s-*\\)?" verilog-declaration-core-re)) +(defconst verilog-declaration-re + (concat "\\s-*" verilog-declaration-simple-re + "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)\\)")) +(defconst verilog-declaration-re-macro + (concat "\\s-*" verilog-declaration-simple-re + "\\s-*\\(\\(" verilog-optional-signed-range-re "\\)\\|\\(" verilog-delay-re "\\)\\|\\(" verilog-macroexp-re "\\)\\)")) +(defconst verilog-declaration-or-iface-mp-re + (concat "\\(" verilog-declaration-re "\\)\\|\\(" verilog-interface-modport-re "\\)")) +(defconst verilog-declaration-embedded-comments-re + (concat "\\( " verilog-declaration-re "\\) ""\\s-*" "\\(" verilog-comment-start-regexp "\\)") + "Match expressions such as: input logic [7:0] /* auto enum sm_psm */ sm_psm;.") (defconst verilog-defun-re (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config")))) (defconst verilog-end-defun-re (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) +(defconst verilog-defun-tf-re-beg + (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config" "function" "task")))) +(defconst verilog-defun-tf-re-end + (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig" "endfunction" "endtask")))) +(defconst verilog-defun-tf-re-all + (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config" "function" "task" + "endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig" "endfunction" "endtask")))) +(defconst verilog-defun-no-class-re + (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "program" "interface" "package" "primitive" "config")))) +(defconst verilog-end-defun-no-class-re + (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) (defconst verilog-zero-indent-re (concat verilog-defun-re "\\|" verilog-end-defun-re)) +(defconst verilog-zero-indent-no-class-re + (concat verilog-defun-no-class-re "\\|" verilog-end-defun-no-class-re)) (defconst verilog-inst-comment-re (eval-when-compile (verilog-regexp-words '("Outputs" "Inouts" "Inputs" "Interfaces" "Interfaced")))) @@ -2983,19 +3057,38 @@ find the errors." (defconst verilog-extended-case-re "\\(\\(unique0?\\s-+\\|priority\\s-+\\)?case[xz]?\\|randcase\\)") (defconst verilog-extended-complete-re ;; verilog-beg-of-statement also looks backward one token to extend this match - (concat "\\(\\(\\<extern\\s-+\\|\\<\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?virtual\\s-+\\|\\<protected\\s-+\\|\\<static\\s-+\\)*\\(\\<function\\>\\|\\<task\\>\\)\\)" + (concat "\\(\\(\\<extern\\s-+\\|\\<\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?virtual\\s-+\\|\\<local\\s-+\\|\\<protected\\s-+\\|\\<static\\s-+\\)*\\(\\<function\\>\\|\\<task\\>\\)\\)" "\\|\\(\\(\\<typedef\\>\\s-+\\)*\\(\\<struct\\>\\|\\<union\\>\\|\\<class\\>\\)\\)" "\\|\\(\\(\\<\\(import\\|export\\)\\>\\s-+\\)?\\(\"DPI\\(-C\\)?\"\\s-+\\)?\\(\\<\\(pure\\|context\\)\\>\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_]*\\s-*=\\s-*\\)?\\(function\\>\\|task\\>\\)\\)" "\\|" verilog-extended-case-re )) + +(eval-and-compile + (defconst verilog-basic-complete-words + '("always" "assign" "always_latch" "always_ff" "always_comb" "analog" "connectmodule" "constraint" + "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while" + "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert" "default" "generate")) + (defconst verilog-basic-complete-words-expr + (let ((words verilog-basic-complete-words)) + (dolist (word '("default" "parameter" "localparam")) + (setq words (remove word words))) + words)) + (defconst verilog-basic-complete-words-expr-no-assign + (remove "assign" verilog-basic-complete-words-expr))) + (defconst verilog-basic-complete-re (eval-when-compile - (verilog-regexp-words - '( - "always" "assign" "always_latch" "always_ff" "always_comb" "analog" "connectmodule" "constraint" - "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while" - "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert" - )))) -(defconst verilog-complete-reg + (verilog-regexp-words verilog-basic-complete-words))) + +(defconst verilog-basic-complete-expr-re + (eval-when-compile + (verilog-regexp-words verilog-basic-complete-words-expr))) + +(defconst verilog-basic-complete-expr-no-assign-re + (eval-when-compile + (verilog-regexp-words verilog-basic-complete-words-expr-no-assign))) + + +(defconst verilog-complete-re (concat verilog-extended-complete-re "\\|\\(" verilog-basic-complete-re "\\)")) @@ -3114,9 +3207,6 @@ find the errors." )) "List of Verilog keywords.") -(defconst verilog-comment-start-regexp "//\\|/\\*" - "Dual comment value for `comment-start-regexp'.") - (defvar verilog-mode-syntax-table (let ((table (make-syntax-table))) ;; Populate the syntax TABLE. @@ -3338,12 +3428,12 @@ See also `verilog-font-lock-extra-types'.") (list "\\<\\(\\(macro\\|connect\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)" '(1 font-lock-keyword-face) - '(3 font-lock-function-name-face prepend)) + '(3 font-lock-function-name-face)) ;; Fontify function definitions (list (concat "\\<function\\>\\s-+\\(integer\\|real\\(time\\)?\\|time\\)\\s-+\\(\\sw+\\)" ) '(1 font-lock-keyword-face) - '(3 font-lock-constant-face prepend)) + '(3 font-lock-constant-face)) '("\\<function\\>\\s-+\\(\\[[^]]+\\]\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (2 font-lock-constant-face append)) @@ -3358,12 +3448,12 @@ See also `verilog-font-lock-extra-types'.") ;; Pre-form for this anchored matcher: ;; First, avoid declaration keywords written in comments, ;; which can also trigger this anchor. - '(if (not (verilog-in-comment-p)) + '(if (and (not (verilog-in-comment-p)) + (not (member (thing-at-point 'symbol) verilog-keywords))) (verilog-single-declaration-end verilog-highlight-max-lookahead) (point)) ;; => current declaration statement is of 0 length nil ;; Post-form: nothing to be done - '(0 font-lock-variable-name-face t t))) - ))) + '(0 font-lock-variable-name-face)))))) (setq verilog-font-lock-keywords-2 @@ -3617,7 +3707,7 @@ inserted using a single call to `verilog-insert'." (defun verilog-single-declaration-end (limit) "Return pos where current (single) declaration statement ends. Also, this function moves POINT forward to the start of a variable name -(skipping the range-part and whitespace). +\(skipping the range-part and whitespace). Function expected to be called with POINT just after a declaration keyword. LIMIT sets the max POINT for searching and moving to. No such limit if LIMIT is 0. @@ -3629,8 +3719,6 @@ Meaning of *single* declaration: and `output [1:0] y' is the other single declaration. In the 1st single declaration, POINT is moved to start of `clk'. And in the 2nd declaration, POINT is moved to `y'." - - (let (maxpoint old-point) ;; maxpoint = min(curr-point + limit, buffer-size) (setq maxpoint (if (eq limit 0) @@ -3651,7 +3739,7 @@ POINT is moved to `y'." (not (eq old-point (point))) (not (eq (char-after) ?\; )) (not (eq (char-after) ?\) )) - (not (looking-at verilog-declaration-re))) + (not (looking-at (verilog-get-declaration-re)))) (setq old-point (point)) (ignore-errors (forward-sexp) @@ -3669,31 +3757,28 @@ This function moves POINT to the next variable within the same declaration (if it exists). LIMIT is expected to be the pos at which current single-declaration ends, obtained using `verilog-single-declaration-end'." - - (let (found-var old-point) - - ;; Remove starting whitespace - (verilog-forward-ws&directives limit) - - (when (< (point) limit) ;; no matching if this is violated - - ;; Find the variable name (match-data is set here) - (setq found-var (re-search-forward verilog-symbol-re limit t)) - - ;; Walk to this variable's delimiter - (save-match-data - (verilog-forward-ws&directives limit) - (setq old-point nil) - (while (and (< (point) limit) - (not (member (char-after) '(?, ?\) ?\;))) - (not (eq old-point (point)))) - (setq old-point (point)) + (when (and verilog-fontify-variables + (not (member (thing-at-point 'symbol) verilog-keywords))) + (let (found-var old-point) + ;; Remove starting whitespace + (verilog-forward-ws&directives limit) + (when (< (point) limit) ;; no matching if this is violated + ;; Find the variable name (match-data is set here) + (setq found-var (re-search-forward verilog-identifier-sym-re limit t)) + ;; Walk to this variable's delimiter + (save-match-data (verilog-forward-ws&directives limit) - (forward-sexp) - (verilog-forward-ws&directives limit)) - ;; Only a comma or semicolon expected at this point - (skip-syntax-forward ".")) - found-var))) + (setq old-point nil) + (while (and (< (point) limit) + (not (member (char-after) '(?, ?\) ?\] ?\} ?\;))) + (not (eq old-point (point)))) + (setq old-point (point)) + (verilog-forward-ws&directives limit) + (forward-sexp) + (verilog-forward-ws&directives limit)) + ;; Only a comma or semicolon expected at this point + (skip-syntax-forward ".")) + found-var)))) (defun verilog-point-text (&optional pointnum) "Return text describing where POINTNUM or current point is (for errors). @@ -3728,9 +3813,14 @@ Use filename, if current buffer being edited shorten to just buffer name." (elsec 1) (found nil) (st (point))) - (if (not (looking-at "\\<")) - (forward-word-strictly -1)) + (unless (looking-at "\\<") + (forward-word-strictly -1)) (cond + ((save-excursion + (goto-char st) + (member (preceding-char) '(?\) ?\} ?\]))) + (goto-char st) + (backward-sexp 1)) ((verilog-skip-backward-comment-or-string)) ((looking-at "\\<else\\>") (setq reg (concat @@ -3754,7 +3844,17 @@ Use filename, if current buffer being edited shorten to just buffer name." (setq found 't)))))) ((looking-at verilog-end-block-re) (verilog-leap-to-head)) - ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)\\|\\(\\<endconnectmodule\\>\\)") + (;; Fallback, when current word does not match `verilog-end-block-re' + (looking-at (concat + "\\(\\<endmodule\\>\\)\\|" ; 1 + "\\(\\<endprimitive\\>\\)\\|" ; 2 + "\\(\\<endclass\\>\\)\\|" ; 3 + "\\(\\<endprogram\\>\\)\\|" ; 4 + "\\(\\<endinterface\\>\\)\\|" ; 5 + "\\(\\<endpackage\\>\\)\\|" ; 6 + "\\(\\<endconnectmodule\\>\\)\\|" ; 7 + "\\(\\<endchecker\\>\\)\\|" ; 8 + "\\(\\<endconfig\\>\\)")) ; 9 (cond ((match-end 1) (verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move)) @@ -3769,7 +3869,11 @@ Use filename, if current buffer being edited shorten to just buffer name." ((match-end 6) (verilog-re-search-backward "\\<package\\>" nil 'move)) ((match-end 7) - (verilog-re-search-backward "\\<connectmodule\\>" nil 'move)) + (verilog-re-search-backward "\\<connectmodule\\>" nil 'move)) + ((match-end 8) + (verilog-re-search-backward "\\<checker\\>" nil 'move)) + ((match-end 9) + (verilog-re-search-backward "\\<config\\>" nil 'move)) (t (goto-char st) (backward-sexp 1)))) @@ -3782,9 +3886,14 @@ Use filename, if current buffer being edited shorten to just buffer name." (md 2) (st (point)) (nest 'yes)) - (if (not (looking-at "\\<")) - (forward-word-strictly -1)) + (unless (looking-at "\\<") + (forward-word-strictly -1)) (cond + ((save-excursion + (goto-char st) + (member (following-char) '(?\( ?\{ ?\[))) + (goto-char st) + (forward-sexp 1)) ((verilog-skip-forward-comment-or-string) (verilog-forward-syntactic-ws)) ((looking-at verilog-beg-block-re-ordered) @@ -3843,22 +3952,31 @@ Use filename, if current buffer being edited shorten to just buffer name." ;; Search forward for matching endtask (setq reg "\\<endtask\\>" ) (setq nest 'no)) - ((match-end 12) + ((match-end 13) ;; Search forward for matching endgenerate (setq reg "\\(\\<generate\\>\\)\\|\\(\\<endgenerate\\>\\)" )) - ((match-end 13) + ((match-end 14) ;; Search forward for matching endgroup (setq reg "\\(\\<covergroup\\>\\)\\|\\(\\<endgroup\\>\\)" )) - ((match-end 14) + ((match-end 15) ;; Search forward for matching endproperty (setq reg "\\(\\<property\\>\\)\\|\\(\\<endproperty\\>\\)" )) - ((match-end 15) + ((match-end 16) ;; Search forward for matching endsequence (setq reg "\\(\\<\\(rand\\)?sequence\\>\\)\\|\\(\\<endsequence\\>\\)" ) (setq md 3)) ; 3 to get to endsequence in the reg above ((match-end 17) ;; Search forward for matching endclocking - (setq reg "\\(\\<clocking\\>\\)\\|\\(\\<endclocking\\>\\)" ))) + (setq reg "\\(\\<clocking\\>\\)\\|\\(\\<endclocking\\>\\)" )) + ((match-end 20) + ;; Search forward for matching `ifn?def, can be `else `elseif or `endif + (setq reg "\\(\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\|\\<`else\\>\\|\\<`elsif\\>\\)" )) + ((match-end 21) + ;; Search forward for matching `else, can be `endif + (setq reg "\\(\\<`else\\>\\|\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\)" )) + ((match-end 22) + ;; Search forward for matching `elsif, can be `else or `endif, DONT support `elsif + (setq reg "\\(\\<`elsif\\>\\|\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\|\\<`else\\>\\)" ))) (if (and reg (forward-word-strictly 1)) (catch 'skip @@ -3867,15 +3985,26 @@ Use filename, if current buffer being edited shorten to just buffer name." here) (while (verilog-re-search-forward reg nil 'move) (cond - ((match-end md) ; a closer in regular expression, so we are climbing out + ((and (or (match-end md) + (and (member (match-string-no-properties 1) '("`else" "`elsif")) + (= 1 depth))) + (or (and (member (match-string-no-properties 2) '("`else" "`elsif")) + (= 1 depth)) + ;; stop at `else/`elsif which matching ifn?def (or `elsif with same depth) + ;; a closer in regular expression, so we are climbing out + (not (member (match-string-no-properties 2) '("`else" "`elsif"))))) (setq depth (1- depth)) (if (= 0 depth) ; we are out! (throw 'skip 1))) - ((match-end 1) ; an opener in the r-e, so we are in deeper now + ((and (match-end 1) ; an opener in the r-e, so we are in deeper now + (not (member (match-string-no-properties 1) '("`else" "`elsif")))) (setq here (point)) ; remember where we started (goto-char (match-beginning 1)) (cond - ((if (or + ((verilog-looking-back "\\(\\<typedef\\>\\s-+\\)" (point-at-bol)) + ;; avoid nesting for typedef class defs + (forward-word-strictly 1)) + ((if (or (looking-at verilog-disable-fork-re) (and (looking-at "fork") (progn @@ -3890,28 +4019,37 @@ Use filename, if current buffer being edited shorten to just buffer name." (throw 'skip 1)))))) ((looking-at (concat - "\\(\\<\\(macro\\)?module\\>\\)\\|" - "\\(\\<primitive\\>\\)\\|" - "\\(\\<class\\>\\)\\|" - "\\(\\<program\\>\\)\\|" - "\\(\\<interface\\>\\)\\|" - "\\(\\<package\\>\\)\\|" - "\\(\\<connectmodule\\>\\)")) + "\\(\\<\\(macro\\)?module\\>\\)\\|" ; 1,2 + "\\(\\<primitive\\>\\)\\|" ; 3 + "\\(\\(\\(interface\\|virtual\\)\\s-+\\)?\\<class\\>\\)\\|" ; 4,5,6 + "\\(\\<program\\>\\)\\|" ; 7 + "\\(\\<interface\\>\\)\\|" ; 8 + "\\(\\<package\\>\\)\\|" ; 9 + "\\(\\<connectmodule\\>\\)\\|" ; 10 + "\\(\\<generate\\>\\)\\|" ; 11 + "\\(\\<checker\\>\\)\\|" ; 12 + "\\(\\<config\\>\\)")) ; 13 (cond ((match-end 1) (verilog-re-search-forward "\\<endmodule\\>" nil 'move)) - ((match-end 2) - (verilog-re-search-forward "\\<endprimitive\\>" nil 'move)) ((match-end 3) - (verilog-re-search-forward "\\<endclass\\>" nil 'move)) + (verilog-re-search-forward "\\<endprimitive\\>" nil 'move)) ((match-end 4) + (verilog-re-search-forward "\\<endclass\\>" nil 'move)) + ((match-end 7) (verilog-re-search-forward "\\<endprogram\\>" nil 'move)) - ((match-end 5) + ((match-end 8) (verilog-re-search-forward "\\<endinterface\\>" nil 'move)) - ((match-end 6) + ((match-end 9) (verilog-re-search-forward "\\<endpackage\\>" nil 'move)) - ((match-end 7) - (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move)) + ((match-end 10) + (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move)) + ((match-end 11) + (verilog-re-search-forward "\\<endgenerate\\>" nil 'move)) + ((match-end 12) + (verilog-re-search-forward "\\<endchecker\\>" nil 'move)) + ((match-end 13) + (verilog-re-search-forward "\\<endconfig\\>" nil 'move)) (t (goto-char st) (if (= (following-char) ?\) ) @@ -3924,11 +4062,69 @@ Use filename, if current buffer being edited shorten to just buffer name." (forward-sexp 1)))))) (defun verilog-declaration-beg () - (verilog-re-search-backward verilog-declaration-re (bobp) t)) - -;; -;; -;; Mode + (verilog-re-search-backward (verilog-get-declaration-re) (bobp) t)) + +(defun verilog-align-typedef-enabled-p () + "Return non-nil if alignment of user typedefs is enabled. +This will be automatically set when either `verilog-align-typedef-regexp' +or `verilog-align-typedef-words' are non-nil." + (when (or verilog-align-typedef-regexp + verilog-align-typedef-words) + t)) + +(defun verilog-get-declaration-typedef-re () + "Return regexp of a user defined typedef. +See `verilog-align-typedef-regexp' and `verilog-align-typedef-words'." + (let (typedef-re words words-re re) + (when (verilog-align-typedef-enabled-p) + (setq typedef-re verilog-align-typedef-regexp) + (setq words verilog-align-typedef-words) + (setq words-re (verilog-regexp-words verilog-align-typedef-words)) + (cond ((and typedef-re (not words)) + (setq re typedef-re)) + ((and (not typedef-re) words) + (setq re words-re)) + ((and typedef-re words) + (setq re (concat verilog-align-typedef-regexp "\\|" words-re)))) + (concat "\\s-*" "\\(" verilog-declaration-prefix-re "\\s-*\\(" verilog-range-re "\\)?" "\\s-*\\)?" + (concat "\\(" re "\\)") + "\\(\\s-*" verilog-range-re "\\)?\\s-+")))) + +(defun verilog-get-declaration-re (&optional type) + "Return declaration regexp depending on customizable variables and TYPE." + (let ((re (cond ((equal type 'iface-mp) + verilog-declaration-or-iface-mp-re) + ((equal type 'embedded-comments) + verilog-declaration-embedded-comments-re) + (verilog-indent-declaration-macros + verilog-declaration-re-macro) + (t + verilog-declaration-re)))) + (when (and (verilog-align-typedef-enabled-p) + (or (string= re verilog-declaration-or-iface-mp-re) + (string= re verilog-declaration-re))) + (setq re (concat "\\(" (verilog-get-declaration-typedef-re) "\\)\\|\\(" re "\\)"))) + re)) + +(defun verilog-looking-at-decl-to-align () + "Return non-nil if pointing at a Verilog variable declaration that must be aligned." + (let* ((re (verilog-get-declaration-re)) + (valid-re (looking-at re)) + (id-pos (match-end 0))) + (and valid-re + (not (verilog-at-struct-decl-p)) + (not (verilog-at-enum-decl-p)) + (save-excursion + (goto-char id-pos) + (verilog-forward-syntactic-ws) + (and (not (looking-at ";")) + (not (member (thing-at-point 'symbol) verilog-keywords)) + (progn ; Avoid alignment of instances whose name match user defined types + (forward-word) + (verilog-forward-syntactic-ws) + (not (looking-at "(")))))))) + +;;; Mode: ;; (defvar verilog-which-tool 1) ;;;###autoload @@ -3965,6 +4161,11 @@ Variables controlling indentation/edit style: function keyword. `verilog-indent-level-directive' (default 1) Indentation of \\=`ifdef/\\=`endif blocks. + `verilog-indent-ignore-multiline-defines' (default t) + Non-nil means ignore indentation on lines that are part of a multiline + define. + `verilog-indent-ignore-regexp' (default nil + Regexp that matches lines that should be ignored for indentation. `verilog-cexp-indent' (default 1) Indentation of Verilog statements broken across lines i.e.: if (a) @@ -3988,6 +4189,9 @@ Variables controlling indentation/edit style: otherwise you get: if (a) begin + `verilog-indent-class-inside-pkg' (default t) + Non-nil means indent classes inside packages. + Otherwise, classes have zero indentation. `verilog-auto-endcomments' (default t) Non-nil means a comment /* ... */ is set after the ends which ends cases, tasks, functions and modules. @@ -3997,6 +4201,17 @@ Variables controlling indentation/edit style: will be inserted. Setting this variable to zero results in every end acquiring a comment; the default avoids too many redundant comments in tight quarters. + `verilog-align-decl-expr-comments' (default t) + Non-nil means align declaration and expressions comments. + `verilog-align-comment-distance' (default 1) + Distance (in spaces) between longest declaration and comments. + Only works if `verilog-align-decl-expr-comments' is non-nil. + `verilog-align-assign-expr' (default nil) + Non-nil means align expressions of continuous assignments. + `verilog-align-typedef-regexp' (default nil) + Regexp that matches user typedefs for declaration alignment. + `verilog-align-typedef-words' (default nil) + List of words that match user typedefs for declaration alignment. `verilog-auto-lineup' (default `declarations') List of contexts where auto lineup of code should be done. @@ -4020,17 +4235,20 @@ Some other functions are: \\[verilog-mark-defun] Mark function. \\[verilog-beg-of-defun] Move to beginning of current function. \\[verilog-end-of-defun] Move to end of current function. - \\[verilog-label-be] Label matching begin ... end, fork ... join, etc statements. + \\[verilog-label-be] Label matching begin ... end, fork ... join, etc + statements. \\[verilog-comment-region] Put marked area in a comment. - \\[verilog-uncomment-region] Uncomment an area commented with \\[verilog-comment-region]. + \\[verilog-uncomment-region] Uncomment an area commented with + \\[verilog-comment-region]. \\[verilog-insert-block] Insert begin ... end. \\[verilog-star-comment] Insert /* ... */. \\[verilog-sk-always] Insert an always @(AS) begin .. end block. \\[verilog-sk-begin] Insert a begin .. end block. \\[verilog-sk-case] Insert a case block, prompting for details. - \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for details. + \\[verilog-sk-for] Insert a for (...) begin .. end block, prompting for + details. \\[verilog-sk-generate] Insert a generate .. endgenerate block. \\[verilog-sk-header] Insert a header block at the top of file. \\[verilog-sk-initial] Insert an initial begin .. end block. @@ -4053,14 +4271,17 @@ Some other functions are: \\[verilog-sk-else-if] Insert an else if (..) begin .. end block. \\[verilog-sk-comment] Insert a comment block. \\[verilog-sk-assign] Insert an assign .. = ..; statement. - \\[verilog-sk-function] Insert a function .. begin .. end endfunction block. + \\[verilog-sk-function] Insert a function .. begin .. end endfunction + block. \\[verilog-sk-input] Insert an input declaration, prompting for details. \\[verilog-sk-output] Insert an output declaration, prompting for details. - \\[verilog-sk-state-machine] Insert a state machine definition, prompting for details. + \\[verilog-sk-state-machine] Insert a state machine definition, prompting + for details. \\[verilog-sk-inout] Insert an inout declaration, prompting for details. \\[verilog-sk-wire] Insert a wire declaration, prompting for details. \\[verilog-sk-reg] Insert a register declaration, prompting for details. - \\[verilog-sk-define-signal] Define signal under point as a register at the top of the module. + \\[verilog-sk-define-signal] Define signal under point as a register at + the top of the module. All key bindings can be seen in a Verilog-buffer with \\[describe-bindings]. Key bindings specific to `verilog-mode-map' are: @@ -4147,7 +4368,7 @@ Key bindings specific to `verilog-mode-map' are: ;; verilog-mode-hook call added by define-derived-mode ) -;;; Integration with the speedbar +;;; Integration with the speedbar: ;; ;; Avoid problems with XEmacs byte-compiles. @@ -4427,15 +4648,24 @@ following code fragment: "Mark the current Verilog function (or procedure). This puts the mark at the end, and point at the beginning." (interactive) - (if (featurep 'xemacs) - (progn - (push-mark) - (verilog-end-of-defun) - (push-mark) - (verilog-beg-of-defun) - (if (fboundp 'zmacs-activate-region) - (zmacs-activate-region))) - (mark-defun))) + (let (found) + (if (featurep 'xemacs) + (progn + (push-mark) + (verilog-end-of-defun) + (push-mark) + (verilog-beg-of-defun) + (if (fboundp 'zmacs-activate-region) + (zmacs-activate-region))) + ;; GNU Emacs + (when (verilog-beg-of-defun) + (setq found (point)) + (verilog-end-of-defun) + (end-of-line) + (push-mark) + (goto-char found) + (beginning-of-line) + (setq mark-active t))))) (defun verilog-comment-region (start end) ;; checkdoc-params: (start end) @@ -4514,7 +4744,21 @@ area. See also `verilog-comment-region'." (defun verilog-beg-of-defun () "Move backward to the beginning of the current function or procedure." (interactive) - (verilog-re-search-backward verilog-defun-re nil 'move)) + (let (found) + (save-excursion + (when (verilog-looking-back verilog-defun-tf-re-end (point-at-bol)) + (verilog-backward-sexp) + (setq found (point))) + (while (and (not found) + (verilog-re-search-backward verilog-defun-tf-re-all nil t)) + (cond ((verilog-looking-back "\\(\\<typedef\\>\\s-+\\)" (point-at-bol)) ; corner case, e.g. 'typedef class <id>;' + (backward-word)) + ((looking-at verilog-defun-tf-re-end) + (verilog-backward-sexp)) + ((looking-at verilog-defun-tf-re-beg) + (setq found (point)))))) + (when found + (goto-char found)))) (defun verilog-beg-of-defun-quick () "Move backward to the beginning of the current function or procedure. @@ -4525,7 +4769,10 @@ Uses `verilog-scan' cache." (defun verilog-end-of-defun () "Move forward to the end of the current function or procedure." (interactive) - (verilog-re-search-forward verilog-end-defun-re nil 'move)) + (when (or (looking-at verilog-defun-tf-re-beg) + (verilog-beg-of-defun)) + (verilog-forward-sexp) + (point))) (defun verilog-get-end-of-defun () (save-excursion @@ -4542,10 +4789,10 @@ Uses `verilog-scan' cache." (case-fold-search nil) (oldpos (point)) (b (progn - (verilog-beg-of-defun) + (verilog-re-search-backward verilog-defun-re nil 'move) (point-marker))) (e (progn - (verilog-end-of-defun) + (verilog-re-search-forward verilog-end-defun-re nil 'move) (point-marker)))) (goto-char (marker-position b)) (if (> (- e b) 200) @@ -4605,19 +4852,18 @@ Uses `verilog-scan' cache." (goto-char h))) ;; stop if we see an extended complete reg, perhaps a complete one (and - (looking-at verilog-complete-reg) + (looking-at verilog-complete-re) (let* ((p (point))) (while (and (looking-at verilog-extended-complete-re) (progn (setq p (point)) (verilog-backward-token) (/= p (point))))) (goto-char p))) - ;; stop if we see a complete reg (previous found extended ones) - (looking-at verilog-basic-complete-re) ;; stop if previous token is an ender (save-excursion (verilog-backward-token) - (looking-at verilog-end-block-re)))) + (or (looking-at verilog-end-block-re) + (verilog-in-directive-p))))) (verilog-backward-syntactic-ws) (verilog-backward-token)) ;; Now point is where the previous line ended. @@ -4634,28 +4880,23 @@ Uses `verilog-scan' cache." (verilog-backward-syntactic-ws)) (let ((pt (point))) (catch 'done - (while (not (looking-at verilog-complete-reg)) + (while (not (looking-at verilog-complete-re)) (setq pt (point)) (verilog-backward-syntactic-ws) (if (or (bolp) (= (preceding-char) ?\;) + (and (= (preceding-char) ?\{) + (save-excursion + (backward-char) + (verilog-at-struct-p))) (progn (verilog-backward-token) - (looking-at verilog-ends-re))) + (or (looking-at verilog-ends-re) + (looking-at "begin")))) (progn (goto-char pt) (throw 'done t))))) (verilog-forward-syntactic-ws))) -;; -;; (while (and -;; (not (looking-at verilog-complete-reg)) -;; (not (bolp)) -;; (not (= (preceding-char) ?\;))) -;; (verilog-backward-token) -;; (verilog-backward-syntactic-ws) -;; (setq pt (point))) -;; (goto-char pt) -;; ;(verilog-forward-syntactic-ws) (defun verilog-end-of-statement () "Move forward to end of current statement." @@ -4713,7 +4954,7 @@ Uses `verilog-scan' cache." pos))))) (defun verilog-in-case-region-p () - "Return true if in a case region. + "Return non-nil if in a case region. More specifically, point @ in the line foo : @ begin" (interactive) (save-excursion @@ -4758,37 +4999,29 @@ More specifically, point @ in the line foo : @ begin" (forward-sexp arg))) (defun verilog-in-generate-region-p () - "Return true if in a generate region. + "Return non-nil if in a generate region. More specifically, after a generate and before an endgenerate." (interactive) - (let ((nest 1)) - (save-excursion - (catch 'done - (while (and - (/= nest 0) - (verilog-re-search-backward - "\\<\\(module\\)\\|\\(connectmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\|\\(if\\)\\|\\(case\\)\\|\\(for\\)\\>" nil 'move) - (cond - ((match-end 1) ; module - we have crawled out - (throw 'done 1)) - ((match-end 2) ; connectmodule - we have crawled out - (throw 'done 1)) - ((match-end 3) ; generate - (setq nest (1- nest))) - ((match-end 4) ; endgenerate - (setq nest (1+ nest))) - ((match-end 5) ; if - (setq nest (1- nest))) - ((match-end 6) ; case - (setq nest (1- nest))) - ((match-end 7) ; for - (setq nest (1- nest)))))))) - (= nest 0) )) ; return nest + (let ((pos (point)) + gen-beg-point gen-end-point) + (save-match-data + (save-excursion + (and (verilog-re-search-backward "\\<\\(generate\\)\\>" nil t) + (forward-word) + (setq gen-beg-point (point)) + (verilog-forward-sexp) + (backward-word) + (setq gen-end-point (point))))) + (if (and gen-beg-point gen-end-point + (>= pos gen-beg-point) + (<= pos gen-end-point)) + t + nil))) (defun verilog-in-fork-region-p () - "Return true if between a fork and join." + "Return non-nil if between a fork and join." (interactive) - (let ((lim (save-excursion (verilog-beg-of-defun) (point))) + (let ((lim (save-excursion (verilog-re-search-backward verilog-defun-re nil 'move) (point))) (nest 1)) (save-excursion (while (and @@ -4802,7 +5035,7 @@ More specifically, after a generate and before an endgenerate." (= nest 0) )) ; return nest (defun verilog-in-deferred-immediate-final-p () - "Return true if inside an `assert/assume/cover final' statement." + "Return non-nil if inside an `assert/assume/cover final' statement." (interactive) (and (looking-at "final") (verilog-looking-back "\\<\\(?:assert\\|assume\\|cover\\)\\>\\s-+" nil)) @@ -5013,7 +5246,7 @@ primitive or interface named NAME." (insert str) (ding 't)) (let ((lim - (save-excursion (verilog-beg-of-defun) (point))) + (save-excursion (verilog-re-search-backward verilog-defun-re nil 'move) (point))) (here (point))) (cond (;-- handle named block differently @@ -5461,7 +5694,7 @@ For example: becomes: // surefire lint_line_off UDDONX" (interactive) - (let ((buff (if (boundp 'next-error-last-buffer) ;Added to Emacs-22.1 + (let ((buff (if (boundp 'next-error-last-buffer) ; Added to Emacs-22.1 next-error-last-buffer (verilog--suppressed-warnings ((obsolete compilation-last-buffer)) @@ -5585,13 +5818,14 @@ FILENAME to find directory to run in, or defaults to `buffer-file-name'." (defun verilog-warn-error (string &rest args) "Call `error' using STRING and optional ARGS. If `verilog-warn-fatal' is non-nil, call `verilog-warn' instead." - (apply (if verilog-warn-fatal #'error #'verilog-warn) + (apply (if (and verilog-warn-fatal verilog-warn-fatal-internal) + #'error #'verilog-warn) string args)) (defmacro verilog-batch-error-wrapper (&rest body) "Execute BODY and add error prefix to any errors found. This lets programs calling batch mode to easily extract error messages." - `(let ((verilog-warn-fatal nil)) + `(let ((verilog-warn-fatal-internal nil)) (condition-case err (progn ,@body) (error @@ -5721,7 +5955,7 @@ This sets up the appropriate Verilog mode environment, calls (string . 0))) (defun verilog-continued-line-1 (lim) - "Return true if this is a continued line. + "Return non-nil if this is a continued line. Set point to where line starts. Limit search to point LIM." (let ((continued 't)) (if (eq 0 (forward-line -1)) @@ -5774,7 +6008,6 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." ;; if we are in a parenthesized list, and the user likes to indent these, return. ;; unless we are in the newfangled coverpoint or constraint blocks (if (and - verilog-indent-lists (verilog-in-paren) (not (verilog-in-coverage-p)) ) @@ -5791,7 +6024,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (looking-at verilog-in-constraint-re) )) ; may still get hosed if concat in constraint (let ((sp (point))) (if (and - (not (looking-at verilog-complete-reg)) + (not (looking-at verilog-complete-re)) (verilog-continued-line-1 lim)) (progn (goto-char sp) (throw 'nesting 'cexp)) @@ -5996,6 +6229,12 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (goto-char here) ; or is clocking, starts a new block (throw 'nesting 'block))))) + ;; if find `ifn?def `else `elsif + ((or (match-end 20) + (match-end 21) + (match-end 22)) + (throw 'continue 'foo)) + ((looking-at "\\<class\\|struct\\|function\\|task\\>") ;; *sigh* These words have an optional prefix: ;; extern {virtual|protected}? function a(); @@ -6025,7 +6264,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." ;; {assert|assume|cover} property (); are complete ;; and could also be labeled: - foo: assert property ;; but - ;; property ID () ... needs end_property + ;; property ID () ... needs endproperty (verilog-beg-of-statement) (if (looking-at verilog-property-re) (throw 'continue 'statement) ; We don't need an endproperty for these @@ -6110,6 +6349,23 @@ of the appropriate enclosing block." (ding 't) (setq nest 0)))))) +(defun verilog-leap-to-class-head () + (let ((nest 1) + (class-re (concat "\\(\\<class\\>\\)\\|\\(\\<endclass\\>\\)"))) + (catch 'skip + (while (verilog-re-search-backward class-re nil 'move) + (cond + ((match-end 1) ; begin + (when (verilog-looking-back "\\(\\<interface\\>\\s-+\\)\\|\\(\\<virtual\\>\\s-+\\)" (point-at-bol)) + (goto-char (match-beginning 0))) + (unless (verilog-looking-back "\\<typedef\\>\\s-+" (point-at-bol)) + (setq nest (1- nest)) + (if (= 0 nest) + ;; Now previous line describes syntax + (throw 'skip 1)))) + ((match-end 2) ; end + (setq nest (1+ nest)))))))) + (defun verilog-leap-to-head () "Move point to the head of this block. Jump from end to matching begin, from endcase to matching case, and so on." @@ -6137,7 +6393,9 @@ Jump from end to matching begin, from endcase to matching case, and so on." (setq reg "\\(\\<fork\\>\\)\\|\\(\\<join\\(_any\\|_none\\)?\\>\\)" )) ((looking-at "\\<endclass\\>") ;; 5: Search back for matching class - (setq reg "\\(\\<class\\>\\)\\|\\(\\<endclass\\>\\)" )) + (catch 'nesting + (verilog-leap-to-class-head) + (setq reg nil))) ((looking-at "\\<endtable\\>") ;; 6: Search back for matching table (setq reg "\\(\\<table\\>\\)\\|\\(\\<endtable\\>\\)" )) @@ -6175,7 +6433,19 @@ Jump from end to matching begin, from endcase to matching case, and so on." (setq reg "\\(\\<\\(rand\\)?sequence\\>\\)\\|\\(\\<endsequence\\>\\)" )) ((looking-at "\\<endclocking\\>") ;; 12: Search back for matching clocking - (setq reg "\\(\\<clocking\\)\\|\\(\\<endclocking\\>\\)" ))) + (setq reg "\\(\\<clocking\\)\\|\\(\\<endclocking\\>\\)" )) + ;; Search back for matching package + ((looking-at "\\<endpackage\\>") + (setq reg "\\(\\<package\\>\\)" )) + ;; Search back for matching program + ((looking-at "\\<endprogram\\>") + (setq reg "\\(\\<program\\>\\)" )) + ((looking-at "\\<`endif\\>") + ;; Search back for matching `endif `else `elsif + (setq reg "\\(\\<`ifn?def\\>\\)\\|\\(\\<`endif\\>\\)" )) + ((looking-at "\\<`else\\>") + ;; Search back for matching `else `else `elsif + (setq reg "\\(\\<`ifn?def\\>\\|\\<`elsif\\>\\)\\|\\(\\<`else\\>\\)" ))) (if reg (catch 'skip (if (eq nesting 'yes) @@ -6221,7 +6491,7 @@ Jump from end to matching begin, from endcase to matching case, and so on." (throw 'skip 1))))))) (defun verilog-continued-line () - "Return true if this is a continued line. + "Return non-nil if this is a continued line. Set point to where line starts." (let ((continued 't)) (if (eq 0 (forward-line -1)) @@ -6394,10 +6664,10 @@ Optional BOUND limits search." (let ((state (save-excursion (verilog-syntax-ppss)))) (cond ((nth 7 state) ; in // comment - (verilog-re-search-backward "//" nil 'move) + (re-search-backward "//" nil 'move) (skip-chars-backward "/")) ((nth 4 state) ; in /* */ comment - (verilog-re-search-backward "/\\*" nil 'move)))) + (re-search-backward "/\\*" nil 'move)))) (narrow-to-region bound (point)) (while (/= here (point)) (setq here (point)) @@ -6450,13 +6720,60 @@ Optional BOUND limits search." (if jump (beginning-of-line 2)))))))) +(defun verilog-pos-at-beg-of-statement () + "Return point position at the beginning of current statement." + (save-excursion + (verilog-beg-of-statement) + (point))) + +(defun verilog-col-at-beg-of-statement () + "Return current column at the beginning of current statement." + (save-excursion + (verilog-beg-of-statement) + (current-column))) + +(defun verilog-pos-at-end-of-statement () + "Return point position at the end of current statement." + (save-excursion + (verilog-end-of-statement))) + +(defun verilog-col-at-end-of-statement () + "Return current column at the end of current statement." + (save-excursion + (verilog-end-of-statement) + (current-column))) + +(defun verilog-pos-at-forward-syntactic-ws () + "Return point position at next non whitespace/comment token." + (save-excursion + (verilog-forward-syntactic-ws) + (point))) + +(defun verilog-col-at-forward-syntactic-ws () + "Return current column at next non whitespace/comment token." + (save-excursion + (verilog-forward-syntactic-ws) + (current-column))) + +(defun verilog-pos-at-backward-syntactic-ws () + "Return point position at previous non whitespace/comment token." + (save-excursion + (verilog-backward-syntactic-ws) + (point))) + +(defun verilog-col-at-backward-syntactic-ws () + "Return current column at previous non whitespace/comment token." + (save-excursion + (verilog-backward-syntactic-ws) + (current-column))) + (defun verilog-in-comment-p () - "Return true if in a star or // comment." + "Return non-nil if in a star or // comment." (let ((state (save-excursion (verilog-syntax-ppss)))) (or (nth 4 state) (nth 7 state)))) (defun verilog-in-star-comment-p () - "Return true if in a star comment." + "Return non-nil if in a star comment." (let ((state (save-excursion (verilog-syntax-ppss)))) (and (nth 4 state) ; t if in a comment of style a // or b /**/ @@ -6465,40 +6782,39 @@ Optional BOUND limits search." )))) (defun verilog-in-slash-comment-p () - "Return true if in a slash comment." + "Return non-nil if in a slash comment." (let ((state (save-excursion (verilog-syntax-ppss)))) (nth 7 state))) (defun verilog-in-comment-or-string-p () - "Return true if in a string or comment." + "Return non-nil if in a string or comment." (let ((state (save-excursion (verilog-syntax-ppss)))) (or (nth 3 state) (nth 4 state) (nth 7 state)))) ; Inside string or comment) (defun verilog-in-attribute-p () - "Return true if point is in an attribute (* [] attribute *)." - (save-match-data - (save-excursion - (verilog-re-search-backward "\\((\\*\\)\\|\\(\\*)\\)" nil 'move) - (cond - ((match-end 1) - (progn (goto-char (match-end 1)) - (not (looking-at "\\s-*)"))) - nil) - ((match-end 2) - (progn (goto-char (match-beginning 2)) - (not (looking-at "(\\s-*"))) - nil) - (t nil))))) + "Return non-nil if point is in an attribute (* [] attribute *)." + (let ((pos (point))) + (save-match-data + (save-excursion + (and (verilog-re-search-backward "(\\*" nil 'move) + (progn (forward-sexp) + (skip-chars-backward "*)")) + (< pos (point))))))) (defun verilog-in-parameter-p () - "Return true if point is in a parameter assignment #( p1=1, p2=5)." + "Return non-nil if point is in a parameter assignment #( p1=1, p2=5)." (save-match-data (save-excursion - (verilog-re-search-backward "\\(#(\\)\\|\\()\\)" nil 'move) - (numberp (match-beginning 1))))) + (and (progn + (verilog-backward-up-list 1) + (verilog-backward-syntactic-ws) + (= (preceding-char) ?\#)) + (progn + (verilog-beg-of-statement-1) + (looking-at verilog-defun-re)))))) (defun verilog-in-escaped-name-p () - "Return true if in an escaped name." + "Return non-nil if in an escaped name." (save-excursion (backward-char) (skip-chars-backward "^ \t\n\f") @@ -6507,20 +6823,20 @@ Optional BOUND limits search." nil))) (defun verilog-in-directive-p () - "Return true if in a directive." + "Return non-nil if in a directive." (save-excursion (beginning-of-line) (looking-at verilog-directive-re-1))) (defun verilog-in-parenthesis-p () - "Return true if in a ( ) expression (but not { } or [ ])." + "Return non-nil if in a ( ) expression (but not { } or [ ])." (save-match-data (save-excursion (verilog-re-search-backward "\\((\\)\\|\\()\\)" nil 'move) (numberp (match-beginning 1))))) (defun verilog-in-paren () - "Return true if in a parenthetical expression. + "Return non-nil if in a parenthetical expression. May cache result using `verilog-syntax-ppss'." (let ((state (save-excursion (verilog-syntax-ppss)))) (> (nth 0 state) 0 ))) @@ -6534,7 +6850,7 @@ May cache result using `verilog-syntax-ppss'." 0 ))) (defun verilog-in-paren-quick () - "Return true if in a parenthetical expression. + "Return non-nil if in a parenthetical expression. Always starts from `point-min', to allow inserts with hooks disabled." ;; The -quick refers to its use alongside the other -quick functions, ;; not that it's likely to be faster than verilog-in-paren. @@ -6542,7 +6858,7 @@ Always starts from `point-min', to allow inserts with hooks disabled." (> (nth 0 state) 0 ))) (defun verilog-in-struct-p () - "Return true if in a struct declaration." + "Return non-nil if in a struct declaration." (interactive) (save-excursion (if (verilog-in-paren) @@ -6568,7 +6884,7 @@ Return >0 for nested struct." nil)))) (defun verilog-in-coverage-p () - "Return true if in a constraint or coverpoint expression." + "Return non-nil if in a constraint or coverpoint expression." (interactive) (save-excursion (if (verilog-in-paren) @@ -6608,7 +6924,7 @@ Also move point to constraint." (equal (char-before) ?\;) (equal (char-before) ?\})) ;; skip what looks like bus repetition operator {#{ - (not (string-match "^{\\s-*[()0-9a-zA-Z_\\]*\\s-*{" + (not (string-match "^{\\s-*[][()0-9a-zA-Z_,:\\]*\\s-*{" (buffer-substring p (point))))))))) (progn (let ( (pt (point)) (pass 0)) @@ -6625,7 +6941,7 @@ Also move point to constraint." )) ;; if first word token not keyword, it maybe the instance name ;; check next word token - (if (looking-at "\\<\\w+\\>\\|\\s-*(\\s-*\\S-+") + (if (looking-at "\\<\\w+\\>\\|\\s-*[[(}]\\s-*\\S-+") (progn (verilog-beg-of-statement) (if (and (not (string-match verilog-named-block-re (buffer-substring pt (point)))) ;; Abort if 'begin' keyword is found @@ -6674,13 +6990,39 @@ Also move point to constraint." (verilog-in-struct-p) (looking-at "}\\(?:\\s-*\\w+\\s-*\\(?:,\\s-*\\w+\\s-*\\)*\\)?;"))) +(defun verilog-at-struct-decl-p () + "Return non-nil if at a struct declaration." + (interactive) + (save-excursion + (verilog-re-search-forward "{" (point-at-eol) t) + (unless (bobp) + (backward-char)) + (verilog-at-struct-p))) + +(defun verilog-at-enum-p () + "If at the { of a enum, return true, not moving point." + (save-excursion + (when (equal (char-after) ?\{) + (verilog-beg-of-statement) + (beginning-of-line) + (when (verilog-re-search-forward verilog-typedef-enum-re (verilog-pos-at-end-of-statement) t) + t)))) + +(defun verilog-at-enum-decl-p () + "Return non-nil if at a enum declaration." + (interactive) + (save-excursion + (verilog-re-search-forward "{" (verilog-pos-at-end-of-statement) t) + (unless (bobp) + (backward-char)) + (verilog-at-enum-p))) + (defun verilog-parenthesis-depth () "Return non zero if in parenthetical-expression." (save-excursion (nth 1 (verilog-syntax-ppss)))) - (defun verilog-skip-forward-comment-or-string () - "Return true if in a string or comment." + "Return non-nil if in a string or comment." (let ((state (save-excursion (verilog-syntax-ppss)))) (cond ((nth 3 state) ;Inside string @@ -6695,7 +7037,7 @@ Also move point to constraint." nil)))) (defun verilog-skip-backward-comment-or-string () - "Return true if in a string or comment." + "Return non-nil if in a string or comment." (let ((state (save-excursion (verilog-syntax-ppss)))) (cond ((nth 3 state) ;Inside string @@ -6712,7 +7054,7 @@ Also move point to constraint." nil)))) (defun verilog-skip-backward-comments () - "Return true if a comment was skipped." + "Return non-nil if a comment was skipped." (let ((more t)) (while more (setq more @@ -6831,6 +7173,9 @@ Only look at a few lines to determine indent level." (let ((type (car indent-str)) (ind (car (cdr indent-str)))) (cond + (; handle indentation ignoring + (verilog-indent-ignore-p) + nil) (; handle continued exp (eq type 'cexp) (let ((here (point))) @@ -6840,14 +7185,14 @@ Only look at a few lines to determine indent level." (= (preceding-char) ?\,) (save-excursion (verilog-beg-of-statement-1) - (looking-at verilog-declaration-re))) + (verilog-looking-at-decl-to-align))) (let* ( fst (val (save-excursion (backward-char 1) (verilog-beg-of-statement-1) (setq fst (point)) - (if (looking-at verilog-declaration-re) + (if (looking-at (verilog-get-declaration-re)) (progn ; we have multiple words (goto-char (match-end 0)) (skip-chars-forward " \t") @@ -6869,9 +7214,9 @@ Only look at a few lines to determine indent level." (+ (current-column) verilog-cexp-indent)))))) (goto-char here) (indent-line-to val) - (if (and (not verilog-indent-lists) - (verilog-in-paren)) - (verilog-pretty-declarations-auto)) + (when (and (not verilog-indent-lists) + (verilog-in-paren)) + (verilog-pretty-declarations-auto)) )) ((= (preceding-char) ?\) ) (goto-char here) @@ -6897,21 +7242,17 @@ Only look at a few lines to determine indent level." (; handle inside parenthetical expressions (eq type 'cparenexp) - (let* ( here - (val (save-excursion - (verilog-backward-up-list 1) - (forward-char 1) - (if verilog-indent-lists - (skip-chars-forward " \t") - (verilog-forward-syntactic-ws)) + (let* ((val (verilog-cparenexp-indent-level)) + (here (save-excursion + (verilog-backward-up-list 1) + (forward-char 1) + (skip-chars-forward " \t") + (point))) + (decl (save-excursion + (goto-char here) + (verilog-forward-syntactic-ws) (setq here (point)) - (current-column))) - - (decl (save-excursion - (goto-char here) - (verilog-forward-syntactic-ws) - (setq here (point)) - (looking-at verilog-declaration-re)))) + (looking-at (verilog-get-declaration-re))))) (indent-line-to val) (if decl (verilog-pretty-declarations-auto)))) @@ -6938,17 +7279,20 @@ Only look at a few lines to determine indent level." (;-- defun (and (eq type 'defun) - (looking-at verilog-zero-indent-re)) + (or (and verilog-indent-class-inside-pkg + (looking-at verilog-zero-indent-no-class-re)) + (and (not verilog-indent-class-inside-pkg) + (looking-at verilog-zero-indent-re)))) (indent-line-to 0)) (;-- declaration (and (or (eq type 'defun) (eq type 'block)) - (looking-at verilog-declaration-re) + (verilog-looking-at-decl-to-align) ;; Do not consider "virtual function", "virtual task", "virtual class" ;; as declarations - (not (looking-at (concat verilog-declaration-re + (not (looking-at (concat (verilog-get-declaration-re) "\\s-+\\(function\\|task\\|class\\)\\b")))) (verilog-indent-declaration ind)) @@ -6994,6 +7338,81 @@ Do not count named blocks or case-statements." (t (current-column))))) +(defun verilog-cparenexp-indent-level () + "Return indent level for current line inside a parenthetical expression." + (let ((start-pos (point)) + (close-par (looking-at "[)}]")) + pos pos-arg-paren) + (save-excursion + (verilog-backward-up-list 1) + (if verilog-indent-lists + (progn + (forward-char 1) + (skip-chars-forward " \t") + (current-column)) + ;; Indentation with `verilog-indent-lists' set to nil + (verilog-beg-of-statement-1) + (when (looking-at "\\<\\(function\\|task\\)\\>") + (verilog-beg-of-statement)) ; find virtual/protected/static + (cond (;; 1) Closing ); of a module/function/task + (and close-par + (save-excursion + (verilog-beg-of-statement-1) + (or (looking-at verilog-complete-re) + (progn (beginning-of-line) + (not (looking-at verilog-assignment-operation-re)))))) + (current-column)) + (;; 2) if (condition) + (looking-at "(") + (forward-char 1) + (skip-chars-forward " \t\f" (point-at-eol)) + (current-column)) + (;; 3) Inside a module/defun param list or function/task argument list + (or (looking-at verilog-defun-level-re) + (looking-at "\\(\\<\\(virtual\\|protected\\|static\\)\\>\\s-+\\)?\\(\\<task\\>\\|\\<function\\>\\)")) + (setq pos-arg-paren (save-excursion + (goto-char start-pos) + (verilog-backward-up-list 1) + (forward-char) + (skip-chars-forward " \t") + (when (not (eolp)) + (current-column)))) + (or pos-arg-paren + ;; arg in next line after ( + (+ (current-column) verilog-indent-level))) + (;; 4) Assignment operation + (save-excursion + (beginning-of-line) + (and (looking-at verilog-assignment-operation-re) + (save-excursion + (goto-char (match-beginning 2)) + (not (verilog-within-string))) + (progn (verilog-forward-syntactic-ws) + (not (looking-at verilog-complete-re))))) + (goto-char (match-end 2)) + (skip-chars-forward " \t\f" (point-at-eol)) + (skip-chars-forward "{(" (1+ (point))) + (skip-chars-forward " \t\f" (point-at-eol)) + (current-column)) + (;; 5) Typedef enum declaration + (verilog-at-enum-decl-p) + (verilog-re-search-forward "{" (verilog-pos-at-end-of-statement) t) + (if (> (verilog-pos-at-forward-syntactic-ws) (point-at-eol)) + (+ (verilog-col-at-beg-of-statement) verilog-indent-level) + (verilog-col-at-forward-syntactic-ws))) + (;; 6) Long reporting strings (e.g. $display or $sformatf inside `uvm_info) + (save-excursion + (goto-char start-pos) + (verilog-backward-up-list 1) + (setq pos (1+ (point))) + (backward-word) + (or (looking-at (concat "\\$" verilog-identifier-re)) ; System function/task + (looking-at verilog-uvm-statement-re))) ; `uvm_* macros + (goto-char pos) + (current-column)) + (t ;; 7) Default + (+ (current-column) verilog-indent-level))))))) + (defun verilog-indent-comment () "Indent current line as comment." (let* ((stcol @@ -7053,90 +7472,137 @@ _ARG is ignored, for `comment-indent-function' compatibility." ;; +(defun verilog-align-comments (startpos endpos) + "Align inline comments between STARTPOS and ENDPOS." + (let (comm-ind e) + (when verilog-align-decl-expr-comments + (setq comm-ind (verilog-get-comment-align-indent (marker-position startpos) endpos)) + (save-excursion + (goto-char (marker-position startpos)) + (while (progn (setq e (marker-position endpos)) + (< (point) e)) + (when (verilog-search-comment-in-declaration e) + (goto-char (match-beginning 0)) + (delete-horizontal-space) + (indent-to (1- (+ comm-ind verilog-align-comment-distance))))))))) + (defun verilog-pretty-declarations-auto (&optional quiet) "Call `verilog-pretty-declarations' QUIET based on `verilog-auto-lineup'." (when (or (eq 'all verilog-auto-lineup) (eq 'declarations verilog-auto-lineup)) (verilog-pretty-declarations quiet))) +(defun verilog--pretty-declarations-find-end (&optional reg-end) + "Find end position for current alignment of declarations. +If region is active, use arg REG-END to set a limit on the alignment." + (let (e) + (if (and (verilog-parenthesis-depth) + (not (verilog-in-struct-p))) + ;; In an argument list or parameter block + (progn + (verilog-backward-up-list -1) + (forward-char -1) + (verilog-backward-syntactic-ws) + (if (region-active-p) + (min reg-end (point)) + (point))) + ;; In a declaration block (not in argument list) + (verilog-end-of-statement) + (setq e (point)) ; Might be on last line + (verilog-forward-syntactic-ws) + (while (verilog-looking-at-decl-to-align) + (verilog-end-of-statement) + (setq e (point)) + (verilog-forward-syntactic-ws)) + (if (region-active-p) + (min reg-end e) + e)))) + +(defun verilog--pretty-declarations-find-base-ind () + "Find base indentation for current alignment of declarations." + (if (and (verilog-parenthesis-depth) + (not (verilog-in-struct-p))) + ;; In an argument list or parameter block + (progn + (unless (or (verilog-looking-back "(" (point-at-bol)) + (bolp)) + (forward-char 1)) + (skip-chars-forward " \t") + (current-column)) + ;; In a declaration block (not in argument list) + (progn + (verilog-do-indent (verilog-calculate-indent)) + (verilog-forward-ws&directives) + (current-column)))) + (defun verilog-pretty-declarations (&optional quiet) "Line up declarations around point. Be verbose about progress unless optional QUIET set." (interactive) - (let* ((m1 (make-marker)) - (e (point)) - el - r - (here (point)) - ind - start - startpos - end - endpos - base-ind - ) + (let ((m1 (make-marker)) + (e (point)) + (here (point)) + el r ind start startpos end endpos base-ind rstart rend) (save-excursion + (when (region-active-p) + (setq rstart (region-beginning)) + (setq rend (region-end)) + (goto-char rstart)) ; Shrinks the region but ensures that start is a valid declaration (if (progn - ;; (verilog-beg-of-statement-1) + ;; Check if alignment can be performed (beginning-of-line) (verilog-forward-syntactic-ws) - (and (not (verilog-in-directive-p)) ; could have `define input foo - (looking-at verilog-declaration-re))) - (progn - (if (verilog-parenthesis-depth) - ;; in an argument list or parameter block - (setq el (verilog-backward-up-list -1) - start (progn - (goto-char e) - (verilog-backward-up-list 1) - (forward-line) ; ignore ( input foo, - (verilog-re-search-forward verilog-declaration-re el 'move) - (goto-char (match-beginning 0)) + (or (and (not (verilog-in-directive-p)) ; could have `define input foo + (verilog-looking-at-decl-to-align)) + (and (verilog-parenthesis-depth) + (looking-at verilog-interface-modport-re)))) + ;; Find boundaries of alignment + (progn + (cond (;; Using region + (region-active-p) + (setq start rstart + startpos (set-marker (make-marker) start) + end (progn (goto-char start) + (verilog--pretty-declarations-find-end rend)) + endpos (set-marker (make-marker) end) + base-ind (progn (goto-char start) + (verilog--pretty-declarations-find-base-ind)))) + (;; In an argument list or parameter block + (and (verilog-parenthesis-depth) + (not (verilog-in-struct-p))) + (setq el (verilog-backward-up-list -1) + start (progn + (goto-char e) + (verilog-backward-up-list 1) + (verilog-re-search-forward (verilog-get-declaration-re 'iface-mp) el 'move) + (goto-char (match-beginning 0)) + (skip-chars-backward " \t") + (point)) + startpos (set-marker (make-marker) start) + end (progn (goto-char start) + (verilog--pretty-declarations-find-end)) + endpos (set-marker (make-marker) end) + base-ind (progn (goto-char start) + (verilog--pretty-declarations-find-base-ind)))) + (;; In a declaration block (not in argument list) + t + (setq + start (progn + (verilog-beg-of-statement-1) + (while (and (verilog-looking-at-decl-to-align) + (not (bobp))) (skip-chars-backward " \t") - (point)) - startpos (set-marker (make-marker) start) - end (progn - (goto-char start) - (verilog-backward-up-list -1) - (forward-char -1) - (verilog-backward-syntactic-ws) - (point)) - endpos (set-marker (make-marker) end) - base-ind (progn - (goto-char start) - (forward-char 1) - (skip-chars-forward " \t") - (current-column))) - ;; in a declaration block (not in argument list) - (setq - start (progn - (verilog-beg-of-statement-1) - (while (and (looking-at verilog-declaration-re) - (not (bobp))) - (skip-chars-backward " \t") - (setq e (point)) - (beginning-of-line) - (verilog-backward-syntactic-ws) - (backward-char) - (verilog-beg-of-statement-1)) - e) - startpos (set-marker (make-marker) start) - end (progn - (goto-char here) - (verilog-end-of-statement) - (setq e (point)) ;Might be on last line - (verilog-forward-syntactic-ws) - (while (looking-at verilog-declaration-re) - (verilog-end-of-statement) - (setq e (point)) - (verilog-forward-syntactic-ws)) - e) - endpos (set-marker (make-marker) end) - base-ind (progn - (goto-char start) - (verilog-do-indent (verilog-calculate-indent)) - (verilog-forward-ws&directives) - (current-column)))) + (setq e (point)) + (verilog-backward-syntactic-ws) + (backward-char) + (verilog-beg-of-statement-1)) + e) + startpos (set-marker (make-marker) start) + end (progn (goto-char here) + (verilog--pretty-declarations-find-end)) + endpos (set-marker (make-marker) end) + base-ind (progn (goto-char start) + (verilog--pretty-declarations-find-base-ind))))) ;; OK, start and end are set (goto-char (marker-position startpos)) (if (and (not quiet) @@ -7152,12 +7618,13 @@ Be verbose about progress unless optional QUIET set." (indent-line-to base-ind) (verilog-forward-ws&directives) (if (< (point) e) - (verilog-re-search-forward "[ \t\n\f]" e 'move))) + (verilog-re-search-forward "[ \t\n\f]" (marker-position endpos) 'move))) (t - (just-one-space) - (verilog-re-search-forward "[ \t\n\f]" e 'move))) - ;;(forward-line) - ) + (unless (verilog-looking-back "(" (point-at-bol)) + (just-one-space)) + (if (looking-at verilog-comment-start-regexp) + (verilog-forward-syntactic-ws) + (verilog-re-search-forward "[ \t\n\f]" e 'move))))) ;; Now find biggest prefix (setq ind (verilog-get-lineup-indent (marker-position startpos) endpos)) ;; Now indent each line. @@ -7167,27 +7634,27 @@ Be verbose about progress unless optional QUIET set." (> r 0)) (setq e (point)) (unless quiet (message "%d" r)) - ;; (verilog-do-indent (verilog-calculate-indent))) (verilog-forward-ws&directives) (cond - ((or (and verilog-indent-declaration-macros - (looking-at verilog-declaration-re-2-macro)) - (looking-at verilog-declaration-re-2-no-macro)) - (let ((p (match-end 0))) - (set-marker m1 p) - (if (verilog-re-search-forward "[[#`]" p 'move) - (progn - (forward-char -1) - (just-one-space) - (goto-char (marker-position m1)) + ((looking-at (verilog-get-declaration-re 'iface-mp)) + (unless (looking-at (verilog-get-declaration-re 'embedded-comments)) + (let ((p (match-end 0))) + (set-marker m1 p) + (if (verilog-re-search-forward "[[#`]" p 'move) + (progn + (forward-char -1) + (just-one-space) + (goto-char (marker-position m1)) + (delete-horizontal-space) + (indent-to ind 1)) + (progn (delete-horizontal-space) - (indent-to ind 1)) - (progn - (delete-horizontal-space) - (indent-to ind 1))))) + (indent-to ind 1)))))) ((verilog-continued-line-1 (marker-position startpos)) (goto-char e) - (indent-line-to ind)) + (unless (and (verilog-in-parenthesis-p) + (looking-at (concat "\\s-*" verilog-identifier-sym-re "\\s-+" verilog-identifier-sym-re "\\s-*"))) + (indent-line-to ind))) ((verilog-in-struct-p) ;; could have a declaration of a user defined item (goto-char e) @@ -7197,104 +7664,202 @@ Be verbose about progress unless optional QUIET set." (verilog-forward-ws&directives) (forward-line -1))) (forward-line 1)) - (unless quiet (message ""))))))) + ;; Align comments if enabled + (when verilog-align-decl-expr-comments + (verilog-align-comments startpos endpos))) + ;; Exit + (unless quiet (message "")))))) + +(defun verilog--pretty-expr-assignment-found (&optional discard-re) + "Return non-nil if point is at a valid assignment operation to be aligned. +Ensure cursor is not over DISCARD-RE (e.g. Verilog keywords). +If returned non-nil, update match data according to `verilog-assignment-operation-re'." + ;; Not looking at a verilog keyword sentence (i.e looking at a potential assignment) + (and (if discard-re + (not (looking-at discard-re)) + t) + ;; Corner case to filter first parameter on param lists + (save-excursion + (if (and (verilog-re-search-forward verilog-assignment-operation-re (point-at-eol) 'move) + (verilog-in-parenthesis-p)) + (progn (verilog-backward-up-list 1) + (forward-char 1) + (not (eq 0 (string-match discard-re (buffer-substring-no-properties (point) (point-at-eol)))))) + t)) + ;; Don't work on multiline assignments unless they are continued lines + ;; e.g, multiple parameters or variable declarations in the same statement + (if (save-excursion + (and (not (verilog-in-parameter-p)) + (verilog-continued-line) + (not (looking-at verilog-basic-complete-re)))) + (save-excursion + (verilog-beg-of-statement-1) + (looking-at (verilog-get-declaration-re))) + t) + ;; Ensure it's not any kind of logical comparison + (save-excursion + (unless (and (not (verilog-in-parameter-p)) + (verilog-re-search-forward (verilog-regexp-words '("if" "for" "assert" "with")) (point-at-eol) 'move)) + t)) + ;; Looking at an assignment (last check, provides match data) + (looking-at verilog-assignment-operation-re))) + +(defun verilog--pretty-expr-find-end (&optional discard-re reg-end) + "Find end position for current alignment of expressions. +Use optional arg DISCARD-RE when aligning expressions outside of an +argument list and REG-END to set a limit on the alignment when the +region is active." + (if (verilog-in-parenthesis-p) + ;; Limit end in argument list + (progn + (verilog-backward-up-list -1) + (forward-char -1) + (verilog-backward-syntactic-ws) + (if (region-active-p) + (min reg-end (point)) + (point))) + ;; Limit end in non-argument list + (save-excursion ; EOL of the last line of the assignment block + (end-of-line) + (let ((pt (point))) ; Might be on last line + (verilog-forward-syntactic-ws) + (beginning-of-line) + (while (and (verilog--pretty-expr-assignment-found discard-re) + (progn + (end-of-line) + (not (eq pt (point))))) + (setq pt (point)) + (verilog-forward-syntactic-ws) + (beginning-of-line)) + (if (region-active-p) + (min reg-end pt) + pt))))) (defun verilog-pretty-expr (&optional quiet) "Line up expressions around point. If QUIET is non-nil, do not print messages showing the progress of line-up." (interactive) - (unless (verilog-in-comment-or-string-p) + (let* ((basic-complete-pretty-expr-re (if verilog-align-assign-expr + verilog-basic-complete-expr-no-assign-re + verilog-basic-complete-expr-re)) + (complete-pretty-expr-re (concat verilog-extended-complete-re "\\|\\(" basic-complete-pretty-expr-re "\\)")) + (discard-re (concat "^\\s-*\\(" complete-pretty-expr-re "\\)")) + rstart rend) (save-excursion - (let ((regexp (concat "^\\s-*" verilog-complete-reg)) - (regexp1 (concat "^\\s-*" verilog-basic-complete-re))) + (when (region-active-p) + (setq rstart (region-beginning)) + (setq rend (region-end)) + (goto-char rstart)) + (unless (verilog-in-comment-or-string-p) (beginning-of-line) - (when (and (not (looking-at regexp)) - (looking-at verilog-assignment-operation-re) + (when (and (verilog--pretty-expr-assignment-found discard-re) (save-excursion (goto-char (match-end 2)) (and (not (verilog-in-attribute-p)) - (not (verilog-in-parameter-p)) (not (verilog-in-comment-or-string-p))))) - (let* ((start (save-excursion ; BOL of the first line of the assignment block - (beginning-of-line) - (let ((pt (point))) - (verilog-backward-syntactic-ws) - (beginning-of-line) - (while (and (not (looking-at regexp1)) - (looking-at verilog-assignment-operation-re) - (not (bobp))) - (setq pt (point)) - (verilog-backward-syntactic-ws) - (beginning-of-line)) ; Ack, need to grok `define - pt))) - (end (save-excursion ; EOL of the last line of the assignment block - (end-of-line) - (let ((pt (point))) ; Might be on last line - (verilog-forward-syntactic-ws) - (beginning-of-line) - (while (and - (not (looking-at regexp1)) - (looking-at verilog-assignment-operation-re) - (progn - (end-of-line) - (not (eq pt (point))))) - (setq pt (point)) - (verilog-forward-syntactic-ws) - (beginning-of-line)) - pt))) - (contains-2-char-operator (string-match "<=" (buffer-substring-no-properties start end))) - (endmark (set-marker (make-marker) end))) - (goto-char start) - (verilog-do-indent (verilog-calculate-indent)) + (let* ((start (cond (;; Using region + (region-active-p) + rstart) + (;; Parameter list + (verilog-in-parenthesis-p) + (progn + (verilog-backward-up-list 1) + (forward-char) + (verilog-re-search-forward verilog-assignment-operation-re-2 nil 'move) + (goto-char (match-beginning 0)) + (point))) + (t ;; Declarations + (save-excursion ; BOL of the first line of the assignment block + (beginning-of-line) + (let ((pt (point))) + (verilog-backward-syntactic-ws) + (beginning-of-line) + (while (and (verilog--pretty-expr-assignment-found discard-re) + (not (bobp))) + (setq pt (point)) + (verilog-backward-syntactic-ws) + (beginning-of-line)) ; Ack, need to grok `define + pt))))) + (startpos (set-marker (make-marker) start)) + (end (cond (;; Using region + (region-active-p) + (verilog--pretty-expr-find-end discard-re rend)) + (;; Parameter list + (verilog-in-parenthesis-p) + (verilog--pretty-expr-find-end)) + (t ;; Declarations + (verilog--pretty-expr-find-end discard-re)))) + (endpos (set-marker (make-marker) end)) + (contains-2-char-operator (string-match "<=" (buffer-substring-no-properties start end)))) + ;; Start with alignment + (goto-char startpos) + (unless (save-excursion + (beginning-of-line) + (looking-at discard-re)) + (verilog-do-indent (verilog-calculate-indent))) (when (and (not quiet) - (> (- end start) 100)) + (> (- (marker-position endpos) (marker-position startpos)) 100)) (message "Lining up expressions.. (please stand by)")) - ;; Set indent to minimum throughout region ;; Rely on mark rather than on point as the indentation changes can ;; make the older point reference obsolete - (while (< (point) (marker-position endmark)) + (while (< (point) (marker-position endpos)) (beginning-of-line) (save-excursion - (verilog-just-one-space verilog-assignment-operation-re)) + (if (looking-at verilog-complete-re) + (progn (goto-char (marker-position startpos)) + (verilog-just-one-space verilog-assignment-operation-re-2)) + (verilog-just-one-space verilog-assignment-operation-re))) (verilog-do-indent (verilog-calculate-indent)) (end-of-line) (verilog-forward-syntactic-ws)) - (let ((ind (verilog-get-lineup-indent-2 verilog-assignment-operation-re start (marker-position endmark))) ; Find the biggest prefix + (let ((ind (verilog-get-lineup-indent-2 verilog-assignment-operation-re (marker-position startpos) (marker-position endpos))) ; Find the biggest prefix e) ;; Now indent each line. - (goto-char start) + (goto-char (marker-position startpos)) (while (progn - (setq e (marker-position endmark)) + (setq e (marker-position endpos)) (> e (point))) (unless quiet (message " verilog-pretty-expr: %d" (- e (point)))) (setq e (point)) (cond - ((looking-at verilog-assignment-operation-re) + ((or (looking-at verilog-assignment-operation-re) + (and (verilog-in-parenthesis-p) + (looking-at verilog-assignment-operation-re-2))) (goto-char (match-beginning 2)) - (unless (or (verilog-in-parenthesis-p) ; Leave attributes and comparisons alone + (unless (or (and (verilog-in-parenthesis-p) ; Leave attributes and comparisons alone + (save-excursion ; Allow alignment of some expressions inside param/port list + (verilog-backward-up-list 1) + (verilog-beg-of-statement-1) + (not (looking-at verilog-defun-level-re)))) (verilog-in-coverage-p)) (if (and contains-2-char-operator (eq (char-after) ?=)) (indent-to (1+ ind)) ; Line up the = of the <= with surrounding = - (indent-to ind)))) - ((verilog-continued-line-1 start) + (indent-to ind))) + (forward-line 1)) + ((and (save-excursion + (verilog-forward-syntactic-ws) + (not (looking-at verilog-complete-re))) + (verilog-continued-line-1 (marker-position startpos))) (goto-char e) - (indent-line-to ind)) - (t ; Must be comment or white space + (indent-line-to ind) + (forward-line 1)) + (t ; Must be comment, white space or syntax error (goto-char e) - (verilog-forward-ws&directives) - (forward-line -1))) - (forward-line 1)) + (forward-line 1)))) + ;; Align comments if enabled + (when verilog-align-decl-expr-comments + (verilog-align-comments startpos endpos)) (unless quiet (message ""))))))))) (defun verilog-just-one-space (myre) "Remove extra spaces around regular expression MYRE." (interactive) - (if (and (not(looking-at verilog-complete-reg)) + (if (and (not(looking-at verilog-complete-re)) (looking-at myre)) (let ((p1 (match-end 1)) (p2 (match-end 2))) @@ -7312,59 +7877,63 @@ BASEIND is the base indent to offset everything." ;; `ind' is used in expressions stored in `verilog-indent-alist'. (verilog--suppressed-warnings ((lexical ind)) (defvar ind)) (let ((pos (point-marker)) - (lim (save-excursion - ;; (verilog-re-search-backward verilog-declaration-opener nil 'move) - (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)\\|\\(\\<task\\>\\)" nil 'move) - (point))) - (ind) - (val) - (m1 (make-marker))) - (setq val - (+ baseind (eval (cdr (assoc 'declaration verilog-indent-alist))))) + (m1 (make-marker)) + (in-paren (verilog-parenthesis-depth)) + (val (+ baseind (eval (cdr (assoc 'declaration verilog-indent-alist))))) + ind) (indent-line-to val) - ;; Use previous declaration (in this module) as template. - (if (or (eq 'all verilog-auto-lineup) - (eq 'declarations verilog-auto-lineup)) - (if (verilog-re-search-backward - (or (and verilog-indent-declaration-macros - verilog-declaration-re-1-macro) - verilog-declaration-re-1-no-macro) - lim t) - (progn - (goto-char (match-end 0)) - (skip-chars-forward " \t") - (setq ind (current-column)) - (goto-char pos) - (setq val - (+ baseind - (eval (cdr (assoc 'declaration verilog-indent-alist))))) - (indent-line-to val) - (if (and verilog-indent-declaration-macros - (looking-at verilog-declaration-re-2-macro)) - (let ((p (match-end 0))) - (set-marker m1 p) - (if (verilog-re-search-forward "[[#`]" p 'move) - (progn - (forward-char -1) - (just-one-space) - (goto-char (marker-position m1)) - (delete-horizontal-space) - (indent-to ind 1)) - (delete-horizontal-space) - (indent-to ind 1))) - (if (looking-at verilog-declaration-re-2-no-macro) - (let ((p (match-end 0))) - (set-marker m1 p) - (if (verilog-re-search-forward "[[`#]" p 'move) - (progn - (forward-char -1) - (just-one-space) - (goto-char (marker-position m1)) - (delete-horizontal-space) - (indent-to ind 1)) - (delete-horizontal-space) - (indent-to ind 1)))))))) + (when (and (or (eq 'all verilog-auto-lineup) + (eq 'declarations verilog-auto-lineup)) + ;; Limit alignment to consecutive statements + (progn + (verilog-backward-syntactic-ws) + (backward-char) + (looking-at ";")) + (progn + (verilog-beg-of-statement) + (looking-at (verilog-get-declaration-re))) + ;; Make sure that we don't jump to an argument list or parameter block if + ;; we were in a declaration block (not in argument list) + (or (and in-paren + (verilog-parenthesis-depth)) + (and (not in-paren) + (not (verilog-parenthesis-depth)))) + ;; Skip variable declarations inside functions/tasks + (skip-chars-backward " \t\f") + (bolp)) + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (setq ind (current-column)) + (goto-char pos) + (setq val + (+ baseind + (eval (cdr (assoc 'declaration verilog-indent-alist))))) + (indent-line-to val) + (if (looking-at (verilog-get-declaration-re)) + (let ((p (match-end 0))) + (set-marker m1 p) + (if (verilog-re-search-forward "[[#`]" p 'move) + (progn + (forward-char -1) + (just-one-space) + (goto-char (marker-position m1)) + (delete-horizontal-space) + (indent-to ind 1)) + (delete-horizontal-space) + (indent-to ind 1))) + (when (looking-at (verilog-get-declaration-re)) + (let ((p (match-end 0))) + (set-marker m1 p) + (if (verilog-re-search-forward "[[`#]" p 'move) + (progn + (forward-char -1) + (just-one-space) + (goto-char (marker-position m1)) + (delete-horizontal-space) + (indent-to ind 1)) + (delete-horizontal-space) + (indent-to ind 1)))))) (goto-char pos))) (defun verilog-get-lineup-indent (b edpos) @@ -7376,16 +7945,13 @@ Region is defined by B and EDPOS." ;; Get rightmost position (while (progn (setq e (marker-position edpos)) (< (point) e)) - (if (verilog-re-search-forward - (or (and verilog-indent-declaration-macros - verilog-declaration-re-1-macro) - verilog-declaration-re-1-no-macro) e 'move) - (progn - (goto-char (match-end 0)) - (verilog-backward-syntactic-ws) - (if (> (current-column) ind) - (setq ind (current-column))) - (goto-char (match-end 0))))) + (when (verilog-re-search-forward (verilog-get-declaration-re 'iface-mp) e 'move) + (goto-char (match-end 0)) + (verilog-backward-syntactic-ws) + (if (> (current-column) ind) + (setq ind (current-column))) + (goto-char (match-end 0)) + (forward-line 1))) (if (> ind 0) (1+ ind) ;; No lineup-string found @@ -7402,12 +7968,13 @@ BEG and END." (save-excursion (let ((ind 0)) (goto-char beg) + (beginning-of-line) ;; Get rightmost position (while (< (point) end) (when (and (verilog-re-search-forward regexp end 'move) (not (verilog-in-attribute-p))) ; skip attribute exprs (goto-char (match-beginning 2)) - (verilog-backward-syntactic-ws) + (skip-chars-backward " \t") (if (> (current-column) ind) (setq ind (current-column))) (goto-char (match-end 0)))) @@ -7420,6 +7987,32 @@ BEG and END." (1+ (current-column)))) ind))) +(defun verilog-search-comment-in-declaration (bound) + "Move cursor to position of comment in declaration and return point. +BOUND is a buffer position that bounds the search." + (and (verilog-re-search-forward (verilog-get-declaration-re 'iface-mp) bound 'move) + (not (looking-at (concat "\\s-*" verilog-comment-start-regexp))) + (re-search-forward verilog-comment-start-regexp (point-at-eol) :noerror))) + +(defun verilog-get-comment-align-indent (b endpos) + "Return the indent level that will line up comments within the region. +Region is defined by B and ENDPOS." + (save-excursion + (let ((ind 0) + e comm-ind) + (goto-char b) + ;; Get rightmost position + (while (progn (setq e (marker-position endpos)) + (< (point) e)) + (when (verilog-search-comment-in-declaration e) + (end-of-line) + (verilog-backward-syntactic-ws) + (setq comm-ind (1+ (current-column))) + (when (> comm-ind ind) + (setq ind comm-ind))) + (forward-line 1)) + ind))) + (defun verilog-comment-depth (type val) "A useful mode debugging aide. TYPE and VAL are comments for insertion." (save-excursion @@ -7439,6 +8032,19 @@ BEG and END." (insert (format "%s %d" type val)))) +(defun verilog-indent-ignore-p () + "Return non-nil if current line should ignore indentation." + (or (and verilog-indent-ignore-multiline-defines + ;; Line with multiline define, ends with "\" or "\" plus trailing whitespace + (or (looking-at ".*\\\\\\s-*$") + (save-excursion ; Last line after multiline define + (verilog-backward-syntactic-ws) + (unless (bobp) + (backward-char)) + (looking-at "\\\\")))) + (and verilog-indent-ignore-regexp ; Ignore lines according to specified regexp + (looking-at verilog-indent-ignore-regexp)))) + ;;; Completion: ;; @@ -7446,7 +8052,7 @@ BEG and END." (defvar verilog-all nil) (defvar verilog-buffer-to-use nil) (defvar verilog-toggle-completions nil - "True means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one. + "Non-nil means \\<verilog-mode-map>\\[verilog-complete-word] should try all possible completions one by one. Repeated use of \\[verilog-complete-word] will show you all of them. Normally, when there is more than one possible completion, it displays a list of all possible completions.") @@ -7598,16 +8204,14 @@ TYPE is `module', `tf' for task or function, or t if unknown." (defun verilog-get-completion-decl (end) "Macro for searching through current declaration (var, type or const) for matches of `str' and adding the occurrence tp `all' through point END." - (let ((re (or (and verilog-indent-declaration-macros - verilog-declaration-re-2-macro) - verilog-declaration-re-2-no-macro)) + (let ((re (verilog-get-declaration-re)) decl-end match) ;; Traverse lines (while (and (< (point) end) (verilog-re-search-forward re end t)) ;; Traverse current line (setq decl-end (save-excursion (verilog-declaration-end))) - (while (and (verilog-re-search-forward verilog-symbol-re decl-end t) + (while (and (verilog-re-search-forward verilog-identifier-sym-re decl-end t) (not (match-end 1))) (setq match (buffer-substring (match-beginning 0) (match-end 0))) (if (string-match (concat "\\<" verilog-str) match) @@ -7619,7 +8223,7 @@ for matches of `str' and adding the occurrence tp `all' through point END." "Calculate all possible completions for variables (or constants)." (let ((start (point))) ;; Search for all reachable var declarations - (verilog-beg-of-defun) + (verilog-re-search-backward verilog-defun-re nil 'move) (save-excursion ;; Check var declarations (verilog-get-completion-decl start)))) @@ -8765,6 +9369,11 @@ Return an array of [outputs inouts inputs wire reg assign const gparam intf]." (t ; Bit width (setq vec (verilog-string-replace-matches "\\s-+" "" nil nil keywd))))) + ;; int'(a) is cast, not declaration of a + ((and (looking-at "'") + (not rvalue)) + (forward-char 1) + (setq expect-signal nil rvalue nil)) ;; Normal or escaped identifier -- note we remember the \ if escaped ((looking-at "\\s-*\\([a-zA-Z0-9`_$]+\\|\\\\[^ \t\n\f]+\\)") (goto-char (match-end 0)) @@ -9702,9 +10311,9 @@ resolve it. If optional RECURSE is non-nil, recurse through \\=`includes. Localparams must be simple assignments to constants, or have their own \"localparam\" label rather than a list of localparams. Thus: - localparam X = 5, Y = 10; // Ok - localparam X = {1\\='b1, 2\\='h2}; // Ok - localparam X = {1\\='b1, 2\\='h2}, Y = 10; // Bad, make into 2 localparam lines + localparam X = 5, Y = 10; // Ok + localparam X = {1\\='b1, 2\\='h2}; // Ok + localparam X = {1\\='b1, 2\\='h2}, Y = 10; // Bad, make into 2 localparam lines Defines must be simple text substitutions, one on a line, starting at the beginning of the line. Any ifdefs or multiline comments around the @@ -9827,8 +10436,7 @@ variable over and over when many modules are compiled together, put a test around the inside each include file: foo.v (an include file): - \\=`ifdef _FOO_V // include if not already included - \\=`else + \\=`ifndef _FOO_V // include if not already included \\=`define _FOO_V ... contents of file \\=`endif // _FOO_V" @@ -10066,7 +10674,7 @@ Results are cached if inside `verilog-preserve-dir-cache'." ;; (prin1 (verilog-dir-files ".")) nil) (defun verilog-dir-file-exists-p (filename) - "Return true if FILENAME exists. + "Return non-nil if FILENAME exists. Like `file-exists-p' but results are cached if inside `verilog-preserve-dir-cache'." (let* ((dirname (file-name-directory filename)) @@ -10105,7 +10713,7 @@ Allows version control to check out the file if need be." modi))))) (defun verilog-is-number (symbol) - "Return true if SYMBOL is number-like." + "Return non-nil if SYMBOL is number-like." (or (string-match "^[0-9 \t:]+$" symbol) (string-match "^[---]*[0-9]+$" symbol) (string-match "^[0-9 \t]+'s?[hdxbo][0-9a-fA-F_xz? \t]*$" symbol))) @@ -10177,7 +10785,7 @@ Or, just the existing dirnames themselves if there are no wildcards." (unless dirnames (error "`verilog-library-directories' should include at least `.'")) (save-match-data - (setq dirnames (reverse dirnames)) ; not nreverse + (setq dirnames (reverse dirnames)) ; not nreverse (let ((dirlist nil) pattern dirfile dirfiles dirname root filename rest basefile) (setq dirnames (mapcar #'substitute-in-file-name dirnames)) @@ -10885,12 +11493,12 @@ This repairs those mis-inserted by an AUTOARG." (if (equal (match-string 3 out) ">>") (int-to-string (ash (string-to-number (match-string 2 out)) (* -1 (string-to-number (match-string 4 out)))))) - (if (equal (match-string 3 out) "<<") - (int-to-string (ash (string-to-number (match-string 2 out)) - (string-to-number (match-string 4 out))))) (if (equal (match-string 3 out) ">>>") (int-to-string (ash (string-to-number (match-string 2 out)) (* -1 (string-to-number (match-string 4 out)))))) + (if (equal (match-string 3 out) "<<") + (int-to-string (ash (string-to-number (match-string 2 out)) + (string-to-number (match-string 4 out))))) (if (equal (match-string 3 out) "<<<") (int-to-string (ash (string-to-number (match-string 2 out)) (string-to-number (match-string 4 out))))) @@ -10920,7 +11528,7 @@ This repairs those mis-inserted by an AUTOARG." (ceiling (/ (log value) (log 2))))) (defun verilog-typedef-name-p (variable-name) - "Return true if the VARIABLE-NAME is a type definition." + "Return non-nil if the VARIABLE-NAME is a type definition." (when verilog-typedef-regexp (verilog-string-match-fold verilog-typedef-regexp variable-name))) @@ -11678,7 +12286,7 @@ If PAR-VALUES replace final strings with these parameter values." (concat "." vl-modport) "") dflt-bits)) ;; Find template - (cond (tpl-ass ; Template of exact port name + (cond (tpl-ass ; Template of exact port name (setq tpl-net (nth 1 tpl-ass))) ((nth 1 tpl-list) ; Wildcards in template, search them (let ((wildcards (nth 1 tpl-list))) @@ -12240,7 +12848,9 @@ For more information see the \\[verilog-faq] and forums at URL (cond ((not verilog-auto-inst-first-any) (re-search-backward "," pt t) (delete-char 1) - (insert ");") + (when (looking-at " ") + (delete-char 1)) ; so we can align // Templated comments + (insert ");") (search-forward "\n") ; Added by inst-port (delete-char -1) (if (search-forward ")" nil t) ; From user, moved up a line @@ -14645,7 +15255,7 @@ and the case items." (if (not (member v1 verilog-keywords)) (save-excursion (setq verilog-sk-signal v1) - (verilog-beg-of-defun) + (verilog-re-search-backward verilog-defun-re nil 'move) (verilog-end-of-statement) (verilog-forward-syntactic-ws) (verilog-sk-def-reg) @@ -14897,7 +15507,12 @@ Files are checked based on `verilog-library-flags'." '( verilog-active-low-regexp verilog-after-save-font-hook + verilog-align-assign-expr + verilog-align-comment-distance + verilog-align-decl-expr-comments verilog-align-ifelse + verilog-align-typedef-regexp + verilog-align-typedef-words verilog-assignment-delay verilog-auto-arg-sort verilog-auto-declare-nettype @@ -14942,13 +15557,17 @@ Files are checked based on `verilog-library-flags'." verilog-compiler verilog-coverage verilog-delete-auto-hook + verilog-fontify-variables verilog-getopt-flags-hook verilog-highlight-grouping-keywords verilog-highlight-includes verilog-highlight-modules verilog-highlight-translate-off verilog-indent-begin-after-if + verilog-indent-class-inside-pkg verilog-indent-declaration-macros + verilog-indent-ignore-multiline-defines + verilog-indent-ignore-regexp verilog-indent-level verilog-indent-level-behavioral verilog-indent-level-declaration diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 1ae60796601..d77024136d0 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -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/reveal.el b/lisp/reveal.el index 8a1239e1aa2..5ebc5f7c6c3 100644 --- a/lisp/reveal.el +++ b/lisp/reveal.el @@ -118,17 +118,13 @@ Each element has the form (WINDOW . OVERLAY).") ;; overlay. Always reveal invisible text, but only reveal ;; display properties if `reveal-toggle-invisible' is ;; present. - (let ((inv (overlay-get ol 'invisible)) - (disp (and (overlay-get ol 'display) - (overlay-get ol 'reveal-toggle-invisible))) - open) - (when (and (or (and inv - ;; There's an `invisible' property. - ;; Make sure it's actually invisible, - ;; and ellipsized. - (and (consp buffer-invisibility-spec) - (cdr (assq inv buffer-invisibility-spec)))) - disp) + (let* ((inv (overlay-get ol 'invisible)) + (disp (and (overlay-get ol 'display) + (overlay-get ol 'reveal-toggle-invisible))) + (hidden (invisible-p inv)) + (ellipsis (and hidden (not (eq t hidden)))) + open) + (when (and (or ellipsis disp) (or (setq open (or (overlay-get ol 'reveal-toggle-invisible) (and (symbolp inv) 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/server.el b/lisp/server.el index eaf24a770e4..608e5df3a5b 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -273,6 +273,11 @@ If nil, no instructions are displayed." :version "28.1" :type 'boolean) +(defvar server-stop-automatically) ; Defined below to avoid recursive load. + +(defvar server-stop-automatically--timer nil + "The timer object for `server-stop-automatically--maybe-kill-emacs'.") + ;; We do not use `temporary-file-directory' here, because emacsclient ;; does not read the init file. (defvar server-socket-dir @@ -636,7 +641,8 @@ anyway." (setq stopped-p t server-process nil server-mode nil - global-minor-modes (delq 'server-mode global-minor-modes))) + global-minor-modes (delq 'server-mode global-minor-modes)) + (server-apply-stop-automatically)) (unwind-protect ;; Delete the socket files made by previous server ;; invocations. @@ -757,6 +763,7 @@ the `server-process' variable." (list :family 'local :service server-file :plist '(:authenticated t))))) + (server-apply-stop-automatically) (unless server-process (error "Could not start server process")) (server-log "Started server") (process-put server-process :server-file server-file) @@ -1769,9 +1776,6 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." (when server-raise-frame (select-frame-set-input-focus (window-frame))))) -(defvar server-stop-automatically nil - "Internal status variable for `server-stop-automatically'.") - ;;;###autoload (defun server-save-buffers-kill-terminal (arg) ;; Called from save-buffers-kill-terminal in files.el. @@ -1779,11 +1783,19 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." With ARG non-nil, silently save all file-visiting buffers, then kill. If emacsclient was started with a list of filenames to edit, then -only these files will be asked to be saved." - (let ((proc (frame-parameter nil 'client))) +only these files will be asked to be saved. + +When running Emacs as a daemon and with +`server-stop-automatically' (which see) set to `kill-terminal' or +`delete-frame', this function may call `save-buffers-kill-emacs' +if there are no other active clients." + (let ((stop-automatically + (and (daemonp) + (memq server-stop-automatically '(kill-terminal delete-frame)))) + (proc (frame-parameter nil 'client))) (cond ((eq proc 'nowait) ;; Nowait frames have no client buffer list. - (if (length> (frame-list) (if server-stop-automatically 2 1)) + (if (length> (frame-list) (if stop-automatically 2 1)) ;; If there are any other frames, only delete this one. ;; When `server-stop-automatically' is set, don't count ;; the daemon frame. @@ -1792,7 +1804,7 @@ only these files will be asked to be saved." ;; If we're the last frame standing, kill Emacs. (save-buffers-kill-emacs arg))) ((processp proc) - (if (or (not server-stop-automatically) + (if (or (not stop-automatically) (length> server-clients 1) (seq-some (lambda (frame) @@ -1818,31 +1830,14 @@ only these files will be asked to be saved." (save-buffers-kill-emacs arg))) (t (error "Invalid client frame"))))) -(defun server-stop-automatically--handle-delete-frame (frame) - "Handle deletion of FRAME when `server-stop-automatically' is used." - (when server-stop-automatically - (if (if (and (processp (frame-parameter frame 'client)) - (eq this-command 'save-buffers-kill-terminal)) - (progn - (dolist (f (frame-list)) - (when (and (eq (frame-parameter frame 'client) - (frame-parameter f 'client)) - (not (eq frame f))) - (set-frame-parameter f 'client nil) - (let ((server-stop-automatically nil)) - (delete-frame f)))) - (if (cddr (frame-list)) - (let ((server-stop-automatically nil)) - (delete-frame frame) - nil) - t)) - (null (cddr (frame-list)))) - (let ((server-stop-automatically nil)) - (save-buffers-kill-emacs) - (delete-frame frame))))) +(defun server-stop-automatically--handle-delete-frame (_frame) + "Handle deletion of FRAME when `server-stop-automatically' is `delete-frame'." + (when (null (cddr (frame-list))) + (let ((server-stop-automatically nil)) + (save-buffers-kill-emacs)))) (defun server-stop-automatically--maybe-kill-emacs () - "Handle closing of Emacs daemon when `server-stop-automatically' is used." + "Handle closing of Emacs daemon when `server-stop-automatically' is `empty'." (unless (cdr (frame-list)) (when (and (not (memq t (mapcar (lambda (b) @@ -1856,41 +1851,70 @@ only these files will be asked to be saved." (process-list))))) (kill-emacs)))) -;;;###autoload -(defun server-stop-automatically (arg) - "Automatically stop server as specified by ARG. - -If ARG is the symbol `empty', stop the server when it has no +(defun server-apply-stop-automatically () + "Apply the current value of `server-stop-automatically'. +This function adds or removes the necessary helpers to manage +stopping the Emacs server automatically, depending on the whether +the server is running or not. This function only applies when +running Emacs as a daemon." + (when (daemonp) + (let (empty-timer-p delete-frame-p) + (when server-process + (pcase server-stop-automatically + ('empty (setq empty-timer-p t)) + ('delete-frame (setq delete-frame-p t)))) + ;; Start or stop the timer. + (if empty-timer-p + (unless server-stop-automatically--timer + (setq server-stop-automatically--timer + (run-with-timer + 10 2 + #'server-stop-automatically--maybe-kill-emacs))) + (when server-stop-automatically--timer + (cancel-timer server-stop-automatically--timer) + (setq server-stop-automatically--timer nil))) + ;; Add or remove the delete-frame hook. + (if delete-frame-p + (add-hook 'delete-frame-functions + #'server-stop-automatically--handle-delete-frame) + (remove-hook 'delete-frame-functions + #'server-stop-automatically--handle-delete-frame)))) + ;; Return the current value of `server-stop-automatically'. + server-stop-automatically) + +(defcustom server-stop-automatically nil + "If non-nil, stop the server under the requested conditions. + +If this is the symbol `empty', stop the server when it has no remaining clients, no remaining unsaved file-visiting buffers, and no running processes with a `query-on-exit' flag. -If ARG is the symbol `delete-frame', ask the user when the last +If this is the symbol `delete-frame', ask the user when the last frame is deleted whether each unsaved file-visiting buffer must be saved and each running process with a `query-on-exit' flag can be stopped, and if so, stop the server itself. -If ARG is the symbol `kill-terminal', ask the user when the +If this is the symbol `kill-terminal', ask the user when the terminal is killed with \\[save-buffers-kill-terminal] \ whether each unsaved file-visiting buffer must be saved and each running process with a `query-on-exit' -flag can be stopped, and if so, stop the server itself. - -Any other value of ARG will cause this function to signal an error. +flag can be stopped, and if so, stop the server itself." + :type '(choice + (const :tag "Never" nil) + (const :tag "When no clients, unsaved files, or processes" + empty) + (const :tag "When killing last terminal" kill-terminal) + (const :tag "When killing last terminal or frame" delete-frame)) + :set (lambda (symbol value) + (set-default symbol value) + (server-apply-stop-automatically)) + :version "29.1") -This function is meant to be called from the user init file." - (when (daemonp) - (setq server-stop-automatically arg) - (cond - ((eq arg 'empty) - (setq server-stop-automatically nil) - (run-with-timer 10 2 - #'server-stop-automatically--maybe-kill-emacs)) - ((eq arg 'delete-frame) - (add-hook 'delete-frame-functions - #'server-stop-automatically--handle-delete-frame)) - ((eq arg 'kill-terminal)) - (t - (error "Unexpected argument"))))) +;;;###autoload +(defun server-stop-automatically (value) + "Automatically stop the Emacs server as specified by VALUE. +This sets the variable `server-stop-automatically' (which see)." + (setopt server-stop-automatically value)) (define-key ctl-x-map "#" 'server-edit) @@ -1905,12 +1929,22 @@ This function is meant to be called from the user init file." ;; continue standard unloading nil) +(define-error 'server-return-invalid-read-syntax + "Emacs server returned unreadable result of evaluation" + 'invalid-read-syntax) + (defun server-eval-at (server form) "Contact the Emacs server named SERVER and evaluate FORM there. -Returns the result of the evaluation, or signals an error if it -cannot contact the specified server. For example: +Returns the result of the evaluation. For example: (server-eval-at \"server\" \\='(emacs-pid)) -returns the process ID of the Emacs instance running \"server\"." +returns the process ID of the Emacs instance running \"server\". + +This function signals `error' if it could not contact the server. + +This function signals `server-return-invalid-read-syntax' if +`read' fails on the result returned by the server. +This will occur whenever the result of evaluating FORM is +something that cannot be printed readably." (let* ((server-dir (if server-use-tcp server-auth-dir server-socket-dir)) (server-file (expand-file-name server server-dir)) (coding-system-for-read 'binary) @@ -1956,8 +1990,14 @@ returns the process ID of the Emacs instance running \"server\"." (progn (skip-chars-forward "^\n") (point)))))) (if (not (equal answer "")) - (read (decode-coding-string (server-unquote-arg answer) - 'emacs-internal))))))) + (condition-case err + (read + (decode-coding-string (server-unquote-arg answer) + 'emacs-internal)) + ;; Re-signal with a more specific condition. + (invalid-read-syntax + (signal 'server-return-invalid-read-syntax + (cdr err))))))))) (provide 'server) 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 b6efb06fc27..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 @@ -1761,6 +1761,7 @@ not at the start of a line. When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not included in the count." + (declare (side-effect-free t)) (save-excursion (save-restriction (narrow-to-region start end) @@ -2715,7 +2716,16 @@ function as needed." (let ((doc (car body))) (when (funcall docstring-p doc) doc))) - (_ (signal 'invalid-function (list function)))))) + ((pred symbolp) + (let ((f (indirect-function function))) + (if f (function-documentation f) + (signal 'void-function (list function))))) + (`(macro . ,f) (function-documentation f)) + (_ + (let ((doc (internal-subr-documentation function))) + (if (eq t doc) + (signal 'invalid-function (list function)) + doc)))))) (cl-defmethod function-documentation ((function accessor)) (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! @@ -2735,7 +2745,8 @@ instead." nil) (cl-defmethod oclosure-interactive-form ((f cconv--interactive-helper)) - `(interactive (funcall ',(cconv--interactive-helper--if f)))) + (let ((if (cconv--interactive-helper--if f))) + `(interactive ,(if (functionp if) `(funcall ',if) if)))) (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. @@ -3858,16 +3869,14 @@ whether (MARKER . ADJUSTMENT) undo elements are in the region, because markers can be arbitrarily relocated. Instead, pass the marker adjustment's corresponding (TEXT . POS) element." (cond ((integerp undo-elt) - (and (>= undo-elt start) - (<= undo-elt end))) + (<= start undo-elt end)) ((eq undo-elt nil) t) ((atom undo-elt) nil) ((stringp (car undo-elt)) ;; (TEXT . POSITION) - (and (>= (abs (cdr undo-elt)) start) - (<= (abs (cdr undo-elt)) end))) + (<= start (abs (cdr undo-elt)) end)) ((and (consp undo-elt) (markerp (car undo-elt))) ;; (MARKER . ADJUSTMENT) (<= start (car undo-elt) end)) @@ -4732,6 +4741,18 @@ Also see the `async-shell-command-buffer' variable." action)) (user-error "Shell command in progress")))) +(defun file-user-uid () + "Return the connection-local effective uid. +This is similar to `user-uid', but may invoke a file name handler +based on `default-directory'. See Info node `(elisp)Magic File +Names'. + +If a file name handler is unable to retrieve the effective uid, +this function will instead return -1." + (if-let ((handler (find-file-name-handler default-directory 'file-user-uid))) + (funcall handler 'file-user-uid) + (user-uid))) + (defun max-mini-window-lines (&optional frame) "Compute maximum number of lines for echo area in FRAME. As defined by `max-mini-window-height'. FRAME defaults to the @@ -6506,7 +6527,7 @@ If the Unicode tables are not yet available, e.g. during bootstrap, then gives correct answers only for ASCII characters." (cond ((unicode-property-table-internal 'lowercase) (characterp (get-char-code-property char 'lowercase))) - ((and (>= char ?A) (<= char ?Z))))) + ((<= ?A char ?Z)))) (defun zap-to-char (arg char &optional interactive) "Kill up to and including ARGth occurrence of CHAR. @@ -6816,6 +6837,7 @@ is active, and returns an integer or nil in the usual way. If you are using this in an editing command, you are most likely making a mistake; see the documentation of `set-mark'." + (declare (side-effect-free t)) (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive) (marker-position (mark-marker)) (signal 'mark-inactive nil))) @@ -8525,6 +8547,45 @@ are interchanged." (interactive "*p") (transpose-subr 'forward-word arg)) +(defun transpose-sexps-default-function (arg) + "Default method to locate a pair of points for transpose-sexps." + ;; Here we should try to simulate the behavior of + ;; (cons (progn (forward-sexp x) (point)) + ;; (progn (forward-sexp (- x)) (point))) + ;; Except that we don't want to rely on the second forward-sexp + ;; putting us back to where we want to be, since forward-sexp-function + ;; might do funny things like infix-precedence. + (if (if (> arg 0) + (looking-at "\\sw\\|\\s_") + (and (not (bobp)) + (save-excursion + (forward-char -1) + (looking-at "\\sw\\|\\s_")))) + ;; Jumping over a symbol. We might be inside it, mind you. + (progn (funcall (if (> arg 0) + #'skip-syntax-backward #'skip-syntax-forward) + "w_") + (cons (save-excursion (forward-sexp arg) (point)) (point))) + ;; Otherwise, we're between sexps. Take a step back before jumping + ;; to make sure we'll obey the same precedence no matter which + ;; direction we're going. + (funcall (if (> arg 0) #'skip-syntax-backward #'skip-syntax-forward) + " .") + (cons (save-excursion (forward-sexp arg) (point)) + (progn (while (or (forward-comment (if (> arg 0) 1 -1)) + (not (zerop (funcall (if (> arg 0) + #'skip-syntax-forward + #'skip-syntax-backward) + "."))))) + (point))))) + +(defvar transpose-sexps-function #'transpose-sexps-default-function + "If non-nil, `transpose-sexps' delegates to this function. + +This function takes one argument ARG, a number. Its expected +return value is a position pair, which is a cons (BEG . END), +where BEG and END are buffer positions.") + (defun transpose-sexps (arg &optional interactive) "Like \\[transpose-chars] (`transpose-chars'), but applies to sexps. Unlike `transpose-words', point must be between the two sexps and not @@ -8540,38 +8601,7 @@ report errors as appropriate for this kind of usage." (condition-case nil (transpose-sexps arg nil) (scan-error (user-error "Not between two complete sexps"))) - (transpose-subr - (lambda (arg) - ;; Here we should try to simulate the behavior of - ;; (cons (progn (forward-sexp x) (point)) - ;; (progn (forward-sexp (- x)) (point))) - ;; Except that we don't want to rely on the second forward-sexp - ;; putting us back to where we want to be, since forward-sexp-function - ;; might do funny things like infix-precedence. - (if (if (> arg 0) - (looking-at "\\sw\\|\\s_") - (and (not (bobp)) - (save-excursion - (forward-char -1) - (looking-at "\\sw\\|\\s_")))) - ;; Jumping over a symbol. We might be inside it, mind you. - (progn (funcall (if (> arg 0) - 'skip-syntax-backward 'skip-syntax-forward) - "w_") - (cons (save-excursion (forward-sexp arg) (point)) (point))) - ;; Otherwise, we're between sexps. Take a step back before jumping - ;; to make sure we'll obey the same precedence no matter which - ;; direction we're going. - (funcall (if (> arg 0) 'skip-syntax-backward 'skip-syntax-forward) - " .") - (cons (save-excursion (forward-sexp arg) (point)) - (progn (while (or (forward-comment (if (> arg 0) 1 -1)) - (not (zerop (funcall (if (> arg 0) - 'skip-syntax-forward - 'skip-syntax-backward) - "."))))) - (point))))) - arg 'special))) + (transpose-subr transpose-sexps-function arg 'special))) (defun transpose-lines (arg) "Exchange current line and previous line, leaving point after both. @@ -8596,13 +8626,15 @@ With argument 0, interchanges line point is in with line mark is in." ;; FIXME document SPECIAL. (defun transpose-subr (mover arg &optional special) "Subroutine to do the work of transposing objects. -Works for lines, sentences, paragraphs, etc. MOVER is a function that -moves forward by units of the given object (e.g. `forward-sentence', -`forward-paragraph'). If ARG is zero, exchanges the current object -with the one containing mark. If ARG is an integer, moves the -current object past ARG following (if ARG is positive) or -preceding (if ARG is negative) objects, leaving point after the -current object." +Works for lines, sentences, paragraphs, etc. MOVER is a function +that moves forward by units of the given +object (e.g. `forward-sentence', `forward-paragraph'), or a +function calculating a cons of buffer positions. + + If ARG is zero, exchanges the current object with the one +containing mark. If ARG is an integer, moves the current object +past ARG following (if ARG is positive) or preceding (if ARG is +negative) objects, leaving point after the current object." (let ((aux (if special mover (lambda (x) (cons (progn (funcall mover x) (point)) @@ -8629,6 +8661,8 @@ current object." (goto-char (+ (car pos2) (- (cdr pos1) (car pos1)))))))) (defun transpose-subr-1 (pos1 pos2) + (unless (and pos1 pos2) + (error "Don't have two things to transpose")) (when (> (car pos1) (cdr pos1)) (setq pos1 (cons (cdr pos1) (car pos1)))) (when (> (car pos2) (cdr pos2)) (setq pos2 (cons (cdr pos2) (car pos2)))) (when (> (car pos1) (car pos2)) @@ -8885,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 @@ -9074,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). @@ -9096,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) @@ -10143,8 +10191,7 @@ PREFIX is the string that represents this modifier in an event type symbol." ((eq symbol 'shift) ;; FIXME: Should we also apply this "upcase" behavior of shift ;; to non-ascii letters? - (if (and (<= (downcase event) ?z) - (>= (downcase event) ?a)) + (if (<= ?a (downcase event) ?z) (upcase event) (logior (ash 1 lshiftby) event))) (t @@ -10821,6 +10868,7 @@ If the buffer doesn't exist, create it first." (defsubst string-empty-p (string) "Check whether STRING is empty." + (declare (pure t) (side-effect-free t)) (string= string "")) (defun read-signal-name () @@ -10838,7 +10886,7 @@ If the buffer doesn't exist, create it first." (defun lax-plist-get (plist prop) "Extract a value from a property list, comparing with `equal'." - (declare (obsolete plist-get "29.1")) + (declare (pure t) (side-effect-free t) (obsolete plist-get "29.1")) (plist-get plist prop #'equal)) (defun lax-plist-put (plist prop val) 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/startup.el b/lisp/startup.el index b0f019d704e..9ae53f4e50b 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2918,7 +2918,7 @@ nil default-directory" name) (when (looking-at "#!") (forward-line)) (let (value form) - (while (ignore-error 'end-of-file + (while (ignore-error end-of-file (setq form (read (current-buffer)))) (setq value (eval form t))) (kill-emacs (if (numberp value) 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 d4428aef765..427014cedc3 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -281,14 +281,20 @@ change the list." When COND yields non-nil, eval BODY forms sequentially and return value of last one, or nil if there are none." (declare (indent 1) (debug t)) - (list 'if cond (cons 'progn body))) + (if body + (list 'if cond (cons 'progn body)) + (macroexp-warn-and-return (format-message "`when' with empty body") + cond '(empty-body when) t))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. When COND yields nil, eval BODY forms sequentially and return value of last one, or nil if there are none." (declare (indent 1) (debug t)) - (cons 'if (cons cond (cons nil body)))) + (if body + (cons 'if (cons cond (cons nil body))) + (macroexp-warn-and-return (format-message "`unless' with empty body") + cond '(empty-body unless) t))) (defsubst subr-primitive-p (object) "Return t if OBJECT is a built-in primitive function." @@ -381,9 +387,24 @@ without silencing all errors." "Execute BODY; if the error CONDITION occurs, return nil. Otherwise, return result of last form in BODY. -CONDITION can also be a list of error conditions." +CONDITION can also be a list of error conditions. +The CONDITION argument is not evaluated. Do not quote it." (declare (debug t) (indent 1)) - `(condition-case nil (progn ,@body) (,condition nil))) + (cond + ((and (eq (car-safe condition) 'quote) + (cdr condition) (null (cddr condition))) + (macroexp-warn-and-return + (format-message + "`ignore-error' condition argument should not be quoted: %S" + condition) + `(condition-case nil (progn ,@body) (,(cadr condition) nil)) + nil t condition)) + (body + `(condition-case nil (progn ,@body) (,condition nil))) + (t + (macroexp-warn-and-return (format-message "`ignore-error' with empty body") + nil '(empty-body ignore-error) t condition)))) + ;;;; Basic Lisp functions. @@ -402,7 +423,9 @@ PREFIX is a string, and defaults to \"g\"." "Do nothing and return nil. This function accepts any number of ARGUMENTS, but ignores them. Also see `always'." - (declare (completion ignore)) + ;; Not declared `side-effect-free' because we don't want calls to it + ;; elided; see `byte-compile-ignore'. + (declare (pure t) (completion ignore)) (interactive) nil) @@ -410,6 +433,7 @@ Also see `always'." "Do nothing and return t. This function accepts any number of ARGUMENTS, but ignores them. Also see `ignore'." + (declare (pure t) (side-effect-free error-free)) t) ;; Signal a compile-error if the first arg is missing. @@ -489,16 +513,19 @@ was called." "Return t if NUMBER is zero." ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because ;; = has a byte-code. - (declare (compiler-macro (lambda (_) `(= 0 ,number)))) + (declare (pure t) (side-effect-free t) + (compiler-macro (lambda (_) `(= 0 ,number)))) (= 0 number)) (defun fixnump (object) "Return t if OBJECT is a fixnum." + (declare (side-effect-free error-free)) (and (integerp object) (<= most-negative-fixnum object most-positive-fixnum))) (defun bignump (object) "Return t if OBJECT is a bignum." + (declare (side-effect-free error-free)) (and (integerp object) (not (fixnump object)))) (defun lsh (value count) @@ -511,8 +538,10 @@ This function is provided for compatibility. In new code, use `ash' instead." (declare (compiler-macro (lambda (form) - (macroexp-warn-and-return "avoid `lsh'; use `ash' instead" - form '(suspicious lsh) t form)))) + (macroexp-warn-and-return + (format-message "avoid `lsh'; use `ash' instead") + form '(suspicious lsh) t form))) + (side-effect-free t)) (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) @@ -685,7 +714,7 @@ instead." If LIST is nil, return nil. If N is non-nil, return the Nth-to-last link of LIST. If N is bigger than the length of LIST, return LIST." - (declare (side-effect-free t)) + (declare (pure t) (side-effect-free t)) ; pure up to mutation (if n (and (>= n 0) (let ((m (safe-length list))) @@ -740,7 +769,9 @@ one is kept. See `seq-uniq' for non-destructive operation." (defun delete-consecutive-dups (list &optional circular) "Destructively remove `equal' consecutive duplicates from LIST. First and last elements are considered consecutive if CIRCULAR is -non-nil." +non-nil. +Of several consecutive `equal' occurrences, the one earliest in +the list is kept." (let ((tail list) last) (while (cdr tail) (if (equal (car tail) (cadr tail)) @@ -776,6 +807,7 @@ TO as (+ FROM (* N INC)) or use a variable whose value was computed with this exact expression. Alternatively, you can, of course, also replace TO with a slightly larger value \(or a slightly more negative value if INC is negative)." + (declare (side-effect-free t)) (if (or (not to) (= from to)) (list from) (or inc (setq inc 1)) @@ -797,6 +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 error-free)) (if (consp tree) (let (result) (while (consp tree) @@ -813,6 +846,7 @@ argument VECP, this copies vectors as well as conses." (aset tree i (copy-tree (aref tree i) vecp))) tree) tree))) + ;;;; Various list-search functions. @@ -1504,6 +1538,7 @@ See also `current-global-map'.") (defun eventp (object) "Return non-nil if OBJECT is an input event or event object." + (declare (pure t) (side-effect-free error-free)) (or (integerp object) (and (if (consp object) (setq object (car object)) @@ -1568,6 +1603,7 @@ in the current Emacs session, then this function may return nil." (defsubst mouse-movement-p (object) "Return non-nil if OBJECT is a mouse movement event." + (declare (side-effect-free error-free)) (eq (car-safe object) 'mouse-movement)) (defun mouse-event-p (object) @@ -1840,7 +1876,7 @@ be a list of the form returned by `event-start' and `event-end'." (defun log10 (x) "Return (log X 10), the log base 10 of X." - (declare (obsolete log "24.4")) + (declare (side-effect-free t) (obsolete log "24.4")) (log x 10)) (set-advertised-calling-convention @@ -2970,6 +3006,7 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defun memory-limit () "Return an estimate of Emacs virtual memory usage, divided by 1024." + (declare (side-effect-free error-free)) (let ((default-directory temporary-file-directory)) (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))) @@ -3297,7 +3334,7 @@ floating point support." (lambda (form) (if (not (or (numberp nodisp) obsolete)) form (macroexp-warn-and-return - "Obsolete calling convention for 'sit-for'" + (format-message "Obsolete calling convention for `sit-for'") `(,(car form) (+ ,seconds (/ (or ,nodisp 0) 1000.0)) ,obsolete) '(obsolete sit-for)))))) ;; This used to be implemented in C until the following discussion: @@ -4140,15 +4177,18 @@ system's shell." (defsubst string-to-list (string) "Return a list of characters in STRING." + (declare (side-effect-free t)) (append string nil)) (defsubst string-to-vector (string) "Return a vector of characters in STRING." + (declare (side-effect-free t)) (vconcat string)) (defun string-or-null-p (object) "Return t if OBJECT is a string or nil. Otherwise, return nil." + (declare (pure t) (side-effect-free error-free)) (or (stringp object) (null object))) (defun list-of-strings-p (object) @@ -4161,21 +4201,25 @@ Otherwise, return nil." (defun booleanp (object) "Return t if OBJECT is one of the two canonical boolean values: t or nil. Otherwise, return nil." + (declare (pure t) (side-effect-free error-free)) (and (memq object '(nil t)) t)) (defun special-form-p (object) "Non-nil if and only if OBJECT is a special form." + (declare (side-effect-free error-free)) (if (and (symbolp object) (fboundp object)) (setq object (indirect-function object))) (and (subrp object) (eq (cdr (subr-arity object)) 'unevalled))) (defun plistp (object) "Non-nil if and only if OBJECT is a valid plist." + (declare (pure t) (side-effect-free error-free)) (let ((len (proper-list-p object))) (and len (zerop (% len 2))))) (defun macrop (object) "Non-nil if and only if OBJECT is a macro." + (declare (side-effect-free t)) (let ((def (indirect-function object))) (when (consp def) (or (eq 'macro (car def)) @@ -4185,6 +4229,7 @@ Otherwise, return nil." "Return non-nil if OBJECT is a function that has been compiled. Does not distinguish between functions implemented in machine code or byte-code." + (declare (side-effect-free error-free)) (or (subrp object) (byte-code-function-p object))) (defun field-at-pos (pos) @@ -4891,6 +4936,7 @@ but that should be robust in the unexpected case that an error is signaled." (declare (debug t) (indent 1)) (let* ((err (make-symbol "err")) (orig-body body) + (orig-format format) (format (if (and (stringp format) body) format (prog1 "Error: %S" (if format (push format body))))) @@ -4901,7 +4947,10 @@ but that should be robust in the unexpected case that an error is signaled." (if (eq orig-body body) exp ;; The use without `format' is obsolete, let's warn when we bump ;; into any such remaining uses. - (macroexp-warn-and-return "Missing format argument" exp nil nil format)))) + (macroexp-warn-and-return + (format-message "Missing format argument in `with-demote-errors'") + exp nil nil + orig-format)))) (defmacro combine-after-change-calls (&rest body) "Execute BODY, but don't call the after-change functions till the end. @@ -4982,21 +5031,20 @@ the function `undo--wrap-and-run-primitive-undo'." beg (marker-position end-marker) #'undo--wrap-and-run-primitive-undo - beg (marker-position end-marker) buffer-undo-list)) + beg (marker-position end-marker) + ;; We will truncate this list by side-effect below. + buffer-undo-list)) (ptr buffer-undo-list)) (if (not (eq buffer-undo-list old-bul)) (progn (while (and (not (eq (cdr ptr) old-bul)) ;; In case garbage collection has removed OLD-BUL. - (cdr ptr)) - (if (and (consp (cdr ptr)) - (consp (cadr ptr)) - (eq (caadr ptr) t)) - ;; Don't include a timestamp entry. - (setcdr ptr (cddr ptr)) - (setq ptr (cdr ptr)))) - (unless (cdr ptr) - (message "combine-change-calls: buffer-undo-list broken")) + (or (cdr ptr) + (progn + (message "combine-change-calls: buffer-undo-list broken") + nil))) + (setq ptr (cdr ptr))) + ;; Truncate the list that's in the `apply' entry. (setcdr ptr nil) (push ap-elt buffer-undo-list) (setcdr buffer-undo-list old-bul))))) @@ -5208,11 +5256,13 @@ wherever possible, since it is slow." (defsubst looking-at-p (regexp) "\ Same as `looking-at' except this function does not change the match data." + (declare (side-effect-free t)) (looking-at regexp t)) (defsubst string-match-p (regexp string &optional start) "\ Same as `string-match' except this function does not change the match data." + (declare (side-effect-free t)) (string-match regexp string start t)) (defun subregexp-context-p (regexp pos &optional start) @@ -5483,14 +5533,14 @@ Upper-case and lower-case letters are treated as equal. Unibyte strings are converted to multibyte for comparison. See also `string-equal'." - (declare (pure t) (side-effect-free t)) + (declare (side-effect-free t)) (eq t (compare-strings string1 0 nil string2 0 nil t))) (defun string-prefix-p (prefix string &optional ignore-case) "Return non-nil if PREFIX is a prefix of STRING. If IGNORE-CASE is non-nil, the comparison is done without paying attention to case differences." - (declare (pure t) (side-effect-free t)) + (declare (side-effect-free t)) (let ((prefix-length (length prefix))) (if (> prefix-length (length string)) nil (eq t (compare-strings prefix 0 prefix-length string @@ -5500,7 +5550,7 @@ to case differences." "Return non-nil if SUFFIX is a suffix of STRING. If IGNORE-CASE is non-nil, the comparison is done without paying attention to case differences." - (declare (pure t) (side-effect-free t)) + (declare (side-effect-free t)) (let ((start-pos (- (length string) (length suffix)))) (and (>= start-pos 0) (eq t (compare-strings suffix nil nil @@ -5528,6 +5578,7 @@ consisting of STR followed by an invisible left-to-right mark "Return non-nil if STRING1 is greater than STRING2 in lexicographic order. Case is significant. Symbols are also allowed; their print names are used instead." + (declare (pure t) (side-effect-free t)) (string-lessp string2 string1)) @@ -5809,6 +5860,7 @@ integer that encodes the corresponding syntax class. See Info node `(elisp)Syntax Table Internals' for a list of codes. If SYNTAX is nil, return nil." + (declare (pure t) (side-effect-free t)) (and syntax (logand (car syntax) 65535))) ;; Utility motion commands @@ -6127,14 +6179,8 @@ command is called from a keyboard macro?" ;; Skip special forms (from non-compiled code). (and frame (null (car frame))) ;; Skip also `interactive-p' (because we don't want to know if - ;; interactive-p was called interactively but if it's caller was) - ;; and `byte-code' (idem; this appears in subexpressions of things - ;; like condition-case, which are wrapped in a separate bytecode - ;; chunk). - ;; FIXME: For lexical-binding code, this is much worse, - ;; because the frames look like "byte-code -> funcall -> #[...]", - ;; which is not a reliable signature. - (memq (nth 1 frame) '(interactive-p 'byte-code)) + ;; interactive-p was called interactively but if it's caller was). + (eq (nth 1 frame) 'interactive-p) ;; Skip package-specific stack-frames. (let ((skip (run-hook-with-args-until-success 'called-interactively-p-functions @@ -6177,7 +6223,8 @@ To test whether a function can be called interactively, use `commandp'." ;; Kept around for now. See discussion at: ;; https://lists.gnu.org/r/emacs-devel/2020-08/msg00564.html - (declare (obsolete called-interactively-p "23.2")) + (declare (obsolete called-interactively-p "23.2") + (side-effect-free error-free)) (called-interactively-p 'interactive)) (defun internal-push-keymap (keymap symbol) @@ -6664,6 +6711,7 @@ Note that a version specified by the list (1) is equal to (1 0), \(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. Also, a version given by the list (1) is higher than (1 -1), which in turn is higher than (1 -2), which is higher than (1 -3)." + (declare (pure t) (side-effect-free t)) (while (and l1 l2 (= (car l1) (car l2))) (setq l1 (cdr l1) l2 (cdr l2))) @@ -6685,6 +6733,7 @@ Note that a version specified by the list (1) is equal to (1 0), \(1 0 0), (1 0 0 0), etc. That is, the trailing zeros are insignificant. Also, a version given by the list (1) is higher than (1 -1), which in turn is higher than (1 -2), which is higher than (1 -3)." + (declare (pure t) (side-effect-free t)) (while (and l1 l2 (= (car l1) (car l2))) (setq l1 (cdr l1) l2 (cdr l2))) @@ -6706,6 +6755,7 @@ Note that integer list (1) is equal to (1 0), (1 0 0), (1 0 0 0), etc. That is, the trailing zeroes are insignificant. Also, integer list (1) is greater than (1 -1) which is greater than (1 -2) which is greater than (1 -3)." + (declare (pure t) (side-effect-free t)) (while (and l1 l2 (= (car l1) (car l2))) (setq l1 (cdr l1) l2 (cdr l2))) @@ -6723,6 +6773,7 @@ which is greater than (1 -3)." "Return the first non-zero element of LST, which is a list of integers. If all LST elements are zeros or LST is nil, return zero." + (declare (pure t) (side-effect-free t)) (while (and lst (zerop (car lst))) (setq lst (cdr lst))) (if lst @@ -6862,6 +6913,7 @@ returned list are in the same order as in TREE. \(flatten-tree \\='(1 (2 . 3) nil (4 5 (6)) 7)) => (1 2 3 4 5 6 7)" + (declare (side-effect-free error-free)) (let (elems) (while (consp tree) (let ((elem (pop tree))) @@ -6888,6 +6940,7 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." "Trim STRING of trailing string matching REGEXP. REGEXP defaults to \"[ \\t\\n\\r]+\"." + (declare (side-effect-free t)) (let ((i (string-match-p (concat "\\(?:" (or regexp "[ \t\n\r]+") "\\)\\'") string))) (if i (substring string 0 i) string))) @@ -6959,6 +7012,7 @@ sentence (see Info node `(elisp) Documentation Tips')." "Return OBJECT as a list. If OBJECT is already a list, return OBJECT itself. If it's not a list, return a one-element list containing OBJECT." + (declare (side-effect-free error-free)) (if (listp object) object (list object))) @@ -6974,27 +7028,17 @@ string will be displayed only if BODY takes longer than TIMEOUT seconds. (lambda () ,@body))) -(defun function-alias-p (func &optional noerror) +(defun function-alias-p (func &optional _noerror) "Return nil if FUNC is not a function alias. -If FUNC is a function alias, return the function alias chain. - -If the function alias chain contains loops, an error will be -signaled. If NOERROR, the non-loop parts of the chain is returned." - (declare (side-effect-free t)) - (let ((chain nil) - (orig-func func)) - (nreverse - (catch 'loop - (while (and (symbolp func) - (setq func (symbol-function func)) - (symbolp func)) - (when (or (memq func chain) - (eq func orig-func)) - (if noerror - (throw 'loop chain) - (signal 'cyclic-function-indirection (list orig-func)))) - (push func chain)) - chain)))) +If FUNC is a function alias, return the function alias chain." + (declare (advertised-calling-convention (func) "30.1") + (side-effect-free error-free)) + (let ((chain nil)) + (while (and (symbolp func) + (setq func (symbol-function func)) + (symbolp func)) + (push func chain)) + (nreverse chain))) (defun readablep (object) "Say whether OBJECT has a readable syntax. @@ -7044,6 +7088,7 @@ is inserted before adjusting the number of empty lines." If OMIT-NULLS, empty lines will be removed from the results. If KEEP-NEWLINES, don't strip trailing newlines from the result lines." + (declare (side-effect-free t)) (if (equal string "") (if omit-nulls nil diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index dce6fa735fc..7c3069ca269 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -105,7 +105,7 @@ For easier selection of tabs by their numbers, consider customizing (const hyper) (const super) (const alt)) - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) ;; Reenable the tab-bar with new keybindings @@ -116,23 +116,23 @@ For easier selection of tabs by their numbers, consider customizing :version "27.1") (defun tab-bar--define-keys () - "Install key bindings for switching between tabs if the user has configured them." + "Install key bindings to switch between tabs if so configured." (when tab-bar-select-tab-modifiers (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?0))) - 'tab-recent) + #'tab-recent) (dotimes (i 8) (global-set-key (vector (append tab-bar-select-tab-modifiers (list (+ i 1 ?0)))) - 'tab-bar-select-tab)) + #'tab-bar-select-tab)) (global-set-key (vector (append tab-bar-select-tab-modifiers (list ?9))) - 'tab-last)) + #'tab-last)) ;; Don't override user customized key bindings (unless (global-key-binding [(control tab)]) - (global-set-key [(control tab)] 'tab-next)) + (global-set-key [(control tab)] #'tab-next)) (unless (global-key-binding [(control shift tab)]) - (global-set-key [(control shift tab)] 'tab-previous)) + (global-set-key [(control shift tab)] #'tab-previous)) (unless (global-key-binding [(control shift iso-lefttab)]) - (global-set-key [(control shift iso-lefttab)] 'tab-previous)) + (global-set-key [(control shift iso-lefttab)] #'tab-previous)) ;; Replace default value with a condition that supports displaying ;; global-mode-string in the tab bar instead of the mode line. @@ -157,6 +157,9 @@ For easier selection of tabs by their numbers, consider customizing (defun tab-bar--load-buttons () "Load the icons for the tab buttons." (require 'icons) + (declare-function icon-string "icons" (name)) + (declare-function iconp "icons" (object)) + (declare-function icons--register "icons") (unless (iconp 'tab-bar-new) (define-icon tab-bar-new nil `((image "tabs/new.xpm" @@ -227,7 +230,8 @@ a list of frames to update." ;; Update `default-frame-alist' (when (eq frames t) (setq default-frame-alist - (cons (cons 'tab-bar-lines (if (and tab-bar-mode (eq tab-bar-show t)) 1 0)) + (cons (cons 'tab-bar-lines + (if (and tab-bar-mode (eq tab-bar-show t)) 1 0)) (assq-delete-all 'tab-bar-lines default-frame-alist))))) (define-minor-mode tab-bar-mode @@ -279,7 +283,8 @@ It returns a list of the form (KEY KEY-BINDING CLOSE-P), where: ;; This code is used when you click the mouse in the tab bar ;; on a console which has no window system but does have a mouse. (let* ((x-position (car (posn-x-y posn))) - (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps))) [tab-bar])) + (keymap (lookup-key (cons 'keymap (nreverse (current-active-maps))) + [tab-bar])) (column 0)) (when x-position (catch 'done @@ -478,7 +483,7 @@ you can use the command `toggle-frame-tab-bar'." :type '(choice (const :tag "Always" t) (const :tag "When more than one tab" 1) (const :tag "Never" nil)) - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (if val @@ -529,7 +534,7 @@ to get the group name." "If non-nil, show the \"New tab\" button in the tab bar. When this is nil, you can create new tabs with \\[tab-new]." :type 'boolean - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -550,7 +555,7 @@ If nil, don't show it at all." (const :tag "On selected tab" selected) (const :tag "On non-selected tabs" non-selected) (const :tag "None" nil)) - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -574,7 +579,7 @@ If nil, don't show it at all." This helps to select the tab by its number using `tab-bar-select-tab' and `tab-bar-select-tab-modifiers'." :type 'boolean - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -604,7 +609,7 @@ from all windows in the window configuration." (const :tag "All window buffers" tab-bar-tab-name-all) (function :tag "Function")) - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -704,7 +709,7 @@ Function gets one argument: a tab." Function gets two arguments, the tab and its number, and should return the formatted tab name to display in the tab bar." :type 'function - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -753,7 +758,7 @@ of the mode line. Replacing `tab-bar-format-tabs' with tab-bar-format-add-tab tab-bar-format-align-right tab-bar-format-global) - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -815,7 +820,8 @@ You can hide these buttons by customizing `tab-bar-format' and removing ,(alist-get 'binding tab) :help "Click to visit tab")))) (when (alist-get 'close-binding tab) - `((,(if (eq (car tab) 'current-tab) 'C-current-tab (intern (format "C-tab-%i" i))) + `((,(if (eq (car tab) 'current-tab) 'C-current-tab + (intern (format "C-tab-%i" i))) menu-item "" ,(alist-get 'close-binding tab)))))) @@ -832,7 +838,7 @@ You can hide these buttons by customizing `tab-bar-format' and removing "Function to get a tab group name. Function gets one argument: a tab." :type 'function - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -848,7 +854,7 @@ Function gets three arguments, a tab with a group name, its number, and an optional value that is non-nil when the tab is from the current group. It should return the formatted tab group name to display in the tab bar." :type 'function - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (force-mode-line-update)) @@ -919,7 +925,8 @@ when the tab is current. Return the result as a keymap." (when (and (not (equal previous-group tab-group)) tab-group) (tab-bar--format-tab-group tab i t)) ;; Override default tab faces to use group faces - (let ((tab-bar-tab-face-function tab-bar-tab-group-face-function)) + (let ((tab-bar-tab-face-function + tab-bar-tab-group-face-function)) (tab-bar--format-tab tab i)))) ;; Show first tab of other groups with a group name ((not (equal previous-group tab-group)) @@ -948,7 +955,8 @@ when the tab is current. Return the result as a keymap." ;; when windows are split horizontally (bug#59620) (if (window-system) `(space :align-to (- right (,hpos))) - `(space :align-to (,(- (frame-inner-width) hpos))))))) + `(space :align-to (,(- (frame-inner-width) + hpos))))))) `((align-right menu-item ,str ignore)))) (defun tab-bar-format-global () @@ -1018,7 +1026,7 @@ This variable has effect only when `tab-bar-auto-width' is non-nil." (const :tag "No limit" nil) (list (integer :tag "Max width (pixels)" :value 220) (integer :tag "Max width (chars)" :value 20))) - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (setq tab-bar--auto-width-hash nil)) @@ -1087,12 +1095,14 @@ tab bar might wrap to the second line when it shouldn't.") curr-width) (cond ((< prev-width width) - (let* ((space (apply 'propertize " " + (let* ((space (apply #'propertize " " (text-properties-at 0 name))) (ins-pos (- len (if close-p 1 0))) (prev-name name)) (while continue - (setf (substring name ins-pos ins-pos) space) + (setq name (concat (substring name 0 ins-pos) + space + (substring name ins-pos))) (setq curr-width (string-pixel-width name)) (if (and (< curr-width width) (> curr-width prev-width)) @@ -1105,7 +1115,9 @@ tab bar might wrap to the second line when it shouldn't.") (let ((del-pos1 (if close-p -2 -1)) (del-pos2 (if close-p -1 nil))) (while continue - (setf (substring name del-pos1 del-pos2) "") + (setq name (concat (substring name 0 del-pos1) + (and del-pos2 + (substring name del-pos2)))) (setq curr-width (string-pixel-width name)) (if (and (> curr-width width) (< curr-width prev-width)) @@ -1309,11 +1321,13 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (when tab-bar-history-mode (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-back))) + (and (window-configuration-p + (alist-get 'wc (car wc-history-back))) wc-history-back) tab-bar-history-back) (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) + (and (window-configuration-p + (alist-get 'wc (car wc-history-forward))) wc-history-forward) tab-bar-history-forward)))) @@ -1339,7 +1353,8 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (when from-index (setf (nth from-index tabs) from-tab)) - (setf (nth to-index tabs) (tab-bar--current-tab-make (nth to-index tabs))) + (setf (nth to-index tabs) + (tab-bar--current-tab-make (nth to-index tabs))) (unless tab-bar-mode (message "Selected tab '%s'" (alist-get 'name to-tab)))) @@ -1406,7 +1421,7 @@ and rename it to NAME." (tab-bar-new-tab) (tab-bar-rename-tab name)))) -(defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab) +(defalias 'tab-bar-select-tab-by-name #'tab-bar-switch-to-tab) (defun tab-bar-move-tab-to (to-number &optional from-number) @@ -1421,7 +1436,8 @@ where argument addressing is relative." (from-number (or from-number (1+ (tab-bar--current-tab-index tabs)))) (from-tab (nth (1- from-number) tabs)) (to-number (if to-number (prefix-numeric-value to-number) 1)) - (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number)) to-number)) + (to-number (if (< to-number 0) (+ (length tabs) (1+ to-number)) + to-number)) (to-index (max 0 (min (1- to-number) (1- (length tabs)))))) (setq tabs (delq from-tab tabs)) (cl-pushnew from-tab (nthcdr to-index tabs)) @@ -1447,7 +1463,8 @@ Like `tab-bar-move-tab', but moves in the opposite direction." (interactive "p") (tab-bar-move-tab (- (or arg 1)))) -(defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number to-frame to-number) +(defun tab-bar-move-tab-to-frame (arg &optional from-frame from-number + to-frame to-number) "Move tab from FROM-NUMBER position to new position at TO-NUMBER. FROM-NUMBER defaults to the current tab number. FROM-NUMBER and TO-NUMBER count from 1. @@ -1463,7 +1480,8 @@ to which to move the tab; ARG defaults to 1." (setq to-frame (next-frame to-frame)))) (unless (eq from-frame to-frame) (let* ((from-tabs (funcall tab-bar-tabs-function from-frame)) - (from-number (or from-number (1+ (tab-bar--current-tab-index from-tabs)))) + (from-number (or from-number + (1+ (tab-bar--current-tab-index from-tabs)))) (from-tab (nth (1- from-number) from-tabs)) (to-tabs (funcall tab-bar-tabs-function to-frame)) (to-index (max 0 (min (1- (or to-number 1)) (1- (length to-tabs)))))) @@ -1485,7 +1503,8 @@ to which to move the tab; ARG defaults to 1." FROM-NUMBER defaults to the current tab (which happens interactively)." (interactive (list (1+ (tab-bar--current-tab-index)))) (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-index (1- (or from-number (1+ (tab-bar--current-tab-index tabs))))) + (tab-index (1- (or from-number + (1+ (tab-bar--current-tab-index tabs))))) (tab-name (alist-get 'name (nth tab-index tabs))) ;; On some window managers, `make-frame' selects the new frame, ;; so previously selected frame is saved to `from-frame'. @@ -1748,7 +1767,8 @@ for the last tab on a frame is determined by ;; Select another tab before deleting the current tab (let ((to-index (or (if to-number (1- to-number)) (pcase tab-bar-close-tab-select - ('left (1- (if (< current-index 1) 2 current-index))) + ('left (1- (if (< current-index 1) 2 + current-index))) ('right (if (> (length tabs) (1+ current-index)) (1+ current-index) (1- current-index))) @@ -1773,7 +1793,8 @@ for the last tab on a frame is determined by (force-mode-line-update) (unless tab-bar-mode - (message "Deleted tab and switched to %s" tab-bar-close-tab-select)))))) + (message "Deleted tab and switched to %s" + tab-bar-close-tab-select)))))) (defun tab-bar-close-tab-by-name (name) "Close the tab given its NAME. @@ -1864,7 +1885,8 @@ If NAME is the empty string, then use the automatic name function `tab-bar-tab-name-function'." (interactive (let* ((tabs (funcall tab-bar-tabs-function)) - (tab-number (or current-prefix-arg (1+ (tab-bar--current-tab-index tabs)))) + (tab-number (or current-prefix-arg + (1+ (tab-bar--current-tab-index tabs)))) (tab-name (alist-get 'name (nth (1- tab-number) tabs)))) (list (read-from-minibuffer "New name for tab (leave blank for automatic naming): " @@ -2129,10 +2151,10 @@ and can restore them." :version "29.1")) (setq tab-bar-forward-button (icon-string 'tab-bar-forward)) - (add-hook 'pre-command-hook 'tab-bar--history-pre-change) - (add-hook 'window-configuration-change-hook 'tab-bar--history-change)) - (remove-hook 'pre-command-hook 'tab-bar--history-pre-change) - (remove-hook 'window-configuration-change-hook 'tab-bar--history-change))) + (add-hook 'pre-command-hook #'tab-bar--history-pre-change) + (add-hook 'window-configuration-change-hook #'tab-bar--history-change)) + (remove-hook 'pre-command-hook #'tab-bar--history-pre-change) + (remove-hook 'window-configuration-change-hook #'tab-bar--history-change))) ;;; Non-graphical access to frame-local tabs (named window configurations) @@ -2172,8 +2194,9 @@ For more information, see the function `tab-switcher'." (tabs (sort tabs (lambda (a b) (< (alist-get 'time b) (alist-get 'time a)))))) (with-current-buffer (get-buffer-create - (format " *Tabs*<%s>" (or (frame-parameter nil 'window-id) - (frame-parameter nil 'name)))) + (format " *Tabs*<%s>" + (or (frame-parameter nil 'window-id) + (frame-parameter nil 'name)))) (setq buffer-read-only nil) (erase-buffer) (tab-switcher-mode) @@ -2188,7 +2211,8 @@ For more information, see the function `tab-switcher'." (propertize (alist-get 'name tab) 'mouse-face 'highlight - 'help-echo "mouse-2: select this window configuration")) + 'help-echo + "mouse-2: select this window configuration")) 'tab tab))) (goto-char (point-min)) (goto-char (or (next-single-property-change (point) 'tab) (point-min))) @@ -2264,8 +2288,8 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." (move-to-column tab-switcher-column)) (defun tab-switcher-unmark (&optional backup) - "Cancel requested operations on window configuration on this line and move down. -With prefix arg, move up instead." + "Cancel operations on window configuration on this line and move down. +With prefix arg BACKUP, move up instead." (interactive "P") (beginning-of-line) (move-to-column tab-switcher-column) @@ -2276,7 +2300,7 @@ With prefix arg, move up instead." (move-to-column tab-switcher-column)) (defun tab-switcher-backup-unmark () - "Move up one line and cancel requested operations on window configuration there." + "Move up one line and cancel operations on window configuration there." (interactive) (forward-line -1) (tab-switcher-unmark) @@ -2284,9 +2308,10 @@ With prefix arg, move up instead." (move-to-column tab-switcher-column)) (defun tab-switcher-delete (&optional arg) - "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command. + "Mark window configuration on this line to be deleted. Prefix arg says how many window configurations to delete. -Negative arg means delete backwards." +Negative arg means delete backwards. +The deletion will be done by the \\<tab-switcher-mode-map>\\[tab-switcher-execute] command." (interactive "p") (let ((buffer-read-only nil)) (if (or (null arg) (= arg 0)) @@ -2304,8 +2329,9 @@ Negative arg means delete backwards." (move-to-column tab-switcher-column))) (defun tab-switcher-delete-backwards (&optional arg) - "Mark window configuration on this line to be deleted by \\<tab-switcher-mode-map>\\[tab-switcher-execute] command. -Then move up one line. Prefix arg means move that many lines." + "Mark window configuration on this line to be deleted. +Then move up one line. Prefix arg means move that many lines. +The deletion will be done by the \\<tab-switcher-mode-map>\\[tab-switcher-execute] command." (interactive "p") (tab-switcher-delete (- (or arg 1)))) @@ -2318,7 +2344,9 @@ Then move up one line. Prefix arg means move that many lines." (tab-bar-tabs-set (delq tab (funcall tab-bar-tabs-function)))) (defun tab-switcher-execute () - "Delete window configurations marked with \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands." + "Delete the marked window configurations. +Use the \\<tab-switcher-mode-map>\\[tab-switcher-delete] commands +to set those marks." (interactive) (save-excursion (goto-char (point-min)) @@ -2364,7 +2392,8 @@ with those specified by the selected window configuration." ((framep all-frames) (list all-frames)) (t (list (selected-frame))))) -(defun tab-bar-get-buffer-tab (buffer-or-name &optional all-frames ignore-current-tab all-tabs) +(defun tab-bar-get-buffer-tab (buffer-or-name + &optional all-frames ignore-current-tab all-tabs) "Return the tab that owns the window whose buffer is BUFFER-OR-NAME. BUFFER-OR-NAME may be a buffer or a buffer name, and defaults to the current buffer. @@ -2540,7 +2569,7 @@ files will be visited." (progn (setq value (nreverse value)) (switch-to-buffer-other-tab (car value)) - (mapc 'switch-to-buffer (cdr value)) + (mapc #'switch-to-buffer (cdr value)) value) (switch-to-buffer-other-tab value)))) @@ -2582,26 +2611,26 @@ When `switch-to-buffer-obey-display-actions' is non-nil, ;;; Short aliases and keybindings -(defalias 'tab-new 'tab-bar-new-tab) -(defalias 'tab-new-to 'tab-bar-new-tab-to) -(defalias 'tab-duplicate 'tab-bar-duplicate-tab) -(defalias 'tab-detach 'tab-bar-detach-tab) -(defalias 'tab-window-detach 'tab-bar-move-window-to-tab) -(defalias 'tab-close 'tab-bar-close-tab) -(defalias 'tab-close-other 'tab-bar-close-other-tabs) -(defalias 'tab-close-group 'tab-bar-close-group-tabs) -(defalias 'tab-undo 'tab-bar-undo-close-tab) -(defalias 'tab-select 'tab-bar-select-tab) -(defalias 'tab-switch 'tab-bar-switch-to-tab) -(defalias 'tab-next 'tab-bar-switch-to-next-tab) -(defalias 'tab-previous 'tab-bar-switch-to-prev-tab) -(defalias 'tab-last 'tab-bar-switch-to-last-tab) -(defalias 'tab-recent 'tab-bar-switch-to-recent-tab) -(defalias 'tab-move 'tab-bar-move-tab) -(defalias 'tab-move-to 'tab-bar-move-tab-to) -(defalias 'tab-rename 'tab-bar-rename-tab) -(defalias 'tab-group 'tab-bar-change-tab-group) -(defalias 'tab-list 'tab-switcher) +(defalias 'tab-new #'tab-bar-new-tab) +(defalias 'tab-new-to #'tab-bar-new-tab-to) +(defalias 'tab-duplicate #'tab-bar-duplicate-tab) +(defalias 'tab-detach #'tab-bar-detach-tab) +(defalias 'tab-window-detach #'tab-bar-move-window-to-tab) +(defalias 'tab-close #'tab-bar-close-tab) +(defalias 'tab-close-other #'tab-bar-close-other-tabs) +(defalias 'tab-close-group #'tab-bar-close-group-tabs) +(defalias 'tab-undo #'tab-bar-undo-close-tab) +(defalias 'tab-select #'tab-bar-select-tab) +(defalias 'tab-switch #'tab-bar-switch-to-tab) +(defalias 'tab-next #'tab-bar-switch-to-next-tab) +(defalias 'tab-previous #'tab-bar-switch-to-prev-tab) +(defalias 'tab-last #'tab-bar-switch-to-last-tab) +(defalias 'tab-recent #'tab-bar-switch-to-recent-tab) +(defalias 'tab-move #'tab-bar-move-tab) +(defalias 'tab-move-to #'tab-bar-move-tab-to) +(defalias 'tab-rename #'tab-bar-rename-tab) +(defalias 'tab-group #'tab-bar-change-tab-group) +(defalias 'tab-list #'tab-switcher) (keymap-set tab-prefix-map "n" #'tab-duplicate) (keymap-set tab-prefix-map "N" #'tab-new-to) diff --git a/lisp/term.el b/lisp/term.el index 2e719567058..e1392908b90 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -1370,7 +1370,6 @@ 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) ;; As we have moved point, bind `select-active-regions' to prevent ;; the `deactivate-mark' call in `term-send-raw-string' from diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el new file mode 100644 index 00000000000..4c1f410a7ef --- /dev/null +++ b/lisp/textmodes/html-ts-mode.el @@ -0,0 +1,134 @@ +;;; html-ts-mode.el --- tree-sitter support for HTML -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author : Theodor Thornhill <theo@thornhill.no> +;; Maintainer : Theodor Thornhill <theo@thornhill.no> +;; Created : January 2023 +;; Keywords : html languages tree-sitter + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; + +;;; Code: + +(require 'treesit) +(require 'sgml-mode) + +(declare-function treesit-parser-create "treesit.c") +(declare-function treesit-node-type "treesit.c") + +(defcustom html-ts-mode-indent-offset 2 + "Number of spaces for each indentation step in `html-ts-mode'." + :version "29.1" + :type 'integer + :safe 'integerp + :group 'html) + +(defvar html-ts-mode--indent-rules + `((html + ((parent-is "fragment") column-0 0) + ((node-is "/>") parent-bol 0) + ((node-is ">") parent-bol 0) + ((node-is "end_tag") parent-bol 0) + ((parent-is "comment") prev-adaptive-prefix 0) + ((parent-is "element") parent-bol html-ts-mode-indent-offset) + ((parent-is "script_element") parent-bol html-ts-mode-indent-offset) + ((parent-is "style_element") parent-bol html-ts-mode-indent-offset) + ((parent-is "start_tag") parent-bol html-ts-mode-indent-offset) + ((parent-is "self_closing_tag") parent-bol html-ts-mode-indent-offset))) + "Tree-sitter indent rules.") + +(defvar html-ts-mode--font-lock-settings + (treesit-font-lock-rules + :language 'html + :override t + :feature 'comment + `((comment) @font-lock-comment-face) + :language 'html + :override t + :feature 'keyword + `("doctype" @font-lock-keyword-face) + :language 'html + :override t + :feature 'definition + `((tag_name) @font-lock-function-name-face) + :language 'html + :override t + :feature 'string + `((quoted_attribute_value) @font-lock-string-face) + :language 'html + :override t + :feature 'property + `((attribute_name) @font-lock-variable-name-face)) + "Tree-sitter font-lock settings for `html-ts-mode'.") + +(defun html-ts-mode--defun-name (node) + "Return the defun name of NODE. +Return nil if there is no name or if NODE is not a defun node." + (when (equal (treesit-node-type node) "tag_name") + (treesit-node-text node t))) + +;;;###autoload +(define-derived-mode html-ts-mode html-mode "HTML" + "Major mode for editing Html, powered by tree-sitter." + :group 'html + + (unless (treesit-ready-p 'html) + (error "Tree-sitter for HTML isn't available")) + + (treesit-parser-create 'html) + + ;; Comments. + (setq-local treesit-text-type-regexp + (regexp-opt '("comment" "text"))) + + ;; Indent. + (setq-local treesit-simple-indent-rules html-ts-mode--indent-rules) + + ;; Navigation. + (setq-local treesit-defun-type-regexp "element") + + (setq-local treesit-defun-name-function #'html-ts-mode--defun-name) + + (setq-local treesit-sentence-type-regexp "tag") + + (setq-local treesit-sexp-type-regexp + (regexp-opt '("element" + "text" + "attribute" + "value"))) + + ;; Font-lock. + (setq-local treesit-font-lock-settings html-ts-mode--font-lock-settings) + (setq-local treesit-font-lock-feature-list + '((comment keyword definition) + (property string) + () ())) + + ;; Imenu. + (setq-local treesit-simple-imenu-settings + '(("Element" "\\`tag_name\\'" nil nil))) + (treesit-major-mode-setup)) + +(if (treesit-ready-p 'html) + (add-to-list 'auto-mode-alist '("\\.html\\'" . html-ts-mode))) + +(provide 'html-ts-mode) + +;;; html-ts-mode.el ends here diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index a9e28a3275b..6c33380b6bd 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -441,13 +441,12 @@ the current paragraph with the one containing the mark." (if (< (point) (point-max)) (end-of-paragraph-text)))))) -(defun forward-sentence (&optional arg) +(defun forward-sentence-default-function (&optional arg) "Move forward to next end of sentence. With argument, repeat. When ARG is negative, move backward repeatedly to start of sentence. The variable `sentence-end' is a regular expression that matches ends of sentences. Also, every paragraph boundary terminates sentences as well." - (interactive "^p") (or arg (setq arg 1)) (let ((opoint (point)) (sentence-end (sentence-end))) @@ -479,6 +478,18 @@ sentences. Also, every paragraph boundary terminates sentences as well." (setq arg (1- arg))) (constrain-to-field nil opoint t))) +(defvar forward-sentence-function #'forward-sentence-default-function + "Function to be used to calculate sentence movements. +See `forward-sentence' for a description of its behavior.") + +(defun forward-sentence (&optional arg) + "Move forward to next end of sentence. With argument ARG, repeat. +If ARG is negative, move backward repeatedly to start of +sentence. Delegates its work to `forward-sentence-function'." + (interactive "^p") + (or arg (setq arg 1)) + (funcall forward-sentence-function arg)) + (defun count-sentences (start end) "Count sentences in current buffer from START to END." (let ((sentences 0) 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/reftex-ref.el b/lisp/textmodes/reftex-ref.el index 7315c1e1e74..da0779c8e8d 100644 --- a/lisp/textmodes/reftex-ref.el +++ b/lisp/textmodes/reftex-ref.el @@ -495,7 +495,7 @@ When called with 2 \\[universal-argument] prefix args, disable magic word recogn sep1 (cdr (assoc sep reftex-multiref-punctuation)) labels (cdr labels)) (when cut - (backward-delete-char cut) + (delete-char (- cut)) (setq cut nil)) ;; remove ~ if we do already have a space 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/thingatpt.el b/lisp/thingatpt.el index 9363a474cb5..f3367290dee 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -645,7 +645,7 @@ back from point." ;; Email addresses (defvar thing-at-point-email-regexp - "<?[-+_.~a-zA-Z][-+_.~:a-zA-Z0-9]*@[-.a-zA-Z0-9]+>?" + "<?[-+_~a-zA-Z0-9][-+_.~:a-zA-Z0-9]*@[-a-zA-Z0-9]+[-.a-zA-Z0-9]*>?" "A regular expression probably matching an email address. This does not match the real name portion, only the address, optionally with angle brackets.") diff --git a/lisp/time.el b/lisp/time.el index f04a22dfd28..522bec46ac6 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -139,6 +139,11 @@ make the mail indicator stand out on a color display." :version "22.1" :type '(choice (const :tag "None" nil) face)) +(defface display-time-date-and-time nil + "Face for `display-time-format'." + :group 'mode-line-faces + :version "30.1") + (defvar display-time-mail-icon (find-image '((:type xpm :file "letter.xpm" :ascent center) (:type pbm :file "letter.pbm" :ascent center))) @@ -179,6 +184,7 @@ depend on `display-time-day-and-date' and `display-time-24hr-format'." (format-time-string (or display-time-format (if display-time-24hr-format "%H:%M" "%-I:%M%p")) now) + 'face 'display-time-date-and-time 'help-echo (format-time-string "%a %b %e, %Y" now)) load (if mail diff --git a/lisp/treesit.el b/lisp/treesit.el index e718ea1a23a..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)) @@ -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) @@ -1730,6 +1773,49 @@ BACKWARD and ALL are the same as in `treesit-search-forward'." (goto-char current-pos))) node)) +(defvar-local treesit-sexp-type-regexp nil + "A regexp that matches the node type of sexp nodes. + +A sexp node is a node that is bigger than punctuation, and +delimits medium sized statements in the source code. It is, +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) 'restricted)) + +(defun treesit-transpose-sexps (&optional arg) + "Tree-sitter `transpose-sexps' function. +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. + +Return a pair of positions as described by +`transpose-sexps-function' for use in `transpose-subr' and +friends." + (let* ((parent (treesit-node-parent (treesit-node-at (point)))) + (child (treesit-node-child parent 0 t))) + (named-let loop ((prev child) + (next (treesit-node-next-sibling child t))) + (when (and prev next) + (if (< (point) (treesit-node-end next)) + (if (= arg -1) + (cons (treesit-node-start prev) + (treesit-node-end prev)) + (when-let ((n (treesit-node-child + parent (+ arg (treesit-node-index prev t)) t))) + (cons (treesit-node-end n) + (treesit-node-start n)))) + (loop (treesit-node-next-sibling prev t) + (treesit-node-next-sibling next t))))))) + ;;; Navigation, defun, things ;; ;; Emacs lets you define "things" by a regexp that matches the type of @@ -1800,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)))) @@ -1858,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))) @@ -1886,7 +1978,8 @@ this function depends on `treesit-defun-type-regexp' and (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))) @@ -1898,6 +1991,40 @@ this function depends on `treesit-defun-type-regexp' and (throw 'done nil) (setq arg (if (> arg 0) (1+ arg) (1- arg)))))))) +(defvar-local treesit-text-type-regexp "\\`comment\\'" + "A regexp that matches the node type of textual nodes. + +A textual node is a node that is not normal code, such as +comments and multiline string literals. For example, +\"(line|block)_comment\" in the case of a comment, or +\"text_block\" in the case of a string. This is used by +`prog-fill-reindent-defun' and friends.") + +(defvar-local treesit-sentence-type-regexp nil + "A regexp that matches the node type of sentence nodes. + +A sentence node is a node that is bigger than a sexp, and +delimits larger statements in the source code. It is, however, +smaller in scope than defuns. This is used by +`treesit-forward-sentence' and friends.") + +(defun treesit-forward-sentence (&optional arg) + "Tree-sitter `forward-sentence-function' function. + +ARG is the same as in `forward-sentence'. + +If inside comment or other nodes described in +`treesit-sentence-type-regexp', use +`forward-sentence-default-function', else move across nodes as +described by `treesit-sentence-type-regexp'." + (if (string-match-p + treesit-text-type-regexp + (treesit-node-type (treesit-node-at (point)))) + (funcall #'forward-sentence-default-function arg) + (funcall + (if (> arg 0) #'treesit-end-of-thing #'treesit-beginning-of-thing) + treesit-sentence-type-regexp (abs arg)))) + (defun treesit-default-defun-skipper () "Skips spaces after navigating a defun. This function tries to move to the beginning of a line, either by @@ -1926,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 @@ -1934,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. @@ -1957,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 @@ -1973,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) @@ -1989,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 @@ -2025,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, @@ -2036,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." @@ -2055,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. @@ -2134,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 () @@ -2366,6 +2491,13 @@ before calling this function." (when treesit-defun-name-function (setq-local add-log-current-defun-function #'treesit-add-log-current-defun)) + + (when treesit-sexp-type-regexp + (setq-local forward-sexp-function #'treesit-forward-sexp)) + (setq-local transpose-sexps-function #'treesit-transpose-sexps) + (when treesit-sentence-type-regexp + (setq-local forward-sentence-function #'treesit-forward-sentence)) + ;; Imenu. (when treesit-simple-imenu-settings (setq-local imenu-create-index-function @@ -2858,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. @@ -2879,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 @@ -2974,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)) @@ -3008,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-domsuf.el b/lisp/url/url-domsuf.el index 74d46f1c037..671885e418f 100644 --- a/lisp/url/url-domsuf.el +++ b/lisp/url/url-domsuf.el @@ -30,14 +30,26 @@ (defvar url-domsuf-domains nil) +(defun url-domsuf--public-suffix-file () + "Look for and return a file name for a recent \"public_suffix_list.dat\". +Emacs ships with a copy of this file, but some systems might have +a newer version available. Look for it in some standard +locations, and if a newer file was found, then return that." + (car (sort + (seq-filter + #'file-readable-p + (list (expand-file-name "publicsuffix.txt.gz" data-directory) + (expand-file-name "publicsuffix.txt" data-directory) + ;; Debian and Fedora + "/usr/share/publicsuffix/public_suffix_list.dat" + ;; FreeBSD port + "/usr/local/share/public_suffix_list/public_suffix_list.dat")) + #'file-newer-than-file-p))) + (defun url-domsuf-parse-file () (with-temp-buffer (with-auto-compression-mode - (insert-file-contents - (let* ((suffixfile (expand-file-name "publicsuffix.txt" data-directory)) - (compressed-file (concat suffixfile ".gz"))) - (or (and (file-readable-p compressed-file) compressed-file) - suffixfile)))) + (insert-file-contents (url-domsuf--public-suffix-file))) (let ((domains nil) domain exception) (while (not (eobp)) diff --git a/lisp/url/url-future.el b/lisp/url/url-future.el index fc852ed7c0b..9b528835a7b 100644 --- a/lisp/url/url-future.el +++ b/lisp/url/url-future.el @@ -53,7 +53,7 @@ (define-inline url-future-errored-p (url-future) (inline-quote (eq (url-future-status ,url-future) 'error))) -(define-inline url-future-cancelled-p (url-future) +(define-inline url-future-canceled-p (url-future) (inline-quote (eq (url-future-status ,url-future) 'cancel))) (defun url-future-finish (url-future &optional status) @@ -96,5 +96,8 @@ (signal 'error 'url-future-already-done) (url-future-finish url-future 'cancel))) +(define-obsolete-function-alias 'url-future-cancelled-p + #'url-future-canceled-p "30.1") + (provide 'url-future) ;;; url-future.el ends here diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index 70714b0f24f..4d7297f6f2e 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -239,35 +239,34 @@ overriding the value of `url-gateway-method'." (if url-gateway-broken-resolution (setq host (url-gateway-nslookup-host host))) - (condition-case nil - ;; This is a clean way to ensure the new process inherits the - ;; right coding systems in both Emacs and XEmacs. - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (setq conn (pcase gw-method - ((or 'tls 'ssl 'native) - (if (eq gw-method 'native) - (setq gw-method 'plain)) - (open-network-stream - name buffer host service - :type gw-method - ;; Use non-blocking socket if we can. - :nowait (and (featurep 'make-network-process) - (url-asynchronous url-current-object) - '(:nowait t)))) - ('socks - (socks-open-network-stream name buffer host service)) - ('telnet - (url-open-telnet name buffer host service)) - ('rlogin - (unless url-gw-rlogin-obsolete-warned-once - (lwarn 'url :error "Setting `url-gateway-method' to `rlogin' is obsolete") - (setq url-gw-rlogin-obsolete-warned-once t)) - (with-suppressed-warnings ((obsolete url-open-rlogin)) - (url-open-rlogin name buffer host service))) - (_ - (error "Bad setting of url-gateway-method: %s" - url-gateway-method)))))) + ;; This is a clean way to ensure the new process inherits the + ;; right coding systems in both Emacs and XEmacs. + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq conn (pcase gw-method + ((or 'tls 'ssl 'native) + (if (eq gw-method 'native) + (setq gw-method 'plain)) + (open-network-stream + name buffer host service + :type gw-method + ;; Use non-blocking socket if we can. + :nowait (and (featurep 'make-network-process) + (url-asynchronous url-current-object) + '(:nowait t)))) + ('socks + (socks-open-network-stream name buffer host service)) + ('telnet + (url-open-telnet name buffer host service)) + ('rlogin + (unless url-gw-rlogin-obsolete-warned-once + (lwarn 'url :error "Setting `url-gateway-method' to `rlogin' is obsolete") + (setq url-gw-rlogin-obsolete-warned-once t)) + (with-suppressed-warnings ((obsolete url-open-rlogin)) + (url-open-rlogin name buffer host service))) + (_ + (error "Bad setting of url-gateway-method: %s" + url-gateway-method))))) conn))) (provide 'url-gw) 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/use-package/bind-key.el b/lisp/use-package/bind-key.el index 0ab72eafce2..b216c668d83 100644 --- a/lisp/use-package/bind-key.el +++ b/lisp/use-package/bind-key.el @@ -447,7 +447,7 @@ This binds keys in such a way that bindings are not overridden by other modes. See `override-global-mode'." (macroexp-progn (bind-keys-form args 'override-global-map))) -(defun get-binding-description (elem) +(defun bind-key--get-binding-description (elem) (cond ((listp elem) (cond @@ -474,7 +474,7 @@ other modes. See `override-global-mode'." (t "#<byte-compiled lambda>"))) -(defun compare-keybindings (l r) +(defun bind-key--compare-keybindings (l r) (let* ((regex bind-key-segregation-regexp) (lgroup (and (string-match regex (caar l)) (match-string 0 (caar l)))) @@ -517,7 +517,7 @@ other modes. See `override-global-mode'." (setq personal-keybindings (sort personal-keybindings (lambda (l r) - (car (compare-keybindings l r)))))) + (car (bind-key--compare-keybindings l r)))))) (if (not (eq (cdar last-binding) (cdar binding))) (princ (format "\n\n%s: %s\n%s\n\n" @@ -525,7 +525,7 @@ other modes. See `override-global-mode'." (make-string (+ 21 (car bind-key-column-widths) (cdr bind-key-column-widths)) ?-))) (if (and last-binding - (cdr (compare-keybindings last-binding binding))) + (cdr (bind-key--compare-keybindings last-binding binding))) (princ "\n"))) (let* ((key-name (caar binding)) @@ -534,10 +534,10 @@ other modes. See `override-global-mode'." (read-kbd-macro key-name))) (command (nth 1 binding)) (was-command (nth 2 binding)) - (command-desc (get-binding-description command)) + (command-desc (bind-key--get-binding-description command)) (was-command-desc (and was-command - (get-binding-description was-command))) - (at-present-desc (get-binding-description at-present))) + (bind-key--get-binding-description was-command))) + (at-present-desc (bind-key--get-binding-description at-present))) (let ((line (format (format "%%-%ds%%-%ds%%s\n" (car bind-key-column-widths) @@ -555,6 +555,11 @@ other modes. See `override-global-mode'." (setq last-binding binding))))) +(define-obsolete-function-alias 'get-binding-description + 'bind-key--get-binding-description "30.1") +(define-obsolete-function-alias 'compare-keybindings + 'bind-key--compare-keybindings "30.1") + (provide 'bind-key) ;; Local Variables: 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/diff-mode.el b/lisp/vc/diff-mode.el index eb01dede56e..d776375d681 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -153,6 +153,17 @@ and hunk-based syntax highlighting otherwise as a fallback." :type (get 'whitespace-style 'custom-type) :version "29.1") +(defcustom diff-ignore-whitespace-switches "-b" + "Switch or list of diff switches to use when ignoring whitespace. +The default \"-b\" means to ignore whitespace-only changes, +\"-w\" means ignore all whitespace changes." + :type '(choice + (string :tag "Ignore whitespace-only changes" :value "-b") + (string :tag "Ignore all whitespace changes" :value "-w") + (string :tag "Single switch") + (repeat :tag "Multiple switches" (string :tag "Switch"))) + :version "30.1") + (defvar diff-vc-backend nil "The VC backend that created the current Diff buffer, if any.") @@ -2103,10 +2114,13 @@ For use in `add-log-current-defun-function'." (goto-char (+ (car pos) (cdr src))) (add-log-current-defun))))))) -(defun diff-ignore-whitespace-hunk () - "Re-diff the current hunk, ignoring whitespace differences." - (interactive) - (diff-refresh-hunk t)) +(defun diff-ignore-whitespace-hunk (&optional whole-buffer) + "Re-diff the current hunk, ignoring whitespace differences. +With non-nil prefix arg, re-diff all the hunks." + (interactive "P") + (if whole-buffer + (diff--ignore-whitespace-all-hunks) + (diff-refresh-hunk t))) (defun diff-refresh-hunk (&optional ignore-whitespace) "Re-diff the current hunk." @@ -2127,7 +2141,7 @@ For use in `add-log-current-defun-function'." (coding-system-for-read buffer-file-coding-system) opts old new) (when ignore-whitespace - (setq opts '("-b"))) + (setq opts (ensure-list diff-ignore-whitespace-switches))) (when opt-type (setq opts (cons opt-type opts))) @@ -2299,6 +2313,16 @@ Call FUN with two args (BEG and END) for each hunk." (or (ignore-errors (diff-hunk-next) (point)) max))))))))) +;; This doesn't use `diff--iterate-hunks', since that assumes that +;; hunks don't change size. +(defun diff--ignore-whitespace-all-hunks () + "Re-diff all the hunks, ignoring whitespace-differences." + (save-excursion + (goto-char (point-min)) + (diff-hunk-next) + (while (looking-at diff-hunk-header-re) + (diff-refresh-hunk t)))) + (defun diff--font-lock-refined (max) "Apply hunk refinement from font-lock." (when (eq diff-refine 'font-lock) diff --git a/lisp/vc/emerge.el b/lisp/vc/emerge.el index de09be80e7c..e95742b304a 100644 --- a/lisp/vc/emerge.el +++ b/lisp/vc/emerge.el @@ -1299,7 +1299,7 @@ Otherwise, the A or B file present is copied to the output file." (setq ancestor-dir-files (cdr ancestor-dir-files)))) (if output-dir (insert "output=" output-dir f "\t")) - (backward-delete-char 1) + (delete-char -1) (insert "\n"))))) ;;; Common setup routines diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 7ae763d2ee4..a3469b71386 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -136,12 +136,19 @@ If nil, use the value of `vc-annotate-switches'. If t, use no switches." ;;;###autoload(put 'vc-git-annotate-switches 'safe-local-variable (lambda (switches) (equal switches "-w"))) (defcustom vc-git-log-switches nil - "String or list of strings specifying switches for Git log under VC." + "String or list of strings giving Git log switches for non-shortlogs." :type '(choice (const :tag "None" nil) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) :version "28.1") +(defcustom vc-git-shortlog-switches nil + "String or list of strings giving Git log switches for shortlogs." + :type '(choice (const :tag "None" nil) + (string :tag "Argument String") + (repeat :tag "Argument List" :value ("") string)) + :version "30.1") + (defcustom vc-git-resolve-conflicts t "When non-nil, mark conflicted file as resolved upon saving. That is performed after all conflict markers in it have been @@ -308,6 +315,23 @@ Good example of file name that needs this: \"test[56].xx\".") (string-trim-right (match-string 1 version-string) "\\.") "0"))))) +(defun vc-git--git-path (&optional path) + "Resolve .git/PATH for the current working tree. +In particular, handle the case where this is a linked working +tree, such that .git is a plain file. + +See the --git-dir and --git-path options to git-rev-parse(1)." + (if (and path (not (string-empty-p path))) + ;; Canonicalize in this branch because --git-dir always returns + ;; an absolute file name. + (expand-file-name + (string-trim-right + (vc-git--run-command-string nil "rev-parse" + "--git-path" path))) + (concat (string-trim-right + (vc-git--run-command-string nil "rev-parse" "--git-dir")) + "/"))) + (defun vc-git--git-status-to-vc-state (code-list) "Convert CODE-LIST to a VC status. @@ -752,12 +776,32 @@ or an empty string if none." :help "Show the contents of the current stash")) map)) +(defun vc-git--cmds-in-progress () + "Return a list of Git commands in progress in this worktree." + (let ((gitdir (vc-git--git-path)) + cmds) + ;; See contrib/completion/git-prompt.sh in git.git. + (when (or (file-directory-p + (expand-file-name "rebase-merge" gitdir)) + (file-exists-p + (expand-file-name "rebase-apply/rebasing" gitdir))) + (push 'rebase cmds)) + (when (file-exists-p + (expand-file-name "rebase-apply/applying" gitdir)) + (push 'am cmds)) + (when (file-exists-p (expand-file-name "MERGE_HEAD" gitdir)) + (push 'merge cmds)) + (when (file-exists-p (expand-file-name "BISECT_START" gitdir)) + (push 'bisect cmds)) + cmds)) + (defun vc-git-dir-extra-headers (dir) (let ((str (with-output-to-string (with-current-buffer standard-output (vc-git--out-ok "symbolic-ref" "HEAD")))) (stash-list (vc-git-stash-list)) (default-directory dir) + (in-progress (vc-git--cmds-in-progress)) branch remote remote-url stash-button stash-string) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) @@ -832,9 +876,9 @@ or an empty string if none." (propertize remote-url 'face 'vc-dir-header-value))) ;; For now just a heading, key bindings can be added later for various bisect actions - (when (file-exists-p (expand-file-name ".git/BISECT_START" (vc-git-root dir))) + (when (memq 'bisect in-progress) (propertize "\nBisect : in progress" 'face 'vc-dir-status-warning)) - (when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root dir))) + (when (memq 'rebase in-progress) (propertize "\nRebase : in progress" 'face 'vc-dir-status-warning)) (if stash-list (concat @@ -1015,13 +1059,26 @@ It is based on `log-edit-mode', and has Git-specific extensions." ;; message. Handle also remote files. (if (eq system-type 'windows-nt) (let ((default-directory (file-name-directory file1))) - (make-nearby-temp-file "git-msg"))))) + (make-nearby-temp-file "git-msg")))) + to-stash) (when vc-git-patch-string (unless (zerop (vc-git-command nil t nil "diff" "--cached" "--quiet")) - ;; Check that all staged changes also exist in the patch. - ;; This is needed to allow adding/removing files that are - ;; currently staged to the index. So remove the whole file diff - ;; from the patch because commit will take it from the index. + ;; Check that what's already staged is compatible with what + ;; we want to commit (bug#60126). + ;; + ;; 1. If the changes to a file in the index are identical to + ;; the changes to that file we want to commit, remove the + ;; changes from our patch, and let the commit take them + ;; from the index. This is necessary for adding and + ;; removing files to work. + ;; + ;; 2. If the changes to a file in the index are different to + ;; changes to that file we want to commit, then we have to + ;; unstage the changes or abort. + ;; + ;; 3. If there are changes to a file in the index but we don't + ;; want to commit any changes to that file, we need to + ;; stash those changes before committing. (with-temp-buffer ;; If the user has switches like -D, -M etc. in their ;; `vc-git-diff-switches', we must pass them here too, or @@ -1032,23 +1089,35 @@ It is based on `log-edit-mode', and has Git-specific extensions." ;; Following code doesn't understand plain diff(1) output. (user-error "Cannot commit patch with nil `vc-git-diff-switches'")) (goto-char (point-min)) - (let ((pos (point)) file-diff file-beg) + (let ((pos (point)) file-name file-header file-diff file-beg) (while (not (eobp)) + (when (and (looking-at "^diff --git a/\\(.+\\) b/\\(.+\\)") + (string= (match-string 1) (match-string 2))) + (setq file-name (match-string 1))) (forward-line 1) ; skip current "diff --git" line + (setq file-header (buffer-substring pos (point))) (search-forward "diff --git" nil 'move) (move-beginning-of-line 1) (setq file-diff (buffer-substring pos (point))) - (if (and (setq file-beg (string-search - file-diff vc-git-patch-string)) - ;; Check that file diff ends with an empty string - ;; or the beginning of the next file diff. - (string-match-p "\\`\\'\\|\\`diff --git" - (substring - vc-git-patch-string - (+ file-beg (length file-diff))))) - (setq vc-git-patch-string - (string-replace file-diff "" vc-git-patch-string)) - (user-error "Index not empty")) + (cond ((and (setq file-beg (string-search + file-diff vc-git-patch-string)) + ;; Check that file diff ends with an empty string + ;; or the beginning of the next file diff. + (string-match-p "\\`\\'\\|\\`diff --git" + (substring + vc-git-patch-string + (+ file-beg (length file-diff))))) + (setq vc-git-patch-string + (string-replace file-diff "" vc-git-patch-string))) + ((string-match (format "^%s" (regexp-quote file-header)) + vc-git-patch-string) + (if (and file-name + (yes-or-no-p + (format "Unstage already-staged changes to %s?" + file-name))) + (vc-git-command nil 0 file-name "reset" "-q" "--") + (user-error "Index not empty"))) + (t (push file-name to-stash))) (setq pos (point)))))) (unless (string-empty-p vc-git-patch-string) (let ((patch-file (make-nearby-temp-file "git-patch"))) @@ -1056,7 +1125,8 @@ It is based on `log-edit-mode', and has Git-specific extensions." (insert vc-git-patch-string)) (unwind-protect (vc-git-command nil 0 patch-file "apply" "--cached") - (delete-file patch-file))))) + (delete-file patch-file)))) + (when to-stash (vc-git--stash-staged-changes files))) (cl-flet ((boolean-arg-fn (argument) (lambda (value) (when (equal value "yes") (list argument))))) @@ -1082,7 +1152,58 @@ It is based on `log-edit-mode', and has Git-specific extensions." args) (unless vc-git-patch-string (if only (list "--only" "--") '("-a")))))) - (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)))) + (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) + (when to-stash + (let ((cached (make-nearby-temp-file "git-cached"))) + (unwind-protect + (progn (with-temp-file cached + (vc-git-command t 0 nil "stash" "show" "-p")) + (vc-git-command nil 0 cached "apply" "--cached")) + (delete-file cached)) + (vc-git-command nil 0 nil "stash" "drop"))))) + +(defun vc-git--stash-staged-changes (files) + "Stash only the staged changes to FILES." + ;; This is necessary because even if you pass a list of file names + ;; to 'git stash push', it will stash any and all staged changes. + (unless (zerop + (vc-git-command nil t files "diff" "--cached" "--quiet")) + (cl-flet + ((git-string (&rest args) + (string-trim-right + (with-output-to-string + (apply #'vc-git-command standard-output 0 nil args))))) + (let ((cached (make-nearby-temp-file "git-cached")) + (message "Previously staged changes") + tree) + ;; Use a temporary index to create a tree object corresponding + ;; to the staged changes to FILES. + (unwind-protect + (progn + (with-temp-file cached + (vc-git-command t 0 files "diff" "--cached" "--")) + (let* ((index (make-nearby-temp-file "git-index")) + (process-environment + (cons (format "GIT_INDEX_FILE=%s" index) + process-environment))) + (unwind-protect + (progn + (vc-git-command nil 0 nil "read-tree" "HEAD") + (vc-git-command nil 0 cached "apply" "--cached") + (setq tree (git-string "write-tree"))) + (delete-file index)))) + (delete-file cached)) + ;; Prepare stash commit object, which has a special structure. + (let* ((tree-commit (git-string "commit-tree" "-m" message + "-p" "HEAD" tree)) + (stash-commit (git-string "commit-tree" "-m" message + "-p" "HEAD" "-p" tree-commit + tree))) + ;; Push the new stash entry. + (vc-git-command nil 0 nil "update-ref" "--create-reflog" + "-m" message "refs/stash" stash-commit) + ;; Unstage the changes we've now stashed. + (vc-git-command nil 0 files "reset" "--")))))) (defun vc-git-find-revision (file rev buffer) (let* (process-file-side-effects @@ -1193,8 +1314,7 @@ This prompts for a branch to merge from." (completing-read "Merge from branch: " (if (or (member "FETCH_HEAD" branches) (not (file-readable-p - (expand-file-name ".git/FETCH_HEAD" - root)))) + (vc-git--git-path "FETCH_HEAD")))) branches (cons "FETCH_HEAD" branches)) nil t))) @@ -1239,8 +1359,7 @@ This prompts for a branch to merge from." (unless (or (not (eq vc-git-resolve-conflicts 'unstage-maybe)) ;; Doing a merge, so bug#20292 doesn't apply. - (file-exists-p (expand-file-name ".git/MERGE_HEAD" - (vc-git-root buffer-file-name))) + (file-exists-p (vc-git--git-path "MERGE_HEAD")) (vc-git-conflicted-files (vc-git-root buffer-file-name))) (vc-git-command nil 0 nil "reset")) (vc-resynch-buffer buffer-file-name t t) @@ -1315,7 +1434,8 @@ If LIMIT is a revision string, use it as an end-revision." ,(format "--pretty=tformat:%s" (car vc-git-root-log-format)) "--abbrev-commit")) - (ensure-list vc-git-log-switches) + (ensure-list + (if shortlog vc-git-shortlog-switches vc-git-log-switches)) (when (numberp limit) (list "-n" (format "%s" limit))) (when start-revision @@ -1330,16 +1450,16 @@ If LIMIT is a revision string, use it as an end-revision." (defun vc-git-log-outgoing (buffer remote-location) (vc-setup-buffer buffer) - (vc-git-command - buffer 'async nil - "log" - "--no-color" "--graph" "--decorate" "--date=short" - (format "--pretty=tformat:%s" (car vc-git-root-log-format)) - "--abbrev-commit" - (concat (if (string= remote-location "") - "@{upstream}" - remote-location) - "..HEAD"))) + (apply #'vc-git-command buffer 'async nil + `("log" + "--no-color" "--graph" "--decorate" "--date=short" + ,(format "--pretty=tformat:%s" (car vc-git-root-log-format)) + "--abbrev-commit" + ,@(ensure-list vc-git-shortlog-switches) + ,(concat (if (string= remote-location "") + "@{upstream}" + remote-location) + "..HEAD")))) (defun vc-git-log-incoming (buffer remote-location) (vc-setup-buffer buffer) @@ -1349,15 +1469,15 @@ If LIMIT is a revision string, use it as an end-revision." ;; so remove everything except a repository name. (replace-regexp-in-string "/.*" "" remote-location))) - (vc-git-command - buffer 'async nil - "log" - "--no-color" "--graph" "--decorate" "--date=short" - (format "--pretty=tformat:%s" (car vc-git-root-log-format)) - "--abbrev-commit" - (concat "HEAD.." (if (string= remote-location "") - "@{upstream}" - remote-location)))) + (apply #'vc-git-command buffer 'async nil + `("log" + "--no-color" "--graph" "--decorate" "--date=short" + ,(format "--pretty=tformat:%s" (car vc-git-root-log-format)) + "--abbrev-commit" + ,@(ensure-list vc-git-shortlog-switches) + ,(concat "HEAD.." (if (string= remote-location "") + "@{upstream}" + remote-location))))) (defun vc-git-log-search (buffer pattern) "Search the log of changes for PATTERN and output results into BUFFER. @@ -1368,6 +1488,7 @@ Display all entries that match log messages in long format. With a prefix argument, ask for a command to run that will output log entries." (let ((args `("log" "--no-color" "-i" + ,@(ensure-list vc-git-log-switches) ,(format "--grep=%s" (or pattern ""))))) (when current-prefix-arg (setq args (cdr (split-string @@ -1415,11 +1536,11 @@ log entries." `((,log-view-message-re (1 'change-log-acknowledgment))) ;; Handle the case: ;; user: foo@bar - '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" + '(("^\\(?:Author\\|Commit\\):[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" (1 'change-log-email)) ;; Handle the case: ;; user: FirstName LastName <foo@bar> - ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" + ("^\\(?:Author\\|Commit\\):[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" (1 'change-log-name) (2 'change-log-email)) ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" @@ -1430,7 +1551,7 @@ log entries." ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" (1 'change-log-acknowledgment) (2 'change-log-acknowledgment)) - ("^\\(?:Date: \\|AuthorDate: \\)\\(.+\\)" (1 'change-log-date)) + ("^\\(?:Date: \\|AuthorDate: \\|CommitDate: \\)\\(.+\\)" (1 'change-log-date)) ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))) @@ -1452,7 +1573,11 @@ or BRANCH^ (where \"^\" can be repeated)." (defun vc-git-expanded-log-entry (revision) (with-temp-buffer - (apply #'vc-git-command t nil nil (list "log" revision "-1" "--no-color" "--")) + (apply #'vc-git-command t nil nil + `("log" + ,revision + "-1" "--no-color" ,@(ensure-list vc-git-log-switches) + "--")) (goto-char (point-min)) (unless (eobp) ;; Indent the expanded log entry. @@ -1651,7 +1776,8 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (if branchp "branch" "tag")))) (if branchp (vc-git-command nil 0 nil "checkout" "-b" name - (when (and start-point (not (eq start-point ""))) + (when (and start-point + (not (equal start-point ""))) start-point)) (vc-git-command nil 0 nil "tag" name))))) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index c64da1233d1..32b0d5d7556 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3403,7 +3403,7 @@ If nil, no default will be used. This option may be set locally." (declare-function message--name-table "message" (orig-string)) (declare-function mml-attach-buffer "mml" - (buffer &optional type description disposition)) + (buffer &optional type description disposition filename)) (declare-function log-view-get-marked "log-view" ()) (defun vc-default-prepare-patch (_backend rev) @@ -3444,6 +3444,19 @@ of the current file." (and-let* ((file (buffer-file-name))) (vc-working-revision file))))) +(defun vc--subject-to-file-name (subject) + "Generate a file name for a patch with subject line SUBJECT." + (let* ((stripped + (replace-regexp-in-string "\\`\\[.*PATCH.*\\]\\s-*" "" + subject)) + (truncated (if (length> stripped 50) + (substring stripped 0 50) + stripped))) + (concat + (string-trim (replace-regexp-in-string "\\W" "-" truncated) + "-+" "-+") + ".patch"))) + ;;;###autoload (defun vc-prepare-patch (addressee subject revisions) "Compose an Email sending patches for REVISIONS to ADDRESSEE. @@ -3454,7 +3467,7 @@ revision, with SUBJECT derived from each revision subject. When invoked with a numerical prefix argument, use the last N revisions. When invoked interactively in a Log View buffer with -marked revisions, use those these." +marked revisions, use those." (interactive (let ((revs (vc-prepare-patch-prompt-revisions)) to) (require 'message) @@ -3500,11 +3513,17 @@ marked revisions, use those these." (rfc822-goto-eoh) (forward-line) (save-excursion - (dolist (patch patches) - (mml-attach-buffer (buffer-name (plist-get patch :buffer)) - "text/x-patch" - (plist-get patch :subject) - "attachment"))) + (let ((i 0)) + (dolist (patch patches) + (let* ((patch-subject (plist-get patch :subject)) + (filename + (vc--subject-to-file-name patch-subject))) + (mml-attach-buffer + (buffer-name (plist-get patch :buffer)) + "text/x-patch" + patch-subject + "attachment" + (format "%04d-%s" (cl-incf i) filename)))))) (open-line 2))))) (defun vc-default-responsible-p (_backend _file) @@ -3645,7 +3664,7 @@ it indicates a specific revision to check out." "Default `last-change' implementation. It returns the last revision that changed LINE number in FILE." (unless (file-exists-p file) - (signal 'file-error "File doesn't exist")) + (signal 'file-error '("File doesn't exist"))) (with-temp-buffer (vc-call-backend (vc-backend file) 'annotate-command file (current-buffer)) diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 9995706a5da..86fc179396e 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -1014,34 +1014,11 @@ See also `whitespace-newline' and `whitespace-display-mappings'." ;;;###autoload -(define-minor-mode global-whitespace-mode - "Toggle whitespace visualization globally (Global Whitespace mode). - -See also `whitespace-style', `whitespace-newline' and -`whitespace-display-mappings'." - :lighter " WS" +(define-globalized-minor-mode global-whitespace-mode + whitespace-mode + whitespace-turn-on-if-enabled :init-value nil - :global t - :group 'whitespace - (cond - (noninteractive ; running a batch job - (setq global-whitespace-mode nil)) - (global-whitespace-mode ; global-whitespace-mode on - (save-current-buffer - (add-hook 'find-file-hook 'whitespace-turn-on-if-enabled) - (add-hook 'after-change-major-mode-hook 'whitespace-turn-on-if-enabled) - (dolist (buffer (buffer-list)) ; adjust all local mode - (set-buffer buffer) - (unless whitespace-mode - (whitespace-turn-on-if-enabled))))) - (t ; global-whitespace-mode off - (save-current-buffer - (remove-hook 'find-file-hook 'whitespace-turn-on-if-enabled) - (remove-hook 'after-change-major-mode-hook 'whitespace-turn-on-if-enabled) - (dolist (buffer (buffer-list)) ; adjust all local mode - (set-buffer buffer) - (unless whitespace-mode - (whitespace-turn-off))))))) + :group 'whitespace) (defvar whitespace-enable-predicate (lambda () @@ -1067,7 +1044,7 @@ This variable is normally modified via `add-function'.") (defun whitespace-turn-on-if-enabled () (when (funcall whitespace-enable-predicate) - (whitespace-turn-on))) + (whitespace-mode))) ;;;###autoload (define-minor-mode global-whitespace-newline-mode @@ -2511,7 +2488,7 @@ purposes)." (setq whitespace-display-table-was-local t) ;; Save the old table so we can restore it when ;; `whitespace-mode' is switched off again. - (when (or whitespace-mode global-whitespace-mode) + (when whitespace-mode (setq whitespace-display-table (copy-sequence buffer-display-table))) ;; Assure `buffer-display-table' is unique diff --git a/lisp/window.el b/lisp/window.el index 016d53ffbdd..aa7520f30fa 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -2510,6 +2510,7 @@ have special meanings: Any other value of ALL-FRAMES means consider all windows on the selected frame and no others." + (declare (side-effect-free error-free)) (let ((windows (window-list-1 nil 'nomini all-frames)) best-window best-time second-best-window second-best-time time) (dolist (window windows) @@ -2588,6 +2589,7 @@ have special meanings: Any other value of ALL-FRAMES means consider all windows on the selected frame and no others." + (declare (side-effect-free error-free)) (let ((best-size 0) best-window size) (dolist (window (window-list-1 nil 'nomini all-frames)) @@ -3786,6 +3788,7 @@ frame, rounded if necessary. PIXELWISE non-nil means to return the coordinates in pixels where the values for RIGHT and BOTTOM are one more than the actual value of these edges. Note that if ABSOLUTE is non-nil, PIXELWISE is implicitly non-nil too." + (declare (side-effect-free t)) (let* ((window (window-normalize-window window body)) (frame (window-frame window)) (border-width (frame-internal-border-width frame)) @@ -3841,6 +3844,7 @@ ABSOLUTE is non-nil, PIXELWISE is implicitly non-nil too." "Return a list of the edge coordinates of WINDOW's body. The return value is that of `window-edges' called with argument BODY non-nil." + (declare (side-effect-free t)) (window-edges window t)) (defalias 'window-inside-edges 'window-body-edges) @@ -3848,12 +3852,14 @@ BODY non-nil." "Return a list of the edge pixel coordinates of WINDOW. The return value is that of `window-edges' called with argument PIXELWISE non-nil." + (declare (side-effect-free t)) (window-edges window nil nil t)) (defun window-body-pixel-edges (&optional window) "Return a list of the edge pixel coordinates of WINDOW's body. The return value is that of `window-edges' called with arguments BODY and PIXELWISE non-nil." + (declare (side-effect-free t)) (window-edges window t nil t)) (defalias 'window-inside-pixel-edges 'window-body-pixel-edges) @@ -3861,12 +3867,14 @@ BODY and PIXELWISE non-nil." "Return a list of the edge pixel coordinates of WINDOW. The return value is that of `window-edges' called with argument ABSOLUTE non-nil." + (declare (side-effect-free t)) (window-edges window nil t t)) (defun window-absolute-body-pixel-edges (&optional window) "Return a list of the edge pixel coordinates of WINDOW's text area. The return value is that of `window-edges' called with arguments BODY and ABSOLUTE non-nil." + (declare (side-effect-free t)) (window-edges window t t t)) (defalias 'window-inside-absolute-pixel-edges 'window-absolute-body-pixel-edges) @@ -4076,6 +4084,7 @@ with a special meaning are: Anything else means consider all windows on the selected frame and no others." + (declare (side-effect-free error-free)) (let ((base-window (selected-window))) (if (and nomini (eq base-window (minibuffer-window))) (setq base-window (next-window base-window))) diff --git a/lisp/woman.el b/lisp/woman.el index 92cd425d32f..24f23c8e8f0 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -1690,11 +1690,11 @@ Do not call directly!" (progn (goto-char (point-min)) (while (search-forward "__\b\b" nil t) - (backward-delete-char 4) + (delete-char -4) (woman-set-face (point) (1+ (point)) 'woman-italic)) (goto-char (point-min)) (while (search-forward "\b\b__" nil t) - (backward-delete-char 4) + (delete-char -4) (woman-set-face (1- (point)) (point) 'woman-italic)))) ;; Interpret overprinting to indicate bold face: |