diff options
Diffstat (limited to 'lisp')
126 files changed, 4953 insertions, 3226 deletions
diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 550d956fb7b..ef8ef1ab5a6 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/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 34aa8399a96..99189d2e570 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..5f31530f068 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) @@ -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-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/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/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/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..c5589324a14 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -4119,9 +4119,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/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-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 2bcb28a0e00..76499d0f520 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -530,7 +530,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 diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 427da557d23..0303fec67a6 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." 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..039cebedb44 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -410,7 +410,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 @@ -755,7 +758,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 @@ -1297,11 +1301,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 +1380,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))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index eb7d026b146..9345665eea8 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,11 @@ 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'. +`interactive-only', `lexical', `mapcar', `constants', +`suspicious' and `empty-body'. 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." +the symbol list." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) @@ -679,11 +680,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..aa9521e5a65 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). @@ -326,6 +327,7 @@ 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. @@ -541,15 +543,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 +1575,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 +1772,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) @@ -3439,7 +3451,7 @@ lambda-expression." (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))) (if (and handler ;; Make sure that function exists. @@ -4835,6 +4847,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)) @@ -5487,6 +5504,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 0154716627f..e715bd90a00 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 diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 152a1fe9434..95a51a4bdde 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) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 43207ce7026..cffe8b09f53 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) @@ -3175,8 +3176,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 +3186,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) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 49e3cdb8de7..4c423be06c4 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1220,7 +1220,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))) @@ -1264,7 +1264,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 @@ -1288,7 +1288,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"))) @@ -1369,7 +1369,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 @@ -1740,7 +1740,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-emit-set-call-subr (subr-name sp-delta) "Emit a call for SUBR-NAME. @@ -2823,7 +2823,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)) @@ -3721,7 +3721,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)))))))) @@ -3805,22 +3805,22 @@ Return the trampoline if found or nil otherwise." form nil ;; If we've disabled nativecomp, don't write the trampolines to ;; the eln cache (but create them). - (and (not inhibit-automatic-native-compilation) - (cl-loop - for dir in (if native-compile-target-directory - (list (expand-file-name comp-native-version-dir - native-compile-target-directory)) - (comp-eln-load-path-eff)) - for f = (expand-file-name - (comp-trampoline-filename subr-name) - dir) - unless (file-exists-p dir) - do (ignore-errors - (make-directory dir t) - (cl-return f)) - when (file-writable-p f) - do (cl-return f) - finally (error "Cannot find suitable directory for output in \ + (unless inhibit-automatic-native-compilation + (cl-loop + for dir in (if native-compile-target-directory + (list (expand-file-name comp-native-version-dir + native-compile-target-directory)) + (comp-eln-load-path-eff)) + for f = (expand-file-name + (comp-trampoline-filename subr-name) + dir) + unless (file-exists-p dir) + do (ignore-errors + (make-directory dir t) + (cl-return f)) + when (file-writable-p f) + do (cl-return f) + finally (error "Cannot find suitable directory for output in \ `native-comp-eln-load-path'")))))) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 5721470ad0d..77f4b26d9bb 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)) @@ -682,6 +685,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)) @@ -722,9 +726,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/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/gv.el b/lisp/emacs-lisp/gv.el index e307776252a..dad91e92a45 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/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168de1bf180..c909ffb6933 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 @@ -367,14 +368,14 @@ 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)) (`(setq ,(and var (pred symbolp) @@ -392,7 +393,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 +458,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 +488,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))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index f92afe56b76..09917cd29b1 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -4562,6 +4562,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/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index abadefb7105..0eb58565b37 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) 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-cmpl.el b/lisp/eshell/em-cmpl.el index ca51cee2558..4206ad048fa 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -312,7 +312,7 @@ to writing a completion function." (eshell-interactive-process-p)) (eshell--pcomplete-insert-tab)) (let ((end (point-marker)) - (begin (save-excursion (eshell-bol) (point))) + (begin (save-excursion (beginning-of-line) (point))) (posns (list t)) args delim) (when (and pcomplete-allow-modifications @@ -342,17 +342,23 @@ to writing a completion function." (setq pos (1+ pos)))) (setq posns (cdr posns)) (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)))) + ;; Remove any top-level `eshell-splice-args' sigils. These + ;; are meant to be rewritten and can't actually be called. + (when (and (consp (car a)) + (eq (caar a) 'eshell-splice-args)) + (setcar a (cadar a))) + ;; 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)) ? ) (not (eq (char-before (1- end)) ?\\))) 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-hist.el b/lisp/eshell/em-hist.el index 05e9598f530..6e0e471d910 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -555,7 +555,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)) @@ -913,7 +913,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 +933,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 diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index 575b5a595f1..b3a0fadf618 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -29,6 +29,8 @@ (require 'esh-mode) (eval-when-compile (require 'eshell)) +(require 'text-property-search) + ;;;###autoload (progn (defgroup eshell-prompt nil @@ -50,7 +52,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 +60,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 +126,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 +136,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..f147d432300 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -50,9 +50,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 +188,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-unix.el b/lisp/eshell/em-unix.el index f88a06d2e95..d550910f4f0 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -786,10 +786,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/esh-arg.el b/lisp/eshell/esh-arg.el index 9aab3af9b47..6c882471aee 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -238,13 +238,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 +301,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 +343,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 +390,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) ?\\) @@ -377,20 +423,24 @@ after are both returned." (when (eshell-looking-at-backslash-return (point)) (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!" @@ -496,5 +546,33 @@ 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))) + (provide 'esh-arg) ;;; esh-arg.el ends here diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index f4ac384ccc5..99c3d7f627d 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -418,8 +418,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,11 +483,16 @@ 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)))) + (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) @@ -783,16 +791,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 +812,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 +837,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. @@ -875,11 +886,8 @@ This is used on systems where async subprocesses are not supported." (progn ,(if (fboundp 'make-process) `(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)))))) @@ -1019,7 +1027,9 @@ produced by `eshell-parse-command'." ;; We can just stick the new command at the end of the current ;; one, and everything will happen as it should. (setcdr (last (cdr eshell-current-command)) - (list `(let ((here (and (eobp) (point)))) + (list `(let ((here (and (eobp) (point))) + (eshell-command-body '(nil)) + (eshell-test-body '(nil))) ,(and input `(insert-and-inherit ,(concat input "\n"))) (if here 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..503d9ba1b63 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -155,7 +155,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 @@ -175,6 +176,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) @@ -261,14 +264,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 +473,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 +506,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 +522,13 @@ 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 + (add-text-properties 0 (length string) + '(field command-output rear-nonsticky (field)) + string) + (eshell-interactive-filter nil string))) (defsubst eshell-begin-on-new-line () "This function outputs a newline if not at beginning of line." @@ -687,14 +688,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 +852,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 +880,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 (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-opt.el b/lisp/eshell/esh-opt.el index e8da847e184..9253f9a4a7d 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -132,7 +132,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 +237,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..27cd521e82e 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -309,7 +309,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 +325,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 @@ -386,7 +386,7 @@ 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)) @@ -407,6 +407,22 @@ 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 + (add-text-properties 0 (length string) + '(field command-output rear-nonsticky (field)) + 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..544a8a74039 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -362,9 +362,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..83dd5cb50f5 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." @@ -453,18 +460,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 +494,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; @@ -576,7 +589,7 @@ Possible variable references are: "Parse and return a list of index-lists. For example, \"[0 1][2]\" becomes: - ((\"0\" \"1\") (\"2\")." + ((\"0\" \"1\") (\"2\"))." (let (indices) (while (eq (char-after) ?\[) (let ((end (eshell-find-delimiter ?\[ ?\]))) @@ -594,8 +607,14 @@ For example, \"[0 1][2]\" becomes: (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'). @@ -752,12 +771,13 @@ For example, to retrieve the second element of a user's record in (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 "#" "@")) + (? (group (regexp eshell-variable-name-regexp))) + string-end) + arg) + (setq pcomplete-stub (substring arg (match-beginning 1))) (throw 'pcomplete-completions (eshell-variables-list))))) (defun eshell-variables-list () diff --git a/lisp/files.el b/lisp/files.el index 0d24852358e..9da82446112 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -6199,11 +6199,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)))))) @@ -6229,32 +6229,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. @@ -6347,6 +6342,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." @@ -7099,10 +7100,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))) @@ -7111,6 +7113,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. @@ -7656,7 +7669,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 @@ -7668,8 +7681,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/frame.el b/lisp/frame.el index af95a047c38..fa376788eb0 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1188,7 +1188,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)) @@ -1218,7 +1218,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)) @@ -1297,7 +1297,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) @@ -3105,6 +3105,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-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/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..be2bdc9bb15 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 () diff --git a/lisp/help-fns.el b/lisp/help-fns.el index a81051cee03..8bf8af73d30 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -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/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 29c39c5dd55..2372fd1ce09 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -444,7 +444,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 c561ea729af..50428c3a31a 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. @@ -283,7 +284,7 @@ VALUE is an integer representing BYTES characters." (defun exif--read-chunk (bytes) "Return BYTES octets from the buffer and advance point that much." (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))) @@ -292,7 +293,7 @@ VALUE is an integer representing BYTES characters." "Read BYTES octets from the buffer as a chunk of big-endian bytes. Advance point to after the read bytes." (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))) @@ -303,7 +304,7 @@ Advance point to after the read bytes." "Read BYTES octets from the buffer as a chunk of low-endian bytes. Advance point to after the read bytes." (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/ldefs-boot.el b/lisp/ldefs-boot.el index a463a7da67e..4d5921582cc 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 @@ -2938,10 +2938,6 @@ This mode is independent from the classic cc-mode.el based (autoload 'c++-ts-mode "c-ts-mode" "\ Major mode for editing C++, powered by tree-sitter. -This mode is independent from the classic cc-mode.el based -`c++-mode', so configuration variables of that mode, like -`c-basic-offset', don't affect this mode. - (fn)" t) (register-definition-prefixes "c-ts-mode" '("c-ts-mode-")) @@ -8222,6 +8218,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 @@ -8232,6 +8229,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). @@ -11284,8 +11282,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 @@ -23437,6 +23437,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-")) @@ -28288,29 +28293,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. +Automatically stop the Emacs server as specified by VALUE. +This sets the variable `server-stop-automatically' (which see). -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. - -This function is meant to be called from the user init file. - -(fn ARG)") +(fn VALUE)") (register-definition-prefixes "server" '("server-")) @@ -32647,7 +32640,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 "\ @@ -32669,7 +32662,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-")) @@ -32735,7 +32727,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-")) @@ -34491,7 +34483,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")) @@ -34760,7 +34752,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> @@ -34794,6 +34786,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) @@ -34817,6 +34814,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. @@ -34826,6 +34826,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. @@ -34849,17 +34860,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. @@ -34882,14 +34896,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: @@ -36008,6 +36025,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 @@ -36017,25 +36035,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/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/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/mouse.el b/lisp/mouse.el index d93594deb04..9c1a72bb368 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 @@ -1800,10 +1809,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/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/eww.el b/lisp/net/eww.el index 859a9b44bcb..73d11c0ef52 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -488,14 +488,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*") @@ -2498,10 +2501,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/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..10f33e5f929 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -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,14 +425,10 @@ 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." @@ -483,7 +466,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 @@ -563,8 +546,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 +561,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 +647,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 +714,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 +746,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 +922,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)) @@ -1106,11 +1079,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 +1101,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 +1115,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 +1139,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 +1228,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? @@ -1288,7 +1262,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..7c1f578d085 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) @@ -702,6 +670,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..6627ef47ee2 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -127,7 +127,7 @@ When called interactively, a Tramp connection has to be selected." (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 @@ -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))))) @@ -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..01f1c38988c 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,29 +275,6 @@ 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)))))) - (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -419,8 +289,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..1dd29190f10 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,6 +117,10 @@ "Tramp method name to use to connect to Kubernetes containers.") ;;;###tramp-autoload +(defconst tramp-toolbox-method "toolbox" + "Tramp method name to use to connect to Toolbox containers.") + +;;;###tramp-autoload (defun tramp-docker--completion-function (&rest _args) "List Docker-like containers available for connection. @@ -151,6 +176,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 (m) (list nil m)) (delq nil names)))) + +;;;###tramp-autoload (defvar tramp-default-remote-shell) ;; Silence byte compiler. ;;;###tramp-autoload @@ -167,6 +213,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 +226,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,6 +241,19 @@ 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 ""))) @@ -203,7 +264,11 @@ see its function help for a description of the format." (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..afd3166d161 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. @@ -497,7 +498,7 @@ directory. File names will be also encrypted." (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) + (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) @@ -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) @@ -756,9 +756,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 +767,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 +797,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..b846caadc18 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)) @@ -127,14 +125,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 +172,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 +202,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 +211,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..02ceb2979f7 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -414,7 +414,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 +716,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 +734,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 +744,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 +798,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. @@ -1139,25 +1140,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 +1167,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 +1184,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 +1219,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 +1229,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 +1278,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 @@ -1485,7 +1481,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (let* ((events (process-get proc 'events)) (rest-string (process-get proc 'rest-string)) (dd (tramp-get-default-directory (process-buffer proc))) - (ddu (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 +1500,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))) @@ -1536,7 +1532,7 @@ 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))) @@ -1560,27 +1556,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 +1603,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 +1613,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 +1696,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 +1716,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 +1745,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 +1992,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 +2037,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 +2080,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)))) @@ -2212,7 +2186,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 +2236,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 +2415,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))))) @@ -2506,12 +2480,8 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." 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. @@ -2564,7 +2534,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 () diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index cff0877555e..c7877c9824d 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -133,8 +133,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) + (mapconcat #'identity (butlast (exec-path)) path-separator) (getenv "PATH")))) (with-eval-after-load 'esh-util diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 2360abfb1dd..9eb2a54cdcf 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? diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index ec8437176db..25bc59eb4ff 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -411,7 +411,7 @@ The string is used in `tramp-methods'.") (add-to-list 'tramp-default-method-alist `(,tramp-local-host-regexp - ,(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) @@ -1086,6 +1086,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,121 +1132,55 @@ 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. @@ -1438,7 +1373,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 +1413,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 +1430,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 +1452,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 +1560,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))) ":" @@ -1744,7 +1673,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")) @@ -2357,7 +2286,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 +2318,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 +2365,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)) @@ -2557,19 +2486,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 +2504,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 +2621,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 +2740,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 +2766,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 +2776,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 +2877,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 +2887,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 @@ -3244,7 +3158,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)) @@ -3925,7 +3839,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,7 +3869,7 @@ 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))) @@ -4028,66 +3942,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)) @@ -4211,7 +4114,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 +4251,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 +4292,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 @@ -4430,7 +4331,7 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." (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 +4503,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 (string-empty-p tty) (process-put proc 'remote-tty tty) (tramp-set-connection-property proc "remote-tty" tty))) @@ -4817,7 +4718,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 +4804,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 +4815,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))) @@ -5175,7 +5076,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) @@ -5259,7 +5160,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 @@ -5403,7 +5304,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 +5312,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 +5352,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 +5449,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) @@ -5622,7 +5522,7 @@ Nonexistent directories are removed from spec." (tramp-get-method-parameter vec 'tramp-remote-shell-args) " ") (tramp-shell-quote-argument tramp-end-of-heredoc)) - 'noerror (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..a9cec17f536 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)))) @@ -695,31 +696,25 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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)))) @@ -1079,12 +1073,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 +1098,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 +1118,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 +1165,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 +1206,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 +1381,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)))) @@ -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)) @@ -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 diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 2d3c436632f..65c4bf23c38 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." @@ -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)) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 88dacdc7893..486a22a60e1 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,7 +450,7 @@ 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." @@ -466,7 +463,7 @@ the result will be a local, non-Tramp, file name." (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))))))) + 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." @@ -476,8 +473,8 @@ the result will be a local, non-Tramp, file name." (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))) + (if (tramp-string-empty-or-nil-p localname) + "" (file-name-unquote localname))) (mapcar (lambda (f) (if (file-directory-p (expand-file-name f directory)) @@ -500,7 +497,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 +505,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 +519,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 +542,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 +560,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 +582,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 +590,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 +627,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 +645,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) @@ -829,7 +753,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". diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 04b683a8a24..6dca53dcbcf 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -443,9 +443,7 @@ See `tramp-methods' for a list of possibilities for METHOD." (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 +523,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 +537,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,7 +638,7 @@ This regexp must match both `tramp-initial-end-of-output' and :type 'regexp) (defcustom tramp-password-prompt-regexp - (tramp-compat-rx + (rx bol (* nonl) (group (regexp (regexp-opt password-word-equivalents))) (* nonl) ":" (? "\^@") (* blank)) @@ -899,18 +897,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 +935,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 +947,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 +955,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 +965,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 +988,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 +1016,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 +1025,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 +1033,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 +1042,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 +1062,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 +1089,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 +1111,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 +1171,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 +1189,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 @@ -1402,20 +1393,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 @@ -1525,8 +1502,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)) @@ -1559,7 +1535,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) @@ -1597,7 +1573,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. @@ -1654,7 +1630,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 @@ -1666,7 +1642,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)))) @@ -1759,7 +1735,7 @@ 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. @@ -1772,14 +1748,18 @@ See `tramp-dissect-file-name' for details." (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) @@ -1824,23 +1804,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))) @@ -1855,8 +1835,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))))) @@ -1865,12 +1844,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 @@ -1965,9 +1944,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) @@ -1986,7 +1965,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'.") @@ -2400,7 +2379,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. @@ -2438,13 +2417,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: @@ -2552,7 +2530,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. @@ -2602,15 +2580,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. @@ -2653,12 +2629,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)) @@ -2837,7 +2813,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) @@ -2874,7 +2850,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 @@ -2972,10 +2948,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 @@ -2983,7 +2959,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)))) @@ -3076,14 +3052,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) @@ -3092,7 +3068,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) @@ -3101,7 +3077,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) @@ -3111,7 +3087,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) @@ -3122,7 +3098,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) @@ -3255,7 +3231,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) @@ -3271,8 +3247,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. @@ -3283,7 +3258,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)))) @@ -3308,15 +3283,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) @@ -3328,8 +3302,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) @@ -3348,7 +3321,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) @@ -3399,14 +3372,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) @@ -3433,15 +3405,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) @@ -3537,6 +3529,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}'. @@ -3703,6 +3788,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. + -1))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3761,7 +3855,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))) @@ -3792,7 +3886,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))) @@ -3807,12 +3902,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))))) @@ -3895,7 +3989,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 @@ -3958,7 +4052,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 @@ -3969,9 +4064,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. @@ -4002,18 +4095,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." @@ -4077,14 +4163,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 @@ -4094,31 +4174,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." @@ -4418,53 +4488,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." @@ -4625,9 +4691,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. @@ -4700,14 +4766,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)) @@ -4721,7 +4787,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)) @@ -4739,7 +4805,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)))))) @@ -4858,9 +4924,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 @@ -5062,19 +5127,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) @@ -5125,11 +5182,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))))))) @@ -5137,10 +5190,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)) @@ -5153,7 +5203,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)) @@ -5184,6 +5234,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) @@ -5195,7 +5251,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) @@ -5221,14 +5277,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) @@ -5425,7 +5480,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) @@ -5757,8 +5812,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) @@ -5943,9 +5997,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) @@ -5962,7 +6014,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) @@ -6293,7 +6345,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'. @@ -6322,7 +6374,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)) @@ -6351,6 +6403,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))) @@ -6371,7 +6424,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)) @@ -6383,6 +6436,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) @@ -6507,7 +6561,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) @@ -6557,7 +6611,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 @@ -6590,7 +6644,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 diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index fa4604103c5..9b271a7cfbd 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/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/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 788c911f86b..1f22a2b2a64 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -779,6 +779,37 @@ 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"))) + + (setq-local treesit-sexp-type-regexp + (regexp-opt '("preproc" + "declarator" + "qualifier" + "type" + "parameter" + "expression" + "literal" + "string"))) + ;; 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) @@ -864,15 +895,23 @@ in your configuration." :group 'c++ (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--set-indent-style 'cpp)) + ;; Font-lock. (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'cpp)) + (treesit-major-mode-setup))) ;; We could alternatively use parsers, but if this works well, I don't diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 2631c24f8db..f1e93c1c23c 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -8288,10 +8288,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 +8307,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 +8418,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 +8453,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 +8489,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 +8512,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 +8522,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 +8535,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. @@ -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 @@ -9072,6 +9130,7 @@ multi-line strings (but not C++, for example)." (when (looking-at c-no-type-key) (setq res 'no-id))) (goto-char (match-end 1)) + (setq pos (point)) (c-forward-syntactic-ws) (or (eq res 'no-id) (setq res 'prefix)))) @@ -9080,32 +9139,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 +9181,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 +9209,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 +9222,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,35 +9242,41 @@ 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. @@ -9213,13 +9288,11 @@ multi-line strings (but not C++, for example)." (cond ((eq name-res t) ;; A normal identifier. (goto-char id-end) + (setq pos (point)) (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 @@ -9233,6 +9306,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 +9332,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 +9343,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 +9373,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 +9410,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 @@ -9737,7 +9817,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 +9851,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 +9864,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 +9896,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) @@ -10569,11 +10655,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. @@ -10796,8 +10882,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" @@ -11121,8 +11206,7 @@ This function might do hidden buffer changes." (space-after-type (save-excursion (goto-char type-start) - (and (c-forward-type) - (progn (c-backward-syntactic-ws) t) + (and (c-forward-type nil t) (or (eolp) (memq (char-after) '(?\ ?\t))))))) (when (not (eq (not space-before-id) diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 852e893dc25..063cfffe1da 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -910,6 +910,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 2a295e885b0..23ac48a6117 100644 --- a/lisp/progmodes/dockerfile-ts-mode.el +++ b/lisp/progmodes/dockerfile-ts-mode.el @@ -155,6 +155,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/eglot.el b/lisp/progmodes/eglot.el index 3fc1d68422a..4fa886bc788 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -182,7 +182,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) diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 6f293acca5e..a352adbba19 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1635,6 +1635,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 +1693,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 8b157dd3333..2edaf9e2593 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1113,13 +1113,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.") @@ -4355,6 +4355,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.") @@ -4384,12 +4402,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." @@ -4403,6 +4418,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." @@ -4431,12 +4462,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 @@ -5124,6 +5157,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 5f3e1ea3e68..93a3bcc594b 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -176,9 +176,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 @@ -276,6 +283,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 "// " (treesit-defun-name defun-node)) + (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/gud.el b/lisp/progmodes/gud.el index 3b792354cbc..92e018aaec1 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -159,143 +159,96 @@ 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.") +(defvar-keymap gud-mode-map + ;; Will inherit from comint-mode via define-derived-mode. + :doc "`gud-mode' keymap.") -(setf (alist-get 'gud-minor-mode minor-mode-map-alist) - gud-minor-mode-map) +(defvar-keymap gud-minor-mode-map + :parent gud-mode-map) -(defvar gud-mode-map - ;; Will inherit from comint-mode via define-derived-mode. - (make-sparse-keymap) - "`gud-mode' keymap.") +(easy-menu-define gud-menu-map gud-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) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 30893638f0d..4405ce0fe04 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 8737472e514..dbd63698770 100644 --- a/lisp/progmodes/java-ts-mode.el +++ b/lisp/progmodes/java-ts-mode.el @@ -297,6 +297,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 treesit-simple-indent-rules java-ts-mode--indent-rules) @@ -317,6 +322,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 b5c912b8b0d..dca93c856fc 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3792,6 +3792,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. @@ -3808,6 +3856,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 "[]*". @@ -3826,6 +3879,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 f54d0187f98..6bd9d30328e 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/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/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el index 60215978176..1144caf79b6 100644 --- a/lisp/progmodes/ruby-ts-mode.el +++ b/lisp/progmodes/ruby-ts-mode.el @@ -1032,6 +1032,20 @@ leading double colon is not added." ;; Navigation. (setq-local treesit-defun-type-regexp ruby-ts--method-regex) + (setq-local treesit-sexp-type-regexp + (regexp-opt '("class" + "module" + "method" + "argument_list" + "array" + "hash" + "parenthesized_statements" + "if" + "case" + "block" + "do_block" + "begin"))) + ;; 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 4c06efc8146..17c22ff4751 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1623,6 +1623,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))) diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index 25cc327d05f..9c4f49efd5e 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -304,6 +304,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." @@ -312,6 +358,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 @@ -325,6 +376,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) @@ -386,6 +443,18 @@ Argument LANGUAGE is either `typescript' or `tsx'." (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..2989d7ddb61 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.") @@ -455,11 +455,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 +505,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 +685,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 +741,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 +755,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 +933,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 +1115,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 +1187,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 +1327,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 +1338,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 +1578,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 +2090,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 +2530,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 +2549,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 +2788,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 +2876,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 +3056,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 +3206,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 +3427,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 +3447,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 +3706,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 +3718,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 +3738,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 +3756,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 +3812,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 +3843,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 +3868,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 +3885,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 +3951,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 +3984,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 +4018,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 +4061,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 +4160,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 +4188,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 +4200,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 +4234,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 +4270,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 +4367,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 +4647,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 +4743,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 +4768,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 +4788,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 +4851,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 +4879,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 +4953,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 +4998,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 +5034,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 +5245,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 +5693,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 +5817,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 +5954,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 +6007,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 +6023,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 +6228,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 +6263,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 +6348,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 +6392,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 +6432,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 +6490,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 +6663,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 +6719,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 +6781,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 +6822,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 +6849,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 +6857,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 +6883,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 +6923,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 +6940,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 +6989,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 +7036,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 +7053,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 +7172,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 +7184,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 +7213,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 +7241,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 +7278,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 +7337,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 +7471,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 +7617,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 +7633,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 +7663,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 +7876,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 +7944,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 +7967,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 +7986,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 +8031,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 +8051,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 +8203,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 +8222,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 +9368,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 +10310,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 +10435,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 +10673,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 +10712,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 +10784,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 +11492,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 +11527,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 +12285,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 +12847,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 +15254,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 +15506,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 +15556,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 916d83d407b..4db0df6c3b8 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -568,7 +568,8 @@ This can be used from `xref-after-jump-hook', for instance.") (dolist (l (list (car history) (cdr history))) (dolist (m l) (set-marker m nil nil))) - (setq history (cons nil nil))) + (setcar history nil) + (setcdr history nil)) nil) ;;;###autoload 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/server.el b/lisp/server.el index eaf24a770e4..35b38ef8fa6 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) diff --git a/lisp/simple.el b/lisp/simple.el index aaad3217982..561c7b568ab 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2709,7 +2709,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! @@ -3852,16 +3861,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)) @@ -4723,6 +4730,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 @@ -6476,7 +6495,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. @@ -8495,6 +8514,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 @@ -8510,38 +8568,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. @@ -8566,13 +8593,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)) @@ -8599,6 +8628,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)) @@ -10108,8 +10139,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 diff --git a/lisp/startup.el b/lisp/startup.el index bb6250d3968..06783a77c1e 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -2921,7 +2921,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/subr.el b/lisp/subr.el index 0f754fcd31f..f909b63aabe 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -280,14 +280,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." @@ -380,9 +386,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. @@ -510,8 +531,9 @@ 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)))) (when (and (< value 0) (< count 0)) (when (< value most-negative-fixnum) (signal 'args-out-of-range (list value count))) @@ -3282,7 +3304,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: @@ -4851,6 +4873,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))))) @@ -4861,7 +4884,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. @@ -4942,21 +4968,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))))) @@ -6087,14 +6112,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 diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 119a243d6b3..9f53b649efd 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/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el new file mode 100644 index 00000000000..58dcc7d8cad --- /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") point-min 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 73abb155aaa..bf249fdcdfb 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))) @@ -480,6 +479,18 @@ sentences. Also, every paragraph boundary terminates sentences as well." (let ((npoint (constrain-to-field nil opoint t))) (not (= npoint opoint))))) +(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/transient.el b/lisp/transient.el index eb3c4ab6bca..42268aedab7 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -6,7 +6,7 @@ ;; URL: https://github.com/magit/transient ;; Keywords: extensions -;; Package-Version: 0.3.7 +;; Package-Version: 0.3.7.50 ;; Package-Requires: ((emacs "26.1")) ;; SPDX-License-Identifier: GPL-3.0-or-later @@ -2199,11 +2199,11 @@ value. Otherwise return CHILDREN as is." (delayed (if transient--exitp (apply-partially #'transient--post-exit this-command) #'transient--resume-override)) - post-command abort-minibuffer) + outside-interactive post-command abort-minibuffer) (unless abort-only (setq post-command (lambda () "@transient--delay-post-command" - (let ((act (and (not (eq (this-command-keys-vector) [])) + (let ((act (and (not (equal (this-command-keys-vector) [])) (or (eq this-command command) ;; `execute-extended-command' was ;; used to call another command @@ -2211,7 +2211,9 @@ value. Otherwise return CHILDREN as is." (equal (ignore-errors (string-to-multibyte (this-command-keys))) - (format "\M-x%s\r" this-command)))))) + (format "\M-x%s\r" this-command)) + ;; Minibuffer used outside `interactive'. + (and outside-interactive 'post-cmd))))) (transient--debug 'post-command-hook "act: %s" act) (when act (remove-hook 'transient--post-command-hook post-command) @@ -2220,12 +2222,15 @@ value. Otherwise return CHILDREN as is." (add-hook 'transient--post-command-hook post-command)) (setq abort-minibuffer (lambda () "@transient--delay-post-command" - (let ((act (and (or (memq this-command transient--abort-commands) - (equal (this-command-keys) "")) - (= (minibuffer-depth) depth)))) + (let ((act (and (= (minibuffer-depth) depth) + (or (memq this-command transient--abort-commands) + (equal (this-command-keys) "") + (prog1 nil + (setq outside-interactive t)))))) (transient--debug 'abort-minibuffer - "mini: %s|%s, act %s" (minibuffer-depth) depth act) + "mini: %s|%s, act: %s" (minibuffer-depth) depth + (or act (and outside-interactive '->post-cmd))) (when act (remove-hook 'transient--post-command-hook post-command) (remove-hook 'minibuffer-exit-hook abort-minibuffer) @@ -2236,7 +2241,7 @@ value. Otherwise return CHILDREN as is." (transient--debug 'post-command) (transient--with-emergency-exit (cond - ((and (eq (this-command-keys-vector) []) + ((and (equal (this-command-keys-vector) []) (= (minibuffer-depth) (1+ transient--minibuffer-depth))) (transient--suspend-override) @@ -2407,6 +2412,10 @@ If there is no parent prefix, then behave like `transient--do-exit'." (transient--stack-zap) transient--exit) +(defun transient--do-leave () + "Call the command without exporting variables and exit the transient." + transient--stay) + (defun transient--do-push-button () "Call the command represented by the activated button. Use that command's pre-command to determine transient behavior." @@ -3376,7 +3385,7 @@ have a history of their own.") (insert ?\n) (insert (propertize " " 'display `(space :align-to (,(nth (1+ c) cc))))))) - (insert (make-string (- (nth c cc) (current-column)) ?\s)) + (insert (make-string (max 1 (- (nth c cc) (current-column))) ?\s)) (when-let ((cell (nth r (nth c columns)))) (insert cell)) (when (= c (1- cs)) @@ -4119,7 +4128,10 @@ we stop there." 'face 'transient-value)) (cl-defmethod transient-prompt ((obj transient-lisp-variable)) - (format "Set %s: " (oref obj variable))) + (if (and (slot-boundp obj 'prompt) + (oref obj prompt)) + (cl-call-next-method obj) + (format "Set %s: " (oref obj variable)))) (defun transient-lisp-variable--reader (prompt initial-input _history) (read--expression prompt initial-input)) diff --git a/lisp/treesit.el b/lisp/treesit.el index 4c9bdfc0bd4..29b29d2665a 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -1639,6 +1639,47 @@ 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) + (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))) + +(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 @@ -1781,6 +1822,40 @@ this function depends on `treesit-defun-type-regexp' and (when treesit-defun-skipper (funcall treesit-defun-skipper)))) +(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 @@ -2243,6 +2318,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 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/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/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 a181765eac3..72160c35f57 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -3381,7 +3381,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) @@ -3422,6 +3422,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. @@ -3432,7 +3445,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) @@ -3478,11 +3491,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) @@ -3623,7 +3642,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 |