diff options
Diffstat (limited to 'lisp')
424 files changed, 16992 insertions, 17256 deletions
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 95cb6a97213..dc25645f5a3 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -540,20 +540,15 @@ check-defun-dups: # dependency in cc-*.elc files on the macros in other cc-*.el and the # version string in cc-defs.el. $(lisp)/progmodes/cc-align.elc\ - $(lisp)/progmodes/cc-cmds.elc $(lisp)/progmodes/cc-compat.elc\ - $(lisp)/progmodes/cc-engine.elc $(lisp)/progmodes/cc-fonts.elc\ - $(lisp)/progmodes/cc-langs.elc $(lisp)/progmodes/cc-menus.elc\ - $(lisp)/progmodes/cc-mode.elc $(lisp)/progmodes/cc-styles.elc\ - $(lisp)/progmodes/cc-vars.elc: \ + $(lisp)/progmodes/cc-cmds.elc $(lisp)/progmodes/cc-engine.elc \ + $(lisp)/progmodes/cc-fonts.elc $(lisp)/progmodes/cc-langs.elc \ + $(lisp)/progmodes/cc-menus.elc $(lisp)/progmodes/cc-mode.elc \ + $(lisp)/progmodes/cc-styles.elc $(lisp)/progmodes/cc-vars.elc: \ $(lisp)/progmodes/cc-bytecomp.elc $(lisp)/progmodes/cc-defs.elc $(lisp)/progmodes/cc-align.elc $(lisp)/progmodes/cc-cmds.elc: \ $(lisp)/progmodes/cc-vars.elc $(lisp)/progmodes/cc-engine.elc -$(lisp)/progmodes/cc-compat.elc: \ - $(lisp)/progmodes/cc-vars.elc $(lisp)/progmodes/cc-styles.elc \ - $(lisp)/progmodes/cc-engine.elc - $(lisp)/progmodes/cc-defs.elc: $(lisp)/progmodes/cc-bytecomp.elc $(lisp)/progmodes/cc-engine.elc: $(lisp)/progmodes/cc-langs.elc \ diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index 6808a68681a..df62bd9f54b 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -275,8 +275,8 @@ buffer rather than as a prevailing configuration (but it's handy to publicize it by making it a customization variable)." :version "24.1" :type 'boolean + :local t :group 'allout-widgets-developer) -(make-variable-buffer-local 'allout-widgets-track-decoration) ;;;_ : Mode context - variables, hookup, and hooks ;;;_ . internal mode variables diff --git a/lisp/allout.el b/lisp/allout.el index e3fe8d08841..e49bdfc9cd0 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -382,23 +382,23 @@ value that `normal-auto-fill-function', if any, when allout mode starts, or else allout's special hanging-indent maintaining auto-fill function, `allout-auto-fill'." :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-inhibit-auto-fill) ;;;_ = allout-inhibit-auto-fill-on-headline (defcustom allout-inhibit-auto-fill-on-headline nil "If non-nil, auto-fill will be inhibited while on topic's header line." :version "24.1" :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-inhibit-auto-fill-on-headline) ;;;_ = allout-use-hanging-indents (defcustom allout-use-hanging-indents t "If non-nil, topic body text auto-indent defaults to indent of the header. I.e., it is indented to be just past the header prefix. This is relevant mostly for situations where auto-fill occurs." :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-use-hanging-indents) ;;;###autoload (put 'allout-use-hanging-indents 'safe-local-variable #'booleanp) ;;;_ = allout-reindent-bodies @@ -414,9 +414,9 @@ A value of t enables reindent in non-programming-code buffers, ie those that do not have the variable `comment-start' set. A value of `force' enables reindent whether or not `comment-start' is set." :type '(choice (const nil) (const t) (const text) (const force)) + :local t :group 'allout) -(make-variable-buffer-local 'allout-reindent-bodies) ;;;###autoload (put 'allout-reindent-bodies 'safe-local-variable (lambda (x) (memq x '(nil t text force)))) @@ -425,8 +425,8 @@ those that do not have the variable `comment-start' set. A value of (defcustom allout-show-bodies nil "If non-nil, show entire body when exposing a topic, rather than just the header." :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-show-bodies) ;;;###autoload (put 'allout-show-bodies 'safe-local-variable #'booleanp) @@ -498,8 +498,8 @@ header prefix, which mostly have the value of this var at their front. Level 1 topics are exceptions. They consist of only a single character, which is typically set to the `allout-primary-bullet'." :type 'string + :local t :group 'allout) -(make-variable-buffer-local 'allout-header-prefix) ;;;###autoload (put 'allout-header-prefix 'safe-local-variable #'stringp) ;;;_ = allout-primary-bullet @@ -515,8 +515,8 @@ with the original Emacs outline mode. See `allout-plain-bullets-string' and `allout-distinctive-bullets-string' for the range of available bullets." :type 'string + :local t :group 'allout) -(make-variable-buffer-local 'allout-primary-bullet) ;;;###autoload (put 'allout-primary-bullet 'safe-local-variable #'stringp) ;;;_ = allout-plain-bullets-string @@ -531,8 +531,8 @@ DO NOT include the close-square-bracket, `]', as a bullet. Outline mode has to be reactivated in order for changes to the value of this var to take effect." :type 'string + :local t :group 'allout) -(make-variable-buffer-local 'allout-plain-bullets-string) ;;;###autoload (put 'allout-plain-bullets-string 'safe-local-variable #'stringp) ;;;_ = allout-distinctive-bullets-string @@ -579,8 +579,8 @@ adopt changes of this value. DO NOT include the close-square-bracket, `]', on either of the bullet strings." :type 'string + :local t :group 'allout) -(make-variable-buffer-local 'allout-distinctive-bullets-string) ;;;###autoload (put 'allout-distinctive-bullets-string 'safe-local-variable #'stringp) @@ -646,8 +646,8 @@ like the original Emacs-outline style prefixes. Whatever the setting of this variable, both old and new style prefixes are always respected by the topic maneuvering functions." :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-old-style-prefixes) ;;;###autoload (put 'allout-old-style-prefixes 'safe-local-variable #'booleanp) ;;;_ = allout-stylish-prefixes -- alternating bullets @@ -694,8 +694,8 @@ this variable setting. The setting of this var is not relevant when `allout-old-style-prefixes' is non-nil." :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-stylish-prefixes) ;;;###autoload (put 'allout-stylish-prefixes 'safe-local-variable #'booleanp) @@ -708,8 +708,8 @@ sequence-number tacked on, just after the bullet. Conventionally set to \"#\", you can set it to a bullet of your choice. A nil value disables numbering maintenance." :type '(choice (const nil) string) + :local t :group 'allout) -(make-variable-buffer-local 'allout-numbered-bullet) ;;;###autoload (put 'allout-numbered-bullet 'safe-local-variable #'string-or-null-p) ;;;_ = allout-file-xref-bullet @@ -725,9 +725,8 @@ Set this var to the bullet you want to use for file cross-references." (defcustom allout-presentation-padding 2 "Presentation-format white-space padding factor, for greater indent." :type 'integer + :local t :group 'allout) - -(make-variable-buffer-local 'allout-presentation-padding) ;;;###autoload (put 'allout-presentation-padding 'safe-local-variable #'integerp) @@ -809,11 +808,10 @@ text for editing though the file system copy is encrypted. \(Auto-saves are handled differently. Buffers with plain-text exposed encrypted topics are exempted from auto saves until all such topics are encrypted.)" - :type 'boolean + :local t :version "23.1" :group 'allout-encryption) -(make-variable-buffer-local 'allout-encrypt-unencrypted-on-saves) (defvar allout-auto-save-temporarily-disabled nil "Non-nil while topic encryption is pending and auto-saving was active. @@ -842,8 +840,8 @@ is nil. Operations potentially causing edits include allout encryption routines. For details, see `allout-toggle-current-subtree-encryption's docstring." :type 'boolean + :local t :group 'allout) -(make-variable-buffer-local 'allout-enable-file-variable-adjustment) ;;;_* CODE -- no user customizations below. diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index b492eb8f07c..4c0969492a0 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -532,7 +532,7 @@ This function can be added to `comint-preoutput-filter-functions'." (while (setq end (string-match ansi-color-control-seq-regexp string start)) (let ((esc-end (match-end 0))) ;; Colorize the old block from start to end using old face. - (when-let ((face (ansi-color--face-vec-face face-vec))) + (when-let* ((face (ansi-color--face-vec-face face-vec))) (put-text-property start end 'font-lock-face face string)) (push (substring string start end) result) @@ -550,7 +550,7 @@ This function can be added to `comint-preoutput-filter-functions'." (when (<= cur-pos esc-end) (string-to-number (match-string 1 string)))))))))) ;; if the rest of the string should have a face, put it there - (when-let ((face (ansi-color--face-vec-face face-vec))) + (when-let* ((face (ansi-color--face-vec-face face-vec))) (put-text-property start (length string) 'font-lock-face face string)) ;; save context, add the remainder of the string to the result @@ -597,7 +597,7 @@ code. It is usually stored as the car of the variable (bright (and ansi-color-bold-is-bright (aref basic-faces 1))) (faces nil)) - (when-let ((fg (car colors))) + (when-let* ((fg (car colors))) (push `(:foreground ,(or (ansi-color--code-as-hex fg) @@ -608,7 +608,7 @@ code. It is usually stored as the car of the variable (mod fg 8)) nil 'default))) faces)) - (when-let ((bg (cadr colors))) + (when-let* ((bg (cadr colors))) (push `(:background ,(or (ansi-color--code-as-hex bg) diff --git a/lisp/ansi-osc.el b/lisp/ansi-osc.el index 8dbaeb45132..6c647c879ad 100644 --- a/lisp/ansi-osc.el +++ b/lisp/ansi-osc.el @@ -84,7 +84,7 @@ located." pos1 (match-beginning 0)))) (setq ansi-osc--marker nil) (delete-region pos0 (point)) - (when-let ((fun (cdr (assoc-string code ansi-osc-handlers)))) + (when-let* ((fun (cdr (assoc-string code ansi-osc-handlers)))) (funcall fun code text))) (put-text-property pos0 end 'invisible t) (setq ansi-osc--marker (copy-marker pos0))))))) @@ -137,7 +137,7 @@ and `shell-dirtrack-mode'." (define-button-type 'ansi-osc-hyperlink 'keymap ansi-osc-hyperlink-map 'help-echo (lambda (_ buffer pos) - (when-let ((url (get-text-property pos 'browse-url-data buffer))) + (when-let* ((url (get-text-property pos 'browse-url-data buffer))) (format "mouse-2, C-c RET: Open %s" url)))) (defvar-local ansi-osc-hyperlink--state nil) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index bf9def681c3..978c07dfddc 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1075,7 +1075,7 @@ return nil. Otherwise point is returned." (while (and (not found) (not (eobp))) (forward-line 1) - (when-let ((descr (archive-get-descr t))) + (when-let* ((descr (archive-get-descr t))) (when (equal (archive--file-desc-ext-file-name descr) file) (setq found t)))) (if (not found) @@ -1097,7 +1097,7 @@ return nil. Otherwise point is returned." (beginning-of-line) (bobp))))) (archive-next-line n) - (when-let ((descr (archive-get-descr t))) + (when-let* ((descr (archive-get-descr t))) (let ((candidate (archive--file-desc-ext-file-name descr)) (buffer (current-buffer))) (when (and candidate diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el index 03fd1f35811..1a741a1b696 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -88,7 +88,7 @@ HOST, USER, PORT, REQUIRE, and MAX." (auth-source-pass-extra-query-keywords (auth-source-pass--build-result-many host port user require max)) (t - (when-let ((result (auth-source-pass--build-result host port user))) + (when-let* ((result (auth-source-pass--build-result host port user))) (list result))))) (defun auth-source-pass--build-result (hosts port user) @@ -195,10 +195,15 @@ See `auth-source-pass-get'." (defun auth-source-pass--read-entry (entry) "Return a string with the file content of ENTRY." (with-temp-buffer - (insert-file-contents (expand-file-name - (format "%s.gpg" entry) - auth-source-pass-filename)) - (buffer-substring-no-properties (point-min) (point-max)))) + ;; `file-name-handler-alist' could be nil, or miss the + ;; `epa-file-handler' entry. We ensure, that it does exist. + ;; (Bug#67937) + (let ((file-name-handler-alist + (cons epa-file-handler file-name-handler-alist))) + (insert-file-contents (expand-file-name + (format "%s.gpg" entry) + auth-source-pass-filename)) + (buffer-substring-no-properties (point-min) (point-max))))) (defun auth-source-pass-parse-entry (entry) "Return an alist of the data associated with ENTRY. @@ -220,7 +225,7 @@ CONTENTS is the contents of a password-store formatted file." (let ((lines (cdr (split-string contents "\n" t "[ \t]+")))) (seq-remove #'null (mapcar (lambda (line) - (when-let ((pos (seq-position line ?:))) + (when-let* ((pos (seq-position line ?:))) (cons (string-trim (substring line 0 pos)) (string-trim (substring line (1+ pos)))))) lines)))) @@ -271,11 +276,12 @@ HOSTS can be a string or a list of strings." n))) seen))) -(defun auth-source-pass--match-parts (parts key value require) - (let ((mv (plist-get parts key))) - (if (memq key require) - (and value (equal mv value)) - (or (not value) (not mv) (equal mv value))))) +(defun auth-source-pass--match-parts (cache key reference require) + (let ((value (plist-get cache key))) + (cond ((memq key require) + (if reference (equal value reference) value)) + ((and value reference) (equal value reference)) + (t)))) (defun auth-source-pass--find-match-many (hosts users ports require max) "Return plists for valid combinations of HOSTS, USERS, PORTS." @@ -296,11 +302,11 @@ HOSTS can be a string or a list of strings." ((equal host (plist-get m :host))) ((auth-source-pass--match-parts m :port port require)) ((auth-source-pass--match-parts m :user user require)) - (parsed (auth-source-pass-parse-entry e)) ;; For now, ignore body-content pairs, if any, ;; from `auth-source-pass--parse-data'. - (secret (or (auth-source-pass--get-attr 'secret parsed) - (not (memq :secret require))))) + (secret (let ((parsed (auth-source-pass-parse-entry e))) + (or (auth-source-pass--get-attr 'secret parsed) + (not (memq :secret require)))))) (push `( :host ,host ; prefer user-provided :host over h ,@(and-let* ((u (plist-get m :user))) (list :user u)) diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index f2631422c62..6b7dcad3899 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -166,18 +166,18 @@ If this contains a %s, that will be replaced by the matching rule." (replace-match (capitalize (user-login-name)) t t)) '(end-of-line 1) " <" (progn user-mail-address) ">\n") - (".dir-locals.el" + ((,(rx ".dir-locals" (? "-2") ".el") . "Directory Local Variables") nil ";;; Directory Local Variables -*- no-byte-compile: t; -*-\n" ";;; For more information see (info \"(emacs) Directory Variables\")\n\n" "((" - '(setq v1 (let (modes) + '(setq v1 (let ((modes '("nil"))) (mapatoms (lambda (mode) (let ((name (symbol-name mode))) (when (string-match "-mode\\'" name) (push name modes))))) (sort modes 'string<))) - (completing-read "Local variables for mode: " v1 nil t) + (completing-read "Local variables for mode: " v1 nil 'confirm) " . ((" (let ((all-variables (apropos-internal ".*" diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 0fdab6ffc9f..8ffe7f07cee 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -370,6 +370,9 @@ buffer.") "Non-nil when file has been modified on the file system. This has been reported by a file notification event.") +(defvar-local auto-revert--last-time 0 ;; Epoch. + "The last time of buffer was reverted.") + (defvar auto-revert-debug nil "Use for debug messages.") @@ -640,10 +643,10 @@ will use an up-to-date value of `auto-revert-interval'." (defun auto-revert-notify-rm-watch () "Disable file notification for current buffer's associated file." - (when-let ((desc - ;; Don't disable notifications if this is an indirect buffer. - (and (null (buffer-base-buffer)) - auto-revert-notify-watch-descriptor))) + (when-let* ((desc + ;; Don't disable notifications if this is an indirect buffer. + (and (null (buffer-base-buffer)) + auto-revert-notify-watch-descriptor))) (setq auto-revert--buffer-by-watch-descriptor (assoc-delete-all desc auto-revert--buffer-by-watch-descriptor)) (ignore-errors @@ -749,13 +752,16 @@ system.") ;; Mark buffer modified. (setq auto-revert-notify-modified-p t) - ;; Revert the buffer now if we're not locked out. + ;; Lock out the buffer. (unless auto-revert--lockout-timer - (auto-revert-handler) (setq auto-revert--lockout-timer (run-with-timer auto-revert--lockout-interval nil - #'auto-revert--end-lockout buffer)))))))))) + #'auto-revert--end-lockout buffer)) + ;; Revert it when first entry or it was reverted intervals ago. + (when (> (float-time (time-since auto-revert--last-time)) + auto-revert--lockout-interval) + (auto-revert-handler)))))))))) (defun auto-revert--end-lockout (buffer) "End the lockout period after a notification. @@ -801,7 +807,8 @@ This is an internal function used by Auto-Revert Mode." #'buffer-stale--default-function) t)))) eob eoblist) - (setq auto-revert-notify-modified-p nil) + (setq auto-revert-notify-modified-p nil + auto-revert--last-time (current-time)) (when revert (when (and auto-revert-verbose (not (eq revert 'fast))) diff --git a/lisp/bindings.el b/lisp/bindings.el index 6b34c5750c1..06a488fa9fa 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -1574,7 +1574,9 @@ if `inhibit-field-text-motion' is non-nil." "n" #'number-to-register "+" #'increment-register "w" #'window-configuration-to-register - "f" #'frameset-to-register) + "f" #'frameset-to-register + "F" #'file-to-register + "B" #'buffer-to-register) (define-key ctl-x-map "r" ctl-x-r-map) (define-key esc-map "q" 'fill-paragraph) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 223a7fedc8d..d43f9f740ca 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -1857,6 +1857,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." "a" #'bookmark-bmenu-show-annotation "A" #'bookmark-bmenu-show-all-annotations "e" #'bookmark-bmenu-edit-annotation + "J" #'bookmark-jump "/" #'bookmark-bmenu-search "<mouse-2>" #'bookmark-bmenu-other-window-with-mouse) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 9bd15dde59d..6c617566cd7 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -480,7 +480,7 @@ When called interactively prompt for MARK; RET remove all marks." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (when-let ((entry (tabulated-list-get-entry))) + (when-let* ((entry (tabulated-list-get-entry))) (let ((xmarks (list (aref entry 0) (aref entry 2)))) (when (or (char-equal mark ?\r) (member (char-to-string mark) xmarks)) @@ -891,7 +891,7 @@ See more at `Buffer-menu-filter-predicate'." (declare-function project-root "project" (project)) (defun Buffer-menu-group-by-root (entry) (with-current-buffer (car entry) - (if-let ((project (project-current))) + (if-let* ((project (project-current))) (project-root project) default-directory))) diff --git a/lisp/button.el b/lisp/button.el index c0584729172..1a732bee98b 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -80,8 +80,15 @@ Mode-specific keymaps may want to use this as their parent keymap." "<touchscreen-down>" #'push-button) (define-minor-mode button-mode - "A minor mode for navigating to buttons with the TAB key." - :keymap button-buffer-map) + "A minor mode for navigating to buttons with the TAB key. + +Disabling the mode will remove all buttons in the current buffer." + :keymap button-buffer-map + (when (not button-mode) + (save-excursion + (save-restriction + (widen) + (unbuttonize-region (point-min) (point-max)))))) ;; Default properties for buttons. (put 'default-button 'face 'button) @@ -663,10 +670,22 @@ itself will be used instead as the function argument. If HELP-ECHO, use that as the `help-echo' property. -Also see `buttonize'." +Also see `buttonize' and `unbuttonize-region'." (add-text-properties start end (button--properties callback data help-echo)) (add-face-text-property start end 'button t)) +(defun unbuttonize-region (start end) + "Remove all the buttons between START and END. +This removes both text-property and overlay based buttons." + (dolist (o (overlays-in start end)) + (when (overlay-get o 'button) + (delete-overlay o))) + (with-silent-modifications + (remove-text-properties start end + (button--properties nil nil nil)) + (add-face-text-property start end + 'button nil))) + (provide 'button) ;;; button.el ends here diff --git a/lisp/calculator.el b/lisp/calculator.el index ef1e6d8dbc3..0764a16370c 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -775,7 +775,7 @@ Defaults to 1." (or (nth 4 op) 1)) (defun calculator-add-operators (more-ops) - "This function handles operator addition. + "Handle operator addition. Adds MORE-OPS to `calculator-operator', called initially to handle `calculator-initial-operators' and `calculator-user-operators'." (let ((added-ops nil)) @@ -1059,49 +1059,50 @@ the `left' or `right' when one of the standard modes is used." (defun calculator-update-display (&optional force) "Update the display. If optional argument FORCE is non-nil, don't use the cached string." - (set-buffer calculator-buffer) - ;; update calculator-stack-display - (when (or force (not (eq (car calculator-stack-display) - calculator-stack))) - (setq calculator-stack-display - (cons calculator-stack - (if calculator-stack - (concat - (let ((calculator-displayer - (if (and calculator-displayers - (= 1 (length calculator-stack))) - ;; customizable display for a single value - (caar calculator-displayers) - calculator-displayer))) - (mapconcat 'calculator-number-to-string - (reverse calculator-stack) - " ")) - " " - (and calculator-display-fragile - calculator-saved-list - ;; Hack: use `eq' to compare the number: it's a - ;; flonum, so `eq' means that its the actual - ;; number rather than a computation that had an - ;; equal result (eg, enter 1,3,2, use "v" to see - ;; the average -- it now shows "2" instead of - ;; "2 [3]"). - (eq (car calculator-stack) - (nth calculator-saved-ptr - calculator-saved-list)) - (if (= 0 calculator-saved-ptr) - (format "[%s]" (length calculator-saved-list)) - (format "[%s/%s]" - (- (length calculator-saved-list) - calculator-saved-ptr) - (length calculator-saved-list))))) - "")))) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (calculator-get-display))) - (set-buffer-modified-p nil) - (goto-char (if calculator-display-fragile - (1+ (length calculator-prompt)) - (1- (point))))) + (when (buffer-live-p calculator-buffer) + (set-buffer calculator-buffer) + ;; update calculator-stack-display + (when (or force (not (eq (car calculator-stack-display) + calculator-stack))) + (setq calculator-stack-display + (cons calculator-stack + (if calculator-stack + (concat + (let ((calculator-displayer + (if (and calculator-displayers + (= 1 (length calculator-stack))) + ;; customizable display for a single value + (caar calculator-displayers) + calculator-displayer))) + (mapconcat 'calculator-number-to-string + (reverse calculator-stack) + " ")) + " " + (and calculator-display-fragile + calculator-saved-list + ;; Hack: use `eq' to compare the number: it's a + ;; flonum, so `eq' means that its the actual + ;; number rather than a computation that had an + ;; equal result (eg, enter 1,3,2, use "v" to see + ;; the average -- it now shows "2" instead of + ;; "2 [3]"). + (eq (car calculator-stack) + (nth calculator-saved-ptr + calculator-saved-list)) + (if (= 0 calculator-saved-ptr) + (format "[%s]" (length calculator-saved-list)) + (format "[%s/%s]" + (- (length calculator-saved-list) + calculator-saved-ptr) + (length calculator-saved-list))))) + "")))) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (calculator-get-display))) + (set-buffer-modified-p nil) + (goto-char (if calculator-display-fragile + (1+ (length calculator-prompt)) + (1- (point)))))) ;;;--------------------------------------------------------------------- ;;; Stack computations @@ -1553,17 +1554,18 @@ a multiplication." (defun calculator-quit () "Quit calculator." (interactive) - (set-buffer calculator-buffer) - (let ((inhibit-read-only t)) (erase-buffer)) - (unless calculator-electric-mode - (ignore-errors - (while (get-buffer-window calculator-buffer) - (delete-window (get-buffer-window calculator-buffer))))) - (kill-buffer calculator-buffer) - (message "Calculator done.") - (if calculator-electric-mode - (throw 'calculator-done nil) ; will kill the buffer - (setq calculator-buffer nil))) + (when (buffer-live-p calculator-buffer) + (set-buffer calculator-buffer) + (let ((inhibit-read-only t)) (erase-buffer)) + (unless calculator-electric-mode + (ignore-errors + (while (get-buffer-window calculator-buffer) + (delete-window (get-buffer-window calculator-buffer))))) + (kill-buffer calculator-buffer) + (message "Calculator done.") + (if calculator-electric-mode + (throw 'calculator-done nil) ; will kill the buffer + (setq calculator-buffer nil)))) (defun calculator-save-and-quit () "Quit the calculator, saving the result on the `kill-ring'." diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index bb319d54c8c..9da2602cca8 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -127,6 +127,9 @@ or \"2024-04-05T14:30Z\" or \"2024-04-05T12:30−02:00\", but shorter, incomplete strings like \"2008-03-02\" are valid, as well as variants like \"2008W32\" (week number) and \"2008-234\" (ordinal day number). +Values returned are identical to those of `decode-time', except +that an unknown DST value is -1 and other unknown values are nil. + Note that, unlike `decode-time', this function does not interpret the time string, and in particular the time-zone designator or UTC offset that is part of STRING does not affect the returned value of diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index f6fc7a8c162..e6d8b672413 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -214,7 +214,7 @@ This function is like `parse-time-string' except that it returns a Lisp timestamp when successful. See `decode-time' for the meaning of FORM." - (when-let ((time (parse-time-string date-string form))) + (when-let* ((time (parse-time-string date-string form))) (encode-time time))) (provide 'parse-time) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index eca80f1e8b6..9a2fb45e3bc 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -145,30 +145,24 @@ it is assumed that PICO was omitted and should be treated as zero." (autoload 'timezone-make-date-arpa-standard "timezone") ;;;###autoload -;; `parse-time-string' isn't sufficiently general or robust. It fails -;; to grok some of the formats that timezone does (e.g. dodgy -;; post-2000 stuff from some Elms) and either fails or returns bogus -;; values. timezone-make-date-arpa-standard should help. (defun date-to-time (date) "Parse a string DATE that represents a date-time and return a time value. DATE should be in one of the forms recognized by `parse-time-string'. -If DATE lacks timezone information, GMT is assumed." +If DATE lacks time zone information, local time is assumed." (condition-case err + ;; Parse DATE. If it contains a year, use defaults for other components. + ;; Then encode the result; this signals an error if the year is missing, + ;; because encode-time signals if crucial time components are nil. + ;; This heuristic uses local time if the string lacks time zone info, + ;; because encode-time treats a nil time zone as local time. (let ((parsed (parse-time-string date))) (when (decoded-time-year parsed) (decoded-time-set-defaults parsed)) (encode-time parsed)) (error - (let ((overflow-error '(error "Specified time is not representable"))) - (if (equal err overflow-error) - (signal (car err) (cdr err)) - (condition-case err - (encode-time (parse-time-string - (timezone-make-date-arpa-standard date))) - (error - (if (equal err overflow-error) - (signal (car err) (cdr err)) - (error "Invalid date: %s" date))))))))) + (if (equal err '(error "Specified time is not representable")) + (signal (car err) (cdr err)) + (error "Invalid date: %s" date))))) ;;;###autoload (defalias 'time-to-seconds #'float-time) diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index d9f6a40865a..235e09d83c2 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -158,7 +158,7 @@ Optional argument FACE specifies the face to do the highlighting." (face-background 'pulse-highlight-face nil 'default))) (stop (color-name-to-rgb (face-background 'default))) (colors (mapcar (apply-partially 'apply 'color-rgb-to-hex) - (color-gradient start stop pulse-iterations)))) + (cons start (color-gradient start stop (1- pulse-iterations)))))) (setq pulse-momentary-timer (run-with-timer 0 pulse-delay #'pulse-tick colors @@ -167,7 +167,7 @@ Optional argument FACE specifies the face to do the highlighting." (defun pulse-tick (colors stop-time) (if (time-less-p nil stop-time) - (when-let (color (elt colors pulse-momentary-iteration)) + (when-let* ((color (elt colors pulse-momentary-iteration))) (set-face-background 'pulse-highlight-face color) (setq pulse-momentary-iteration (1+ pulse-momentary-iteration))) (pulse-momentary-unhighlight))) diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 586cb1cf23b..f980e52c315 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -166,9 +166,8 @@ the following keys: in `semanticdb-project-system-databases'. The Emacs Lisp system DB is an omniscience database." :group 'semanticdb - :type semanticdb-find-throttle-custom-list) - -(make-variable-buffer-local 'semanticdb-find-default-throttle) + :type semanticdb-find-throttle-custom-list + :local t) (defun semanticdb-find-throttle-active-p (access-type) "Non-nil if ACCESS-TYPE is an active throttle type." diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el index e13eec209ed..6043e096a0a 100644 --- a/lisp/cedet/semantic/imenu.el +++ b/lisp/cedet/semantic/imenu.el @@ -60,14 +60,14 @@ (defcustom semantic-imenu-summary-function 'semantic-format-tag-abbreviate "Function to use when creating items in Imenu. Some useful functions are found in `semantic-format-tag-functions'." - :type semantic-format-tag-custom-list) -(make-variable-buffer-local 'semantic-imenu-summary-function) + :type semantic-format-tag-custom-list + :local t) ;;;###autoload (defcustom semantic-imenu-bucketize-file t "Non-nil if tags in a file are to be grouped into buckets." - :type 'boolean) -(make-variable-buffer-local 'semantic-imenu-bucketize-file) + :type 'boolean + :local t) (defcustom semantic-imenu-adopt-external-members t "Non-nil if types in a file should adopt externally defined members. @@ -78,21 +78,21 @@ definition." (defcustom semantic-imenu-buckets-to-submenu t "Non-nil if buckets of tags are to be turned into submenus. This option is ignored if `semantic-imenu-bucketize-file' is nil." - :type 'boolean) -(make-variable-buffer-local 'semantic-imenu-buckets-to-submenu) + :type 'boolean + :local t) ;;;###autoload (defcustom semantic-imenu-expand-type-members t "Non-nil if types should have submenus with members in them." - :type 'boolean) -(make-variable-buffer-local 'semantic-imenu-expand-type-members) + :type 'boolean + :local t) (defcustom semantic-imenu-bucketize-type-members t "Non-nil if members of a type should be grouped into buckets. A nil value means to keep them in the same order. Overridden to nil if `semantic-imenu-bucketize-file' is nil." - :type 'boolean) -(make-variable-buffer-local 'semantic-imenu-bucketize-type-members) + :type 'boolean + :local t) (defcustom semantic-imenu-sort-bucket-function nil "Function to use when sorting tags in the buckets of functions. @@ -107,8 +107,8 @@ on this function." (const semantic-sort-tags-by-name-decreasing-ci) (const semantic-sort-tags-by-type-increasing-ci) (const semantic-sort-tags-by-type-decreasing-ci) - (function))) -(make-variable-buffer-local 'semantic-imenu-sort-bucket-function) + (function)) + :local t) (defcustom semantic-imenu-index-directory nil "Non-nil to index the entire directory for tags. diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el index aec251a0dc6..94d91105fda 100644 --- a/lisp/cedet/semantic/senator.el +++ b/lisp/cedet/semantic/senator.el @@ -85,8 +85,8 @@ tag, where possible." (defcustom senator-highlight-found nil "If non-nil, Senator commands momentarily highlight found tags." - :type 'boolean) -(make-variable-buffer-local 'senator-highlight-found) + :type 'boolean + :local t) ;;; Faces (defface senator-momentary-highlight-face diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el index 5c487a7f44d..a9148bd80ed 100644 --- a/lisp/cedet/semantic/symref.el +++ b/lisp/cedet/semantic/symref.el @@ -81,8 +81,8 @@ The tool symbol can be `detect', or a symbol that is the name of a tool that can be used for symbol referencing." :type 'symbol + :local t :group 'semantic) -(make-variable-buffer-local 'semantic-symref-tool) ;;; TOOL SETUP ;; diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index d4316fb1175..b03cf1f1840 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -238,8 +238,8 @@ is run). (inferior-scheme-mode))) (setq scheme-program-name cmd) (setq scheme-buffer "*scheme*") - (with-suppressed-warnings ((obsolete display-comint-buffer-action)) - (pop-to-buffer "*scheme*" display-comint-buffer-action))) + (pop-to-buffer "*scheme*" (append display-buffer--same-window-action + '((category . comint))))) (defun scheme-start-file (prog) "Return the name of the start file corresponding to PROG. @@ -359,8 +359,8 @@ With argument, position cursor at end of buffer." (interactive "P") (if (or (and scheme-buffer (get-buffer scheme-buffer)) (scheme-interactively-start-process)) - (with-suppressed-warnings ((obsolete display-comint-buffer-action)) - (pop-to-buffer scheme-buffer display-comint-buffer-action)) + (pop-to-buffer scheme-buffer (append display-buffer--same-window-action + '((category . comint)))) (error "No current process buffer. See variable `scheme-buffer'")) (when eob-p (push-mark) diff --git a/lisp/color.el b/lisp/color.el index 79dced4e3d7..cdeaa97ee64 100644 --- a/lisp/color.el +++ b/lisp/color.el @@ -55,6 +55,7 @@ If FRAME cannot display COLOR, return nil." (let ((valmax (float (car (color-values "#ffffffffffff"))))) (mapcar (lambda (x) (/ x valmax)) (color-values color frame)))) +;;;###autoload (defun color-rgb-to-hex (red green blue &optional digits-per-component) "Return hexadecimal #RGB notation for the color specified by RED GREEN BLUE. RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive. @@ -75,6 +76,23 @@ components (e.g. \"#ffff1212ecec\")." (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color))))) +;;;###autoload +(defun color-blend (a b &optional alpha) + "Blend the two colors A and B in linear space with ALPHA. +A and B should be lists (RED GREEN BLUE), where each element is +between 0.0 and 1.0, inclusive. ALPHA controls the influence A +has on the result and should be between 0.0 and 1.0, inclusive. + +For instance: + + (color-blend \\='(1 0.5 1) \\='(0 0 0) 0.75) + => (0.75 0.375 0.75)" + (setq alpha (or alpha 0.5)) + (let (blend) + (dotimes (i 3) + (push (+ (* (nth i a) alpha) (* (nth i b) (- 1 alpha))) blend)) + (nreverse blend))) + (defun color-gradient (start stop step-number) "Return a list with STEP-NUMBER colors from START to STOP. The color list builds a color gradient starting at color START to @@ -446,7 +464,11 @@ See `color-desaturate-hsl'." Given a color defined in terms of hue, saturation, and luminance \(arguments H, S, and L), return a color that is PERCENT lighter. Returns a list (HUE SATURATION LUMINANCE)." - (list H S (color-clamp (+ L (* L (/ percent 100.0)))))) + (let ((p (/ percent 100.0))) + (if (> p 0.0) + (setq L (* L (- 1.0 p))) + (setq p (- (* L (abs p))))) + (list H S (color-clamp (+ L p))))) (defun color-lighten-name (name percent) "Make a color with a specified NAME lighter by PERCENT. diff --git a/lisp/comint.el b/lisp/comint.el index d52090911b9..6423e695430 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -404,7 +404,7 @@ This variable is buffer-local." (regexp-opt '("Enter" "enter" "Enter same" "enter same" "Enter the" "enter the" "Current" - "Enter Auth" "enter auth" "Old" "old" "New" "new" "'s" "login" + "Enter Auth" "enter auth" "Old" "old" "New" "new" "login" "Kerberos" "CVS" "UNIX" " SMB" "LDAP" "PEM" "SUDO" "[sudo]" "doas" "Repeat" "Bad" "Retype" "Verify") t) @@ -418,11 +418,13 @@ This variable is buffer-local." ;; The ccrypt encryption dialog doesn't end with a colon, so ;; treat it specially. "\\|^Enter encryption key: (repeat) *\\'" + ;; Default openssh format: "user@host's password:". + "\\|^[^@ \t\n]+@[^@ \t\n]+'s password: *\\'" ;; openssh-8.6p1 format: "(user@host) Password:". "\\|^([^)@ \t\n]+@[^)@ \t\n]+) Password: *\\'") "Regexp matching prompts for passwords in the inferior process. This is used by `comint-watch-for-password-prompt'." - :version "29.1" + :version "31.1" :type 'regexp :group 'comint) @@ -1056,6 +1058,7 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." (ring-size (min 1500 comint-input-ring-size)) (ring (make-ring ring-size)) ;; Use possibly buffer-local values of these variables. + (ring-max-size comint-input-ring-size) (ring-separator comint-input-ring-separator) (ring-file-prefix comint-input-ring-file-prefix) (history-ignore comint-input-history-ignore) @@ -1066,7 +1069,7 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." ;; Watch for those date stamps in history files! (goto-char (point-max)) (let (start end history) - (while (and (< count comint-input-ring-size) + (while (and (< count ring-max-size) (re-search-backward ring-separator nil t) (setq end (match-beginning 0))) (goto-char (if (re-search-backward ring-separator nil t) @@ -1084,7 +1087,7 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." (not (string-equal (ring-ref ring 0) history)))) (when (= count ring-size) - (ring-extend ring (min (- comint-input-ring-size ring-size) + (ring-extend ring (min (- ring-max-size ring-size) ring-size)) (setq ring-size (ring-size ring))) (ring-insert-at-beginning ring history) @@ -2568,12 +2571,14 @@ to detect the need to (prompt and) send a password. Ignores any carriage returns (\\r) in STRING. This function could be in the list `comint-output-filter-functions'." - (let ((string (string-limit string comint-password-prompt-max-length t)) + (let ((string (string-limit + (string-replace "\r" "" string) + comint-password-prompt-max-length t)) prompt) (when (let ((case-fold-search t)) - (string-match comint-password-prompt-regexp - (string-replace "\r" "" string))) - (setq prompt (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+")) + (string-match comint-password-prompt-regexp string)) + (setq prompt (string-trim (match-string 0 string) + "[ \n\r\t\v\f\b\a]+" "\n+")) ;; Use `run-at-time' in order not to pause execution of the ;; process filter with a minibuffer (run-at-time @@ -4109,7 +4114,7 @@ setting." (font-lock-flush)) (defun comint--fontify-input-ppss-flush-indirect (beg &rest rest) - (when-let ((buf (comint-indirect-buffer t))) + (when-let* ((buf (comint-indirect-buffer t))) (with-current-buffer buf (when (memq #'syntax-ppss-flush-cache before-change-functions) (apply #'syntax-ppss-flush-cache beg rest))))) @@ -4168,7 +4173,7 @@ function called, or nil, if no function was called (if BEG = END)." (text-property-not-all beg1 end 'field 'output) (text-property-any beg1 end 'field 'output)) end)) - (when-let ((fun (if is-output fun-output fun-input))) + (when-let* ((fun (if is-output fun-output fun-input))) (save-restriction (let ((beg2 beg1) (end2 end1)) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index caebb9d01e3..0fae7e94fdb 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -49,6 +49,29 @@ ;; prefix (so nothing is underlined in the preview), it displays a list ;; of all matching completion candidates. ;; +;; You can also insert only the first word of the completion candidate +;; with the command `completion-preview-insert-word'. With a numeric +;; prefix argument, it inserts that many words instead of just the one. +;; This command is not bound by default, but you may want to bind it to +;; M-f (or remap `forward-word') in `completion-preview-active-mode-map' +;; since it's very much like a `forward-word' that also moves "into" the +;; completion preview. To define your own command that inserts part of +;; a completion candidate by moving "into" the completion preview, use +;; the function `completion-preview-partial-insert'. For example, you +;; can define a command that completes exactly one symbol as follows: +;; +;; (defun my-completion-preview-insert-symbol () +;; (interactive) +;; (completion-preview-partial-insert #'forward-symbol 1)) +;; +;; Similarly to `completion-preview-insert-word', the command +;; `completion-preview-insert-sexp' lets you complete by one or more +;; balanced expressions. The definition of this command is very similar +;; to the simple example above, expect it uses `forward-sexp' rather +;; than `forward-symbol'. This command can be useful when you're using +;; Completion Preview mode with long, complex completion candidates, +;; such as entire shell commands from the shell history. +;; ;; If you set the user option `completion-preview-exact-match-only' to ;; non-nil, Completion Preview mode only suggests a completion ;; candidate when its the only possible completion for the (partial) @@ -65,6 +88,26 @@ ;; `completion-preview-idle-delay' to have the preview appear only ;; when you pause typing for a short duration rather than after every ;; key. Try setting it to 0.2 seconds and see how that works for you. +;; +;; Sometimes you may want to use Completion Preview mode alongside other +;; Emacs features that place an overlay after point, in a way that could +;; "compete" with the preview overlay. In such cases, you should give +;; the completion preview overlay a higher priority, so it properly +;; appears immediately after point, before other overlays. To do that, +;; set the variable `completion-preview-overlay-priority'. You can set +;; it buffer-locally if you only use competing overlays in some buffers. +;; In particular, an important use case for this variable is enabling +;; Completion Preview mode for `M-:' and other minibuffers that support +;; `completion-at-point'. In the minibuffer, some message are displayed +;; using an overlay that may, by default, conflict with the completion +;; preview overlay. Use `completion-preview-overlay-priority' to +;; resolve this conflict by giving the completion preview overlay a +;; higher priority: +;; +;; (add-hook 'eval-expression-minibuffer-setup-hook +;; (lambda () +;; (setq-local completion-preview-overlay-priority 1200) +;; (completion-preview-mode))) ;;; Code: @@ -90,7 +133,9 @@ first candidate, and you can cycle between the candidates with delete-backward-char backward-delete-char-untabify analyze-text-conversion - completion-preview-complete) + completion-preview-complete + completion-preview-insert-word + completion-preview-insert-sexp) "List of commands that should trigger completion preview." :type '(repeat (function :tag "Command" :value self-insert-command)) :version "30.1") @@ -128,6 +173,24 @@ If this is nil, display the completion preview without delay." (const :tag "No delay" nil)) :version "30.1") +(defcustom completion-preview-ignore-case nil + "Whether Completion Preview mode ignores case differences. + +By default this option is nil, which says that case is significant, so a +completion candidate \"FooBar\" matches prefix \"Foo\", but not \"foo\". +If you set it to non-nil, then Completion Preview mode also suggests +completions that differ in case from the prefix that you type; for +example, it may suggest completing \"foo\" with the suffix \"Bar\" when +there's an available completion candidate \"FooBar\". Note that in this +case, when you insert the completion (with `completion-preview-insert'), +Completion Preview mode does not update the completed prefix according +to the capitalization of the completion candidate, instead it simply +ignores such case differences, so the resulting string is \"fooBar\". + +See also `completion-ignore-case'." + :type 'boolean + :version "31.1") + (defvar completion-preview-sort-function #'minibuffer--sort-by-length-alpha "Sort function to use for choosing a completion candidate to preview.") @@ -163,6 +226,8 @@ If this is nil, display the completion preview without delay." "M-i" #'completion-preview-complete ;; "M-n" #'completion-preview-next-candidate ;; "M-p" #'completion-preview-prev-candidate + ;; "<remap> <forward-word>" #'completion-preview-insert-word + ;; "<remap> <forward-sexp>" #'completion-preview-insert-sexp ) (defun completion-preview--ignore () @@ -225,11 +290,16 @@ Completion Preview mode avoids updating the preview after these commands.") (setq completion-preview--overlay nil completion-preview--inhibit-update-p nil))) +(defvar completion-preview-overlay-priority nil + "Value of the `priority' property for the completion preview overlay.") + (defun completion-preview--make-overlay (pos string) "Make preview overlay showing STRING at POS, or move existing preview there." (if completion-preview--overlay (move-overlay completion-preview--overlay pos pos) (setq completion-preview--overlay (make-overlay pos pos)) + (overlay-put completion-preview--overlay 'priority + completion-preview-overlay-priority) (overlay-put completion-preview--overlay 'window (selected-window))) (add-text-properties 0 1 '(cursor 1) string) (overlay-put completion-preview--overlay 'after-string string) @@ -252,8 +322,15 @@ Completion Preview mode adds this function to "Mode for when the completion preview is shown." :interactive nil (if completion-preview-active-mode - (add-hook 'window-selection-change-functions - #'completion-preview--window-selection-change nil t) + (progn + (add-hook 'window-selection-change-functions + #'completion-preview--window-selection-change nil t) + ;; Give keymap precedence over other minor mode maps. + ;; TODO: Use explicit minor mode precedence instead when + ;; implemented (bug#74492). + (setf (alist-get 'completion-preview-active-mode + minor-mode-overriding-map-alist) + completion-preview-active-mode-map)) (remove-hook 'window-selection-change-functions #'completion-preview--window-selection-change t) (completion-preview-hide))) @@ -293,6 +370,7 @@ candidates or if there are multiple matching completions and ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((pred (plist-get props :predicate)) (string (buffer-substring beg end)) + (completion-ignore-case completion-preview-ignore-case) (md (completion-metadata string table pred)) (sort-fn (or (completion-metadata-get md 'cycle-sort-function) (completion-metadata-get md 'display-sort-function) @@ -309,11 +387,11 @@ candidates or if there are multiple matching completions and (prefix (substring string base))) (when last (setcdr last nil) - (when-let ((sorted (funcall sort-fn - (delete prefix (all-completions prefix all)))) - (common (try-completion prefix sorted)) - (lencom (length common)) - (suffixes sorted)) + (when-let* ((sorted (funcall sort-fn + (delete prefix (all-completions prefix all)))) + (common (try-completion prefix sorted)) + (lencom (length common)) + (suffixes sorted)) (unless (and (cdr suffixes) completion-preview-exact-match-only) ;; Remove the common prefix from each candidate. (while sorted @@ -327,8 +405,8 @@ candidates or if there are multiple matching completions and (and (consp res) (not (functionp res)) (seq-let (beg end table &rest plist) res - (or (when-let ((data (completion-preview--try-table - table beg end plist))) + (or (when-let* ((data (completion-preview--try-table + table beg end plist))) `(,(+ beg (length (car data))) ,end ,plist ,@data)) (unless (eq 'no (plist-get plist :exclusive)) ;; Return non-nil to exclude other capfs. @@ -340,7 +418,7 @@ candidates or if there are multiple matching completions and (run-hook-wrapped 'completion-at-point-functions #'completion-preview--capf-wrapper) - (when-let ((suffix (car suffixes))) + (when-let* ((suffix (car suffixes))) (set-text-properties 0 (length suffix) (list 'face (if (cdr suffixes) 'completion-preview @@ -440,28 +518,107 @@ point, otherwise hide it." ;; preview, don't do anything. (unless internal-p (if (and (completion-preview-require-certain-commands) - (completion-preview-require-minimum-symbol-length)) + (completion-preview-require-minimum-symbol-length) + (not buffer-read-only)) (completion-preview--show) (completion-preview-active-mode -1))))) +(defun completion-preview--barf-if-no-preview () + "Signal a `user-error' if completion preview is not active." + (unless completion-preview-active-mode + (user-error "No current completion preview"))) + (defun completion-preview-insert () "Insert the completion candidate that the preview is showing." (interactive) - (if completion-preview-active-mode + (completion-preview--barf-if-no-preview) + (let* ((pre (completion-preview--get 'completion-preview-base)) + (end (completion-preview--get 'completion-preview-end)) + (ind (completion-preview--get 'completion-preview-index)) + (all (completion-preview--get 'completion-preview-suffixes)) + (com (completion-preview--get 'completion-preview-common)) + (efn (plist-get (completion-preview--get 'completion-preview-props) + :exit-function)) + (aft (completion-preview--get 'after-string)) + (str (concat pre com (nth ind all)))) + (completion-preview-active-mode -1) + (goto-char end) + (insert-and-inherit (substring-no-properties aft)) + (when (functionp efn) (funcall efn str 'finished)))) + +(defun completion-preview-partial-insert (fun &rest args) + "Insert part of the current completion preview candidate. + +This function calls FUN with arguments ARGS, after temporarily inserting +the entire current completion preview candidate. FUN should move point: +if it moves point forward into the completion text, this function +inserts the prefix of the completion candidate up to that point. +Beyond moving point, FUN should not modify the current buffer." + (completion-preview--barf-if-no-preview) + (let* ((end (completion-preview--get 'completion-preview-end)) + (aft (completion-preview--get 'after-string)) + (eoc (+ end (length aft)))) + ;; Keep region active, if it is already. This lets commands that + ;; call this function interact correctly with `shift-select-mode'. + (let ((deactivate-mark nil)) + ;; Partially insert current completion candidate. + (catch 'abort-atomic-change + (atomic-change-group + (let ((change-group (prepare-change-group))) + (save-excursion + (goto-char end) + ;; Temporarily insert the full completion candidate. + (insert-and-inherit (substring-no-properties aft))) + ;; Set point to the end of the prefix that we want to keep. + (apply fun args) + (unless (< end (point)) + ;; Point didn't advance into the completion, so abort change + ;; to avoid littering `buffer-undo-list' with a nop entry. + (throw 'abort-atomic-change nil)) + ;; Delete the rest. + (delete-region (min (point) eoc) eoc) + ;; Combine into one change group. + (undo-amalgamate-change-group change-group))))) + ;; Cleanup. + (cond + ;; If we kept the entire completion candidate, call :exit-function. + ((<= eoc (point)) (let* ((pre (completion-preview--get 'completion-preview-base)) - (end (completion-preview--get 'completion-preview-end)) (ind (completion-preview--get 'completion-preview-index)) (all (completion-preview--get 'completion-preview-suffixes)) (com (completion-preview--get 'completion-preview-common)) - (efn (plist-get (completion-preview--get 'completion-preview-props) - :exit-function)) - (aft (completion-preview--get 'after-string)) - (str (concat pre com (nth ind all)))) + (efn (plist-get + (completion-preview--get 'completion-preview-props) + :exit-function))) (completion-preview-active-mode -1) - (goto-char end) - (insert (substring-no-properties aft)) - (when (functionp efn) (funcall efn str 'finished))) - (user-error "No current completion preview"))) + (when (functionp efn) (funcall efn (concat pre com (nth ind all)) + 'finished)))) + ;; If we kept anything, update preview overlay accordingly. + ((< end (point)) + (completion-preview--inhibit-update) + (overlay-put (completion-preview--make-overlay + (point) + (propertize + (substring aft (- (point) end)) + 'mouse-face 'completion-preview-highlight + 'keymap completion-preview--mouse-map)) + 'completion-preview-end (point))) + ;; If we kept nothing, do nothing. + ))) + +(defun completion-preview-insert-word (&optional n) + "Insert the first N words of the current completion preview candidate. + +Interactively, N is the numeric prefix argument, and it defaults to 1." + (interactive "^p") + (completion-preview-partial-insert #'forward-word n)) + +(defun completion-preview-insert-sexp (&optional n) + "Insert the first N s-expressions of the current completion preview candidate. + +Interactively, N is the numeric prefix argument, and it defaults to 1." + (interactive "^p") + (completion-preview-partial-insert #'forward-sexp n 'interactive)) (defun completion-preview-complete () "Complete up to the longest common prefix of all completion candidates. @@ -472,8 +629,7 @@ candidates unless `completion-auto-help' is nil. If you repeat this command again when the completions list is visible, it scrolls the completions list." (interactive) - (unless completion-preview-active-mode - (user-error "No current completion preview")) + (completion-preview--barf-if-no-preview) (let* ((beg (completion-preview--get 'completion-preview-beg)) (end (completion-preview--get 'completion-preview-end)) (com (completion-preview--get 'completion-preview-common)) @@ -512,7 +668,7 @@ completions list." (completion-preview--inhibit-update) (completion-at-point)) ;; Otherwise, insert the common prefix and update the preview. - (insert ins) + (insert-and-inherit ins) (let ((suf (nth cur all)) (pos (point))) (if (or (string-empty-p suf) (null suf)) @@ -578,15 +734,21 @@ prefix argument and defaults to 1." (message (format-spec completion-preview-message-format `((?i . ,(1+ new)) (?n . ,len)))))))) -(defun completion-preview--active-p (_symbol buffer) - "Check if the completion preview is currently shown in BUFFER." +(defun completion-preview-active-p (_symbol buffer) + "Check if the completion preview is currently shown in BUFFER. + +The first argument, SYMBOL, is ignored. You can use this function as +the `completion-predicate' property of commands that you define that +should only be available when the completion preview is active." (buffer-local-value 'completion-preview-active-mode buffer)) (dolist (cmd '(completion-preview-insert + completion-preview-insert-word + completion-preview-insert-sexp completion-preview-complete completion-preview-prev-candidate completion-preview-next-candidate)) - (put cmd 'completion-predicate #'completion-preview--active-p)) + (put cmd 'completion-predicate #'completion-preview-active-p)) ;;;###autoload (define-minor-mode completion-preview-mode diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index de7c3ea7cb6..12d9315c52b 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -175,16 +175,9 @@ "Support for editing files." :group 'emacs) -(defgroup wp nil - "Support for editing text files. -Use group `text' for this instead. This group is obsolete." - :group 'emacs) - (defgroup text nil "Support for editing text files." - :group 'emacs - ;; Inherit from deprecated `wp' for compatibility, for now. - :group 'wp) + :group 'emacs) (defgroup data nil "Support for editing binary data files." @@ -1082,9 +1075,10 @@ even if it doesn't match the type.) (defun setopt--set (variable value) (custom-load-symbol variable) ;; Check that the type is correct. - (when-let ((type (get variable 'custom-type))) + (when-let* ((type (get variable 'custom-type))) (unless (widget-apply (widget-convert type) :match value) - (warn "Value `%S' does not match type %s" value type))) + (warn "Value `%S' for variable `%s' does not match its type \"%s\"" + value variable type))) (put variable 'custom-check-value (list value)) (funcall (or (get variable 'custom-set) #'set-default) variable value)) @@ -1285,7 +1279,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 "29.4" +(defvar customize-changed-options-previous-release "30.1" "Version for `customize-changed' to refer back to by default.") ;; Packages will update this variable, so make it available. @@ -3431,6 +3425,28 @@ to switch between two values." ;;; The `custom-face-edit' Widget. +(defvar custom-face--font-cache-timeout 60 + "Refresh the cache of font families after at most this many seconds.") + +(defalias 'custom-face--font-completion + (let ((lastlist nil) + (lasttime nil) + (lastframe nil)) + (completion-table-case-fold + (completion-table-dynamic + (lambda (_string) + ;; Flush the cache timeout after a while. + (let ((time (float-time))) + (if (and lastlist (eq (selected-frame) lastframe) + (> custom-face--font-cache-timeout (- time lasttime))) + lastlist + ;; (message "last list time: %s" (if lasttime (- time lasttime))) + (setq lasttime time) + (setq lastframe (selected-frame)) + (setq lastlist + (nconc (mapcar #'car face-font-family-alternatives) + (font-family-list)))))))))) + (define-widget 'custom-face-edit 'checklist "Widget for editing face attributes. The following properties have special meanings for this widget: @@ -5933,7 +5949,7 @@ The appropriate types are: (defun custom-dirlocals-maybe-update-cons () "If focusing out from the first widget in a cons widget, update its value." - (when-let ((w (widget-at))) + (when-let* ((w (widget-at))) (when (widget-get w :custom-dirlocals-symbol) (widget-value-set (widget-get w :parent) (cons (widget-value w) "")) @@ -6024,7 +6040,7 @@ Moves point into the widget that holds the value." If at least an option doesn't validate, signals an error and moves point to the widget with the invalid value." (dolist (opt (custom-dirlocals-get-options)) - (when-let ((w (widget-apply opt :validate))) + (when-let* ((w (widget-apply opt :validate))) (goto-char (widget-get w :from)) (error "%s" (widget-get w :error)))) t) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index d0a1a66e29f..478092c30cb 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -48,7 +48,8 @@ (defconst custom-face-attributes `((:family (string :tag "Font Family" - :help-echo "Font family or fontset alias name.")) + :completions custom-face--font-completion + :help-echo "Font family or fontset alias name (with completion).")) (:foundry (string :tag "Font Foundry" diff --git a/lisp/custom.el b/lisp/custom.el index c049e8f8be0..63d2eea4d94 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -204,7 +204,7 @@ set to nil, as the value is no longer rogue." ((eq keyword :local) (when (memq value '(t permanent)) (setq buffer-local t)) - (when (eq value 'permanent) + (when (memq value '(permanent permanent-only)) (put symbol 'permanent-local t))) ((eq keyword :type) (put symbol 'custom-type (purecopy value))) @@ -300,6 +300,8 @@ The following keywords are meaningful: :local If VALUE is t, mark SYMBOL as automatically buffer-local. If VALUE is `permanent', also set SYMBOL's `permanent-local' property to t. + If VALUE is `permanent-only', set SYMBOL's `permanent-local' + property to t, but do not mark it as automatically buffer-local. The following common keywords are also meaningful. @@ -461,10 +463,10 @@ Each DISPLAY can have the following values: `display-supports-face-attributes-p' for more information on exactly how testing is done. -In the ATTS property list, possible attributes are `:family', -`:width', `:height', `:weight', `:slant', `:underline', -`:overline', `:strike-through', `:box', `:foreground', -`:background', `:stipple', `:inverse-video', and `:inherit'. +In the ATTS property list, possible attributes are `:family', `:font', +`:foundry', `:width', `:height', `:weight', `:slant', `:underline', +`:overline', `:strike-through', `:box', `:foreground', `:distant-foreground', +`:background', `:stipple', `:inverse-video', `:extend', and `:inherit'. See Info node `(elisp) Faces' in the Emacs Lisp manual for more information." @@ -977,7 +979,7 @@ Also change :reverse-video to :inverse-video." (when (listp spec) (if (or (memq :bold spec) (memq :italic spec) - (memq :inverse-video spec)) + (memq :reverse-video spec)) (let (result) (while spec (let ((key (car spec)) @@ -1360,7 +1362,7 @@ Return t if THEME was successfully loaded, nil otherwise." t)))) (t (error "Unable to load theme `%s'" theme)))) - (when-let ((obs (get theme 'byte-obsolete-info))) + (when-let* ((obs (get theme 'byte-obsolete-info))) (display-warning 'initialization (format "The `%s' theme is obsolete%s" theme diff --git a/lisp/delsel.el b/lisp/delsel.el index df99a56d7bc..18d889ab4c8 100644 --- a/lisp/delsel.el +++ b/lisp/delsel.el @@ -95,6 +95,24 @@ information on adapting behavior of commands in Delete Selection mode." (remove-hook 'pre-command-hook 'delete-selection-pre-hook) (add-hook 'pre-command-hook 'delete-selection-pre-hook))) +;;;###autoload +(define-minor-mode delete-selection-local-mode + "Toggle `delete-selection-mode' only in this buffer. + +For compatibility with features and packages that are aware of +`delete-selection-mode', this local mode sets the variable +`delete-selection-mode' in the current buffer as needed." + :global nil :group 'editing-basics + :variable (buffer-local-value 'delete-selection-mode (current-buffer)) + (cond + ((eq delete-selection-mode (default-value 'delete-selection-mode)) + (kill-local-variable 'delete-selection-mode)) + ((not (default-value 'delete-selection-mode)) + ;; Locally enabled, but globally disabled. + (delete-selection-mode 1) ; Setup the hooks. + (setq-default delete-selection-mode nil) ; But keep it globally disabled. + ))) + (defvar delsel--replace-text-or-position nil) ;;;###autoload diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 524a6474cd4..1f8b79f5258 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -673,10 +673,10 @@ The character information includes: (if display (format "terminal code %s" display) "not encodable for terminal")))))) - ,@(when-let ((composition-name - (and composition-string - (eq (aref char-script-table char) 'emoji) - (emoji-describe composition-string)))) + ,@(when-let* ((composition-name + (and composition-string + (eq (aref char-script-table char) 'emoji) + (emoji-describe composition-string)))) (list (list "composition name" composition-name))) ,@(let ((face (if (not (or disp-vector composition)) diff --git a/lisp/desktop.el b/lisp/desktop.el index 06f0bbb946e..3ca684efb49 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -699,7 +699,7 @@ DIRNAME omitted or nil means use `desktop-dirname'." (defun desktop--emacs-pid-running-p (pid) "Return non-nil if an Emacs process whose ID is PID might still be running." - (when-let ((attr (process-attributes pid))) + (when-let* ((attr (process-attributes pid))) (let ((proc-cmd (alist-get 'comm attr)) (my-cmd (file-name-nondirectory (car command-line-args))) (case-fold-search t)) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index e06e36aaa75..3390f9b83d1 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1440,7 +1440,7 @@ This excludes `dired-guess-shell-alist-user' and ((executable-find "run-mailcap") "run-mailcap")) "A shell command to open a file externally." - :type 'string + :type '(choice (const :tag "None" nil) string) :group 'dired :version "30.1") @@ -1451,39 +1451,48 @@ This excludes `dired-guess-shell-alist-user' and (declare-function w32-shell-execute "w32fns.c") ;;;###autoload -(defun dired-do-open (&optional arg) - "Open all marked (or next ARG) files using an external program. +(defun shell-command-do-open (files) + "Open each of FILES using an external program. This \"opens\" the file(s) using the external command that is most -appropriate for the file(s) according to the system conventions. -If files are marked, run the command on each marked file. Otherwise, -run it on the next ARG files, or on the file at mouse-click, or on the -file at point. The appropriate command to \"open\" a file on each -system is determined by `shell-command-guess-open'." - (interactive "P" dired-mode) - (let ((files (if (mouse-event-p last-nonmenu-event) - (save-excursion - (mouse-set-point last-nonmenu-event) - (dired-get-marked-files nil arg)) - (dired-get-marked-files nil arg))) - (command shell-command-guess-open)) +appropriate for the file(s) according to the system conventions." + (let ((command shell-command-guess-open)) (when (and (memq system-type '(windows-nt)) (equal command "start")) (setq command "open")) - (when command - (dolist (file files) + (if command (cond - ((memq system-type '(gnu/linux)) - (call-process command nil 0 nil file)) ((memq system-type '(ms-dos)) - (shell-command (concat command " " (shell-quote-argument file)))) + (dolist (file files) + (shell-command (concat command " " (shell-quote-argument file))))) ((memq system-type '(windows-nt)) - (w32-shell-execute command (convert-standard-filename file))) + (dolist (file files) + (w32-shell-execute command (convert-standard-filename file)))) ((memq system-type '(cygwin)) - (call-process command nil nil nil file)) + (dolist (file files) + (call-process command nil nil nil file))) ((memq system-type '(darwin)) - (start-process (concat command " " file) nil command file)) + (dolist (file files) + (start-process (concat command " " file) nil command file))) (t - (error "Open not supported on this system"))))))) + (dolist (file files) + (call-process command nil 0 nil file)))) + (error "Open not supported on this system")))) + +;;;###autoload +(defun dired-do-open (&optional arg) + "Open all marked (or next ARG) files using an external program. +This \"opens\" the file(s) using the external command that is most +appropriate for the file(s) according to the system conventions. +If files are marked, run the command on each marked file. Otherwise, +run it on the next ARG files, or on the file at mouse-click, or on the +file at point. The appropriate command to \"open\" a file on each +system is determined by `shell-command-guess-open'." + (interactive "P" dired-mode) + (shell-command-do-open (if (mouse-event-p last-nonmenu-event) + (save-excursion + (mouse-set-point last-nonmenu-event) + (dired-get-marked-files nil arg)) + (dired-get-marked-files nil arg)))) ;;; Commands that delete or redisplay part of the dired buffer @@ -3803,7 +3812,7 @@ resume the query replace with the command \\[fileloop-continue]." (interactive (let ((common (query-replace-read-args - "Query replace regexp in marked files" t t))) + "Query replace regexp in marked files" t t t))) (list (nth 0 common) (nth 1 common) (nth 2 common))) dired-mode) (dolist (file (dired-get-marked-files nil nil #'dired-nondirectory-p nil t)) @@ -3827,7 +3836,7 @@ you can later apply as a patch after reviewing the changes." (interactive (let ((common (query-replace-read-args - "Replace regexp as diff in marked files" t t))) + "Replace regexp as diff in marked files" t t t))) (list (nth 0 common) (nth 1 common) (nth 2 common)))) (dired-post-do-command) (multi-file-replace-regexp-as-diff @@ -3903,7 +3912,7 @@ function works." (interactive (let ((common (query-replace-read-args - "Query replace regexp in marked files" t t))) + "Query replace regexp in marked files" t t t))) (list (nth 0 common) (nth 1 common))) dired-mode) (require 'xref) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 98cf09945da..1b78b2e2925 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -218,7 +218,7 @@ toggle between those two." ;;; Menu bindings -(when-let ((menu (lookup-key dired-mode-map [menu-bar]))) +(when-let* ((menu (lookup-key dired-mode-map [menu-bar]))) (easy-menu-add-item menu '("Operate") ["Find Files" dired-do-find-marked-files :help "Find current or marked files"] diff --git a/lisp/dired.el b/lisp/dired.el index 0d526dfc376..f79a2220bea 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -387,6 +387,12 @@ new Dired buffers." :version "24.4" :group 'dired) +(defcustom dired-hide-details-hide-absolute-location nil + "Non-nil means `dired-hide-details-mode' hides directory absolute location." + :type 'boolean + :version "31.1" + :group 'dired) + (defcustom dired-always-read-filesystem nil "Non-nil means revert buffers visiting files before searching them. By default, commands like `dired-mark-files-containing-regexp' will @@ -738,6 +744,13 @@ Subexpression 2 must end right before the \\n.") ;;; Font-lock +(defcustom dired-check-symlinks t + "Whether symlinks are checked for validity. +Set it to nil for remote directories, which suffer from a slow connection." + :type 'boolean + :group 'dired + :version "31.1") + (defvar dired-font-lock-keywords (list ;; @@ -815,11 +828,13 @@ Subexpression 2 must end right before the \\n.") ;; Broken Symbolic link. (list dired-re-sym (list (lambda (end) - (let* ((file (dired-file-name-at-point)) - (truename (ignore-errors (file-truename file)))) - ;; either not existent target or circular link - (and (not (and truename (file-exists-p truename))) - (search-forward-regexp "\\(.+\\) \\(->\\) ?\\(.+\\)" end t)))) + (when (connection-local-value dired-check-symlinks) + (let* ((file (dired-file-name-at-point)) + (truename (ignore-errors (file-truename file)))) + ;; either not existent target or circular link + (and (not (and truename (file-exists-p truename))) + (search-forward-regexp + "\\(.+\\) \\(->\\) ?\\(.+\\)" end t))))) '(dired-move-to-filename) nil '(1 'dired-broken-symlink) @@ -829,24 +844,29 @@ Subexpression 2 must end right before the \\n.") ;; Symbolic link to a directory. (list dired-re-sym (list (lambda (end) - (when-let* ((file (dired-file-name-at-point)) - (truename (ignore-errors (file-truename file)))) - (and (file-directory-p truename) - (search-forward-regexp "\\(.+-> ?\\)\\(.+\\)" end t)))) + (when (connection-local-value dired-check-symlinks) + (when-let* ((file (dired-file-name-at-point)) + (truename (ignore-errors (file-truename file)))) + (and (file-directory-p truename) + (search-forward-regexp + "\\(.+-> ?\\)\\(.+\\)" end t))))) '(dired-move-to-filename) nil '(1 dired-symlink-face) '(2 `(face ,dired-directory-face dired-symlink-filename t)))) ;; - ;; Symbolic link to a non-directory. + ;; Symbolic link to a non-directory. Or no check at all. (list dired-re-sym (list (lambda (end) - (when-let ((file (dired-file-name-at-point))) - (let ((truename (ignore-errors (file-truename file)))) - (and (or (not truename) - (not (file-directory-p truename))) - (search-forward-regexp "\\(.+-> ?\\)\\(.+\\)" - end t))))) + (if (not (connection-local-value dired-check-symlinks)) + (search-forward-regexp + "\\(.+-> ?\\)\\(.+\\)" end t) + (when-let* ((file (dired-file-name-at-point))) + (let ((truename (ignore-errors (file-truename file)))) + (and (or (not truename) + (not (file-directory-p truename))) + (search-forward-regexp + "\\(.+-> ?\\)\\(.+\\)" end t)))))) '(dired-move-to-filename) nil '(1 dired-symlink-face) @@ -1721,11 +1741,11 @@ see `dired-use-ls-dired' for more details.") (executable-find "sh"))) (switch (if remotep "-c" shell-command-switch))) ;; Enable globstar - (when-let ((globstar dired-maybe-use-globstar) - (enable-it - (assoc-default - (file-truename sh) dired-enable-globstar-in-shell - (lambda (reg shell) (string-match reg shell))))) + (when-let* ((globstar dired-maybe-use-globstar) + (enable-it + (assoc-default + (file-truename sh) dired-enable-globstar-in-shell + (lambda (reg shell) (string-match reg shell))))) (setq script (format "%s; %s" enable-it script))) (unless (zerop @@ -1802,12 +1822,25 @@ see `dired-use-ls-dired' for more details.") (when (and (or hdr wildcard) (not (and (looking-at "^ \\(.*\\):$") (file-name-absolute-p (match-string 1))))) - ;; Note that dired-build-subdir-alist will replace the name - ;; by its expansion, so it does not matter whether what we insert - ;; here is fully expanded, but it should be absolute. - (insert " " (or (car-safe dir-wildcard) - (directory-file-name (file-name-directory dir))) - ":\n") + (let* ((dir-indent " ") + (dir-name (or (car-safe dir-wildcard) + (directory-file-name + (file-name-directory dir)))) + (dir-name-point (+ (point) (length dir-indent))) + (hideable-location + (and dired-hide-details-hide-absolute-location + (not (string-empty-p (file-name-nondirectory + dir-name)))))) + ;; Inserted directory name must be absolute, but keep in + ;; mind it may be replaced in some instances like in + ;; `dired-build-subdir-alist'. + (insert dir-indent dir-name ":\n") + (when hideable-location + (put-text-property + dir-name-point + (+ dir-name-point + (length (file-name-directory dir-name))) + 'invisible 'dired-hide-details-absolute-location))) (setq content-point (point))) (when wildcard ;; Insert "wildcard" line where "total" line would be for a full dir. @@ -1830,7 +1863,7 @@ see `dired-use-ls-dired' for more details.") ;; Replace "total" with "total used in directory" to ;; avoid confusion. (replace-match "total used in directory" nil nil nil 1)) - (if-let ((available (get-free-disk-space file))) + (if-let* ((available (get-free-disk-space file))) (cond ((eq dired-free-space 'separate) (end-of-line) @@ -2770,7 +2803,7 @@ Keybindings: (let ((point (window-point w))) (save-excursion (goto-char point) - (if-let ((f (dired-get-filename nil t))) + (if-let* ((f (dired-get-filename nil t))) `((dired-filename . ,f)) `((position . ,(point))))))))) (setq-local window-point-context-use-function @@ -2778,9 +2811,9 @@ Keybindings: (with-current-buffer (window-buffer w) (let ((point (window-point w))) (save-excursion - (if-let ((f (alist-get 'dired-filename context))) + (if-let* ((f (alist-get 'dired-filename context))) (dired-goto-file f) - (when-let ((p (alist-get 'position context))) + (when-let* ((p (alist-get 'position context))) (goto-char p))) (setq point (point))) (set-window-point w point))))) @@ -3243,8 +3276,9 @@ unchanged." When this minor mode is enabled, details such as file ownership and permissions are hidden from view. -See options: `dired-hide-details-hide-symlink-targets' and -`dired-hide-details-hide-information-lines'." +See options: `dired-hide-details-hide-symlink-targets', +`dired-hide-details-hide-information-lines' and +`dired-hide-details-hide-absolute-location'." :group 'dired (unless (derived-mode-p '(dired-mode wdired-mode)) (error "Not a Dired buffer")) @@ -3269,6 +3303,11 @@ See options: `dired-hide-details-hide-symlink-targets' and 'remove-from-invisibility-spec) 'dired-hide-details-information) (funcall (if (and dired-hide-details-mode + dired-hide-details-hide-absolute-location) + #'add-to-invisibility-spec + #'remove-from-invisibility-spec) + 'dired-hide-details-absolute-location) + (funcall (if (and dired-hide-details-mode dired-hide-details-hide-symlink-targets (not (derived-mode-p 'wdired-mode))) 'add-to-invisibility-spec @@ -3674,7 +3713,18 @@ instead of `dired-actual-switches'." (substring new-dir-name (match-end 0))) (expand-file-name new-dir-name)))) (delete-region (point) (match-end 1)) - (insert new-dir-name)) + (let ((new-dir-name-pos (point)) + (hideable-location + (and dired-hide-details-hide-absolute-location + (not (string-empty-p + (file-name-nondirectory new-dir-name)))))) + (insert new-dir-name) + (when hideable-location + (put-text-property + new-dir-name-pos + (+ new-dir-name-pos + (length (file-name-directory new-dir-name))) + 'invisible 'dired-hide-details-absolute-location)))) (setq count (1+ count)) ;; Undo any escaping of newlines and \ by dired-insert-directory. ;; Convert "n" preceded by odd number of \ to newline, and \\ to \. diff --git a/lisp/dirtrack.el b/lisp/dirtrack.el index 07e176b8eea..8e9181f1379 100644 --- a/lisp/dirtrack.el +++ b/lisp/dirtrack.el @@ -126,10 +126,9 @@ First item is a regexp that describes where to find the path in a prompt. Second is a number, the regexp group to match." :type '(sexp (regexp :tag "Prompt Expression") (integer :tag "Regexp Group")) + :local t :version "24.1") -(make-variable-buffer-local 'dirtrack-list) - (defcustom dirtrack-debug nil "If non-nil, the function `dirtrack' will report debugging info." :type 'boolean) diff --git a/lisp/dnd.el b/lisp/dnd.el index 411f0d5774c..bf8d3908619 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -270,8 +270,8 @@ for it will be modified." ;; assigned their own handlers. (dolist (leftover urls) (setq return-value 'private) - (if-let ((handler (browse-url-select-handler leftover - 'internal))) + (if-let* ((handler (browse-url-select-handler leftover + 'internal))) (funcall handler leftover action) (dnd-insert-text window action leftover))) (or return-value 'private)))) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 993a880f34f..4d7d36c8a16 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -27,8 +27,10 @@ ;; `pdftotext', which comes with xpdf (https://www.foolabs.com/xpdf/) ;; or poppler (https://poppler.freedesktop.org/). EPUB, CBZ, FB2, XPS ;; and OXPS documents require `mutool' which comes with mupdf -;; (https://mupdf.com/index.html). Djvu documents require `ddjvu' +;; (https://mupdf.com/index.html). DjVu documents require `ddjvu' ;; (from DjVuLibre). ODF files require `soffice' (from LibreOffice). +;; `djvused' (from DjVuLibre) can be optionally used to generate imenu +;; outline for DjVu documents when available. ;;; Commentary: @@ -185,13 +187,13 @@ are available (see Info node `(emacs)Document View')." (defcustom doc-view-pdfdraw-program (cond + ((executable-find "mutool") "mutool") ((executable-find "pdfdraw") "pdfdraw") ((executable-find "mudraw") "mudraw") - ((executable-find "mutool") "mutool") (t "mudraw")) "Name of MuPDF's program to convert PDF files to PNG." :type 'file - :version "24.4") + :version "31.1") (defcustom doc-view-pdftotext-program-args '("-raw") "Parameters to give to the pdftotext command." @@ -216,10 +218,23 @@ are available (see Info node `(emacs)Document View')." :type 'boolean :version "30.1") -(defcustom doc-view-imenu-enabled (and (executable-find "mutool") t) - "Whether to generate an imenu outline when \"mutool\" is available." +(defcustom doc-view-djvused-program (and (executable-find "djvused") + "djvused") + "Name of \"djvused\" program to generate imenu outline for DjVu files. +This is part of DjVuLibre." + :type '(choice (const nil) file) + :version "31.1") + +(defcustom doc-view-imenu-enabled (and (or (executable-find "mutool") + (executable-find "djvused")) + t) + "Whether to generate imenu outline for PDF and DjVu files. +This uses \"mutool\" for PDF files and \"djvused\" for DjVu files." :type 'boolean - :version "29.1") + :version "31.1") +(make-obsolete-variable 'doc-view-imenu-enabled + "Imenu index is generated unconditionally when available." + "31.1") (defcustom doc-view-imenu-title-format "%t (%p)" "Format spec for imenu's display of section titles from docview documents. @@ -561,7 +576,10 @@ Typically \"page-%s.png\".") "C-c C-c" #'doc-view-toggle-display ;; Open a new buffer with doc's text contents "C-c C-t" #'doc-view-open-text - "r" #'revert-buffer) + "r" #'revert-buffer + ;; Registers + "m" #'doc-view-page-to-register + "'" #'doc-view-jump-to-register) (define-obsolete-function-alias 'doc-view-revert-buffer #'revert-buffer "27.1") (defvar revert-buffer-preserve-modes) @@ -1525,15 +1543,18 @@ to do that. To reset the slice use `doc-view-reset-slice'." ;; Redisplay (doc-view-goto-page (doc-view-current-page))) +(defvar touch-screen-simple-mouse-conversion) ; Defined in touch-screen.el. + (defun doc-view-set-slice-using-mouse () "Set the slice of the images that should be displayed. You set the slice by pressing mouse-1 at its top-left corner and dragging it to its bottom-right corner. See also `doc-view-set-slice' and `doc-view-reset-slice'." (interactive) - (let (x y w h done) + (let ((touch-screen-simple-mouse-conversion t) + x y w h done) (while (not done) - (let ((e (read-event + (let ((e (read-key (concat "Press mouse-1 at the top-left corner and " "drag it to the bottom-right corner!")))) (when (eq (car e) 'drag-mouse-1) @@ -1779,34 +1800,27 @@ For now these keys are useful: (let ((txt (expand-file-name "doc.txt" (doc-view--current-cache-dir))) (page (doc-view-current-page))) (if (file-readable-p txt) - (let ((inhibit-read-only t) - (buffer-undo-list t) - (dv-bfn doc-view--buffer-file-name)) - (erase-buffer) - ;; FIXME: Replacing the buffer's PDF content with its txt rendering - ;; is pretty risky. We should probably use *another* - ;; buffer instead, so there's much less risk of - ;; overwriting the PDF file with some text rendering. - (set-buffer-multibyte t) - (insert-file-contents txt) - (doc-view--text-view-mode) - (setq-local doc-view--buffer-file-name dv-bfn) - (set-buffer-modified-p nil) - (doc-view-minor-mode) - (goto-char (point-min)) - ;; Put point at the start of the page the user was - ;; reading. Pages are separated by Control-L characters. - (re-search-forward page-delimiter nil t (1- page)) - (add-hook 'write-file-functions - (lambda () - ;; FIXME: If the user changes major mode and then - ;; saves the buffer, the PDF file will be clobbered - ;; with its txt rendering! - (when (eq major-mode 'doc-view--text-view-mode) - (error "Cannot save text contents of document %s" - buffer-file-name))) - nil t)) - (doc-view-doc->txt txt 'doc-view-open-text))))) + (let ((dv-bfn doc-view--buffer-file-name) + (dv-text-buffer-name (format "%s/text" (buffer-name)))) + ;; Prepare the text buffer + (with-current-buffer (get-buffer-create dv-text-buffer-name) + (let ((inhibit-read-only t) + (buffer-undo-list t)) + (erase-buffer) + (set-buffer-multibyte t) + (insert-file-contents txt) + (doc-view--text-view-mode) + (setq-local doc-view--buffer-file-name dv-bfn) + ;; Pages are separated by form feed characters. + (setq-local page-delimiter " ") + (set-buffer-modified-p nil) + (doc-view-minor-mode) + (goto-char (point-min)) + ;; Put point at the start of the page the user was + ;; reading. Pages are separated by Control-L characters. + (re-search-forward page-delimiter nil t (1- page)))) + (switch-to-buffer (get-buffer dv-text-buffer-name))) + (doc-view-doc->txt txt 'doc-view-open-text))))) ;;;;; Toggle between editing and viewing @@ -1827,14 +1841,11 @@ For now these keys are useful: (doc-view-fallback-mode) (doc-view-minor-mode 1)) ((eq major-mode 'doc-view--text-view-mode) - (let ((buffer-undo-list t)) - ;; We're currently viewing the document's text contents, so switch - ;; back to . - (setq buffer-read-only nil) - (insert-file-contents doc-view--buffer-file-name nil nil nil t) - (doc-view-fallback-mode) - (doc-view-minor-mode 1) - (set-buffer-modified-p nil))) + ;; We're currently viewing the document's text contents, switch to + ;; the buffer visiting the real document and kill myself. + (let ((dv-buffer (find-buffer-visiting doc-view--buffer-file-name))) + (kill-buffer) + (switch-to-buffer dv-buffer))) (t ;; Switch to doc-view-mode (when (and (buffer-modified-p) @@ -1958,11 +1969,25 @@ the document text." (doc-view-goto-page (caar (last doc-view--current-search-matches))))))) ;;;; Imenu support -(defconst doc-view--outline-rx - "[^\t]+\\(\t+\\)\"\\(.+\\)\"\t#\\(?:page=\\)?\\([0-9]+\\)") - (defvar-local doc-view--outline nil - "Cached PDF outline, so that it is only computed once per document.") + "Cached document outline, so that it is only computed once per document. +It can be the symbol `unavailable' to indicate that outline is +unavailable for the document.") + +(defvar doc-view--mutool-pdf-outline-script + "var document = new Document.openDocument(\"%s\", \"application/pdf\"); +var outline = document.loadOutline(); +if(!outline) quit(); +function pp(outl, level){print(\"((level . \" + level + \")\");\ +print(\"(title . \" + repr(outl.title) + \")\");\ +print(\"(page . \" + (document.resolveLink(outl.uri)+1) + \"))\");\ +if(outl.down){for(var i=0; i<outl.down.length; i++){pp(outl.down[i], level+1);}}}; +function run(){print(\"BEGIN(\");\ +for(var i=0; i<outline.length; i++){pp(outline[i], 1);}print(\")\");}; +run()" + "JS script to extract the PDF's outline using mutool. +The script has to be minified to pass it to the REPL. The \"BEGIN\" +marker is here to skip past the prompt characters.") (defun doc-view--pdf-outline (&optional file-name) "Return a list describing the outline of FILE-NAME. @@ -1973,19 +1998,64 @@ title, nesting level and page number. The list is flat: its tree structure is extracted by `doc-view--imenu-subtree'." (let ((fn (or file-name (buffer-file-name)))) (when fn - (let ((outline nil) - (fn (expand-file-name fn))) - (with-temp-buffer - (unless (eql 0 (call-process "mutool" nil (current-buffer) nil "show" fn "outline")) + (with-temp-buffer + (let ((proc (make-process + :name "doc-view-pdf-outline" + :command (list "mutool" "run") + :buffer (current-buffer)))) + (process-send-string proc (format doc-view--mutool-pdf-outline-script + (expand-file-name fn))) + ;; Need to send this twice for some reason... + (process-send-eof) + (process-send-eof) + (while (accept-process-output proc)) + (unless (eq (process-status proc) 'exit) + (setq doc-view--outline 'unavailable) (imenu-unavailable-error "Unable to create imenu index using `mutool'")) (goto-char (point-min)) - (while (re-search-forward doc-view--outline-rx nil t) - (push `((level . ,(length (match-string 1))) - (title . ,(replace-regexp-in-string "\\\\[rt]" " " - (match-string 2))) - (page . ,(string-to-number (match-string 3)))) - outline))) - (nreverse outline))))) + (when (search-forward "BEGIN" nil t) + (condition-case nil + (read (current-buffer)) + (end-of-file nil)))))))) + +(defun doc-view--djvu-outline (&optional file-name) + "Return a list describing the outline of FILE-NAME. +If FILE-NAME is nil or omitted, it defaults to the current buffer's file +name. + +For the format, see `doc-view--pdf-outline'." + (unless file-name (setq file-name (buffer-file-name))) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8)) + ;; Pass "-u" to make `djvused' emit UTF-8 encoded text to avoid + ;; unescaping octal escapes for non-ASCII text. + (call-process doc-view-djvused-program nil (current-buffer) nil + "-u" "-e" "print-outline" file-name) + (goto-char (point-min)) + (when (eobp) + (setq doc-view--outline 'unavailable) + (imenu-unavailable-error "Unable to create imenu index using `djvused'")) + (nreverse (doc-view--parse-djvu-outline (read (current-buffer))))))) + +(defun doc-view--parse-djvu-outline (bookmark &optional level) + "Return a list describing the djvu outline from BOOKMARK. +Optional argument LEVEL is the current heading level, which defaults to 1." + (unless level (setq level 1)) + (let ((res)) + (unless (eq (car bookmark) 'bookmarks) + (user-error "Unknown outline type: %S" (car bookmark))) + (pcase-dolist (`(,title ,page . ,rest) (cdr bookmark)) + (push `((level . ,level) + (title . ,title) + (page . ,(string-to-number (string-remove-prefix "#" page)))) + res) + (when (and rest (listp (car rest))) + (setq res (append + (doc-view--parse-djvu-outline + (cons 'bookmarks rest) + (+ level 1)) + res)))) + res)) (defun doc-view--imenu-subtree (outline act) "Construct a tree of imenu items for the given outline list and action. @@ -2019,19 +2089,38 @@ entries at an upper level." For extensibility, callers can specify a FILE-NAME to indicate the buffer other than the current buffer, and a jumping function GOTO-PAGE-FN other than `doc-view-goto-page'." - (let* ((goto (or goto-page-fn 'doc-view-goto-page)) - (act (lambda (_name _pos page) (funcall goto page))) - (outline (or doc-view--outline (doc-view--pdf-outline file-name)))) - (car (doc-view--imenu-subtree outline act)))) + (unless doc-view--outline + (setq doc-view--outline (doc-view--outline file-name))) + (unless (eq doc-view--outline 'unavailable) + (let* ((goto (or goto-page-fn #'doc-view-goto-page)) + (act (lambda (_name _pos page) (funcall goto page))) + (outline doc-view--outline)) + (car (doc-view--imenu-subtree outline act))))) + +(defun doc-view--outline (&optional file-name) + "Return the outline for the file FILE-NAME. +If FILE-NAME is nil, use the current file instead." + (unless file-name (setq file-name (buffer-file-name))) + (let ((outline + (pcase doc-view-doc-type + ('djvu + (when doc-view-djvused-program + (doc-view--djvu-outline file-name))) + ('odf + (doc-view--pdf-outline (doc-view-current-cache-doc-pdf))) + (_ + (doc-view--pdf-outline file-name))))) + (when outline (imenu-add-to-menubar "Outline")) + ;; When the outline could not be made due to unavailability of the + ;; required program, or its absency from the document, return + ;; 'unavailable'. + (or outline 'unavailable))) (defun doc-view-imenu-setup () "Set up local state in the current buffer for imenu, if needed." - (when doc-view-imenu-enabled - (setq-local imenu-create-index-function #'doc-view-imenu-index - imenu-submenus-on-top nil - imenu-sort-function nil - doc-view--outline (doc-view--pdf-outline)) - (when doc-view--outline (imenu-add-to-menubar "Outline")))) + (setq-local imenu-create-index-function #'doc-view-imenu-index + imenu-submenus-on-top nil + imenu-sort-function nil)) ;;;; User interface commands and the mode @@ -2480,6 +2569,56 @@ See the command `doc-view-mode' for more information on this mode." (put 'doc-view-bookmark-jump 'bookmark-handler-type "DocView") +;;; Register integration + +(defvar-local doc-view-register-alist nil + "Register alist containing only doc-view registers for current buffer. +Each doc-view register entry is of the form (doc-view . ALIST) where +ALIST has the keys `buffer', `file', and `page'. The value of `buffer' +is the buffer which visits the file specified by the value of `file'. +The value of `page' is the page stored in the register.") + +(defun doc-view-page-to-register (register) + "Store the current page to the specified REGISTER." + (interactive + (let ((register-alist doc-view-register-alist)) + (list (register-read-with-preview "Page to register: ")))) + (let ((register-alist doc-view-register-alist)) + (set-register register + `(doc-view + (buffer . ,(current-buffer)) + (file . ,(buffer-file-name)) + (page . ,(doc-view-current-page)))) + (setq doc-view-register-alist register-alist))) + +(defun doc-view-jump-to-register (register) + "Jump to the specified REGISTER." + (interactive + (let ((register-alist doc-view-register-alist)) + (list (register-read-with-preview "Jump to register: ")))) + (let ((register-alist doc-view-register-alist)) + (jump-to-register register))) + +(cl-defmethod register-val-insert ((val (head doc-view))) + (prin1 val)) + +(cl-defmethod register-val-describe ((val (head doc-view)) _verbose) + (let* ((alist (cdr val)) + (name (or (file-name-nondirectory (alist-get 'file alist)) + (buffer-name (alist-get 'buffer alist))))) + (princ name) + (princ " p. ") + (princ (alist-get 'page alist)))) + +(cl-defmethod register-val-jump-to ((val (head doc-view)) _arg) + (let* ((alist (cdr val)) + (buffer (or (alist-get 'buffer alist) + (find-buffer-visiting (alist-get 'file alist))))) + (unless buffer + (user-error "Cannot find the doc-view buffer to jump to")) + (switch-to-buffer buffer) + (doc-view-goto-page (alist-get 'page alist)))) + ;; Obsolete. (defun doc-view-intersection (l1 l2) diff --git a/lisp/dom.el b/lisp/dom.el index b329379fdc3..616778051bf 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -65,7 +65,7 @@ (defun dom-remove-attribute (node attribute) "Remove ATTRIBUTE from NODE." (setq node (dom-ensure-node node)) - (when-let ((old (assoc attribute (cadr node)))) + (when-let* ((old (assoc attribute (cadr node)))) (setcar (cdr node) (delq old (cadr node))))) (defmacro dom-attr (node attr) diff --git a/lisp/editorconfig.el b/lisp/editorconfig.el index c524945c4b9..fbc7a59d823 100644 --- a/lisp/editorconfig.el +++ b/lisp/editorconfig.el @@ -283,14 +283,11 @@ If set, enable that mode when `trim_trailing_whitespace` is set to true. Otherwise, use `delete-trailing-whitespace'." :type 'symbol) -(defvar editorconfig-properties-hash nil +(defvar-local editorconfig-properties-hash nil "Hash object of EditorConfig properties that was enabled for current buffer. Set by `editorconfig-apply' and nil if that is not invoked in current buffer yet.") -(make-variable-buffer-local 'editorconfig-properties-hash) -(put 'editorconfig-properties-hash - 'permanent-local - t) +(put 'editorconfig-properties-hash 'permanent-local t) (defvar editorconfig-lisp-use-default-indent nil "Selectively ignore the value of indent_size for Lisp files. @@ -474,9 +471,7 @@ heuristic for those modes not found there." (defvar-local editorconfig--apply-coding-system-currently nil "Used internally.") -(put 'editorconfig--apply-coding-system-currently - 'permanent-local - t) +(put 'editorconfig--apply-coding-system-currently 'permanent-local t) (defun editorconfig-merge-coding-systems (end-of-line charset) "Return merged coding system symbol of END-OF-LINE and CHARSET." diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index 40618e9ef38..c9627763d8d 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -260,7 +260,7 @@ inside a comment or string." (list ?\( (cdr direct) t string-or-comment))) (reverse (list ?\) (car reverse) t string-or-comment))))) -(defun electric-pair--insert (char) +(defun electric-pair--insert (char times) (let ((last-command-event char) (blink-matching-paren nil) (electric-pair-mode nil) @@ -271,7 +271,7 @@ inside a comment or string." ;; us to add these newlines, and is probably about to kick in ;; again after we add the closer. (electric-layout-allow-duplicate-newlines t)) - (self-insert-command 1))) + (self-insert-command times))) (defun electric-pair--syntax-ppss (&optional pos where) "Like `syntax-ppss', but sometimes fallback to `parse-partial-sexp'. @@ -455,7 +455,8 @@ happened." (atomic-change-group ;; Don't use `delete-char'; that may modify the head of the ;; undo list. - (delete-region (point) (1- (point))) + (delete-region (- (point) (prefix-numeric-value current-prefix-arg)) + (point)) (throw 'done (cond ((eq ?\( syntax) @@ -474,25 +475,26 @@ happened." Works by first removing the character from the buffer, then doing some list calculations, finally restoring the situation as if nothing happened." - (pcase (electric-pair-syntax-info char) - (`(,syntax ,pair ,_ ,s-or-c) - (unwind-protect - (progn - (delete-char -1) - (cond ((eq syntax ?\)) - (let* ((pair-data - (electric-pair--balance-info - -1 s-or-c)) - (innermost (car pair-data)) - (outermost (cdr pair-data))) - (and - (cond ((car outermost) - (car innermost)) - ((car innermost) - (not (eq (cdr outermost) pair))))))) - ((eq syntax ?\") - (electric-pair--inside-string-p char)))) - (insert char))))) + (let ((num (prefix-numeric-value current-prefix-arg))) + (pcase (electric-pair-syntax-info char) + (`(,syntax ,pair ,_ ,s-or-c) + (unwind-protect + (progn + (delete-char (- num)) + (cond ((eq syntax ?\)) + (let* ((pair-data + (electric-pair--balance-info + (- num) s-or-c)) + (innermost (car pair-data)) + (outermost (cdr pair-data))) + (and + (cond ((car outermost) + (car innermost)) + ((car innermost) + (not (eq (cdr outermost) pair))))))) + ((eq syntax ?\") + (electric-pair--inside-string-p char)))) + (insert (make-string num char))))))) (defun electric-pair-default-skip-self (char) (if electric-pair-preserve-balance @@ -527,11 +529,14 @@ The decision is taken by order of preference: `electric-pair-inhibit-predicate', `electric-pair-skip-self' and `electric-pair-skip-whitespace' (which see)." (let* ((pos (and electric-pair-mode (electric--after-char-pos))) + (num (when pos (prefix-numeric-value current-prefix-arg))) + (beg (when num (- pos num))) (skip-whitespace-info)) (pcase (electric-pair-syntax-info last-command-event) (`(,syntax ,pair ,unconditional ,_) (cond ((null pos) nil) + ((zerop num) nil) ;; Wrap a pair around the active region. ;; ((and (memq syntax '(?\( ?\) ?\" ?\$)) (use-region-p)) @@ -545,16 +550,17 @@ The decision is taken by order of preference: (>= (mark) (point)))) (save-excursion (goto-char (mark)) - (electric-pair--insert pair)) - (delete-region pos (1- pos)) - (electric-pair--insert pair) + (electric-pair--insert pair num)) + (delete-region beg pos) + (electric-pair--insert pair num) (goto-char (mark)) - (electric-pair--insert last-command-event))) + (electric-pair--insert last-command-event num))) ;; Backslash-escaped: no pairing, no skipping. ((save-excursion - (goto-char (1- pos)) + (goto-char beg) (not (zerop (% (skip-syntax-backward "\\") 2)))) - nil) + (let ((current-prefix-arg (1- num))) + (electric-pair-post-self-insert-function))) ;; Skip self. ((and (memq syntax '(?\) ?\" ?\$)) (and (or unconditional @@ -580,10 +586,10 @@ The decision is taken by order of preference: ;; live with it for now. (when skip-whitespace-info (funcall electric-pair-skip-whitespace-function)) - (delete-region (1- pos) (if (eq skip-whitespace-info 'chomp) - (point) - pos)) - (forward-char)) + (delete-region beg (if (eq skip-whitespace-info 'chomp) + (point) + pos)) + (forward-char num)) ;; Insert matching pair. ((and (memq syntax '(?\( ?\" ?\$)) (not overwrite-mode) @@ -592,7 +598,7 @@ The decision is taken by order of preference: (goto-char pos) (funcall electric-pair-inhibit-predicate last-command-event))))) - (save-excursion (electric-pair--insert pair)))))))) + (save-excursion (electric-pair--insert pair num)))))))) (defun electric-pair-open-newline-between-pairs-psif () "Honor `electric-pair-open-newline-between-pairs'. @@ -604,7 +610,8 @@ Member of `post-self-insert-hook' if `electric-pair-mode' is on." (< (1+ (point-min)) (point) (point-max)) (eq (save-excursion (skip-chars-backward "\t\s") - (char-before (1- (point)))) + (char-before (- (point) + (prefix-numeric-value current-prefix-arg)))) (matching-paren (char-after)))) (save-excursion (newline 1 t)))) @@ -618,7 +625,7 @@ Member of `post-self-insert-hook' if `electric-pair-mode' is on." ARG and KILLP are passed directly to `backward-delete-char-untabify', which see." (interactive "*p\nP") - (delete-char 1) + (delete-char arg) (backward-delete-char-untabify arg killp)) (defvar electric-pair-mode-map diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index 120972d6cd8..eddb006c500 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -33,7 +33,6 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'pcase)) -(eval-when-compile (require 'subr-x)) ; if-let (require 'find-func) (require 'help-mode) ; Define `help-function-def' button type. (require 'lisp-mode) @@ -202,6 +201,7 @@ frames where the source code location is known.") "+" #'backtrace-multi-line "-" #'backtrace-single-line "." #'backtrace-expand-ellipses + "C-]" #'abort-recursive-edit "<follow-link>" 'mouse-face "<mouse-2>" #'mouse-select-window diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index d8dbfa62bf9..0a89a33cbc3 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -483,7 +483,7 @@ There can be multiple entries for the same NAME if it has several aliases.") `(,fn ,name . ,optimized-rest))) ((guard (when for-effect - (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) + (if-let* ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 75cfc7b32d3..f1486f70634 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -222,12 +222,27 @@ So far, FUNCTION can only be a symbol, not a lambda expression." (cadr elem))) val))))) +(defalias 'byte-run--anonymize-arg-list + #'(lambda (arg-list) + (mapcar (lambda (x) + (if (memq x '(&optional &rest)) + x + t)) + arg-list))) + (defalias 'byte-run--set-function-type - #'(lambda (f _args val &optional f2) + #'(lambda (f args val &optional f2) (when (and f2 (not (eq f2 f))) (error "`%s' does not match top level function `%s' inside function type \ declaration" f2 f)) + (unless (and (length= val 3) + (eq (car val) 'function) + (listp (car (cdr val)))) + (error "Type `%s' is not valid a function type" val)) + (unless (equal (byte-run--anonymize-arg-list args) + (byte-run--anonymize-arg-list (car (cdr val)))) + (error "Type `%s' incompatible with function arguments `%s'" val args)) (list 'function-put (list 'quote f) ''function-type (list 'quote val)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 88167fc7ebd..f058fc48cc7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2713,7 +2713,7 @@ Call from the source buffer." (let ((newdocs (byte-compile--docstring docs kind name))) (unless (eq docs newdocs) (setq form (byte-compile--list-with-n form 3 newdocs))))) - form)) + (byte-compile-keep-pending form))) (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) @@ -5361,6 +5361,59 @@ FORM is used to provide location, `bytecomp--cus-function' and (bytecomp--cus-warn type "`%s' is not a valid type" type)) ))) +(defun bytecomp--check-cus-face-spec (spec) + "Check for mistakes in a `defface' SPEC argument." + (when (consp spec) + (dolist (sp spec) + (let ((display (car-safe sp)) + (atts (cdr-safe sp))) + (cond ((listp display) + (dolist (condition display) + (unless (memq (car-safe condition) + '(type class background min-colors supports)) + (bytecomp--cus-warn + (list sp spec) + "Bad face display condition `%S'" (car condition))))) + ((not (memq display '(t default))) + (bytecomp--cus-warn + (list sp spec) "Bad face display `%S'" display))) + (when (and (consp atts) (null (cdr atts))) + (setq atts (car atts))) ; old (DISPLAY ATTS) syntax + (while atts + (let ((attr (car atts)) + (val (cadr atts))) + (cond + ((not (keywordp attr)) + (bytecomp--cus-warn + (list atts sp spec) + "Non-keyword in face attribute list: `%S'" attr)) + ((null (cdr atts)) + (bytecomp--cus-warn + (list atts sp spec) "Missing face attribute `%s' value" attr)) + ((memq attr '( :inherit :extend + :family :foundry :width :height :weight :slant + :foreground :distant-foreground :background + :underline :overline :strike-through :box + :inverse-video :stipple :font + ;; FIXME: obsolete keywords, warn about them too? + :bold ; :bold t = :weight bold + :italic ; :italic t = :slant italic + )) + (when (eq (car-safe val) 'quote) + (bytecomp--cus-warn + (list val atts sp spec) + "Value for face attribute `%s' should not be quoted" attr))) + ((eq attr :reverse-video) + (bytecomp--cus-warn + (list atts sp spec) + (concat "Face attribute `:reverse-video' has been removed;" + " use `:inverse-video' instead"))) + (t + (bytecomp--cus-warn + (list atts sp spec) + "`%s' is not a valid face attribute keyword" attr)))) + (setq atts (cddr atts))))))) + ;; Unified handler for multiple functions with similar arguments: ;; (NAME SOMETHING DOC KEYWORD-ARGS...) (byte-defop-compiler-1 define-widget bytecomp--custom-declare) @@ -5394,6 +5447,13 @@ FORM is used to provide location, `bytecomp--cus-function' and (eq (car-safe type-arg) 'quote)) (bytecomp--check-cus-type (cadr type-arg))))))) + (when (eq fun 'custom-declare-face) + (let ((face-arg (nth 2 form))) + (when (and (eq (car-safe face-arg) 'quote) + (consp (cdr face-arg)) + (null (cddr face-arg))) + (bytecomp--check-cus-face-spec (nth 1 face-arg))))) + ;; Check :group (when (cond ((memq fun '(custom-declare-variable custom-declare-face)) @@ -5407,7 +5467,13 @@ FORM is used to provide location, `bytecomp--cus-function' and (when (and name byte-compile-current-file ; only when compiling a whole file (eq fun 'custom-declare-group)) - (setq byte-compile-current-group name)))) + (setq byte-compile-current-group name)) + + ;; Check :local + (when-let* ((val (and (eq fun 'custom-declare-variable) + (plist-get keyword-args :local))) + (_ (not (member val '(t 'permanent 'permanent-only))))) + (bytecomp--cus-warn form ":local keyword does not accept %S" val)))) (byte-compile-normal-call form)) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index c472d421eb0..ac2e0645f96 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -652,7 +652,7 @@ argument to `chart-sort' to sort the lists if desired." "Compute total size of files in directory DIR and its subdirectories. DIR is assumed to be a directory, verified by the caller." (let ((size 0)) - (dolist (file (directory-files-recursively dir "." t)) + (dolist (file (directory-files-recursively dir "" t)) (let ((fsize (nth 7 (file-attributes file)))) (if (> fsize 0) (setq size diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 21d40c56e74..6865a02f9e8 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -290,6 +290,7 @@ made in the style guide relating to order." Currently, all recognized keywords must be on `finder-known-keywords'." :version "25.1" :type 'boolean) +;;;###autoload(put 'checkdoc-package-keywords-flag 'safe-local-variable #'booleanp) (defvar checkdoc-style-functions nil "Hook run after the standard style check is completed. @@ -308,11 +309,12 @@ problem discovered. This is useful for adding additional checks.") (defvar checkdoc-diagnostic-buffer "*Style Warnings*" "Name of warning message buffer.") -(defcustom checkdoc-verb-check-experimental-flag t +(defcustom checkdoc-verb-check-experimental-flag nil "Non-nil means to attempt to check the voice of the doc string. This check keys off some words which are commonly misused. See the variable `checkdoc-common-verbs-wrong-voice' if you wish to add your own." - :type 'boolean) + :type 'boolean + :version "31.1") ;;;###autoload(put 'checkdoc-verb-check-experimental-flag 'safe-local-variable #'booleanp) (defvar checkdoc-generate-compile-warnings-flag nil @@ -346,6 +348,7 @@ See Info node `(elisp) Documentation Tips' for background." ;; (setq checkdoc--argument-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional +;; (setq checkdoc-permit-comma-termination-flag t) ; optional ;; (setq checkdoc-verb-check-experimental-flag nil) ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' @@ -1085,7 +1088,7 @@ Optional argument TAKE-NOTES causes all errors to be logged." Evaluation is done first so the form will be read before the documentation is checked. If there is a documentation error, then the display of what was evaluated will be overwritten by the diagnostic message." - (interactive) + (interactive nil emacs-lisp-mode) (call-interactively #'eval-defun) (checkdoc-defun)) @@ -1096,7 +1099,7 @@ Call `error' if the doc string has problems. If NO-ERROR is non-nil, then do not call error, but call `message' instead. If the doc string passes the test, then check the function for rogue white space at the end of each line." - (interactive) + (interactive nil emacs-lisp-mode) (save-excursion (beginning-of-defun) (when (checkdoc--next-docstring) @@ -2134,7 +2137,7 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"." (seq (any "cC") "f") ; cf. (seq (any "eE") ".g") ; e.g. (seq (any "iI") "." (any "eE")) ; i.e. - "a.k.a" "etc" "vs" "N.B" + "a.k.a" "etc" "vs" "N.B" "U.S" ;; Some non-standard or less common ones that we ;; might as well accept. "Inc" "Univ" "misc" "resp") @@ -2473,25 +2476,33 @@ Code:, and others referenced in the style guide." (setq err (or - ;; * A footer. Not compartmentalized from lm-verify: too bad. - ;; The following is partially clipped from lm-verify + ;; * Library footer (save-excursion (goto-char (point-max)) - (if (not (re-search-backward - ;; This should match the requirement in - ;; `package-buffer-info'. - (concat "^;;; " (regexp-quote (concat fn fe)) " ends here") - nil t)) - (if (checkdoc-y-or-n-p "No identifiable footer! Add one?") - (progn - (goto-char (point-max)) - (insert "\n(provide '" fn ")\n\n;;; " fn fe " ends here\n")) - (checkdoc-create-error - (format "The footer should be: (provide '%s)\\n;;; %s%s ends here" - fn fn fe) - ;; The buffer may be empty. - (max (point-min) (1- (point-max))) - (point-max))))) + (let* ((footer-line (lm-package-needs-footer-line))) + (if (not (re-search-backward + ;; This should match the requirement in + ;; `package-buffer-info'. + (if footer-line + (concat "^;;; " (regexp-quote (concat fn fe)) " ends here") + (concat "\n(provide '" fn ")\n")) + nil t)) + (if (checkdoc-y-or-n-p (if footer-line + "No identifiable footer! Add one?" + "No `provide' statement! Add one?")) + (progn + (goto-char (point-max)) + (insert (if footer-line + (concat "\n(provide '" fn ")\n\n;;; " fn fe " ends here\n") + (concat "\n(provide '" fn ")\n")))) + (checkdoc-create-error + (if footer-line + (format "The footer should be: (provide '%s)\\n;;; %s%s ends here" + fn fn fe) + (format "The footer should be: (provide '%s)\\n" fn)) + ;; The buffer may be empty. + (max (point-min) (1- (point-max))) + (point-max)))))) err)) ;; The below checks will not return errors if the user says NO @@ -2532,14 +2543,18 @@ Code:, and others referenced in the style guide." "Search between BEG and END for a style error with message text. Optional arguments BEG and END represent the boundary of the check. The default boundary is the entire buffer." - (let ((e nil) - (type nil)) + (let ((e nil)) (if (not (or beg end)) (setq beg (point-min) end (point-max))) (goto-char beg) - (while (setq type (checkdoc-message-text-next-string end)) + (while-let ((type (checkdoc-message-text-next-string end))) (setq e (checkdoc-message-text-engine type))) e)) +(defvar checkdoc--warning-function-re + (rx (or "display-warning" "org-display-warning" + "warn" "lwarn" + "message-box"))) + (defun checkdoc-message-text-next-string (end) "Move cursor to the next checkable message string after point. Return the message classification. @@ -2552,6 +2567,7 @@ Argument END is the maximum bounds to search in." (group (or (seq (* (or wordchar (syntax symbol))) "error") + (regexp checkdoc--warning-function-re) (seq (* (or wordchar (syntax symbol))) (or "y-or-n-p" "yes-or-no-p") (? "-with-timeout")) @@ -2559,8 +2575,13 @@ Argument END is the maximum bounds to search in." (+ (any "\n\t "))) end t)) (let* ((fn (match-string 1)) - (type (cond ((string-match "error" fn) - 'error) + (type (cond ((string-match "error" fn) + 'error) + ((string-match (rx bos + (regexp checkdoc--warning-function-re) + eos) + fn) + 'warning) (t 'y-or-n-p)))) (if (string-match "checkdoc-autofix-ask-replace" fn) (progn (forward-sexp 2) @@ -2630,30 +2651,33 @@ should not end with a period, and should start with a capital letter. The function `y-or-n-p' has similar constraints. Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." ;; If type is nil, then attempt to derive it. - (if (not type) - (save-excursion - (up-list -1) - (if (looking-at "(format") - (up-list -1)) - (setq type - (cond ((looking-at "(error") - 'error) - (t 'y-or-n-p))))) + (unless type + (save-excursion + (up-list -1) + (when (looking-at "(format") + (up-list -1)) + (setq type + (cond ((looking-at "(error") + 'error) + ((looking-at + (rx "(" (regexp checkdoc--warning-function-re) + (syntax whitespace))) + 'warning) + (t 'y-or-n-p))))) (let ((case-fold-search nil)) (or ;; From the documentation of the symbol `error': ;; In Emacs, the convention is that error messages start with a capital ;; letter but *do not* end with a period. Please follow this convention ;; for the sake of consistency. - (if (and (checkdoc--error-bad-format-p) - (not (checkdoc-autofix-ask-replace - (match-beginning 1) (match-end 1) - "Capitalize your message text?" - (capitalize (match-string 1)) - t))) - (checkdoc-create-error "Messages should start with a capital letter" - (match-beginning 1) (match-end 1)) - nil) + (when (and (checkdoc--error-bad-format-p) + (not (checkdoc-autofix-ask-replace + (match-beginning 1) (match-end 1) + "Capitalize your message text?" + (capitalize (match-string 1)) + t))) + (checkdoc-create-error "Messages should start with a capital letter" + (match-beginning 1) (match-end 1))) ;; In general, sentences should have two spaces after the period. (checkdoc-sentencespace-region-engine (point) (save-excursion (forward-sexp 1) @@ -2663,19 +2687,18 @@ Argument TYPE specifies the type of question, such as `error' or `y-or-n-p'." (save-excursion (forward-sexp 1) (point))) ;; Here are message type specific questions. - (if (and (eq type 'error) - (save-excursion (forward-sexp 1) - (forward-char -2) - (looking-at "\\.")) - (not (checkdoc-autofix-ask-replace (match-beginning 0) - (match-end 0) - "Remove period from error?" - "" - t))) - (checkdoc-create-error - "Error messages should *not* end with a period" - (match-beginning 0) (match-end 0)) - nil) + (when (and (eq type 'error) + (save-excursion (forward-sexp 1) + (forward-char -2) + (looking-at "\\.")) + (not (checkdoc-autofix-ask-replace (match-beginning 0) + (match-end 0) + "Remove period from error?" + "" + t))) + (checkdoc-create-error + "Error messages should *not* end with a period" + (match-beginning 0) (match-end 0))) ;; From `(elisp) Programming Tips': "A question asked in the ;; minibuffer with `yes-or-no-p' or `y-or-n-p' should start with ;; a capital letter and end with '?'." @@ -2828,7 +2851,7 @@ function called to create the messages." ;;;###autoload (defun checkdoc-package-keywords () "Find package keywords that aren't in `finder-known-keywords'." - (interactive) + (interactive nil emacs-lisp-mode) (require 'finder) (let ((unrecognized-keys (cl-remove-if diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 19429ce80df..4108512b3fa 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -733,6 +733,8 @@ PROPLIST is a list of the sort returned by `symbol-plist'. Call `cl--find-class' to get TYPE's propname `cl--class'" (cl--find-class type)) +(declare-function help-fns--setup-xref-backend "help-fns" ()) + ;;;###autoload (defun cl-describe-type (type &optional _buf _frame) "Display the documentation for type TYPE (a symbol)." @@ -753,6 +755,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'" ;; cl-deftype). (user-error "Unknown type %S" type)))) (with-current-buffer standard-output + (help-fns--setup-xref-backend) ;; Return the text we displayed. (buffer-string))))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b37f744b175..65bc2cb9173 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2247,15 +2247,35 @@ Like `cl-flet' but the definitions can refer to previous ones. . ,optimized-body)) ,retvar))))))) +(defun cl--self-tco-on-form (var form) + ;; Apply self-tco to the function returned by FORM, assuming that + ;; it will be bound to VAR. + (pcase form + (`(function (lambda ,fargs . ,ebody)) form + (pcase-let* ((`(,decls . ,body) (macroexp-parse-body ebody)) + (`(,ofargs . ,obody) (cl--self-tco var fargs body))) + `(function (lambda ,ofargs ,@decls . ,obody)))) + (`(let ,bindings ,form) + `(let ,bindings ,(cl--self-tco-on-form var form))) + (`(if ,cond ,exp1 ,exp2) + `(if ,cond ,(cl--self-tco-on-form var exp1) + ,(cl--self-tco-on-form var exp2))) + (`(oclosure--fix-type ,exp1 ,exp2) + `(oclosure--fix-type ,exp1 ,(cl--self-tco-on-form var exp2))) + (_ form))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form either (FUNC EXP) +where EXP is a form that should return the function to bind to the +function name FUNC, or (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the -forms of the function body. FUNC is defined in any BODY, as well +forms of the function body. FUNC is in scope in any BODY or EXP, as well as FORM, so you can write recursive and mutually recursive -function definitions. See info node `(cl) Function Bindings' for -details. +function definitions, with the caveat that EXPs are evaluated in sequence +and you cannot call a FUNC before its EXP has been evaluated. +See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -2273,18 +2293,16 @@ details. (unless (assq 'function newenv) (push (cons 'function #'cl--labels-convert) newenv)) ;; Perform self-tail call elimination. - (setq binds (mapcar - (lambda (bind) - (pcase-let* - ((`(,var ,sargs . ,sbody) bind) - (`(function (lambda ,fargs . ,ebody)) - (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) - newenv)) - (`(,ofargs . ,obody) - (cl--self-tco var fargs ebody))) - `(,var (function (lambda ,ofargs . ,obody))))) - (nreverse binds))) - `(letrec ,binds + `(letrec ,(mapcar + (lambda (bind) + (pcase-let* ((`(,var ,sargs . ,sbody) bind)) + `(,var ,(cl--self-tco-on-form + var (macroexpand-all + (if (null sbody) + sargs ;A (FUNC EXP) definition. + `(cl-function (lambda ,sargs . ,sbody))) + newenv))))) + (nreverse binds)) . ,(macroexp-unprogn (macroexpand-all (macroexp-progn body) diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el index e9b94681a4b..78720949b67 100644 --- a/lisp/emacs-lisp/comp-common.el +++ b/lisp/emacs-lisp/comp-common.el @@ -510,13 +510,13 @@ comes from `comp-primitive-type-specifiers' or the function type declaration itself." (let ((kind 'declared) type-spec) - (when-let ((res (assoc function comp-primitive-type-specifiers))) + (when-let* ((res (assoc function comp-primitive-type-specifiers))) ;; Declared primitive (setf type-spec (cadr res))) (let ((f (and (symbolp function) (symbol-function function)))) (when (and f (null type-spec)) - (if-let ((delc-type (function-get function 'function-type))) + (if-let* ((delc-type (function-get function 'function-type))) ;; Declared Lisp function (setf type-spec delc-type) (when (native-comp-function-p f) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 058fc522858..e1350370750 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -89,10 +89,10 @@ Integer values are handled in the `range' slot.") "Return all non built-in type names currently defined." (let (res) (mapatoms (lambda (x) - (when-let ((class (cl-find-class x)) - ;; Ignore EIEIO classes as they can be - ;; redefined at runtime. - (gate (not (eq 'eieio--class (type-of class))))) + (when-let* ((class (cl-find-class x)) + ;; Ignore EIEIO classes as they can be + ;; redefined at runtime. + (gate (not (eq 'eieio--class (type-of class))))) (push x res))) obarray) res)) @@ -528,8 +528,8 @@ Return them as multiple value." `(with-comp-cstr-accessors (if (or (neg src1) (neg src2)) (setf (typeset ,dst) '(number)) - (when-let ((r1 (range ,src1)) - (r2 (range ,src2))) + (when-let* ((r1 (range ,src1)) + (r2 (range ,src2))) (let* ((l1 (comp-cstr-smallest-in-range r1)) (l2 (comp-cstr-smallest-in-range r2)) (h1 (comp-cstr-greatest-in-range r1)) @@ -620,7 +620,7 @@ DST is returned." ;; Check first if we are in the simple case of all input non-negate ;; or negated so we don't have to cons. - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (apply #'comp--cstr-union-homogeneous range dst srcs) (cl-return-from comp--cstr-union-1-no-mem dst)) @@ -805,7 +805,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (range dst) () (neg dst) nil) (cl-return-from comp-cstr-intersection-no-mem dst))) - (when-let ((res (comp--cstrs-homogeneous srcs))) + (when-let* ((res (comp--cstrs-homogeneous srcs))) (if (eq res 'neg) (apply #'comp--cstr-union-homogeneous t dst srcs) (apply #'comp-cstr-intersection-homogeneous dst srcs)) @@ -917,7 +917,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (when (and (null (neg cstr)) (null (valset cstr)) (null (typeset cstr))) - (when-let (range (range cstr)) + (when-let* ((range (range cstr))) (let* ((low (caar range)) (high (cdar (last range)))) (unless (or (eq low '-) @@ -926,15 +926,6 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (> high most-positive-fixnum)) t)))))) -(defun comp-cstr-symbol-p (cstr) - "Return t if CSTR is certainly a symbol." - (with-comp-cstr-accessors - (and (null (range cstr)) - (null (neg cstr)) - (and (or (null (typeset cstr)) - (equal (typeset cstr) '(symbol))) - (cl-every #'symbolp (valset cstr)))))) - (defsubst comp-cstr-cons-p (cstr) "Return t if CSTR is certainly a cons." (with-comp-cstr-accessors @@ -945,6 +936,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (defun comp-cstr-type-p (cstr type) "Return t if CSTR is certainly of type TYPE." + ;; Only basic types are valid input. + (cl-assert (symbolp type)) (when (with-comp-cstr-accessors (cl-case type @@ -956,15 +949,22 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (or (null (typeset cstr)) (equal (typeset cstr) '(integer))))))) (t - (if-let ((pred (get type 'cl-deftype-satisfies))) + (if-let* ((pred (get type 'cl-deftype-satisfies))) (and (null (range cstr)) (null (neg cstr)) - (and (or (null (typeset cstr)) - (equal (typeset cstr) `(,type))) - (cl-every pred (valset cstr)))) + (if (null (typeset cstr)) + (and (valset cstr) + (cl-every pred (valset cstr))) + (when (equal (typeset cstr) `(,type)) + ;; (valset cstr) can be nil as well. + (cl-every pred (valset cstr))))) (error "Unknown predicate for type %s" type))))) t)) +(defun comp-cstr-symbol-p (cstr) + "Return t if CSTR is certainly a symbol." + (comp-cstr-type-p cstr 'symbol)) + ;; Move to comp.el? (defsubst comp-cstr-cl-tag-p (cstr) "Return non-nil if CSTR is a CL tag." diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index a659d7f68b7..b4f8b46b93a 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -186,8 +186,7 @@ processes from `comp-async-compilations'" (max 1 (/ (num-processors) 2)))) native-comp-async-jobs-number)) -(defvar comp-last-scanned-async-output nil) -(make-variable-buffer-local 'comp-last-scanned-async-output) +(defvar-local comp-last-scanned-async-output nil) ;; From warnings.el (defvar warning-suppress-types) (defun comp--accept-and-process-async-output (process) @@ -371,8 +370,8 @@ Return the trampoline if found or nil otherwise." (memq subr-name native-comp-never-optimize-functions) (gethash subr-name comp-installed-trampolines-h)) (cl-assert (subr-primitive-p subr)) - (when-let ((trampoline (or (comp--trampoline-search subr-name) - (comp-trampoline-compile subr-name)))) + (when-let* ((trampoline (or (comp--trampoline-search subr-name) + (comp-trampoline-compile subr-name)))) (comp--install-trampoline subr-name trampoline))))) ;;;###autoload @@ -424,7 +423,7 @@ bytecode definition was not changed in the meantime)." (t (signal 'native-compiler-error (list "Not a file nor directory" file-or-dir))))) (dolist (file file-list) - (if-let ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) + (if-let* ((entry (seq-find (lambda (x) (string= file (car x))) comp-files-queue))) ;; Most likely the byte-compiler has requested a deferred ;; compilation, so update `comp-files-queue' to reflect that. (unless (or (null load) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 947fb06e602..f37bb965ffb 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -164,6 +164,7 @@ Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") comp--ipa-pure comp--add-cstrs comp--fwprop + comp--type-check-optim comp--tco comp--fwprop comp--remove-type-hints @@ -200,9 +201,9 @@ Useful to hook into pass checkers.") "Given FUNCTION return the corresponding `comp-constraint'." (when (symbolp function) (or (gethash function comp-primitive-func-cstr-h) - (when-let ((type (or (when-let ((f (comp--symbol-func-to-fun function))) - (comp-func-declared-type f)) - (function-get function 'function-type)))) + (when-let* ((type (or (when-let* ((f (comp--symbol-func-to-fun function))) + (comp-func-declared-type f)) + (function-get function 'function-type)))) (comp-type-spec-to-cstr type))))) ;; Keep it in sync with the `cl-deftype-satisfies' property set in @@ -616,7 +617,7 @@ In use by the back-end." (defun comp--function-pure-p (f) "Return t if F is pure." (or (get f 'pure) - (when-let ((func (comp--symbol-func-to-fun f))) + (when-let* ((func (comp--symbol-func-to-fun f))) (comp-func-pure func)))) (defun comp--alloc-class-to-container (alloc-class) @@ -792,25 +793,33 @@ clashes." :byte-func byte-code))) (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) -(cl-defmethod comp--spill-lap-function ((form list)) - "Byte-compile FORM, spilling data from the byte compiler." - (unless (memq (car-safe form) '(lambda closure)) - (signal 'native-compiler-error - '("Cannot native-compile, form is not a lambda or closure"))) +(defun comp--spill-lap-single-function (function) + "Byte-compile FUNCTION, spilling data from the byte compiler." (unless (comp-ctxt-output comp-ctxt) (setf (comp-ctxt-output comp-ctxt) (make-temp-file "comp-lambda-" nil ".eln"))) - (let* ((byte-code (byte-compile form)) + (let* ((byte-code (byte-compile function)) (c-name (comp-c-func-name "anonymous-lambda" "F"))) - (setf (comp-ctxt-top-level-forms comp-ctxt) - (list (make-byte-to-native-func-def :name '--anonymous-lambda - :c-name c-name - :byte-func byte-code))) - (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) + (setf (comp-ctxt-top-level-forms comp-ctxt) + (list (make-byte-to-native-func-def :name '--anonymous-lambda + :c-name c-name + :byte-func byte-code))) + (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))) + +(cl-defmethod comp--spill-lap-function ((form list)) + "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"))) + (comp--spill-lap-single-function form)) + +(cl-defmethod comp--spill-lap-function ((fun interpreted-function)) + "Spill data from the byte compiler for the interpreted-function FUN." + (comp--spill-lap-single-function fun)) (defun comp--intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda', create a function in `comp-ctxt'." - (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) + (when-let* ((byte-func (byte-to-native-lambda-byte-func obj))) (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) @@ -1696,7 +1705,7 @@ into the C code forwarding the compilation unit." ;; FIXME Actually we could have another hash for this. (cl-flet ((pred (bb) (equal (comp-block-lap-addr bb) addr))) - (if-let ((pending (cl-find-if #'pred + (if-let* ((pending (cl-find-if #'pred (comp-limplify-pending-blocks comp-pass)))) (comp-block-name pending) (cl-loop for bb being the hash-value in (comp-func-blocks comp-func) @@ -1873,9 +1882,9 @@ The assume is emitted at the beginning of the block BB." rhs))) (comp-block-insns bb)))) ((pred comp--arithm-cmp-fun-p) - (when-let ((kind (if negated - (comp--negate-arithm-cmp-fun kind) - kind))) + (when-let* ((kind (if negated + (comp--negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make--comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) @@ -1891,10 +1900,10 @@ The assume is emitted at the beginning of the block BB." (defun comp--maybe-add-vmvar (op cmp-res insns-seq) "If CMP-RES is clobbering OP emit a new constrained mvar and return it. Return OP otherwise." - (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) - (new-mvar (make--comp-mvar - :slot - (- (cl-incf (comp-func-vframe-size comp-func)))))) + (if-let* ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res))) + (new-mvar (make--comp-mvar + :slot + (- (cl-incf (comp-func-vframe-size comp-func)))))) (progn (push `(assume ,new-mvar ,op) (cdr insns-seq)) new-mvar) @@ -1965,7 +1974,11 @@ TARGET-BB-SYM is the symbol name of the target block." (defun comp--add-cond-cstrs-simple () "`comp--add-cstrs' worker function for each selected function." (cl-loop - for b being each hash-value of (comp-func-blocks comp-func) + ;; Don't iterate over hash values directly as + ;; `comp--add-cond-cstrs-target-block' can modify the hash table + ;; content. + for b in (cl-loop for b being each hash-value of (comp-func-blocks comp-func) + collect b) do (cl-loop named in-the-basic-block @@ -2126,14 +2139,14 @@ TARGET-BB-SYM is the symbol name of the target block." for bb being each hash-value of (comp-func-blocks comp-func) do (comp--loop-insn-in-block bb - (when-let ((match - (pcase insn - (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f lhs args))) - (`(,(pred comp--call-op-p) ,f . ,args) - (when-let ((cstr-f (comp--get-function-cstr f))) - (cl-values f cstr-f nil args)))))) + (when-let* ((match + (pcase insn + (`(set ,lhs (,(pred comp--call-op-p) ,f . ,args)) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f lhs args))) + (`(,(pred comp--call-op-p) ,f . ,args) + (when-let* ((cstr-f (comp--get-function-cstr f))) + (cl-values f cstr-f nil args)))))) (cl-multiple-value-bind (f cstr-f lhs args) match (cl-loop with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f)) @@ -2327,14 +2340,14 @@ blocks." finger2 (comp-block-post-num b2)))) b1)) (first-processed (l) - (if-let ((p (cl-find-if #'comp-block-idom l))) + (if-let* ((p (cl-find-if #'comp-block-idom l))) p (signal 'native-ice '("can't find first preprocessed"))))) - (when-let ((blocks (comp-func-blocks comp-func)) - (entry (gethash 'entry blocks)) - ;; No point to go on if the only bb is 'entry'. - (bb0 (gethash 'bb_0 blocks))) + (when-let* ((blocks (comp-func-blocks comp-func)) + (entry (gethash 'entry blocks)) + ;; No point to go on if the only bb is 'entry'. + (bb0 (gethash 'bb_0 blocks))) (cl-loop with rev-bb-list = (comp--collect-rev-post-order entry) with changed = t @@ -2437,7 +2450,7 @@ blocks." PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." (when pre-lambda (funcall pre-lambda bb)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) when (eq bb (comp-block-idom child)) @@ -2495,7 +2508,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil." do (comp--ssa-rename-insn insn in-frame)) (setf (comp-block-final-frame bb) (copy-sequence in-frame)) - (when-let ((out-edges (comp-block-out-edges bb))) + (when-let* ((out-edges (comp-block-out-edges bb))) (cl-loop for ed in out-edges for child = (comp-edge-dst ed) @@ -2540,26 +2553,29 @@ Return t when one or more block was removed, nil otherwise." ret t) finally return ret)) +(defun comp--ssa-function (function) + "Port into minimal SSA FUNCTION." + (let* ((comp-func function) + (ssa-status (comp-func-ssa-status function))) + (unless (eq ssa-status t) + (cl-loop + when (eq ssa-status 'dirty) + do (comp--clean-ssa function) + do (comp--compute-edges) + (comp--compute-dominator-tree) + until (null (comp--remove-unreachable-blocks))) + (comp--compute-dominator-frontiers) + (comp--log-block-info) + (comp--place-phis) + (comp--ssa-rename) + (comp--finalize-phis) + (comp--log-func comp-func 3) + (setf (comp-func-ssa-status function) t)))) + (defun comp--ssa () - "Port all functions into minimal SSA form." - (maphash (lambda (_ f) - (let* ((comp-func f) - (ssa-status (comp-func-ssa-status f))) - (unless (eq ssa-status t) - (cl-loop - when (eq ssa-status 'dirty) - do (comp--clean-ssa f) - do (comp--compute-edges) - (comp--compute-dominator-tree) - until (null (comp--remove-unreachable-blocks))) - (comp--compute-dominator-frontiers) - (comp--log-block-info) - (comp--place-phis) - (comp--ssa-rename) - (comp--finalize-phis) - (comp--log-func comp-func 3) - (setf (comp-func-ssa-status f) t)))) - (comp-ctxt-funcs-h comp-ctxt))) + "Port all functions into minimal SSA all functions." + (cl-loop for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt) + do (comp--ssa-function f))) ;;; propagate pass specific code. @@ -2652,7 +2668,7 @@ Return non-nil if the function is folded successfully." ;; should do basic block pruning in order to be sure that this ;; is not dead-code. This is now left to gcc, to be ;; implemented only if we want a reliable diagnostic here. - (let* ((f (if-let (f-in-ctxt (comp--symbol-func-to-fun f)) + (let* ((f (if-let* ((f-in-ctxt (comp--symbol-func-to-fun f))) ;; If the function is IN the compilation ctxt ;; and know to be pure. (comp-func-byte-func f-in-ctxt) @@ -2669,7 +2685,7 @@ Fold the call in case." (comp-cstr-imm-vld-p (car args))) (setf f (comp-cstr-imm (car args)) args (cdr args))) - (when-let ((cstr-f (comp--get-function-cstr f))) + (when-let* ((cstr-f (comp--get-function-cstr f))) (let ((cstr (comp-cstr-f-ret cstr-f))) (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. @@ -2802,6 +2818,69 @@ Return t if something was changed." (comp-ctxt-funcs-h comp-ctxt))) +;;; Type check optimizer pass specific code. + +;; This pass optimize-out unnecessary type checks, that is calls to +;; `type-of' and corresponding conditional branches. +;; +;; This is often advantageous in cases where a function manipulates an +;; object with several slot accesses like: +;; +;; (cl-defstruct foo a b c) +;; (defun bar (x) +;; (setf (foo-a x) 3) +;; (+ (foo-b x) (foo-c x))) +;; +;; After x is accessed and type checked once, it's proved to be of type +;; foo, and no other type checks are required. + +;; At present running this pass over the whole Emacs codebase triggers +;; the optimization of 1972 type checks. + +(defun comp--type-check-optim-block (block) + "Optimize conditional branches in BLOCK when possible." + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns block) + do (pcase insns-seq + (`((set ,(and (pred comp-mvar-p) mvar-tested-copy) + ,(and (pred comp-mvar-p) mvar-tested)) + (set ,(and (pred comp-mvar-p) mvar-1) + (call type-of ,(and (pred comp-mvar-p) mvar-tested-copy))) + (set ,(and (pred comp-mvar-p) mvar-2) + (call symbol-value ,(and (pred comp-cstr-cl-tag-p) mvar-tag))) + (set ,(and (pred comp-mvar-p) mvar-3) + (call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred comp-mvar-p) mvar-2))) + (cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1 ,bb2)) + (cl-assert (comp-cstr-imm-vld-p mvar-tag)) + (when (comp-cstr-type-p mvar-tested (comp-cstr-cl-tag mvar-tag)) + (comp-log (format "Optimizing conditional branch %s in function: %s" + bb1 + (comp-func-name comp-func)) + 3) + (setf (car insns-seq) '(comment "optimized by comp--type-check-optim") + (cdr insns-seq) `((jump ,bb2)) + ;; Set the SSA status as dirty so + ;; `comp--ssa-function' will remove the unreachable + ;; branches later. + (comp-func-ssa-status comp-func) 'dirty)))))) + +(defun comp--type-check-optim (_) + "Optimize conditional branches when possible." + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + when (>= (comp-func-speed f) 2) + do (cl-loop + for b being each hash-value of (comp-func-blocks f) + do (comp--type-check-optim-block b) + finally + (progn + (when (eq (comp-func-ssa-status f) 'dirty) + (comp--ssa-function f)) + (comp--log-func comp-func 3))))) + + ;;; Call optimizer pass specific code. ;; This pass is responsible for the following optimizations: ;; - Call to subrs that are in defined in the C source and are passing through @@ -2889,14 +2968,14 @@ FUNCTION can be a function-name or byte compiled function." do (comp--loop-insn-in-block b (pcase insn (`(set ,lval (callref funcall ,f . ,rest)) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn `(set ,lval ,new-form)))) (`(callref funcall ,f . ,rest) - (when-let ((ok (comp-cstr-imm-vld-p f)) - (new-form (comp--call-optim-form-call - (comp-cstr-imm f) rest))) + (when-let* ((ok (comp-cstr-imm-vld-p f)) + (new-form (comp--call-optim-form-call + (comp-cstr-imm f) rest))) (setf insn new-form))))))) (defun comp--call-optim (_) @@ -3509,7 +3588,6 @@ the deferred compilation mechanism." do (comp-log (format "Pass %s took: %fs." pass time) 0)))) - (native-compiler-skip) (t (let ((err-val (cdr err))) ;; If we are doing an async native compilation print the @@ -3565,31 +3643,37 @@ the deferred compilation mechanism." Search happens in `native-comp-eln-load-path'." (cl-loop with eln-filename = (comp-el-to-eln-rel-filename filename) - for dir in native-comp-eln-load-path - for f = (expand-file-name eln-filename - (expand-file-name comp-native-version-dir - (expand-file-name - dir - invocation-directory))) + for dir in (comp-eln-load-path-eff) + for f = (expand-file-name eln-filename dir) when (file-exists-p f) do (cl-return f))) ;;;###autoload (defun native-compile (function-or-file &optional output) "Compile FUNCTION-OR-FILE into native code. -This is the synchronous entry-point for the Emacs Lisp native -compiler. FUNCTION-OR-FILE is a function symbol, a form, or the -filename of an Emacs Lisp source file. If OUTPUT is non-nil, use -it as the filename for the compiled object. If FUNCTION-OR-FILE -is a filename, if the compilation was successful return the -filename of the compiled object. If FUNCTION-OR-FILE is a -function symbol or a form, if the compilation was successful -return the compiled function." +This is the synchronous entry-point for the Emacs Lisp native compiler. +FUNCTION-OR-FILE is a function symbol, a form, an interpreted-function, +or the filename of an Emacs Lisp source file. If OUTPUT is non-nil, use +it as the filename for the compiled object. If FUNCTION-OR-FILE is a +filename, if the compilation was successful return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a form, if +the compilation was successful return the compiled function." (declare (ftype (function ((or string symbol) &optional string) (or native-comp-function string)))) (comp--native-compile function-or-file nil output)) ;;;###autoload +(defun native-compile-directory (directory) + "Native compile if necessary all the .el files present in DIRECTORY. +Each .el file is native-compiled if the corresponding .eln file is not +found in any directory mentioned in `native-comp-eln-load-path'. +The search within DIRECTORY is performed recursively." + (mapc (lambda (file) + (unless (comp-lookup-eln file) + (native-compile file))) + (directory-files-recursively directory ".+\\.el\\'"))) + +;;;###autoload (defun batch-native-compile (&optional for-tarball) "Perform batch native compilation of remaining command-line arguments. diff --git a/lisp/emacs-lisp/cond-star.el b/lisp/emacs-lisp/cond-star.el new file mode 100644 index 00000000000..7ba6bf369b0 --- /dev/null +++ b/lisp/emacs-lisp/cond-star.el @@ -0,0 +1,745 @@ +;;; cond-star.el --- Extended form of `cond' construct -*-lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Maintainer: Richard Stallman <rms@gnu.org> +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements `cond*', an alternative to `pcase'. + +;; Here is the list of functions the generated code is known to call: +;; car, cdr, car-safe, cdr-safe, nth, nthcdr, null, eq, equal, eql, =, +;; vectorp, length. +;; It also uses these control and binding primitives: +;; and, or, if, progn, let, let*, setq. +;; For regexp matching only, it can call string-match and match-string. + +;; ??? If a clause starts with a keyword, +;; should the element after the keyword be treated in the usual way +;; as a pattern? Currently `cond*-non-exit-clause-substance' explicitly +;; prevents that by adding t at the front of its value. + +;;; Code: + +(require 'cl-lib) ; for cl-assert + +(defmacro cond* (&rest clauses) + "Extended form of traditional Lisp `cond' construct. +A `cond*' construct is a series of clauses, and a clause +normally has the form (CONDITION BODY...). + +CONDITION can be a Lisp expression, as in `cond'. +Or it can be one of `(pcase* PATTERN DATUM)', +`(bind* BINDINGS...)', or `(match* PATTERN DATUM)', + +`(pcase* PATTERN DATUM)' means to match DATUM against the +pattern PATTERN, using the same pattern syntax as `pcase'. +The condition counts as true if PATTERN matches DATUM. + +`(bind* BINDINGS...)' means to bind BINDINGS (as if they were in `let*') +for the body of the clause. As a condition, it counts as true +if the first binding's value is non-nil. All the bindings are made +unconditionally for whatever scope they cover. + +`(match* PATTERN DATUM)' is an alternative to `pcase*' that uses another +syntax for its patterns, see `match*'. + +When a clause's condition is true, and it exits the `cond*' +or is the last clause, the value of the last expression +in its body becomes the return value of the `cond*' construct. + +Non-exit clause: + +If a clause has only one element, or if its first element is +t, or if it ends with the keyword :non-exit, then +this clause never exits the `cond*' construct. Instead, +control falls through to the next clause (if any). +The bindings made in CONDITION for the BODY of the non-exit clause +are passed along to the rest of the clauses in this `cond*' construct. + +\\[match*\\] for documentation of the patterns for use in `match*'." + (cond*-convert clauses)) + +(defmacro match* (pattern _datum) + "This specifies matching DATUM against PATTERN. +It is not really a Lisp function, and it is meaningful +only in the CONDITION of a `cond*' clause. + +`_' matches any value. +KEYWORD matches that keyword. +nil matches nil. +t matches t. +SYMBOL matches any value and binds SYMBOL to that value. + If SYMBOL has been matched and bound earlier in this pattern, + it matches here the same value that it matched before. +REGEXP matches a string if REGEXP matches it. + The match must cover the entire string from its first char to its last. +ATOM (meaning any other kind of non-list not described above) + matches anything `equal' to it. +\(rx REGEXP) uses a regexp specified in s-expression form, + as in the function `rx', and matches the data that way. +\(rx REGEXP SYM0 SYM1...) uses a regexp specified in s-expression form, + and binds the symbols SYM0, SYM1, and so on + to (match-string 0 DATUM), (match-string 1 DATUM), and so on. + You can use as many SYMs as regexp matching supports. + +`OBJECT matches any value `equal' to OBJECT. +\(cons CARPAT CDRPAT) + matches a cons cell if CARPAT matches its car and CDRPAT matches its cdr. +\(list ELTPATS...) + matches a list if the ELTPATS match its elements. + The first ELTPAT should match the list's first element. + The second ELTPAT should match the list's second element. And so on. +\(vector ELTPATS...) + matches a vector if the ELTPATS match its elements. + The first ELTPAT should match the vector's first element. + The second ELTPAT should match the vector's second element. And so on. +\(cdr PATTERN) matches PATTERN with strict checking of cdrs. + That means that `list' patterns verify that the final cdr is nil. + Strict checking is the default. +\(cdr-safe PATTERN) matches PATTERN with lax checking of cdrs. + That means that `list' patterns do not examine the final cdr. +\(and CONJUNCTS...) matches each of the CONJUNCTS against the same data. + If all of them match, this pattern succeeds. + If one CONJUNCT fails, this pattern fails and does not try more CONJUNCTS. +\(or DISJUNCTS...) matches each of the DISJUNCTS against the same data. + If one DISJUNCT succeeds, this pattern succeeds + and does not try more DISJUNCTs. + If all of them fail, this pattern fails. +\(COND*-EXPANDER ...) + Here the car is a symbol that has a `cond*-expander' property + which defines how to handle it in a pattern. The property value + is a function. Trying to match such a pattern calls that + function with one argument, the pattern in question (including its car). + The function should return an equivalent pattern + to be matched instead. +\(PREDICATE SYMBOL) + matches datum if (PREDICATE DATUM) is true, + then binds SYMBOL to DATUM. +\(PREDICATE SYMBOL MORE-ARGS...) + matches datum if (PREDICATE DATUM MORE-ARGS...) is true, + then binds SYMBOL to DATUM. + MORE-ARGS... can refer to symbols bound earlier in the pattern. +\(constrain SYMBOL EXP) + matches datum if the form EXP is true. + EXP can refer to symbols bound earlier in the pattern." + ;; FIXME: `byte-compile-warn-x' is not necessarily defined here. + (byte-compile-warn-x pattern "`match*' used other than as a `cond*' condition")) + +(defun cond*-non-exit-clause-p (clause) + "If CLAUSE, a cond* clause, is a non-exit clause, return t." + (or (null (cdr-safe clause)) ;; clause has only one element. + (and (cdr-safe clause) + ;; Starts with t. + (or (eq (car clause) t) + ;; Begins with keyword. + (keywordp (car clause)))) + ;; Ends with keyword. + (keywordp (car (last clause))))) + +(defun cond*-non-exit-clause-substance (clause) + "For a non-exit cond* clause CLAUSE, return its substance. +This removes a final keyword if that's what makes CLAUSE non-exit." + (cond ((null (cdr-safe clause)) ;; clause has only one element. + clause) + ;; Starts with t or a keyword. + ;; Include t as the first element of the substance + ;; so that the following element is not treated as a pattern. + ((and (cdr-safe clause) + (or (eq (car clause) t) + (keywordp (car clause)))) + ;; Standardize on t as the first element. + (cons t (cdr clause))) + + ;; Ends with keyword. + ((keywordp (car (last clause))) + ;; Do NOT include the final keyword. + (butlast clause)))) + +(defun cond*-convert (clauses) + "Process a list of cond* clauses, CLAUSES. +Returns the equivalent Lisp expression." + (if clauses + (cond*-convert-clause (car-safe clauses) (cdr-safe clauses)))) + +(defun cond*-convert-clause (clause rest) + "Process one `cond*' clause, CLAUSE. +REST is the rest of the clauses of this cond* expression." + (if (cond*-non-exit-clause-p clause) + ;; Handle a non-exit clause. Make its bindings active + ;; around the whole rest of this cond*, treating it as + ;; a condition whose value is always t, around the rest + ;; of this cond*. + (let ((substance (cond*-non-exit-clause-substance clause))) + (cond*-convert-condition + ;; Handle the first substantial element in the non-exit clause + ;; as a matching condition. + (car substance) + ;; Any following elements in the + ;; non-exit clause are just expressions. + (cdr substance) + ;; Remaining clauses will be UNCONDIT-CLAUSES: + ;; run unconditionally and handled as a cond* body. + rest + nil nil)) + ;; Handle a normal (conditional exit) clause. + (cond*-convert-condition (car-safe clause) (cdr-safe clause) nil + rest (cond*-convert rest)))) + +(defun cond*-convert-condition (condition true-exps uncondit-clauses rest iffalse) + "Process the condition part of one cond* clause. +TRUE-EXPS is a list of Lisp expressions to be executed if this +condition is true, and inside its bindings. +UNCONDIT-CLAUSES is a list of cond*-clauses to be executed if this +condition is true, and inside its bindings. +This is used for non-exit clauses; it is nil for conditional-exit clauses. + +REST and IFFALSE are non-nil for conditional-exit clauses that are not final. +REST is a list of clauses to process after this one if +this one could have exited but does not exit. +This is used for conditional exit clauses. +IFFALSE is the value to compute after this one if +this one could have exited but does not exit. +This is used for conditional exit clauses." + (if (and uncondit-clauses rest) + (error "Clause is both exiting and non-exit")) + (let ((pat-type (car-safe condition))) + (cond ((eq pat-type 'bind*) + (let* ((bindings (cdr condition)) + (first-binding (car bindings)) + (first-variable (if (symbolp first-binding) first-binding + (car first-binding))) + (first-value (if (symbolp first-binding) nil + (cadr first-binding))) + (init-gensym (gensym "init")) + ;; BINDINGS with the initial value of the first binding + ;; replaced by INIT-GENSYM. + (mod-bindings + (cons (list first-variable init-gensym) (cdr bindings)))) + ;;; ??? Here pull out all nontrivial initial values + ;;; ??? to compute them earlier. + (if rest + ;; bind* starts an exiting clause which is not final. + ;; Therefore, must run IFFALSE. + `(let ((,init-gensym ,first-value)) + (if ,init-gensym + (let* ,mod-bindings + . ,true-exps) + ;; Always calculate all bindings' initial values, + ;; but the bindings must not cover IFFALSE. + (let* ,mod-bindings nil) + ,iffalse)) + (if uncondit-clauses + ;; bind* starts a non-exit clause which is not final. + ;; Run the TRUE-EXPS if condition value is true. + ;; Then always go on to run the UNCONDIT-CLAUSES. + (if true-exps + `(let ((,init-gensym ,first-value)) +;;; ??? Should we make the bindings a second time for the UNCONDIT-CLAUSES. +;;; as the doc string says, for uniformity with match*? + (let* ,mod-bindings + (when ,init-gensym + . ,true-exps) + ,(cond*-convert uncondit-clauses))) + `(let* ,bindings + ,(cond*-convert uncondit-clauses))) + ;; bind* starts a final clause. + ;; If there are TRUE-EXPS, run them if condition succeeded. + ;; Always make the bindings, in case the + ;; initial values have side effects. + `(let ((,init-gensym ,first-value)) + ;; Calculate all binding values unconditionally. + (let* ,mod-bindings + (when ,init-gensym + . ,true-exps))))))) + ((eq pat-type 'pcase*) + (if true-exps + (progn + (when uncondit-clauses + ;; FIXME: This happens in cases like + ;; (cond* ((match* `(,x . ,y) EXP) THEN :non-exit) + ;; (t ELSE)) + ;; where ELSE is supposed to run after THEN also (and + ;; with access to `x' and `y'). + (error ":non-exit not supported with `pcase*'")) + (cl-assert (or (null iffalse) rest)) + `(pcase ,(nth 2 condition) + (,(nth 1 condition) ,@true-exps) + (_ ,iffalse))) + (cl-assert (null iffalse)) + (cl-assert (null rest)) + `(pcase-let ((,(nth 1 condition) ,(nth 2 condition))) + (cond* . ,uncondit-clauses)))) + ((eq pat-type 'match*) + (cond*-match condition true-exps uncondit-clauses iffalse)) + (t + ;; Ordinary Lisp expression is the condition. + (if rest + ;; A nonfinal exiting clause. + ;; If condition succeeds, run the TRUE-EXPS. + ;; There are following clauses, so run IFFALSE + ;; if the condition fails. + `(if ,condition + (progn . ,true-exps) + ,iffalse) + (if uncondit-clauses + ;; A non-exit clause. + ;; If condition succeeds, run the TRUE-EXPS. + ;; Then always go on to run the UNCONDIT-CLAUSES. + `(progn (if ,condition + (progn . ,true-exps)) + ,(cond*-convert uncondit-clauses)) + ;; An exiting clause which is also final. + ;; If there are TRUE-EXPS, run them if CONDITION succeeds. + (if true-exps + `(if ,condition (progn . ,true-exps)) + ;; Run and return CONDITION. + condition))))))) + +(defun cond*-match (matchexp true-exps uncondit-clauses iffalse) + "Generate code to match a match* pattern PATTERN. +Match it against data represented by the expression DATA. +TRUE-EXPS, UNCONDIT-CLAUSES and IFFALSE have the same meanings +as in `cond*-condition'." + (when (or (null matchexp) (null (cdr-safe matchexp)) + (null (cdr-safe (cdr matchexp))) + (cdr-safe (cdr (cdr matchexp)))) + (byte-compile-warn-x matchexp "Malformed (match* ...) expression")) + (let* (raw-result + (pattern (nth 1 matchexp)) + (data (nth 2 matchexp)) + expression + (inner-data data) + ;; Add backtrack aliases for or-subpatterns to cdr of this. + (backtrack-aliases (list nil)) + run-true-exps + store-value-swap-outs retrieve-value-swap-outs + gensym) + ;; For now, always bind a gensym to the data to be matched. + (setq gensym (gensym "d") inner-data gensym) + ;; Process the whole pattern as a subpattern. + (setq raw-result (cond*-subpat pattern nil nil nil backtrack-aliases inner-data)) + (setq expression (cdr raw-result)) + ;; If there are conditional expressions and some + ;; unconditional clauses to follow, + ;; and the pattern bound some variables, + ;; copy their values into special aliases + ;; to be copied back at the start of the unconditional clauses. + (when (and uncondit-clauses true-exps + (car raw-result)) + (dolist (bound-var (car raw-result)) + (push `(setq ,(gensym "ua") ,(car bound-var)) store-value-swap-outs) + (push `(,(car bound-var) ,(gensym "ua")) retrieve-value-swap-outs))) + + ;; Make an expression to run the TRUE-EXPS inside our bindings. + (if store-value-swap-outs + ;; If we have to store those bindings' values in aliases + ;; for the UNCONDIT-CLAUSES, do so inside these bindings. + (setq run-true-exps + (cond*-bind-pattern-syms + (car raw-result) + `(prog1 (progn . ,true-exps) . ,store-value-swap-outs))) + (setq run-true-exps + (cond*-bind-pattern-syms + (car raw-result) + `(progn . ,true-exps)))) + ;; Run TRUE-EXPS if match succeeded. Bind our bindings around it. + (setq expression + (if (and (null run-true-exps) (null iffalse)) + ;; We MUST compute the expression, even when no decision + ;; depends on its value, because it may call functions with + ;; side effects. + expression + `(if ,expression + ,run-true-exps + ;; For a non-final exiting clause, run IFFALSE if match failed. + ;; Don't bind the bindings around it, since + ;; an exiting clause's bindings don't affect later clauses. + ,iffalse))) + ;; For a non-final non-exiting clause, + ;; always run the UNCONDIT-CLAUSES. + (if uncondit-clauses + (setq expression + `(progn ,expression + ,(cond*-bind-pattern-syms + (if retrieve-value-swap-outs + ;; If we saved the bindings' values after the + ;; true-clauses, bind the same variables + ;; here to the values we saved then. + retrieve-value-swap-outs + ;; Otherwise bind them to the values + ;; they matched in the pattern. + (car raw-result)) + (cond*-convert uncondit-clauses))))) + ;; Bind the backtrack-aliases if any. + ;; We need them bound for the TRUE-EXPS. + ;; It is harmless to bind them around IFFALSE + ;; because they are all gensyms anyway. + (if (cdr backtrack-aliases) + (setq expression + `(let ,(mapcar #'cdr (cdr backtrack-aliases)) + ,expression))) + (if retrieve-value-swap-outs + (setq expression + `(let ,(mapcar #'cadr retrieve-value-swap-outs) + ,expression))) + ;; If we used a gensym, wrap on code to bind it. + (if gensym + (if (and (listp expression) (eq (car expression) 'progn)) + `(let ((,gensym ,data)) . ,(cdr expression)) + `(let ((,gensym ,data)) ,expression)) + expression))) + +(defun cond*-bind-pattern-syms (bindings expr) + "Wrap EXPR in code to bind the BINDINGS. +This is used for the bindings specified explicitly in match* patterns." + ;; They can't have side effects. Skip them + ;; if we don't actually need them. + (if (equal expr '(progn)) + nil + (if bindings + (if (eq (car expr) 'progn) + `(let* ,bindings . ,(cdr expr)) + `(let* ,bindings ,expr)) + expr))) + +(defvar cond*-debug-pattern nil) + +;; ??? Structure type patterns not implemented yet. +;; ??? Probably should optimize the `nth' calls in handling `list'. + +(defun cond*-subpat (subpat cdr-ignore bindings inside-or backtrack-aliases data) + "Generate code to match the subpattern within `match*'. +SUBPAT is the subpattern to handle. +CDR-IGNORE if true means don't verify there are no extra elts in a list. +BINDINGS is the list of bindings made by +the containing and previous subpatterns of this pattern. +Each element of BINDINGS must have the form (VAR VALUE). +BACKTRACK-ALIASES is used to pass data upward. Initial call should +pass (list). The cdr of this collects backtracking aliases made for +variables bound within (or...) patterns so that the caller +can bind them etc. Each of them has the form (USER-SYMBOL . GENSYM). +DATA is the expression for the data that this subpattern is +supposed to match against. + +Return Value has the form (BINDINGS . CONDITION), where +BINDINGS is the list of bindings to be made for SUBPAT +plus the subpatterns that contain/precede it. +Each element of BINDINGS has the form (VAR VALUE). +CONDITION is the condition to be tested to decide +whether SUBPAT (as well as the subpatterns that contain/precede it) matches," + (if (equal cond*-debug-pattern subpat) + (debug)) +;;; (push subpat subpat-log) + (cond ((eq subpat '_) + ;; _ as pattern makes no bindings and matches any data. + (cons bindings t)) + ((memq subpat '(nil t)) + (cons bindings `(eq ,subpat ,data))) + ((keywordp subpat) + (cons bindings `(eq ,subpat ,data))) + ((symbolp subpat) + (let ((this-binding (assq subpat bindings)) + (this-alias (assq subpat (cdr backtrack-aliases)))) + (if this-binding + ;; Variable already bound. + ;; Compare what this variable should be bound to + ;; to the data it is supposed to match. + ;; That is because we don't actually bind these bindings + ;; around the condition-testing expression. + (cons bindings `(equal ,(cadr this-binding) ,data)) + (if inside-or + (let (alias-gensym) + (if this-alias + ;; Inside `or' subpattern, if this symbol already + ;; has an alias for backtracking, just use that. + ;; This means the symbol was matched + ;; in a previous arm of the `or'. + (setq alias-gensym (cdr this-alias)) + ;; Inside `or' subpattern, but this symbol has no alias, + ;; make an alias for it. + (setq alias-gensym (gensym "ba")) + (push (cons subpat alias-gensym) (cdr backtrack-aliases))) + ;; Make a binding for the symbol, to its backtrack-alias, + ;; and set the alias (a gensym) to nil. + (cons `((,subpat ,alias-gensym) . ,bindings) + `(setq ,alias-gensym ,data))) + ;; Not inside `or' subpattern: ask for a binding for this symbol + ;; and say it does match whatever datum. + (cons `((,subpat ,data) . ,bindings) + t))))) + ;; Various constants. + ((numberp subpat) + (cons bindings `(eql ,subpat ,data))) + ;; Regular expressions as strings. + ((stringp subpat) + (cons bindings `(string-match ,(concat subpat "\\'") ,data))) + ;; All other atoms match with `equal'. + ((not (consp subpat)) + (cons bindings `(equal ,subpat ,data))) + ((not (consp (cdr subpat))) + (byte-compile-warn-x subpat "%s subpattern with malformed or missing arguments" (car subpat))) + ;; Regular expressions specified as list structure. + ;; (rx REGEXP VARS...) + ((eq (car subpat) 'rx) + (let* ((rxpat (concat (rx-to-string (cadr subpat) t) "\\'")) + (vars (cddr subpat)) setqs (varnum 0) + (match-exp `(string-match ,rxpat ,data))) + (if (null vars) + (cons bindings match-exp) + ;; There are variables to bind to the matched substrings. + (if (> (length vars) 10) + (byte-compile-warn-x vars "Too many variables specified for matched substrings")) + (dolist (elt vars) + (unless (symbolp elt) + (byte-compile-warn-x vars "Non-symbol %s given as name for matched substring" elt))) + ;; Bind these variables to nil, before the pattern. + (setq bindings (nconc (mapcar #'list vars) bindings)) + ;; Make the expressions to set the variables. + (setq setqs (mapcar + (lambda (var) + (prog1 `(setq ,var (match-string ,varnum ,data)) + (setq varnum (1+ varnum)))) + vars)) + (cons bindings `(if ,match-exp + (progn ,@setqs t)))))) + ;; Quoted object as constant to match with `eq' or `equal'. + ((eq (car subpat) 'quote) + (if (symbolp (car-safe (cdr-safe subpat))) + (cons bindings `(eq ,subpat ,data)) + (cons bindings `(equal ,subpat ,data)))) + ;; Match a call to `cons' by destructuring. + ((eq (car subpat) 'cons) + (let (car-result cdr-result car-exp cdr-exp) + (setq car-result + (cond*-subpat (nth 1 subpat) cdr-ignore bindings inside-or backtrack-aliases `(car ,data))) + (setq bindings (car car-result) + car-exp (cdr car-result)) + (setq cdr-result + (cond*-subpat (nth 2 subpat) cdr-ignore bindings inside-or backtrack-aliases `(cdr ,data))) + (setq bindings (car cdr-result) + cdr-exp (cdr cdr-result)) + (cons bindings + (cond*-and `((consp ,data) ,car-exp ,cdr-exp))))) + ;; Match a call to `list' by destructuring. + ((eq (car subpat) 'list) + (let ((i 0) expressions) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let ((result + (cond*-subpat this-elt cdr-ignore bindings inside-or + backtrack-aliases `(nth ,i ,data)))) + (setq bindings (car result)) + (push `(consp ,(if (zerop i) data `(nthcdr ,i ,data))) + expressions) + (setq i (1+ i)) + (push (cdr result) expressions))) + ;; Verify that list ends here, if we are supposed to check that. + (unless cdr-ignore + (push `(null (nthcdr ,i ,data)) expressions)) + (cons bindings (cond*-and (nreverse expressions))))) + ;; Match (apply 'vector (backquote-list* LIST...)), destructuring. + ((eq (car subpat) 'apply) + ;; We only try to handle the case generated by backquote. + ;; Convert it to a call to `vector' and handle that. + (let ((cleaned-up + `(vector . ,(cond*-un-backquote-list* (cdr (nth 2 subpat)))))) + ;; (cdr (nth 2 subpat)) gets LIST as above. + (cond*-subpat cleaned-up + cdr-ignore bindings inside-or backtrack-aliases data))) + ;; Match a call to `vector' by destructuring. + ((eq (car subpat) 'vector) + (let* ((elts (cdr subpat)) + (length (length elts)) + expressions (i 0)) + (dolist (elt elts) + (let* ((result + (cond*-subpat elt cdr-ignore bindings inside-or + backtrack-aliases `(aref ,i ,data)))) + (setq i (1+ i)) + (setq bindings (car result)) + (push (cdr result) expressions))) + (cons bindings + (cond*-and `((vectorp ,data) (= (length ,data) ,length) + . ,(nreverse expressions)))))) + ;; Subpattern to set the cdr-ignore flag. + ((eq (car subpat) 'cdr-ignore) + (cond*-subpat (cadr subpat) t bindings inside-or backtrack-aliases data)) + ;; Subpattern to clear the cdr-ignore flag. + ((eq (car subpat) 'cdr) + (cond*-subpat (cadr subpat) nil bindings inside-or backtrack-aliases data)) + ;; Handle conjunction subpatterns. + ((eq (car subpat) 'and) + (let (expressions) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let ((result + (cond*-subpat this-elt cdr-ignore bindings inside-or + backtrack-aliases data))) + (setq bindings (car result)) + (push (cdr result) expressions))) + (cons bindings (cond*-and (nreverse expressions))))) + ;; Handle disjunction subpatterns. + ((eq (car subpat) 'or) + ;; The main complexity is unsetting the pattern variables + ;; that tentatively match in an or-branch that later failed. + (let (expressions + (bindings-before-or bindings) + (aliases-before-or (cdr backtrack-aliases))) + ;; Check for bad structure of SUBPAT here? + (dolist (this-elt (cdr subpat)) + (let* ((bindings bindings-before-or) + bindings-to-clear expression + result) + (setq result + (cond*-subpat this-elt cdr-ignore bindings t + backtrack-aliases data)) + (setq bindings (car result)) + (setq expression (cdr result)) + ;; Were any bindings made by this arm of the disjunction? + (when (not (eq bindings bindings-before-or)) + ;; OK, arrange to clear their backtrack aliases + ;; if this arm does not match. + (setq bindings-to-clear bindings) + (let (clearing) + ;; For each of those bindings, ... + (while (not (eq bindings-to-clear bindings-before-or)) + ;; ... make an expression to set it to nil, in CLEARING. + (let* ((this-variable (caar bindings-to-clear)) + (this-backtrack (assq this-variable + (cdr backtrack-aliases)))) + (push `(setq ,(cdr this-backtrack) nil) clearing)) + (setq bindings-to-clear (cdr bindings-to-clear))) + ;; Wrap EXPRESSION to clear those backtrack aliases + ;; if EXPRESSION is false. + (setq expression + (if (null clearing) + expression + (if (null (cdr clearing)) + `(or ,expression + ,(car clearing)) + `(progn ,@clearing)))))) + (push expression expressions))) + ;; At end of (or...), EACH variable bound by any arm + ;; has a backtrack alias gensym. At run time, that gensym's value + ;; will be what was bound in the successful arm, or nil. + ;; Now make a binding for each variable from its alias gensym. + (let ((aliases (cdr backtrack-aliases))) + (while (not (eq aliases aliases-before-or)) + (push `(,(caar aliases) ,(cdar aliases)) bindings) + (pop aliases))) + (cons bindings `(or . ,(nreverse expressions))))) + ;; Expand cond*-macro call, treat result as a subpattern. + ((get (car subpat) 'cond*-expander) + ;; Treat result as a subpattern. + (cond*-subpat (funcall (get (car subpat) 'cond*-expander) subpat) + cdr-ignore bindings inside-or backtrack-aliases data)) + ((macrop (car subpat)) + (cond*-subpat (macroexpand subpat) cdr-ignore bindings inside-or + backtrack-aliases data)) + ;; Simple constrained variable, as in (symbolp x). + ((functionp (car subpat)) + ;; Without this, nested constrained variables just work. + (unless (symbolp (cadr subpat)) + (byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern")) + (let* ((rest-args (cddr subpat)) + ;; Process VAR to get a binding for it. + (result (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or backtrack-aliases data)) + (new-bindings (car result)) + (expression (cdr result)) + (combined-exp + (cond*-and (list `(,(car subpat) ,data . ,rest-args) expression)))) + + (cons new-bindings + (cond*-bind-around new-bindings combined-exp)))) + ;; Generalized constrained variable: (constrain VAR EXP) + ((eq (car subpat) 'constrain) + ;; Without this, nested constrained variables just work. + (unless (symbolp (cadr subpat)) + (byte-compile-warn-x subpat "Complex pattern nested in constrained variable pattern")) + ;; Process VAR to get a binding for it. + (let ((result + (cond*-subpat (cadr subpat) cdr-ignore bindings inside-or + backtrack-aliases data))) + (cons (car result) + ;; This is the test condition. + (cond*-bind-around (car result) (nth 2 subpat))))) + (t + (byte-compile-warn-x subpat "Undefined pattern type `%s' in `cond*'" (car subpat))))) + +;;; Subroutines of cond*-subpat. + +(defun cond*-bind-around (bindings exp) + "Wrap a `let*' around EXP, to bind those of BINDINGS used in EXP." + (let ((what-to-bind (cond*-used-within bindings exp))) + (if what-to-bind + `(let* ,(nreverse what-to-bind) ,exp) + exp))) + +(defun cond*-used-within (bindings exp) + "Return the list of those bindings in BINDINGS which EXP refers to. +This operates naively and errs on the side of overinclusion, +and does not distinguish function names from variable names. +That is safe for the purpose this is used for." + (cond ((symbolp exp) + (let ((which (assq exp bindings))) + (if which (list which)))) + ((listp exp) + (let (combined (rest exp)) + ;; Find the bindings used in each element of EXP + ;; and merge them together in COMBINED. + ;; It would be simpler to use dolist at each level, + ;; but this avoids errors from improper lists. + (while rest + (let ((in-this-elt (cond*-used-within bindings (car rest)))) + (while in-this-elt + ;; Don't insert the same binding twice. + (unless (memq (car-safe in-this-elt) combined) + (push (car-safe in-this-elt) combined)) + (pop in-this-elt))) + (pop rest)) + combined)))) + +;; Construct a simplified equivalent to `(and . ,CONJUNCTS), +;; assuming that it will be used only as a truth value. +;; We don't bother checking for nil in CONJUNCTS +;; because that would not normally happen. +(defun cond*-and (conjuncts) + (setq conjuncts (remq t conjuncts)) + (if (null conjuncts) + t + (if (null (cdr conjuncts)) + (car conjuncts) + `(and . ,conjuncts)))) + +;; Convert the arguments in a form that calls `backquote-list*' +;; into equivalent args to pass to `list'. +;; We assume the last argument has the form 'LIST. +;; That means quotify each of that list's elements, +;; and preserve the other arguments in front of them. +(defun cond*-un-backquote-list* (args) + (if (cdr args) + (cons (car args) + (cond*-un-backquote-list* (cdr args))) + (mapcar (lambda (x) (list 'quote x)) (cadr (car args))))) + +(provide 'cond-star) + +;;; cond-star.el ends here diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index a140027839e..9c429828b13 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -763,6 +763,59 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." ;;; easy-mmode-define-navigation ;;; +(defun easy-mmode--prev (re name count &optional endfun narrowfun) + "Go to the COUNT'th previous occurrence of RE. + +If none, error with NAME. + +ENDFUN and NARROWFUN are treated like in `easy-mmode-define-navigation'." + (unless count (setq count 1)) + (if (< count 0) (easy-mmode--next re name (- count) endfun narrowfun) + (let ((re-narrow (and narrowfun (prog1 (buffer-narrowed-p) (widen))))) + ;; If point is inside a match for RE, move to its beginning like + ;; `backward-sexp' and other movement commands. + (when (and (not (zerop count)) + (save-excursion + ;; Make sure we're out of the current match if any. + (goto-char (if (re-search-backward re nil t 1) + (match-end 0) (point-min))) + (re-search-forward re nil t 1)) + (< (match-beginning 0) (point) (match-end 0))) + (goto-char (match-beginning 0)) + (setq count (1- count))) + (unless (re-search-backward re nil t count) + (user-error "No previous %s" name)) + (when re-narrow (funcall narrowfun))))) + +(defun easy-mmode--next (re name count &optional endfun narrowfun) + "Go to the next COUNT'th occurrence of RE. + +If none, error with NAME. + +ENDFUN and NARROWFUN are treated like in `easy-mmode-define-navigation'." + (unless count (setq count 1)) + (if (< count 0) (easy-mmode--prev re name (- count) endfun narrowfun) + (if (looking-at re) (setq count (1+ count))) + (let ((re-narrow (and narrowfun (prog1 (buffer-narrowed-p) (widen))))) + (if (not (re-search-forward re nil t count)) + (if (looking-at re) + (goto-char (or (if endfun (funcall endfun)) (point-max))) + (user-error "No next %s" name)) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer)) + (called-interactively-p 'interactive)) + (let ((endpt (or (save-excursion + (if endfun (funcall endfun) + (re-search-forward re nil t 2))) + (point-max)))) + (unless (pos-visible-in-window-p endpt nil t) + (let ((ws (window-start))) + (recenter '(0)) + (if (< (window-start) ws) + ;; recenter scrolled in the wrong direction! + (set-window-start nil ws))))))) + (when re-narrow (funcall narrowfun))))) + (defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun &rest body) "Define BASE-next and BASE-prev to navigate in the buffer. @@ -780,53 +833,23 @@ BODY is executed after moving to the destination location." (let* ((base-name (symbol-name base)) (prev-sym (intern (concat base-name "-prev"))) (next-sym (intern (concat base-name "-next"))) - (when-narrowed - (lambda (body) - (if (null narrowfun) body - `(let ((was-narrowed (prog1 (buffer-narrowed-p) (widen)))) - ,body - (when was-narrowed (funcall #',narrowfun))))))) + (endfun (when endfun `#',endfun)) + (narrowfun (when narrowfun `#',narrowfun))) (unless name (setq name base-name)) - ;; FIXME: Move most of those functions's bodies to helper functions! `(progn (defun ,next-sym (&optional count) ,(format "Go to the next COUNT'th %s. Interactively, COUNT is the prefix numeric argument, and defaults to 1." name) (interactive "p") - (unless count (setq count 1)) - (if (< count 0) (,prev-sym (- count)) - (if (looking-at ,re) (setq count (1+ count))) - ,(funcall when-narrowed - `(if (not (re-search-forward ,re nil t count)) - (if (looking-at ,re) - (goto-char (or ,(if endfun `(funcall #',endfun)) (point-max))) - (user-error "No next %s" ,name)) - (goto-char (match-beginning 0)) - (when (and (eq (current-buffer) (window-buffer)) - (called-interactively-p 'interactive)) - (let ((endpt (or (save-excursion - ,(if endfun `(funcall #',endfun) - `(re-search-forward ,re nil t 2))) - (point-max)))) - (unless (pos-visible-in-window-p endpt nil t) - (let ((ws (window-start))) - (recenter '(0)) - (if (< (window-start) ws) - ;; recenter scrolled in the wrong direction! - (set-window-start nil ws)))))))) - ,@body)) + (easy-mmode--next ,re ,name count ,endfun ,narrowfun) + ,@body) (put ',next-sym 'definition-name ',base) (defun ,prev-sym (&optional count) ,(format "Go to the previous COUNT'th %s. -Interactively, COUNT is the prefix numeric argument, and defaults to 1." - (or name base-name)) +Interactively, COUNT is the prefix numeric argument, and defaults to 1." name) (interactive "p") - (unless count (setq count 1)) - (if (< count 0) (,next-sym (- count)) - ,(funcall when-narrowed - `(unless (re-search-backward ,re nil t count) - (user-error "No previous %s" ,name))) - ,@body)) + (easy-mmode--prev ,re ,name count ,endfun ,narrowfun) + ,@body) (put ',prev-sym 'definition-name ',base)))) ;; When deleting these two, also delete them from loaddefs-gen.el. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index deebe5109bd..d09229ee890 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1803,12 +1803,21 @@ infinite loops when the code/environment contains a circular object.") (cl-defmethod edebug--match-&-spec-op ((_ (eql '&interpose)) cursor specs) "Compute the specs for `&interpose SPEC FUN ARGS...'. -Extracts the head of the data by matching it against SPEC, -and then matches the rest by calling (FUN HEAD PF ARGS...) -where PF is the parsing function which FUN can call exactly once, -passing it the specs that it needs to match. -Note that HEAD will always be a list, since specs are defined to match -a sequence of elements." +SPECS is a list (SPEC FUN ARGS...), where SPEC is an edebug +specification, FUN is the function from the &interpose form which +transforms the edebug spec, and the optional ARGS is a list of final +arguments to be supplied to FUN. + +Extracts the head of the data by matching it against SPEC, and then +matches the rest by calling (FUN HEAD PF ARGS...). PF is the parsing +function which FUN must call exactly once, passing it one argument, the +specs that it needs to match. FUN's value must be the value of this PF +call, which in turn will be the value of this function. + +Note that HEAD will always be a list, since specs is defined to match a +sequence of elements." + ;; Note: PF is called in FUN rather than in this function, so that it + ;; can use any dynamic bindings created there. (pcase-let* ((`(,spec ,fun . ,args) specs) (exps (edebug-cursor-expressions cursor)) @@ -1817,14 +1826,14 @@ a sequence of elements." (length (edebug-cursor-expressions cursor)))) (head (seq-subseq exps 0 consumed))) (cl-assert (eq (edebug-cursor-expressions cursor) (nthcdr consumed exps))) - (apply fun `(,head - ,(lambda (newspecs) - ;; FIXME: What'd be the difference if we used - ;; `edebug-match-sublist', which is what - ;; `edebug-list-form-args' uses for the similar purpose - ;; when matching "normal" forms? - (append instrumented-head (edebug-match cursor newspecs))) - ,@args)))) + (apply fun head + (lambda (newspecs) + ;; FIXME: What'd be the difference if we used + ;; `edebug-match-sublist', which is what + ;; `edebug-list-form-args' uses for the similar purpose + ;; when matching "normal" forms? + (append instrumented-head (edebug-match cursor newspecs))) + args))) (cl-defmethod edebug--match-&-spec-op ((_ (eql '¬)) cursor specs) ;; If any specs match, then fail @@ -3922,8 +3931,8 @@ be installed in `emacs-lisp-mode-map'.") (define-obsolete-variable-alias 'global-edebug-prefix 'edebug-global-prefix "28.1") (defvar edebug-global-prefix - (when-let ((binding - (car (where-is-internal 'Control-X-prefix (list global-map))))) + (when-let* ((binding + (car (where-is-internal 'Control-X-prefix (list global-map))))) (concat binding [?X])) "Prefix key for global edebug commands, available from any buffer.") @@ -4659,8 +4668,8 @@ instrumentation for, defaulting to all functions." functions))))) ;; Remove instrumentation. (dolist (symbol functions) - (when-let ((unwrapped - (edebug--unwrap*-symbol-function symbol))) + (when-let* ((unwrapped + (edebug--unwrap*-symbol-function symbol))) (edebug--strip-plist symbol) (defalias symbol unwrapped))) (message "Removed edebug instrumentation from %s" diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 74f5e21db7d..98d9a2d2f4f 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -769,10 +769,10 @@ dynamically set from ARGS." (let* ((slot (aref slots i)) (slot-name (eieio-slot-descriptor-name slot)) (initform (cl--slot-descriptor-initform slot))) - (unless (or (when-let ((initarg - (car (rassq slot-name - (eieio--class-initarg-tuples - this-class))))) + (unless (or (when-let* ((initarg + (car (rassq slot-name + (eieio--class-initarg-tuples + this-class))))) (plist-get initargs initarg)) ;; Those slots whose initform is constant already have ;; the right value set in the default-object. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index cd60f9f457f..8469440c982 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -395,8 +395,8 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(when-let ((testfile ,(or (macroexp-file-name) - buffer-file-name))) + `(when-let* ((testfile ,(or (macroexp-file-name) + buffer-file-name))) (let ((default-directory (file-name-directory testfile))) (file-truename (if (file-accessible-directory-p "resources/") diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 105c44d49aa..97aa233f6e2 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -328,8 +328,8 @@ DATA is displayed to the user and should state the reason for skipping." (unless (eql ,value ',default-value) (list :value ,value)) (unless (eql ,value ',default-value) - (when-let ((-explainer- - (ert--get-explainer ',fn-name))) + (when-let* ((-explainer- + (ert--get-explainer ',fn-name))) (list :explanation (apply -explainer- ,args))))) value) @@ -1316,13 +1316,9 @@ empty string." (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." - (let ((begin (point)) - (cols (current-column)) - (pp-escape-newlines t) + (let ((pp-escape-newlines t) (print-escape-control-characters t)) - (pp object (current-buffer)) - (unless (bolp) (insert "\n")) - (indent-rigidly begin (point) cols))) + (pp object (current-buffer)))) (defun ert--insert-infos (result) "Insert `ert-info' infos from RESULT into current buffer. @@ -1356,10 +1352,10 @@ RESULT must be an `ert-test-result-with-condition'." (defun ert-test-location (test) "Return a string description the source location of TEST." - (when-let ((loc - (ignore-errors - (find-function-search-for-symbol - (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (when-let* ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) (let* ((buffer (car loc)) (point (cdr loc)) (file (file-relative-name (buffer-file-name buffer))) @@ -1552,11 +1548,11 @@ test packages depend on each other, it might be helpful.") "Write a JUnit test report, generated from STATS." ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format ;; https://llg.cubic.org/docs/junit/ - (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) - (test-file (symbol-file symbol 'ert--test)) - (test-report - (file-name-with-extension - (or ert-load-file-name test-file) "xml"))) + (when-let* ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) (with-temp-file test-report (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" @@ -2910,10 +2906,10 @@ write erts files." (setq end-before end-after start-after start-before)) ;; Update persistent specs. - (when-let ((point-char (assq 'point-char specs))) + (when-let* ((point-char (assq 'point-char specs))) (setq gen-specs (map-insert gen-specs 'point-char (cdr point-char)))) - (when-let ((code (cdr (assq 'code specs)))) + (when-let* ((code (cdr (assq 'code specs)))) (setq gen-specs (map-insert gen-specs 'code (car (read-from-string code))))) ;; Get the "after" strings. @@ -2921,12 +2917,12 @@ write erts files." (insert-buffer-substring file-buffer start-after end-after) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-after-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) ;; Get the expected "after" point. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (goto-char (point-min)) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)) @@ -2937,13 +2933,13 @@ write erts files." (insert-buffer-substring file-buffer start-before end-before) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-before-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) (goto-char (point-min)) ;; Place point in the specified place. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)))) (let ((code (cdr (assq 'code gen-specs)))) diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index ce783983b77..f3ddf9f81c9 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -26,7 +26,7 @@ ;; The funniest thing about this is that I can't imagine why a package ;; so obviously useful as this hasn't been written before!! ;; ;;; find-func -;; (find-function-setup-keys) +;; (find-function-mode 1) ;; ;; or just: ;; @@ -323,6 +323,8 @@ customizing the candidate completions." (switch-to-buffer (find-file-noselect (find-library-name library))) (run-hooks 'find-function-after-hook))) +(defvar find-function--read-history-library nil) + ;;;###autoload (defun read-library-name () "Read and return a library name, defaulting to the one near point. @@ -351,12 +353,14 @@ if non-nil)." (when (and def (not (test-completion def table))) (setq def nil)) (completing-read (format-prompt "Library name" def) - table nil nil nil nil def)) + table nil nil nil + 'find-function--read-history-library def)) (let ((files (read-library-name--find-files dirs suffixes))) (when (and def (not (member def files))) (setq def nil)) (completing-read (format-prompt "Library name" def) - files nil t nil nil def))))) + files nil t nil + 'find-function--read-history-library def))))) (defun read-library-name--find-files (dirs suffixes) "Return a list of all files in DIRS that match SUFFIXES." @@ -575,6 +579,10 @@ is non-nil, signal an error instead." (let ((func-lib (find-function-library function lisp-only t))) (find-function-search-for-symbol (car func-lib) nil (cdr func-lib)))) +(defvar find-function--read-history-function nil) +(defvar find-function--read-history-variable nil) +(defvar find-function--read-history-face nil) + (defun find-function-read (&optional type) "Read and return an interned symbol, defaulting to the one near point. @@ -597,7 +605,9 @@ otherwise uses `variable-at-point'." (list (intern (completing-read (format-prompt "Find %s" symb prompt-type) obarray predicate - 'lambda nil nil (and symb (symbol-name symb))))))) + 'lambda nil + (intern (format "find-function--read-history-%s" prompt-type)) + (and symb (symbol-name symb))))))) (defun find-function-do-it (symbol type switch-fn) "Find Emacs Lisp SYMBOL in a buffer and display it. @@ -796,20 +806,35 @@ See `find-function-on-key'." (find-variable-other-window symb)))) ;;;###autoload +(define-minor-mode find-function-mode + "Enable some key bindings for the `find-function' family of functions." + :group 'find-function :version "31.1" :global t :lighter nil + ;; For compatibility with the historical behavior of the old + ;; `find-function-setup-keys', define our bindings at the precedence + ;; level of the global map. + :keymap nil + (pcase-dolist (`(,map ,key ,cmd) + `((,ctl-x-map "F" find-function) + (,ctl-x-4-map "F" find-function-other-window) + (,ctl-x-5-map "F" find-function-other-frame) + (,ctl-x-map "K" find-function-on-key) + (,ctl-x-4-map "K" find-function-on-key-other-window) + (,ctl-x-5-map "K" find-function-on-key-other-frame) + (,ctl-x-map "V" find-variable) + (,ctl-x-4-map "V" find-variable-other-window) + (,ctl-x-5-map "V" find-variable-other-frame) + (,ctl-x-map "L" find-library) + (,ctl-x-4-map "L" find-library-other-window) + (,ctl-x-5-map "L" find-library-other-frame))) + (if find-function-mode + (keymap-set map key cmd) + (keymap-unset map key t)))) + +;;;###autoload (defun find-function-setup-keys () - "Define some key bindings for the `find-function' family of functions." - (define-key ctl-x-map "F" 'find-function) - (define-key ctl-x-4-map "F" 'find-function-other-window) - (define-key ctl-x-5-map "F" 'find-function-other-frame) - (define-key ctl-x-map "K" 'find-function-on-key) - (define-key ctl-x-4-map "K" 'find-function-on-key-other-window) - (define-key ctl-x-5-map "K" 'find-function-on-key-other-frame) - (define-key ctl-x-map "V" 'find-variable) - (define-key ctl-x-4-map "V" 'find-variable-other-window) - (define-key ctl-x-5-map "V" 'find-variable-other-frame) - (define-key ctl-x-map "L" 'find-library) - (define-key ctl-x-4-map "L" 'find-library-other-window) - (define-key ctl-x-5-map "L" 'find-library-other-frame)) + "Turn on `find-function-mode', which see." + (find-function-mode 1)) +(make-obsolete 'find-function-setup-keys 'find-function-mode "31.1") (provide 'find-func) diff --git a/lisp/emacs-lisp/icons.el b/lisp/emacs-lisp/icons.el index 847ef53a1cb..144b60a2c1d 100644 --- a/lisp/emacs-lisp/icons.el +++ b/lisp/emacs-lisp/icons.el @@ -119,7 +119,7 @@ If OBJECT is an icon, return the icon properties." (setq spec (icons--copy-spec spec)) ;; Let the Customize theme override. (unless inhibit-theme - (when-let ((theme-spec (cadr (car (get icon 'theme-icon))))) + (when-let* ((theme-spec (cadr (car (get icon 'theme-icon))))) (setq spec (icons--merge-spec (icons--copy-spec theme-spec) spec)))) ;; Inherit from the parent spec (recursively). (unless inhibit-inheritance @@ -149,15 +149,15 @@ If OBJECT is an icon, return the icon properties." ;; Go through all the variations in this section ;; and return the first one we can display. (dolist (icon (icon-spec-values type-spec)) - (when-let ((result - (icons--create type icon type-keywords))) + (when-let* ((result + (icons--create type icon type-keywords))) (throw 'found - (if-let ((face (plist-get type-keywords :face))) + (if-let* ((face (plist-get type-keywords :face))) (propertize result 'face face) result))))))))) (unless icon-string (error "Couldn't find any way to display the %s icon" name)) - (when-let ((help (plist-get keywords :help-echo))) + (when-let* ((help (plist-get keywords :help-echo))) (setq icon-string (propertize icon-string 'help-echo help))) (propertize icon-string 'rear-nonsticky t))))) @@ -200,18 +200,18 @@ present if the icon is represented by an image." " " 'display (let ((props (append - (if-let ((height (plist-get keywords :height))) + (if-let* ((height (plist-get keywords :height))) (list :height (if (eq height 'line) (window-default-line-height) height))) - (if-let ((width (plist-get keywords :width))) + (if-let* ((width (plist-get keywords :width))) (list :width (if (eq width 'font) (default-font-width) width))) '(:scale 1) - (if-let ((rotation (plist-get keywords :rotation))) + (if-let* ((rotation (plist-get keywords :rotation))) (list :rotation rotation)) - (if-let ((margin (plist-get keywords :margin))) + (if-let* ((margin (plist-get keywords :margin))) (list :margin margin)) (list :ascent (if (plist-member keywords :ascent) (plist-get keywords :ascent) @@ -219,10 +219,10 @@ present if the icon is represented by an image." (apply 'create-image file nil nil props)))))) (cl-defmethod icons--create ((_type (eql 'emoji)) icon _keywords) - (when-let ((font (and (display-multi-font-p) - ;; FIXME: This is not enough for ensuring - ;; display of color Emoji. - (car (internal-char-font nil ?🟠))))) + (when-let* ((font (and (display-multi-font-p) + ;; FIXME: This is not enough for ensuring + ;; display of color Emoji. + (car (internal-char-font nil ?🟠))))) (and (font-has-char-p font (aref icon 0)) icon))) diff --git a/lisp/emacs-lisp/let-alist.el b/lisp/emacs-lisp/let-alist.el index cdd476d9df6..b1822519999 100644 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@ -36,22 +36,23 @@ ;; symbol inside body is let-bound to their cdrs in the alist. Dotted ;; symbol is any symbol starting with a `.'. Only those present in ;; the body are let-bound and this search is done at compile time. +;; A number will result in a list index. ;; ;; For instance, the following code ;; ;; (let-alist alist -;; (if (and .title .body) +;; (if (and .title.0 .body) ;; .body ;; .site ;; .site.contents)) ;; ;; essentially expands to ;; -;; (let ((.title (cdr (assq 'title alist))) +;; (let ((.title.0 (nth 0 (cdr (assq 'title alist)))) ;; (.body (cdr (assq 'body alist))) ;; (.site (cdr (assq 'site alist))) ;; (.site.contents (cdr (assq 'contents (cdr (assq 'site alist)))))) -;; (if (and .title .body) +;; (if (and .title.0 .body) ;; .body ;; .site ;; .site.contents)) @@ -93,14 +94,17 @@ symbol, and each cdr is the same symbol without the `.'." (if (string-match "\\`\\." name) clean (let-alist--list-to-sexp - (mapcar #'intern (nreverse (split-string name "\\."))) + (mapcar #'read (nreverse (split-string name "\\."))) variable)))) (defun let-alist--list-to-sexp (list var) "Turn symbols LIST into recursive calls to `cdr' `assq' on VAR." - `(cdr (assq ',(car list) - ,(if (cdr list) (let-alist--list-to-sexp (cdr list) var) - var)))) + (let ((sym (car list)) + (rest (if (cdr list) (let-alist--list-to-sexp (cdr list) var) + var))) + (cond + ((numberp sym) `(nth ,sym ,rest)) + (t `(cdr (assq ',sym ,rest)))))) (defun let-alist--remove-dot (symbol) "Return SYMBOL, sans an initial dot." @@ -116,22 +120,23 @@ symbol, and each cdr is the same symbol without the `.'." "Let-bind dotted symbols to their cdrs in ALIST and execute BODY. Dotted symbol is any symbol starting with a `.'. Only those present in BODY are let-bound and this search is done at compile time. +A number will result in a list index. For instance, the following code (let-alist alist - (if (and .title .body) + (if (and .title.0 .body) .body .site .site.contents)) essentially expands to - (let ((.title (cdr (assq \\='title alist))) + (let ((.title (nth 0 (cdr (assq \\='title alist)))) (.body (cdr (assq \\='body alist))) (.site (cdr (assq \\='site alist))) (.site.contents (cdr (assq \\='contents (cdr (assq \\='site alist)))))) - (if (and .title .body) + (if (and .title.0 .body) .body .site .site.contents)) diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index 8b0494dc5cb..3c7f047d203 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -1,7 +1,6 @@ ;;; lisp-mnt.el --- utility functions for Emacs Lisp maintainers -*- lexical-binding:t -*- -;; Copyright (C) 1992, 1994, 1997, 2000-2024 Free Software Foundation, -;; Inc. +;; Copyright (C) 1992-2024 Free Software Foundation, Inc. ;; Author: Eric S. Raymond <esr@thyrsus.com> ;; Maintainer: emacs-devel@gnu.org @@ -106,8 +105,10 @@ ;; * Code line --- exists so Lisp can know where commentary and/or ;; change-log sections end. ;; -;; * Footer line --- marks end-of-file so it can be distinguished from -;; an expanded formfeed or the results of truncation. +;; * Footer line --- marks end-of-file so it can be distinguished +;; from an expanded formfeed or the results of truncation. This is +;; required for a package to be installable by package.el in Emacs 29.1 +;; or earlier, but is optional in later versions. ;;; Code: @@ -467,6 +468,29 @@ package version (a string)." (lm--prepare-package-dependencies (package-read-from-string (mapconcat #'identity require-lines " ")))))) +(defun lm-package-needs-footer-line (&optional file) + "Return non-nil if package in current buffer needs a footer line. + +Footer lines (sometimes referred to as \"terminating comments\") look +like this: + + ;;; some-cool-package.el ends here + +Such lines are required for a package to be installable by package.el in +Emacs 29.1 or earlier, but are optional in later versions. If the +package depends on a version of Emacs where package.el requires such +comments, or if no version requirement is specified, return non-nil. + +If optional argument FILE is non-nil, use that file instead of the +current buffer." + (lm-with-file file + ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs + ;; version is specified as 30.1 or later. + (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) + (lm-package-requires))))) + (or (null min-emacs) + (version< min-emacs "30.1"))))) + (defun lm-keywords (&optional file) "Return the keywords given in file FILE, or current buffer if FILE is nil. The return is a `downcase'-ed string, or nil if no keywords @@ -533,7 +557,6 @@ absent, return nil." (if (and page (string-match (rx bol "<" (+ nonl) ">" eol) page)) (substring page 1 -1) page))) -(defalias 'lm-homepage #'lm-website) ; for backwards-compatibility ;;; Verification and synopses @@ -552,7 +575,7 @@ says display \"OK\" in temp buffer for files that have no problems. Optional argument VERBOSE specifies verbosity level. Optional argument NON-FSF-OK if non-nil means a non-FSF copyright notice is allowed." - ;; FIXME: Make obsolete in favor of checkdoc? + (declare (obsolete checkdoc "31.1")) (interactive (list nil nil t)) (let* ((ret (and verbose "Ok")) name) @@ -593,11 +616,12 @@ copyright notice is allowed." ((not (lm-code-start)) "Can't find a `Code' section marker") ((progn - (goto-char (point-max)) - (not - (re-search-backward - (rx bol ";;; " (regexp name) " ends here") - nil t))) + (when (lm-package-needs-footer-line) + (goto-char (point-max)) + (not + (re-search-backward + (rx bol ";;; " (regexp name) " ends here") + nil t)))) "Can't find the footer line") ((not (and (lm-copyright-mark) (lm-crack-copyright))) "Can't find a valid copyright notice") @@ -663,6 +687,7 @@ Prompts for bug subject TOPIC. Leaves you in a mail buffer." (define-obsolete-function-alias 'lm-code-mark #'lm-code-start "30.1") (define-obsolete-function-alias 'lm-commentary-mark #'lm-commentary-start "30.1") (define-obsolete-function-alias 'lm-history-mark #'lm-history-start "30.1") +(define-obsolete-function-alias 'lm-homepage #'lm-website "31.1") (provide 'lisp-mnt) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 601cc7bf712..4b89eb91387 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -490,14 +490,17 @@ This will generate compile-time constants from BINDINGS." (2 font-lock-constant-face nil t)) ;; Words inside \\[], \\<>, \\{} or \\`' tend to be for ;; `substitute-command-keys'. - (,(rx "\\\\" (or (seq "[" (group-n 1 lisp-mode-symbol) "]") + (,(rx "\\\\" (or (seq "[" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) "]") (seq "`" (group-n 1 ;; allow multiple words, e.g. "C-x a" lisp-mode-symbol (* " " lisp-mode-symbol)) "'"))) (1 font-lock-constant-face prepend)) - (,(rx "\\\\" (or (seq "<" (group-n 1 lisp-mode-symbol) ">") - (seq "{" (group-n 1 lisp-mode-symbol) "}"))) + (,(rx "\\\\" (or (seq "<" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) ">") + (seq "{" + (group-n 1 (seq lisp-mode-symbol (not "\\"))) "}"))) (1 font-lock-variable-name-face prepend)) ;; Ineffective backslashes (typically in need of doubling). ("\\(\\\\\\)\\([^\"\\]\\)" @@ -1153,7 +1156,7 @@ is the buffer position of the start of the containing expression." (defun lisp--local-defform-body-p (state) "Return non-nil when at local definition body according to STATE. STATE is the `parse-partial-sexp' state for current position." - (when-let ((start-of-innermost-containing-list (nth 1 state))) + (when-let* ((start-of-innermost-containing-list (nth 1 state))) (let* ((parents (nth 9 state)) (first-cons-after (cdr parents)) (second-cons-after (cdr first-cons-after)) @@ -1171,11 +1174,11 @@ STATE is the `parse-partial-sexp' state for current position." (let (local-definitions-starting-point) (and (save-excursion (goto-char (1+ second-order-parent)) - (when-let ((head (ignore-errors - ;; FIXME: This does not distinguish - ;; between reading nil and a read error. - ;; We don't care but still, better fix this. - (read (current-buffer))))) + (when-let* ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* cl-symbol-macrolet)) ;; In what follows, we rely on (point) returning non-nil. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index e65eec508d9..c9e27e78c33 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -36,8 +36,8 @@ This is only necessary if the opening paren or brace is not in column 0. See function `beginning-of-defun'." :type '(choice (const nil) regexp) + :local t :group 'lisp) -(make-variable-buffer-local 'defun-prompt-regexp) (defcustom parens-require-spaces t "If non-nil, add whitespace as needed when inserting parentheses. @@ -850,10 +850,18 @@ It's used by the command `delete-pair'. The value 0 disables blinking." :group 'lisp :version "28.1") +(defcustom delete-pair-push-mark nil + "Non-nil means `delete-pair' pushes mark at end of delimited region." + :type 'boolean + :group 'lisp + :version "31.1") + (defun delete-pair (&optional arg) "Delete a pair of characters enclosing ARG sexps that follow point. A negative ARG deletes a pair around the preceding ARG sexps instead. -The option `delete-pair-blink-delay' can disable blinking." +The option `delete-pair-blink-delay' can disable blinking. With +`delete-pair-push-mark' enabled, pushes a mark at the end of the +enclosed region." (interactive "P") (if arg (setq arg (prefix-numeric-value arg)) @@ -887,7 +895,9 @@ The option `delete-pair-blink-delay' can disable blinking." (when (and (numberp delete-pair-blink-delay) (> delete-pair-blink-delay 0)) (sit-for delete-pair-blink-delay)) - (delete-char -1))) + (delete-char -1) + (when delete-pair-push-mark + (push-mark)))) (delete-char 1)))) (defun raise-sexp (&optional n) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el index bc075fd296d..6e843f741d8 100644 --- a/lisp/emacs-lisp/loaddefs-gen.el +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -295,7 +295,7 @@ expression, in which case we want to handle forms differently." (null (plist-get props :set)) (error nil))) ;; Propagate the :safe property to the loaddefs file. - ,@(when-let ((safe (plist-get props :safe))) + ,@(when-let* ((safe (plist-get props :safe))) `((put ',varname 'safe-local-variable ,safe)))))) ;; Extract theme properties. @@ -413,8 +413,8 @@ don't include." (save-excursion ;; Since we're "open-coding", we have to repeat more ;; complicated logic in `hack-local-variables'. - (when-let ((beg - (re-search-forward "read-symbol-shorthands: *" nil t))) + (when-let* ((beg + (re-search-forward "read-symbol-shorthands: *" nil t))) ;; `read-symbol-shorthands' alist ends with two parens. (let* ((end (re-search-forward ")[;\n\s]*)")) (commentless (replace-regexp-in-string @@ -499,7 +499,7 @@ don't include." (when (and autoload-compute-prefixes compute-prefixes) (with-demoted-errors "%S" - (when-let + (when-let* ((form (loaddefs-generate--compute-prefixes load-name))) ;; This output needs to always go in the main loaddefs.el, ;; regardless of `generated-autoload-file'. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 4524eccc7ef..053db927b67 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -41,7 +41,8 @@ This is to preserve the data in it in the event of a (defmacro macroexp--with-extended-form-stack (expr &rest body) "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." - (declare (indent 1)) + (declare (indent 1) + (debug (sexp body))) `(let ((byte-compile-form-stack (cons ,expr byte-compile-form-stack))) ,@body)) diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index b7bc5536f78..71be928e30f 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -170,56 +170,60 @@ DOC should be a doc string, and ARGS are keywords as applicable to "create unique index multisession_idx on multisession (package, key)"))))) (cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) - (multisession--ensure-db) - (let ((id (list (multisession--package object) - (multisession--key object)))) - (cond - ;; We have no value yet; check the database. - ((eq (multisession--cached-value object) multisession--unbound) - (let ((stored - (car - (sqlite-select - multisession--db - "select value, sequence from multisession where package = ? and key = ?" - id)))) - (if stored - (let ((value (car (read-from-string (car stored))))) - (setf (multisession--cached-value object) value - (multisession--cached-sequence object) (cadr stored)) - value) - ;; Nothing; return the initial value. - (multisession--initial-value object)))) - ;; We have a value, but we want to update in case some other - ;; Emacs instance has updated. - ((multisession--synchronized object) - (let ((stored - (car - (sqlite-select - multisession--db - "select value, sequence from multisession where sequence > ? and package = ? and key = ?" - (cons (multisession--cached-sequence object) id))))) - (if stored - (let ((value (car (read-from-string (car stored))))) - (setf (multisession--cached-value object) value - (multisession--cached-sequence object) (cadr stored)) - value) - ;; Nothing, return the cached value. - (multisession--cached-value object)))) - ;; Just return the cached value. - (t - (multisession--cached-value object))))) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (multisession--ensure-db) + (let ((id (list (multisession--package object) + (multisession--key object)))) + (cond + ;; We have no value yet; check the database. + ((eq (multisession--cached-value object) multisession--unbound) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where package = ? and key = ?" + id)))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing; return the initial value. + (multisession--initial-value object)))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where sequence > ? and package = ? and key = ?" + (cons (multisession--cached-sequence object) id))))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing, return the cached value. + (multisession--cached-value object)))) + ;; Just return the cached value. + (t + (multisession--cached-value object)))))) (cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) object value) - (catch 'done - (let ((i 0)) - (while (< i 10) - (condition-case nil - (throw 'done (multisession--set-value-sqlite object value)) - (sqlite-locked-error - (setq i (1+ i)) - (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) - (signal 'sqlite-locked-error "Database is locked")))) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (catch 'done + (let ((i 0)) + (while (< i 10) + (condition-case nil + (throw 'done (multisession--set-value-sqlite object value)) + (sqlite-locked-error + (setq i (1+ i)) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal 'sqlite-locked-error "Database is locked"))))) (defun multisession--set-value-sqlite (object value) (multisession--ensure-db) @@ -245,16 +249,20 @@ DOC should be a doc string, and ARGS are keywords as applicable to (setf (multisession--cached-value object) value)))) (cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) - (multisession--ensure-db) - (sqlite-select - multisession--db - "select package, key, value from multisession order by package, key")) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (multisession--ensure-db) + (sqlite-select + multisession--db + "select package, key, value from multisession order by package, key"))) (cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) - (sqlite-execute multisession--db - "delete from multisession where package = ? and key = ?" - (list (multisession--package object) - (multisession--key object)))) + (if (not (sqlite-available-p)) + (cl-call-next-method) + (sqlite-execute multisession--db + "delete from multisession where package = ? and key = ?" + (list (multisession--package object) + (multisession--key object))))) ;; Files Backend @@ -420,8 +428,8 @@ storage method to list." (tabulated-list-print t) (goto-char (point-min)) (when id - (when-let ((match - (text-property-search-forward 'tabulated-list-id id t))) + (when-let* ((match + (text-property-search-forward 'tabulated-list-id id t))) (goto-char (prop-match-beginning match)))))) (defun multisession-delete-value (id) @@ -448,7 +456,7 @@ storage method to list." (let* ((object (or ;; If the multisession variable already exists, use ;; it (so that we update it). - (if-let (sym (intern-soft (cdr id))) + (if-let* ((sym (intern-soft (cdr id)))) (and (boundp sym) (symbol-value sym)) nil) ;; Create a new object. diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index e168096e153..d30f616f6ea 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -63,71 +63,19 @@ (defconst package-vc--elpa-packages-version 1 "Version number of the package specification format understood by package-vc.") -(defconst package-vc--backend-type - `(choice :convert-widget - ,(lambda (widget) - (let (opts) - (dolist (be vc-handled-backends) - (when (or (vc-find-backend-function be 'clone) - (alist-get 'clone (get be 'vc-functions))) - (push (widget-convert (list 'const be)) opts))) - (widget-put widget :args opts)) - widget)) - "The type of VC backends that support cloning package VCS repositories.") - -(defcustom package-vc-heuristic-alist - `((,(rx bos "http" (? "s") "://" - (or (: (? "www.") "github.com" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "codeberg.org" - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: (? "www.") "gitlab" (+ "." (+ alnum)) - "/" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" - (or "r" "git") "/" - (+ (or alnum "-" "." "_")) (? "/"))) - (or (? "/") ".git") eos) - . Git) - (,(rx bos "http" (? "s") "://" - (or (: "hg.sr.ht" - "/~" (+ (or alnum "-" "." "_")) - "/" (+ (or alnum "-" "." "_"))) - (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Hg) - (,(rx bos "http" (? "s") "://" - (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" - (+ (or alnum "-" "." "_")) (? "/"))) - eos) - . Bzr)) - "Alist mapping repository URLs to VC backends. -`package-vc-install' consults this alist to determine the VC -backend from the repository URL when you call it without -specifying a backend. Each element of the alist has the form -\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of -the first association for which the URL of the repository matches -the URL-REGEXP of the association. If no match is found, -`package-vc-install' uses `package-vc-default-backend' instead." - :type `(alist :key-type (regexp :tag "Regular expression matching URLs") - :value-type ,package-vc--backend-type) - :version "29.1") +(define-obsolete-variable-alias + 'package-vc-heuristic-alist + 'vc-clone-heuristic-alist "31.1") (defcustom package-vc-default-backend 'Git "Default VC backend to use for cloning package repositories. `package-vc-install' uses this backend when you specify neither the backend nor a repository URL that's recognized via -`package-vc-heuristic-alist'. +`vc-clone-heuristic-alist'. The value must be a member of `vc-handled-backends' that supports the `clone' VC function." - :type package-vc--backend-type + :type vc-cloneable-backends-custom-type :version "29.1") (defcustom package-vc-register-as-project t @@ -247,8 +195,8 @@ This function is meant to be used as a hook for `package-read-archive-hook'." (car spec))) (setf (alist-get (intern archive) package-vc--archive-data-alist) (cdr spec)) - (when-let ((default-vc (plist-get (cdr spec) :default-vc)) - ((not (memq default-vc vc-handled-backends)))) + (when-let* ((default-vc (plist-get (cdr spec) :default-vc)) + ((not (memq default-vc vc-handled-backends)))) (warn "Archive `%S' expects missing VC backend %S" archive (plist-get (cdr spec) :default-vc))))))))) @@ -279,7 +227,7 @@ asynchronously." (defun package-vc--version (pkg) "Return the version number for the VC package PKG." (cl-assert (package-vc-p pkg)) - (if-let ((main-file (package-vc--main-file pkg))) + (if-let* ((main-file (package-vc--main-file pkg))) (with-temp-buffer (insert-file-contents main-file) (package-strip-rcs-id @@ -626,13 +574,6 @@ documentation and marking the package as installed." ""))) t)) -(defun package-vc--guess-backend (url) - "Guess the VC backend for URL. -This function will internally query `package-vc-heuristic-alist' -and return nil if it cannot reasonably guess." - (and url (alist-get url package-vc-heuristic-alist - nil nil #'string-match-p))) - (declare-function project-remember-projects-under "project" (dir &optional recursive)) (defun package-vc--clone (pkg-desc pkg-spec dir rev) @@ -646,7 +587,7 @@ attribute in PKG-SPEC." (unless (file-exists-p dir) (make-directory (file-name-directory dir) t) (let ((backend (or (plist-get pkg-spec :vc-backend) - (package-vc--guess-backend url) + (vc-guess-url-backend url) (plist-get (alist-get (package-desc-archive pkg-desc) package-vc--archive-data-alist nil nil #'string=) @@ -663,7 +604,7 @@ attribute in PKG-SPEC." ;; Check out the latest release if requested (when (eq rev :last-release) - (if-let ((release-rev (package-vc--release-rev pkg-desc))) + (if-let* ((release-rev (package-vc--release-rev pkg-desc))) (vc-retrieve-tag dir release-rev) (message "No release revision was found, continuing..."))))) @@ -753,7 +694,7 @@ VC packages that have already been installed." ;; pointing towards a repository, and use that as a backup (and-let* ((extras (package-desc-extras (cadr pkg))) (url (alist-get :url extras)) - ((package-vc--guess-backend url))))))) + ((vc-guess-url-backend url))))))) (not allow-url))) (defun package-vc--read-package-desc (prompt &optional installed) @@ -868,7 +809,7 @@ If PACKAGE is a string, it specifies the URL of the package repository. In this case, optional argument BACKEND specifies the VC backend to use for cloning the repository; if it's nil, this function tries to infer which backend to use according to -the value of `package-vc-heuristic-alist' and if that fails it +the value of `vc-clone-heuristic-alist' and if that fails it uses `package-vc-default-backend'. Optional argument NAME specifies the package name in this case; if it's nil, this package uses `file-name-base' on the URL to obtain the package @@ -917,7 +858,7 @@ installs takes precedence." (cdr package) rev)) ((and-let* (((stringp package)) - (backend (or backend (package-vc--guess-backend package)))) + (backend (or backend (vc-guess-url-backend package)))) (package-vc--unpack (package-desc-create :name (or name (intern (file-name-base package))) @@ -930,7 +871,7 @@ installs takes precedence." (or (package-vc--desc->spec (cadr desc)) (and-let* ((extras (package-desc-extras (cadr desc))) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" package)) rev))) @@ -958,7 +899,7 @@ for the last released version of the package." (let ((pkg-spec (or (package-vc--desc->spec pkg-desc) (and-let* ((extras (package-desc-extras pkg-desc)) (url (alist-get :url extras)) - (backend (package-vc--guess-backend url))) + (backend (vc-guess-url-backend url))) (list :vc-backend backend :url url)) (user-error "Package `%s' has no VC data" (package-desc-name pkg-desc))))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 53d04b0d5ec..438af781393 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -858,22 +858,22 @@ byte-compilation of the new package to fail." (cl-remove-if-not #'stringp (mapcar #'car load-history))))) (dolist (file files) - (when-let ((library (package--library-stem - (file-relative-name file dir))) - (canonical (locate-library library nil effective-path)) - (truename (file-truename canonical)) - ;; Normally, all files in a package are compiled by - ;; now, but don't assume that. E.g. different - ;; versions can add or remove `no-byte-compile'. - (altname (if (string-suffix-p ".el" truename) - (replace-regexp-in-string - "\\.el\\'" ".elc" truename t) - (replace-regexp-in-string - "\\.elc\\'" ".el" truename t))) - (found (or (member truename history) - (and (not (string= altname truename)) - (member altname history)))) - (recent-index (length found))) + (when-let* ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil effective-path)) + (truename (file-truename canonical)) + ;; Normally, all files in a package are compiled by + ;; now, but don't assume that. E.g. different + ;; versions can add or remove `no-byte-compile'. + (altname (if (string-suffix-p ".el" truename) + (replace-regexp-in-string + "\\.el\\'" ".elc" truename t) + (replace-regexp-in-string + "\\.elc\\'" ".el" truename t))) + (found (or (member truename history) + (and (not (string= altname truename)) + (member altname history)))) + (recent-index (length found))) (unless (equal (file-name-base library) (format "%s-autoloads" (package-desc-name pkg-desc))) (push (cons (expand-file-name library dir) recent-index) result)))) @@ -1161,6 +1161,7 @@ Signal an error if the entire string was not used." (declare-function lm-keywords-list "lisp-mnt" (&optional file)) (declare-function lm-maintainers "lisp-mnt" (&optional file)) (declare-function lm-authors "lisp-mnt" (&optional file)) +(declare-function lm-package-needs-footer-line "lisp-mnt" (&optional file)) (defun package-buffer-info () "Return a `package-desc' describing the package in the current buffer. @@ -1180,14 +1181,9 @@ boundaries." ;; requirement for a "footer line" without unduly impacting users ;; on earlier Emacs versions. See Bug#26490 for more details. (unless (search-forward (concat ";;; " file-name ".el ends here") nil 'move) - ;; Starting in Emacs 30.1, avoid warning if the minimum Emacs - ;; version is specified as 30.1 or later. - (let ((min-emacs (cadar (seq-filter (lambda (x) (eq (car x) 'emacs)) - (lm-package-requires))))) - (when (or (null min-emacs) - (version< min-emacs "30.1")) - (lwarn '(package package-format) :warning - "Package lacks a terminating comment")))) + (when (lm-package-needs-footer-line) + (lwarn '(package package-format) :warning + "Package lacks a terminating comment"))) ;; Try to include a trailing newline. (forward-line) (narrow-to-region start (point)) @@ -2442,9 +2438,10 @@ directory." (defun package-install-selected-packages (&optional noconfirm) "Ensure packages in `package-selected-packages' are installed. If some packages are not installed, propose to install them. -If optional argument NOCONFIRM is non-nil, don't ask for -confirmation to install packages." - (interactive) + +If optional argument NOCONFIRM is non-nil, or when invoked with a prefix +argument, don't ask for confirmation to install packages." + (interactive "P") (package--archives-initialize) ;; We don't need to populate `package-selected-packages' before ;; using here, because the outcome is the same either way (nothing @@ -2620,26 +2617,31 @@ are invalid due to changed byte-code, macros or the like." (package-recompile pkg-desc)))) ;;;###autoload -(defun package-autoremove () +(defun package-autoremove (&optional noconfirm) "Remove packages that are no longer needed. Packages that are no more needed by other packages in `package-selected-packages' and their dependencies -will be deleted." - (interactive) +will be deleted. + +If optional argument NOCONFIRM is non-nil, or when invoked with a prefix +argument, don't ask for confirmation to install packages." + (interactive "P") ;; If `package-selected-packages' is nil, it would make no sense to ;; try to populate it here, because then `package-autoremove' will ;; do absolutely nothing. - (when (or package-selected-packages + (when (or noconfirm + package-selected-packages (yes-or-no-p (format-message "`package-selected-packages' is empty! Really remove ALL packages? "))) (let ((removable (package--removable-packages))) (if removable - (when (y-or-n-p - (format "Packages to delete: %d (%s), proceed? " - (length removable) - (mapconcat #'symbol-name removable " "))) + (when (or noconfirm + (y-or-n-p + (format "Packages to delete: %d (%s), proceed? " + (length removable) + (mapconcat #'symbol-name removable " ")))) (mapc (lambda (p) (package-delete (cadr (assq p package-alist)) t)) removable)) @@ -2694,7 +2696,7 @@ the Emacs user directory is set to a temporary directory." `(add-to-list 'package-directory-list ,dir)) (cons package-user-dir package-directory-list)) (setq package-load-list ',package-load-list) - (package-initialize))))))) + (package-activate-all))))))) ;;;; Package description buffer. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index e9b2980d3ed..9812621d50e 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -84,14 +84,17 @@ (defun pcase--edebug-match-pat-args (head pf) ;; (cl-assert (null (cdr head))) (setq head (car head)) - (or (alist-get head '((quote sexp) - (or &rest pcase-PAT) - (and &rest pcase-PAT) - (guard form) - (pred &or ("not" pcase-FUN) pcase-FUN) - (app pcase-FUN pcase-PAT))) - (let ((me (pcase--get-macroexpander head))) - (funcall pf (and me (symbolp me) (edebug-get-spec me)))))) + (let ((specs + (or + (alist-get head '((quote sexp) + (or &rest pcase-PAT) + (and &rest pcase-PAT) + (guard form) + (pred &or ("not" pcase-FUN) pcase-FUN) + (app pcase-FUN pcase-PAT))) + (let ((me (pcase--get-macroexpander head))) + (and me (symbolp me) (edebug-get-spec me)))))) + (funcall pf specs))) (defun pcase--get-macroexpander (s) "Return the macroexpander for pcase pattern head S, or nil." @@ -181,6 +184,7 @@ Emacs Lisp manual for more information and examples." (let* ((main (documentation (symbol-function 'pcase) 'raw)) (ud (help-split-fundoc main 'pcase))) (require 'help-fns) + (declare-function help-fns-short-filename "help-fns" (filename)) (declare-function help-fns--signature "help-fns" (function doc real-def real-function buffer)) (with-temp-buffer @@ -213,9 +217,7 @@ Emacs Lisp manual for more information and examples." (save-excursion (forward-char -1) (insert (format-message " in `")) - ;; `file-name-nondirectory' is naive, but - ;; `help-fns-short-filename' is not fast enough yet (bug#73766). - (help-insert-xref-button (file-name-nondirectory filename) + (help-insert-xref-button (help-fns-short-filename filename) 'help-function-def symbol filename 'pcase-macro) (insert (format-message "'.")))) @@ -242,9 +244,14 @@ not signal an error." ;;;###autoload (defmacro pcase-lambda (lambda-list &rest body) "Like `lambda' but allow each argument to be a pattern. -I.e. accepts the usual &optional and &rest keywords, but every -formal argument can be any pattern accepted by `pcase' (a mere -variable name being but a special case of it)." +I.e. accepts the usual &optional and &rest keywords, but every formal +argument can be any pattern destructed by `pcase-let' (a mere variable +name being but a special case of it). + +Each argument should match its respective pattern in the parameter +list (i.e. be of a compatible structure); a mismatch may signal an error +or may go undetected, binding arguments to arbitrary values, such as +nil." (declare (doc-string 2) (indent defun) (debug (&define (&rest pcase-PAT) lambda-doc def-body))) (let* ((bindings ()) @@ -1170,7 +1177,11 @@ The predicate is the logical-AND of: `'(,(cadr upata) . ,(cadr upatd)) `(and (pred consp) (app car-safe ,upata) - (app cdr-safe ,upatd))))) + (app cdr-safe ,upatd) + ,@(when (eq (car qpat) '\`) + `((guard ,(macroexp-warn-and-return + "Nested ` are not supported in Pcase patterns" + t nil nil qpat)))))))) ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat) ;; In all other cases just raise an error so we can't break ;; backward compatibility when adding \` support for other diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index e550bd4d689..e246e4211bb 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -308,17 +308,24 @@ can handle, whenever this is possible. Uses the pretty-printing code specified in `pp-default-function'. Output stream is STREAM, or value of `standard-output' (which see)." - (cond - ((and (eq (or stream standard-output) (current-buffer)) - ;; Make sure the current buffer is setup sanely. - (eq (syntax-table) emacs-lisp-mode-syntax-table) - (eq indent-line-function #'lisp-indent-line)) - ;; Skip the buffer->string->buffer middle man. - (funcall pp-default-function object) - ;; Preserve old behavior of (usually) finishing with a newline. - (unless (bolp) (insert "\n"))) - (t - (princ (pp-to-string object) (or stream standard-output))))) + (let ((stream (or stream standard-output))) + (cond + ((and (eq stream (current-buffer)) + ;; Make sure the current buffer is setup sanely. + (eq (syntax-table) emacs-lisp-mode-syntax-table) + (eq indent-line-function #'lisp-indent-line)) + ;; Skip the buffer->string->buffer middle man. + (funcall pp-default-function object) + ;; Preserve old behavior of (usually) finishing with a newline. + (unless (bolp) (insert "\n"))) + (t + (save-current-buffer + (when (bufferp stream) (set-buffer stream)) + (let ((begin (point)) + (cols (current-column))) + (princ (pp-to-string object) (or stream standard-output)) + (when (and (> cols 0) (bufferp stream)) + (indent-rigidly begin (point) cols)))))))) ;;;###autoload (defun pp-display-expression (expression out-buffer-name &optional lisp) @@ -484,8 +491,8 @@ the bounds of a region containing Lisp code to pretty-print." (cons (cond ((consp (cdr sexp)) (let ((head (car sexp))) - (if-let (((null (cddr sexp))) - (syntax-entry (assq head pp--quoting-syntaxes))) + (if-let* (((null (cddr sexp))) + (syntax-entry (assq head pp--quoting-syntaxes))) (progn (insert (cdr syntax-entry)) (pp--insert-lisp (cadr sexp))) diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index 7113d5a6241..2a2315f08b5 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -52,7 +52,6 @@ ;; (repeat N FORM) (= N FORM) ;; (syntax CHARACTER) (syntax NAME) ;; (syntax CHAR-SYM) [1] (syntax NAME) -;; (category chinse-two-byte) (category chinese-two-byte) ;; unibyte ascii ;; multibyte nonascii ;; -------------------------------------------------------- @@ -1011,7 +1010,6 @@ Return (REGEXP . PRECEDENCE)." (not-at-beginning-of-line . ?>) (alpha-numeric-two-byte . ?A) (chinese-two-byte . ?C) - (chinse-two-byte . ?C) ; A typo in Emacs 21.1-24.3. (greek-two-byte . ?G) (japanese-hiragana-two-byte . ?H) (indian-two-byte . ?I) diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index d5ed934f805..df825bd68c8 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -336,10 +336,61 @@ This construct can only be used with lexical binding." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defvar work-buffer--list nil) +(defvar work-buffer-limit 10 + "Maximum number of reusable work buffers. +When this limit is exceeded, newly allocated work buffers are +automatically killed, which means that in a such case +`with-work-buffer' becomes equivalent to `with-temp-buffer'.") + +(defsubst work-buffer--get () + "Get a work buffer." + (let ((buffer (pop work-buffer--list))) + (if (buffer-live-p buffer) + buffer + (generate-new-buffer " *work*" t)))) + +(defun work-buffer--release (buffer) + "Release work BUFFER." + (if (buffer-live-p buffer) + (with-current-buffer buffer + ;; Flush BUFFER before making it available again, i.e. clear + ;; its contents, remove all overlays and buffer-local + ;; variables. Is it enough to safely reuse the buffer? + (let ((inhibit-read-only t) + ;; Avoid deactivating the region as side effect. + deactivate-mark) + (erase-buffer)) + (delete-all-overlays) + (let (change-major-mode-hook) + (kill-all-local-variables t)) + ;; Make the buffer available again. + (push buffer work-buffer--list))) + ;; If the maximum number of reusable work buffers is exceeded, kill + ;; work buffer in excess, taking into account that the limit could + ;; have been let-bound to temporarily increase its value. + (when (> (length work-buffer--list) work-buffer-limit) + (mapc #'kill-buffer (nthcdr work-buffer-limit work-buffer--list)) + (setq work-buffer--list (ntake work-buffer-limit work-buffer--list)))) + ;;;###autoload -(defun string-pixel-width (string) - "Return the width of STRING in pixels. +(defmacro with-work-buffer (&rest body) + "Create a work buffer, and evaluate BODY there like `progn'. +Like `with-temp-buffer', but reuse an already created temporary +buffer when possible, instead of creating a new one on each call." + (declare (indent 0) (debug t)) + (let ((work-buffer (make-symbol "work-buffer"))) + `(let ((,work-buffer (work-buffer--get))) + (with-current-buffer ,work-buffer + (unwind-protect + (progn ,@body) + (work-buffer--release ,work-buffer)))))) +;;;###autoload +(defun string-pixel-width (string &optional buffer) + "Return the width of STRING in pixels. +If BUFFER is non-nil, use the face remappings from that buffer when +determining the width. If you call this function to measure pixel width of a string with embedded newlines, it returns the width of the widest substring that does not include newlines." @@ -348,15 +399,26 @@ substring that does not include newlines." 0 ;; Keeping a work buffer around is more efficient than creating a ;; new temporary buffer. - (with-current-buffer (get-buffer-create " *string-pixel-width*") - ;; If `display-line-numbers' is enabled in internal buffers - ;; (e.g. globally), it breaks width calculation (bug#59311) - (setq-local display-line-numbers nil) - (delete-region (point-min) (point-max)) - ;; Disable line-prefix and wrap-prefix, for the same reason. - (setq line-prefix nil - wrap-prefix nil) - (insert (propertize string 'line-prefix nil 'wrap-prefix nil)) + (with-work-buffer + (if buffer + (setq-local face-remapping-alist + (with-current-buffer buffer + face-remapping-alist)) + (kill-local-variable 'face-remapping-alist)) + ;; Avoid deactivating the region as side effect. + (let (deactivate-mark) + (insert string)) + ;; If `display-line-numbers' is enabled in internal + ;; buffers (e.g. globally), it breaks width calculation + ;; (bug#59311). Disable `line-prefix' and `wrap-prefix', + ;; for the same reason. + (add-text-properties + (point-min) (point-max) '(display-line-numbers-disable t)) + ;; Prefer `remove-text-properties' to `propertize' to avoid + ;; creating a new string on each call. + (remove-text-properties + (point-min) (point-max) '(line-prefix nil wrap-prefix nil)) + (setq line-prefix nil wrap-prefix nil) (car (buffer-text-pixel-size nil nil t))))) ;;;###autoload @@ -418,7 +480,7 @@ this defaults to the current buffer." (t disp))) ;; Remove any old instances. - (when-let ((old (assoc prop disp))) + (when-let* ((old (assoc prop disp))) (setq disp (delete old disp))) (setq disp (cons (list prop value) disp)) (when vector diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 30397137efb..eaf3c5cb561 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -492,8 +492,8 @@ changing `tabulated-list-sort-key'." (if groups (dolist (group groups) (insert (car group) ?\n) - (when-let ((saved-pt-new (tabulated-list-print-entries - (cdr group) sorter update entry-id))) + (when-let* ((saved-pt-new (tabulated-list-print-entries + (cdr group) sorter update entry-id))) (setq saved-pt saved-pt-new))) (setq saved-pt (tabulated-list-print-entries entries sorter update entry-id))) diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index fb4a2a82d07..d916ca0f76a 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -469,7 +469,7 @@ or return multiple values." ;; form to look odd. See bug#25316. 'testcover-1value) - (`(\` ,bq-form) + (`(,'\` ,bq-form) (testcover-analyze-coverage-backquote-form bq-form)) ((or 't 'nil (pred keywordp)) @@ -548,7 +548,7 @@ FORM is treated as if it will be evaluated." 'testcover-1value)) ((pred atom) 'testcover-1value) - (`(\` ,bq-form) + (`(,'\` ,bq-form) (testcover-analyze-coverage-backquote-form bq-form)) (`(defconst ,sym ,val . ,_) (push sym testcover-module-constants) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 52309a247c0..c237eeb52af 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -41,23 +41,21 @@ nil `[ ;; Idle. ,(propertize - (if (aref timer 7) " *" " ") + (if (timer--idle-delay timer) " *" " ") 'help-echo "* marks idle timers" 'timer timer) ;; Next time. ,(propertize - (let ((time (list (aref timer 1) - (aref timer 2) - (aref timer 3)))) + (let ((time (timer--time timer))) (format "%12s" (format-seconds "%dd %hh %mm %z%,1ss" (float-time - (if (aref timer 7) + (if (timer--idle-delay timer) time (time-subtract time nil)))))) 'help-echo "Time until next invocation") ;; Repeat. - ,(let ((repeat (aref timer 4))) + ,(let ((repeat (timer--repeat-delay timer))) (cond ((numberp repeat) (propertize @@ -73,7 +71,7 @@ (let ((cl-print-compiled 'static) (cl-print-compiled-button nil) (print-escape-newlines t)) - (cl-prin1-to-string (aref timer 5))) + (cl-prin1-to-string (timer--function timer))) 'help-echo "Function called by timer")])) (append timer-list timer-idle-list))) (tabulated-list-print)) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index f6f2a8d87c0..166755e4dcc 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -407,7 +407,7 @@ This function returns a timer object which you can use in ;; Handle relative times like "2 hours 35 minutes". (when (stringp time) - (when-let ((secs (timer-duration time))) + (when-let* ((secs (timer-duration time))) (setq time (timer-relative-time nil secs)))) ;; Handle "11:23pm" and the like. Interpret it as meaning today diff --git a/lisp/emacs-lisp/track-changes.el b/lisp/emacs-lisp/track-changes.el index 1d5c5e9917a..2d45f41ae94 100644 --- a/lisp/emacs-lisp/track-changes.el +++ b/lisp/emacs-lisp/track-changes.el @@ -170,6 +170,10 @@ More specifically it indicates which \"before\" they hold. "Current size of the buffer, as far as this library knows. This is used to try and detect cases where buffer modifications are \"lost\".") +(defvar track-changes--trace nil + "Ring holding a trace of recent calls to the API. +Each call is recorded as a (BUFFER-NAME . BACKTRACE).") + ;;;; Exposed API. (defvar track-changes-record-errors @@ -178,7 +182,8 @@ This is used to try and detect cases where buffer modifications are \"lost\".") ;; annoy the user too much about errors. (string-match "\\..*\\." emacs-version) "If non-nil, keep track of errors in `before/after-change-functions' calls. -The errors are kept in `track-changes--error-log'.") +The errors are kept in `track-changes--error-log'. +If set to `trace', then we additionally keep a trace of recent calls to the API.") (cl-defun track-changes-register ( signal &key nobefore disjoint immediate) "Register a new tracker whose change-tracking function is SIGNAL. @@ -213,6 +218,7 @@ and should thus be extra careful: don't modify the buffer, don't call a function that may block, do as little work as possible, ... When IMMEDIATE is non-nil, the SIGNAL should probably not always call `track-changes-fetch', since that would defeat the purpose of this library." + (track-changes--trace) (when (and nobefore disjoint) ;; FIXME: Without `before-change-functions', we can discover ;; a disjoint change only after the fact, which is not good enough. @@ -236,6 +242,7 @@ When IMMEDIATE is non-nil, the SIGNAL should probably not always call Trackers can consume resources (especially if `track-changes-fetch' is not called), so it is good practice to unregister them when you don't need them any more." + (track-changes--trace) (unless (memq id track-changes--trackers) (error "Unregistering a non-registered tracker: %S" id)) (setq track-changes--trackers (delq id track-changes--trackers)) @@ -270,6 +277,7 @@ This reflects a bug somewhere, so please report it when it happens. If no changes occurred since the last time, it doesn't call FUNC and returns nil, otherwise it returns the value returned by FUNC and re-enable the TRACKER corresponding to ID." + (track-changes--trace) (cl-assert (memq id track-changes--trackers)) (unless (equal track-changes--buffer-size (buffer-size)) (track-changes--recover-from-error @@ -387,6 +395,29 @@ returned to a consistent state." ;;;; Auxiliary functions. +(defun track-changes--backtrace (n &optional base) + (let ((frames nil)) + (catch 'done + (mapbacktrace (lambda (&rest frame) + (if (>= (setq n (- n 1)) 0) + (push frame frames) + (push '... frames) + (throw 'done nil))) + (or base #'track-changes--backtrace))) + (nreverse frames))) + +(defun track-changes--trace () + (when (eq 'trace track-changes-record-errors) + (require 'ring) + (declare-function ring-insert "ring" (ring item)) + (declare-function make-ring "ring" (size)) + (unless track-changes--trace + (setq track-changes--trace (make-ring 10))) + (ring-insert track-changes--trace + (cons (buffer-name) + (track-changes--backtrace + 10 #'track-changes--trace))))) + (defun track-changes--clean-state () (cond ((null track-changes--state) @@ -442,7 +473,9 @@ returned to a consistent state." (defvar track-changes--error-log () "List of errors encountered. -Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") +Each element is a tuple [BUFFER-NAME BACKTRACE RECENT-KEYS TRACE]. +where both RECENT-KEYS and TRACE are sorted oldest-first and +backtraces have the deepest frame first.") (defun track-changes--recover-from-error (&optional info) ;; We somehow got out of sync. This is usually the result of a bug @@ -453,14 +486,15 @@ Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") (message "Recovering from confusing calls to `before/after-change-functions'!") (warn "Missing/incorrect calls to `before/after-change-functions'!! Details logged to `track-changes--error-log'") - (push (list (buffer-name) info - (let* ((bf (backtrace-frames - #'track-changes--recover-from-error)) - (tail (nthcdr 50 bf))) - (when tail (setcdr tail '...)) - bf) - (let ((rk (recent-keys 'include-cmds))) - (if (< (length rk) 20) rk (substring rk -20)))) + (push (vector (buffer-name) info + (track-changes--backtrace + 50 #'track-changes--recover-from-error) + (let ((rk (recent-keys 'include-cmds))) + (if (< (length rk) 20) rk (substring rk -20))) + (when (and (eq 'trace track-changes-record-errors) + (fboundp 'ring-elements)) + (apply #'vector + (nreverse (ring-elements track-changes--trace))))) track-changes--error-log)) (setq track-changes--before-clean 'unset) (setq track-changes--buffer-size (buffer-size)) @@ -470,6 +504,7 @@ Details logged to `track-changes--error-log'") (setq track-changes--state (track-changes--state))) (defun track-changes--before (beg end) + (track-changes--trace) (cl-assert track-changes--state) (cl-assert (<= beg end)) (let* ((size (- end beg)) @@ -554,6 +589,7 @@ Details logged to `track-changes--error-log'") (buffer-substring-no-properties old-bend new-bend))))))))) (defun track-changes--after (beg end len) + (track-changes--trace) (cl-assert track-changes--state) (let ((offset (- (- end beg) len))) (cl-incf track-changes--buffer-size offset) diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el index d58c6894c16..c4f14d7b4b2 100644 --- a/lisp/emacs-lisp/vtable.el +++ b/lisp/emacs-lisp/vtable.el @@ -45,7 +45,8 @@ getter formatter displayer - -numerical) + -numerical + -aligned) (defclass vtable () ((columns :initarg :columns :accessor vtable-columns) @@ -212,18 +213,12 @@ See info node `(vtable)Top' for vtable documentation." (funcall accessor face2) (plist-get face2 slot)))) (if (and col1 col2) - (vtable--color-blend col1 col2) + (apply #'color-rgb-to-hex + `(,@(color-blend (color-name-to-rgb col1) + (color-name-to-rgb col2)) + 2)) (or col1 col2)))) -;;; FIXME: This is probably not the right way to blend two colors, is -;;; it? -(defun vtable--color-blend (color1 color2) - (cl-destructuring-bind (r g b) - (mapcar (lambda (n) (* (/ n 2) 255.0)) - (cl-mapcar #'+ (color-name-to-rgb color1) - (color-name-to-rgb color2))) - (format "#%02X%02X%02X" r g b))) - ;;; Interface utility functions. (defun vtable-current-table () @@ -271,7 +266,7 @@ If TABLE is found, return the position of the start of the table. If it can't be found, return nil and don't move point." (let ((start (point))) (goto-char (point-min)) - (if-let ((match (text-property-search-forward 'vtable table t))) + (if-let* ((match (text-property-search-forward 'vtable table t))) (goto-char (prop-match-beginning match)) (goto-char start) nil))) @@ -279,7 +274,7 @@ If it can't be found, return nil and don't move point." (defun vtable-goto-column (column) "Go to COLUMN on the current line." (beginning-of-line) - (if-let ((match (text-property-search-forward 'vtable-column column t))) + (if-let* ((match (text-property-search-forward 'vtable-column column t))) (goto-char (prop-match-beginning match)) (end-of-line))) @@ -311,10 +306,10 @@ is signaled." ;; FIXME: If the table's buffer has no visible window, or if its ;; width has changed since the table was updated, the cache key will ;; not match and the object can't be updated. (Bug #69837). - (if-let ((line-number (seq-position (car (vtable--cache table)) old-object - (lambda (a b) - (equal (car a) b)))) - (line (elt (car (vtable--cache table)) line-number))) + (if-let* ((line-number (seq-position (car (vtable--cache table)) old-object + (lambda (a b) + (equal (car a) b)))) + (line (elt (car (vtable--cache table)) line-number))) (progn (setcar line object) (setcdr line (vtable--compute-cached-line table object)) @@ -368,86 +363,89 @@ end (if the index is too large) of the table. BEFORE is ignored in this case. This also updates the displayed table." - ;; FIXME: Inserting an object into an empty vtable currently isn't - ;; possible. `nconc' fails silently (twice), and `setcar' on the cache - ;; raises an error. + ;; If the vtable is empty, just add the object and regenerate the + ;; table. (if (null (vtable-objects table)) - (error "[vtable] Cannot insert object into empty vtable")) - ;; First insert into the objects. - (let ((pos (if location - (if (integerp location) - (prog1 - (nthcdr location (vtable-objects table)) - ;; Do not prepend if index is too large: - (setq before nil)) - (or (memq location (vtable-objects table)) - ;; Prepend if `location' is not found and - ;; `before' is non-nil: - (and before (vtable-objects table)))) - ;; If `location' is nil and `before' is non-nil, we - ;; prepend the new object. - (if before (vtable-objects table))))) - (if (or before ; If `before' is non-nil, `pos' should be, as well. - (and pos (integerp location))) - ;; Add the new object before. - (let ((old-object (car pos))) - (setcar pos object) - (setcdr pos (cons old-object (cdr pos)))) - ;; Otherwise, add the object after. - (if pos - ;; Splice the object into the list. - (setcdr pos (cons object (cdr pos))) - ;; Otherwise, append the object. - (nconc (vtable-objects table) (list object))))) - ;; Then adjust the cache and display. - (save-excursion - (vtable-goto-table table) - (let* ((cache (vtable--cache table)) - (inhibit-read-only t) - (keymap (get-text-property (point) 'keymap)) - (ellipsis (if (vtable-ellipsis table) - (propertize (truncate-string-ellipsis) - 'face (vtable-face table)) - "")) - (ellipsis-width (string-pixel-width ellipsis)) - (elem (if location ; This binding mirrors the binding of `pos' above. - (if (integerp location) - (nth location (car cache)) - (or (assq location (car cache)) - (and before (caar cache)))) - (if before (caar cache)))) - (pos (memq elem (car cache))) - (line (cons object (vtable--compute-cached-line table object)))) - (if (or before + (progn + (setf (vtable-objects table) (list object)) + (vtable--recompute-numerical table (vtable--compute-cached-line table object)) + (vtable-goto-table table) + (vtable-revert-command)) + ;; First insert into the objects. + (let ((pos (if location + (if (integerp location) + (prog1 + (nthcdr location (vtable-objects table)) + ;; Do not prepend if index is too large: + (setq before nil)) + (or (memq location (vtable-objects table)) + ;; Prepend if `location' is not found and + ;; `before' is non-nil: + (and before (vtable-objects table)))) + ;; If `location' is nil and `before' is non-nil, we + ;; prepend the new object. + (if before (vtable-objects table))))) + (if (or before ; If `before' is non-nil, `pos' should be, as well. (and pos (integerp location))) - ;; Add the new object before:. - (let ((old-line (car pos))) - (setcar pos line) - (setcdr pos (cons old-line (cdr pos))) - (unless (vtable-goto-object (car elem)) - (vtable-beginning-of-table))) + ;; Add the new object before. + (let ((old-object (car pos))) + (setcar pos object) + (setcdr pos (cons old-object (cdr pos)))) ;; Otherwise, add the object after. (if pos ;; Splice the object into the list. - (progn - (setcdr pos (cons line (cdr pos))) - (if (vtable-goto-object location) - (forward-line 1) ; Insert *after*. - (vtable-end-of-table))) + (setcdr pos (cons object (cdr pos))) ;; Otherwise, append the object. - (setcar cache (nconc (car cache) (list line))) - (vtable-end-of-table))) - (let ((start (point))) - ;; FIXME: We have to adjust colors in lines below this if we - ;; have :row-colors. - (vtable--insert-line table line 0 - (nth 1 cache) (vtable--spacer table) - ellipsis ellipsis-width) - (add-text-properties start (point) (list 'keymap keymap - 'vtable table))) - ;; We may have inserted a non-numerical value into a previously - ;; all-numerical table, so recompute. - (vtable--recompute-numerical table (cdr line))))) + (nconc (vtable-objects table) (list object))))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + (elem (if location ; This binding mirrors the binding of `pos' above. + (if (integerp location) + (nth location (car cache)) + (or (assq location (car cache)) + (and before (caar cache)))) + (if before (caar cache)))) + (pos (memq elem (car cache))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (or before + (and pos (integerp location))) + ;; Add the new object before:. + (let ((old-line (car pos))) + (setcar pos line) + (setcdr pos (cons old-line (cdr pos))) + (unless (vtable-goto-object (car elem)) + (vtable-beginning-of-table))) + ;; Otherwise, add the object after. + (if pos + ;; Splice the object into the list. + (progn + (setcdr pos (cons line (cdr pos))) + (if (vtable-goto-object location) + (forward-line 1) ; Insert *after*. + (vtable-end-of-table))) + ;; Otherwise, append the object. + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table))) + (let ((start (point))) + ;; FIXME: We have to adjust colors in lines below this if we + ;; have :row-colors. + (vtable--insert-line table line 0 + (nth 1 cache) (vtable--spacer table) + ellipsis ellipsis-width) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line)))))) (defun vtable-column (table index) "Return the name of the INDEXth column in TABLE." @@ -470,7 +468,17 @@ This also updates the displayed table." (t (elt object index)))) -(defun vtable--compute-columns (table) +(defun vtable--compute-columns (table &optional recompute) + "Compute column specs for TABLE. +Set the `align', `-aligned' and `-numerical' properties of each column. +If the column contains only numerical data, set `-numerical' to t, +otherwise to nil. `-aligned' indicates whether the column has an +`align' property set by the user. If it does, `align' is not touched, +otherwise it is set to `right' for numeric columns and to `left' for +non-numeric columns. + +If RECOMPUTE is non-nil, do not set `-aligned'. This can be used to +recompute the column specs when the table data has changed." (let ((numerical (make-vector (length (vtable-columns table)) t)) (columns (vtable-columns table))) ;; First determine whether there are any all-numerical columns. @@ -481,11 +489,16 @@ This also updates the displayed table." table)) (setf (elt numerical index) nil))) (vtable-columns table))) + ;; Check if any columns have an explicit `align' property. + (unless recompute + (dolist (column (vtable-columns table)) + (when (vtable-column-align column) + (setf (vtable-column--aligned column) t)))) ;; Then fill in defaults. (seq-map-indexed (lambda (column index) ;; This is used when displaying. - (unless (vtable-column-align column) + (unless (vtable-column--aligned column) (setf (vtable-column-align column) (if (elt numerical index) 'right @@ -638,7 +651,7 @@ This also updates the displayed table." (insert "\n") (put-text-property start (point) 'vtable-object (car line)) (unless column-colors - (when-let ((row-colors (slot-value table '-cached-colors))) + (when-let* ((row-colors (slot-value table '-cached-colors))) (add-face-text-property start (point) (elt row-colors (mod line-number (length row-colors)))))))) @@ -810,7 +823,7 @@ If NEXT, do the next column." (setq recompute t))) line) (when recompute - (vtable--compute-columns table)))) + (vtable--compute-columns table t)))) (defun vtable--set-header-line (table widths spacer) (setq header-line-format @@ -850,32 +863,48 @@ If NEXT, do the next column." (error "Invalid spec: %s" spec)))) (defun vtable--compute-widths (table cache) - "Compute the display widths for TABLE." - (seq-into - (seq-map-indexed - (lambda (column index) - (let ((width - (or - ;; Explicit widths. - (and (vtable-column-width column) - (vtable--compute-width table (vtable-column-width column))) - ;; Compute based on the displayed widths of - ;; the data. - (seq-max (seq-map (lambda (elem) - (nth 1 (elt (cdr elem) index))) - cache))))) - ;; Let min-width/max-width specs have their say. - (when-let ((min-width (and (vtable-column-min-width column) - (vtable--compute-width - table (vtable-column-min-width column))))) - (setq width (max width min-width))) - (when-let ((max-width (and (vtable-column-max-width column) - (vtable--compute-width - table (vtable-column-max-width column))))) - (setq width (min width max-width))) - width)) - (vtable-columns table)) - 'vector)) + "Compute the display widths for TABLE. +CACHE is TABLE's cache data as returned by `vtable--compute-cache'." + (let* ((n-0cols 0) ; Count the number of zero-width columns. + (widths (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; If the vtable is empty and no explicit width is given, + ;; set its width to 0 and deal with it below. + (when (null cache) + (setq n-0cols (1+ n-0cols)) + 0) + ;; Otherwise, compute based on the displayed widths of the + ;; data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let* ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let* ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)))) + ;; If there are any zero-width columns, divide the remaining window + ;; width evenly over them. + (when (> n-0cols 0) + (let* ((combined-width (apply #'+ widths)) + (default-width (/ (- (window-width nil t) combined-width) n-0cols))) + (setq widths (mapcar (lambda (width) + (if (zerop width) + default-width + width)) + widths)))) + (seq-into widths 'vector))) (defun vtable--compute-cache (table) (seq-map @@ -904,7 +933,7 @@ If NEXT, do the next column." (vtable-keymap table)) (copy-keymap vtable-map) vtable-map))) - (when-let ((actions (vtable-actions table))) + (when-let* ((actions (vtable-actions table))) (while actions (funcall (lambda (key binding) (keymap-set map key diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 68db33bfa68..b11e1ebeb70 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -285,7 +285,7 @@ entirely by setting `warning-suppress-types' or (unless buffer-name (setq buffer-name "*Warnings*")) (with-suppressed-warnings ((obsolete warning-level-aliases)) - (when-let ((new (cdr (assq level warning-level-aliases)))) + (when-let* ((new (cdr (assq level warning-level-aliases)))) (warn "Warning level `%s' is obsolete; use `%s' instead" level new) (setq level new))) (or (< (warning-numeric-level level) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 9f724551239..e9f32b447d8 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -698,8 +698,8 @@ If nil, the cursor will move backwards without deleting anything." "List of file and buffer names to consider related to the current buffer. Related buffers can be cycled through via :R and :P commands." :type 'boolean + :local 'permanent-only :group 'viper-misc) -(put 'viper-related-files-and-buffers-ring 'permanent-local t) ;; Used to find out if we are done with searching the current buffer. (defvar-local viper-local-search-start-marker nil) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index d28c319de98..db4f12b84f9 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -1135,8 +1135,8 @@ This option is appropriate if you like Emacs-style words." :type '(radio (const strict-vi) (const reformed-vi) (const extended) (const emacs)) :set #'viper-set-syntax-preference + :local t :group 'viper) -(make-variable-buffer-local 'viper-syntax-preference) ;; addl-chars are characters to be temporarily considered as alphanumerical diff --git a/lisp/epa-file.el b/lisp/epa-file.el index 90cc91e99a0..ee0a665aa62 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -177,7 +177,7 @@ encryption is used." (nth 3 error))) (let ((exists (file-exists-p local-file))) (when exists - (if-let ((wrong-password (epa--wrong-password-p context))) + (if-let* ((wrong-password (epa--wrong-password-p context))) ;; Don't display the *error* buffer if we just ;; have a wrong password; let the later error ;; handler notify the user. diff --git a/lisp/epa.el b/lisp/epa.el index c29df18bb58..e7856f8463b 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -498,7 +498,7 @@ If SECRET is non-nil, list secret keys instead of public keys." (defun epa-show-key () "Show a key on the current line." (interactive) - (if-let ((key (get-text-property (point) 'epa-key))) + (if-let* ((key (get-text-property (point) 'epa-key))) (save-selected-window (epa--show-key key)) (error "No key on this line"))) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 9aedc110067..e72fa036f17 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -605,7 +605,7 @@ escape hatch for inhibiting their transmission.") (concat "Unbreakable line encountered " "(Recover input with \\[erc-previous-command])")))) (goto-char upper)) - (when-let ((cmp (find-composition (point) (1+ (point))))) + (when-let* ((cmp (find-composition (point) (1+ (point))))) (if (= (car cmp) (point-min)) (goto-char (nth 1 cmp)) (goto-char (car cmp))))) @@ -1057,9 +1057,9 @@ Conditionally try to reconnect and take appropriate action." (setq erc--hidden-prompt-overlay nil))) (cl-defmethod erc--conceal-prompt () - (when-let (((null erc--hidden-prompt-overlay)) - (ov (make-overlay erc-insert-marker (1- erc-input-marker) - nil 'front-advance))) + (when-let* (((null erc--hidden-prompt-overlay)) + (ov (make-overlay erc-insert-marker (1- erc-input-marker) + nil 'front-advance))) (defvar erc-prompt-hidden) (overlay-put ov 'display erc-prompt-hidden) (setq erc--hidden-prompt-overlay ov))) @@ -1534,11 +1534,15 @@ See also `erc-server-responses'." (gethash (format (if (numberp command) "%03i" "%s") command) erc-server-responses)) +(defvar erc--parsed-response nil) + (defun erc-call-hooks (process message) "Call hooks associated with MESSAGE in PROCESS. Finds hooks by looking in the `erc-server-responses' hash table." - (let ((hook (or (erc-get-hook (erc-response.command message)) + (let ((erc--parsed-response message) + (erc--msg-prop-overrides erc--msg-prop-overrides) + (hook (or (erc-get-hook (erc-response.command message)) 'erc-default-server-functions))) (run-hook-with-args-until-success hook process message) ;; Some handlers, like `erc-cmd-JOIN', open new targets without @@ -1847,8 +1851,8 @@ add things to `%s' instead." ?t tgt ?m mode) (erc-display-message parsed 'notice buf 'MODE ?n nick ?u login - ?h host ?t tgt ?m mode))) - (erc-banlist-update proc parsed)))) + ?h host ?t tgt ?m mode))))) + nil) (defun erc--wrangle-query-buffers-on-nick-change (old new) "Create or reuse a query buffer for NEW nick after considering OLD nick. @@ -2074,12 +2078,12 @@ like `erc-insert-modify-hook'.") (defvar erc-receive-query-display) (defvar erc-receive-query-display-defer) (if privp - (when-let ((erc-join-buffer - (or (and (not erc-receive-query-display-defer) - erc-receive-query-display) - (and erc-ensure-target-buffer-on-privmsg - (or erc-receive-query-display - erc-join-buffer))))) + (when-let* ((erc-join-buffer + (or (and (not erc-receive-query-display-defer) + erc-receive-query-display) + (and erc-ensure-target-buffer-on-privmsg + (or erc-receive-query-display + erc-join-buffer))))) (push `(erc-receive-query-display . ,(intern cmd)) erc--display-context) (setq buffer (erc--open-target nick))) @@ -2258,12 +2262,12 @@ primitive value." (if-let* ((table (or erc--isupport-params (erc-with-server-buffer erc--isupport-params))) (value (with-memoization (gethash key table) - (when-let ((v (assoc (symbol-name key) - (or erc-server-parameters - (erc-with-server-buffer + (when-let* ((v (assoc (symbol-name key) + (or erc-server-parameters + (erc-with-server-buffer erc-server-parameters))))) - (if-let ((val (cdr v)) - ((not (string-empty-p val)))) + (if-let* ((val (cdr v)) + ((not (string-empty-p val)))) (erc--parse-isupport-value val) '--empty--))))) (pcase value diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c158b443b89..b4a94321947 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -462,18 +462,18 @@ retrieve it during buttonizing via (defun erc-button-add-nickname-buttons (entry) "Search through the buffer for nicknames, and add buttons." - (when-let ((form (nth 2 entry)) - ;; Spoof `form' slot of default legacy `nicknames' entry - ;; so `erc-button--extract-form' sees a function value. - (form (let ((erc-button-buttonize-nicks - (and erc-button-buttonize-nicks - erc-button--modify-nick-function))) - (erc-button--extract-form form))) - (oncep (if-let ((erc-button-highlight-nick-once) - (c (erc--check-msg-prop 'erc--cmd)) - ((memq c erc-button-highlight-nick-once))) - 1 0)) - (seen 0)) + (when-let* ((form (nth 2 entry)) + ;; Spoof `form' slot of default legacy `nicknames' entry + ;; so `erc-button--extract-form' sees a function value. + (form (let ((erc-button-buttonize-nicks + (and erc-button-buttonize-nicks + erc-button--modify-nick-function))) + (erc-button--extract-form form))) + (oncep (if-let* ((erc-button-highlight-nick-once) + (c (erc--check-msg-prop 'erc--cmd)) + ((memq c erc-button-highlight-nick-once))) + 1 0)) + (seen 0)) (goto-char (point-min)) (while-let (((or (zerop seen) (zerop oncep))) @@ -665,14 +665,14 @@ greater than `point-min' with a text property of `erc-callback'.") (p start)) (while (progn ;; Break out of current search context. - (when-let ((low (max (point-min) (1- (pos-bol)))) - (high (min (point-max) (1+ (pos-eol)))) - (prop (get-text-property p 'erc-callback)) - (q (if nextp - (text-property-not-all p high - 'erc-callback prop) - (funcall search-fn p 'erc-callback nil low))) - ((< low q high))) + (when-let* ((low (max (point-min) (1- (pos-bol)))) + (high (min (point-max) (1+ (pos-eol)))) + (prop (get-text-property p 'erc-callback)) + (q (if nextp + (text-property-not-all p high + 'erc-callback prop) + (funcall search-fn p 'erc-callback nil low))) + ((< low q high))) (setq p q)) ;; Assume that buttons occur frequently enough that ;; omitting LIMIT is acceptable. diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 057e7981515..9bb3f650b9b 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -267,9 +267,9 @@ instead of a `set' state, which precludes any actual saving." (rassq known custom-current-group-alist))) (throw 'found known)) (when (setq known (intern-soft (concat "erc-" downed "-mode"))) - (when-let ((found (custom-group-of-mode known))) + (when-let* ((found (custom-group-of-mode known))) (throw 'found found)))) - (when-let ((found (get (erc--normalize-module-symbol s) 'erc-group))) + (when-let* ((found (get (erc--normalize-module-symbol s) 'erc-group))) (throw 'found found))) 'erc)) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index b5b8fbaf8ab..cb401782125 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -440,6 +440,18 @@ fallback." `(or ,v ""))))) spec))))) + +;;;; Misc 31.1 + +(defun erc-compat--window-no-other-p (window) + ;; See bug#73706. + (if (fboundp 'window-no-other-p) + (window-no-other-p window) + (setq window (window-normalize-window window t)) + (and (not ignore-window-parameters) + (window-parameter window 'no-other-window)))) + + (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index c863d99a339..13f1dbf266c 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -172,8 +172,8 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." (save-restriction (narrow-to-region (point) (point-max)) (funcall (or erc-fill--function erc-fill-function)) - (when-let ((erc-fill-line-spacing) - (p (point-min))) + (when-let* ((erc-fill-line-spacing) + (p (point-min))) (widen) (when (or (erc--check-msg-prop 'erc--spkr) (save-excursion @@ -186,9 +186,9 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." "Fills a text such that messages start at column `erc-fill-static-center'." (save-restriction (goto-char (point-min)) - (when-let (((looking-at "^\\(\\S-+\\)")) - ((not (erc--check-msg-prop 'erc--msg 'datestamp))) - (nick (match-string 1))) + (when-let* (((looking-at "^\\(\\S-+\\)")) + ((not (erc--check-msg-prop 'erc--msg 'datestamp))) + (nick (match-string 1))) (progn (let ((fill-column (- erc-fill-column (erc-timestamp-offset))) (fill-prefix (make-string erc-fill-static-center 32))) @@ -322,13 +322,13 @@ command." "Move to start of message text when left of speaker. Basically mimic what `move-beginning-of-line' does with invisible text. Stay put if OLD-POINT lies within hidden region." - (when-let ((erc-fill-wrap-merge) - (prop (get-text-property (point) 'erc-fill--wrap-merge)) - ((or (member prop '("" t)) - (eq 'margin (car-safe (car-safe prop))))) - (end (text-property-not-all (point) (pos-eol) - 'erc-fill--wrap-merge prop)) - ((or (null old-point) (>= old-point end)))) + (when-let* ((erc-fill-wrap-merge) + (prop (get-text-property (point) 'erc-fill--wrap-merge)) + ((or (member prop '("" t)) + (eq 'margin (car-safe (car-safe prop))))) + (end (text-property-not-all (point) (pos-eol) + 'erc-fill--wrap-merge prop)) + ((or (null old-point) (>= old-point end)))) (goto-char end))) (defun erc-fill--wrap-beginning-of-line (arg) @@ -413,7 +413,6 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." "<remap> <toggle-truncate-lines>" #'erc-fill-wrap-toggle-truncate-lines "<remap> <next-line>" #'erc-fill--wrap-next-line "<remap> <previous-line>" #'erc-fill--wrap-previous-line - "C-c a" #'erc-fill-wrap-cycle-visual-movement ;; Not sure if this is problematic because `erc-bol' takes no args. "<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line) @@ -421,7 +420,7 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." (defvar erc-scrolltobottom-mode) (defvar erc-legacy-invisible-bounds-p) -(defvar erc--fill-wrap-scrolltobottom-exempt-p nil) +(defvar erc-fill--wrap-scrolltobottom-exempt-p nil) (defun erc-fill--wrap-ensure-dependencies () (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) @@ -435,7 +434,7 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'." (unless erc-fill-mode (push 'fill missing-deps) (erc-fill-mode +1)) - (unless (or erc-scrolltobottom-mode erc--fill-wrap-scrolltobottom-exempt-p + (unless (or erc-scrolltobottom-mode erc-fill--wrap-scrolltobottom-exempt-p (memq 'scrolltobottom erc-modules)) (push 'scrolltobottom missing-deps) (erc-scrolltobottom-mode +1)) @@ -547,6 +546,9 @@ via `erc-fill-wrap-mode-hook'." (when erc-fill-wrap-merge (add-hook 'erc-button--prev-next-predicate-functions #'erc-fill--wrap-merged-button-p nil t)) + (add-function :after (local 'erc--clear-function) + #'erc-fill--wrap-massage-initial-message-post-clear + '((depth . 50))) (erc-stamp--display-margin-mode +1) (visual-line-mode +1)) ((visual-line-mode -1) @@ -557,6 +559,8 @@ via `erc-fill-wrap-mode-hook'." (kill-local-variable 'erc-fill--wrap-last-msg) (kill-local-variable 'erc--inhibit-prompt-display-property-p) (kill-local-variable 'erc-fill--wrap-merge-indicator-pre) + (remove-function (local 'erc--clear-function) + #'erc-fill--wrap-massage-initial-message-post-clear) (remove-hook 'erc--refresh-prompt-hook #'erc-fill--wrap-indent-prompt t) (remove-hook 'erc-button--prev-next-predicate-functions @@ -668,12 +672,30 @@ Also cover region with text prop `erc-fill--wrap-merge' set to t." (let ((next-beg (point-max))) (save-restriction (widen) - (when-let (((get-text-property next-beg 'erc-fill--wrap-merge)) - (end (erc--get-inserted-msg-bounds next-beg)) - (beg (pop end)) - (erc-fill--wrap-continued-predicate #'ignore)) + (when-let* (((get-text-property next-beg 'erc-fill--wrap-merge)) + (end (erc--get-inserted-msg-bounds next-beg)) + (beg (pop end)) + (erc-fill--wrap-continued-predicate #'ignore)) (erc-fill--wrap-rejigger-region (1- beg) (1+ end) nil 'repairp)))))) +(defun erc-fill--wrap-massage-initial-message-post-clear (beg end) + "Maybe reveal hidden speaker or add stamp on initial message after END." + (if erc-stamp--date-mode + (erc-stamp--redo-right-stamp-post-clear beg end) + ;; With other non-date stamp-insertion functions, remove hidden + ;; speaker continuation on first spoken message in buffer. + (when-let* (((< end (1- erc-insert-marker))) + (next (text-property-not-all end (min erc-insert-marker + (+ 4096 end)) + 'erc--msg nil)) + (bounds (erc--get-inserted-msg-bounds next)) + (found (text-property-not-all (car bounds) (cdr bounds) + 'erc-fill--wrap-merge nil)) + (erc-fill--wrap-continued-predicate #'ignore)) + (erc-fill--wrap-rejigger-region (max (1- (car bounds)) (point-min)) + (min (1+ (cdr bounds)) erc-insert-marker) + nil 'repairp)))) + (defun erc-fill-wrap () "Use text props to mimic the effect of `erc-fill-static'. See `erc-fill-wrap-mode' for details." @@ -685,11 +707,11 @@ See `erc-fill-wrap-mode' for details." (funcall erc-fill--wrap-length-function)) (and-let* ((msg-prop (erc--check-msg-prop 'erc--msg)) ((not (eq msg-prop 'unknown)))) - (when-let ((e (erc--get-speaker-bounds)) - (b (pop e)) - ((or erc-fill--wrap-action-dedent-p - (not (erc--check-msg-prop 'erc--ctcp - 'ACTION))))) + (when-let* ((e (erc--get-speaker-bounds)) + (b (pop e)) + ((or erc-fill--wrap-action-dedent-p + (not (erc--check-msg-prop 'erc--ctcp + 'ACTION))))) (goto-char e)) (skip-syntax-forward "^-") (forward-char) @@ -754,18 +776,18 @@ With REPAIRP, destructively fill gaps and re-merge speakers." (end (text-property-not-all beg finish 'line-prefix val))) ;; If this is a left-side stamp on its own line. (remove-text-properties beg (1+ end) '(line-prefix nil wrap-prefix nil)) - (when-let ((repairp) - (dbeg (text-property-not-all beg end - 'erc-fill--wrap-merge nil)) - ((get-text-property (1+ dbeg) 'erc--speaker)) - (dval (get-text-property dbeg 'erc-fill--wrap-merge))) + (when-let* ((repairp) + (dbeg (text-property-not-all beg end + 'erc-fill--wrap-merge nil)) + ((get-text-property (1+ dbeg) 'erc--speaker)) + (dval (get-text-property dbeg 'erc-fill--wrap-merge))) (remove-list-of-text-properties dbeg (text-property-not-all dbeg end 'erc-fill--wrap-merge dval) '(display erc-fill--wrap-merge))) ;; This "should" work w/o `front-sticky' and `rear-nonsticky'. - (let* ((pos (if-let (((eq 'erc-timestamp (field-at-pos beg))) - (b (field-beginning beg)) - ((eq 'datestamp (get-text-property b 'erc--msg)))) + (let* ((pos (if-let* (((eq 'erc-timestamp (field-at-pos beg))) + (b (field-beginning beg)) + ((eq 'datestamp (get-text-property b 'erc--msg)))) b beg)) (erc--msg-props (map-into (text-properties-at pos) 'hash-table)) @@ -780,8 +802,8 @@ With REPAIRP, destructively fill gaps and re-merge speakers." (funcall on-next)) ;; Skip to end of message upon encountering accidental gaps ;; introduced by third parties (or bugs). - (if-let (((/= ?\n (char-after end))) - (next (erc--get-inserted-msg-end beg))) + (if-let* (((/= ?\n (char-after end))) + (next (erc--get-inserted-msg-end beg))) (progn (cl-assert (= ?\n (char-after next))) (when repairp ; eol <= next @@ -896,6 +918,12 @@ decorations applied by third-party modules." (length (format-time-string erc-timestamp-format)) 0)) +(cl-defmethod erc--determine-fill-column-function + (&context (erc-fill-mode (eql t))) + (if erc-fill-wrap-mode + (- (window-width) erc-fill--wrap-value 1) + erc-fill-column)) + (provide 'erc-fill) ;;; erc-fill.el ends here diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 9837ec302ee..5d1aab4910d 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -141,7 +141,7 @@ or send-related hooks. When recentering has not been performed, attempt to restore last `window-start', if known." (dolist (window (get-buffer-window-list nil nil 'visible)) (with-selected-window window - (when-let + (when-let* ((erc--scrolltobottom-window-info) (found (assq window erc--scrolltobottom-window-info)) ((not (erc--scrolltobottom-confirm (nth 2 found))))) @@ -308,6 +308,19 @@ buffer than the window's start." :package-version '(ERC . "5.6") :type 'boolean) +(defcustom erc-keep-place-indicator-truncation nil + "What to do when truncation occurs and the buffer is trimmed. +If nil, a truncation event moves the indicator, effectively resetting it +to `point-min'. If this option's value is t, the indicator stays put +and limits the operation, but only when it resides on an actual message. +That is, if it remains at its initial position at or near `point-min', +truncation will still occur. As of ERC 5.6.1, this option only +influences the behavior of the `truncate' module, rather than truncation +resulting from a /CLEAR." + :group 'erc + :package-version '(ERC . "5.6.1") + :type 'boolean) + (defface erc-keep-place-indicator-line '((((class color) (min-colors 88) (background light) (supports :underline (:style wave))) @@ -337,19 +350,19 @@ Do so only when switching to a new buffer in the same window if the replaced buffer is no longer visible in another window and its `window-start' at the time of switching is strictly greater than the indicator's position." - (when-let ((erc-keep-place-indicator-follow) - (window (selected-window)) - ((not (eq window (active-minibuffer-window)))) - (old-buffer (window-old-buffer window)) - ((buffer-live-p old-buffer)) - ((not (eq old-buffer (current-buffer)))) - (ov (buffer-local-value 'erc--keep-place-indicator-overlay - old-buffer)) - ((not (get-buffer-window old-buffer 'visible))) - (prev (assq old-buffer (window-prev-buffers window))) - (old-start (nth 1 prev)) - (old-inmkr (buffer-local-value 'erc-insert-marker old-buffer)) - ((< (overlay-end ov) old-start old-inmkr))) + (when-let* ((erc-keep-place-indicator-follow) + (window (selected-window)) + ((not (eq window (active-minibuffer-window)))) + (old-buffer (window-old-buffer window)) + ((buffer-live-p old-buffer)) + ((not (eq old-buffer (current-buffer)))) + (ov (buffer-local-value 'erc--keep-place-indicator-overlay + old-buffer)) + ((not (get-buffer-window old-buffer 'visible))) + (prev (assq old-buffer (window-prev-buffers window))) + (old-start (nth 1 prev)) + (old-inmkr (buffer-local-value 'erc-insert-marker old-buffer)) + ((< (overlay-end ov) old-start old-inmkr))) (with-current-buffer old-buffer (erc-keep-place-move old-start)))) @@ -370,6 +383,8 @@ and `keep-place-indicator' in different buffers." #'erc--keep-place-indicator-on-window-buffer-change 40) (add-hook 'erc-keep-place-mode-hook #'erc--keep-place-indicator-on-global-module 40) + (add-function :before (local 'erc--clear-function) + #'erc--keep-place-indicator-adjust-on-clear '((depth . 40))) (if (pcase erc-keep-place-indicator-buffer-type ('target erc--target) ('server (not erc--target)) @@ -377,15 +392,15 @@ and `keep-place-indicator' in different buffers." (progn (erc--restore-initialize-priors erc-keep-place-indicator-mode erc--keep-place-indicator-overlay (make-overlay 0 0)) - (when-let (((memq erc-keep-place-indicator-style '(t arrow))) - (ov-property (if (zerop (fringe-columns 'left)) - 'after-string - 'before-string)) - (display (if (zerop (fringe-columns 'left)) - `((margin left-margin) ,overlay-arrow-string) - '(left-fringe right-triangle - erc-keep-place-indicator-arrow))) - (bef (propertize " " 'display display))) + (when-let* (((memq erc-keep-place-indicator-style '(t arrow))) + (ov-property (if (zerop (fringe-columns 'left)) + 'after-string + 'before-string)) + (display (if (zerop (fringe-columns 'left)) + `((margin left-margin) ,overlay-arrow-string) + '(left-fringe right-triangle + erc-keep-place-indicator-arrow))) + (bef (propertize " " 'display display))) (overlay-put erc--keep-place-indicator-overlay ov-property bef)) (when (memq erc-keep-place-indicator-style '(t face)) (overlay-put erc--keep-place-indicator-overlay 'face @@ -401,7 +416,9 @@ and `keep-place-indicator' in different buffers." (remove-hook 'erc-keep-place-mode-hook #'erc--keep-place-indicator-on-global-module) (remove-hook 'window-buffer-change-functions - #'erc--keep-place-indicator-on-window-buffer-change))) + #'erc--keep-place-indicator-on-window-buffer-change) + (remove-function (local 'erc--clear-function) + #'erc--keep-place-indicator-adjust-on-clear))) (when (local-variable-p 'erc-insert-pre-hook) (remove-hook 'erc-insert-pre-hook #'erc-keep-place t)) (remove-hook 'erc-keep-place-mode-hook @@ -418,6 +435,21 @@ Do this by simulating `keep-place' in all buffers where (remove-hook 'erc-insert-pre-hook #'erc-keep-place t) (add-hook 'erc-insert-pre-hook #'erc-keep-place 65 t)))) +(defvar erc--keep-place-move-hook nil + "Hook run when `erc-keep-place-move' moves the indicator.") + +(defun erc--keep-place-indicator-adjust-on-clear (beg end) + "Either shrink region bounded by BEG to END to preserve overlay, or reset." + (when-let* ((pos (overlay-start erc--keep-place-indicator-overlay)) + ((<= beg pos end))) + (if (and erc-keep-place-indicator-truncation + (not erc--called-as-input-p)) + (when-let* ((pos (erc--get-inserted-msg-beg pos))) + (set-marker end pos)) + (let (erc--keep-place-move-hook) + ;; Move earlier than `beg', which may delimit date stamps, etc. + (erc-keep-place-move (point-min)))))) + (defun erc-keep-place-move (pos) "Move keep-place indicator to current line or POS. For use with `keep-place-indicator' module. When called @@ -441,6 +473,9 @@ window's first line. Interpret an integer as an offset in lines." (let ((inhibit-field-text-motion t)) (when pos (goto-char pos)) + (when-let* ((pos (erc--get-inserted-msg-beg))) + (goto-char pos)) + (run-hooks 'erc--keep-place-move-hook) (move-overlay erc--keep-place-indicator-overlay (line-beginning-position) (line-end-position))))) @@ -603,8 +638,8 @@ Do nothing if the variable `erc-command-indicator' is nil." (map-into `((erc--msg . slash-cmd) ,@(reverse ovs)) 'hash-table))))) - (when-let ((string (erc-command-indicator)) - (erc-input-marker (copy-marker erc-input-marker))) + (when-let* ((string (erc-command-indicator)) + (erc-input-marker (copy-marker erc-input-marker))) (erc-display-prompt nil nil string 'erc-command-indicator-face) (remove-text-properties insert-position (point) '(field nil erc-prompt nil)) @@ -1115,195 +1150,6 @@ servers. If called from a program, PROC specifies the server process." (multi-occur (erc-buffer-list nil proc) string)) -;;;; querypoll - -(declare-function ring-empty-p "ring" (ring)) -(declare-function ring-insert "ring" (ring item)) -(declare-function ring-insert+extend "ring" (ring item)) -(declare-function ring-length "ring" (ring)) -(declare-function ring-member "ring" (ring item)) -(declare-function ring-ref "ring" (ring index)) -(declare-function ring-remove "ring" (ring &optional index)) - -(defvar-local erc--querypoll-ring nil) -(defvar-local erc--querypoll-timer nil) - -(defcustom erc-querypoll-exclude-regexp - (rx bot (or (: "*" (+ nonl)) (: (+ (in "A-Za-z")) "Serv")) eot) - "Pattern to skip polling for bots and services you regularly query." - :group 'erc - :package-version '(ERC . "5.6") - :type 'regexp) - -;;;###autoload(autoload 'erc-querypoll-mode "erc-goodies" nil t) -(define-erc-module querypoll nil - "Send periodic \"WHO\" requests for each query buffer. -Omit query participants who are currently present in some channel. -Instead of announcing arrivals and departures, rely on other modules, -like `nickbar', to provide UI feedback when changes occur. - -Once ERC implements the `monitor' extension, this module will serve as -an optional fallback for keeping query-participant rolls up to date on -servers that lack support or are stingy with their allotments. Until -such time, this module should be considered experimental. - -This is a local ERC module, so selectively polling only a subset of -query targets is possible but cumbersome. To do so, ensure -`erc-querypoll-mode' is enabled in the server buffer, and then toggle it -as appropriate in desired query buffers. To stop polling for the -current connection, toggle off the command \\[erc-querypoll-mode] from a -server buffer, or run \\`M-x C-u erc-querypoll-disable RET' from a -target buffer." - ((if erc--target - (if (erc-query-buffer-p) - (progn ; accommodate those who eschew `erc-modules' - (erc-with-server-buffer - (unless erc-querypoll-mode - (erc-querypoll-mode +1))) - (erc--querypoll-subscribe (current-buffer))) - (erc-querypoll-mode -1)) - (cl-assert (not erc--decouple-query-and-channel-membership-p)) - (setq-local erc--querypoll-ring (make-ring 5)) - (erc-with-all-buffers-of-server erc-server-process nil - (unless erc-querypoll-mode - (erc-querypoll-mode +1))))) - ((when erc--querypoll-timer - (cancel-timer erc--querypoll-timer)) - (if erc--target - (when-let (((erc-query-buffer-p)) - (ring (erc-with-server-buffer erc--querypoll-ring)) - (index (ring-member ring (current-buffer))) - ((not (erc--querypoll-target-in-chan-p (current-buffer))))) - (ring-remove ring index) - (unless (erc-current-nick-p (erc-target)) - (erc-remove-current-channel-member (erc-target)))) - (erc-with-all-buffers-of-server erc-server-process #'erc-query-buffer-p - (erc-querypoll-mode -1))) - (kill-local-variable 'erc--querypoll-ring) - (kill-local-variable 'erc--querypoll-timer)) - 'local) - -(cl-defmethod erc--queries-current-p (&context (erc-querypoll-mode (eql t))) t) - -(defvar erc-querypoll-period-params '(10 10 1) - "Parameters affecting the delay with respect to the number of buffers. -The elements represent some parameters of an exponential decay function, -a(e)^{-x/b}+c. The first number (a) affects the overall scaling. A -higher value means longer delays for all query buffers relative to queue -length. The second number (b) determines how quickly the delay -decreases as the queue length increases. Larger values make the delay -taper off more gradually. The last number (c) sets the minimum delay -between updates regardless of queue length.") - -(defun erc--querypoll-compute-period (queue-size) - "Calculate delay based on QUEUE-SIZE." - (let ((scale (nth 0 erc-querypoll-period-params)) - (rate (* 1.0 (nth 1 erc-querypoll-period-params))) - (min (nth 2 erc-querypoll-period-params))) - (+ (* scale (exp (/ (- queue-size) rate))) min))) - -(defun erc--querypoll-target-in-chan-p (buffer) - "Determine whether buffer's target, as a user, is joined to any channels." - (and-let* - ((target (erc--target-string (buffer-local-value 'erc--target buffer))) - (user (erc-get-server-user target)) - (buffers (erc-server-user-buffers user)) - ((seq-some #'erc-channel-p buffers))))) - -(defun erc--querypoll-get-length (ring) - "Return the effective length of RING, discounting chan members." - (let ((count 0)) - (dotimes (i (ring-length ring)) - (unless (erc--querypoll-target-in-chan-p (ring-ref ring i)) - (cl-incf count 1))) - count)) - -(defun erc--querypoll-get-next (ring) - (let ((n (ring-length ring))) - (catch 'found - (while (natnump (cl-decf n)) - (when-let ((buffer (ring-remove ring)) - ((buffer-live-p buffer))) - ;; Push back buffers for users joined to some chan. - (if (erc--querypoll-target-in-chan-p buffer) - (ring-insert ring buffer) - (throw 'found buffer))))))) - -(defun erc--querypoll-subscribe (query-buffer &optional penalty) - "Add QUERY-BUFFER to FIFO and ensure timer is running." - (when query-buffer - (cl-assert (erc-query-buffer-p query-buffer))) - (erc-with-server-buffer - (when (and query-buffer - (not (with-current-buffer query-buffer - (or (erc-current-nick-p (erc-target)) - (string-match erc-querypoll-exclude-regexp - (erc-target))))) - (not (ring-member erc--querypoll-ring query-buffer))) - (ring-insert+extend erc--querypoll-ring query-buffer)) - (unless erc--querypoll-timer - (setq erc--querypoll-timer - (let* ((length (erc--querypoll-get-length erc--querypoll-ring)) - (period (erc--querypoll-compute-period length))) - (run-at-time (+ (or penalty 0) period) - nil #'erc--querypoll-send (current-buffer))))))) - -(defun erc--querypoll-on-352 (target-nick args) - "Add or update `erc-server-users' data for TARGET-NICK from ARGS. -Then add user to participant rolls in any existing query buffers." - (pcase-let - ((`(,_ ,channel ,login ,host ,_server ,nick ,_flags, hop-real) args)) - (when (and (string= channel "*") (erc-nick-equal-p nick target-nick)) - (if-let ((user (erc-get-server-user nick))) - (erc-update-user user nick host login - (erc--extract-352-full-name hop-real)) - ;; Don't add unless target is already known. - (when (erc-get-buffer nick erc-server-process) - (erc-add-server-user - nick (make-erc-server-user - :nickname nick :login login :host host - :full-name (erc--extract-352-full-name hop-real))))) - (erc--ensure-query-member nick) - t))) - -;; This uses heuristics to associate replies to the initial request -;; because ERC does not yet support `labeled-response'. -(defun erc--querypoll-send (server-buffer) - "Send a captive \"WHO\" in SERVER-BUFFER." - (when (and (buffer-live-p server-buffer) - (buffer-local-value 'erc-server-connected server-buffer)) - (with-current-buffer server-buffer - (setq erc--querypoll-timer nil) - (if-let ((buffer (erc--querypoll-get-next erc--querypoll-ring))) - (letrec - ((target (erc--target-string - (buffer-local-value 'erc--target buffer))) - (penalty 0) - (here-fn (erc-once-with-server-event - "352" (lambda (_ parsed) - (erc--querypoll-on-352 - target (erc-response.command-args parsed))))) - (done-fn (erc-once-with-server-event - "315" - (lambda (_ parsed) - (if (memq here-fn erc-server-352-functions) - (erc-remove-user - (nth 1 (erc-response.command-args parsed))) - (remove-hook 'erc-server-352-functions here-fn t)) - (remove-hook 'erc-server-263-functions fail-fn t) - (remove-hook 'erc-server-315-functions done-fn t) - (erc--querypoll-subscribe buffer penalty) - t))) - (fail-fn (erc-once-with-server-event - "263" - (lambda (proc parsed) - (setq penalty 60) - (funcall done-fn proc parsed) - t)))) - (erc-server-send (concat "WHO " target))) - (unless (ring-empty-p erc--querypoll-ring) - (erc--querypoll-subscribe nil 30)))))) - (provide 'erc-goodies) ;;; erc-goodies.el ends here diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el index 6e8a196255b..2874e2a4a00 100644 --- a/lisp/erc/erc-ibuffer.el +++ b/lisp/erc/erc-ibuffer.el @@ -121,10 +121,10 @@ (define-ibuffer-column erc-members (:name "Users") - (if-let ((table (or erc-channel-users erc-server-users)) - ((hash-table-p table)) - (count (hash-table-count table)) - ((> count 0))) + (if-let* ((table (or erc-channel-users erc-server-users)) + ((hash-table-p table)) + (count (hash-table-count table)) + ((> count 0))) (number-to-string count) "")) diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index cb57d8a00a1..9d08121fee6 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -157,8 +157,8 @@ network or a network ID). Return nil on failure." ;; encountering errors, like a 475 ERR_BADCHANNELKEY. (defun erc-join--remove-requested-channel (_ parsed) "Remove channel from `erc-join--requested-channels'." - (when-let ((channel (cadr (erc-response.command-args parsed))) - ((member channel erc-join--requested-channels))) + (when-let* ((channel (cadr (erc-response.command-args parsed))) + ((member channel erc-join--requested-channels))) (setq erc-join--requested-channels (delete channel erc-join--requested-channels))) nil) @@ -175,7 +175,7 @@ network or a network ID). Return nil on failure." (defun erc-autojoin--join () ;; This is called in the server buffer (pcase-dolist (`(,name . ,channels) erc-autojoin-channels-alist) - (when-let ((match (erc-autojoin-server-match name))) + (when-let* ((match (erc-autojoin-server-match name))) (dolist (chan channels) (let ((buf (erc-get-buffer chan erc-server-process))) (unless (and buf (with-current-buffer buf diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 66420662c23..a1102ebdcdf 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -231,7 +231,7 @@ also be a predicate function. To only log when you are not set away, use: (add-hook 'erc-part-hook #'erc-conditional-save-buffer) ;; append, so that 'erc-initialize-log-marker runs first (add-hook 'erc-connect-pre-hook #'erc-log-setup-logging 'append) - (add-hook 'erc--pre-clear-functions #'erc-save-buffer-in-logs 50) + ;; FIXME use proper local "setup" function and major-mode hook. (dolist (buffer (erc-buffer-list)) (erc-log-setup-logging buffer)) (erc--modify-local-map t "C-c C-l" #'erc-save-buffer-in-logs)) @@ -244,7 +244,6 @@ also be a predicate function. To only log when you are not set away, use: (remove-hook 'erc-quit-hook #'erc-conditional-save-queries) (remove-hook 'erc-part-hook #'erc-conditional-save-buffer) (remove-hook 'erc-connect-pre-hook #'erc-log-setup-logging) - (remove-hook 'erc--pre-clear-functions #'erc-save-buffer-in-logs) (dolist (buffer (erc-buffer-list)) (erc-log-disable-logging buffer)) (erc--modify-local-map nil "C-c C-l" #'erc-save-buffer-in-logs))) @@ -259,6 +258,8 @@ The current buffer is given by BUFFER." (auto-save-mode -1) (setq buffer-file-name nil) (add-hook 'write-file-functions #'erc-save-buffer-in-logs nil t) + (add-function :before (local 'erc--clear-function) + #'erc-log--save-on-clear '((depth . 50))) (when erc-log-insert-log-on-open (ignore-errors (save-excursion @@ -271,6 +272,7 @@ The current buffer is given by BUFFER." "Disable logging in BUFFER." (when (erc-logging-enabled buffer) (with-current-buffer buffer + (remove-function (local 'erc--clear-function) #'erc-log--save-on-clear) (setq buffer-offer-save nil erc-enable-logging nil)))) @@ -305,6 +307,10 @@ Return nil if BUFFER is a server buffer." (erc-save-buffer-in-logs buffer))) (defvar erc-log--save-in-progress-p nil) +;; The function `erc-directory-writable-p' may signal when HOME is not +;; writable, such as when running the test suite (/nonexistent). This +;; flag tells `erc-logging-enabled' to use `file-writable-p' instead. +(defvar erc-log--check-writable-nocreate-p nil) ;;;###autoload (defun erc-logging-enabled (&optional buffer) @@ -317,7 +323,9 @@ is writable (it will be created as necessary) and (and erc-log-channels-directory (not erc-log--save-in-progress-p) (or (functionp erc-log-channels-directory) - (erc-directory-writable-p erc-log-channels-directory)) + (if erc-log--check-writable-nocreate-p + (file-writable-p erc-log-channels-directory) + (erc-directory-writable-p erc-log-channels-directory))) (if (functionp erc-enable-logging) (funcall erc-enable-logging buffer) (buffer-local-value 'erc-enable-logging buffer)))) @@ -352,13 +360,13 @@ The result is converted to lowercase, as IRC is case-insensitive." erc-log-channels-directory))))) (defun erc-generate-log-file-name-with-date (buffer &rest _ignore) - "This function computes a short log file name. + "Compute a short log file name with the current date. The name of the log file is composed of BUFFER and the current date. This function is a possible value for `erc-generate-log-file-name-function'." (concat (buffer-name buffer) "-" (format-time-string "%Y-%m-%d") ".txt")) (defun erc-generate-log-file-name-short (buffer &rest _ignore) - "This function computes a short log file name. + "Compute a short log file name. In fact, it only uses the buffer name of the BUFFER argument, so you can affect that using `rename-buffer' and the-like. This function is a possible value for @@ -415,6 +423,7 @@ You can save every individual message by putting this function on (widen) ;; early on in the initialization, don't try and write the log out (when (and (markerp erc-last-saved-position) + (null erc--insert-marker) ; suppress when splicing (> erc-insert-marker (1+ erc-last-saved-position))) (let ((start (1+ (marker-position erc-last-saved-position))) (end (marker-position erc-insert-marker))) @@ -446,14 +455,17 @@ You can save every individual message by putting this function on (set-buffer-modified-p nil)))))) t) -;; This is a kludge to avoid littering erc-truncate.el with forward -;; declarations needed only for a corner-case compatibility check. -(defun erc-log--call-when-logging-enabled-sans-module (fn) - (when (and (erc-logging-enabled) - (not (or erc-log-mode (memq 'log erc-modules)))) - (let ((dirfile (and (stringp erc-log-channels-directory) - erc-log-channels-directory))) - (funcall fn dirfile)))) +(defun erc-log--save-on-clear (_ end) + (erc-save-buffer-in-logs end)) + +;; This exists to avoid littering erc-truncate.el with forward +;; declarations needed only for a compatibility check. +(defun erc-log--check-legacy-implicit-enabling-by-truncate () + "Return non-nil when conditions for legacy \"implicit\" activation are met. +This only concerns the \\+`truncate' module." + (and (not (or erc-log-mode (memq 'log erc-modules))) + (let ((erc-log--check-writable-nocreate-p t)) + (erc-logging-enabled)))) (provide 'erc-log) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 8497382a733..6dc18bf250e 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -118,11 +118,21 @@ The following values are allowed: nil - do not highlight the message at all `nick' - highlight pal's nickname only - `message' - highlight the entire message from pal + \\+`message' - highlight the full message body from a matching pal `all' - highlight the entire message (including the nick) from pal -Any other value disables pal highlighting altogether." +A value of `nick' only highlights a matching sender's nick in the +bracketed speaker portion of the message. A value of \\+`message' +basically highlights its complement: the message-body alone, after the +speaker tag. All values for this option require a matching sender to be +an actual user on the network \(or a bot/service) as opposed to a host +name, such as that of the server itself \(e.g. \"irc.gnu.org\"). When +patterns from other user-based categories \(namely, \\+`fool' and +\\+`dangerous-host') also match, the behavior is undefined. However, in +ERC 5.6, `erc-dangerous-host-face' is known to clobber `erc-fool-face', +which in turn clobbers `erc-pal-face'. \(Other effects, such as +\\+`fool'-related invisibility may not survive such collisions.)" :type '(choice (const nil) (const nick) (const message) @@ -130,17 +140,18 @@ Any other value disables pal highlighting altogether." (defcustom erc-fool-highlight-type 'nick "Determines how to highlight messages by fools. -See `erc-fools'. - -The following values are allowed: - - nil - do not highlight the message at all - `nick' - highlight fool's nickname only - `message' - highlight the entire message from fool - `all' - highlight the entire message (including the nick) - from fool - -Any other value disables fool highlighting altogether." +Unlike with the \\+`pal' and \\+`dangerous-host' categories, ERC doesn't +only attempt to match associated patterns (here, from `erc-fools') +against a message's sender, it also checks for matches in traditional +IRC-style \"mentions\" in which a speaker addresses a USER directly: + + <speaker> USER: hi. + <speaker> USER, hi. + +However, at present, this option doesn't offer a means of highlighting +matched mentions alone. See `erc-pal-highlight-type' for a summary of +possible values and additional details common to categories like +\\+`fool' that normally match against a message's sender." :type '(choice (const nil) (const nick) (const message) @@ -165,16 +176,10 @@ Any other value disables keyword highlighting altogether." (defcustom erc-dangerous-host-highlight-type 'nick "Determines how to highlight messages by nicks from dangerous-hosts. -See `erc-dangerous-hosts'. - -The following values are allowed: - - `nick' - highlight nick from dangerous-host only - `message' - highlight the entire message from dangerous-host - `all' - highlight the entire message (including the nick) - from dangerous-host - -Any other value disables dangerous-host highlighting altogether." +Use option `erc-dangerous-hosts' to specify patterns. See +`erc-pal-highlight-type' for a summary of possible values as well as +additional details common to categories like \\+`dangerous-host' that +normally match against a message's sender." :type '(choice (const nil) (const nick) (const message) @@ -235,10 +240,14 @@ for beeping to work." (defcustom erc-text-matched-hook '(erc-log-matches) "Abnormal hook for visiting text matching a predefined \"type\". -ERC calls members with the arguments (MATCH-TYPE NUH MESSAGE), -where MATCH-TYPE is one of the symbols `current-nick', `keyword', -`pal', `dangerous-host', `fool', and NUH is an `erc-response' -sender, like bob!~bob@example.org." +ERC calls members with the arguments (MATCH-TYPE NUH MESSAGE), where +MATCH-TYPE is a symbol among `current-nick', `keyword', `pal', +`dangerous-host', and `fool'; and NUH is an `erc-response' sender, like +\"bob!~bob@example.org\" or an IRC command prefixed with the string +\"Server:\", as in \"Server:353\". MESSAGE is the current incarnation +of the just-inserted message minus a leading speaker, like \"<bob> \". +For traditional reasons, MESSAGE always includes a leading +`erc-notice-prefix' and a trailing newline." :options '(erc-log-matches erc-hide-fools erc-beep-on-match) :type 'hook) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index a5ca05b137a..d1e4a0238a1 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -831,6 +831,10 @@ respectively. The separator is given by `erc-networks--id-sep'." (len 0 :type integer :documentation "Length of active `parts' interval.")) +(define-inline erc-networks--id-string (id) + "Return the symbol for `erc-networks--id' ID as a string." + (inline-quote (symbol-name (erc-networks--id-symbol ,id)))) + ;; For now, please use this instead of `erc-networks--id-fixed-p'. (cl-defgeneric erc-networks--id-given (net-id) "Return the preassigned identifier for a network context, if any. @@ -904,8 +908,8 @@ aside) that aren't also `eq'.") (defun erc-networks--id-qualifying-init-parts () "Return opaque list of atoms to serve as canonical identifier." - (when-let ((network (erc-network)) - (nick (erc-current-nick))) + (when-let* ((network (erc-network)) + (nick (erc-current-nick))) (vector network (erc-downcase nick)))) (defvar erc-networks--id-sep "/" @@ -986,7 +990,7 @@ object." (erc-networks--rename-server-buffer (or proc erc-server-process) parsed) (erc-networks--shrink-ids-and-buffer-names-any) (erc-with-all-buffers-of-server erc-server-process #'erc-target - (when-let + (when-let* ((new-name (erc-networks--reconcile-buffer-names erc--target nid)) ((not (equal (buffer-name) new-name)))) (rename-buffer new-name 'unique)))) @@ -1002,7 +1006,7 @@ object." ((nid erc-networks--id-qualifying) (other erc-networks--id-qualifying)) "Grow NID along with that of the current buffer. Rename the current buffer if its NID has grown." - (when-let ((n (erc-networks--id-qualifying-prefix-length other nid))) + (when-let* ((n (erc-networks--id-qualifying-prefix-length other nid))) (while (and (<= (erc-networks--id-qualifying-len nid) n) (erc-networks--id-qualifying-grow-id nid))) ;; Grow and rename a visited buffer and all its targets @@ -1159,10 +1163,10 @@ TARGET to be an `erc--target' object." ((not (with-suppressed-warnings ((obsolete erc-reuse-buffers)) erc-reuse-buffers)) (cadr (split-string - (symbol-name (erc-networks--id-symbol erc-networks--id)) + (erc-networks--id-string erc-networks--id) "/"))) ((erc--target-channel-local-p target) erc-server-announced-name) - (t (symbol-name (erc-networks--id-symbol erc-networks--id)))))) + (t (erc-networks--id-string erc-networks--id))))) (defun erc-networks--ensure-unique-target-buffer-name () (when-let* ((new-name (erc-networks--construct-target-buffer-name @@ -1171,8 +1175,7 @@ TARGET to be an `erc--target' object." (rename-buffer new-name 'unique))) (defun erc-networks--ensure-unique-server-buffer-name () - (when-let* ((new-name (symbol-name (erc-networks--id-symbol - erc-networks--id))) + (when-let* ((new-name (erc-networks--id-string erc-networks--id)) ((not (equal (buffer-name) new-name)))) (rename-buffer new-name 'unique))) @@ -1387,9 +1390,9 @@ Expect ANNOUNCED to be the server's reported host name." (string= erc-server-announced-name announced))) ;; If a target buffer exists for the current process, kill this ;; stale one after transplanting its content; else reinstate. - (if-let ((actual (erc-get-buffer (erc--target-string erc--target) - new-proc)) - (erc-networks--target-transplant-in-progress-p t)) + (if-let* ((actual (erc-get-buffer (erc--target-string erc--target) + new-proc)) + (erc-networks--target-transplant-in-progress-p t)) (progn (funcall erc-networks--transplant-target-buffer-function (current-buffer) actual) @@ -1489,7 +1492,7 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let ;; buffer may have been deleted. (erc-networks--reclaim-orphaned-target-buffers new-proc erc-networks--id erc-server-announced-name) - (let* ((name (symbol-name (erc-networks--id-symbol erc-networks--id))) + (let* ((name (erc-networks--id-string erc-networks--id)) ;; When this ends up being the current buffer, either we have ;; a "given" ID or the buffer was reused on reconnecting. (existing (get-buffer name))) @@ -1593,7 +1596,7 @@ return the host alone sans URL formatting (for compatibility)." erc-server-alist))))) (s-choose (lambda (entry) (and (equal (nth 1 entry) net) - (if-let ((b (string-search ": " (car entry)))) + (if-let* ((b (string-search ": " (car entry)))) (cons (format "%s (%s)" (nth 2 entry) (substring (car entry) (+ b 2))) (cdr entry)) diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index ccf65f15abd..6d4f8c596fc 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -89,10 +89,10 @@ ERC only considers this option during module activation, so users should adjust it before connecting." :type '(repeat string)) -(defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face - erc-my-nick-face erc-pal-face erc-fool-face) +(defcustom erc-nicks-skip-faces '(erc-notice-face erc-my-nick-face) "Faces to avoid highlighting atop." - :type (erc--with-dependent-type-match (repeat face) erc-match)) + :type '(repeat face) + :package-version '(ERC . "5.6.1")) (defcustom erc-nicks-backing-face erc-button-nickname-face "Face to mix with generated one for emphasizing non-speakers." @@ -175,17 +175,20 @@ like \"@%-012n\"." (defcustom erc-nicks-track-faces 'prioritize "Show nick faces in the `track' module's portion of the mode line. -A value of nil means don't show nick faces at all. A value of -`defer' means have `track' consider nick faces only after those -ranked faces in `erc-track-faces-normal-list'. This has the -effect of \"alternating\" between a ranked \"normal\" and a nick. -The value `prioritize' means have `track' consider nick faces to -be \"normal\" unless the current speaker is the same as the -previous one, in which case pretend the value is `defer'. Like -most options in this module, updating the value mid-session is -not officially supported, although cycling \\[erc-nicks-mode] may -be worth a shot." - :type '(choice (const nil) (const defer) (const prioritize))) +A value of nil means don't show `nicks'-managed faces at all. A value +of t means treat them as non-\"normal\" faces ranked at or below +`erc-default-face'. This has the effect of always showing them while +suppressing the \"alternating\" behavior normally associated with +`erc-track-faces-normal-list' (including between the speaker and nicks +mentioned in the message body.) A value of `defer' means treat nicks as +unranked normals to favor alternating between them and ranked normals. +A value of `prioritize' exhibits the same alternating effect as `defer' +when speakers stay the same but allows a new speaker's face to +impersonate a ranked normal so that adjacent speakers alternate among +themselves before deferring to non-face normals. Like most options in +this module, updating the value mid-session is not officially supported, +although cycling \\[erc-nicks-mode] may be worth a shot." + :type '(choice boolean (const defer) (const prioritize))) (defvar erc-nicks--max-skip-search 3 ; make this an option? "Max number of faces to visit when testing `erc-nicks-skip-faces'.") @@ -306,10 +309,10 @@ lower it to the upper bound of `erc-nicks-contrast-range'." "Invert COLOR based on the CAR of `erc-nicks-contrast-range'. Don't bother if the inverted color has less contrast than the input." - (if-let ((con-input (erc-nicks--get-contrast color)) - ((< con-input (car erc-nicks-contrast-range))) - (flipped (mapcar (lambda (c) (- 1.0 c)) color)) - ((> (erc-nicks--get-contrast flipped) con-input))) + (if-let* ((con-input (erc-nicks--get-contrast color)) + ((< con-input (car erc-nicks-contrast-range))) + (flipped (mapcar (lambda (c) (- 1.0 c)) color)) + ((> (erc-nicks--get-contrast flipped) con-input))) flipped color)) @@ -362,8 +365,8 @@ input." (defun erc-nicks--redirect-face-widget-link (args) (pcase args (`(,widget face-link . ,plist) - (when-let ((face (widget-value widget)) - ((get face 'erc-nicks--custom-face))) + (when-let* ((face (widget-value widget)) + ((get face 'erc-nicks--custom-face))) (unless (symbol-file face) (setf (plist-get plist :action) (lambda (&rest _) (erc-nicks--create-defface-template face)))) @@ -515,17 +518,17 @@ Abandon search after examining LIMIT faces." (defun erc-nicks--highlight (nickname &optional base-face) "Return face for NICKNAME unless it or BASE-FACE is blacklisted." - (when-let ((trimmed (erc-nicks--trim nickname)) - ((not (member trimmed erc-nicks--downcased-skip-nicks))) - ((not (and base-face - (erc-nicks--skip-p base-face erc-nicks-skip-faces - erc-nicks--max-skip-search)))) - (key (erc-nicks--gen-key-from-format-spec trimmed))) + (when-let* ((trimmed (erc-nicks--trim nickname)) + ((not (member trimmed erc-nicks--downcased-skip-nicks))) + ((not (and base-face + (erc-nicks--skip-p base-face erc-nicks-skip-faces + erc-nicks--max-skip-search)))) + (key (erc-nicks--gen-key-from-format-spec trimmed))) (erc-nicks--get-face trimmed key))) (defun erc-nicks--highlight-button (nick-object) "Possibly add face to `erc-button--nick-user' NICK-OBJECT." - (when-let + (when-let* ((nick-object) (face (get-text-property (car (erc-button--nick-bounds nick-object)) 'font-lock-face)) @@ -580,7 +583,7 @@ Abandon search after examining LIMIT faces." (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal) #'erc-nicks-customize-face) (erc-nicks--setup-track-integration) - (add-hook 'erc-track-mode #'erc-nicks--setup-track-integration 50 t) + (add-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration 50 t) (advice-add 'widget-create-child-and-convert :filter-args #'erc-nicks--redirect-face-widget-link)) ((kill-local-variable 'erc-nicks--face-table) @@ -597,7 +600,10 @@ Abandon search after examining LIMIT faces." (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight-button) (remove-function (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals) + #'erc-nicks--track-prioritize) + (remove-function (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always) + (remove-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration t) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) nil) @@ -622,13 +628,13 @@ Abandon search after examining LIMIT faces." (customize-face new-face))) (defun erc-nicks--list-faces-help-button-action (face) - (when-let (((or (get face 'erc-nicks--custom-face) - (y-or-n-p (format "Create new persistent face for %s?" - (get face 'erc-nicks--key))))) - (nid (get face 'erc-nicks--netid)) - (foundp (lambda () - (erc-networks--id-equal-p nid erc-networks--id))) - (server-buffer (car (erc-buffer-filter foundp)))) + (when-let* (((or (get face 'erc-nicks--custom-face) + (y-or-n-p (format "Create new persistent face for %s?" + (get face 'erc-nicks--key))))) + (nid (get face 'erc-nicks--netid)) + (foundp (lambda () + (erc-networks--id-equal-p nid erc-networks--id))) + (server-buffer (car (erc-buffer-filter foundp)))) (with-current-buffer server-buffer (erc-nicks-customize-face (get face 'erc-nicks--nick))))) @@ -647,13 +653,13 @@ Abandon search after examining LIMIT faces." (facep (car (button-get (point) 'help-args)))) (button-put (point) 'help-function #'erc-nicks--list-faces-help-button-action) - (if-let ((face (car (button-get (point) 'help-args))) - ((not (get face 'erc-nicks--custom-face))) - ((not (get face 'erc-nicks--key)))) + (if-let* ((face (car (button-get (point) 'help-args))) + ((not (get face 'erc-nicks--custom-face))) + ((not (get face 'erc-nicks--key)))) (progn (delete-region (pos-bol) (1+ (pos-eol))) (forward-line -1)) - (when-let ((nid (get face 'erc-nicks--netid)) - (net (symbol-name (erc-networks--id-symbol nid)))) + (when-let* ((nid (get face 'erc-nicks--netid)) + (net (erc-networks--id-string nid))) (goto-char (button-end (point))) (skip-syntax-forward "-") (put-text-property (point) (1+ (point)) 'rear-nonsticky nil) @@ -684,8 +690,8 @@ ones." (user-error "Pool empty: all colors rejected")) (dolist (nick (hash-table-keys erc-nicks--face-table)) ;; User-tuned faces do not have an `erc-nicks--key' property. - (when-let ((face (gethash nick erc-nicks--face-table)) - (key (get face 'erc-nicks--key))) + (when-let* ((face (gethash nick erc-nicks--face-table)) + (key (get face 'erc-nicks--key))) (setq key (erc-nicks--gen-key-from-format-spec nick)) (put face 'erc-nicks--key key) (set-face-foreground face (erc-nicks--determine-color key)))) @@ -713,8 +719,8 @@ ones." Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"." (let (out) (dolist (face (face-list) (nreverse out)) - (when-let (((string-prefix-p prefix (symbol-name face))) - (color (face-foreground face))) + (when-let* (((string-prefix-p prefix (symbol-name face))) + (color (face-foreground face))) (push color out))))) (defun erc-nicks--reject-uninterned-faces (candidate) @@ -723,29 +729,55 @@ Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"." ((facep next)) ((not (intern-soft next)))) (setq candidate (cdr candidate))) - (if (and (consp candidate) (not (cdr candidate))) (car candidate) candidate)) + (erc--solo candidate)) -(define-inline erc-nicks--oursp (face) +(define-inline erc-nicks--ours-p (face) + "Return uninterned `nicks'-created face if FACE is a known list of faces." (inline-quote (and-let* ((sym (car-safe ,face)) ((symbolp sym)) ((get sym 'erc-nicks--key))) sym))) -(defun erc-nicks--check-normals (current contender contenders normals) - "Return a viable `nicks'-owned face from NORMALS in CONTENDERS. -But only do so if the CURRENT face is also one of ours and in -NORMALS and if the highest ranked CONTENDER among new faces is -`erc-default-face', the lowest ranking default priority face." - (and-let* (((eq contender 'erc-default-face)) - ((or (null current) (gethash current normals))) - (spkr (or (null current) (erc-nicks--oursp current)))) +(defvar erc-nicks-track-normal-max-rank 'erc-default-face + "Highest priority normal face still eligible to alternate with `nicks' faces. +Must appear in both `erc-track-faces-priority-list' and +`erc-track-faces-normal-list'.") + +(defun erc-nicks--assess-track-faces (current contender ranks normals) + "Return symbol face for CURRENT or t, to mean CURRENT is replaceable. +But only do so if CURRENT and CONTENDER are either nil or \"normal\" +faces ranking at or below `erc-nicks-track-normal-max-rank'. See +`erc-track--select-mode-line-face' for the expected types of RANKS and +NORMALS. Expect a non-nil CONTENDER to always be ranked." + (and-let* + (((or (null contender) (gethash contender normals))) + ((or (null current) (gethash current normals))) + (threshold (gethash erc-nicks-track-normal-max-rank (car ranks))) + ((or (null contender) (<= threshold (gethash contender (car ranks))))) + ((or (erc-nicks--ours-p current) + (null current) + (<= threshold (or (gethash current (car ranks)) 0))))))) + +(defun erc-nicks--track-prioritize (current contender contenders ranks normals) + "Return a viable non-CURRENT `nicks' face among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when-let* + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) (catch 'contender - (dolist (candidate (cdr contenders) contender) - (when-let (((not (equal candidate current))) - ((gethash candidate normals)) - (s (erc-nicks--oursp candidate)) - ((not (eq s spkr)))) + (dolist (candidate (cdr contenders)) + (when-let* (((not (equal candidate current))) + (s (erc-nicks--ours-p candidate)) + ((not (eq s spkr)))) + (throw 'contender candidate)))))) + +(defun erc-nicks--track-always (current contender contenders ranks normals) + "Return a viable `nicks' face, possibly CURRENT, among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when (erc-nicks--assess-track-faces current contender ranks normals) + (catch 'contender + (dolist (candidate (reverse (cdr contenders))) + (when (erc-nicks--ours-p candidate) (throw 'contender candidate)))))) (defun erc-nicks--setup-track-integration () @@ -755,7 +787,10 @@ NORMALS and if the highest ranked CONTENDER among new faces is ;; Variant `defer' is handled elsewhere. ('prioritize (add-function :override (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals)) + #'erc-nicks--track-prioritize)) + ('t + (add-function :override (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always)) ('nil (add-function :override (local 'erc-track--face-reject-function) #'erc-nicks--reject-uninterned-faces))))) @@ -763,9 +798,9 @@ NORMALS and if the highest ranked CONTENDER among new faces is (defun erc-nicks--remember-face-for-track (face) "Add FACE to local hash table maintained by `track' module." (or (gethash face erc-track--normal-faces) - (if-let ((sym (or (car-safe face) face)) - ((symbolp sym)) - ((get sym 'erc-nicks--key))) + (if-let* ((sym (or (car-safe face) face)) + ((symbolp sym)) + ((get sym 'erc-nicks--key))) (puthash face face erc-track--normal-faces) face))) diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index 45b0fb12c43..7e78120f799 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -262,6 +262,202 @@ with args, toggle notify status of people." (notify-on . "Detected %n on IRC network %m") (notify-off . "%n has left IRC network %m")) + +;;;; Module `querypoll' + +;; This module is similar to `notify' in that it periodically tries to +;; discover whether certain users are online. Unlike that module, it's +;; not really configurable. Rather, it only selects users you've +;; corresponded with in a query buffer, and it keeps `erc-server-users' +;; entries for them updated. + +(declare-function ring-empty-p "ring" (ring)) +(declare-function ring-insert "ring" (ring item)) +(declare-function ring-insert+extend "ring" (ring item)) +(declare-function ring-length "ring" (ring)) +(declare-function ring-member "ring" (ring item)) +(declare-function ring-ref "ring" (ring index)) +(declare-function ring-remove "ring" (ring &optional index)) + +(defvar-local erc--querypoll-ring nil) +(defvar-local erc--querypoll-timer nil) + +(defcustom erc-querypoll-exclude-regexp + (rx bot (or (: "*" (+ nonl)) (: (+ (in "A-Za-z")) "Serv")) eot) + "Pattern to skip polling for bots and services you regularly query." + :group 'erc + :package-version '(ERC . "5.6") + :type 'regexp) + +;;;###autoload(autoload 'erc-querypoll-mode "erc-notify" nil t) +(define-erc-module querypoll nil + "Send periodic \"WHO\" requests for each query buffer. +Omit query participants who are currently present in some channel. +Instead of announcing arrivals and departures, rely on other modules, +like `nickbar', to provide UI feedback when changes occur. + +Once ERC implements the `monitor' extension, this module will serve as +an optional fallback for keeping query-participant rolls up to date on +servers that lack support or are stingy with their allotments. Until +such time, this module should be considered experimental. + +This is a local ERC module, so selectively polling only a subset of +query targets is possible but cumbersome. To do so, ensure +`erc-querypoll-mode' is enabled in the server buffer, and then toggle it +as appropriate in desired query buffers. To stop polling for the +current connection, toggle off the command \\[erc-querypoll-mode] from a +server buffer, or run \\`M-x C-u erc-querypoll-disable RET' from a +target buffer." + ((if erc--target + (if (erc-query-buffer-p) + (progn ; accommodate those who eschew `erc-modules' + (erc-with-server-buffer + (unless erc-querypoll-mode + (erc-querypoll-mode +1))) + (erc--querypoll-subscribe (current-buffer))) + (erc-querypoll-mode -1)) + (cl-assert (not erc--decouple-query-and-channel-membership-p)) + (setq-local erc--querypoll-ring (make-ring 5)) + (erc-with-all-buffers-of-server erc-server-process nil + (unless erc-querypoll-mode + (erc-querypoll-mode +1))))) + ((when erc--querypoll-timer + (cancel-timer erc--querypoll-timer)) + (if erc--target + (when-let* (((erc-query-buffer-p)) + (ring (erc-with-server-buffer erc--querypoll-ring)) + (index (ring-member ring (current-buffer))) + ((not (erc--querypoll-target-in-chan-p (current-buffer))))) + (ring-remove ring index) + (unless (erc-current-nick-p (erc-target)) + (erc-remove-current-channel-member (erc-target)))) + (erc-with-all-buffers-of-server erc-server-process #'erc-query-buffer-p + (erc-querypoll-mode -1))) + (kill-local-variable 'erc--querypoll-ring) + (kill-local-variable 'erc--querypoll-timer)) + 'local) + +(cl-defmethod erc--queries-current-p (&context (erc-querypoll-mode (eql t))) t) + +(defvar erc-querypoll-period-params '(10 10 1) + "Parameters affecting the delay with respect to the number of buffers. +The elements represent some parameters of an exponential decay function, +a(e)^{-x/b}+c. The first number (a) affects the overall scaling. A +higher value means longer delays for all query buffers relative to queue +length. The second number (b) determines how quickly the delay +decreases as the queue length increases. Larger values make the delay +taper off more gradually. The last number (c) sets the minimum delay +between updates regardless of queue length.") + +(defun erc--querypoll-compute-period (queue-size) + "Calculate delay based on QUEUE-SIZE." + (let ((scale (nth 0 erc-querypoll-period-params)) + (rate (* 1.0 (nth 1 erc-querypoll-period-params))) + (min (nth 2 erc-querypoll-period-params))) + (+ (* scale (exp (/ (- queue-size) rate))) min))) + +(defun erc--querypoll-target-in-chan-p (buffer) + "Determine whether buffer's target, as a user, is joined to any channels." + (and-let* + ((target (erc--target-string (buffer-local-value 'erc--target buffer))) + (user (erc-get-server-user target)) + (buffers (erc-server-user-buffers user)) + ((seq-some #'erc-channel-p buffers))))) + +(defun erc--querypoll-get-length (ring) + "Return the effective length of RING, discounting chan members." + (let ((count 0)) + (dotimes (i (ring-length ring)) + (unless (erc--querypoll-target-in-chan-p (ring-ref ring i)) + (cl-incf count 1))) + count)) + +(defun erc--querypoll-get-next (ring) + (let ((n (ring-length ring))) + (catch 'found + (while (natnump (cl-decf n)) + (when-let* ((buffer (ring-remove ring)) + ((buffer-live-p buffer))) + ;; Push back buffers for users joined to some chan. + (if (erc--querypoll-target-in-chan-p buffer) + (ring-insert ring buffer) + (throw 'found buffer))))))) + +(defun erc--querypoll-subscribe (query-buffer &optional penalty) + "Add QUERY-BUFFER to FIFO and ensure timer is running." + (when query-buffer + (cl-assert (erc-query-buffer-p query-buffer))) + (erc-with-server-buffer + (when (and query-buffer + (not (with-current-buffer query-buffer + (or (erc-current-nick-p (erc-target)) + (string-match erc-querypoll-exclude-regexp + (erc-target))))) + (not (ring-member erc--querypoll-ring query-buffer))) + (ring-insert+extend erc--querypoll-ring query-buffer)) + (unless erc--querypoll-timer + (setq erc--querypoll-timer + (let* ((length (erc--querypoll-get-length erc--querypoll-ring)) + (period (erc--querypoll-compute-period length))) + (run-at-time (+ (or penalty 0) period) + nil #'erc--querypoll-send (current-buffer))))))) + +(defun erc--querypoll-on-352 (target-nick args) + "Add or update `erc-server-users' data for TARGET-NICK from ARGS. +Then add user to participant rolls in any existing query buffers." + (pcase-let + ((`(,_ ,channel ,login ,host ,_server ,nick ,_flags, hop-real) args)) + (when (and (string= channel "*") (erc-nick-equal-p nick target-nick)) + (if-let* ((user (erc-get-server-user nick))) + (erc-update-user user nick host login + (erc--extract-352-full-name hop-real)) + ;; Don't add unless target is already known. + (when (erc-get-buffer nick erc-server-process) + (erc-add-server-user + nick (make-erc-server-user + :nickname nick :login login :host host + :full-name (erc--extract-352-full-name hop-real))))) + (erc--ensure-query-member nick) + t))) + +;; This uses heuristics to associate replies to the initial request +;; because ERC does not yet support `labeled-response'. +(defun erc--querypoll-send (server-buffer) + "Send a captive \"WHO\" in SERVER-BUFFER." + (when (and (buffer-live-p server-buffer) + (buffer-local-value 'erc-server-connected server-buffer)) + (with-current-buffer server-buffer + (setq erc--querypoll-timer nil) + (if-let* ((buffer (erc--querypoll-get-next erc--querypoll-ring))) + (letrec + ((target (erc--target-string + (buffer-local-value 'erc--target buffer))) + (penalty 0) + (here-fn (erc-once-with-server-event + "352" (lambda (_ parsed) + (erc--querypoll-on-352 + target (erc-response.command-args parsed))))) + (done-fn (erc-once-with-server-event + "315" + (lambda (_ parsed) + (if (memq here-fn erc-server-352-functions) + (erc-remove-user + (nth 1 (erc-response.command-args parsed))) + (remove-hook 'erc-server-352-functions here-fn t)) + (remove-hook 'erc-server-263-functions fail-fn t) + (remove-hook 'erc-server-315-functions done-fn t) + (erc--querypoll-subscribe buffer penalty) + t))) + (fail-fn (erc-once-with-server-event + "263" + (lambda (proc parsed) + (setq penalty 60) + (funcall done-fn proc parsed) + t)))) + (erc-server-send (concat "WHO " target))) + (unless (ring-empty-p erc--querypoll-ring) + (erc--querypoll-subscribe nil 30)))))) + (provide 'erc-notify) ;;; erc-notify.el ends here diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index 05cbaf3872f..afbe3895667 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -187,6 +187,14 @@ for use on `completion-at-point-function'." (pcomplete-here '("cancel")) (pcomplete-opt "a")) +(defun pcomplete/erc-mode/BANLIST () + (pcomplete-opt "f")) +(defalias 'pcomplete/erc-mode/BL #'pcomplete/erc-mode/BANLIST) + +(defun pcomplete/erc-mode/MASSUNBAN () + (pcomplete-opt "f")) +(defalias 'pcomplete/erc-mode/MUB #'pcomplete/erc-mode/MASSUNBAN) + ;;; Functions that provide possible completions. (defun pcomplete-erc-commands () diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el index 1998e4f129b..65dba95d5c3 100644 --- a/lisp/erc/erc-sasl.el +++ b/lisp/erc/erc-sasl.el @@ -148,17 +148,17 @@ PLIST to contain keyword params known to `auth-source-search'." (defun erc-sasl--read-password (prompt) "Return configured option or server password. If necessary, pass PROMPT to `read-passwd'." - (if-let ((found (pcase (alist-get 'password erc-sasl--options) - ((guard (alist-get 'authfn erc-sasl--options)) - (let-alist erc-sasl--options - (let ((erc-sasl-user .user) - (erc-sasl-password .password) - (erc-sasl-mechanism .mechanism) - (erc-sasl-authzid .authzid) - (erc-sasl-auth-source-function .authfn)) - (funcall .authfn :user (erc-sasl--get-user))))) - (:password erc-session-password) - ((and (pred stringp) v) (unless (string-empty-p v) v))))) + (if-let* ((found (pcase (alist-get 'password erc-sasl--options) + ((guard (alist-get 'authfn erc-sasl--options)) + (let-alist erc-sasl--options + (let ((erc-sasl-user .user) + (erc-sasl-password .password) + (erc-sasl-mechanism .mechanism) + (erc-sasl-authzid .authzid) + (erc-sasl-auth-source-function .authfn)) + (funcall .authfn :user (erc-sasl--get-user))))) + (:password erc-session-password) + ((and (pred stringp) v) (unless (string-empty-p v) v))))) (copy-sequence (erc--unfun found)) (read-passwd prompt))) diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 0881006ed77..6ea5e03881c 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -578,13 +578,13 @@ as needed." (letrec ((attempts 3) (on-notice (lambda (_proc parsed) - (when-let ((nick (erc-extract-nick - (erc-response.sender parsed))) - ((erc-nick-equal-p nick "nickserv")) - (contents (erc-response.contents parsed)) - (case-fold-search t) - ((string-match (rx (or "ghost" "is not online")) - contents))) + (when-let* ((nick (erc-extract-nick + (erc-response.sender parsed))) + ((erc-nick-equal-p nick "nickserv")) + (contents (erc-response.contents parsed)) + (case-fold-search t) + ((string-match (rx (or "ghost" "is not online")) + contents))) (setq attempts 1) (erc-server-send (concat "NICK " want) 'force)) (when (zerop (cl-decf attempts)) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index e45fb9a7adf..ed27881abdc 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -512,13 +512,13 @@ associated with an ERC session." ". Setting to t for the current Emacs session." " Customize it permanently to avoid this message.") (setq speedbar-update-flag t)) - (when-let (((null speedbar-buffer)) - (speedbar-frame-parameters (backquote-list* - '(visibility . nil) - '(no-other-frame . t) - speedbar-frame-parameters)) - (speedbar-after-create-hook #'erc-speedbar--emulate-sidebar) - (original-frame (selected-frame))) + (when-let* (((null speedbar-buffer)) + (speedbar-frame-parameters (backquote-list* + '(visibility . nil) + '(no-other-frame . t) + speedbar-frame-parameters)) + (speedbar-after-create-hook #'erc-speedbar--emulate-sidebar) + (original-frame (selected-frame))) (erc-install-speedbar-variables) ;; Run before toggling mode to prevent timer from being ;; created twice. @@ -591,8 +591,8 @@ For controlling whether the speedbar window is selectable with (and speedbar-buffer (eq speedbar-frame (window-frame (get-buffer-window speedbar-buffer t))))) - (when-let ((buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) - (car (erc-buffer-filter #'erc--server-buffer-p))))) + (when-let* ((buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) + (car (erc-buffer-filter #'erc--server-buffer-p))))) (with-current-buffer buf (erc-speedbar--ensure 'forcep))))) ((remove-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) @@ -649,11 +649,10 @@ unlock the window." (interactive "P") (unless erc-nickbar-mode (user-error "`erc-nickbar-mode' inactive")) - (when-let ((window (get-buffer-window speedbar-buffer))) + (when-let* ((window (get-buffer-window speedbar-buffer))) (let ((val (cond ((natnump arg) t) ((integerp arg) nil) - (t (not (window-parameter window - 'no-other-window)))))) + (t (not (erc-compat--window-no-other-p window)))))) (with-current-buffer speedbar-buffer (setq cursor-type (not val))) (set-window-parameter window 'no-other-window val) @@ -670,10 +669,10 @@ unlock the window." (defun erc-speedbar--compose-nicks-face (orig buffer user cuser) (require 'erc-nicks) (let ((rv (funcall orig buffer user cuser))) - (if-let ((nick (erc-server-user-nickname user)) - (face (with-current-buffer buffer - (erc-nicks--highlight nick rv))) - ((not (eq face erc-button-nickname-face)))) + (if-let* ((nick (erc-server-user-nickname user)) + (face (with-current-buffer buffer + (erc-nicks--highlight nick rv))) + ((not (eq face erc-button-nickname-face)))) (cons face (ensure-list rv)) rv))) diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el index b2f565d71bf..5ff28fa14e8 100644 --- a/lisp/erc/erc-spelling.el +++ b/lisp/erc/erc-spelling.el @@ -52,15 +52,17 @@ (defcustom erc-spelling-dictionaries nil "An alist mapping buffer names to dictionaries. -The `car' of every cell is a buffer name, the `cadr' is the -string name of an associated dictionary. + +Each element is a list of the form (KEY VALUE), where KEY is a buffer +name and VALUE a locale or dictionary name known to `ispell', for +example: ((\"Libera.Chat\" \"en_US\") (\"#esperanto\" \"esperanto\")). + The dictionary is inherited from server buffers, so if you want a default dictionary for some server, you can use a server buffer name here." :type '(choice (const nil) - (repeat (cons (string :tag "Buffer name") - (string :tag "Dictionary")))) - :group 'erc-spelling) + (repeat (list (string :tag "Buffer name") + (string :tag "Dictionary"))))) (defun erc-spelling-init (buffer) "Enable flyspell mode in an ERC buffer. diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index bebc1d0be38..24bb510fd70 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -182,13 +182,11 @@ from entering them and instead jump over them." (add-hook 'erc-insert-modify-hook #'erc-add-timestamp 70) (add-hook 'erc-send-modify-hook #'erc-add-timestamp 70) (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect) - (add-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear 40) (unless erc--updating-modules-p (erc-buffer-do #'erc-stamp--setup))) ((remove-hook 'erc-mode-hook #'erc-stamp--setup) (remove-hook 'erc-insert-modify-hook #'erc-add-timestamp) (remove-hook 'erc-send-modify-hook #'erc-add-timestamp) (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect) - (remove-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear) (erc-buffer-do #'erc-stamp--setup))) (defvar erc-stamp--invisible-property nil @@ -199,13 +197,13 @@ from entering them and instead jump over them." (defun erc-stamp--recover-on-reconnect () "Attempt to restore \"last-inserted\" snapshots from prior session." - (when-let ((priors (or erc--server-reconnecting erc--target-priors))) + (when-let* ((priors (or erc--server-reconnecting erc--target-priors))) (dolist (var '(erc-timestamp-last-inserted erc-timestamp-last-inserted-left erc-timestamp-last-inserted-right erc-stamp--deferred-date-stamp erc-stamp--date-stamps)) - (when-let (existing (alist-get var priors)) + (when-let* ((existing (alist-get var priors))) (set var existing))))) (defvar erc-stamp--current-time nil @@ -398,14 +396,14 @@ non-nil." (goto-char (point-min)) (while (progn - (when-let (((< (point) (pos-eol))) - (end (1- (pos-eol))) - ((eq 'erc-timestamp (field-at-pos end))) - (beg (field-beginning end)) - ;; Skip a line that's just a timestamp. - ((> beg (point)))) + (when-let* (((< (point) (pos-eol))) + (end (1- (pos-eol))) + ((eq 'erc-timestamp (field-at-pos end))) + (beg (field-beginning end)) + ;; Skip a line that's just a timestamp. + ((> beg (point)))) (delete-region beg (1+ end))) - (when-let (time (erc--get-inserted-msg-prop 'erc--ts)) + (when-let* ((time (erc--get-inserted-msg-prop 'erc--ts))) (insert (format-time-string "[%H:%M:%S] " time))) (zerop (forward-line)))) "") @@ -507,10 +505,10 @@ and `erc-stamp--margin-left-p', before activating the mode." (&context (erc-stamp--display-margin-mode (eql t)) (erc-stamp--margin-left-p (eql t)) (erc-stamp--skip-left-margin-prompt-p null)) - (when-let (((null erc--hidden-prompt-overlay)) - (prompt (string-pad erc-prompt-hidden left-margin-width nil 'start)) - (ov (make-overlay erc-insert-marker (1- erc-input-marker) - nil 'front-advance))) + (when-let* (((null erc--hidden-prompt-overlay)) + (prompt (string-pad erc-prompt-hidden left-margin-width nil 'start)) + (ov (make-overlay erc-insert-marker (1- erc-input-marker) + nil 'front-advance))) (overlay-put ov 'display `((margin left-margin) ,prompt)) (setq erc--hidden-prompt-overlay ov))) @@ -536,7 +534,7 @@ and `erc-stamp--margin-left-p', before activating the mode." (goto-char (point-min)) (insert-and-inherit (setq erc-timestamp-last-inserted string)) (dolist (p erc-stamp--inherited-props) - (when-let ((v (get-text-property (point) p))) + (when-let* ((v (get-text-property (point) p))) (put-text-property (point-min) (point) p v))) (erc-put-text-property (point-min) (point) 'invisible erc-stamp--invisible-property) @@ -643,7 +641,7 @@ printed just after each line's text (no alignment)." (_ (indent-to pos))) (insert string) (dolist (p erc-stamp--inherited-props) - (when-let ((v (get-text-property (1- from) p))) + (when-let* ((v (get-text-property (1- from) p))) (put-text-property from (point) p v))) (erc-put-text-property from (point) 'field 'erc-timestamp) (erc-put-text-property from (point) 'rear-nonsticky t) @@ -707,7 +705,8 @@ Return P or, if found, a position less than P." ;; Continue searching after encountering a message without a ;; timestamp because date stamps must be unique, and ;; "Re-establishing connection" messages should have stamps. - (while-let ((q (previous-single-property-change (1- p) 'erc--ts)) + (while-let ((pp (max (1- p) (point-min))) + (q (previous-single-property-change pp 'erc--ts)) (qq (erc--get-inserted-msg-beg q)) (ts (get-text-property qq 'erc--ts)) ((not (time-less-p ts target-time)))) @@ -725,13 +724,13 @@ inserted is a date stamp." "Schedule a date stamp to be inserted via HOOK-VAR. Do so when `erc-stamp--deferred-date-stamp' and its `fn' slot are non-nil." - (when-let ((data erc-stamp--deferred-date-stamp) - ((eq (erc-stamp--date-fn data) #'ignore)) - (ct (erc-stamp--date-ts data)) - (rendered (erc-stamp--date-str data)) - (buffer (current-buffer)) - (symbol (make-symbol "erc-stamp--insert-date")) - (marker (setf (erc-stamp--date-marker data) (point-min-marker)))) + (when-let* ((data erc-stamp--deferred-date-stamp) + ((eq (erc-stamp--date-fn data) #'ignore)) + (ct (erc-stamp--date-ts data)) + (rendered (erc-stamp--date-str data)) + (buffer (current-buffer)) + (symbol (make-symbol "erc-stamp--insert-date")) + (marker (setf (erc-stamp--date-marker data) (point-min-marker)))) (setf (erc-stamp--date-fn data) symbol) (fset symbol (lambda (&rest _) @@ -753,7 +752,7 @@ non-nil." (set-marker marker (point-min)) (set-marker-insertion-type marker t) (erc--hide-message 'timestamp)) - ,@erc-insert-post-hook)) + ,@(ensure-list erc-insert-post-hook))) (erc-insert-timestamp-function #'erc-stamp--propertize-left-date-stamp) (pos (erc-stamp--find-insertion-point marker aligned)) @@ -857,15 +856,15 @@ and date stamps inserted by this function." ;; "prepended" date stamps as well. However, since this is a ;; compatibility oriented code path, and pre-5.6 did no such ;; thing, better to punt. - (if-let ((erc-stamp-prepend-date-stamps-p) - (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) - ((not (string= ts-left erc-timestamp-last-inserted-left)))) + (if-let* ((erc-stamp-prepend-date-stamps-p) + (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) + ((not (string= ts-left erc-timestamp-last-inserted-left)))) (progn (goto-char (point-min)) (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left) (insert (setq erc-timestamp-last-inserted-left ts-left))) - (when-let + (when-let* (((null erc-stamp--deferred-date-stamp)) (rendered (erc-stamp--format-date-stamp ct)) ((not (string-equal rendered erc-timestamp-last-inserted-left))) @@ -980,11 +979,16 @@ For `erc-hide-timestamps, modify `buffer-invisibility-spec'." (defun erc-stamp--setup () "Enable or disable buffer-local `erc-stamp-mode' modifications." (if erc-stamp-mode - (erc-stamp--manage-local-options-state) + (progn + (erc-stamp--manage-local-options-state) + (add-function :around (local 'erc--clear-function) + #'erc-stamp--reset-on-clear '((depth . 40)))) (let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible) (erc-stamp--manage-local-options-state)) ;; Undo local mods from `erc-insert-timestamp-left-and-right'. (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left' + (remove-function (local 'erc--clear-function) + #'erc-stamp--reset-on-clear) (kill-local-variable 'erc-stamp--last-stamp) (kill-local-variable 'erc-timestamp-last-inserted) (kill-local-variable 'erc-timestamp-last-inserted-right) @@ -1023,6 +1027,8 @@ enabled when the message was inserted." (defvar-local erc-stamp--last-stamp nil) +;; FIXME rename this to avoid confusion with IRC messages. +;; Something like `erc-stamp--on-clear-echo-area-message'. (defun erc-stamp--on-clear-message (&rest _) "Return `dont-clear-message' when operating inside the same stamp." (and erc-stamp--last-stamp erc-echo-timestamps @@ -1052,25 +1058,81 @@ with the option `erc-echo-timestamps', see the companion option (defun erc--echo-ts-csf (_window _before dir) (erc-echo-timestamp dir (erc--get-inserted-msg-prop 'erc--ts))) -(defun erc-stamp--update-saved-position (&rest _) - (remove-hook 'erc-stamp--insert-date-hook - #'erc-stamp--update-saved-position t) - (move-marker erc-last-saved-position (1- (point-max)))) - -(defun erc-stamp--reset-on-clear (pos) - "Forget last-inserted stamps when POS is at insert marker. -And discard stale references in `erc-stamp--date-stamps'." - (when erc-stamp--date-stamps - (setq erc-stamp--date-stamps - (seq-filter (lambda (o) (> (erc-stamp--date-marker o) pos)) - erc-stamp--date-stamps))) - (when (= pos (1- erc-insert-marker)) - (when erc-stamp--date-mode - (add-hook 'erc-stamp--insert-date-hook - #'erc-stamp--update-saved-position 0 t)) - (setq erc-timestamp-last-inserted nil - erc-timestamp-last-inserted-left nil - erc-timestamp-last-inserted-right nil))) +(defun erc-stamp--redo-right-stamp-post-clear (_ end) + "Append new right stamp to first inserted message after END." + ;; During truncation, the last existing right stamp is often deleted + ;; regardless of `erc-timestamp-only-if-changed-flag'. As of ERC 5.6, + ;; recreating inserted messages from scratch isn't doable. (Although, + ;; attempting surgery like this is likely unwise.) + (when-let* ((erc-stamp--date-mode) + ((< end (1- erc-insert-marker))) ; not a /CLEAR + (bounds (erc--get-inserted-msg-bounds (1+ end))) + (ts (get-text-property (car bounds) 'erc--ts)) + (format (with-suppressed-warnings + ((obsolete erc-timestamp-format-right)) + (or erc-timestamp-format-right erc-timestamp-format))) + (rendered (erc-format-timestamp ts format)) + ((not (equal rendered erc-timestamp-last-inserted-right))) + ((not (eq 'erc-timestamp (field-at-pos (1- (cdr bounds)))))) + (erc--msg-props (map-into `((erc--ts . ,ts)) 'hash-table))) + (save-excursion + (save-restriction + (let ((erc-timestamp-last-inserted erc-timestamp-last-inserted) + (erc-timestamp-last-inserted-right + erc-timestamp-last-inserted-right)) + (narrow-to-region (car bounds) (1+ (cdr bounds))) + (cl-assert (= ?\n (char-before (point-max)))) + (erc-add-timestamp)))))) + +(defun erc-stamp--reset-on-clear (orig beg end) + "Forget date stamps older than POS and remake newest culled. +Call ORIG, an `erc--clear-function', with BEG and END markers." + (let ((fullp (= (1- erc-insert-marker) end)) ; /CLEAR-p + (skipp (or (erc--memq-msg-prop 'erc--skip 'stamp) + (and erc--msg-prop-overrides + (memq 'stamp (alist-get 'erc--skip + erc--msg-prop-overrides))))) + (culled ())) + (when erc-stamp--date-stamps + (setq erc-stamp--date-stamps + ;; Assume `seq-filter' visits items in order. + (seq-filter (lambda (o) + (or (> (erc-stamp--date-marker o) end) + (ignore + (set-marker (erc-stamp--date-marker o) nil) + (push o culled)))) + erc-stamp--date-stamps))) + ;; Before /CLEAR'ing a data stamp, skip past last blank in headroom. + (when (and fullp culled (not skipp) (< 1 beg 3 end)) + (set-marker beg 3)) + (funcall orig beg end) + (when-let* ((culled) + ((not skipp)) + (ct (erc-stamp--date-ts (car culled))) + (hook (make-symbol "temporary-hook")) + (rendered (erc-stamp--format-date-stamp ct)) + (data (make-erc-stamp--date :ts ct :str rendered))) + (cl-assert erc-stamp--date-mode) + ;; Object successfully removed from model but snapshot remains. + (cl-assert (null (cl-find rendered erc-stamp--date-stamps + :test #'string= + :key #'erc-stamp--date-str))) + (let ((erc-stamp--deferred-date-stamp data) + ;; At midnight, `rendered' may still be yesterday while + ;; `erc-timestamp-last-inserted-left' is already today. + (erc-timestamp-last-inserted-left nil)) + (erc-stamp--defer-date-insertion-on-post-modify hook) + (set-marker (erc-stamp--date-marker data) end) + (run-hooks hook) + ;; After /CLEAR'ing, remove new date stamp's trailing newline + ;; because one resides between `end' and `erc-input-marker' + ;; (originally meant to protect `erc-last-saved-position'). + (when (and fullp (= end erc-last-saved-position)) + (cl-assert (or erc--called-as-input-p (null erc--msg-props))) + (delete-region (1- end) end))) + (when fullp + (setq erc-timestamp-last-inserted-right nil + erc-timestamp-last-inserted nil))))) (defun erc-stamp--dedupe-date-stamps (old-stamps) "Update `erc-stamp--date-stamps' from its counterpart OLD-STAMPS. @@ -1082,9 +1144,9 @@ copy non-duplicate `erc-stamp--date' objects from OLD-STAMPS to the current buffer's, maintaining order." (let (need) (dolist (old old-stamps) - (if-let ((new (cl-find (erc-stamp--date-str old) erc-stamp--date-stamps - :test #'string= :key #'erc-stamp--date-str)) - (new-marker (erc-stamp--date-marker new))) + (if-let* ((new (cl-find (erc-stamp--date-str old) erc-stamp--date-stamps + :test #'string= :key #'erc-stamp--date-str)) + (new-marker (erc-stamp--date-marker new))) ;; The new buffer now has a duplicate stamp, so remove the ;; "newer" one from the buffer. (progn diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el index dcdef7cfafc..bb11ade221d 100644 --- a/lisp/erc/erc-status-sidebar.el +++ b/lisp/erc/erc-status-sidebar.el @@ -258,17 +258,17 @@ current frame only." (erc-track-mode +1)) (add-hook 'erc--setup-buffer-hook #'erc-status-sidebar--open) ;; Preserve side-window dimensions after `custom-buffer-done'. - (when-let (((not erc--updating-modules-p)) - (buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) - (car (erc-buffer-filter - (lambda () erc-server-connected)))))) + (when-let* (((not erc--updating-modules-p)) + (buf (or (and (derived-mode-p 'erc-mode) (current-buffer)) + (car (erc-buffer-filter + (lambda () erc-server-connected)))))) (with-current-buffer buf (erc-status-sidebar--open)))) ((remove-hook 'erc--setup-buffer-hook #'erc-status-sidebar--open) (erc-status-sidebar-close 'all-frames) - (when-let ((arg erc--module-toggle-prefix-arg) - ((numberp arg)) - ((< arg 0))) + (when-let* ((arg erc--module-toggle-prefix-arg) + ((numberp arg)) + ((< arg 0))) (erc-status-sidebar-kill)))) ;;;###autoload @@ -308,7 +308,7 @@ even if one already exists in another frame." (defun erc-status-sidebar-prefer-target-as-name (buffer) "Return some name to represent buffer in the sidebar." - (if-let ((target (buffer-local-value 'erc--target buffer))) + (if-let* ((target (buffer-local-value 'erc--target buffer))) (cond ((and erc-status-sidebar--trimpat (erc--target-channel-p target)) (string-trim-left (erc--target-string target) erc-status-sidebar--trimpat)) @@ -340,8 +340,8 @@ even if one already exists in another frame." (let ((erc-status-sidebar--trimpat (and (eq erc-status-sidebar-style 'all-mixed) (with-current-buffer (process-buffer proc) - (when-let ((ch-pfxs (erc--get-isupport-entry - 'CHANTYPES 'single))) + (when-let* ((ch-pfxs (erc--get-isupport-entry + 'CHANTYPES 'single))) (regexp-quote ch-pfxs))))) (erc-status-sidebar--prechan (and (eq erc-status-sidebar-style @@ -390,8 +390,8 @@ focused window." (next (cadr (member buffer buflist))) ((buffer-live-p next)) (proc (buffer-local-value 'erc-server-process next)) - (id (process-get proc 'erc-networks--id))) - (symbol-name (erc-networks--id-symbol id))) + (id (process-get proc 'erc-networks--id)) + ((erc-networks--id-string id)))) "???") "\n")) @@ -484,7 +484,7 @@ name stand out." (cl-assert (eq major-mode 'erc-status-sidebar-mode)) (cl-assert (eq (selected-window) window)) (cl-assert (eq (window-buffer window) (current-buffer))) - (when-let ((buf (get-text-property pos 'erc-buf))) + (when-let* ((buf (get-text-property pos 'erc-buf))) ;; Option operates relative to last selected window (select-window (get-mru-window nil nil 'not-selected)) (pop-to-buffer buf erc-status-sidebar-click-display-action))))) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 39a4775ddca..97fb7e726bd 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,25 +161,33 @@ The faces used are the same as used for text in the buffers. \(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)" :type 'boolean) +;; In an emergency, users can opt out of this migration with: +;; +;; (put 'erc-track-faces-priority-list 'erc-track--obsolete-faces t) +;; (put 'erc-track-faces-normal-list 'erc-track--obsolete-faces t) +;; (defun erc-track--massage-nick-button-faces (sym val &optional set-fn) - "Transform VAL of face-list option SYM to have new defaults. -Use `set'-compatible SET-FN when given. If an update was -performed, set the symbol property `erc-track--obsolete-faces' of -SYM to t." - (let* ((changedp nil) - (new (mapcar - (lambda (f) - (if (and (eq (car-safe f) 'erc-nick-default-face) - (equal f '(erc-nick-default-face erc-default-face))) - (progn - (setq changedp t) - (put sym 'erc-track--obsolete-faces t) - (cons 'erc-button-nick-default-face (cdr f))) - f)) - val))) - (if set-fn - (funcall set-fn sym (if changedp new val)) - (set-default sym (if changedp new val))))) + "Transform VAL of face-list option SYM to remove/replace obsolete items. +Use `set'-compatible SET-FN when given. Record any migrations as cons +cells of (OLD . NEW) in the symbol property `erc-track--obsolete-faces' +of SYM." + (let* ((oldface '(erc-nick-default-face erc-default-face)) + (newface '(erc-button-nick-default-face erc-default-face)) + (migrations (get sym 'erc-track--obsolete-faces)) + (new (if migrations + val + (delq nil + (mapcar + (lambda (f) + (if (equal f oldface) + (setf (alist-get oldface migrations + nil nil #'equal) + (and (not (member newface val)) newface)) + f)) + val))))) + (when migrations + (put sym 'erc-track--obsolete-faces migrations)) + (if set-fn (funcall set-fn sym new) (set-default sym new)))) (defcustom erc-track-faces-priority-list '(erc-error-face @@ -191,6 +199,7 @@ SYM to t." (erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face erc-action-face @@ -204,7 +213,7 @@ be highlighted using that face. The first matching face is used. Note that ERC prioritizes certain faces reserved for critical messages regardless of this option's value." - :package-version '(ERC . "5.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -229,8 +238,10 @@ setting this variable might not be very useful." '((erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face + erc-notice-face erc-action-face) "A list of faces considered to be part of normal conversations. This list is used to highlight active buffer names in the mode line. @@ -246,7 +257,7 @@ module. To see your changes reflected mid-session, cycle \\[erc-track-mode]. The effect may be disabled by setting this variable to nil." - :package-version '(ERC . "5.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -398,12 +409,12 @@ For now, omit relevant options like `erc-track-shorten-start' and friends, even though they do affect the outcome, because they likely change too infrequently to matter over sub-second intervals and are unlikely to be let-bound or set locally." - (when-let ((hash (setq erc-track--shortened-names-current-hash - (sxhash-equal (list channel-names - (buffer-list) - erc-track-shorten-function)))) - (erc-track--shortened-names) - ((= hash (car erc-track--shortened-names)))) + (when-let* ((hash (setq erc-track--shortened-names-current-hash + (sxhash-equal (list channel-names + (buffer-list) + erc-track-shorten-function)))) + (erc-track--shortened-names) + ((= hash (car erc-track--shortened-names)))) (cdr erc-track--shortened-names))) (gv-define-simple-setter erc-track--shortened-names-get @@ -636,49 +647,79 @@ keybindings will not do anything useful." (erc-track-enable)) (set sym val)))) +(defvar-local erc-track--priority-faces nil + "Local copy of `erc-track-faces-priority-list' as a hash table. +Keys are faces and values are rank integers (smaller is more important).") + (defvar-local erc-track--normal-faces nil - "Local copy of `erc-track-faces-normal-list' as a hash table.") + "Local copy of `erc-track-faces-normal-list' as a hash table. +Keys and values are faces. The table is weak valued so it can double as +a buttonizing cache. See `erc-button-add-button' and `erc--merge-prop'.") (defun erc-track--setup () "Initialize a buffer for use with the `track' module. -If this is a server buffer or `erc-track-faces-normal-list' is -locally bound, create a new `erc-track--normal-faces' for the -current buffer. Otherwise, set the local value to the server -buffer's." +If this is a server buffer or either `erc-track-faces-normal-list' or +`erc-track-faces-priority-list' is locally bound, create a new cache +table with corresponding local variable `erc-track--normal-faces' or +`erc-track--priority-faces'. Otherwise, in target buffers with no local +binding, set the cache variable's local value to that of server's." (if erc-track-mode - (let ((existing (erc-with-server-buffer erc-track--normal-faces)) - (localp (and erc--target - (local-variable-p 'erc-track-faces-normal-list))) - (opts '(erc-track-faces-normal-list erc-track-faces-priority-list)) - warnp table) + (let (warnp) ;; Don't bother warning users who've disabled `button'. - (unless (or erc--target (not (or (bound-and-true-p erc-button-mode) - (memq 'button erc-modules)))) - (when (or localp (local-variable-p 'erc-track-faces-priority-list)) - (dolist (opt opts) + (unless (or erc--target + (not (or (bound-and-true-p erc-button-mode) + (memq 'button erc-modules)))) + (dolist (opt '(erc-track-faces-normal-list + erc-track-faces-priority-list)) + (when (local-variable-p opt) (erc-track--massage-nick-button-faces opt (symbol-value opt) - #'set))) - (dolist (opt opts) - (when (get opt 'erc-track--obsolete-faces) - (push opt warnp) + #'set)) + (when-let* ((migrations (get opt 'erc-track--obsolete-faces)) + ((consp migrations))) + (push (cons opt + (mapcar (pcase-lambda (`(,old . ,new)) + (format (if new "changed %s to %s" + "removed %s") + old new)) + migrations)) + warnp) (put opt 'erc-track--obsolete-faces nil))) (when warnp - (erc--warn-once-before-connect 'erc-track-mode - (if (cdr warnp) "Options " "Option ") - (mapconcat (lambda (o) (format "`%S'" o)) warnp " and ") - (if (cdr warnp) " contain" " contains") - " an obsolete item, %S, intended to match buttonized nicknames." - " ERC has changed it to %S for the current session." - " Please save the current value to silence this message." - '(erc-nick-default-face erc-default-face) - '(erc-button-nick-default-face erc-default-face)))) - (when (or (null existing) localp) - (setq table (map-into (mapcar (lambda (f) (cons f f)) - erc-track-faces-normal-list) - '(hash-table :test equal :weakness value)))) - (setq erc-track--normal-faces (or table existing)) - (unless (or localp existing) - (erc-with-server-buffer (setq erc-track--normal-faces table)))) + (pcase-dolist (`(,opt . ,migrations) warnp) + (erc--warn-once-before-connect 'erc-track-mode + "Option `%S' contains " + (if (cdr migrations) "obsolete items." "an obsolete item.") + " ERC has done the following for the current session: %s." + " Please review these changes and, if convinced," + " silence this message by saving the current value." + opt (string-join migrations ", "))))) + ;; Set `erc-track--priority-faces' cache to new or shared value. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-priority-list))) + (existing (erc-with-server-buffer erc-track--priority-faces)) + (table (or (and (not localp) existing) + (let ((p 0)) + (map-into + (mapcar (lambda (f) (cons f (cl-incf p))) + (append erc-track--attn-faces + erc-track-faces-priority-list)) + `(hash-table :test equal)))))) + (setq erc-track--priority-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--priority-faces table)))) + ;; Likewise for `erc-track--normal-faces' cache. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-normal-list))) + (existing (erc-with-server-buffer erc-track--normal-faces)) + (table (or (and (not localp) existing) + (map-into (mapcar (lambda (f) (cons f f)) + erc-track-faces-normal-list) + `(hash-table :test equal + :weakness value))))) + (setq erc-track--normal-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--normal-faces table))))) + (kill-local-variable 'erc-track--priority-faces) (kill-local-variable 'erc-track--normal-faces))) ;;; Visibility @@ -768,7 +809,7 @@ is displayed according to `erc-track-mouse-face'." ;; (really?), 3. the defun needs to switch to BUFFER, so we would ;; need to save that value somewhere. (let ((map (make-sparse-keymap)) - (name (if erc-track-showcount + (name (if (and count erc-track-showcount) (concat string erc-track-showcount-string (int-to-string count)) @@ -915,44 +956,54 @@ them, it can't be replaced." (defvar erc-track--alt-normals-function nil "A function to possibly elect a \"normal\" face. Called with the current incumbent and the worthiest new contender -followed by all new contending faces and so-called \"normal\" -faces. See `erc-track--select-mode-line-face' for their meanings -and expected types. This function should return a face or nil.") +followed by all new contending faces, ranked faces, and so-called +\"normal\" faces. See `erc-track--select-mode-line-face' for their +meanings and expected types. This function should return a face or nil.") (defun erc-track--select-mode-line-face (cur-face new-faces ranks normals) "Return CUR-FACE or a replacement for displaying in the mode-line, or nil. -Expect RANKS to be a list of faces and both NORMALS and the car -of NEW-FACES to be hash tables mapping faces to non-nil values. -Assume the latter's makeup and that of RANKS to resemble -`erc-track-faces-normal-list' and `erc-track-faces-priority-list'. -If NEW-FACES has a cdr, expect it to be its car's contents -ordered from most recently seen (later in the buffer) to -earliest. In general, act like `erc-track-select-mode-line-face' -except appeal to `erc-track--alt-normals-function' if it's -non-nil, falling back on reconsidering NEW-FACES when CUR-FACE -outranks all its members. That is, choose the first among RANKS -in NEW-FACES not equal to CUR-FACE. Failing that, choose the -first face in NEW-FACES that's also in NORMALS, assuming -NEW-FACES has a cdr." +Expect NEW-FACES to be a cons cell whose car is a hash table mapping +faces present in the applicable region to t and whose cdr is its car's +contents ordered from most recently seen (later in the buffer) to +earliest. Expect RANKS to be a cons cell whose car is a hash table +similar to `erc-track--priority-faces' and whose cdr is a list of +prioritized faces resembling `erc-track-faces-priority-list'. Expect +NORMALS to be a hash table mapping faces to themselves. In general, act +identically to `erc-track-select-mode-line-face', except appeal to +`erc-track--alt-normals-function' if it's non-nil, and fall back on +reconsidering only NEW-FACES appearing in NORMALS when CUR-FACE is +itself \"normal\" and outranks all NEW-FACES. That is, choose the first +among RANKS in both NEW-FACES and NORMALS not equal to CUR-FACE. +Failing that, choose the first face in both NEW-FACES and NORMALS." (cl-check-type erc-track-ignore-normal-contenders-p null) (cl-check-type new-faces cons) - (when-let ((choice (catch 'face - (dolist (candidate ranks) - (when (or (equal candidate cur-face) - (gethash candidate (car new-faces))) - (throw 'face candidate)))))) + ;; Choose the highest ranked face in `erc-track-faces-priority-list' + ;; that's either `cur-face' itself or one appearing in the region + ;; being processed. + (when-let* ((choice (catch 'face + (dolist (candidate (cdr ranks)) + (when (or (equal candidate cur-face) + (gethash candidate (car new-faces))) + (throw 'face candidate)))))) (or (and erc-track--alt-normals-function (funcall erc-track--alt-normals-function - cur-face choice new-faces normals)) + cur-face choice new-faces ranks normals)) + ;; If `choice' is still `cur-face' and also a "normal", attempt + ;; to choose another normal in order to produce the flickering + ;; effect mentioned in the doc of `erc-track-faces-normal-list'. (and (equal choice cur-face) (gethash choice normals) (catch 'face + ;; If ranked "normal" faces other than `choice' appear in + ;; the region, return the most important one. (progn - (dolist (candidate ranks) + (dolist (candidate (cdr ranks)) (when (and (not (equal candidate choice)) (gethash candidate (car new-faces)) (gethash choice normals)) (throw 'face candidate))) + ;; Otherwise, go with any "normal" face other than + ;; `choice' in the region. (dolist (candidate (cdr new-faces)) (when (and (not (equal candidate choice)) (gethash candidate normals)) @@ -989,21 +1040,31 @@ the current buffer is in `erc-mode'." ;; (in the car), change its face attribute (in the cddr) if ;; necessary. See `erc-modified-channels-alist' for the ;; exact data structure used. - (when-let + (when-let* ((faces (if erc-track-ignore-normal-contenders-p (erc-faces-in (buffer-string)) - (erc-track--get-faces-in-current-message))) + (erc-track--collect-faces-in))) (normals erc-track--normal-faces) (erc-track-faces-priority-list `(,@erc-track--attn-faces ,@erc-track-faces-priority-list)) - (ranks erc-track-faces-priority-list) + (ranks (cons erc-track--priority-faces + erc-track-faces-priority-list)) ((not (and (or (eq erc-track-priority-faces-only 'all) (member this-channel erc-track-priority-faces-only)) - (not (catch 'found - (dolist (f ranks) - (when (gethash f (or (car-safe faces) faces)) - (throw 'found t))))))))) + ;; Iterate over the shorter of `ranks' and `faces'. + (let* ((r>fp (or erc-track-ignore-normal-contenders-p + (> (hash-table-count (car ranks)) + (hash-table-count (car faces))))) + (elems (cond ((not r>fp) (cdr ranks)) ; f>=r + (erc-track-ignore-normal-contenders-p + faces) + ((cdr faces)))) + (table (if r>fp (car ranks) (car faces)))) + (not (catch 'found + (dolist (f elems) + (when (gethash f table) + (throw 'found t)))))))))) (progn ; FIXME remove `progn' on next major edit (if (not (assq (current-buffer) erc-modified-channels-alist)) ;; Add buffer, faces and counts @@ -1017,7 +1078,7 @@ the current buffer is in `erc-mode'." nil faces ranks normals)))) erc-modified-channels-alist)) ;; Else modify the face for the buffer, if necessary. - (when faces + (when (or erc-track-ignore-normal-contenders-p (cdr faces)) (let* ((cell (assq (current-buffer) erc-modified-channels-alist)) (old-face (cddr cell)) @@ -1057,25 +1118,25 @@ the current buffer is in `erc-mode'." (defvar erc-track--face-reject-function nil "Function called with face in current buffer to massage or reject.") -(defun erc-track--get-faces-in-current-message () - "Collect all faces in the narrowed buffer. -Return a cons of a hash table and a list ordered from most -recently seen to earliest seen." - (let ((i (text-property-not-all (point-min) (point-max) 'font-lock-face nil)) - (seen (make-hash-table :test #'equal)) - ;; - (rfaces ()) - (faces (make-hash-table :test #'equal))) - (while-let ((i) - (cur (get-text-property i 'face))) - (unless (gethash cur seen) - (puthash cur t seen) - (when erc-track--face-reject-function - (setq cur (funcall erc-track--face-reject-function cur))) - (when cur - (push cur rfaces) - (puthash cur t faces))) - (setq i (next-single-property-change i 'font-lock-face))) +(defun erc-track--collect-faces-in () + "Collect all faces in the (presumably narrowed) current buffer. +Return a cons cell of a hash table and a list ordered from most recently +seen to least." + (let* ((prop (if noninteractive 'font-lock-face 'face)) + (p (text-property-not-all (point-min) (point-max) prop nil)) + (seen (and p (make-hash-table :test #'equal))) + (faces (make-hash-table :test #'equal)) + (rfaces ())) + (while p + (when-let* ((cur (get-text-property p prop))) + (unless (gethash cur seen) + (puthash cur t seen) + (when erc-track--face-reject-function + (setq cur (funcall erc-track--face-reject-function cur))) + (when cur + (push cur rfaces) + (puthash cur t faces)))) + (setq p (next-single-property-change p prop))) (cons faces rfaces))) ;;; Buffer switching @@ -1153,8 +1214,8 @@ unless any passes.") (current-buffer)) (setq erc-track-last-non-erc-buffer (current-buffer))) ;; and jump to the next active channel - (if-let ((buf (erc-track-get-active-buffer arg)) - ((buffer-live-p buf))) + (if-let* ((buf (erc-track-get-active-buffer arg)) + ((buffer-live-p buf))) (funcall fun buf) (erc-modified-channels-update) (erc-track--switch-buffer fun arg))) @@ -1183,7 +1244,7 @@ reverse it." (erc-track--switch-buffer 'switch-to-buffer-other-window arg)) (defun erc-track--replace-killed-buffer (existing) - (when-let ((found (assq existing erc-modified-channels-alist))) + (when-let* ((found (assq existing erc-modified-channels-alist))) (setcar found (current-buffer)))) (provide 'erc-track) diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el index 4b602074ebb..b6666c76f33 100644 --- a/lisp/erc/erc-truncate.el +++ b/lisp/erc/erc-truncate.el @@ -36,41 +36,71 @@ :group 'erc) (defcustom erc-max-buffer-size 30000 - "Maximum size in chars of each ERC buffer. -Used only when auto-truncation is enabled. -\(see `erc-truncate-buffer' and `erc-insert-post-hook')." + "Buffer size in characters after truncation. +Only applies when the `truncate' module is enabled." :type 'integer) +(defcustom erc-truncate-padding-size 4096 + "Headroom threshold triggering truncation and determining its frequency. +Truncation occurs when the buffer's size meets or exceeds this value +plus `erc-max-buffer-size'." + :type 'integer + :package-version '(ERC . "5.6.1")) + ;;;###autoload(autoload 'erc-truncate-mode "erc-truncate" nil t) (define-erc-module truncate nil "Truncate a query buffer if it gets too large. This prevents the query buffer from getting too large, which can bring any grown Emacs to its knees after a few days worth of -tracking heavy-traffic channels." +tracking heavy-traffic channels. + +Before ERC 5.6, this module performed logging whenever the \\+`log' +module's library, \\+`erc-log', happened to be loaded, regardless of +whether the \\+`log' module itself was enabled. (Loading can of course +happen in any number of ways, such as when browsing options via +\\[customize-group] or completing autoloaded symbol names at the +\\[describe-variable] prompt.) Users of \\+`truncate' who prefer the +old behavior can add \\+`log' to `erc-modules' to get the same effect. +Those who don't want logging but need to load the \\+`erc-log' library +for other purposes should customize either `erc-enable-logging' or +`erc-log-channels-directory' to avoid the annoying warning." ;;enable ((add-hook 'erc-insert-done-hook #'erc-truncate-buffer) - (add-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging)) + (add-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging) + (add-hook 'erc-mode-hook #'erc-truncate--setup) + (unless erc--updating-modules-p (erc-buffer-do #'erc-truncate--setup))) ;; disable ((remove-hook 'erc-insert-done-hook #'erc-truncate-buffer) - (remove-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging))) + (remove-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging) + (remove-hook 'erc-mode-hook #'erc-truncate--setup) + (erc-buffer-do #'erc-truncate--setup))) + +(defvar-local erc-truncate--buffer-size nil + "Temporary buffer-local override for `erc-max-buffer-size'.") + +(defun erc-truncate--setup () + "Enable or disable buffer-local `erc-truncate-mode' modifications." + (if erc-truncate-mode + (progn + (when-let* ((priors (or erc--server-reconnecting erc--target-priors)) + (val (alist-get 'erc-truncate--buffer-size priors))) + (setq erc-truncate--buffer-size val)) + (add-function :before (local 'erc--clear-function) + #'erc-truncate--inhibit-when-local-and-interactive + '((depth . 20)))) + (remove-function (local 'erc--clear-function) + #'erc-truncate--inhibit-when-local-and-interactive) + (kill-local-variable 'erc-truncate--buffer-size))) (defun erc-truncate--warn-about-logging (&rest _) (when (and (not erc--target) - (fboundp 'erc-log--call-when-logging-enabled-sans-module)) - ;; We could also enable `erc-log-mode' here, but the risk of - ;; lasting damage is nonzero. - (erc-log--call-when-logging-enabled-sans-module - (lambda (dirfile) - ;; Emit a real Emacs warning because the message may be - ;; truncated away before it can be read if merely inserted. - (erc-button--display-error-notice-with-keys-and-warn - "The `truncate' module no longer enables logging implicitly." - " If you want ERC to write logs before truncating, add `log' to" - " `erc-modules' using something like \\[customize-option]." - " To silence this message, don't `require' `erc-log'." - (and dirfile " Alternatively, change the value of") - (and dirfile " `erc-log-channels-directory', or move ") - dirfile (and dirfile " elsewhere.")))))) + (fboundp 'erc-log--check-legacy-implicit-enabling-by-truncate) + (erc-log--check-legacy-implicit-enabling-by-truncate)) + ;; Emit a real Emacs warning because the message may be + ;; truncated away before it can be read if merely inserted. + (erc-button--display-error-notice-with-keys-and-warn + "The `truncate' module no longer enables logging implicitly." + " See the doc string for `erc-truncate-mode' for details."))) ;;;###autoload (defun erc-truncate-buffer-to-size (size &optional buffer) @@ -90,49 +120,60 @@ present in `erc-modules'." (setq buffer (current-buffer)) (unless (get-buffer buffer) (error "erc-truncate-buffer-to-size: %S is not a buffer" buffer))) - (when (> (buffer-size buffer) (+ size 512)) + (when (and (> (buffer-size buffer) (+ size erc-truncate-padding-size)) + (not (buffer-local-value 'erc--inhibit-clear-p buffer))) (with-current-buffer buffer - ;; Note that when erc-insert-post-hook runs, the buffer is - ;; narrowed to the new message. So do this delicate widening. - ;; I am not sure, I think this was not recommended behavior in - ;; Emacs 20. - (save-restriction - (widen) - (let ((end (- erc-insert-marker size))) - ;; Truncate at message boundary (formerly line boundary - ;; before 5.6). - (goto-char end) - (goto-char (or (erc--get-inserted-msg-beg end) - (pos-bol))) - (setq end (point)) - ;; try to save the current buffer using - ;; `erc-save-buffer-in-logs'. We use this, in case the - ;; user has both `erc-save-buffer-in-logs' and - ;; `erc-truncate-buffer' in `erc-insert-post-hook'. If - ;; this is the case, only the non-saved part of the current - ;; buffer should be saved. Rather than appending the - ;; deleted part of the buffer to the log file. - ;; - ;; Alternatively this could be made conditional on: - ;; (not (memq 'erc-save-buffer-in-logs - ;; erc-insert-post-hook)) - ;; Comments? - ;; The comments above concern pre-5.6 behavior and reflect - ;; an obsolete understanding of how `erc-logging-enabled' - ;; behaves in practice. - (run-hook-with-args 'erc--pre-clear-functions end) - ;; disable undoing for the truncating - (buffer-disable-undo) - (let ((inhibit-read-only t)) - (delete-region (point-min) end))) - (buffer-enable-undo))))) + (let ((wc (and (get-buffer-window) (current-window-configuration)))) + (save-excursion + ;; Widen to preserve pre-5.5 behavior. + (save-restriction + (widen) + (let ((beg (point-min-marker)) + (end (goto-char (- erc-insert-marker size)))) + ;; Truncate at message boundary (formerly line boundary + ;; before 5.6). + (goto-char (or (erc--get-inserted-msg-beg end) (pos-bol))) + (setq end (point-marker)) + (with-silent-modifications + (let ((erc--inhibit-clear-p t)) + (funcall erc--clear-function beg end))) + (set-marker beg nil) + (set-marker end nil)))) + (when wc + (set-window-configuration wc)))))) ;;;###autoload (defun erc-truncate-buffer () "Truncate current buffer to `erc-max-buffer-size'." (interactive) + ;; This `save-excursion' only exists for historical reasons because + ;; `erc-truncate-buffer-to-size' normally runs in a different buffer. (save-excursion - (erc-truncate-buffer-to-size erc-max-buffer-size))) + (if (and erc--parsed-response erc--msg-props) + (when-let* + (((not erc--inhibit-clear-p)) + ((not (erc--memq-msg-prop 'erc--skip 'truncate))) + ;; Determine here because this may be a target buffer and + ;; the hook always runs in the server buffer. + (size (if (and erc-truncate--buffer-size + (> erc-truncate--buffer-size erc-max-buffer-size)) + erc-truncate--buffer-size + erc-max-buffer-size)) + (symbol (make-symbol "erc-truncate--buffer-deferred")) + (buffer (current-buffer))) + (fset symbol + (lambda (&rest _) + (remove-hook 'erc-timer-hook symbol t) + (erc-truncate-buffer-to-size size buffer))) + (erc-with-server-buffer (add-hook 'erc-timer-hook symbol -80 t))) + (unless erc--inhibit-clear-p + (erc-truncate-buffer-to-size erc-max-buffer-size))))) + +(defun erc-truncate--inhibit-when-local-and-interactive (&rest _) + "Ensure `erc-truncate--buffer-size' is nil on /CLEAR." + (when (and erc--called-as-input-p erc-truncate--buffer-size) + (message "Resetting max buffer size to %d" erc-max-buffer-size) + (setq erc-truncate--buffer-size nil))) (provide 'erc-truncate) ;;; erc-truncate.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 688d2f4b1ae..ad279a0ff66 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -12,7 +12,7 @@ ;; David Edmondson (dme@dme.org) ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) -;; Version: 5.6.0.30.1 +;; Version: 5.6.1-git ;; Package-Requires: ((emacs "27.1") (compat "29.1.4.5")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -70,7 +70,7 @@ (require 'auth-source) (eval-when-compile (require 'subr-x)) -(defconst erc-version "5.6.0.30.1" +(defconst erc-version "5.6.1-git" "This version of ERC.") (defvar erc-official-location @@ -87,7 +87,8 @@ ("5.4" . "28.1") ("5.4.1" . "29.1") ("5.5" . "29.1") - ("5.6" . "30.1"))) + ("5.6" . "30.1") + ("5.6.1" . "31.1"))) (defgroup erc nil "Emacs Internet Relay Chat client." @@ -173,7 +174,8 @@ as of ERC 5.6: and help text, and on outgoing messages unless echoed back by the server (assuming future support) - - `erc--spkr': a string, the nick of the person speaking + - `erc--spkr': a string, the non-case-mapped nick of the speaker as + stored in the `nickname' slot of its `erc-server-users' item - `erc--ctcp': a CTCP command, like `ACTION' @@ -565,9 +567,9 @@ restore the described historical behavior.") (defun erc--ensure-query-member (nick) "Populate membership table in query buffer for online NICK." (erc-with-buffer (nick) - (when-let (((not erc--decouple-query-and-channel-membership-p)) - ((zerop (hash-table-count erc-channel-users))) - (user (erc-get-server-user nick))) + (when-let* (((not erc--decouple-query-and-channel-membership-p)) + ((zerop (hash-table-count erc-channel-users))) + (user (erc-get-server-user nick))) (erc-update-current-channel-member nick nil t) (erc--unhide-prompt) t))) @@ -577,10 +579,10 @@ restore the described historical behavior.") Ensure targets with an entry in `erc-server-users' are present in `erc-channel-members'." (erc-with-all-buffers-of-server erc-server-process #'erc-query-buffer-p - (when-let (((not erc--decouple-query-and-channel-membership-p)) - ((zerop (hash-table-count erc-channel-users))) - (target (erc-target)) - ((erc-get-server-user target))) + (when-let* (((not erc--decouple-query-and-channel-membership-p)) + ((zerop (hash-table-count erc-channel-users))) + (target (erc-target)) + ((erc-get-server-user target))) (erc-update-current-channel-member target nil t) (erc--unhide-prompt)) erc-server-process)) @@ -664,15 +666,15 @@ Also remove members from the server table if this was their only buffer." (defun erc--remove-channel-users-but (nick) "Drain channel users and remove from server, sparing NICK." - (when-let ((users (erc-with-server-buffer erc-server-users)) - (my-user (gethash (erc-downcase nick) users)) - (original-function erc--forget-server-user-function) - (erc--forget-server-user-function - (if erc--decouple-query-and-channel-membership-p - erc--forget-server-user-function - (lambda (nick user) - (unless (eq user my-user) - (funcall original-function nick user)))))) + (when-let* ((users (erc-with-server-buffer erc-server-users)) + (my-user (gethash (erc-downcase nick) users)) + (original-function erc--forget-server-user-function) + (erc--forget-server-user-function + (if erc--decouple-query-and-channel-membership-p + erc--forget-server-user-function + (lambda (nick user) + (unless (eq user my-user) + (funcall original-function nick user)))))) (erc-remove-channel-users))) (defmacro erc--define-channel-user-status-compat-getter (name c d) @@ -714,9 +716,9 @@ inlining calls to these adapters." "Add or remove membership status associated with LETTER for NICK-OR-CUSR. With RESETP, clear the user's status info completely. If ENABLEP is non-nil, add the status value associated with LETTER." - (when-let ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) - (cdr (erc-get-channel-member nick-or-cusr)))) - (n (erc--get-prefix-flag letter))) + (when-let* ((cusr (or (and (erc-channel-user-p nick-or-cusr) nick-or-cusr) + (cdr (erc-get-channel-member nick-or-cusr)))) + (n (erc--get-prefix-flag letter))) (cl-callf (lambda (v) (if resetp (if enablep n 0) @@ -1104,8 +1106,8 @@ A user identifier has the form \"nick!login@host\". If an identifier matches, the message from the person will not be processed." :group 'erc-ignore - :type '(repeat regexp)) -(make-variable-buffer-local 'erc-ignore-list) + :type '(repeat regexp) + :local t) (defcustom erc-ignore-reply-list nil "List of regexps matching user identifiers to ignore completely. @@ -1792,7 +1794,9 @@ Defaults to the server buffer." (setq-local completion-ignore-case t) (add-hook 'post-command-hook #'erc-check-text-conversion nil t) (add-hook 'kill-buffer-hook #'erc-kill-buffer-function nil t) - (add-hook 'completion-at-point-functions #'erc-complete-word-at-point nil t)) + (add-hook 'completion-at-point-functions #'erc-complete-word-at-point nil t) + (add-function :before (local 'erc--clear-function) + #'erc--skip-past-headroom-on-clear '((depth . 30)))) ;; activation @@ -1983,13 +1987,12 @@ the existing buffers will be reused." "old behavior when t now permanent" "29.1") (defun erc-normalize-port (port) - "Normalize the port specification PORT to integer form. -PORT may be an integer, a string or a symbol. If it is a string or a -symbol, it may have these values: -* irc -> 194 -* ircs -> 994 -* ircd -> 6667 -* ircd-dalnet -> 7000" + "Normalize known PORT specifications to an integer. +Expect PORT to be an integer, a string, or a symbol to coerce into a +standardized form for the express purpose of equality comparisons. If +PORT is an IANA recognized service, return its numeric mapping. Do the +same for a few traditional but nonstandard names. Return nil in +pathological cases." ;; These were updated somewhat in 2022 to reflect modern standards ;; and practices. See also: ;; @@ -1997,7 +2000,7 @@ symbol, it may have these values: ;; https://www.iana.org/assignments/service-names-port-numbers (cond ((symbolp port) - (erc-normalize-port (symbol-name port))) + (and port (erc-normalize-port (symbol-name port)))) ((stringp port) (let ((port-nr (string-to-number port))) (cond @@ -2007,14 +2010,19 @@ symbol, it may have these values: 194) ((string-equal port "ircs") 994) - ((string-equal port "ircu") 6667) ; 6665-6669 + ((string-equal port "ircu") 6665) + ((string-equal port "ircu-2") 6666) + ((string-equal port "ircu-3") 6667) + ((string-equal port "ircu-4") 6668) + ((string-equal port "ircu-5") 6669) ((string-equal port "ircd") ; nonstandard (irc-serv is 529) 6667) ((string-equal port "ircs-u") 6697) ((string-equal port "ircd-dalnet") 7000) + ((string-empty-p port) nil) (t - nil)))) + 0)))) ((numberp port) port) (t @@ -2056,8 +2064,7 @@ same manner." (if (and (with-suppressed-warnings ((obsolete erc-reuse-buffers)) erc-reuse-buffers) id) - (let ((string (symbol-name (erc-networks--id-symbol - (erc-networks--id-create id))))) + (let ((string (erc-networks--id-string (erc-networks--id-create id)))) (when-let* ((buf (get-buffer string)) ((erc-server-process-alive buf))) (user-error "Session with ID %S already exists" string)) @@ -2391,12 +2398,12 @@ invocations by third-party packages.") (defun erc--find-mode (sym) (setq sym (erc--normalize-module-symbol sym)) - (if-let ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) - ((and (fboundp mode) - (autoload-do-load (symbol-function mode) mode))) - ((or (get sym 'erc--module) - (symbol-file mode) - (ignore (cl-pushnew sym erc--aberrant-modules))))) + (if-let* ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) + ((and (fboundp mode) + (autoload-do-load (symbol-function mode) mode))) + ((or (get sym 'erc--module) + (symbol-file mode) + (ignore (cl-pushnew sym erc--aberrant-modules))))) mode (and (or (and erc--requiring-module-mode-p ;; Also likely non-nil: (eq sym (car features)) @@ -2414,7 +2421,7 @@ invocations by third-party packages.") (defun erc--update-modules (modules) (let (local-modes) (dolist (module modules local-modes) - (if-let ((mode (erc--find-mode module))) + (if-let* ((mode (erc--find-mode module))) (if (custom-variable-p mode) (funcall mode 1) (push mode local-modes)) @@ -2662,7 +2669,7 @@ side effect of setting the current buffer to the one it returns. Use (if connect (erc-server-connect erc-session-server - erc-session-port + (erc-string-to-port erc-session-port) buffer erc-session-client-certificate) (erc-update-mode-line)) @@ -2686,6 +2693,9 @@ side effect of setting the current buffer to the one it returns. Use (defun erc-initialize-log-marker (buffer) "Initialize the `erc-last-saved-position' marker to a sensible position. BUFFER is the current buffer." + ;; Note that in 5.6, `erc-input-marker' itself became a "sensible + ;; position" when its insertion type changed to t. However, + ;; decrementing still makes sense for compatibility. (with-current-buffer buffer (unless (markerp erc-last-saved-position) (setq erc-last-saved-position (make-marker)) @@ -2763,8 +2773,8 @@ properties needed by entry-point commands, like `erc-tls'." (port (or (url-portspec url) (erc-compute-port (let ((d (erc-compute-port sp))) ; may be a string - (read-string (format-prompt "Port" d) - nil nil d))))) + (erc-string-to-port + (read-string (format-prompt "Port" d) nil nil d)))))) ;; Trust the user not to connect twice accidentally. We ;; can't use `erc-already-logged-in' to check for an existing ;; connection without modifying it to consider USER and PASS. @@ -2786,10 +2796,10 @@ properties needed by entry-point commands, like `erc-tls'." (format-prompt "Server password" p) "Server password (optional): "))) (if erc-prompt-for-password (read-passwd m nil p) p))) - (opener (and (or sp (eql port erc-default-port-tls) + (opener (and (or sp (erc-port-equal port erc-default-port-tls) (and (equal server erc-default-server) (not (string-prefix-p "irc://" input)) - (eql port erc-default-port) + (erc-port-equal port erc-default-port) (y-or-n-p "Connect using TLS instead? ") (setq port erc-default-port-tls))) #'erc-open-tls-stream)) @@ -2885,7 +2895,8 @@ and defers to `erc-compute-port', `erc-compute-user', and ;;;###autoload (cl-defun erc-tls (&key (server (erc-compute-server)) - (port (erc-compute-port 'ircs-u)) + (port (let ((erc-default-port erc-default-port-tls)) + (erc-compute-port))) (nick (erc-compute-nick)) (user (erc-compute-user)) password @@ -3056,9 +3067,8 @@ such inconsistent labeling may pose a problem until the MOTD is received. Setting a fixed `erc-networks--id' can serve as a workaround." (when erc-debug-irc-protocol - (let ((esid (if-let ((erc-networks--id) - (esid (erc-networks--id-symbol erc-networks--id))) - (symbol-name esid) + (let ((esid (if erc-networks--id + (erc-networks--id-string erc-networks--id) (or erc-server-announced-name (format "%s:%s" erc-session-server erc-session-port)))) (ts (when erc-debug-irc-protocol-time-format @@ -3290,10 +3300,10 @@ a full refresh." (insert s) (delete-region erc-insert-marker p)))) (run-hooks 'erc--refresh-prompt-hook) - (when-let (((> erc--refresh-prompt-continue-request 0)) - (n erc--refresh-prompt-continue-request) - (erc--refresh-prompt-continue-request -1) - (b (current-buffer))) + (when-let* (((> erc--refresh-prompt-continue-request 0)) + (n erc--refresh-prompt-continue-request) + (erc--refresh-prompt-continue-request -1) + (b (current-buffer))) (erc-with-all-buffers-of-server erc-server-process (lambda () (not (eq b (current-buffer)))) (if (= n 1) @@ -3320,10 +3330,14 @@ value. Otherwise, return the stored value." (macroexp-let2* nil ((point point) (at-start-p at-start-p)) `(or (and ,at-start-p ,point) - (and-let* ((p (previous-single-property-change ,point 'erc--msg))) - (if (and (= p (1- ,point)) (get-text-property p 'erc--msg)) - p - (1- p)))))) + (let ((p (previous-single-property-change ,point 'erc--msg))) + (cond + ((and p (= p (1- ,point)) (get-text-property p 'erc--msg)) p) + (p (1- p)) + ((and (null p) + (> ,point (point-min)) + (get-text-property (1- point) 'erc--msg)) + (1- point))))))) (defmacro erc--get-inserted-msg-end-at (point at-start-p) (macroexp-let2 nil point point @@ -3352,9 +3366,9 @@ if not found." (and-let* ((b (erc--get-inserted-msg-beg-at point at-start-p))) (cons b (erc--get-inserted-msg-end-at point at-start-p))))) -(defun erc--get-inserted-msg-prop (prop) +(defun erc--get-inserted-msg-prop (prop &optional point) "Return the value of text property PROP for some message at point." - (and-let* ((stack-pos (erc--get-inserted-msg-beg (point)))) + (and-let* ((stack-pos (erc--get-inserted-msg-beg (or point (point))))) (get-text-property stack-pos prop))) ;; FIXME improve this nascent "message splicing" facility to include a @@ -3379,7 +3393,8 @@ a history backlog." (declare (indent 1)) (let ((marker (make-symbol "marker"))) `(progn - (cl-assert (= ?\n (char-before ,marker-or-pos))) + (cl-assert (or (= ,marker-or-pos (point-min)) + (= ?\n (char-before ,marker-or-pos)))) (cl-assert (null erc--insert-line-function)) (let* ((,marker (and (not (markerp ,marker-or-pos)) (copy-marker ,marker-or-pos))) @@ -3505,8 +3520,7 @@ modification hooks)." (add-text-properties (point-min) (1+ (point-min)) props))) (erc--refresh-prompt))))) (run-hooks 'erc-insert-done-hook) - (erc-update-undo-list (- (or (marker-position (or erc--insert-marker - erc-insert-marker)) + (erc-update-undo-list (- (or erc--insert-marker erc-insert-marker (point-max)) insert-position)))))) @@ -3665,10 +3679,10 @@ Callers should be aware that this function fails if the property `erc--important-props' has an empty value almost anywhere along the affected region. Use the function `erc--remove-from-prop-value-list' to ensure that props with empty values are excised completely." - (when-let ((registered (erc--check-msg-prop 'erc--important-prop-names)) - (present (seq-intersection props registered)) - (b (or beg (point-min))) - (e (or end (point-max)))) + (when-let* ((registered (erc--check-msg-prop 'erc--important-prop-names)) + (present (seq-intersection props registered)) + (b (or beg (point-min))) + (e (or end (point-max)))) (while-let (((setq b (text-property-not-all b e 'erc--important-props nil))) (val (get-text-property b 'erc--important-props)) @@ -3695,7 +3709,8 @@ them from the previous newline, and add them to the newline suffixing the inserted version of STRING." (let* ((after (and (not erc-legacy-invisible-bounds-p) (get-text-property (point) 'erc--hide))) - (before (and after (get-text-property (1- (point)) 'invisible))) + (before (and after (> (point) (point-min)) + (get-text-property (1- (point)) 'invisible))) (a (and after (ensure-list after))) (b (and before (ensure-list before))) (new (and before (erc--solo (cl-intersection b a))))) @@ -3777,7 +3792,7 @@ reverse order so they end up sorted in buffer interval plists for retrieval by `text-properties-at' and friends." (let (out) (dolist (k erc--ranked-properties) - (when-let ((v (gethash k table))) + (when-let* ((v (gethash k table))) (remhash k table) (setq out (nconc (list k v) out)))) (maphash (lambda (k v) (setq out (nconc (list k v) out))) table) @@ -4119,8 +4134,8 @@ for other purposes.") (defun erc-send-input-line (target line &optional force) "Send LINE to TARGET." - (when-let ((target) - (cmem (erc-get-channel-member (erc-current-nick)))) + (when-let* ((target) + (cmem (erc-get-channel-member (erc-current-nick)))) (setf (erc-channel-user-last-message-time (cdr cmem)) (erc-compat--current-lisp-time))) (when (and (not erc--allow-empty-outgoing-lines-p) (string= line "\n")) @@ -4417,7 +4432,7 @@ of `erc-ignore-list'." (format "Now ignoring %s" user))) (erc-with-server-buffer (when timeout - (if-let ((existing (erc--find-ignore-timer user (current-buffer)))) + (if-let* ((existing (erc--find-ignore-timer user (current-buffer)))) (timer-set-time existing (timer-relative-time nil timeout)) (run-at-time timeout nil #'erc--unignore-user user (current-buffer)))) @@ -4429,11 +4444,11 @@ of `erc-ignore-list'." (erc-with-server-buffer (let ((seen (copy-sequence erc-ignore-list))) (dolist (timer timer-list) - (when-let ((args (erc--get-ignore-timer-args timer)) - ((eq (current-buffer) (nth 1 args))) - (user (car args)) - (delta (- (timer-until timer (current-time)))) - (duration (erc--format-time-period delta))) + (when-let* ((args (erc--get-ignore-timer-args timer)) + ((eq (current-buffer) (nth 1 args))) + (user (car args)) + (delta (- (timer-until timer (current-time)))) + (duration (erc--format-time-period delta))) (setq seen (delete user seen)) (erc-display-message nil 'notice 'active 'ignore-list ?p user ?s duration))) @@ -4464,24 +4479,45 @@ of `erc-ignore-list'." (erc-display-message nil 'notice 'active (format "No longer ignoring %s" user)) (setq erc-ignore-list (delete user erc-ignore-list)) - (when-let ((existing (erc--find-ignore-timer user buffer))) + (when-let* ((existing (erc--find-ignore-timer user buffer))) (cancel-timer existing))))) -(defvar erc--pre-clear-functions nil - "Abnormal hook run when truncating buffers. -Called with position indicating boundary of interval to be excised.") +(defvar erc--clear-function #'delete-region + "Function to truncate buffer. +Called with two markers, LOWER and UPPER, indicating the bounds of the +interval to be excised. LOWER <= UPPER <= `erc-insert-marker'.") + +(defun erc--skip-past-headroom-on-clear (beg end) + "Move marker BEG past the two newlines added by `erc--initialize-markers'." + (when (and (not (buffer-narrowed-p)) (= beg (point-min))) + (save-excursion + (goto-char (point-min)) + (let ((pos (skip-chars-forward "\n" (if erc--called-as-input-p 2 3)))) + (set-marker beg (min (1+ pos) end erc-input-marker)))))) + +(defvar erc--inhibit-clear-p nil + "When non-nil, ERC inhibits buffer truncation.") (defun erc-cmd-CLEAR () "Clear messages in current buffer after informing active modules. Expect modules to perform housekeeping tasks to withstand the disruption. When called from Lisp code, only clear messages up to but not including the one occupying the current line." + (when erc--inhibit-clear-p + (user-error "Truncation currently inhibited")) (with-silent-modifications - (let ((max (if (>= (point) erc-insert-marker) - (1- erc-insert-marker) - (or (erc--get-inserted-msg-beg (point)) (pos-bol))))) - (run-hook-with-args 'erc--pre-clear-functions max) - (delete-region (point-min) max))) + (let ((end (copy-marker + ;; Leave a final newline for compatibility, even though + ;; it complicates `erc--clear-function' handling. + (cond ((>= (point) erc-insert-marker) + (max (point-min) (1- erc-insert-marker))) + ((erc--get-inserted-msg-beg (point))) + ((pos-bol))))) + (beg (point-min-marker))) + (let ((erc--inhibit-clear-p t)) + (funcall erc--clear-function beg end)) + (set-marker beg nil) + (set-marker end nil))) t) (put 'erc-cmd-CLEAR 'process-not-needed t) @@ -4635,17 +4671,17 @@ node `(erc) auth-source'." function)) (defun erc--auth-source-determine-params-defaults () - (let* ((net (and-let* ((erc-networks--id) - (esid (erc-networks--id-symbol erc-networks--id)) - ((symbol-name esid))))) + (let* ((net (and erc-networks--id + (erc-networks--id-string erc-networks--id))) (localp (and erc--target (erc--target-channel-local-p erc--target))) (hosts (if localp (list erc-server-announced-name erc-session-server net) (list net erc-server-announced-name erc-session-server))) (ports (list (cl-typecase erc-session-port (integer (number-to-string erc-session-port)) - (string (and (string= erc-session-port "irc") - erc-session-port)) ; or nil + (string (and (not (member erc-session-port + '("" "irc"))) + erc-session-port)) (t erc-session-port)) "irc"))) (list (cons :host (delq nil hosts)) @@ -5215,7 +5251,7 @@ Display the query buffer in accordance with `erc-interactive-display'." (erc--display-context `((erc-interactive-display . /QUERY) ,@erc--display-context))) (erc-with-server-buffer - (if-let ((buffer (erc-get-buffer user erc-server-process))) + (if-let* ((buffer (erc-get-buffer user erc-server-process))) (prog1 buffer (erc-setup-buffer buffer)) (prog1 (erc--open-target user) ; becomes current buffer @@ -5552,109 +5588,117 @@ If CHANNEL is not specified, clear the topic for the default channel." (defvar-local erc-channel-banlist nil "A list of bans seen for the current channel. - -Each ban is an alist of the form: - (WHOSET . MASK) - -The property `received-from-server' indicates whether -or not the ban list has been requested from the server.") +Entries are cons cells of the form (OP . MASK), where OP is the channel +operator who issued the ban. Modules needing such a list should call +`erc-sync-banlist' once per session in the channel before accessing the +variable. Interactive users need only issue a /BANLIST. Note that +older versions of ERC relied on a deprecated convention involving a +property of the symbol `erc-channel-banlist' to indicate whether a ban +list had been received in full; this was found to be unreliable.") (put 'erc-channel-banlist 'received-from-server nil) -(defvar erc-fill-column) - -(defun erc-cmd-BANLIST () - "Pretty-print the contents of `erc-channel-banlist'. - -The ban list is fetched from the server if necessary." - (let ((chnl (erc-default-target)) - (chnl-name (buffer-name))) - - (cond - ((not (erc-channel-p chnl)) - (erc-display-message nil 'notice 'active "You're not on a channel\n")) - - ((not (get 'erc-channel-banlist 'received-from-server)) - (let ((old-367-hook erc-server-367-functions)) - (setq erc-server-367-functions 'erc-banlist-store - erc-channel-banlist nil) - ;; fetch the ban list then callback - (erc-with-server-buffer - (erc-once-with-server-event - 368 - (lambda (_proc _parsed) - (with-current-buffer chnl-name - (put 'erc-channel-banlist 'received-from-server t) - (setq erc-server-367-functions old-367-hook) - (erc-cmd-BANLIST) - t))) - (erc-server-send (format "MODE %s b" chnl))))) - - ((null erc-channel-banlist) - (erc-display-message nil 'notice 'active - (format "No bans for channel: %s\n" chnl)) +(defvar-local erc--channel-banlist-synchronized-p nil + "Whether the full channel ban list has been fetched since joining.") + +(defun erc-sync-banlist (&optional done-fn) + "Initialize syncing of current channel's `erc-channel-banlist'. +Arrange for it to remain synced for the rest of the IRC session. When +DONE-FN is non-nil, call it with no args once fully updated. Expect it +to return non-nil, if necessary, to inhibit further processing." + (unless (erc-channel-p (current-buffer)) + (error "Not a channel buffer")) + (let ((channel (erc-target)) + (buffer (current-buffer)) + (hook (lambda (&rest r) (apply #'erc-banlist-store r) t))) + (setq erc-channel-banlist nil) + (erc-with-server-buffer + (add-hook 'erc-server-367-functions hook -98 t) + (erc-once-with-server-event + 368 (lambda (&rest _) + (remove-hook 'erc-server-367-functions hook t) + (with-current-buffer buffer + (prog1 (if done-fn (funcall done-fn) t) + (setq erc--channel-banlist-synchronized-p t))))) + (erc-server-send (format "MODE %s b" channel))))) + +(defun erc--wrap-banlist-cmd (slashcmd) + (lambda () + (put 'erc-channel-banlist 'received-from-server t) + (unwind-protect (funcall slashcmd) (put 'erc-channel-banlist 'received-from-server nil)) + t)) - (t - (let* ((erc-fill-column (or (and (boundp 'erc-fill-column) - erc-fill-column) - (and (boundp 'fill-column) - fill-column) - (1- (window-width)))) - (separator (make-string erc-fill-column ?=)) - (fmt (concat - "%-" (number-to-string (/ erc-fill-column 2)) "s" - "%" (number-to-string (/ erc-fill-column 2)) "s"))) +(defvar erc-banlist-fill-padding 1.0 + "Scaling factor from 0 to 1 of free space between entries, if any.") - (erc-display-message - nil 'notice 'active - (format "Ban list for channel: %s\n" (erc-default-target))) - - (erc-display-line separator 'active) - (erc-display-line (format fmt "Ban Mask" "Banned By") 'active) - (erc-display-line separator 'active) - - (mapc - (lambda (x) - (erc-display-line - (format fmt - (truncate-string-to-width (cdr x) (/ erc-fill-column 2)) - (if (car x) - (truncate-string-to-width (car x) (/ erc-fill-column 2)) - "")) - 'active)) - erc-channel-banlist) - - (erc-display-message nil 'notice 'active "End of Ban list") - (put 'erc-channel-banlist 'received-from-server nil))))) +(cl-defgeneric erc--determine-fill-column-function () + fill-column) + +(defun erc-cmd-BANLIST (&rest args) + "Print the list of ban masks for the current channel. +When uninitialized or with option -f, resync `erc-channel-banlist'." + (cond + ((not (erc-channel-p (current-buffer))) + (erc-display-message nil 'notice 'active "You're not on a channel\n")) + ((or (equal args '("-f")) + (and (not erc--channel-banlist-synchronized-p) + (not (get 'erc-channel-banlist 'received-from-server)))) + (erc-sync-banlist (erc--wrap-banlist-cmd #'erc-cmd-BANLIST))) + ((null erc-channel-banlist) + (erc-display-message nil 'notice 'active + (format "No bans for channel: %s\n" (erc-target)))) + ((let ((max-width (erc--determine-fill-column-function)) + (lw 0) (rw 0) separator fmt) + (dolist (entry erc-channel-banlist) + (setq rw (max (length (car entry)) rw) + lw (max (length (cdr entry)) lw))) + (let ((maxw (* 1.0 (min max-width (+ rw lw))))) + (when (< maxw (+ rw lw)) ; scale down when capped + (cl-psetq rw (/ (* rw maxw) (* 1.0 (+ rw lw))) + lw (/ (* lw maxw) (* 1.0 (+ rw lw))))) + (when-let* ((larger (max rw lw)) ; cap ratio at 3:1 + (wavg (* maxw 0.75)) + ((> larger wavg))) + (setq rw (if (eql larger rw) wavg (- maxw wavg)) + lw (- maxw rw))) + (cl-psetq rw (+ rw (* erc-banlist-fill-padding + (- (/ (* rw max-width) maxw) rw))) + lw (+ lw (* erc-banlist-fill-padding + (- (/ (* lw max-width) maxw) lw))))) + (setq rw (truncate rw) + lw (truncate lw)) + (cl-assert (<= (+ rw lw) max-width)) + (setq separator (make-string (+ rw lw 1) ?=) + fmt (concat "%-" (number-to-string lw) "s " + "%" (number-to-string rw) "s")) + (erc-display-message + nil 'notice 'active + (format "Ban list for channel: %s%s\n" (erc-target) + (if erc--channel-banlist-synchronized-p " (cached)" ""))) + (erc-display-line separator 'active) + (erc-display-line (format fmt "Ban Mask" "Banned By") 'active) + (erc-display-line separator 'active) + (dolist (entry erc-channel-banlist) + (erc-display-line + (format fmt (truncate-string-to-width (cdr entry) lw) + (truncate-string-to-width (car entry) rw)) + 'active)) + (erc-display-message nil 'notice 'active "End of Ban list")))) + (put 'erc-channel-banlist 'received-from-server nil) t) (defalias 'erc-cmd-BL #'erc-cmd-BANLIST) -(defun erc-cmd-MASSUNBAN () - "Mass Unban. - -Unban all currently banned users in the current channel." +(defun erc-cmd-MASSUNBAN (&rest args) + "Remove all bans in the current channel." (let ((chnl (erc-default-target))) (cond - ((not (erc-channel-p chnl)) (erc-display-message nil 'notice 'active "You're not on a channel\n")) - - ((not (get 'erc-channel-banlist 'received-from-server)) - (let ((old-367-hook erc-server-367-functions)) - (setq erc-server-367-functions 'erc-banlist-store) - ;; fetch the ban list then callback - (erc-with-server-buffer - (erc-once-with-server-event - 368 - (lambda (_proc _parsed) - (with-current-buffer chnl - (put 'erc-channel-banlist 'received-from-server t) - (setq erc-server-367-functions old-367-hook) - (erc-cmd-MASSUNBAN) - t))) - (erc-server-send (format "MODE %s b" chnl))))) - + ((or (equal args '("-f")) + (and (not erc--channel-banlist-synchronized-p) + (not (get 'erc-channel-banlist 'received-from-server)))) + (erc-sync-banlist (erc--wrap-banlist-cmd #'erc-cmd-MASSUNBAN))) (t (let ((bans (mapcar #'cdr erc-channel-banlist))) (when bans ;; Glob the bans into groups of three, and carry out the unban. @@ -5665,8 +5709,9 @@ Unban all currently banned users in the current channel." (format "MODE %s -%s %s" (erc-default-target) (make-string (length x) ?b) (mapconcat #'identity x " ")))) - (erc-group-list bans 3)))) - t)))) + (erc-group-list bans 3)))))) + (put 'erc-channel-banlist 'received-from-server nil) + t)) (defalias 'erc-cmd-MUB #'erc-cmd-MASSUNBAN) @@ -6337,20 +6382,18 @@ rely on their presence, and cleaner ways exist)." "Template for a CTCP ACTION status message from current client.") (defun erc--speakerize-nick (nick &optional disp) - "Propertize NICK with `erc--speaker' if not already present. -Do so to DISP instead if it's non-nil. In either case, assign -NICK, sans properties, as the `erc--speaker' value. As a side -effect, pair the latter string (the same `eq'-able object) with -the symbol `erc--spkr' in the \"msg prop\" environment for any -imminent `erc-display-message' invocations. While doing so, -include any overrides defined in `erc--message-speaker-catalog'." - (let ((plain-nick (substring-no-properties nick))) - (erc--ensure-spkr-prop plain-nick (get erc--message-speaker-catalog - 'erc--msg-prop-overrides)) - (if (text-property-not-all 0 (length (or disp nick)) - 'erc--speaker nil (or disp nick)) - (or disp nick) - (propertize (or disp nick) 'erc--speaker plain-nick)))) + "Return propertized NICK with canonical NICK in `erc--speaker'. +Return propertized DISP instead if given. As a side effect, pair NICK +with `erc--spkr' in the \"msg prop\" environment for any imminent +`erc-display-message' invocations, and include any overrides defined in +`erc--message-speaker-catalog'. Expect NICK (but not necessarily DISP) +to be absent of any existing text properties." + (when-let* ((erc-server-process) + (cusr (erc-get-server-user nick))) + (setq nick (erc-server-user-nickname cusr))) + (erc--ensure-spkr-prop nick (get erc--message-speaker-catalog + 'erc--msg-prop-overrides)) + (propertize (or disp nick) 'erc--speaker nick)) (defun erc--determine-speaker-message-format-args (nick message queryp privmsgp inputp &optional statusmsg prefix disp-nick) @@ -6513,14 +6556,14 @@ similar to that performed by `erc-format-my-nick', but use either `erc--message-speaker-input-query-privmsg' as a formatting template, with MESSAGE being the actual message body. Return a copy with possibly shared text-property values." - (if-let ((erc-show-my-nick) - (nick (erc-current-nick)) - (pfx (erc-get-channel-membership-prefix nick)) - (erc-current-message-catalog erc--message-speaker-catalog) - (key (if (or erc-format-query-as-channel-p - (erc--target-channel-p erc--target)) - 'input-chan-privmsg - 'input-query-privmsg))) + (if-let* ((erc-show-my-nick) + (nick (erc-current-nick)) + (pfx (erc-get-channel-membership-prefix nick)) + (erc-current-message-catalog erc--message-speaker-catalog) + (key (if (or erc-format-query-as-channel-p + (erc--target-channel-p erc--target)) + 'input-chan-privmsg + 'input-query-privmsg))) (progn (cond (erc--msg-props (puthash 'erc--msg key erc--msg-props)) (erc--msg-prop-overrides (push (cons 'erc--msg key) @@ -6638,17 +6681,31 @@ See also: `erc-echo-notice-in-user-buffers', erc-channel-banlist)))))) nil) +;; This was a default member of `erc-server-368-functions' (nee -hook) +;; between January and June of 2003 (but not as part of any release). (defun erc-banlist-finished (proc parsed) "Record that we have received the banlist." + (declare (obsolete "uses obsolete and likely faulty logic" "31.1")) (let* ((channel (nth 1 (erc-response.command-args parsed))) (buffer (erc-get-buffer channel proc))) (with-current-buffer buffer (put 'erc-channel-banlist 'received-from-server t))) t) ; suppress the 'end of banlist' message +(defun erc--banlist-update (statep mask) + "Add or remove a mask from `erc-channel-banlist'." + (if statep + (let ((whoset (erc-response.sender erc--parsed-response))) + (cl-pushnew (cons whoset mask) erc-channel-banlist :test #'equal)) + (let ((upcased (upcase mask))) + (setq erc-channel-banlist + (cl-delete-if (lambda (y) (equal (upcase (cdr y)) upcased)) + erc-channel-banlist))))) + (defun erc-banlist-update (proc parsed) "Check MODE commands for bans and update the banlist appropriately." ;; FIXME: Possibly incorrect. -- Lawrence 2004-05-11 + (declare (obsolete "continual syncing via `erc--banlist-update'" "31.1")) (let* ((tgt (car (erc-response.command-args parsed))) (mode (erc-response.contents parsed)) (whoset (erc-response.sender parsed)) @@ -7139,7 +7196,7 @@ extensions." (let ((names (delete "" (split-string names-string))) (erc-channel-members-changed-hook nil)) (dolist (name names) - (when-let ((args (erc--partition-prefixed-names name))) + (when-let* ((args (erc--partition-prefixed-names name))) (pcase-let* ((`(,status ,nick ,login ,host) args) (cmem (erc-get-channel-user nick))) (progn @@ -7731,6 +7788,11 @@ Remember when STATE is non-nil and forget otherwise." (cl-pushnew (char-to-string c) erc-channel-modes :test #'equal) (delete (char-to-string c) erc-channel-modes)))) +;; We could specialize on type A, but that may be too brittle. +(cl-defmethod erc--handle-channel-mode (_ (_ (eql ?b)) state arg) + "Update `erc-channel-banlist' when synchronized." + (when erc--channel-banlist-synchronized-p (erc--banlist-update state arg))) + ;; We could specialize on type C, but that may be too brittle. (cl-defmethod erc--handle-channel-mode (_ (_ (eql ?l)) state arg) "Update channel user limit, remembering ARG when STATE is non-nil." @@ -8130,10 +8192,10 @@ ERC prints them as a single message joined by newlines.") (let* ((str (erc-user-input)) (state (erc--make-input-split str))) (run-hook-with-args 'erc--input-review-functions state) - (when-let (((not (erc--input-split-abortp state))) - (inhibit-read-only t) - (erc--current-line-input-split state) - (old-buf (current-buffer))) + (when-let* (((not (erc--input-split-abortp state))) + (inhibit-read-only t) + (erc--current-line-input-split state) + (old-buf (current-buffer))) (progn ; unprogn this during next major surgery (erc-set-active-buffer (current-buffer)) ;; Kill the input and the prompt @@ -8143,10 +8205,9 @@ ERC prints them as a single message joined by newlines.") ;; Fix the buffer if the command didn't kill it (when (buffer-live-p old-buf) (with-current-buffer old-buf - (save-restriction - (widen) - (let ((buffer-modified (buffer-modified-p))) - (set-buffer-modified-p buffer-modified)))))) + (setq buffer-undo-list nil) + ;; `set-buffer-modified-p' used to do this here. + (force-mode-line-update)))) ;; Only when last hook has been run... (run-hook-with-args 'erc-send-completed-hook str))) @@ -8783,7 +8844,7 @@ Sets the buffer local variables: - `erc-server-current-nick'" (setq erc-session-connector erc-server-connect-function erc-session-server (erc-compute-server server) - erc-session-port (or port erc-default-port) + erc-session-port (erc-compute-port port) erc-session-user-full-name (erc-compute-full-name name) erc-session-username (erc-compute-user user) erc-session-password (erc--compute-server-password passwd nick)) @@ -8856,8 +8917,12 @@ non-nil value is found. - PORT (the argument passed to this function) - The `erc-port' option -- The `erc-default-port' variable" - (erc-normalize-port (or port erc-port erc-default-port))) +- The `erc-default-port' variable + +Note that between ERC 5.5 and 5.6.1, this function filtered its result +through `erc-normalize-port', which introduced regrettable surprises, +such as unwelcome, possibly null, type conversions." + (or (and port (not (equal "" port)) port) erc-port erc-default-port)) ;; time routines @@ -8939,6 +9004,8 @@ If S is nil or an empty string then return general CLIENTINFO." ;; Hook functions +;; FIXME rename this to something like `erc-ensure-directory-writable'. +;; Functions suffixed with "-p" probably shouldn't have side effects. (defun erc-directory-writable-p (dir) "Determine whether DIR is a writable directory. If it doesn't exist, create it." @@ -9125,12 +9192,11 @@ This should be a string with substitution variables recognized by "Return the network or the current target and network combined. If the name of the network is not available, then use the shortened server name instead." - (if-let ((erc--target) - (name (if-let ((erc-networks--id) - (esid (erc-networks--id-symbol erc-networks--id))) - (symbol-name esid) - (erc-shorten-server-name (or erc-server-announced-name - erc-session-server))))) + (if-let* ((erc--target) + (name (if erc-networks--id + (erc-networks--id-string erc-networks--id) + (erc-shorten-server-name (or erc-server-announced-name + erc-session-server))))) (concat (erc--target-string erc--target) "@" name) (buffer-name))) @@ -9711,8 +9777,8 @@ one of the following hooks: `erc-kill-channel-hook' if a channel buffer was killed, or `erc-kill-buffer-hook' if any other buffer." (when (eq major-mode 'erc-mode) - (when-let ((erc--target) - (nick (erc-current-nick))) + (when-let* ((erc--target) + (nick (erc-current-nick))) (erc--remove-channel-users-but nick)) (cond ((eq (erc-server-buffer) (current-buffer)) @@ -9767,10 +9833,10 @@ This function should be on `erc-kill-server-hook'." (defun erc-restore-text-properties () "Ensure the `erc-parsed' and `tags' props cover the entire message." - (when-let ((parsed-posn (erc-find-parsed-property)) + (when-let* ((parsed-posn (erc-find-parsed-property)) (found (erc-get-parsed-vector parsed-posn))) (put-text-property (point-min) (point-max) 'erc-parsed found) - (when-let ((tags (get-text-property parsed-posn 'tags))) + (when-let* ((tags (get-text-property parsed-posn 'tags))) (put-text-property (point-min) (point-max) 'tags tags)))) (defun erc-get-parsed-vector (point) @@ -9796,7 +9862,7 @@ This function should be on `erc-kill-server-hook'." See also `erc-message-type'." ;; IRC numerics are three-digit numbers, possibly with leading 0s. ;; To invert: (if (numberp o) (format "%03d" o) (symbol-name o)) - (if-let ((n (string-to-number command)) ((zerop n))) (intern command) n)) + (if-let* ((n (string-to-number command)) ((zerop n))) (intern command) n)) ;; Teach url.el how to open irc:// URLs with ERC. ;; To activate, customize `url-irc-function' to `url-irc-erc'. @@ -9816,9 +9882,8 @@ by `erc' and `erc-tls'." (or (eql 6697 (plist-get plist :port)) (yes-or-no-p "Connect using TLS? ")))) (erc-server (plist-get plist :server)) - (erc-port (or (plist-get plist :port) - (and ircsp (erc-normalize-port 'ircs-u)) - erc-port)) + (erc-default-port (if ircsp erc-default-port-tls erc-default-port)) + (erc-port (erc-compute-port (plist-get plist :port))) (erc-nick (or (plist-get plist :nick) erc-nick)) (erc-password (plist-get plist :password)) (args (erc-select-read-args))) @@ -9850,9 +9915,9 @@ Customize `erc-url-connect-function' to override this." (and (string-equal erc-session-server host) ;; Ports only matter when dialed hosts ;; match and we have sufficient info. - (or (not port) - (= (erc-normalize-port erc-session-port) - port))))))))) + (or (null port) + (erc-port-equal erc-session-port + port))))))))) key deferred) (unless server-buffer (setq deferred t diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el index ff0620702cf..4f8f0c1c7e4 100644 --- a/lisp/eshell/em-alias.el +++ b/lisp/eshell/em-alias.el @@ -208,10 +208,9 @@ This is useful after manually editing the contents of the file." "Write out the current aliases into `eshell-aliases-file'." (when (and eshell-aliases-file (file-writable-p (file-name-directory eshell-aliases-file))) - (let ((eshell-current-handles - (eshell-create-handles eshell-aliases-file 'overwrite))) + (eshell-with-handles (eshell-aliases-file 'overwrite) (eshell/alias) - (eshell-close-handles 0 'nil)))) + (eshell-set-exit-info 0 nil)))) (defsubst eshell-lookup-alias (name) "Check whether NAME is aliased. Return the alias if there is one." @@ -222,14 +221,14 @@ This is useful after manually editing the contents of the file." (defun eshell-maybe-replace-by-alias--which (command) (unless (and eshell-prevent-alias-expansion (member command eshell-prevent-alias-expansion)) - (when-let ((alias (eshell-lookup-alias command))) + (when-let* ((alias (eshell-lookup-alias command))) (concat command " is an alias, defined as \"" (cadr alias) "\"")))) (defun eshell-maybe-replace-by-alias (command _args) "Call COMMAND's alias definition, if it exists." (unless (and eshell-prevent-alias-expansion (member command eshell-prevent-alias-expansion)) - (when-let ((alias (eshell-lookup-alias command))) + (when-let* ((alias (eshell-lookup-alias command))) (throw 'eshell-replace-command `(let ((eshell-command-name ',eshell-last-command-name) (eshell-command-arguments ',eshell-last-arguments) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 4c79f7b187a..ef931db62b2 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -444,7 +444,7 @@ to writing a completion function." ('nil (propertize "" 'pcomplete-arg-value arg)) (_ - (propertize (eshell-stringify arg) + (propertize (eshell-stringify arg t) 'pcomplete-arg-value arg)))) args) posns))) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index e70f2cfe196..e005bc98873 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -65,9 +65,7 @@ they lack somewhat in feel from the typical shell equivalents." :version "24.1" ; removed eshell-dirs-initialize :type 'hook) -(defcustom eshell-pwd-convert-function (if (eshell-under-windows-p) - #'expand-file-name - #'identity) +(defcustom eshell-pwd-convert-function #'expand-file-name "The function used to normalize the value of Eshell's `pwd'. The value returned by `pwd' is also used when recording the last-visited directory in the last-dir-ring, so it will affect the @@ -75,7 +73,8 @@ form of the list used by `cd ='." :type '(radio (function-item file-truename) (function-item expand-file-name) (function-item identity) - (function :tag "Other"))) + (function :tag "Other")) + :version "31.1") (defcustom eshell-ask-to-save-last-dir 'always "Determine if the last-dir-ring should be automatically saved. @@ -319,14 +318,13 @@ Thus, this does not include the current directory.") (defun eshell/pwd () "Change output from `pwd' to be cleaner." - (let* ((path default-directory) - (len (length path))) - (if (and (> len 1) - (eq (aref path (1- len)) ?/) - (not (and (eshell-under-windows-p) - (string-match "\\`[A-Za-z]:[\\/]\\'" path)))) - (setq path (substring path 0 (1- (length path))))) - (funcall (or eshell-pwd-convert-function #'identity) path))) + (let ((dir default-directory)) + (when (and (eq (aref dir (1- (length dir))) ?/) + (not (and (eshell-under-windows-p) + (string-match "\\`[A-Za-z]:[\\/]\\'" dir))) + (length> (file-local-name dir) 1)) + (setq dir (substring dir 0 -1))) + (funcall (or eshell-pwd-convert-function #'identity) dir))) (defun eshell-expand-multiple-dots (filename) ;; FIXME: This advice recommendation is rather odd: it's somewhat @@ -427,8 +425,7 @@ in the minibuffer: (let ((eshell-last-command-name) (eshell-last-command-status) (eshell-last-arguments)) - (eshell-protect - (eshell-plain-command "ls" (cdr args))))) + (eshell-plain-command "ls" (cdr args)))) nil)))) (put 'eshell/cd 'eshell-no-numeric-conversions t) diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 2aceaf188f3..b94c4e3ed46 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -141,7 +141,7 @@ This mimics the behavior of zsh if non-nil, but bash if nil." (when (boundp 'eshell-special-chars-outside-quoting) (setq-local eshell-special-chars-outside-quoting (append eshell-glob-chars-list eshell-special-chars-outside-quoting))) - (add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars t t) + (add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars 90 t) (add-hook 'eshell-pre-rewrite-command-hook 'eshell-no-command-globbing nil t)) @@ -149,40 +149,49 @@ This mimics the behavior of zsh if non-nil, but bash if nil." "Don't glob the command argument. Reflect this by modifying TERMS." (ignore (pcase (car terms) - ((or `(eshell-extended-glob ,term) - `(eshell-splice-args (eshell-extended-glob ,term))) + ((or `(eshell-expand-glob ,term) + `(eshell-splice-args (eshell-expand-glob ,term))) (setcar terms term))))) (defun eshell-add-glob-modifier () - "Add `eshell-extended-glob' to the argument modifier list." + "Add `eshell-expand-glob' to the argument modifier list." (when eshell-glob-splice-results (add-hook 'eshell-current-modifiers #'eshell-splice-args 99)) - (add-hook 'eshell-current-modifiers #'eshell-extended-glob)) + (add-hook 'eshell-current-modifiers #'eshell-expand-glob)) (defun eshell-parse-glob-chars () - "Parse a globbing delimiter. -The character is not advanced for ordinary globbing characters, so -that other function may have a chance to override the globbing -interpretation." + "Parse a globbing character." (when (memq (char-after) eshell-glob-chars-list) - (if (not (memq (char-after) '(?\( ?\[))) - (ignore (eshell-add-glob-modifier)) - (let ((here (point))) - (forward-char) - (let* ((delim (char-before)) - (end (eshell-find-delimiter - delim (if (eq delim ?\[) ?\] ?\))))) - (if (not end) - (throw 'eshell-incomplete (char-to-string delim)) - (if (and (eshell-using-module 'eshell-pred) - (eshell-arg-delimiter (1+ end))) - (ignore (goto-char here)) - (eshell-add-glob-modifier) - (prog1 - (buffer-substring-no-properties (1- (point)) (1+ end)) - (goto-char (1+ end)))))))))) + (eshell-add-glob-modifier) + (prog1 + (propertize (char-to-string (char-after)) 'eshell-glob-char t) + (forward-char)))) (defvar eshell-glob-chars-regexp nil) +(defsubst eshell-glob-chars-regexp () + "Return the lazily-created value for `eshell-glob-chars-regexp'." + (or eshell-glob-chars-regexp + (setq-local eshell-glob-chars-regexp + (rx-to-string `(+ (any ,@eshell-glob-chars-list)) t)))) + +(defun eshell-parse-glob-string (glob) + "Add text properties to glob characters in GLOB and return the result." + (let ((regexp (rx-to-string + `(or (seq (group-n 1 "\\") anychar) + (group-n 2 (regexp ,(eshell-glob-chars-regexp)))) + t))) + (with-temp-buffer + (insert glob) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (cond + ((match-beginning 1) ; Remove backslash escape. + (delete-region (match-beginning 1) (match-end 1))) + ((match-beginning 2) ; Propertize globbing character. + (put-text-property (match-beginning 2) (match-end 2) + 'eshell-glob-char t)))) + (buffer-string)))) + (defvar eshell-glob-matches) (defvar message-shown) @@ -190,11 +199,16 @@ interpretation." '(("**/" . recurse) ("***/" . recurse-symlink))) -(defsubst eshell-glob-chars-regexp () - "Return the lazily-created value for `eshell-glob-chars-regexp'." - (or eshell-glob-chars-regexp - (setq-local eshell-glob-chars-regexp - (format "[%s]+" (apply 'string eshell-glob-chars-list))))) +(defsubst eshell--glob-char-p (string index) + (get-text-property index 'eshell-glob-char string)) + +(defsubst eshell--contains-glob-char-p (string) + (text-property-any 0 (length string) 'eshell-glob-char t string)) + +(defun eshell--all-glob-chars-p (string) + (and (length> string 0) + (not (text-property-not-all + 0 (length string) 'eshell-glob-char t string)))) (defun eshell-glob-regexp (pattern) "Convert glob-pattern PATTERN to a regular expression. @@ -211,9 +225,10 @@ The basic syntax is: [a-b] [a-b] matches a character or range [^a] [^a] excludes a character or range -If any characters in PATTERN have the text property `escaped' -set to true, then these characters will match themselves in the -resulting regular expression." +This function only considers in PATTERN that have the text property +`eshell-glob-char' set to t for conversion from glob to regexp syntax. +All other characters are treated as literals. See also +`eshell-parse-glob-chars' and `eshell-parse-glob-string'." (let ((matched-in-pattern 0) ; How much of PATTERN handled regexp) (while (string-match (eshell-glob-chars-regexp) @@ -224,7 +239,7 @@ resulting regular expression." (concat regexp (regexp-quote (substring pattern matched-in-pattern op-begin)))) - (if (get-text-property op-begin 'escaped pattern) + (if (not (eshell--glob-char-p pattern op-begin)) (setq regexp (concat regexp (regexp-quote (char-to-string op-char))) matched-in-pattern (1+ op-begin)) @@ -244,7 +259,11 @@ resulting regular expression." (defun eshell-glob-p (pattern) "Return non-nil if PATTERN has any special glob characters." - (string-match (eshell-glob-chars-regexp) pattern)) + (declare (obsolete nil "31.1")) + ;; "~" is an infix globbing character, so one at the start of a glob + ;; must be a literal. + (let ((start (if (string-prefix-p "~" pattern) 1 0))) + (string-match (eshell-glob-chars-regexp) pattern start))) (defun eshell-glob-convert-1 (glob &optional last) "Convert a GLOB matching a single element of a file name to regexps. @@ -261,8 +280,8 @@ include, and the second for ones to exclude." ;; Split the glob if it contains a negation like x~y. (while (and (eq incl glob) (setq index (string-search "~" glob index))) - (if (or (get-text-property index 'escaped glob) - (or (= (1+ index) len))) + (if (or (not (eshell--glob-char-p glob index)) + (= (1+ index) len)) (setq index (1+ index)) (setq incl (substring glob 0 index) excl (substring glob (1+ index))))) @@ -306,13 +325,18 @@ The result is a list of three elements: (setq start-dir (pop globs)) (setq start-dir (file-name-as-directory "."))) (while globs - (if-let ((recurse (cdr (assoc (car globs) - eshell-glob-recursive-alist)))) + ;; "~" is an infix globbing character, so one at the start of a + ;; glob component must be a literal. + (when (eq (aref (car globs) 0) ?~) + (remove-text-properties 0 1 '(eshell-glob-char) (car globs))) + (if-let* ((recurse (cdr (assoc (car globs) eshell-glob-recursive-alist))) + ((eshell--all-glob-chars-p + (string-trim-right (car globs) "/")))) (if last-saw-recursion (setcar result recurse) (push recurse result) (setq last-saw-recursion t)) - (if (or result (eshell-glob-p (car globs))) + (if (or result (eshell--contains-glob-char-p (car globs))) (push (eshell-glob-convert-1 (car globs) (null (cdr globs))) result) ;; We haven't seen a glob yet, so instead append to the start @@ -324,6 +348,38 @@ The result is a list of three elements: (nreverse result) isdir))) +(defun eshell-expand-glob (glob) + "Return a list of files matched by GLOB. +Each globbing character in GLOB should have a non-nil value for the text +property `eshell-glob-char' (e.g. by `eshell-parse-glob-chars') in order +for it to have syntactic meaning; otherwise, this function treats the +character literally. + +This function is primarily intended for use within Eshell command +forms. If you want to use an ordinary string as a glob, use +`eshell-extended-glob' instead." + (let ((globs (eshell-glob-convert glob)) + eshell-glob-matches message-shown) + (unwind-protect + ;; After examining GLOB, make sure we actually got some globs + ;; before computing the results. We can get zero globs for + ;; remote file names using "~", like "/ssh:remote:~/file.txt". + ;; During Eshell argument parsing, we can't always be sure if + ;; the "~" is a home directory reference or part of a glob + ;; (e.g. if the argument was assembled from variables). + (when (cadr globs) + (apply #'eshell-glob-entries globs)) + (when message-shown + (message nil))) + (cond + (eshell-glob-matches + (sort eshell-glob-matches #'string<)) + ((and eshell-error-if-no-glob (cadr globs)) + (error "No matches found: %s" glob)) + (t + (let ((result (substring-no-properties glob))) + (if eshell-glob-splice-results (list result) result)))))) + (defun eshell-extended-glob (glob) "Return a list of files matched by GLOB. If no files match, signal an error (if `eshell-error-if-no-glob' @@ -339,26 +395,9 @@ syntax. Things that are not supported are: Mainly they are not supported because file matching is done with Emacs regular expressions, and these cannot support the above constructs." - (let ((globs (eshell-glob-convert glob)) - eshell-glob-matches message-shown) - (if (null (cadr globs)) - ;; If, after examining GLOB, there are no actual globs, just - ;; bail out. This can happen for remote file names using "~", - ;; like "/ssh:remote:~/file.txt". During parsing, we can't - ;; always be sure if the "~" is a home directory reference or - ;; part of a glob (e.g. if the argument was assembled from - ;; variables). - (if eshell-glob-splice-results (list glob) glob) - (unwind-protect - (apply #'eshell-glob-entries globs) - (if message-shown - (message nil))) - (or (and eshell-glob-matches (sort eshell-glob-matches #'string<)) - (if eshell-error-if-no-glob - (error "No matches found: %s" glob) - (if eshell-glob-splice-results - (list glob) - glob)))))) + (eshell-expand-glob (eshell-parse-glob-string glob))) + +(defconst eshell--glob-anything (eshell-parse-glob-string "*")) ;; FIXME does this really need to abuse eshell-glob-matches, message-shown? (defun eshell-glob-entries (path globs only-dirs) @@ -375,7 +414,7 @@ directories and files." (if (rassq (car globs) eshell-glob-recursive-alist) (setq recurse-p (car globs) glob (or (cadr globs) - (eshell-glob-convert-1 "*" t)) + (eshell-glob-convert-1 eshell--glob-anything t)) glob-remainder (cddr globs)) (setq glob (car globs) glob-remainder (cdr globs))) diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 8bf2e20d320..e8cdb9c82c4 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -246,6 +246,17 @@ scope during the evaluation of TEST-SEXP." (declare-function eshell-extended-glob "em-glob" (glob)) (defvar eshell-error-if-no-glob) +(defvar eshell-glob-splice-results) + +(defun eshell-ls--expand-wildcards (file) + "Expand the shell wildcards in FILE if any." + (if (and (atom file) + (not (file-exists-p file))) + (let ((eshell-error-if-no-glob t) + ;; Ensure `eshell-extended-glob' returns a list. + (eshell-glob-splice-results t)) + (mapcar #'file-relative-name (eshell-extended-glob file))) + (list (file-relative-name file)))) (defun eshell-ls--insert-directory (orig-fun file switches &optional wildcard full-directory-p) @@ -277,13 +288,7 @@ instead." (require 'em-glob) (let* ((insert-func 'insert) (error-func 'insert) - (eshell-error-if-no-glob t) - (target ; Expand the shell wildcards if any. - (if (and (atom file) - (string-match "[[?*]" file) - (not (file-exists-p file))) - (mapcar #'file-relative-name (eshell-extended-glob file)) - (file-relative-name file))) + (target (eshell-ls--expand-wildcards file)) (switches (append eshell-ls-dired-initial-args (and (or (consp dired-directory) wildcard) (list "-d")) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index a9274e7c60d..16946eb5bfc 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -121,7 +121,7 @@ The format of each entry is (?r . (lambda (lst) (mapcar #'file-name-sans-extension lst))) (?e . (lambda (lst) (mapcar #'file-name-extension lst))) (?t . (lambda (lst) (mapcar #'file-name-nondirectory lst))) - (?q . (lambda (lst) (mapcar #'eshell-escape-arg lst))) + (?q . #'identity) ; Obsolete as of Emacs 31.1. (?u . (lambda (lst) (seq-uniq lst))) (?o . (lambda (lst) (sort lst #'string-lessp))) (?O . (lambda (lst) (sort lst #'string-greaterp))) @@ -197,7 +197,6 @@ FOR SINGLE ARGUMENTS, or each argument of a list of strings: t basename e file extension r strip file extension - q escape special characters S split string at any whitespace character S/PAT/ split string at each occurrence of PAT @@ -261,8 +260,8 @@ respectively.") (defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the predicate/modifier code." - (add-hook 'eshell-parse-argument-hook - #'eshell-parse-arg-modifier t t) + ;; Make sure this function runs before `eshell-parse-glob-chars'. + (add-hook 'eshell-parse-argument-hook #'eshell-parse-arg-modifier 50 t) (eshell-pred-mode)) (defun eshell-apply-modifiers (lst predicates modifiers string-desc) @@ -442,7 +441,7 @@ before the closing delimiter. This allows modifiers like (error "Unknown %s name specified for modifier `%c'" mod-type mod-char)) (lambda (file) - (when-let ((attrs (file-attributes file))) + (when-let* ((attrs (file-attributes file))) (= (nth attr-index attrs) ugid))))) (defun eshell-pred-file-time (mod-char mod-type attr-index) @@ -467,7 +466,7 @@ before the closing delimiter. This allows modifiers like (list #'time-less-p (lambda (a b) (time-less-p b a)) #'time-equal-p))) - (if-let ((number (eshell-get-numeric-modifier-argument))) + (if-let* ((number (eshell-get-numeric-modifier-argument))) (setq when (time-since (* number quantum))) (let* ((file (or (eshell-get-delimited-modifier-argument) (error "Malformed %s time modifier `%c'" @@ -476,7 +475,7 @@ before the closing delimiter. This allows modifiers like (error "Cannot stat file `%s'" file)))) (setq when (nth attr-index attrs)))) (lambda (file) - (when-let ((attrs (file-attributes file))) + (when-let* ((attrs (file-attributes file))) (funcall qual when (nth attr-index attrs)))))) (defun eshell-pred-file-type (type) @@ -492,13 +491,13 @@ that `ls -l' will show in the first column of its display." '(?b ?c) (list type)))) (lambda (file) - (when-let ((attrs (eshell-file-attributes (directory-file-name file)))) + (when-let* ((attrs (eshell-file-attributes (directory-file-name file)))) (memq (aref (file-attribute-modes attrs) 0) set))))) (defsubst eshell-pred-file-mode (mode) "Return a test which tests that MODE pertains to the file." (lambda (file) - (when-let ((modes (file-modes file 'nofollow))) + (when-let* ((modes (file-modes file 'nofollow))) (not (zerop (logand mode modes)))))) (defun eshell-pred-file-links () @@ -507,7 +506,7 @@ that `ls -l' will show in the first column of its display." (amount (or (eshell-get-numeric-modifier-argument) (error "Invalid file link count modifier `l'")))) (lambda (file) - (when-let ((attrs (eshell-file-attributes file))) + (when-let* ((attrs (eshell-file-attributes file))) (funcall qual (file-attribute-link-number attrs) amount))))) (defun eshell-pred-file-size () @@ -528,7 +527,7 @@ that `ls -l' will show in the first column of its display." (error "Invalid file size modifier `L'")) quantum)) (lambda (file) - (when-let ((attrs (eshell-file-attributes file))) + (when-let* ((attrs (eshell-file-attributes file))) (funcall qual (file-attribute-size attrs) amount))))) (defun eshell-pred-substitute (&optional repeat) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index 7de2bd4dc21..37970ac0ba5 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -119,6 +119,19 @@ arriving, or after." (add-hook 'eshell-post-command-hook 'eshell-emit-prompt nil t) (eshell-prompt-mode))) +(defun eshell--append-text-property (start end prop value &optional object) + "Append to a text property from START to END. +PROP is the text property to append to, and VALUE is the list of +property values to append. OBJECT is the object to propertize, as with +`put-text-property' (which see)." + (let (next) + (while (< start end) + (setq next (next-single-property-change start prop object end)) + (put-text-property start next prop + (append (get-text-property start prop object) value) + object) + (setq start next)))) + (defun eshell-emit-prompt () "Emit a prompt if eshell is being used interactively." (when (boundp 'ansi-color-context-region) @@ -126,19 +139,16 @@ arriving, or after." (run-hooks 'eshell-before-prompt-hook) (if (not eshell-prompt-function) (set-marker eshell-last-output-end (point)) - (let ((prompt (funcall eshell-prompt-function))) - (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) + (let* ((prompt (funcall eshell-prompt-function)) + (len (length prompt)) + (sticky-props '(field))) + (put-text-property 0 len 'field 'prompt prompt) + (when eshell-highlight-prompt + (add-text-properties + 0 len '(read-only t font-lock-face eshell-prompt) prompt) + (setq sticky-props `(read-only font-lock-face . ,sticky-props))) + (eshell--append-text-property 0 len 'front-sticky sticky-props prompt) + (eshell--append-text-property 0 len 'rear-nonsticky sticky-props prompt) (eshell-interactive-filter nil prompt))) (run-hooks 'eshell-after-prompt-hook)) @@ -178,8 +188,8 @@ Like `forward-paragraph', but also stops at the beginning of each prompt." (while (and (> n 0) (< (point) (point-max))) (let ((next-paragraph (save-excursion (forward-paragraph) (point))) (next-prompt (save-excursion - (if-let ((match (text-property-search-forward - 'field 'prompt t t))) + (if-let* ((match (text-property-search-forward + 'field 'prompt t t))) (prop-match-beginning match) (point-max))))) (goto-char (min next-paragraph next-prompt))) @@ -212,7 +222,7 @@ Like `backward-paragraph', but navigates using fields." (pcase (get-text-property (point) 'field) ('command-output) ('prompt (goto-char (field-end))) - (_ (when-let ((match (text-property-search-backward 'field 'prompt t))) + (_ (when-let* ((match (text-property-search-backward 'field 'prompt t))) (goto-char (prop-match-end match))))) ;; Now, move forward/backward to our destination prompt. (if (natnump n) diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index ebba0440d68..f426afb5d28 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -24,6 +24,7 @@ ;;; Code: (require 'esh-mode) +(require 'esh-cmd) (require 'esh-io) ;;;###esh-module-autoload @@ -67,22 +68,24 @@ This includes when running `eshell-command'." 'eshell/source) eshell-interpreter-alist)) (setq-local eshell-complex-commands - (append '("source" ".") eshell-complex-commands)) - ;; these two variables are changed through usage, but we don't want - ;; to ruin it for other modules - (let (eshell-inside-quote-regexp - eshell-outside-quote-regexp) - (and (not (bound-and-true-p eshell-non-interactive-p)) - eshell-login-script - (file-readable-p eshell-login-script) - (eshell-do-eval - `(eshell-commands ,(eshell--source-file eshell-login-script)) - t)) - (and eshell-rc-script - (file-readable-p eshell-rc-script) - (eshell-do-eval - `(eshell-commands ,(eshell--source-file eshell-rc-script)) - t)))) + (append '("source" ".") eshell-complex-commands)) + ;; Run our startup scripts once this Eshell session has finished + ;; initialization. + (add-hook 'eshell-after-initialize-hook #'eshell-run-startup-scripts 90 t)) + +(defun eshell-run-startup-scripts () + "Run any necessary startup scripts for the current Eshell session." + (when (and (not (bound-and-true-p eshell-non-interactive-p)) + eshell-login-script + (file-readable-p eshell-login-script)) + (eshell-do-eval + `(eshell-commands ,(eshell--source-file eshell-login-script)) + t)) + (when (and eshell-rc-script + (file-readable-p eshell-rc-script)) + (eshell-do-eval + `(eshell-commands ,(eshell--source-file eshell-rc-script)) + t))) (defun eshell--source-file (file &optional args subcommand-p) "Return a Lisp form for executing the Eshell commands in FILE, passing ARGS. @@ -106,22 +109,30 @@ Comments begin with `#'." (eshell--source-file file args subcommand-p))) ;;;###autoload -(defun eshell-execute-file (file &optional args destination) +(defun eshell-execute-file (file &optional args output-target error-target) "Execute a series of Eshell commands in FILE, passing ARGS. -If DESTINATION is t, write the command output to the current buffer. If -nil, don't write the output anywhere. For any other value, output to -the corresponding Eshell target (see `eshell-get-target'). +If OUTPUT-TARGET is t (interactively, with the prefix argument), write +the command's standard output to the current buffer at point. If nil, +don't write the output anywhere. For any other value, output to that +Eshell target (see `eshell-get-target'). + +ERROR-TARGET is similar to OUTPUT-TARGET, except that it controls where +to write standard error, and a nil value means to write standard error +to the same place as standard output. (To suppress standard error, you +can write to the Eshell virtual target \"/dev/null\".) Comments begin with `#'." + (interactive (list (read-file-name "Execute file: " nil nil t) + nil (not (not current-prefix-arg)))) (let ((eshell-non-interactive-p t) - (stdout (if (eq destination t) (current-buffer) destination))) + (stdout (if (eq output-target t) (current-buffer) output-target)) + (stderr (if (eq error-target t) (current-buffer) error-target))) (with-temp-buffer (eshell-mode) (eshell-do-eval - `(let ((eshell-current-handles - (eshell-create-handles ',stdout 'insert)) - (eshell-current-subjob-p)) - ,(eshell--source-file file args)) + `(eshell-with-handles (',stdout 'insert ',stderr 'insert) + (let ((eshell-current-subjob-p)) + ,(eshell--source-file file args))) t)))) (cl-defstruct (eshell-princ-target @@ -166,11 +177,9 @@ top in order to make it into an executable script: (with-temp-buffer (eshell-mode) (eshell-do-eval - `(let ((eshell-current-handles - (eshell-create-handles "/dev/stdout" 'append - "/dev/stderr" 'append)) - (eshell-current-subjob-p)) - ,(eshell--source-file file args)) + `(eshell-with-handles ("/dev/stdout" 'append "/dev/stderr" 'append) + (let ((eshell-current-subjob-p)) + ,(eshell--source-file file args))) t)))) (defun eshell/source (file &rest args) diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 671573f38c5..9cdc0ca6f25 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -858,119 +858,109 @@ external command." pcomplete-last-completion-raw t) (throw 'pcomplete-completions (pcomplete-read-host-names))))) -(defvar block-size) -(defvar by-bytes) -(defvar dereference-links) -(defvar grand-total) -(defvar human-readable) -(defvar max-depth) -(defvar only-one-filesystem) -(defvar show-all) - -(defsubst eshell-du-size-string (size) - (let* ((str (eshell-printable-size size human-readable block-size t)) - (len (length str))) - (concat str (if (< len 8) - (make-string (- 8 len) ? ))))) - -(defun eshell-du-sum-directory (path depth) +(cl-defun eshell-du-sum-directory (path depth-remaining &rest args + &key print-function show-all + dereference-links only-one-filesystem + seen-files) "Summarize PATH, and its member directories." - (let ((entries (eshell-directory-files-and-attributes path)) - (size 0.0)) - (while entries - (unless (string-match "\\`\\.\\.?\\'" (caar entries)) - (let* ((entry (concat path "/" - (caar entries))) - (symlink (and (stringp (file-attribute-type (cdar entries))) - (file-attribute-type (cdar entries))))) + (let ((size 0.0)) + (dolist (entry (eshell-directory-files-and-attributes path)) + (unless (or (string-match "\\`\\.\\.?\\'" (car entry)) + (gethash (file-attribute-file-identifier (cdr entry)) + seen-files)) + (puthash (file-attribute-file-identifier (cdr entry)) t seen-files) + (let* ((file-name (concat path "/" (car entry))) + (file-type (file-attribute-type (cdr entry))) + (symlink (and (stringp file-type) file-type))) (unless (or (and symlink (not dereference-links)) (and only-one-filesystem (/= only-one-filesystem - (file-attribute-device-number (cdar entries))))) - (if symlink - (setq entry symlink)) + (file-attribute-device-number (cdr entry))))) + (when symlink + (setq file-name symlink)) (setq size (+ size - (if (eq t (car (cdar entries))) - (eshell-du-sum-directory entry (1+ depth)) - (let ((file-size (file-attribute-size (cdar entries)))) - (prog1 - file-size - (if show-all - (eshell-print - (concat (eshell-du-size-string file-size) - entry "\n"))))))))))) - (setq entries (cdr entries))) - (if (or (not max-depth) - (= depth max-depth) - (= depth 0)) - (eshell-print (concat (eshell-du-size-string size) - (directory-file-name path) "\n"))) + (if (eq file-type t) ; This is a directory. + (apply #'eshell-du-sum-directory file-name + (when depth-remaining (1- depth-remaining)) + args) + (let ((file-size (file-attribute-size (cdr entry)))) + (when show-all + (funcall print-function file-size file-name)) + file-size)))))))) + (when (or (not depth-remaining) + (natnump depth-remaining)) + (funcall print-function size (directory-file-name path))) size)) (defun eshell/du (&rest args) "Implementation of \"du\" in Lisp, passing ARGS." - (setq args (if args - (eshell-stringify-list (flatten-tree args)) - '("."))) - (let ((ext-du (eshell-search-path "du"))) - (if (and ext-du - (not (catch 'have-ange-path - (dolist (arg args) - (if (string-equal - (file-remote-p (expand-file-name arg) 'method) "ftp") - (throw 'have-ange-path t)))))) - (throw 'eshell-external (eshell-external-command ext-du args)) - (eshell-eval-using-options - "du" args - '((?a "all" nil show-all - "write counts for all files, not just directories") - (nil "block-size" t block-size - "use SIZE-byte blocks (i.e., --block-size SIZE)") - (?b "bytes" nil by-bytes - "print size in bytes") - (?c "total" nil grand-total - "produce a grand total") - (?d "max-depth" t max-depth - "display data only this many levels of data") - (?h "human-readable" 1024 human-readable - "print sizes in human readable format") - (?H "si" 1000 human-readable - "likewise, but use powers of 1000 not 1024") - (?k "kilobytes" 1024 block-size - "like --block-size 1024") - (?L "dereference" nil dereference-links - "dereference all symbolic links") - (?m "megabytes" 1048576 block-size - "like --block-size 1048576") - (?s "summarize" 0 max-depth - "display only a total for each argument") - (?x "one-file-system" nil only-one-filesystem - "skip directories on different filesystems") - (nil "help" nil nil - "show this usage screen") - :external "du" - :usage "[OPTION]... FILE... + (let ((original-args args)) + (eshell-eval-using-options + "du" args + '((?a "all" nil show-all + "write counts for all files, not just directories") + (nil "block-size" t block-size + "use SIZE-byte blocks (i.e., --block-size SIZE)") + (?b "bytes" 1 block-size + "print size in bytes") + (?c "total" nil grand-total + "produce a grand total") + (?d "max-depth" t max-depth + "display data only this many levels of data") + (?h "human-readable" 1024 human-readable + "print sizes in human readable format") + (?H "si" 1000 human-readable + "likewise, but use powers of 1000 not 1024") + (?k "kilobytes" 1024 block-size + "like --block-size 1024") + (?L "dereference" nil dereference-links + "dereference all symbolic links") + (?m "megabytes" 1048576 block-size + "like --block-size 1048576") + (?s "summarize" 0 max-depth + "display only a total for each argument") + (?x "one-file-system" nil only-one-filesystem + "skip directories on different filesystems") + (nil "help" nil nil + "show this usage screen") + :external "du" + :usage "[OPTION]... FILE... Summarize disk usage of each FILE, recursively for directories.") - (unless by-bytes - (setq block-size (or block-size 1024))) - (if (and max-depth (stringp max-depth)) - (setq max-depth (string-to-number max-depth))) - ;; filesystem support means nothing under Windows - (if (eshell-under-windows-p) - (setq only-one-filesystem nil)) - (let ((size 0.0)) - (while args - (if only-one-filesystem - (setq only-one-filesystem - (file-attribute-device-number (eshell-file-attributes - (file-name-as-directory (car args)))))) - (setq size (+ size (eshell-du-sum-directory - (directory-file-name (car args)) 0))) - (setq args (cdr args))) - (if grand-total - (eshell-print (concat (eshell-du-size-string size) - "total\n")))))))) + ;; If possible, use the external "du" command. + (when-let* (((not (seq-some + (lambda (i) (and (stringp i) (file-remote-p i))) + args))) + (ext-du (eshell-search-path "du"))) + (throw 'eshell-external (eshell-external-command ext-du original-args))) + (setq block-size (or block-size 1024)) + (when (stringp block-size) + (setq block-size (string-to-number block-size))) + (when (stringp max-depth) + (setq max-depth (string-to-number max-depth))) + ;; Filesystem support means nothing under MS-Windows. + (when (eshell-under-windows-p) + (setq only-one-filesystem nil)) + (let ((size 0.0) + (seen-files (make-hash-table :test #'equal)) + (print-function + (lambda (size name) + (let ((size-str (eshell-printable-size size human-readable + block-size t))) + (eshell-print (concat (string-pad size-str 8) name "\n")))))) + (dolist (arg (or args '("."))) + (when only-one-filesystem + (setq only-one-filesystem + (file-attribute-device-number + (eshell-file-attributes (file-name-as-directory arg))))) + (setq size (+ size (eshell-du-sum-directory + (directory-file-name arg) max-depth + :print-function print-function :show-all show-all + :dereference-links dereference-links + :only-one-filesystem only-one-filesystem + :seen-files seen-files)))) + (when grand-total + (funcall print-function size "total")))))) (put 'eshell/du 'eshell-filename-arguments t) diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el index 0a032395fd3..263ec37a720 100644 --- a/lisp/eshell/em-xtra.el +++ b/lisp/eshell/em-xtra.el @@ -40,46 +40,37 @@ naturally accessible within Emacs." ;;; Functions: -(autoload 'eshell-parse-command "esh-cmd") - (defun eshell/expr (&rest args) "Implementation of expr, using the calc package." (calc-eval (eshell-flatten-and-stringify args))) -(defun eshell/substitute (&rest args) +(defun eshell/substitute (new old seq &rest args) "Easy front-end to `cl-substitute', for comparing lists of strings." - (apply #'cl-substitute (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-substitute new old seq :test #'equal args)) -(defun eshell/count (&rest args) +(defun eshell/count (item seq &rest args) "Easy front-end to `cl-count', for comparing lists of strings." - (apply #'cl-count (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-count item seq :test #'equal args)) -(defun eshell/mismatch (&rest args) +(defun eshell/mismatch (seq1 seq2 &rest args) "Easy front-end to `cl-mismatch', for comparing lists of strings." - (apply #'cl-mismatch (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-mismatch seq1 seq2 :test #'equal args)) -(defun eshell/union (&rest args) +(defun eshell/union (list1 list2 &rest args) "Easy front-end to `cl-union', for comparing lists of strings." - (apply #'cl-union (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-union list1 list2 :test #'equal args)) -(defun eshell/intersection (&rest args) +(defun eshell/intersection (list1 list2 &rest args) "Easy front-end to `cl-intersection', for comparing lists of strings." - (apply #'cl-intersection (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-intersection list1 list2 :test #'equal args)) -(defun eshell/set-difference (&rest args) +(defun eshell/set-difference (list1 list2 &rest args) "Easy front-end to `cl-set-difference', for comparing lists of strings." - (apply #'cl-set-difference (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-set-difference list1 list2 :test #'equal args)) -(defun eshell/set-exclusive-or (&rest args) +(defun eshell/set-exclusive-or (list1 list2 &rest args) "Easy front-end to `cl-set-exclusive-or', for comparing lists of strings." - (apply #'cl-set-exclusive-or (car args) (cadr args) :test #'equal - (cddr args))) + (apply #'cl-set-exclusive-or list1 list2 :test #'equal args)) (defalias 'eshell/ff #'find-name-dired) (defalias 'eshell/gf #'find-grep-dired) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 6fc700cce89..937f1f435f0 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -35,6 +35,8 @@ (eval-when-compile (require 'cl-lib)) +(declare-function eshell-term-as-value "esh-cmd" (term)) + (defgroup eshell-arg nil "Argument parsing involves transforming the arguments passed on the command line into equivalent Lisp forms that, when evaluated, will @@ -51,8 +53,6 @@ yield the values intended." (defvar eshell-current-quoted nil) (defvar eshell-current-argument-plain nil "If non-nil, the current argument is \"plain\", and not part of a command.") -(defvar eshell-inside-quote-regexp nil) -(defvar eshell-outside-quote-regexp nil) ;;; User Variables: @@ -87,66 +87,30 @@ If POS is nil, the location of point is checked." (memq (char-after pos) eshell-delimiter-argument-list)))) (defcustom eshell-parse-argument-hook - (list - ;; a term such as #<buffer NAME>, or #<process NAME> is a buffer - ;; or process reference - 'eshell-parse-special-reference - - ;; numbers convert to numbers if they stand alone - (lambda () - (when (and (not eshell-current-argument) - (not eshell-current-quoted) - (looking-at eshell-number-regexp) - (eshell-arg-delimiter (match-end 0))) - (goto-char (match-end 0)) - (let ((str (match-string 0))) - (if (> (length str) 0) - (add-text-properties 0 (length str) '(number t) str)) - str))) - - ;; parse any non-special characters, based on the current context - (lambda () - (unless eshell-inside-quote-regexp - (setq eshell-inside-quote-regexp - (format "[^%s]+" - (apply 'string eshell-special-chars-inside-quoting)))) - (unless eshell-outside-quote-regexp - (setq eshell-outside-quote-regexp - (format "[^%s]+" - (apply 'string eshell-special-chars-outside-quoting)))) - (when (looking-at (if eshell-current-quoted - eshell-inside-quote-regexp - eshell-outside-quote-regexp)) - (goto-char (match-end 0)) - (let ((str (match-string 0))) - (if str - (set-text-properties 0 (length str) nil str)) - str))) - - ;; whitespace or a comment is an argument delimiter - (lambda () - (let (comment-p) - (when (or (looking-at "[ \t]+") - (and (not eshell-current-argument) - (looking-at "#\\([^<'].*\\|$\\)") - (setq comment-p t))) - (if comment-p - (add-text-properties (match-beginning 0) (match-end 0) - '(comment t))) - (goto-char (match-end 0)) - (eshell-finish-arg)))) - - ;; parse backslash and the character after - 'eshell-parse-backslash - - ;; text beginning with ' is a literally quoted - 'eshell-parse-literal-quote - - ;; text beginning with " is interpolably quoted - 'eshell-parse-double-quote - - ;; argument delimiter - 'eshell-parse-delimiter) + '(;; A term such as #<buffer NAME>, or #<process NAME> is a buffer + ;; or process reference. + eshell-parse-special-reference + ;; Numbers convert to numbers if they stand alone. + eshell-parse-number + ;; Integers convert to numbers if they stand alone or are part of a + ;; range expression. + eshell-parse-integer + ;; Range tokens go between integers and denote a half-open range. + eshell-parse-range-token + ;; Parse any non-special characters, based on the current context. + eshell-parse-non-special + ;; Whitespace is an argument delimiter. + eshell-parse-whitespace + ;; ... so is a comment. + eshell-parse-comment + ;; Parse backslash and the character after. + eshell-parse-backslash + ;; Text beginning with ' is a literally quoted. + eshell-parse-literal-quote + ;; Text beginning with " is interpolably quoted. + eshell-parse-double-quote + ;; Delimiters that separate individual commands. + eshell-parse-delimiter) "Define how to process Eshell command line arguments. When each function on this hook is called, point will be at the current position within the argument list. The function should either @@ -216,15 +180,36 @@ Eshell will expand special refs like \"#<ARG...>\" into (defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the argument parsing code." (eshell-arg-mode) - (setq-local eshell-inside-quote-regexp nil) - (setq-local eshell-outside-quote-regexp nil) - (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook #'eshell-complete-special-reference nil t))) +(defvar eshell--non-special-inside-quote-regexp nil) +(defsubst eshell--non-special-inside-quote-regexp () + (or eshell--non-special-inside-quote-regexp + (setq-local eshell--non-special-inside-quote-regexp + (rx-to-string + `(+ (not (any ,@eshell-special-chars-inside-quoting))) t)))) + +(defvar eshell--non-special-outside-quote-regexp nil) +(defsubst eshell--non-special-outside-quote-regexp () + (or eshell--non-special-outside-quote-regexp + (setq-local eshell--non-special-outside-quote-regexp + (rx-to-string + `(+ (not (any ,@eshell-special-chars-outside-quoting))) t)))) + +(defvar eshell--after-range-token-regexp nil) +(defsubst eshell--after-range-token-regexp () + (or eshell--after-range-token-regexp + (setq-local eshell--after-range-token-regexp + (rx-to-string + `(or (any ,@eshell-special-chars-outside-quoting) + (regexp ,eshell-integer-regexp)) + t)))) + (defsubst eshell-escape-arg (string) "Return STRING with the `escaped' property on it." + (declare (obsolete nil "31.1")) (if (stringp string) (add-text-properties 0 (length string) '(escaped t) string)) string) @@ -271,13 +256,15 @@ would produce (\"abc\" \"d\")." (defun eshell-concat-1 (quoted first second) "Concatenate FIRST and SECOND. -If QUOTED is nil and either FIRST or SECOND are numbers, try to -convert the result to a number as well." - (let ((result (concat (eshell-stringify first) (eshell-stringify second)))) - (if (and (not quoted) - (or (numberp first) (numberp second))) - (eshell-convert-to-number result) - result))) +If QUOTED is nil and either FIRST or SECOND are numberlike, try to mark +the result as a number as well." + (let ((result (concat (eshell-stringify first quoted) + (eshell-stringify second quoted)))) + (when (and (not quoted) + (or (numberp first) (eshell--numeric-string-p first) + (numberp second) (eshell--numeric-string-p second))) + (eshell-mark-numeric-string result)) + result)) (defun eshell-concat-groups (quoted &rest args) "Concatenate groups of arguments in ARGS and return the result. @@ -316,8 +303,8 @@ then the result will be: "If there are pending modifications to be made, make them now." (when eshell-current-argument (when eshell-arg-listified - (if-let ((grouped-terms (eshell-prepare-splice - 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 @@ -439,6 +426,88 @@ Point is left at the end of the arguments." "A stub function that generates an error if a floating splice is found." (error "Splice operator is not permitted in this context")) +(defconst eshell--range-token (propertize ".." 'eshell-range t)) + +(defun eshell-parse-number () + "Parse a numeric argument. +Eshell can treat unquoted arguments matching `eshell-number-regexp' as +their numeric values." + (when (and (not eshell-current-argument) + (not eshell-current-quoted) + (looking-at eshell-number-regexp) + (eshell-arg-delimiter (match-end 0))) + (goto-char (match-end 0)) + (let ((str (match-string 0))) + (add-text-properties 0 (length str) '(number t) str) + str))) + +(defun eshell-parse-integer () + "Parse an integer argument." + (unless eshell-current-quoted + (let ((prev-token (if eshell-arg-listified + (car (last eshell-current-argument)) + eshell-current-argument))) + (when (and (memq prev-token `(nil ,eshell--range-token)) + (looking-at eshell-integer-regexp) + (or (eshell-arg-delimiter (match-end 0)) + (save-excursion + (goto-char (match-end 0)) + (looking-at-p (rx ".."))))) + (goto-char (match-end 0)) + (let ((str (match-string 0))) + (add-text-properties 0 (length str) '(number t) str) + str))))) + +(defun eshell-unmark-range-token (string) + (remove-text-properties 0 (length string) '(eshell-range) string)) + +(defun eshell-parse-range-token () + "Parse a range token. +This separates two integers (possibly as dollar expansions) and denotes +a half-open range." + (when (and (not eshell-current-quoted) + (looking-at (rx "..")) + (or (eshell-arg-delimiter (match-end 0)) + (save-excursion + (goto-char (match-end 0)) + (looking-at (eshell--after-range-token-regexp))))) + ;; If we parse multiple range tokens for a single argument, then + ;; they can't actually be range tokens. Unmark the result to + ;; indicate this. + (when (memq eshell--range-token + (if eshell-arg-listified + eshell-current-argument + (list eshell-current-argument))) + (add-hook 'eshell-current-modifiers #'eshell-unmark-range-token)) + (forward-char 2) + eshell--range-token)) + +(defun eshell-parse-non-special () + "Parse any non-special characters, depending on the current context." + (when (looking-at (if eshell-current-quoted + (eshell--non-special-inside-quote-regexp) + (eshell--non-special-outside-quote-regexp))) + (goto-char (match-end 0)) + (let ((str (match-string 0))) + (when str + (set-text-properties 0 (length str) nil str)) + str))) + +(defun eshell-parse-whitespace () + "Parse any whitespace, finishing the current argument. +These are treated as argument delimiters and so finish the current argument." + (when (looking-at "[ \t]+") + (goto-char (match-end 0)) + (eshell-finish-arg))) + +(defun eshell-parse-comment () + "Parse a comment, finishing the current argument." + (when (and (not eshell-current-argument) + (looking-at "#\\([^<'].*\\|$\\)")) + (add-text-properties (match-beginning 0) (match-end 0) '(comment t)) + (goto-char (match-end 0)) + (eshell-finish-arg))) + (defsubst eshell-looking-at-backslash-return (pos) "Test whether a backslash-return sequence occurs at POS." (declare (obsolete nil "30.1")) @@ -472,53 +541,46 @@ after are both returned." (when (= (1+ (point)) (point-max)) (throw 'eshell-incomplete "\\")) (forward-char 2) ; Move one char past the backslash. - (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))))))) + (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) + ;; 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". + ((and eshell-current-quoted + (not (memq (char-before) eshell-special-chars-inside-quoting))) + (concat "\\" (char-to-string (char-before)))) + (t + (char-to-string (char-before)))))) (defun eshell-parse-literal-quote () "Parse a literally quoted string. Nothing has special meaning!" - (if (eq (char-after) ?\') - (let ((end (eshell-find-delimiter ?\' ?\'))) - (if (not end) - (throw 'eshell-incomplete "'") - (let ((string (buffer-substring-no-properties (1+ (point)) end))) - (goto-char (1+ end)) - (while (string-match "''" string) - (setq string (replace-match "'" t t string))) - (list 'eshell-escape-arg string)))))) + (when (eq (char-after) ?\') + (let ((end (eshell-find-delimiter ?\' ?\'))) + (unless end + (throw 'eshell-incomplete "'")) + (let ((string (buffer-substring-no-properties (1+ (point)) end))) + (goto-char (1+ end)) + (while (string-match "''" string) + (setq string (replace-match "'" t t string))) + string)))) (defun eshell-parse-double-quote () "Parse a double quoted string, which allows for variable interpolation." (when (eq (char-after) ?\") (let* ((end (eshell-find-delimiter ?\" ?\" nil nil t)) - (eshell-current-quoted t)) - (if (not end) - (throw 'eshell-incomplete "\"") - (prog1 - (save-restriction - (forward-char) - (narrow-to-region (point) end) - (let ((arg (eshell-parse-argument))) - (if (eq arg nil) - "" - (list 'eshell-escape-arg arg)))) - (goto-char (1+ end))))))) + (eshell-current-quoted t)) + (unless end + (throw 'eshell-incomplete "\"")) + (prog1 + (save-restriction + (forward-char) + (narrow-to-region (point) end) + (or (eshell-parse-argument) "")) + (goto-char (1+ end)))))) (defun eshell-unescape-inner-double-quote (bound) "Unescape escaped characters inside a double-quoted string. @@ -545,7 +607,7 @@ leaves point where it was." (apply #'concat (nreverse strings)))))) (defun eshell-parse-delimiter () - "Parse an argument delimiter, which is essentially a command operator." + "Parse a command delimiter, which is essentially a command operator." ;; this `eshell-operator' keyword gets parsed out by ;; `eshell-split-commands'. Right now the only possibility for ;; error is an incorrect output redirection specifier. @@ -626,7 +688,8 @@ If the form has no `type', the syntax is parsed as if `type' were (prog1 (cons creation-fun (let ((eshell-current-argument-plain t)) - (eshell-parse-arguments (point) end))) + (mapcar #'eshell-term-as-value + (eshell-parse-arguments (point) end)))) (goto-char (1+ end))) (ignore (goto-char here))))))) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 528c7f95594..c0015745ad5 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -104,7 +104,6 @@ (require 'esh-arg) (require 'esh-proc) (require 'esh-module) -(require 'esh-io) (require 'esh-ext) (require 'eldoc) @@ -182,8 +181,7 @@ describing where Eshell will find the function." :type 'hook) (defcustom eshell-pre-rewrite-command-hook - '(eshell-no-command-conversion - eshell-subcommand-arg-values) + '(eshell-no-command-conversion) "A hook run before command rewriting begins. The terms of the command to be rewritten is passed as arguments, and may be modified in place. Any return value is ignored." @@ -240,16 +238,6 @@ return non-nil if the command is complex." :version "24.1" ; removed eshell-cmd-initialize :type 'hook) -(defcustom eshell-deferrable-commands - '(eshell-named-command - eshell-lisp-command - eshell-process-identity) - "A list of functions which might return an asynchronous process. -If they return a process object, execution of the calling Eshell -command will wait for completion (in the background) before finishing -the command." - :type '(repeat function)) - (defcustom eshell-subcommand-bindings '((eshell-in-subcommand-p t) (eshell-in-pipeline-p nil) @@ -286,8 +274,19 @@ Each element is of the form (FORM PROCESSES), as with Has the value `first', `last' for the first/last commands in the pipeline, otherwise t.") (defvar eshell-in-subcommand-p nil) + (defvar eshell-last-arguments nil) (defvar eshell-last-command-name nil) +(defvar-local eshell-last-command-status 0 + "The exit code from the last command. 0 if successful.") +(defvar-local eshell-last-command-result nil + "The result of the last command. Not related to success.") + +(defvar eshell-deferrable-commands '(eshell-deferrable) + "A list of functions which might return a deferrable process. +If they return a process object (or list thereof), execution of the +calling Eshell command will wait for completion (in the background) +before finishing the command.") (defvar eshell-allow-commands t "If non-nil, allow evaluating command forms (including Lisp forms). @@ -415,7 +414,6 @@ command hooks should be run before and after the command." ;; The last command (first in our reversed list) is implicitly ;; terminated by ";". (sep-terms (cons ";" sep-terms)) - (steal-handles t) (commands (nreverse (mapcan @@ -426,13 +424,10 @@ command hooks should be run before and after the command." (error "Empty command before `&'")) (setq cmd (eshell-parse-pipeline cmd)) (unless eshell-in-pipeline-p - (setq cmd `(eshell-trap-errors ,cmd))) + (setq cmd `(eshell-do-command ,cmd))) ;; Copy I/O handles so each full statement can manipulate - ;; them if they like. Steal the handles for the last - ;; command (first in our reversed list); we won't use the - ;; originals again anyway. - (setq cmd `(eshell-with-copied-handles ,cmd ,steal-handles) - steal-handles nil) + ;; them if they like. + (setq cmd `(eshell-with-copied-handles ,cmd)) (when (equal sep "&") (setq cmd `(eshell-do-subjob ,cmd))) (list cmd)))) @@ -459,6 +454,7 @@ command hooks should be run before and after the command." (defun eshell-subcommand-arg-values (terms) "Convert subcommand arguments {x} to ${x}, in order to take their values." + (declare (obsolete nil "31.1")) (setq terms (cdr terms)) ; skip command argument (while terms (if (and (listp (car terms)) @@ -470,9 +466,9 @@ command hooks should be run before and after the command." (defun eshell-rewrite-sexp-command (terms) "Rewrite a sexp in initial position, such as `(+ 1 2)'." ;; this occurs when a Lisp expression is in first position - (if (and (listp (car terms)) - (eq (caar terms) 'eshell-command-to-value)) - (car (cdar terms)))) + (when (and (listp (car terms)) + (eq (caar terms) 'eshell-lisp-command)) + (car terms))) (defun eshell-rewrite-initial-subcommand (terms) "Rewrite a subcommand in initial position, such as `{+ 1 2}'." @@ -482,19 +478,23 @@ command hooks should be run before and after the command." (defun eshell-rewrite-named-command (terms) "If no other rewriting rule transforms TERMS, assume a named command." - (let ((sym (if eshell-in-pipeline-p - 'eshell-named-command* - 'eshell-named-command)) - (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)))))) + (when terms + (setq terms (cons (car terms) + ;; Convert arguments to take their values. + (mapcar #'eshell-term-as-value (cdr terms)))) + (let ((sym (if eshell-in-pipeline-p + 'eshell-named-command* + 'eshell-named-command)) + (grouped-terms (eshell-prepare-splice terms))) + (cond + (grouped-terms + `(let ((new-terms (append ,@grouped-terms))) + (,sym (car new-terms) (cdr new-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) @@ -507,6 +507,7 @@ current output stream, which is separately redirectable. SILENT means the user and/or any redirections shouldn't see any output from this command. If both SHARE-OUTPUT and SILENT are non-nil, the second is ignored." + (declare (obsolete nil "31.1")) ;; something that begins with `eshell-convert' means that it ;; intends to return a Lisp value. We want to get past this, ;; but if it's not _actually_ a value interpolation -- in which @@ -522,10 +523,35 @@ the second is ignored." `(eshell-commands ,(cadr (cadr arg)) ,silent)) arg)) -(defvar eshell-last-command-status) ;Define in esh-io.el. (defvar eshell--local-vars nil "List of locally bound vars that should take precedence over env-vars.") +(iter-defun eshell-for-iterate (&rest args) + "Iterate over the elements of each sequence in ARGS. +If ARGS is not a sequence, treat it as a list of one element." + (dolist (arg args) + (when (eshell--range-string-p arg) + (setq arg (eshell--string-to-range arg))) + (cond + ((eshell-range-p arg) + (let ((i (eshell-range-begin arg)) + (end (eshell-range-end arg))) + ;; NOTE: We could support unbounded ranges here, but those + ;; aren't very easy to use in Eshell yet. (We'd need something + ;; like the "break" statement for "for" loops.) + (cl-assert (and i end)) + (while (< i end) + (iter-yield i) + (cl-incf i)))) + ((stringp arg) + (iter-yield arg)) + ((listp arg) + (dolist (i arg) (iter-yield i))) + ((arrayp arg) + (dotimes (i (length arg)) (iter-yield (aref arg i)))) + (t + (iter-yield arg))))) + (defun eshell-rewrite-for-command (terms) "Rewrite a `for' command into its equivalent Eshell command form. Because the implementation of `for' relies upon conditional evaluation @@ -533,39 +559,36 @@ of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." (if (and (equal (car terms) "for") (equal (nth 2 terms) "in")) - (let ((for-items (make-symbol "for-items")) + (let ((iter-symbol (intern (nth 1 terms))) (body (car (last terms)))) (setcdr (last terms 2) nil) - `(let ((,for-items - (append - ,@(mapcar - (lambda (elem) - (if (listp elem) - elem - `(list ,elem))) - (nthcdr 3 terms))))) - (while ,for-items - (let ((,(intern (cadr terms)) (car ,for-items)) - (eshell--local-vars (cons ',(intern (cadr terms)) - eshell--local-vars))) - (eshell-protect - ,(eshell-invokify-arg body t))) - (setq ,for-items (cdr ,for-items))) - (eshell-close-handles))))) - -(defun eshell-structure-basic-command (func names keyword test body - &optional else) + `(let ((eshell--local-vars (cons ',iter-symbol eshell--local-vars))) + (iter-do (,iter-symbol (eshell-for-iterate + ,@(mapcar #'eshell-term-as-value + (nthcdr 3 terms)))) + ,body))))) + +(defun eshell-structure-basic-command (func names keyword test &rest body) "With TERMS, KEYWORD, and two NAMES, structure a basic command. The first of NAMES should be the positive form, and the second the negative. It's not likely that users should ever need to call this function." + (declare (obsolete nil "31.1")) + (unless test + (error "Missing test for `%s' command" keyword)) + + ;; If the test form is a subcommand, wrap it in `eshell-commands' to + ;; silence the output. + (when (memq (car test) '(eshell-as-subcommand eshell-lisp-command)) + (setq test `(eshell-commands ,test t))) + ;; If the test form begins with `eshell-convert' or ;; `eshell-escape-arg', it means something data-wise will be ;; returned, and we should let that determine the truth of the ;; statement. (unless (memq (car test) '(eshell-convert eshell-escape-arg)) (setq test - `(progn ,test + `(progn (eshell-deferrable ,test) (eshell-exit-success-p)))) ;; should we reverse the sense of the test? This depends @@ -578,43 +601,60 @@ function." (string= keyword (cadr names)))) (setq test `(not ,test))) - ;; finally, create the form that represents this structured - ;; command - `(progn - (,func ,test ,body ,else) - (eshell-close-handles))) + ;; Finally, create the form that represents this structured command. + `(,func ,test ,@body)) + +(defun eshell-silence-test-command (terms) + "If TERMS is a subcommand, wrap it in `eshell-commands' to silence output." + (if (memq (car-safe terms) '(eshell-as-subcommand eshell-lisp-command)) + `(eshell-command-success (eshell-commands ,terms t)) + terms)) (defun eshell-rewrite-while-command (terms) "Rewrite a `while' command into its equivalent Eshell command form. Because the implementation of `while' relies upon conditional evaluation of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." - (if (and (stringp (car terms)) - (member (car terms) '("while" "until"))) - (eshell-structure-basic-command - 'while '("while" "until") (car terms) - (eshell-invokify-arg (cadr terms) nil t) - `(eshell-protect - ,(eshell-invokify-arg (car (last terms)) t))))) + (when (and (stringp (car terms)) + (member (car terms) '("while" "until"))) + (unless (cadr terms) + (error "Missing test for `while' command")) + (let ((condition (eshell-silence-test-command (cadr terms)))) + (unless (string= (car terms) "while") + (setq condition `(not ,condition))) + `(while ,condition + ,(caddr terms))))) (defun eshell-rewrite-if-command (terms) "Rewrite an `if' command into its equivalent Eshell command form. Because the implementation of `if' relies upon conditional evaluation of its argument (i.e., use of a Lisp special form), it must be implemented via rewriting, rather than as a function." - (if (and (stringp (car terms)) - (member (car terms) '("if" "unless"))) - (eshell-structure-basic-command - 'if '("if" "unless") (car terms) - (eshell-invokify-arg (cadr terms) nil t) - `(eshell-protect - ,(eshell-invokify-arg (car (last terms (if (= (length terms) 4) 2))) - t)) - (if (= (length terms) 4) - `(eshell-protect - ,(eshell-invokify-arg (car (last terms)) t)))))) - -(defvar eshell-last-command-result) ;Defined in esh-io.el. + (when (and (stringp (car terms)) + (member (car terms) '("if" "unless"))) + (unless (cadr terms) + (error "Missing test for `while' command")) + (let ((condition (eshell-silence-test-command (cadr terms))) + (then (caddr terms)) + (else (if (equal (nth 3 terms) "else") + ;; If there's an "else" keyword, allow chaining + ;; together multiple "if" forms... + (or (eshell-rewrite-if-command (nthcdr 4 terms)) + (nth 4 terms)) + ;; ... otherwise, only allow a single "else" block + ;; (without the keyword) as before for compatibility. + (nth 3 terms)))) + (unless (string= (car terms) "if") + (setq condition `(not ,condition))) + `(if ,condition ,then ,else)))) + +(defun eshell-set-exit-info (status &optional result) + "Set the exit status and result for the last command. +STATUS is the process exit code (zero, if the command completed +successfully). RESULT is the value of the last command." + (when status + (setq eshell-last-command-status status)) + (setq eshell-last-command-result result)) (defun eshell-exit-success-p () "Return non-nil if the last command was successful. @@ -655,10 +695,10 @@ This means an exit code of 0." sep-terms (nreverse sep-terms)) (while results (cl-assert (car sep-terms)) - (setq final (eshell-structure-basic-command - 'if (string= (pop sep-terms) "&&") "if" - `(eshell-protect ,(pop results)) - `(eshell-protect ,final)))) + (setq final `(,(if (string= (pop sep-terms) "&&") 'and 'or) + (eshell-command-success + (eshell-deferrable ,(pop results))) + ,final))) final)) (defun eshell-parse-subcommand-argument () @@ -689,8 +729,7 @@ This means an exit code of 0." (end-of-file (throw 'eshell-incomplete "("))))) (if (eshell-arg-delimiter) - `(eshell-command-to-value - (eshell-lisp-command (quote ,obj))) + `(eshell-lisp-command (quote ,obj)) (ignore (goto-char here)))))) (defun eshell-split-commands (terms separator &optional @@ -743,12 +782,12 @@ if none)." ;; `eshell-do-eval' [Iterative evaluation]: ;; ;; @ Don't use special forms that conditionally evaluate their -;; arguments, such as `let*', unless Eshell explicitly supports -;; them. Eshell supports the following special forms: `catch', -;; `condition-case', `if', `let', `prog1', `progn', `quote', `setq', -;; `unwind-protect', and `while'. +;; arguments, such as `let*', unless Eshell explicitly supports them. +;; Eshell supports the following special forms: `and', `catch', +;; `condition-case', `if', `let', `or', `prog1', `progn', `quote', +;; `setq', `unwind-protect', and `while'. ;; -;; @ The two `special' variables are `eshell-current-handles' and +;; @ The two "special" variables are `eshell-current-handles' and ;; `eshell-current-subjob-p'. Bind them locally with a `let' if you ;; need to change them. Change them directly only if your intention ;; is to change the calling environment. @@ -757,6 +796,28 @@ if none)." ;; that `eshell-do-eval' will evaluated, such as command rewriting ;; hooks (see `eshell-rewrite-command-hook' and friends). +(defmacro eshell-with-handles (handle-args &rest body) + "Create a new set of I/O handles and evaluate BODY. +HANDLE-ARGS is a list of arguments to pass to `eshell-create-handles'. +After evaluating BODY, automatically release the handles, allowing them +to close." + (declare (indent 1)) + `(let ((eshell-current-handles (eshell-create-handles ,@handle-args))) + (unwind-protect + ,(if (length= body 1) (car body) `(progn ,@body)) + (eshell-close-handles)))) + +(defmacro eshell-with-copied-handles (&rest body) + "Copy the current I/O handles and evaluate BODY. +After evaluating BODY, automatically release the handles, allowing them +to close." + (declare (indent 0)) + `(let ((eshell-current-handles + (eshell-duplicate-handles eshell-current-handles))) + (unwind-protect + ,(if (length= body 1) (car body) `(progn ,@body)) + (eshell-close-handles)))) + (defmacro eshell-do-subjob (object) "Evaluate a command OBJECT as a subjob. We indicate that the process was run in the background by @@ -769,14 +830,17 @@ returning it as (:eshell-background . PROCESSES)." (defmacro eshell-commands (object &optional silent) "Place a valid set of handles, and context, around command OBJECT." - `(let ((eshell-current-handles - (eshell-create-handles ,(not silent) 'append)) - eshell-current-subjob-p) - ,object)) + `(let (eshell-current-subjob-p) + (eshell-with-handles (,(not silent) 'append) + ,object))) + +(defmacro eshell-command-success (command) + "Return non-nil if COMMAND exits successfully." + `(progn ,command (eshell-exit-success-p))) (defvar eshell-this-command-hook nil) -(defmacro eshell-trap-errors (object) +(defmacro eshell-do-command (object) "Trap any errors that occur, so they are not entirely fatal. Also, the variable `eshell-this-command-hook' is available for the duration of OBJECT's evaluation. Note that functions should be added @@ -787,50 +851,35 @@ this grossness will be made to disappear by using `call/cc'..." `(eshell-condition-case err (let ((eshell-this-command-hook '(ignore))) (unwind-protect - ,object + (eshell-deferrable ,object) (mapc #'funcall eshell-this-command-hook))) (error (eshell-errorn (error-message-string err)) - (eshell-close-handles 1)))) + (eshell-set-exit-info 1)))) -(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-duplicate-handles eshell-current-handles ,steal-p))) - ,object)) +(define-obsolete-function-alias 'eshell-trap-errors #'eshell-do-command "31.1") + +(defalias 'eshell-deferrable 'identity + "A wrapper to mark a particular form as potentially deferrable. +If the wrapped form returns a process (or list thereof), Eshell will +wait for completion in the background for the process(es) to complete.") (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." + (declare (obsolete nil "31.1")) `(progn (eshell-protect-handles eshell-current-handles) ,object)) -(defun eshell--unmark-deferrable (command) - "If COMMAND is (or ends with) a deferrable command, unmark it as such. -This changes COMMAND in-place by converting function calls listed -in `eshell-deferrable-commands' to their non-deferrable forms so -that Eshell doesn't erroneously allow deferring it. For example, -`eshell-named-command' becomes `eshell-named-command*'." - (let ((cmd command)) - (when (memq (car cmd) '(let progn)) - (setq cmd (car (last cmd)))) - (when (memq (car cmd) eshell-deferrable-commands) - (setcar cmd (intern-soft - (concat (symbol-name (car cmd)) "*")))) - command)) - (defmacro eshell-do-pipelines (pipeline &optional notfirst) "Execute the commands in PIPELINE, connecting each to one another. Returns a list of the processes in the pipeline. This macro calls itself recursively, with NOTFIRST non-nil." (when (setq pipeline (cadr pipeline)) - (eshell--unmark-deferrable (car pipeline)) `(eshell-with-copied-handles (let ((next-procs ,(when (cdr pipeline) @@ -847,9 +896,7 @@ This macro calls itself recursively, with NOTFIRST non-nil." `(eshell-set-output-handle ,eshell-output-handle 'append (car next-procs))) (let ((proc ,(car pipeline))) - (cons proc next-procs))) - ;; Steal handles if this is the last item in the pipeline. - ,(null (cdr pipeline))))) + (cons proc next-procs)))))) (defmacro eshell-do-pipelines-synchronously (pipeline) "Execute the commands in PIPELINE in sequence synchronously. @@ -860,8 +907,6 @@ first command invocation in the pipeline (usually t or nil). This is used on systems where async subprocesses are not supported." (when (setq pipeline (cadr pipeline)) - ;; FIXME: is deferrable significant here? - (eshell--unmark-deferrable (car pipeline)) `(prog1 (eshell-with-copied-handles (progn @@ -873,20 +918,17 @@ supported." ;; meaning for synchronous processes: it's non-nil ;; only when piping *to* a process. (eshell-in-pipeline-p ,(and (cdr pipeline) t))) - ,(car pipeline))) - ;; Steal handles if this is the last item in the pipeline. - ,(null (cdr pipeline))) + ,(car pipeline)))) ,(when (cdr pipeline) `(eshell-do-pipelines-synchronously (quote ,(cdr pipeline))))))) -(defalias 'eshell-process-identity 'identity) +(define-obsolete-function-alias 'eshell-process-identity #'identity "31.1") (defmacro eshell-execute-pipeline (pipeline) "Execute the commands in PIPELINE, connecting each to one another." - `(eshell-process-identity - ,(if eshell-supports-asynchronous-processes - `(remove nil (eshell-do-pipelines ,pipeline)) - `(eshell-do-pipelines-synchronously ,pipeline)))) + (if eshell-supports-asynchronous-processes + `(remove nil (eshell-do-pipelines ,pipeline)) + `(eshell-do-pipelines-synchronously ,pipeline))) (defmacro eshell-as-subcommand (command) "Execute COMMAND as a subcommand. @@ -911,11 +953,19 @@ This avoids the need to use `let*'." (defmacro eshell-command-to-value (command) "Run an Eshell COMMAND synchronously, returning its output." (let ((value (make-symbol "eshell-temp"))) - `(let ((eshell-in-pipeline-p nil) - (eshell-current-handles - (eshell-create-handles ',value 'overwrite))) - ,command - ,value))) + `(eshell-with-handles (',value 'overwrite) + (let ((eshell-in-pipeline-p nil)) + ,command + ,value)))) + +(defun eshell-term-as-value (term) + "Convert an Eshell TERM to take its value." + (cond + ((eq (car-safe term) 'eshell-as-subcommand) ; {x} -> ${x} + `(eshell-convert (eshell-command-to-value ,term))) + ((eq (car-safe term) 'eshell-lisp-command) ; (x) -> $(x) + `(eshell-command-to-value ,term)) + (t term))) ;;;_* Iterative evaluation ;; @@ -951,7 +1001,7 @@ A command can be invoked directly if all of the following are true: * The command is of the form (eshell-with-copied-handles - (eshell-trap-errors (eshell-named-command NAME [ARGS])) _). + (eshell-do-command (eshell-named-command NAME [ARGS]))). * NAME is a string referring to an alias function and isn't a complex command (see `eshell-complex-commands'). @@ -959,8 +1009,7 @@ A command can be invoked directly if all of the following are true: * Any subcommands in ARGS can also be invoked directly." (pcase command (`(eshell-with-copied-handles - (eshell-trap-errors (eshell-named-command ,name . ,args)) - ,_) + (eshell-do-command (eshell-named-command ,name . ,args))) (and name (stringp name) (not (member name eshell-complex-commands)) (catch 'simple @@ -1164,10 +1213,22 @@ have been replaced by constants." (t (caddr args))))) ; Zero or one ELSE forms (unless (consp new-form) - (setq new-form (cons 'progn new-form))) + (setq new-form `(progn ,new-form))) (setcar form (car new-form)) (setcdr form (cdr new-form)))) (eshell-do-eval form synchronous-p)) + ((memq (car form) '(and or)) + (eshell-manipulate form (format-message "evaluating %s form" (car form)) + (let* ((result (eshell-do-eval (car args) synchronous-p)) + (value (cadr result))) + (if (or (null (cdr args)) + (if (eq (car form) 'or) value (not value))) + ;; If this is the last sub-form or we short-circuited, + ;; just return the result. + result + ;; Otherwise, remove this sub-form and re-evaluate. + (setcdr form (cdr args)) + (eshell-do-eval form synchronous-p))))) ((eq (car form) 'setcar) (setcar (cdr args) (eshell-do-eval (cadr args) synchronous-p)) (eval form)) @@ -1303,10 +1364,10 @@ have been replaced by constants." (setcar form (car new-form)) (setcdr form (cdr new-form))) (eshell-do-eval form synchronous-p)) - (if-let (((memq (car form) eshell-deferrable-commands)) - (procs (eshell-make-process-list result))) + (if-let* (((memq (car form) eshell-deferrable-commands)) + (procs (eshell-make-process-list result))) (if synchronous-p - (apply #'eshell/wait procs) + (funcall #'eshell-wait-for-processes procs) (eshell-manipulate form "inserting ignore form" (setcar form 'ignore) (setcdr form nil)) @@ -1327,9 +1388,9 @@ have been replaced by constants." (run-hook-wrapped 'eshell-named-command-hook (lambda (hook) - (when-let (((symbolp hook)) - (which-func (get hook 'eshell-which-function)) - (result (funcall which-func command))) + (when-let* (((symbolp hook)) + (which-func (get hook 'eshell-which-function)) + (result (funcall which-func command))) (throw 'found result)))) (eshell-plain-command--which name))) (error (eshell-error (format "which: %s\n" (cadr error))))))) @@ -1360,7 +1421,8 @@ COMMAND may result in an alias being executed, or a plain command." (eshell-plain-command eshell-last-command-name eshell-last-arguments)))) -(defalias 'eshell-named-command* 'eshell-named-command) +(define-obsolete-function-alias 'eshell-named-command* #'eshell-named-command + "31.1") (defun eshell-find-alias-function (name) "Check whether a function called `eshell/NAME' exists." @@ -1392,7 +1454,7 @@ COMMAND may result in an alias being executed, or a plain command." sym))) (defun eshell-plain-command--which (command) - (if-let ((sym (eshell--find-plain-lisp-command command))) + (if-let* ((sym (eshell--find-plain-lisp-command command))) (or (with-output-to-string (require 'help-fns) (princ (format "%s is " sym)) @@ -1404,7 +1466,7 @@ COMMAND may result in an alias being executed, or a plain command." "Insert output from a plain COMMAND, using ARGS. COMMAND may result in either a Lisp function being executed by name, or an external command." - (if-let ((sym (eshell--find-plain-lisp-command command))) + (if-let* ((sym (eshell--find-plain-lisp-command command))) (eshell-lisp-command sym args) (eshell-external-command command args))) @@ -1429,10 +1491,12 @@ case." ;; command status to some non-zero value to indicate an error; to ;; match GNU/Linux, we use 141, which the numeric value of ;; SIGPIPE on GNU/Linux (13) with the high bit (2^7) set. - (setq eshell-last-command-status 141) + (when (memq eshell-in-pipeline-p '(nil last)) + (eshell-set-exit-info 141)) nil) (error - (setq eshell-last-command-status 1) + (when (memq eshell-in-pipeline-p '(nil last)) + (eshell-set-exit-info 1)) (let ((msg (error-message-string err))) (if (and (not form-p) (string-match "^Wrong number of arguments" msg) @@ -1511,8 +1575,9 @@ a string naming a Lisp function." (unless eshell-allow-commands (signal 'eshell-commands-forbidden '(lisp))) (catch 'eshell-external ; deferred to an external command - (setq eshell-last-command-status 0 - eshell-last-arguments args) + (when (memq eshell-in-pipeline-p '(nil last)) + (eshell-set-exit-info 0)) + (setq eshell-last-arguments args) (let* ((eshell-ensure-newline-p t) (command-form-p (functionp object)) (result @@ -1524,9 +1589,7 @@ a string naming a Lisp function." (while args (let ((arg (car args))) (cond - ((and numeric (stringp arg) (> (length arg) 0) - (text-property-any 0 (length arg) - 'number t arg)) + ((and numeric (eshell--numeric-string-p arg)) ;; If any of the arguments are flagged as ;; numbers waiting for conversion, convert ;; them now. @@ -1547,18 +1610,21 @@ a string naming a Lisp function." (eshell-eval* #'eshell-print-maybe-n #'eshell-error-maybe-n object)))) - (eshell-close-handles - ;; If `eshell-lisp-form-nil-is-failure' is non-nil, Lisp forms - ;; that succeeded but have a nil result should have an exit - ;; status of 2. - (when (and eshell-lisp-form-nil-is-failure - (not command-form-p) - (= eshell-last-command-status 0) - (not result)) - 2) - (list 'quote result))))) - -(defalias 'eshell-lisp-command* #'eshell-lisp-command) + (when (memq eshell-in-pipeline-p '(nil last)) + (eshell-set-exit-info + ;; If `eshell-lisp-form-nil-is-failure' is non-nil, Lisp forms + ;; that succeeded but have a nil result should have an exit + ;; status of 2. + (when (and eshell-lisp-form-nil-is-failure + (not command-form-p) + (= eshell-last-command-status 0) + (not result)) + 2) + result)) + nil))) + +(define-obsolete-function-alias 'eshell-lisp-command* #'eshell-lisp-command + "31.1") (provide 'esh-cmd) diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index 18fd1cdb0ec..5c2b6b8d2ee 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -75,6 +75,7 @@ (require 'cl-lib)) (declare-function eshell-interactive-print "esh-mode" (string)) +(declare-function eshell-term-as-value "esh-cmd" (term)) (defgroup eshell-io nil "Eshell's I/O management code provides a scheme for treating many @@ -200,12 +201,6 @@ describing the mode, e.g. for using with `eshell-get-target'.") (defvar eshell-current-handles nil) -(defvar-local eshell-last-command-status 0 - "The exit code from the last command. 0 if successful.") - -(defvar eshell-last-command-result nil - "The result of the last command. Not related to success.") - (defvar eshell-output-file-buffer nil "If non-nil, the current buffer is a file output buffer.") @@ -307,8 +302,8 @@ describing the mode, e.g. for using with `eshell-get-target'.") (unless (cdr tt) (error "Missing redirection target")) (nconc eshell-current-redirections - (list (list 'ignore - (append (car tt) (list (cadr tt)))))) + `((ignore ,(append (car tt) + (list (eshell-term-as-value (cadr tt))))))) (setcdr tl (cddr tt)) (setq tt (cddr tt))) (t @@ -359,17 +354,17 @@ calling this function)." (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'). +reference count by one. 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." + (declare (advertised-calling-convention (handles) "31.1")) (let ((dup-handles (make-vector eshell-number-of-handles nil))) (dotimes (idx eshell-number-of-handles) - (when-let ((handle (aref handles idx))) + (when-let* ((handle (aref handles idx))) (unless steal-p (cl-incf (cdar handle))) (aset dup-handles idx (list (car handle) t)))) @@ -378,27 +373,31 @@ is not shared with the original handles." (defun eshell-protect-handles (handles) "Protect the handles in HANDLES from a being closed." (dotimes (idx eshell-number-of-handles) - (when-let ((handle (aref handles idx))) + (when-let* ((handle (aref handles idx))) (cl-incf (cdar handle)))) handles) -(defun eshell-close-handles (&optional exit-code result handles) +(declare-function eshell-exit-success-p "esh-cmd") + +(defun eshell-close-handles (&optional handles obsolete-1 obsolete-2) "Close all of the current HANDLES, taking refcounts into account. -If HANDLES is nil, use `eshell-current-handles'. +If HANDLES is nil, use `eshell-current-handles'." + (declare (advertised-calling-convention (&optional handles) "31.1")) + (when (or obsolete-1 obsolete-2 (numberp handles)) + (declare-function eshell-set-exit-info "esh-cmd" + (&optional exit-code result)) + ;; In addition to setting the advertised calling convention, warn + ;; if we get here. A caller may have called with the right number + ;; of arguments but the wrong type. + (display-warning '(eshell close-handles) + "Called `eshell-close-handles' with obsolete arguments") + ;; Here, HANDLES is really the exit code. + (when (or handles obsolete-1) + (eshell-set-exit-info (or handles 0) (cadr obsolete-1))) + (setq handles obsolete-2)) -EXIT-CODE is the process exit code (zero, if the command -completed successfully). If nil, then use the exit code already -set in `eshell-last-command-status'. - -RESULT is the quoted value of the last command. If nil, then use -the value already set in `eshell-last-command-result'." - (when exit-code - (setq eshell-last-command-status exit-code)) - (when result - (cl-assert (eq (car result) 'quote)) - (setq eshell-last-command-result (cadr result))) (let ((handles (or handles eshell-current-handles)) - (succeeded (= eshell-last-command-status 0))) + (succeeded (eshell-exit-success-p))) (dotimes (idx eshell-number-of-handles) (eshell-close-handle (aref handles idx) succeeded)))) @@ -609,7 +608,7 @@ If TARGET is a virtual target (see `eshell-virtual-targets'), return an `eshell-generic-target' instance; otherwise, return a marker for a file named TARGET." (setq mode (or mode 'insert)) - (if-let ((redir (assoc raw-target eshell-virtual-targets))) + (if-let* ((redir (assoc raw-target eshell-virtual-targets))) (let (target) (catch 'eshell-null-device (setq target (if (nth 2 redir) @@ -700,7 +699,7 @@ If status is nil, prompt before killing." (cl-defmethod eshell-close-target ((target eshell-function-target) status) "Close an Eshell function TARGET." - (when-let ((close-function (eshell-function-target-close-function target))) + (when-let* ((close-function (eshell-function-target-close-function target))) (funcall close-function status))) (cl-defgeneric eshell-output-object-to-target (object target) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 34ce82cfbc4..4f94934fccd 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -90,6 +90,10 @@ That is to say, the first time during an Emacs session." :type 'hook) +(defcustom eshell-after-initialize-hook nil + "A hook that gets run after an Eshell session has been fully initialized." + :type 'hook) + (defcustom eshell-exit-hook nil "A hook that is run whenever `eshell' is exited. This hook is only run if exiting actually kills the buffer." @@ -406,7 +410,7 @@ and the hook `eshell-exit-hook'." (when eshell-first-time-p (setq eshell-first-time-p nil) (run-hooks 'eshell-first-time-mode-hook)) - + (run-hooks 'eshell-after-initialize-hook) (run-hooks 'eshell-post-command-hook)) (put 'eshell-mode 'mode-class 'special) @@ -530,11 +534,10 @@ Putting this function on `eshell-pre-command-hook' will mimic Plan 9's (defun eshell-interactive-print (string) "Print STRING to the eshell display buffer." (when string - (eshell--mark-as-output 0 (length string) string) - (eshell-interactive-filter nil string))) + (eshell-interactive-output-filter nil string))) (defsubst eshell-begin-on-new-line () - "This function outputs a newline if not at beginning of line." + "Print a newline if not at beginning of line." (save-excursion (goto-char eshell-last-output-end) (or (bolp) @@ -685,7 +688,7 @@ newline." (custom-add-option 'eshell-input-filter-functions 'eshell-kill-new) (defun eshell-interactive-filter (buffer string) - "Send output (STRING) to the interactive display, using BUFFER. + "Send STRING to the interactive display, using BUFFER. This is done after all necessary filtering has been done." (unless buffer (setq buffer (current-buffer))) @@ -725,6 +728,17 @@ This is done after all necessary filtering has been done." (goto-char opoint) (eshell-run-output-filters)))))) +(defun eshell-interactive-output-filter (buffer string) + "Send STRING to the interactive display as command output, using BUFFER. +This is like `eshell-interactive-filter', but marks the inserted string +as command output (see `eshell--mark-as-output')." + (let ((eshell-output-filter-functions + (cons (lambda () + (eshell--mark-as-output eshell-last-output-start + eshell-last-output-end)) + eshell-output-filter-functions))) + (eshell-interactive-filter buffer string))) + (defun eshell-run-output-filters () "Run the `eshell-output-filter-functions' on the current output." (save-current-buffer @@ -862,20 +876,61 @@ When run interactively, widen the buffer first." (goto-char (point-max)) (recenter -1)) -(defun eshell/clear (&optional scrollback) - "Scroll contents of eshell window out of sight, leaving a blank window. -If SCROLLBACK is non-nil, clear the scrollback contents." +(defun eshell-clear (&optional clear-scrollback) + "Scroll contents of the Eshell window out of sight, leaving a blank window. +If CLEAR-SCROLLBACK is non-nil (interactively, with the prefix +argument), clear the scrollback contents. + +Otherwise, the behavior depends on `eshell-scroll-show-maximum-output'. +If non-nil, fill newlines before the current prompt so that the prompt +is the last line in the window; if nil, just scroll the window so that +the prompt is the first line in the window." + (interactive "P") + (cond + (clear-scrollback + (let ((inhibit-read-only t)) + (widen) + (delete-region (point-min) (eshell-end-of-output)))) + (eshell-scroll-show-maximum-output + (save-excursion + (goto-char (eshell-end-of-output)) + (let ((inhibit-read-only t)) + (insert-and-inherit (make-string (window-size) ?\n)))) + (when (< (point) eshell-last-output-end) + (goto-char eshell-last-output-end))) + (t + (when (< (point) eshell-last-output-end) + (goto-char eshell-last-output-end)) + (set-window-start nil (eshell-end-of-output))))) + +(defun eshell/clear (&optional clear-scrollback) + "Scroll contents of the Eshell window out of sight, leaving a blank window. +If CLEAR-SCROLLBACK is non-nil, clear the scrollback contents. + +Otherwise, the behavior depends on `eshell-scroll-show-maximum-output'. +If non-nil, fill newlines before the current prompt so that the prompt +is the last line in the window; if nil, just scroll the window so that +the prompt is the first line in the window. + +This command is for use as an Eshell command (entered at the prompt); +for clearing the Eshell buffer from elsewhere (e.g. via +\\[execute-extended-command]), use `eshell-clear'." (interactive) - (if scrollback - (eshell/clear-scrollback) + (cond + ((null eshell-current-handles) + (eshell-clear clear-scrollback)) + (clear-scrollback + (let ((inhibit-read-only t)) + (erase-buffer))) + (eshell-scroll-show-maximum-output (let ((eshell-input-filter-functions nil)) - (insert (make-string (window-size) ?\n)) - (eshell-send-input)))) + (ignore (eshell-interactive-print (make-string (window-size) ?\n))))) + (t + (recenter 0)))) (defun eshell/clear-scrollback () - "Clear the scrollback content of the eshell window." - (let ((inhibit-read-only t)) - (erase-buffer))) + "Clear the scrollback content of the Eshell window." + (eshell/clear t)) (defun eshell-get-old-input (&optional use-current-region) "Return the command input on the current line. diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index f3a099885bb..99ac22b2a80 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -25,6 +25,7 @@ (require 'esh-arg) (require 'esh-io) +(require 'esh-opt) (require 'esh-util) (require 'pcomplete) @@ -127,7 +128,8 @@ To add or remove elements of this list, see (declare-function eshell-reset "esh-mode" (&optional no-hooks)) (declare-function eshell-send-eof-to-process "esh-mode") -(declare-function eshell-interactive-filter "esh-mode" (buffer string)) +(declare-function eshell-interactive-output-filter "esh-mode" (buffer string)) +(declare-function eshell-set-exit-info "esh-cmd" (status result)) (declare-function eshell-tail-process "esh-cmd") (defvar-keymap eshell-proc-mode-map @@ -184,16 +186,46 @@ This is like `process-live-p', but additionally checks whether ;; cleared out the handles (see `eshell-sentinel'). (process-get process :eshell-handles))) -(defun eshell-wait-for-process (&rest procs) - "Wait until PROCS have successfully completed." - (dolist (proc procs) - (when (eshell-processp proc) - (while (eshell-process-active-p proc) - (when (input-pending-p) - (discard-input)) - (sit-for eshell-process-wait-time))))) +(defun eshell-wait-for-processes (&optional procs timeout) + "Wait until PROCS have completed execution. +If TIMEOUT is non-nil, wait at most that many seconds. Return non-nil +if all the processes finished executing before the timeout expired." + (let ((expiration (when timeout (time-add (current-time) timeout)))) + (catch 'timeout + (dolist (proc procs) + (while (if (processp proc) + (eshell-process-active-p proc) + (process-attributes proc)) + (when (input-pending-p) + (discard-input)) + (when (and expiration + (not (time-less-p (current-time) expiration))) + (throw 'timeout nil)) + (sit-for eshell-process-wait-time))) + t))) -(defalias 'eshell/wait #'eshell-wait-for-process) +(defun eshell-wait-for-process (&rest procs) + "Wait until PROCS have completed execution." + (declare (obsolete 'eshell-wait-for-processes "31.1")) + (eshell-wait-for-processes procs)) + +(defun eshell/wait (&rest args) + "Wait until processes have completed execution." + (eshell-eval-using-options + "wait" args + '((?h "help" nil nil "show this usage screen") + (?t "timeout" t timeout "timeout in seconds") + :preserve-args + :show-usage + :usage "[OPTION] PROCESS... +Wait until PROCESS(es) have completed execution.") + (when (stringp timeout) + (setq timeout (string-to-number timeout))) + (dolist (arg args) + (unless (or (processp arg) (natnump arg)) + (error "wait: invalid argument type: %s" (type-of arg)))) + (unless (eshell-wait-for-processes args timeout) + (error "wait: timed out after %s seconds" timeout)))) (defun eshell/jobs () "List processes, if there are any." @@ -206,35 +238,34 @@ This is like `process-live-p', but additionally checks whether Usage: kill [-<signal>] <pid>|<process> ... Accepts PIDs and process objects. Optionally accept signals and signal names." - ;; If the first argument starts with a dash, treat it as the signal - ;; specifier. (let ((signum 'SIGINT)) (let ((arg (car args)) (case-fold-search nil)) (when (stringp arg) + ;; If the first argument starts with a dash, treat it as the + ;; signal specifier. (cond ((string-match "\\`-[[:digit:]]+\\'" arg) - (setq signum (abs (string-to-number arg)))) + (setq signum (abs (string-to-number arg))) + (pop args)) ((string-match "\\`-\\([[:upper:]]+\\|[[:lower:]]+\\)\\'" arg) - (setq signum (intern (substring arg 1))))) - (setq args (cdr args)))) - (while args - (let ((arg (if (eshell-processp (car args)) - (process-id (car args)) - (string-to-number (car args))))) - (when arg - (cond - ((null arg) - (error "kill: null pid. Process may actually be a network connection.")) - ((not (numberp arg)) - (error "kill: invalid argument type: %s" (type-of arg))) - ((and (numberp arg) - (<= arg 0)) - (error "kill: bad pid: %d" arg)) - (t - (signal-process arg signum))))) - (setq args (cdr args)))) - nil) + (setq signum (intern (substring arg 1))) + (pop args))))) + (dolist (proc args) + (when (stringp proc) + (setq proc (string-to-number proc))) + (let ((result + (cond + ((numberp proc) + (when (<= proc 0) + (error "kill: bad pid: %d" proc)) + (signal-process proc signum (file-remote-p default-directory))) + ((eshell-processp proc) + (signal-process proc signum)) + (t + (error "kill: invalid argument type: %s" (type-of proc)))))) + (when (= result -1) + (error "kill: failed to kill process %s" proc)))))) (put 'eshell/kill 'eshell-no-numeric-conversions t) @@ -340,6 +371,7 @@ Used only on systems which do not support async subprocesses.") #'eshell-insertion-filter) :sentinel #'eshell-sentinel)) (eshell-record-process-properties stderr-proc eshell-error-handle)) + (eshell-protect-handles eshell-current-handles) (setq proc (let ((command (file-local-name (expand-file-name command))) (conn-type (pcase (bound-and-true-p eshell-in-pipeline-p) @@ -363,6 +395,9 @@ Used only on systems which do not support async subprocesses.") (mapconcat #'shell-quote-argument (process-command proc) " ")) (eshell-record-process-object proc) (eshell-record-process-properties proc) + ;; Don't set exit info for processes being piped elsewhere. + (when (memq (bound-and-true-p eshell-in-pipeline-p) '(nil last)) + (process-put proc :eshell-set-exit-info t)) (when stderr-proc ;; Provide a shared flag between the primary and stderr ;; processes. This lets the primary process wait to clean up @@ -430,10 +465,10 @@ Used only on systems which do not support async subprocesses.") (setq lbeg lend) (set-buffer proc-buf)) (set-buffer oldbuf)) - ;; Simulate the effect of eshell-sentinel. - (eshell-close-handles + ;; Simulate the effect of `eshell-sentinel'. + (eshell-set-exit-info (if (numberp exit-status) exit-status -1) - (list 'quote (and (numberp exit-status) (= exit-status 0)))) + (and (numberp exit-status) (= exit-status 0))) (run-hook-with-args 'eshell-kill-hook command exit-status) (or (bound-and-true-p eshell-in-pipeline-p) (setq eshell-last-sync-output-start nil)) @@ -448,10 +483,9 @@ This is done after all necessary filtering has been done." (when string (eshell-debug-command 'process "received output from process `%s'\n\n%s" process string) - (eshell--mark-as-output 0 (length string) string) - (eshell-interactive-filter (if process (process-buffer process) - (current-buffer)) - string))) + (eshell-interactive-output-filter (if process (process-buffer process) + (current-buffer)) + string))) (define-obsolete-function-alias 'eshell-output-filter #'eshell-interactive-process-filter "30.1") @@ -479,23 +513,28 @@ output." "forwarding output from process `%s'\n\n%s" proc data) (condition-case nil (eshell-output-object data index handles) - ;; FIXME: We want to send SIGPIPE to the process - ;; here. However, remote processes don't currently - ;; support that, and not all systems have SIGPIPE in - ;; the first place (e.g. MS Windows). In these - ;; cases, just kill the process; this is - ;; reasonably close to the right behavior, since the - ;; default action for SIGPIPE is to terminate the - ;; process. For use cases where SIGPIPE is truly - ;; needed, using an external pipe operator (`*|') - ;; may work instead (e.g. when working with remote - ;; processes). (eshell-pipe-broken - (if (or (process-get proc 'remote-pid) - (eq system-type 'windows-nt)) - (kill-process proc) - (signal-process proc 'SIGPIPE)))))) - (process-put proc :eshell-busy nil)))))) + ;; The output pipe broke, so send SIGPIPE to the + ;; process. NOTE: Due to the additional indirection + ;; of Emacs process filters, the process will likely + ;; see the SIGPIPE later than it would in a regular + ;; shell, which could cause problems. For cases + ;; where this matters, using an external pipe + ;; operator (`*|') may work instead. + (cond + ;; Delay signaling remote processes to prevent + ;; "Forbidden reentrant call of Tramp". + ((process-get proc 'remote-pid) + (run-at-time 0 nil #'signal-process proc 'SIGPIPE)) + ;; MS-Windows doesn't support SIGPIPE, so send + ;; SIGTERM there instead; this is reasonably close + ;; to the right behavior, since the default action + ;; for SIGPIPE is to terminate the process. + ((eq system-type 'windows-nt) + (signal-process proc 'SIGTERM)) + (t + (signal-process proc 'SIGPIPE))))))) + (process-put proc :eshell-busy nil)))))) (defun eshell-sentinel (proc string) "Generic sentinel for command processes. Reports only signals. @@ -509,10 +548,8 @@ PROC is the process that's exiting. STRING is the exit message." (let* ((handles (process-get proc :eshell-handles)) (index (process-get proc :eshell-handle-index)) (primary (= index eshell-output-handle)) + (set-exit-info (process-get proc :eshell-set-exit-info)) (data (process-get proc :eshell-pending)) - ;; Only get the status for the primary subprocess, - ;; not the pipe process (if any). - (status (when primary (process-exit-status proc))) (stderr-live (process-get proc :eshell-stderr-live))) ;; Write the exit message for the last process in the ;; foreground pipeline if its status is abnormal and @@ -521,8 +558,7 @@ PROC is the process that's exiting. STRING is the exit message." (eshell-interactive-output-p eshell-error-handle handles) (not (string-match "^\\(finished\\|exited\\)" string))) - (eshell--mark-as-output 0 (length string) string) - (eshell-interactive-filter (process-buffer proc) string)) + (eshell-interactive-output-filter (process-buffer proc) string)) (process-put proc :eshell-pending nil) ;; If we're in the middle of handling output from this ;; process then schedule the EOF for later. @@ -530,32 +566,36 @@ PROC is the process that's exiting. STRING is the exit message." (not (process-live-p proc)))) (finish-io (lambda () - (with-current-buffer (process-buffer proc) - (if (or (process-get proc :eshell-busy) - (and wait-for-stderr (car stderr-live))) - (progn + (if (buffer-live-p (process-buffer proc)) + (with-current-buffer (process-buffer proc) + (if (or (process-get proc :eshell-busy) + (and wait-for-stderr (car stderr-live))) + (progn + (eshell-debug-command 'process + "i/o busy for process `%s'" proc) + (run-at-time 0 nil finish-io)) + (when data + (ignore-error eshell-pipe-broken + (eshell-output-object + data index handles))) + (when set-exit-info + (let ((status (process-exit-status proc))) + (eshell-set-exit-info status (= status 0)))) + (eshell-close-handles handles) + ;; Clear the handles to mark that we're 100% + ;; finished with the I/O for this process. + (process-put proc :eshell-handles nil) (eshell-debug-command 'process - "i/o busy for process `%s'" proc) - (run-at-time 0 nil finish-io)) - (when data - (ignore-error eshell-pipe-broken - (eshell-output-object - data index handles))) - (eshell-close-handles - status - (when status (list 'quote (= status 0))) - handles) - ;; Clear the handles to mark that we're 100% - ;; finished with the I/O for this process. - (process-put proc :eshell-handles nil) - (eshell-debug-command 'process - "finished external process `%s'" proc) - (if primary - (run-hook-with-args 'eshell-kill-hook - proc string) - (setcar stderr-live nil))))))) + "finished external process `%s'" proc) + (if primary + (run-hook-with-args 'eshell-kill-hook + proc string) + (setcar stderr-live nil)))) + (eshell-debug-command 'process + "buffer for external process `%s' already killed" + proc))))) (funcall finish-io))) - (when-let ((entry (assq proc eshell-process-list))) + (when-let* ((entry (assq proc eshell-process-list))) (eshell-remove-process-entry entry)))))) (defun eshell-process-interact (func &optional all query) @@ -617,16 +657,14 @@ long to delay between signals." (defun eshell-round-robin-kill (&optional query) "Kill current process by trying various signals in sequence. See the variable `eshell-kill-processes-on-exit'." - (let ((sigs eshell-kill-process-signals)) - (while sigs + (catch 'done + (dolist (sig eshell-kill-process-signals) (eshell-process-interact - (lambda (proc) - (signal-process (process-id proc) (car sigs))) t query) - (setq query nil) - (if (not eshell-process-list) - (setq sigs nil) - (sleep-for eshell-kill-process-wait-time) - (setq sigs (cdr sigs)))))) + (lambda (proc) (signal-process proc sig)) t query) + (when (eshell-wait-for-processes (mapcar #'car eshell-process-list) + eshell-kill-process-wait-time) + (throw 'done nil)) + (setq query nil)))) (defun eshell-query-kill-processes () "Kill processes belonging to the current Eshell buffer, possibly with query." diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 46083184aaa..57dd1353aab 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -343,15 +343,61 @@ If `eshell-convert-numeric-arguments', always return nil." (concat "\\`\\s-*" eshell-number-regexp "\\s-*\\'") string))) +(defsubst eshell--do-mark-numeric-string (string) + (put-text-property 0 (length string) 'number t string)) + +(defun eshell-mark-numeric-string (string) + "If STRING is convertible to a number, add a text property indicating so. +See `eshell-convertible-to-number-p'." + (when (eshell-convertible-to-number-p string) + (eshell--do-mark-numeric-string string)) + string) + +(defsubst eshell--numeric-string-p (string) + "Return non-nil if STRING has been marked as numeric." + (and (stringp string) + (length> string 0) + (not (text-property-not-all 0 (length string) 'number t string)))) + (defun eshell-convert-to-number (string) "Try to convert STRING to a number. If STRING doesn't look like a number (or `eshell-convert-numeric-arguments' is nil), just return STRING unchanged." + (declare (obsolete 'eshell-mark-numeric-string "31.1")) (if (eshell-convertible-to-number-p string) (string-to-number string) string)) +(cl-defstruct (eshell-range + (:constructor nil) + (:constructor eshell-range-create (begin end))) + "A half-open range from BEGIN to END." + begin end) + +(defsubst eshell--range-string-p (string) + "Return non-nil if STRING has been marked as a range." + (and (stringp string) + (text-property-any 0 (length string) 'eshell-range t string))) + +(defun eshell--string-to-range (string) + "Convert STRING to an `eshell-range' object." + (let* ((startpos (text-property-any 0 (length string) 'eshell-range t string)) + (endpos (next-single-property-change startpos 'eshell-range + string (length string))) + range-begin range-end) + (unless (= startpos 0) + (setq range-begin (substring string 0 startpos)) + (unless (eshell--numeric-string-p range-begin) + (user-error "range begin `%s' is not a number" range-begin)) + (setq range-begin (string-to-number range-begin))) + (unless (= endpos (length string)) + (setq range-end (substring string endpos)) + (unless (eshell--numeric-string-p range-end) + (user-error "range end `%s' is not a number" range-end)) + (setq range-end (string-to-number range-end))) + (eshell-range-create range-begin range-end))) + (defun eshell-convert (string &optional to-string) "Convert STRING into a more-native Lisp object. If TO-STRING is non-nil, always return a single string with @@ -366,7 +412,7 @@ trailing newlines removed. Otherwise, this behaves as follows: (cond ((not (stringp string)) (if to-string - (eshell-stringify string) + (eshell-stringify string t) string)) (to-string (string-trim-right string "\n+")) (t (let ((len (length string))) @@ -376,10 +422,10 @@ trailing newlines removed. Otherwise, this behaves as follows: (setq string (substring string 0 (1- len)))) (if (string-search "\n" string) (let ((lines (split-string string "\n"))) - (if (seq-every-p #'eshell-convertible-to-number-p lines) - (mapcar #'string-to-number lines) - lines)) - (eshell-convert-to-number string))))))) + (when (seq-every-p #'eshell-convertible-to-number-p lines) + (mapc #'eshell--do-mark-numeric-string lines)) + lines) + (eshell-mark-numeric-string string))))))) (defvar-local eshell-path-env (getenv "PATH") "Content of $PATH. @@ -451,7 +497,7 @@ Prepend remote identification of `default-directory', if any." (defun eshell-split-filename (filename) "Split a FILENAME into a list of file/directory components." (let* ((remote (file-remote-p filename)) - (filename (file-local-name filename)) + (filename (or (file-remote-p filename 'localname 'never) filename)) (len (length filename)) (index 0) (curr-start 0) parts) @@ -488,25 +534,27 @@ Prepend remote identification of `default-directory', if any." (define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1") -(defun eshell-stringify (object) +(defun eshell-stringify (object &optional quoted) "Convert OBJECT into a string value." (cond ((stringp object) object) ((numberp object) - (number-to-string object)) + (if quoted + (number-to-string object) + (propertize (number-to-string object) 'number t))) ((and (eq object t) (not eshell-stringify-t)) nil) (t (string-trim-right (pp-to-string object))))) -(defsubst eshell-stringify-list (args) +(defsubst eshell-stringify-list (args &optional quoted) "Convert each element of ARGS into a string value." - (mapcar #'eshell-stringify args)) + (mapcar (lambda (i) (eshell-stringify i quoted)) args)) (defsubst eshell-list-to-string (list) "Convert LIST into a single string separated by spaces." - (mapconcat #'eshell-stringify list " ")) + (mapconcat (lambda (i) (eshell-stringify i t)) list " ")) (defsubst eshell-flatten-and-stringify (&rest args) "Flatten and stringify all of the ARGS into a single string." diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 1b54f1862be..b6bae7a379c 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -495,8 +495,7 @@ process any indices that come after the variable reference." (if splice (setq value `(eshell-list-to-string ,value) splice nil) - (setq value `(eshell-stringify ,value)))) - (setq value `(eshell-escape-arg ,value)) + (setq value `(eshell-stringify ,value t)))) (when splice (setq value `(eshell-splice-args ,value))) value)) @@ -554,24 +553,22 @@ Possible variable references are: (subcmd (or (eshell-unescape-inner-double-quote end) (cons (point) end)))) (prog1 - `(let ((eshell-current-handles - (eshell-create-handles ,temp 'overwrite))) - (progn - (eshell-as-subcommand - ,(let ((eshell-current-quoted nil)) - (eshell-parse-command subcmd))) - (ignore - (nconc eshell-this-command-hook - ;; Quote this lambda; it will be evaluated by - ;; `eshell-do-eval', which requires very - ;; particular forms in order to work - ;; properly. See bug#54190. - (list (function - (lambda () - (delete-file ,temp) - (when-let ((buffer (get-file-buffer ,temp))) - (kill-buffer buffer))))))) - (eshell-apply-indices ,temp indices ,eshell-current-quoted))) + `(eshell-with-handles (,temp 'overwrite) + (eshell-as-subcommand + ,(let ((eshell-current-quoted nil)) + (eshell-parse-command subcmd))) + (ignore + (nconc eshell-this-command-hook + ;; Quote this lambda; it will be evaluated by + ;; `eshell-do-eval', which requires very + ;; particular forms in order to work + ;; properly. See bug#54190. + (list (function + (lambda () + (delete-file ,temp) + (when-let* ((buffer (get-file-buffer ,temp))) + (kill-buffer buffer))))))) + (eshell-apply-indices ,temp indices ,eshell-current-quoted)) (goto-char (1+ end)))))) ((eq (char-after) ?\() (condition-case nil @@ -589,11 +586,11 @@ Possible variable references are: (or (eshell-unescape-inner-double-quote (point-max)) (cons (point) (point-max))) (let (name) - (when-let ((delim - (catch 'eshell-incomplete - (ignore (setq name (if (eq (char-after) ?\') - (eshell-parse-literal-quote) - (eshell-parse-double-quote))))))) + (when-let* ((delim + (catch 'eshell-incomplete + (ignore (setq name (if (eq (char-after) ?\') + (eshell-parse-literal-quote) + (eshell-parse-double-quote))))))) (throw 'eshell-incomplete (concat "$" delim))) (when name `(eshell-get-variable ,(eval name) indices ,eshell-current-quoted))))) @@ -609,8 +606,6 @@ Possible variable references are: (t (error "Invalid variable reference")))) -(defvar eshell-glob-function) - (defun eshell-parse-indices () "Parse and return a list of index-lists. This produces a series of Lisp forms to be processed by @@ -627,7 +622,7 @@ For example, \"[0 1][2]\" becomes: (forward-char) (eshell-with-temp-command (or (eshell-unescape-inner-double-quote end) (cons (point) end)) - (let (eshell-glob-function (eshell-current-quoted nil)) + (let ((eshell-current-quoted nil)) (setq indices (cons (eshell-parse-arguments (point-min) (point-max)) indices)))) @@ -645,24 +640,13 @@ in the cons is nil. Otherwise (including if INDEX is not a string), return the original value of INDEX." - (save-match-data - (cond - ((and (stringp index) (get-text-property 0 'number index)) - (string-to-number index)) - ((and (stringp index) - (not (text-property-any 0 (length index) 'escaped t index)) - (string-match (rx string-start - (group-n 1 (? (regexp eshell-integer-regexp))) - ".." - (group-n 2 (? (regexp eshell-integer-regexp))) - string-end) - index)) - (let ((begin (match-string 1 index)) - (end (match-string 2 index))) - (cons (unless (string-empty-p begin) (string-to-number begin)) - (unless (string-empty-p end) (string-to-number end))))) - (t - index)))) + (cond + ((eshell--numeric-string-p index) + (string-to-number index)) + ((eshell--range-string-p index) + (eshell--string-to-range index)) + (t + index))) (defun eshell-eval-indices (indices) "Evaluate INDICES, a list of index-lists generated by `eshell-parse-indices'." @@ -672,13 +656,15 @@ the original value of INDEX." (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))) + `(list ,@(mapcar (lambda (idx-list) + (cons 'list (mapcar #'eshell-term-as-value 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'). If QUOTED is non-nil, this was invoked inside double-quotes." - (if-let ((alias (assoc name eshell-variable-aliases-list))) + (if-let* ((alias (assoc name eshell-variable-aliases-list))) (let ((target (nth 1 alias))) (when (and (not (functionp target)) (consp target)) @@ -717,7 +703,7 @@ If QUOTED is non-nil, this was invoked inside double-quotes." NAME can be a string (in which case it refers to an environment variable or variable alias) or a symbol (in which case it refers to a Lisp variable)." - (if-let ((alias (assoc name eshell-variable-aliases-list))) + (if-let* ((alias (assoc name eshell-variable-aliases-list))) (let ((target (nth 1 alias))) (cond ((functionp target) @@ -765,11 +751,10 @@ Otherwise, each INT-OR-NAME refers to an element of the list value. Integers imply a direct index, and names, an associate lookup using `assoc'. -If QUOTED is non-nil, this was invoked inside double-quotes. -This affects the behavior of splitting strings: without quoting, -the split values are converted to numbers via -`eshell-convert-to-number' if possible; with quoting, they're -left as strings. +If QUOTED is non-nil, this was invoked inside double-quotes. This +affects the behavior of splitting strings: without quoting, the split +values are marked as numbers via `eshell-mark-numeric-string' if +possible; with quoting, they're left as plain strings. For example, to retrieve the second element of a user's record in '/etc/passwd', the variable reference would look like: @@ -785,7 +770,7 @@ For example, to retrieve the second element of a user's record in refs (cdr refs))) (setq value (split-string value separator)) (unless quoted - (setq value (mapcar #'eshell-convert-to-number value))))) + (setq value (mapcar #'eshell-mark-numeric-string value))))) (cond ((< (length refs) 0) (error "Invalid array variable index: %s" @@ -798,14 +783,6 @@ For example, to retrieve the second element of a user's record in (push (eshell-index-value value ref) new-value)) (setq value (nreverse new-value))))))) -(pcase-defmacro eshell-index-range (start end) - "A pattern that matches an Eshell index range. -EXPVAL should be a cons cell, with each slot containing either an -integer or nil. If this matches, bind the values of the sltos to -START and END." - (list '\` (cons (list '\, `(and (or (pred integerp) (pred null)) ,start)) - (list '\, `(and (or (pred integerp) (pred null)) ,end))))) - (defun eshell-index-value (value index) "Reference VALUE using the given INDEX." (let ((parsed-index (eshell-parse-index index))) @@ -813,15 +790,17 @@ START and END." (pcase parsed-index ((pred integerp) (ring-ref value parsed-index)) - ((eshell-index-range start end) + ((pred eshell-range-p) (let* ((len (ring-length value)) - (real-start (mod (or start 0) len)) + (begin (eshell-range-begin parsed-index)) + (end (eshell-range-end parsed-index)) + (real-begin (mod (or begin 0) len)) (real-end (mod (or end len) len))) (when (and (eq real-end 0) (not (eq end 0))) (setq real-end len)) (ring-convert-sequence-to-ring - (seq-subseq (ring-elements value) real-start real-end)))) + (seq-subseq (ring-elements value) real-begin real-end)))) (_ (error "Invalid index for ring: %s" index))) (pcase parsed-index @@ -829,8 +808,9 @@ START and END." (when (< parsed-index 0) (setq parsed-index (+ parsed-index (length value)))) (seq-elt value parsed-index)) - ((eshell-index-range start end) - (seq-subseq value (or start 0) end)) + ((pred eshell-range-p) + (seq-subseq value (or (eshell-range-begin parsed-index) 0) + (eshell-range-end parsed-index))) (_ ;; INDEX is some non-integer value, so treat VALUE as an alist. (cdr (assoc parsed-index value))))))) @@ -842,10 +822,10 @@ START and END." (let ((arg (pcomplete-actual-arg))) (when (string-match (rx "$" (? (or "#" "@")) - (? (or (group-n 1 (regexp eshell-variable-name-regexp) - string-end) - (seq (group-n 2 (or "'" "\"")) - (group-n 1 (+ anychar)))))) + (or (group-n 1 (? (regexp eshell-variable-name-regexp)) + string-end) + (seq (group-n 2 (or "'" "\"")) + (group-n 1 (+ anychar))))) arg) (setq pcomplete-stub (substring arg (match-beginning 1))) (let ((delimiter (match-string 2 arg))) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 43f6930c80b..3def918bdd1 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -176,7 +176,7 @@ (require 'cl-lib)) (require 'esh-util) (require 'esh-module) ;For eshell-using-module -(require 'esh-proc) ;For eshell-wait-for-process +(require 'esh-proc) ;For eshell-wait-for-processes (require 'esh-io) ;For eshell-last-command-status (require 'esh-cmd) @@ -216,6 +216,34 @@ named \"*eshell*<2>\"." :type 'string :group 'eshell) +(defcustom eshell-command-async-buffer 'confirm-new-buffer + "What to do when the output buffer is used by another shell command. +This option specifies how to resolve the conflict where a new command +wants to direct its output to the buffer whose name is stored +in `eshell-command-buffer-name-async', but that buffer is already +taken by another running shell command. + +The value `confirm-kill-process' is used to ask for confirmation before +killing the already running process and running a new process in the +same buffer, `confirm-new-buffer' for confirmation before running the +command in a new buffer with a name other than the default buffer name, +`new-buffer' for doing the same without confirmation, +`confirm-rename-buffer' for confirmation before renaming the existing +output buffer and running a new command in the default buffer, +`rename-buffer' for doing the same without confirmation." + :type '(choice (const :tag "Confirm killing of running command" + confirm-kill-process) + (const :tag "Confirm creation of a new buffer" + confirm-new-buffer) + (const :tag "Create a new buffer" + new-buffer) + (const :tag "Confirm renaming of existing buffer" + confirm-rename-buffer) + (const :tag "Rename the existing buffer" + rename-buffer)) + :group 'eshell + :version "31.1") + ;;;_* Running Eshell ;; ;; There are only three commands used to invoke Eshell. The first two @@ -250,8 +278,8 @@ information on Eshell, see Info node `(eshell)Top'." (t (get-buffer-create eshell-buffer-name))))) (cl-assert (and buf (buffer-live-p buf))) - (with-suppressed-warnings ((obsolete display-comint-buffer-action)) - (pop-to-buffer buf display-comint-buffer-action)) + (pop-to-buffer buf (append display-buffer--same-window-action + '((category . comint)))) (unless (derived-mode-p 'eshell-mode) (eshell-mode)) buf)) @@ -295,44 +323,88 @@ information on Eshell, see Info node `(eshell)Top'." (eshell-command-mode +1)) (read-from-minibuffer prompt)))) +(defvar eshell-command-buffer-name-async "*Eshell Async Command Output*") +(defvar eshell-command-buffer-name-sync "*Eshell Command Output*") + ;;;###autoload -(defun eshell-command (command &optional to-current-buffer) +(defun eshell-command (command &optional output-target error-target) "Execute the Eshell command string COMMAND. -If TO-CURRENT-BUFFER is non-nil (interactively, with the prefix -argument), then insert output into the current buffer at point." +If OUTPUT-TARGET is t (interactively, with the prefix argument), write +the command's standard output to the current buffer at point. If nil, +write the output to a new output buffer. For any other value, output to +that Eshell target (see `eshell-get-target'). + +ERROR-TARGET is similar to OUTPUT-TARGET, except that it controls where +to write standard error, and a nil value means to write standard error +to the same place as standard output. (To suppress standard error, you +can write to the Eshell virtual target \"/dev/null\".) + +When \"&\" is added at end of command, the command is async and its +output appears in a specific buffer. You can customize +`eshell-command-async-buffer' to specify what to do when this output +buffer is already taken by another running shell command." (interactive (list (eshell-read-command) - current-prefix-arg)) + (not (not current-prefix-arg)))) (save-excursion - (let ((stdout (if to-current-buffer (current-buffer) t)) + (let ((stdout (cond ((eq output-target t) (current-buffer)) + ((not output-target) t) + (t output-target))) + (stderr (if (eq error-target t) (current-buffer) error-target)) (buf (set-buffer (generate-new-buffer " *eshell cmd*"))) (eshell-non-interactive-p t)) (eshell-mode) (let* ((proc (eshell-eval-command - `(let ((eshell-current-handles - (eshell-create-handles ,stdout 'insert)) - (eshell-current-subjob-p)) - ,(eshell-parse-command command)) + `(eshell-with-handles (',stdout 'insert ',stderr 'insert) + (let ((eshell-current-subjob-p)) + ,(eshell-parse-command command))) command)) - intr - (bufname (if (eq (car-safe proc) :eshell-background) - "*Eshell Async Command Output*" - (setq intr t) - "*Eshell Command Output*"))) - (if (buffer-live-p (get-buffer bufname)) - (kill-buffer bufname)) - (rename-buffer bufname) + (async (eq (car-safe proc) :eshell-background)) + (bufname (cond + ((not (eq stdout t)) nil) + (async eshell-command-buffer-name-async) + (t eshell-command-buffer-name-sync))) + unique) + (when bufname + (when (buffer-live-p (get-buffer bufname)) + (cond + ((with-current-buffer bufname + (and (null eshell-foreground-command) + (null eshell-background-commands))) + ;; The old buffer is done executing; kill it so we can + ;; take its place. + (kill-buffer bufname)) + ((eq eshell-command-async-buffer 'confirm-kill-process) + (shell-command--same-buffer-confirm "Kill it") + (with-current-buffer bufname + ;; Stop all the processes in the old buffer (there may + ;; be several). + (eshell-round-robin-kill)) + (kill-buffer bufname)) + ((eq eshell-command-async-buffer 'confirm-new-buffer) + (shell-command--same-buffer-confirm "Use a new buffer") + (setq unique t)) + ((eq eshell-command-async-buffer 'new-buffer) + (setq unique t)) + ((eq eshell-command-async-buffer 'confirm-rename-buffer) + (shell-command--same-buffer-confirm "Rename it") + (with-current-buffer bufname + (rename-uniquely))) + ((eq eshell-command-async-buffer 'rename-buffer) + (with-current-buffer bufname + (rename-uniquely))))) + (rename-buffer bufname unique)) ;; things get a little coarse here, since the desire is to ;; make the output as attractive as possible, with no ;; extraneous newlines - (when intr - (apply #'eshell-wait-for-process (cadr eshell-foreground-command)) + (unless async + (funcall #'eshell-wait-for-processes (cadr eshell-foreground-command)) (cl-assert (not eshell-foreground-command)) (goto-char (point-max)) (while (and (bolp) (not (bobp))) (delete-char -1))) (cl-assert (and buf (buffer-live-p buf))) - (unless to-current-buffer - (let ((len (if (not intr) 2 + (unless bufname + (let ((len (if async 2 (count-lines (point-min) (point-max))))) (cond ((= len 0) @@ -348,7 +420,7 @@ argument), then insert output into the current buffer at point." ;; cause the output buffer to take up as little screen ;; real-estate as possible, if temp buffer resizing is ;; enabled - (and intr temp-buffer-resize-mode + (and (not async) temp-buffer-resize-mode (resize-temp-buffer-window))))))))))) ;;;###autoload diff --git a/lisp/faces.el b/lisp/faces.el index c3a54a08a3d..f8ec0f1a187 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -100,7 +100,7 @@ a font height that isn't optimal." ;; which are generally available. (defcustom face-font-family-alternatives (mapcar (lambda (arg) (mapcar 'purecopy arg)) - '(("Monospace" "courier" "fixed") + '(("Monospace" "Cascadia Code" "Lucida Console" "courier" "fixed") ;; Monospace Serif is an Emacs invention, intended to work around ;; portability problems when using Courier. It should work well @@ -133,7 +133,10 @@ a font height that isn't optimal." ;; This is present for backward compatibility. ("courier" "CMU Typewriter Text" "fixed") - ("Sans Serif" "helv" "helvetica" "arial" "fixed") + ("Sans Serif" + ;; https://en.wikipedia.org/wiki/List_of_typefaces_included_with_Microsoft_Windows + "Calibri" "Tahoma" "Lucida Sans Unicode" + "helv" "helvetica" "arial" "fixed") ("helv" "helvetica" "arial" "fixed"))) "Alist of alternative font family names. Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...). @@ -2094,7 +2097,7 @@ do that, use `get-text-property' and `get-char-property'." (let (faces) (when text ;; Try to get a face name from the buffer. - (when-let ((face (thing-at-point 'face))) + (when-let* ((face (thing-at-point 'face))) (push face faces))) ;; Add the named faces that the `read-face-name' or `face' property uses. (let ((faceprop (or (get-char-property (point) 'read-face-name) @@ -2818,6 +2821,21 @@ Use the face `mode-line-highlight' for features that can be selected." :version "28.1" :group 'basic-faces) +(defface header-line-active + '((t :inherit header-line)) + "Face for the selected header line. +This inherits from the `header-line' face." + :version "31.1" + :group 'mode-line-faces + :group 'basic-faces) + +(defface header-line-inactive + '((t :inherit header-line)) + "Basic header line face for non-selected windows." + :version "31.1" + :group 'mode-line-faces + :group 'basic-faces) + (defface vertical-border '((((type tty)) :inherit mode-line-inactive)) "Face used for vertical window dividers on ttys." diff --git a/lisp/ffap.el b/lisp/ffap.el index e431aeed8b1..6a4915fb5a3 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -805,7 +805,7 @@ to extract substrings.") (declare-function project-root "project" (project)) (defun ffap-in-project (name) - (when-let (project (project-current)) + (when-let* ((project (project-current))) (file-name-concat (project-root project) name))) (defun ffap-home (name) (ffap-locate-file name t '("~"))) diff --git a/lisp/filenotify.el b/lisp/filenotify.el index 4e289d564c9..89711e6ca8a 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -76,7 +76,7 @@ struct.") "Remove DESCRIPTOR from `file-notify-descriptors'. DESCRIPTOR should be an object returned by `file-notify-add-watch'. If it is registered in `file-notify-descriptors', a `stopped' event is sent." - (when-let ((watch (gethash descriptor file-notify-descriptors))) + (when-let* ((watch (gethash descriptor file-notify-descriptors))) (unwind-protect ;; Send `stopped' event. (file-notify-handle-event diff --git a/lisp/files-x.el b/lisp/files-x.el index 5f8c1e9aec2..24a14144a69 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -560,7 +560,7 @@ Returns the filename, expanded." (read-file-name "File: " (cond (dir) - ((when-let ((proj (and (featurep 'project) (project-current)))) + ((when-let* ((proj (and (featurep 'project) (project-current)))) (project-root proj)))) nil (lambda (fname) @@ -792,8 +792,8 @@ whose elements are of the form (VAR . VALUE). Unlike `connection-local-set-profile-variables' (which see), this function preserves the values of any existing variable definitions that aren't listed in VARIABLES." - (when-let ((existing-variables - (nreverse (connection-local-get-profile-variables profile)))) + (when-let* ((existing-variables + (nreverse (connection-local-get-profile-variables profile)))) (dolist (var variables) (setf (alist-get (car var) existing-variables) (cdr var))) (setq variables (nreverse existing-variables))) @@ -967,7 +967,7 @@ value is the default binding of the variable." (if (not criteria) ,variable (hack-connection-local-variables criteria) - (if-let ((result (assq ',variable connection-local-variables-alist))) + (if-let* ((result (assq ',variable connection-local-variables-alist))) (cdr result) ,variable)))) diff --git a/lisp/files.el b/lisp/files.el index 63a08ce5b22..a65bc4a4ea2 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -144,8 +144,8 @@ the default for a new file created there by you. This variable is relevant only if `backup-by-copying' is nil." :version "24.1" :type 'boolean + :local 'permanent-only :group 'backup) -(put 'backup-by-copying-when-mismatch 'permanent-local t) (defcustom backup-by-copying-when-privileged-mismatch 200 "Non-nil means create backups by copying to preserve a privileged owner. @@ -178,9 +178,8 @@ use `kill-buffer-query-functions'." :type '(choice (const :tag "Never" nil) (const :tag "On Emacs exit" t) (const :tag "Whenever save-some-buffers is called" always)) + :local 'permanent :group 'backup) -(make-variable-buffer-local 'buffer-offer-save) -(put 'buffer-offer-save 'permanent-local t) (defcustom find-file-existing-other-name t "Non-nil means find a file under alternative names, in existing buffers. @@ -1300,15 +1299,17 @@ NOERROR is equal to `reload'), or otherwise emit a warning." (lh nil) ;We loaded the right file. ((eq noerror 'reload) (load fn nil 'nomessage)) ((and fn (memq feature features)) - (funcall (if noerror #'warn #'error) - "Feature `%S' is now provided by a different file %s" - feature fn)) + (let ((oldfile (symbol-file feature 'provide))) + (funcall (if noerror #'warn #'error) + "Feature `%S' loaded from %S is now provided by %S" + feature (if oldfile (abbreviate-file-name oldfile)) + (abbreviate-file-name fn)))) (fn (funcall (if noerror #'warn #'error) - "Could not load file %s" fn)) + "Could not load file: %s" fn)) (t (funcall (if noerror #'warn #'error) - "Could not locate file %s in load path" + "Could not locate file in load path: %s" (or filename (symbol-name feature))))))) res)) @@ -1356,7 +1357,7 @@ Tip: You can use this expansion of remote identifier components returns a remote file name for file \"/bin/sh\" that has the same remote identifier as FILE but expanded; a name such as \"/sudo:root@myhost:/bin/sh\"." - (when-let ((handler (find-file-name-handler file 'file-remote-p))) + (when-let* ((handler (find-file-name-handler file 'file-remote-p))) (funcall handler 'file-remote-p file identification connected))) ;; Probably this entire variable should be obsolete now, in favor of @@ -2212,7 +2213,7 @@ if you want to permanently change your home directory after having started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; Get rid of the prefixes added by the automounter. (save-match-data ;FIXME: Why? - (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if-let* ((handler (find-file-name-handler filename 'abbreviate-file-name))) (funcall handler 'abbreviate-file-name filename) ;; Avoid treating /home/foo as /home/Foo during `~' substitution. (let ((case-fold-search (file-name-case-insensitive-p filename))) @@ -3015,6 +3016,9 @@ since only a single case-insensitive search through the alist is made." ("\\.scm\\.[0-9]*\\'" . scheme-mode) ("\\.[ckz]?sh\\'\\|\\.shar\\'\\|/\\.z?profile\\'" . sh-mode) ("\\.bash\\'" . sh-mode) + ;; Bash builtin 'fc' creates a temp file named "bash-fc.XXXXXX" + ;; to edit shell commands from its history list. + ("/bash-fc\\.[0-9A-Za-z]\\{6\\}\\'" . sh-mode) ("/PKGBUILD\\'" . sh-mode) ("\\(/\\|\\`\\)\\.\\(bash_\\(profile\\|history\\|log\\(in\\|out\\)\\)\\|z?log\\(in\\|out\\)\\)\\'" . sh-mode) ("\\(/\\|\\`\\)\\.\\(shrc\\|zshrc\\|m?kshrc\\|bashrc\\|t?cshrc\\|esrc\\)\\'" . sh-mode) @@ -3048,8 +3052,6 @@ since only a single case-insensitive search through the alist is made." ;; Anyway, the following extensions are supported by gfortran. ("\\.f9[05]\\'" . f90-mode) ("\\.f0[38]\\'" . f90-mode) - ("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode - ("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode) ("\\.srt\\'" . srecode-template-mode) ("\\.prolog\\'" . prolog-mode) ("\\.tar\\'" . tar-mode) @@ -3544,7 +3546,7 @@ we don't actually set it to the same mode the buffer already has." ;; If we didn't, look for an interpreter specified in the first line. ;; As a special case, allow for things like "#!/bin/env perl", which ;; finds the interpreter anywhere in $PATH. - (when-let + (when-let* ((interp (save-excursion (goto-char (point-min)) (if (looking-at auto-mode-interpreter-regexp) @@ -3619,7 +3621,10 @@ instead. FUNCTION is typically a major mode which \"does the same thing\" as MODE, but can also be nil to hide other entries (either in this var or in `major-mode-remap-defaults') and means that we should call MODE." - :type '(alist (symbol) (function))) + :type '(alist + :tag "Remappings" + :key-type (symbol :tag "From major mode") + :value-type (function :tag "To mode (or function)"))) (defvar major-mode-remap-defaults nil "Alist mapping file-specified modes to alternative modes. @@ -4173,7 +4178,7 @@ all the specified local variables, but ignores any settings of \"mode:\"." ;; Handle `lexical-binding' and other special local ;; variables. (dolist (variable permanently-enabled-local-variables) - (when-let ((elem (assq variable result))) + (when-let* ((elem (assq variable result))) (push elem file-local-variables-alist))) (hack-local-variables-apply)))))) @@ -4431,12 +4436,13 @@ already the major mode." (pcase var ('mode (let ((mode (intern (concat (downcase (symbol-name val)) - "-mode")))) + "-mode")))) (set-auto-mode-0 mode t))) ('eval (pcase val (`(add-hook ',hook . ,_) (hack-one-local-variable--obsolete hook))) - (save-excursion (eval val t))) + (let ((enable-local-variables nil)) ;FIXME: Should be buffer-local! + (save-excursion (eval val t)))) (_ (hack-one-local-variable--obsolete var) ;; Make sure the string has no text properties. @@ -4482,6 +4488,21 @@ Returns the new list." ;; Need a new cons in case we setcdr later. (push (cons variable value) variables))))) +(defun dir-locals--load-mode-if-needed (key alist) + ;; If KEY is an extra parent it may remain not loaded + ;; (hence with some of its mode-specific vars missing their + ;; `safe-local-variable' property), leading to spurious + ;; prompts about unsafe vars (bug#68246). + (when (and (symbolp key) (autoloadp (indirect-function key))) + (let ((unsafe nil)) + (pcase-dolist (`(,var . ,_val) alist) + (unless (or (memq var '(mode eval)) + (get var 'safe-local-variable)) + (setq unsafe t))) + (when unsafe + (ignore-errors + (autoload-do-load (indirect-function key))))))) + (defun dir-locals-collect-variables (class-variables root variables &optional predicate) "Collect entries from CLASS-VARIABLES into VARIABLES. @@ -4512,15 +4533,9 @@ to see whether it should be considered." (funcall predicate key) (or (not key) (derived-mode-p key))) - ;; If KEY is an extra parent it may remain not loaded - ;; (hence with some of its mode-specific vars missing their - ;; `safe-local-variable' property), leading to spurious - ;; prompts about unsafe vars (bug#68246). - (if (and (symbolp key) (autoloadp (indirect-function key))) - (ignore-errors (autoload-do-load (indirect-function key)))) (let* ((alist (cdr entry)) (subdirs (assq 'subdirs alist))) - (if (or (not subdirs) + (when (or (not subdirs) (progn (setq alist (remq subdirs alist)) (cdr-safe subdirs)) @@ -4529,6 +4544,7 @@ to see whether it should be considered." ;; variables apply to this directory and N levels ;; below it (0 == nil). (equal root (expand-file-name default-directory))) + (dir-locals--load-mode-if-needed key alist) (setq variables (dir-locals-collect-mode-variables alist variables)))))))) (error @@ -6164,7 +6180,13 @@ Before and after saving the buffer, this function runs (defvar save-some-buffers--switch-window-callback nil) (defvar save-some-buffers-action-alist - `((?\C-r + `((?\M-~ ,(lambda (buf) + (with-current-buffer buf + (set-buffer-modified-p nil)) + ;; Return t so we don't ask about BUF again. + t) + ,(purecopy "skip this buffer and mark it unmodified")) + (?\C-r ,(lambda (buf) (if (not enable-recursive-minibuffers) (progn (display-buffer buf) @@ -6271,7 +6293,8 @@ in variables (rather than in buffers).") (defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. -You can answer \\`y' or \\`SPC' to save, \\`n' or \\`DEL' not to save, \\`C-r' +You can answer \\`y' or \\`SPC' to save, \\`n' or \\`DEL' not to save, +\\`M-~' not to save and also mark the buffer as unmodified, \\`C-r' to look at the buffer in question with `view-buffer' before deciding, \\`d' to view the differences using `diff-buffer-with-file', \\`!' to save the buffer and all remaining @@ -6944,8 +6967,8 @@ buffer read-only, or keeping minor modes, etc.") (defun revert-buffer-restore-read-only () "Preserve read-only state for `revert-buffer'." - (when-let ((state (and (boundp 'read-only-mode--state) - (list read-only-mode--state)))) + (when-let* ((state (and (boundp 'read-only-mode--state) + (list read-only-mode--state)))) (lambda () (setq buffer-read-only (car state)) (setq-local read-only-mode--state (car state))))) @@ -8496,7 +8519,8 @@ If RESTART, restart Emacs after killing the current Emacs process." ;; Query the user for other things, perhaps. (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) - (funcall confirm "Really exit Emacs? ")) + (funcall confirm (format "Really %s Emacs? " + (if restart "restart" "exit")))) (kill-emacs nil restart)))) (defun save-buffers-kill-terminal (&optional arg) diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 5b4ee0d70aa..13c8bf722c3 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -431,9 +431,9 @@ specifies what to use in place of \"-ls\" as the final argument." "Sort entries in *Find* buffer by file name lexicographically." (sort-subr nil 'forward-line 'end-of-line (lambda () - (when-let ((start - (next-single-property-change - (point) 'dired-filename))) + (when-let* ((start + (next-single-property-change + (point) 'dired-filename))) (buffer-substring-no-properties start (line-end-position)))))) diff --git a/lisp/find-file.el b/lisp/find-file.el index 23e0c12ad2c..65e980d38fc 100644 --- a/lisp/find-file.el +++ b/lisp/find-file.el @@ -130,37 +130,45 @@ (defcustom ff-pre-find-hook nil "List of functions to be called before the search for the file starts." - :type 'hook) + :type 'hook + :local t) (defcustom ff-pre-load-hook nil "List of functions to be called before the other file is loaded." - :type 'hook) + :type 'hook + :local t) (defcustom ff-post-load-hook nil "List of functions to be called after the other file is loaded." - :type 'hook) + :type 'hook + :local t) (defcustom ff-not-found-hook nil "List of functions to be called if the other file could not be found." - :type 'hook) + :type 'hook + :local t) (defcustom ff-file-created-hook nil "List of functions to be called if the other file needs to be created." - :type 'hook) + :type 'hook + :local t) (defcustom ff-case-fold-search nil "Non-nil means ignore cases in matches (see `case-fold-search'). If you have extensions in different cases, you will want this to be nil." - :type 'boolean) + :type 'boolean + :local t) (defcustom ff-always-in-other-window nil "If non-nil, find the corresponding file in another window by default. To override this, give an argument to `ff-find-other-file'." - :type 'boolean) + :type 'boolean + :local t) (defcustom ff-ignore-include nil "If non-nil, ignore `#include' lines." - :type 'boolean) + :type 'boolean + :local t) (defcustom ff-always-try-to-create t "If non-nil, always attempt to create the other file if it was not found." @@ -168,7 +176,8 @@ To override this, give an argument to `ff-find-other-file'." (defcustom ff-quiet-mode nil "If non-nil, do not trace which directories are being searched." - :type 'boolean) + :type 'boolean + :local t) ;;;###autoload (defcustom ff-special-constructs @@ -220,7 +229,8 @@ function must return a non-nil list of file-names. It cannot return nil, nor can it signal in any way a failure to find a suitable list of file names." :type '(choice (repeat (list regexp (choice (repeat string) function))) - symbol)) + symbol) + :local t) (defcustom ff-search-directories 'cc-search-directories "List of directories to search for a specific file. @@ -243,7 +253,8 @@ not exist, it is replaced (silently) with an empty string. The stars are *not* wildcards: they are searched for together with the preceding slash. The star represents all the subdirectories except `..', and each of these subdirectories will be searched in turn." - :type '(choice (repeat directory) symbol)) + :type '(choice (repeat directory) symbol) + :local t) (defcustom cc-search-directories '("." "/usr/include" "/usr/local/include/*") @@ -294,17 +305,6 @@ is created with the first matching extension (`.cc' yields `.hh')." ;; No user definable variables beyond this point! ;; ============================================== -(make-variable-buffer-local 'ff-pre-find-hook) -(make-variable-buffer-local 'ff-pre-load-hook) -(make-variable-buffer-local 'ff-post-load-hook) -(make-variable-buffer-local 'ff-not-found-hook) -(make-variable-buffer-local 'ff-file-created-hook) -(make-variable-buffer-local 'ff-case-fold-search) -(make-variable-buffer-local 'ff-always-in-other-window) -(make-variable-buffer-local 'ff-ignore-include) -(make-variable-buffer-local 'ff-quiet-mode) -(make-variable-buffer-local 'ff-other-file-alist) -(make-variable-buffer-local 'ff-search-directories) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User entry points diff --git a/lisp/finder.el b/lisp/finder.el index 1cf607c03c0..167c2079954 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -71,8 +71,7 @@ (text . "editing text files") (tools . "programming tools") (unix . "UNIX feature interfaces and emulators") - (vc . "version control") - (wp . "use keyword `text' instead; this keyword is obsolete")) + (vc . "version control")) "Association list of the standard \"Keywords:\" headers. Each element has the form (KEYWORD . DESCRIPTION).") diff --git a/lisp/foldout.el b/lisp/foldout.el index 5799318fc6f..a4b6a402c5c 100644 --- a/lisp/foldout.el +++ b/lisp/foldout.el @@ -490,6 +490,21 @@ Signal an error if the event didn't occur on a heading." (error "Not a heading line"))) +(defun foldout-widen-to-current-fold () + "Widen to the current fold level. +If in a fold, widen to that fold's boundaries. +If not in a fold, acts like `widen'." + (interactive) + (if foldout-fold-list + (let* ((last-fold (car foldout-fold-list)) + (start (car last-fold)) + (end (cdr last-fold))) + (widen) + (narrow-to-region start + (if end (1- (marker-position end)) (point-max)))) + (widen))) + + ;;; Keymaps: (defvar foldout-inhibit-key-bindings nil diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 7b077a826bf..d2232f72c55 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1846,11 +1846,11 @@ See `font-lock-ignore' for the possible rules." (defun font-lock--filter-keywords (keywords) "Filter a list of KEYWORDS using `font-lock-ignore'." - (if-let ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) - (when (or (and (boundp mode) mode) - (derived-mode-p mode)) - (copy-sequence rules))) - font-lock-ignore))) + (if-let* ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) + (when (or (and (boundp mode) mode) + (derived-mode-p mode)) + (copy-sequence rules))) + font-lock-ignore))) (seq-filter (lambda (keyword) (not (font-lock--match-keyword `(or ,@rules) keyword))) keywords) diff --git a/lisp/format.el b/lisp/format.el index 34bd30e83a5..fc44436874b 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -90,9 +90,9 @@ ;; FROM-FN used to call the "diac" command which is not widely ;; available and apparently not under a free software license: ;; https://nm.wu-wien.ac.at/nm/download/file/diac4.tar.gz - ;; Reliable round-trip conversion is not possible anyway - ;; and would be by heuristic method, so use nil for now. - nil iso-iso2duden t nil) + ;; Reliable round-trip conversion is not possible anyway and + ;; would be by heuristic method, so make it write-only for now. + iso-cvt-write-only iso-iso2duden t nil) (de646 ,(purecopy "German ASCII (ISO 646)") nil ,(purecopy "iconv -f iso646-de -t utf-8") diff --git a/lisp/frame.el b/lisp/frame.el index 64f0d054df8..1b5aa8cff08 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -115,6 +115,74 @@ appended when the minibuffer frame is created." (sexp :tag "Value"))) :group 'frames) +(defun frame-deletable-p (&optional frame) + "Return non-nil if specified FRAME can be safely deleted. +FRAME must be a live frame and defaults to the selected frame. + +FRAME cannot be safely deleted in the following cases: + +- FRAME is the only visible or iconified frame. + +- FRAME hosts the active minibuffer window that does not follow the + selected frame. + +- All other visible or iconified frames are either child frames or have + a non-nil `delete-before' parameter. + +- FRAME or one of its descendants hosts the minibuffer window of a frame + that is not a descendant of FRAME. + +This covers most cases where `delete-frame' might fail when called from +top-level. It does not catch some special cases like, for example, +deleting a frame during a drag-and-drop operation. In any such case, it +will be better to wrap the `delete-frame' call in a `condition-case' +form." + (setq frame (window-normalize-frame frame)) + (let ((active-minibuffer-window (active-minibuffer-window)) + deletable) + (catch 'deletable + (when (and active-minibuffer-window + (eq (window-frame active-minibuffer-window) frame) + (not (eq (default-toplevel-value + 'minibuffer-follows-selected-frame) + t))) + (setq deletable nil) + (throw 'deletable nil)) + + (let ((frames (delq frame (frame-list)))) + (dolist (other frames) + ;; A suitable "other" frame must be either visible or + ;; iconified. Child frames and frames with a non-nil + ;; 'delete-before' parameter do not qualify as other frame - + ;; either of these will depend on a "suitable" frame found in + ;; this loop. + (unless (or (frame-parent other) + (frame-parameter other 'delete-before) + (not (frame-visible-p other))) + (setq deletable t)) + + ;; Some frame not descending from FRAME may use the minibuffer + ;; window of FRAME or the minibuffer window of a frame + ;; descending from FRAME. + (when (let* ((minibuffer-window (minibuffer-window other)) + (minibuffer-frame + (and minibuffer-window + (window-frame minibuffer-window)))) + (and minibuffer-frame + ;; If the other frame is a descendant of + ;; FRAME, it will be deleted together with + ;; FRAME ... + (not (frame-ancestor-p frame other)) + ;; ... but otherwise the other frame must + ;; neither use FRAME nor any descendant of + ;; it as minibuffer frame. + (or (eq minibuffer-frame frame) + (frame-ancestor-p frame minibuffer-frame)))) + (setq deletable nil) + (throw 'deletable nil)))) + + deletable))) + (defun handle-delete-frame (event) "Handle delete-frame events from the X server." (interactive "e") diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el index 02744a7f0a5..39ae6809a55 100644 --- a/lisp/gnus/canlock.el +++ b/lisp/gnus/canlock.el @@ -41,8 +41,6 @@ ;;; Code: -(require 'sha1) - (defvar mail-header-separator) (defgroup canlock nil diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 5151ad1c1b8..8243e4e632b 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2419,8 +2419,8 @@ fill width." (defun article-emojize-symbols () "Display symbols (that have an emoji version) as emojis." (interactive nil gnus-article-mode) - (when-let ((font (and (display-multi-font-p) - (car (internal-char-font nil ?😀))))) + (when-let* ((font (and (display-multi-font-p) + (car (internal-char-font nil ?😀))))) (save-excursion (let ((inhibit-read-only t)) (goto-char (point-min)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 71bfaa639fa..788de46efda 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3852,6 +3852,7 @@ If given numerical prefix, toggle the N next groups." (gnus-group-next-group 1)) (defun gnus-group-toggle-subscription (group &optional silent) + "Prompt for group, and toggle its subscription." (interactive (list (gnus-group-completing-read nil nil (gnus-read-active-file-p))) gnus-group-mode) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index af7284b88e8..0d0827b3890 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -309,7 +309,7 @@ status will be retrieved from the first matching attendee record." ;;; gnus-icalendar-event-reply ;;; -(defun gnus-icalendar-event--build-reply-event-body (ical-request status identities) +(defun gnus-icalendar-event--build-reply-event-body (ical-request status identities &optional comment) (let ((summary-status (capitalize (symbol-name status))) (attendee-status (upcase (symbol-name status))) reply-event-lines) @@ -319,6 +319,10 @@ status will be retrieved from the first matching attendee record." (if (string-match "^[^:]+:" line) (replace-match (format "\\&%s: " summary-status) t nil line) line)) + (update-comment + (line) + (if comment (format "COMMENT:%s" comment) + line)) (update-dtstamp () (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t)) (attendee-matches-identity @@ -341,6 +345,7 @@ status will be retrieved from the first matching attendee record." (cond ((string= key "ATTENDEE") (update-attendee-status line)) ((string= key "SUMMARY") (update-summary line)) + ((string= key "COMMENT") (update-comment line)) ((string= key "DTSTAMP") (update-dtstamp)) ((member key '("ORGANIZER" "DTSTART" "DTEND" "LOCATION" "DURATION" "SEQUENCE" @@ -363,16 +368,27 @@ status will be retrieved from the first matching attendee record." attendee-status user-full-name user-mail-address) reply-event-lines)) + ;; add comment line if not existing + (when (and comment + (not (gnus-icalendar-find-if + (lambda (x) + (string-match "^COMMENT" x)) + reply-event-lines))) + (push (format "COMMENT:%s" comment) reply-event-lines)) + (mapconcat #'identity `("BEGIN:VEVENT" ,@(nreverse reply-event-lines) "END:VEVENT") "\n")))) -(defun gnus-icalendar-event-reply-from-buffer (buf status identities) +(defun gnus-icalendar-event-reply-from-buffer (buf status identities &optional comment) "Build a calendar event reply for request contained in BUF. The reply will have STATUS (`accepted', `tentative' or `declined'). The reply will be composed for attendees matching any entry -on the IDENTITIES list." +on the IDENTITIES list. +Optional argument COMMENT will be placed in the comment field of the +reply. +" (cl-labels ((extract-block (blockname) @@ -396,7 +412,7 @@ on the IDENTITIES list." "PRODID:Gnus" "VERSION:2.0" zone - (gnus-icalendar-event--build-reply-event-body event status identities) + (gnus-icalendar-event--build-reply-event-body event status identities comment) "END:VCALENDAR"))) (mapconcat #'identity (delq nil contents) "\n")))))) @@ -878,13 +894,13 @@ These will be used to retrieve the RSVP information from ical events." (insert "Subject: " subject) (message-send-and-exit)))) -(defun gnus-icalendar-reply (data) +(defun gnus-icalendar-reply (data &optional comment) (let* ((handle (car data)) (status (cadr data)) (event (caddr data)) (reply (gnus-icalendar-with-decoded-handle handle (gnus-icalendar-event-reply-from-buffer - (current-buffer) status (gnus-icalendar-identities)))) + (current-buffer) status (gnus-icalendar-identities) comment))) (organizer (gnus-icalendar-event:organizer event))) (when reply @@ -1009,25 +1025,37 @@ These will be used to retrieve the RSVP information from ical events." (when data (gnus-icalendar-save-part data)))) -(defun gnus-icalendar-reply-accept () - "Accept invitation in the current article." - (interactive nil gnus-article-mode gnus-summary-mode) +(defun gnus-icalendar-reply-accept (&optional comment-p) + "Accept invitation in the current article. + +Optional argument COMMENT-P non-nil (interactively `\\[universal-argument]') +means prompt for a comment to include in the reply." + (interactive "P" gnus-article-mode gnus-summary-mode) (with-current-buffer gnus-article-buffer - (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event)) + (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event) + (when comment-p (read-string "Comment: "))) (setq-local gnus-icalendar-reply-status 'accepted))) -(defun gnus-icalendar-reply-tentative () - "Send tentative response to invitation in the current article." - (interactive nil gnus-article-mode gnus-summary-mode) +(defun gnus-icalendar-reply-tentative (&optional comment-p) + "Send tentative response to invitation in the current article. + +Optional argument COMMENT-P non-nil (interactively `\\[universal-argument]') +means prompt for a comment to include in the reply." + (interactive "P" gnus-article-mode gnus-summary-mode) (with-current-buffer gnus-article-buffer - (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event)) + (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event) + (when comment-p (read-string "Comment: "))) (setq-local gnus-icalendar-reply-status 'tentative))) -(defun gnus-icalendar-reply-decline () - "Decline invitation in the current article." - (interactive nil gnus-article-mode gnus-summary-mode) +(defun gnus-icalendar-reply-decline (&optional comment-p) + "Decline invitation in the current article. + +Optional argument COMMENT-P non-nil (interactively `\\[universal-argument]') +means prompt for a comment to include in the reply." + (interactive "P" gnus-article-mode gnus-summary-mode) (with-current-buffer gnus-article-buffer - (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event)) + (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event) + (when comment-p (read-string "Comment: "))) (setq-local gnus-icalendar-reply-status 'declined))) (defun gnus-icalendar-event-export () diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index 558ad8648ca..b73fa268da2 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -357,7 +357,7 @@ If it is down, start it up (again)." (funcall (gnus-get-function gnus-command-method 'close-server) (nth 1 gnus-command-method) (nthcdr 2 gnus-command-method)) - (when-let ((elem (assoc gnus-command-method gnus-opened-servers))) + (when-let* ((elem (assoc gnus-command-method gnus-opened-servers))) (setf (nth 1 elem) 'closed))))) (defun gnus-request-list (command-method) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index c25163ac770..ca82546ef82 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -1012,7 +1012,7 @@ Responsible for handling and, or, and parenthetical expressions.") (let (clauses) (mapc (lambda (item) - (when-let ((expr (gnus-search-transform-expression engine item))) + (when-let* ((expr (gnus-search-transform-expression engine item))) (push expr clauses))) query) (mapconcat #'identity (reverse clauses) " "))) @@ -1486,7 +1486,7 @@ Returns a list of [group article score] vectors." (push (list f-name article group score) artlist))))) ;; Are we running an additional grep query? - (when-let ((grep-reg (alist-get 'grep query))) + (when-let* ((grep-reg (alist-get 'grep query))) (setq artlist (gnus-search-grep-search engine artlist grep-reg))) (when (>= gnus-verbose 7) @@ -1717,9 +1717,9 @@ cross our fingers for the rest of it." (let (clauses) (mapc (lambda (item) - (when-let ((expr (if (consp (car-safe item)) - (gnus-search-transform engine item) - (gnus-search-transform-expression engine item)))) + (when-let* ((expr (if (consp (car-safe item)) + (gnus-search-transform engine item) + (gnus-search-transform-expression engine item)))) (push expr clauses))) query) (mapconcat #'identity (reverse clauses) " "))) @@ -2141,8 +2141,8 @@ remaining string, then adds all that to the top-level spec." (assoc-string srv gnus-search-engine-instance-alist t)) (nth 1 engine-config) (cdr-safe (assoc (car method) gnus-search-default-engines)) - (when-let ((old (assoc 'nnir-search-engine - (cddr method)))) + (when-let* ((old (assoc 'nnir-search-engine + (cddr method)))) (nnheader-message 8 "\"nnir-search-engine\" is no longer a valid parameter") (nth 1 old)))) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a9caa83b15c..cebeb6d4c37 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -8501,7 +8501,7 @@ with MARKS. MARKS can either be a string of marks or a list of marks. Returns how many articles were removed." (interactive (list - (completing-read "Marks:" + (completing-read "Marks: " (let ((mark-list '())) (mapc (lambda (datum) (cl-pushnew (gnus-data-mark datum) mark-list)) @@ -8518,7 +8518,7 @@ list of marks. Returns how many articles were removed." (interactive (list - (completing-read "Marks:" + (completing-read "Marks: " (let ((mark-list '())) (mapc (lambda (datum) (cl-pushnew (gnus-data-mark datum) mark-list)) @@ -9374,9 +9374,9 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (let ((pt (point)) urls primary) (while (forward-button 1 nil nil t) (setq pt (point)) - (when-let ((w (button-at pt)) - (u (or (button-get w 'shr-url) - (get-text-property pt 'gnus-string)))) + (when-let* ((w (button-at pt)) + (u (or (button-get w 'shr-url) + (get-text-property pt 'gnus-string)))) (when (string-match-p "\\`[[:alpha:]]+://" u) (if (and gnus-collect-urls-primary-text (null primary) (string= gnus-collect-urls-primary-text (button-label w))) @@ -9404,7 +9404,7 @@ See `gnus-collect-urls'." (let* ((parsed (url-generic-parse-url url)) (host (url-host parsed)) (rest (concat (url-filename parsed) - (when-let ((target (url-target parsed))) + (when-let* ((target (url-target parsed))) (concat "#" target))))) (concat host (string-truncate-left rest (- max (length host))))))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index f1fc129a505..62a090bd9df 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -3119,9 +3119,9 @@ g -- Group name." "Check whether GROUP supports function FUNC. GROUP can either be a string (a group name) or a select method." (ignore-errors - (when-let ((method (if (stringp group) - (car (gnus-find-method-for-group group)) - group))) + (when-let* ((method (if (stringp group) + (car (gnus-find-method-for-group group)) + group))) (unless (featurep method) (require method)) (fboundp (intern (format "%s-%s" method func)))))) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index fdafc29f7e8..64685490ab0 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -954,9 +954,8 @@ See the Gnus manual for details." ;; Since idle timers created when Emacs is already in the idle ;; state don't get activated until Emacs _next_ becomes idle, we ;; need to force our timer to be considered active now. We do - ;; this by being naughty and poking the timer internals directly - ;; (element 0 of the vector is nil if the timer is active). - (aset mail-source-report-new-mail-idle-timer 0 nil))) + ;; this by being naughty and poking the timer internals directly. + (setf (timer--triggered mail-source-report-new-mail-idle-timer) nil))) (declare-function display-time-event-handler "time" ()) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 6e9a7e8f72a..c504742b0fe 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -4904,7 +4904,7 @@ If you always want Gnus to send messages in one piece, set message-required-mail-headers)) ;; otherwise, delete the MFT header if the field is empty (when (equal "" (mail-fetch-field "mail-followup-to")) - (message-remove-header "^Mail-Followup-To:"))) + (message-remove-header "Mail-Followup-To"))) ;; Insert some headers. (let ((message-deletable-headers (if news nil message-deletable-headers))) @@ -4938,8 +4938,8 @@ If you always want Gnus to send messages in one piece, set (let ((addr (message-fetch-field hdr))) (when (stringp addr) (dolist (address (mail-header-parse-addresses addr t)) - (when-let ((warning (textsec-suspicious-p - address 'email-address-header))) + (when-let* ((warning (textsec-suspicious-p + address 'email-address-header))) (unless (y-or-n-p (format "Suspicious address: %s; send anyway?" warning)) @@ -8616,7 +8616,6 @@ From headers in the original article." (let ((regexps (if (stringp message-hidden-headers) (list message-hidden-headers) message-hidden-headers)) - (inhibit-modification-hooks t) end-of-headers) (when regexps (save-excursion diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index 3c7e3cbdf1a..26b2c03a3dc 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -173,7 +173,7 @@ This can be either \"inline\" or \"attachment\".") ,#'mm-uu-diff-test) (git-format-patch "^diff --git " - "^-- " + "^$" ,#'mm-uu-diff-extract nil ,#'mm-uu-diff-test) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 8ecf7a33305..70cefe5bb49 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -507,7 +507,7 @@ type detected." (when (and (consp (car cont)) (= (length cont) 1) content-type) - (when-let ((spec (assq 'type (cdr (car cont))))) + (when-let* ((spec (assq 'type (cdr (car cont))))) (setcdr spec content-type))) (when (fboundp 'libxml-parse-html-region) (setq cont (mapcar #'mml-expand-all-html-into-multipart-related cont))) @@ -943,7 +943,7 @@ type detected." (when parameters (let ((cont (copy-sequence cont))) ;; Set the file name to what's specified by the user. - (when-let ((recipient-filename (cdr (assq 'recipient-filename cont)))) + (when-let* ((recipient-filename (cdr (assq 'recipient-filename cont)))) (setcdr cont (cons (cons 'filename recipient-filename) (cdr cont)))) diff --git a/lisp/gnus/nnatom.el b/lisp/gnus/nnatom.el index f6885abb634..a9f6b9179de 100644 --- a/lisp/gnus/nnatom.el +++ b/lisp/gnus/nnatom.el @@ -56,12 +56,12 @@ (insert-file-contents feed) (mm-url-insert-file-contents (concat "https://" feed))) (file-error (nnheader-report nnatom-backend (cdr e))) - (:success (when-let ((data (if (libxml-available-p) - (libxml-parse-xml-region - (point-min) (point-max)) - (car (xml-parse-region - (point-min) (point-max))))) - (authors (list 'authors))) + (:success (when-let* ((data (if (libxml-available-p) + (libxml-parse-xml-region + (point-min) (point-max)) + (car (xml-parse-region + (point-min) (point-max))))) + (authors (list 'authors))) (when (eq (car data) 'top) (setq data (assq 'feed data))) (dom-add-child-before data authors) @@ -93,8 +93,8 @@ (when (eq (car data) 'feed) (setq data (dom-children data))) ;; Discard any children between/after entries. (while (and data (not (eq (car-safe (car data)) 'entry))) (pop data)) - (when-let ((article (car data)) - (auths (list 'authors)) (links (list 'links))) + (when-let* ((article (car data)) + (auths (list 'authors)) (links (list 'links))) (dom-add-child-before article links) (dom-add-child-before article auths) (dolist (child (cddddr article) `(,article . ,(cdr data))) @@ -126,7 +126,7 @@ (defun nnatom--read-article-or-group-authors (article-or-group) "Return the authors of ARTICLE-OR-GROUP, or nil." - (when-let + (when-let* ((a (mapconcat (lambda (author) (let* ((name (nnatom--dom-line (dom-child-by-tag author 'name))) @@ -161,14 +161,14 @@ return the subject. Otherwise, return nil." (defun nnatom--read-publish (article) "Return the date and time ARTICLE was published, or nil." - (when-let (d (dom-child-by-tag article 'published)) + (when-let* ((d (dom-child-by-tag article 'published))) (date-to-time (nnatom--dom-line d)))) (defvoo nnatom-read-publish-date-function #'nnatom--read-publish nil nnfeed-read-publish-date-function) (defun nnatom--read-update (article) "Return the date and time of the last update to ARTICLE, or nil." - (when-let (d (dom-child-by-tag article 'updated)) + (when-let* ((d (dom-child-by-tag article 'updated))) (date-to-time (nnatom--dom-line d)))) (defvoo nnatom-read-update-date-function #'nnatom--read-update nil nnfeed-read-update-date-function) @@ -178,56 +178,56 @@ return the subject. Otherwise, return nil." (let ((alt 0) (rel 0) (sel 0) (enc 0) (via 0) (aut 0)) (mapcan (lambda (link) - (when-let ((l (car-safe link))) + (when-let* ((l (car-safe link))) (or - (when-let (((eq l 'content)) - (src (dom-attr link 'src)) - (label (concat "Link" - (and (< 1 (cl-incf alt)) - (format " %s" alt))))) + (when-let* (((eq l 'content)) + (src (dom-attr link 'src)) + (label (concat "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt))))) `(((("text/plain") . ,(format "%s: %s\n" label src)) (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " src label))))) - (when-let (((or (eq l 'author) (eq l 'contributor))) - (name (nnatom--dom-line (dom-child-by-tag link 'name))) - (name (if (string-blank-p name) - (concat "Author" - (and (< 1 (cl-incf aut)) - (format " %s" aut))) - name)) - (uri (nnatom--dom-line (dom-child-by-tag link 'uri))) - ((not (string-blank-p uri)))) + (when-let* (((or (eq l 'author) (eq l 'contributor))) + (name (nnatom--dom-line (dom-child-by-tag link 'name))) + (name (if (string-blank-p name) + (concat "Author" + (and (< 1 (cl-incf aut)) + (format " %s" aut))) + name)) + (uri (nnatom--dom-line (dom-child-by-tag link 'uri))) + ((not (string-blank-p uri)))) `(((("text/plain") . ,(format "%s: %s\n" name uri)) (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " uri name))))) - (when-let (((eq l 'link)) - (attrs (dom-attributes link)) - (label (or (cdr (assq 'title attrs)) - (pcase (cdr (assq 'rel attrs)) - ("related" - (concat "Related" - (and (< 1 (cl-incf rel)) - (format " %s" rel)))) - ("self" - (concat "More" - (and (< 1 (cl-incf sel)) - (format " %s" sel)))) - ("enclosure" - (concat "Enclosure" - (and (< 1 (cl-incf enc)) - (format " %s" enc)))) - ("via" - (concat "Source" - (and (< 1 (cl-incf via)) - (format " %s" via)))) - (_ (if-let - ((lang (cdr (assq 'hreflang link)))) - (format "Link (%s)" lang) - (concat - "Link" - (and (< 1 (cl-incf alt)) - (format " %s" alt)))))))) - (link (cdr (assq 'href attrs)))) + (when-let* (((eq l 'link)) + (attrs (dom-attributes link)) + (label (or (cdr (assq 'title attrs)) + (pcase (cdr (assq 'rel attrs)) + ("related" + (concat "Related" + (and (< 1 (cl-incf rel)) + (format " %s" rel)))) + ("self" + (concat "More" + (and (< 1 (cl-incf sel)) + (format " %s" sel)))) + ("enclosure" + (concat "Enclosure" + (and (< 1 (cl-incf enc)) + (format " %s" enc)))) + ("via" + (concat "Source" + (and (< 1 (cl-incf via)) + (format " %s" via)))) + (_ (if-let* + ((lang (cdr (assq 'hreflang link)))) + (format "Link (%s)" lang) + (concat + "Link" + (and (< 1 (cl-incf alt)) + (format " %s" alt)))))))) + (link (cdr (assq 'href attrs)))) `(((("text/plain") . ,(format "%s: %s\n" label link)) (("text/html") . ,(format "<a href=\"%s\">[%s]</a> " link label)))))))) diff --git a/lisp/gnus/nnfeed.el b/lisp/gnus/nnfeed.el index 2d33d4c813b..e8c1fdb8e2b 100644 --- a/lisp/gnus/nnfeed.el +++ b/lisp/gnus/nnfeed.el @@ -277,8 +277,8 @@ group names to their data, which should be a vector of the form (defun nnfeed--read-server (server) "Read SERVER's information from storage." - (if-let ((f (nnfeed--server-file server)) - ((file-readable-p f))) + (if-let* ((f (nnfeed--server-file server)) + ((file-readable-p f))) (with-temp-buffer (insert-file-contents f) (goto-char (point-min)) @@ -287,10 +287,10 @@ group names to their data, which should be a vector of the form (defun nnfeed--write-server (server) "Write SERVER's information to storage." - (if-let ((f (nnfeed--server-file server)) - ((file-writable-p f))) - (if-let ((s (gethash server nnfeed-servers)) - ((hash-table-p s))) + (if-let* ((f (nnfeed--server-file server)) + ((file-writable-p f))) + (if-let* ((s (gethash server nnfeed-servers)) + ((hash-table-p s))) (with-temp-file f (insert ";;;; -*- mode: lisp-data -*- DO NOT EDIT\n") (prin1 s (current-buffer)) @@ -346,8 +346,8 @@ If GROUP is omitted or nil, parse the entire FEED." (and desc (aset g 5 desc)) (while-let ((article (funcall nnfeed-read-article-function cg stale)) (article (prog1 (car article) (setq cg (cdr article))))) - (when-let ((id (funcall nnfeed-read-id-function article)) - (id (format "<%s@%s.%s>" id name nnfeed-backend))) + (when-let* ((id (funcall nnfeed-read-id-function article)) + (id (format "<%s@%s.%s>" id name nnfeed-backend))) (let* ((num (gethash id ids)) (update (funcall nnfeed-read-update-date-function article)) (prev-update (aref (gethash num articles @@ -423,14 +423,14 @@ Each value in this table should be a vector of the form (defun nnfeed--group-data (group server) "Get parsed data for GROUP from SERVER." - (when-let ((server (nnfeed--server-address server)) - (s (gethash server nnfeed-servers)) - ((hash-table-p s))) + (when-let* ((server (nnfeed--server-address server)) + (s (gethash server nnfeed-servers)) + ((hash-table-p s))) (gethash group s))) (defun nnfeed-retrieve-article (article group) "Retrieve headers for ARTICLE from GROUP." - (if-let ((a (gethash article (aref group 2)))) + (if-let* ((a (gethash article (aref group 2)))) (insert (format "221 %s Article retrieved. From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" article @@ -441,10 +441,10 @@ From: %s\nSubject: %s\nDate: %s\nMessage-ID: %s\n.\n" (insert "404 Article not found.\n.\n"))) (deffoo nnfeed-retrieve-headers (articles &optional group server _fetch-old) - (if-let ((server (or server (nnfeed--current-server-no-prefix))) - (g (or (nnfeed--group-data group server) - `[ nil ,nnfeed-group-article-ids ,nnfeed-group-articles - nil nil nil]))) + (if-let* ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + `[ nil ,nnfeed-group-article-ids ,nnfeed-group-articles + nil nil nil]))) (with-current-buffer nntp-server-buffer (erase-buffer) (or (and (stringp (car articles)) @@ -513,27 +513,27 @@ by `nnfeed-read-parts-function'), and links (as returned by Only HEADERS of a type included in MIME are considered." (concat (mapconcat (lambda (header) - (when-let ((m (car-safe header)) - ((member m mime))) + (when-let* ((m (car-safe header)) + ((member m mime))) (format "%s: %s\n" m (cdr header)))) headers) "\n" (funcall nnfeed-print-content-function content headers links))) (deffoo nnfeed-request-article (article &optional group server to-buffer) - (if-let ((server (or server (nnfeed--current-server-no-prefix))) - (g (or (nnfeed--group-data group server) - (and (setq group nnfeed-group) - `[ nil ,nnfeed-group-article-ids - ,nnfeed-group-articles - ,nnfeed-group-article-max-num - ,nnfeed-group-article-min-num nil]))) - (num (or (and (stringp article) - (gethash article (aref g 1))) - (and (numberp article) article))) - ((and (<= num (aref g 3)) - (>= num (aref g 4)))) - (a (gethash num (aref g 2)))) + (if-let* ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (nnfeed--group-data group server) + (and (setq group nnfeed-group) + `[ nil ,nnfeed-group-article-ids + ,nnfeed-group-articles + ,nnfeed-group-article-max-num + ,nnfeed-group-article-min-num nil]))) + (num (or (and (stringp article) + (gethash article (aref g 1))) + (and (numberp article) article))) + ((and (<= num (aref g 3)) + (>= num (aref g 4)))) + (a (gethash num (aref g 2)))) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) (let* ((links (aref a 5)) @@ -575,12 +575,12 @@ Only HEADERS of a type included in MIME are considered." (deffoo nnfeed-request-group (group &optional server fast _info) (with-current-buffer nntp-server-buffer (erase-buffer) - (if-let ((server (or server (nnfeed--current-server-no-prefix))) - (g (or (if fast (nnfeed--group-data group server) - (setq server (nnfeed--parse-feed server group)) - (and (hash-table-p server) (gethash group server))) - `[ ,group ,(make-hash-table :test 'equal) - ,(make-hash-table :test 'eql) 0 1 ""]))) + (if-let* ((server (or server (nnfeed--current-server-no-prefix))) + (g (or (if fast (nnfeed--group-data group server) + (setq server (nnfeed--parse-feed server group)) + (and (hash-table-p server) (gethash group server))) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) 0 1 ""]))) (progn (setq nnfeed-group group nnfeed-group-article-ids (aref g 1) @@ -608,10 +608,10 @@ Only HEADERS of a type included in MIME are considered." (deffoo nnfeed-request-list (&optional server) (with-current-buffer nntp-server-buffer (erase-buffer) - (when-let ((p (point)) - (s (nnfeed--parse-feed - (or server (nnfeed--current-server-no-prefix)))) - ((hash-table-p s))) + (when-let* ((p (point)) + (s (nnfeed--parse-feed + (or server (nnfeed--current-server-no-prefix)))) + ((hash-table-p s))) (maphash (lambda (group g) (insert (format "\"%s\" %s %s y\n" group (aref g 3) (aref g 4)))) @@ -634,12 +634,12 @@ Only HEADERS of a type included in MIME are considered." ;; separates the group name from the description with either a tab or a space. (defun nnfeed--group-description (name group) "Return a description line for a GROUP called NAME." - (when-let ((desc (aref group 5)) - ((not (string-blank-p desc)))) + (when-let* ((desc (aref group 5)) + ((not (string-blank-p desc)))) (insert name "\t" desc "\n"))) (deffoo nnfeed-request-group-description (group &optional server) - (when-let ((server (or server (nnfeed--current-server-no-prefix))) + (when-let* ((server (or server (nnfeed--current-server-no-prefix))) (g (nnfeed--group-data group server))) (with-current-buffer nntp-server-buffer (erase-buffer) @@ -647,38 +647,38 @@ Only HEADERS of a type included in MIME are considered." t))) (deffoo nnfeed-request-list-newsgroups (&optional server) - (when-let ((server (or server (nnfeed--current-server-no-prefix))) - (s (gethash (nnfeed--server-address server) nnfeed-servers)) - ((hash-table-p s))) + (when-let* ((server (or server (nnfeed--current-server-no-prefix))) + (s (gethash (nnfeed--server-address server) nnfeed-servers)) + ((hash-table-p s))) (with-current-buffer nntp-server-buffer (erase-buffer) (maphash #'nnfeed--group-description s) t))) (deffoo nnfeed-request-rename-group (group new-name &optional server) - (when-let ((server (or server (nnfeed--current-server-no-prefix))) - (a (nnfeed--server-address server)) - (s (or (gethash a nnfeed-servers) - (and ; Open the server to add it to `nnfeed-servers' - (save-match-data - (nnfeed-open-server - server - (cdr ; Get defs and backend. - (assoc a (cdr (assq nnfeed-backend nnoo-state-alist)) - (lambda (car key) - (and (stringp car) - (string-match - (concat - "\\`\\(\\(nn[[:alpha:]]+\\)\\+\\)?" - (regexp-quote key) "\\'") - car) - (setq server car))))) - (if (match-string 1 server) - (intern (match-string 2 server)) 'nnfeed))) - (gethash a nnfeed-servers)))) - (g (or (nnfeed--group-data group a) - `[ ,group ,(make-hash-table :test 'equal) - ,(make-hash-table :test 'eql) nil 1 ""]))) + (when-let* ((server (or server (nnfeed--current-server-no-prefix))) + (a (nnfeed--server-address server)) + (s (or (gethash a nnfeed-servers) + (and ; Open the server to add it to `nnfeed-servers' + (save-match-data + (nnfeed-open-server + server + (cdr ; Get defs and backend. + (assoc a (cdr (assq nnfeed-backend nnoo-state-alist)) + (lambda (car key) + (and (stringp car) + (string-match + (concat + "\\`\\(\\(nn[[:alpha:]]+\\)\\+\\)?" + (regexp-quote key) "\\'") + car) + (setq server car))))) + (if (match-string 1 server) + (intern (match-string 2 server)) 'nnfeed))) + (gethash a nnfeed-servers)))) + (g (or (nnfeed--group-data group a) + `[ ,group ,(make-hash-table :test 'equal) + ,(make-hash-table :test 'eql) nil 1 ""]))) (puthash new-name g s) (puthash group new-name nnfeed-group-names) (remhash group s) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 7b0e42ff89d..16ed338a0de 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -918,10 +918,10 @@ during splitting, which may be slow." (nnimap-finish-retrieve-group-infos server info sequences t) (setq active (nth 2 (assoc group nnimap-current-infos))))) - (setq active (or active '(0 . 1))) + (setq active (or active '(1 . 0))) (erase-buffer) (insert (format "211 %d %d %d %S\n" - (- (cdr active) (car active)) + (max (1+ (- (cdr active) (car active))) 0) (car active) (cdr active) group)) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index e11d063f6ee..dbe0aba176f 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -554,10 +554,10 @@ as unread by Gnus.") (mapcar (lambda (art) (cons art - (when-let ((modtime - (file-attribute-modification-time - (file-attributes - (concat dir (int-to-string art)))))) + (when-let* ((modtime + (file-attribute-modification-time + (file-attributes + (concat dir (int-to-string art)))))) (time-convert modtime 'list)))) new))) ;; Make Gnus mark all new articles as unread. diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 1ffe1b16588..c87c86bae84 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -85,14 +85,14 @@ current help buffer.") (defun help-definition-prefixes () "Return the up-to-date radix-tree form of `definition-prefixes'." - (when (> (hash-table-count definition-prefixes) 0) + (when (and (null help-definition-prefixes) + (> (hash-table-count definition-prefixes) 0)) (maphash (lambda (prefix files) (let ((old (radix-tree-lookup help-definition-prefixes prefix))) (setq help-definition-prefixes (radix-tree-insert help-definition-prefixes prefix (append old files))))) - definition-prefixes) - (clrhash definition-prefixes)) + definition-prefixes)) help-definition-prefixes) (defun help--loaded-p (file) @@ -112,6 +112,7 @@ current help buffer.") (pcase-dolist (`(,prefix . ,files) prefixes) (setq help-definition-prefixes (radix-tree-insert help-definition-prefixes prefix nil)) + (remhash prefix definition-prefixes) (dolist (file files) ;; FIXME: Should we scan help-definition-prefixes to remove ;; other prefixes of the same file? @@ -206,9 +207,12 @@ type specifier when available." ,@(when completions-detailed '((affixation-function . help--symbol-completion-table-affixation))) (category . symbol-help)) - (when help-enable-completion-autoload + (when (and help-enable-completion-autoload + (memq action '(nil t lambda))) (let ((prefixes (radix-tree-prefixes (help-definition-prefixes) string))) - (help--load-prefixes prefixes))) + ;; Don't load FOO.el during `test-completion' of `FOO-'. + (unless (and (eq action 'lambda) (assoc string prefixes)) + (help--load-prefixes prefixes)))) (let ((prefix-completions (and help-enable-completion-autoload (mapcar #'intern (all-completions string definition-prefixes))))) @@ -262,6 +266,23 @@ interactive command." fn)) (list fn))) +(declare-function project-combine-directories "project" (&rest lists)) + +(cl-defmethod xref-backend-references ((_backend (eql 'elisp)) identifier + &context (major-mode help-mode)) + (mapcan + (lambda (dir) + (message "Searching %s..." dir) + (redisplay) + (prog1 + (xref-references-in-directory identifier dir) + (message "Searching %s... done" dir))) + (project-combine-directories (elisp-load-path-roots)))) + +(defun help-fns--setup-xref-backend () + (add-hook 'xref-backend-functions #'elisp--xref-backend nil t) + (setq-local semantic-symref-filepattern-alist '((help-mode "*.el")))) + ;;;###autoload (defun describe-function (function) "Display the full documentation of FUNCTION (a symbol). @@ -295,6 +316,8 @@ handling of autoloaded functions." (princ " is ") (describe-function-1 function) (with-current-buffer standard-output + (help-fns--setup-xref-backend) + ;; Return the text we displayed. (buffer-string)))))) @@ -302,7 +325,7 @@ handling of autoloaded functions." (defun help-find-source () "Switch to a buffer visiting the source of what is being described in *Help*." (interactive) - (if-let ((help-buffer (get-buffer "*Help*"))) + (if-let* ((help-buffer (get-buffer "*Help*"))) (with-current-buffer help-buffer (help-view-source)) (error "No *Help* buffer found"))) @@ -626,7 +649,7 @@ the C sources, too." (lambda (entry level) (when (symbolp map) (setq map (symbol-function map))) - (when-let ((elem (assq entry (cdr map)))) + (when-let* ((elem (assq entry (cdr map)))) (when (> level 0) (push sep string)) (if (eq (nth 1 elem) 'menu-item) @@ -869,6 +892,21 @@ the C sources, too." )) +(defun help-fns--first-release-override (symbol type) + "The first release defining SYMBOL of TYPE, or nil. +TYPE indicates the namespace and is `fun' or `var'." + (let* ((sym-rel-file (expand-file-name "symbol-releases.eld" data-directory)) + (tuples + (with-temp-buffer + (ignore-errors + (insert-file-contents sym-rel-file) + (goto-char (point-min)) + (read (current-buffer)))))) + (unless (cl-every (lambda (x) (and (= (length x) 3) (stringp (car x)))) + tuples) + (error "Bad %s format" sym-rel-file)) + (car (rassoc (list type symbol) tuples)))) + (defun help-fns--first-release (symbol) "Return the likely first release that defined SYMBOL, or nil." ;; Code below relies on the etc/NEWS* files. @@ -949,15 +987,23 @@ the C sources, too." ;; (display-buffer (current-buffer))))) (add-hook 'help-fns-describe-function-functions - #'help-fns--mention-first-release) + #'help-fns--mention-first-function-release) (add-hook 'help-fns-describe-variable-functions - #'help-fns--mention-first-release) -(defun help-fns--mention-first-release (object) + #'help-fns--mention-first-variable-release) + +(defun help-fns--mention-first-function-release (object) + (help-fns--mention-first-release object 'fun)) + +(defun help-fns--mention-first-variable-release (object) ;; Don't output anything if we've already output the :version from ;; the `defcustom'. (unless (memq 'help-fns--customize-variable-version help-fns--activated-functions) - (when-let ((first (and (symbolp object) + (help-fns--mention-first-release object 'var))) + +(defun help-fns--mention-first-release (object type) + (when (symbolp object) + (when-let* ((first (or (help-fns--first-release-override object type) (help-fns--first-release object)))) (with-current-buffer standard-output (insert (format " Probably introduced at or before Emacs version %s.\n" @@ -970,8 +1016,8 @@ the C sources, too." #'help-fns--mention-shortdoc-groups) (defun help-fns--mention-shortdoc-groups (object) (require 'shortdoc) - (when-let ((groups (and (symbolp object) - (shortdoc-function-groups object)))) + (when-let* ((groups (and (symbolp object) + (shortdoc-function-groups object)))) (let ((start (point)) (times 0)) (with-current-buffer standard-output @@ -999,17 +1045,41 @@ the C sources, too." (fill-region-as-paragraph (point-min) (point-max)) (goto-char (point-max)))))) +(require 'radix-tree) + +(defconst help-fns--radix-trees + (make-hash-table :weakness 'key :test 'equal) + "Cache of radix-tree representation of `load-path'.") + +(defun help-fns--filename (file) + (let ((f (abbreviate-file-name (expand-file-name file)))) + (if (file-name-case-insensitive-p f) (downcase f) f))) + +(defun help-fns--radix-tree (dirs) + (with-memoization (gethash dirs help-fns--radix-trees) + (let ((rt radix-tree-empty)) + (dolist (d dirs) + (let ((d (help-fns--filename (file-name-as-directory d)))) + (setq rt (radix-tree-insert rt d t)))) + rt))) + (defun help-fns-short-filename (filename) - (let* ((abbrev (abbreviate-file-name filename)) - (short abbrev)) - (dolist (dir load-path) - (let ((rel (file-relative-name filename dir))) - (if (< (length rel) (length short)) - (setq short rel))) - (let ((rel (file-relative-name abbrev dir))) - (if (< (length rel) (length short)) - (setq short rel)))) - short)) + (let* ((short (help-fns--filename filename)) + (prefixes (radix-tree-prefixes (help-fns--radix-tree load-path) + (file-name-directory short)))) + (if (not prefixes) + ;; The file is not inside the `load-path'. + ;; FIXME: Here's the old code (too slow, bug#73766), + ;; which used to try and shorten it with "../" as well. + ;; (dolist (dir load-path) + ;; (let ((rel (file-relative-name filename dir))) + ;; (if (< (length rel) (length short)) + ;; (setq short rel))) + ;; (let ((rel (file-relative-name abbrev dir))) + ;; (if (< (length rel) (length short)) + ;; (setq short rel)))) + short + (file-relative-name short (caar prefixes))))) (defun help-fns--analyze-function (function) ;; FIXME: Document/explain the differences between FUNCTION, @@ -1487,6 +1557,7 @@ it is displayed along with the global value." (delete-char 1))))) (with-current-buffer standard-output + (help-fns--setup-xref-backend) ;; Return the text we displayed. (buffer-string)))))))) @@ -1502,8 +1573,6 @@ it is displayed along with the global value." :parent button-map "e" #'help-fns-edit-variable))))) -(defvar help-fns--edit-variable) - (put 'help-fns-edit-variable 'disabled t) (defun help-fns-edit-variable () "Edit the variable under point." @@ -1512,50 +1581,10 @@ it is displayed along with the global value." (let ((var (get-text-property (point) 'help-fns--edit-variable))) (unless var (error "No variable under point")) - (pop-to-buffer-same-window (format "*edit %s*" (nth 0 var))) - (prin1 (nth 1 var) (current-buffer)) - (pp-buffer) - (goto-char (point-min)) - (help-fns--edit-value-mode) - (insert (format ";; Edit the `%s' variable.\n" (nth 0 var)) - (substitute-command-keys - ";; `\\[help-fns-edit-mode-done]' to update the value and exit; \ -`\\[help-fns-edit-mode-cancel]' to cancel.\n\n")) - (setq-local help-fns--edit-variable var))) - -(defvar-keymap help-fns--edit-value-mode-map - "C-c C-c" #'help-fns-edit-mode-done - "C-c C-k" #'help-fns-edit-mode-cancel) - -(define-derived-mode help-fns--edit-value-mode emacs-lisp-mode "Elisp" - :interactive nil) - -(defun help-fns-edit-mode-done (&optional kill) - "Update the value of the variable being edited and kill the edit buffer. -If KILL (the prefix), don't update the value, but just kill the -current buffer." - (interactive "P" help-fns--edit-value-mode) - (unless help-fns--edit-variable - (error "Invalid buffer")) - (goto-char (point-min)) - (cl-destructuring-bind (variable _ buffer help-buffer) - help-fns--edit-variable - (unless (buffer-live-p buffer) - (error "Original buffer is gone; can't update")) - (unless kill - (let ((value (read (current-buffer)))) - (with-current-buffer buffer - (set variable value)))) - (kill-buffer (current-buffer)) - (when (buffer-live-p help-buffer) - (with-current-buffer help-buffer - (revert-buffer))))) - -(defun help-fns-edit-mode-cancel () - "Kill the edit buffer and cancel editing of the value. -This cancels value editing without updating the value." - (interactive nil help-fns--edit-value-mode) - (help-fns-edit-mode-done t)) + (let ((str (read-string-from-buffer + (format ";; Edit the `%s' variable." (nth 0 var)) + (prin1-to-string (nth 1 var))))) + (set (nth 0 var) (read str))))) (defun help-fns--run-describe-functions (functions &rest args) (with-current-buffer standard-output @@ -1589,7 +1618,7 @@ This cancels value editing without updating the value." (defun help-fns--customize-variable-version (variable) (when (custom-variable-p variable) ;; Note variable's version or package version. - (when-let ((output (describe-variable-custom-version-info variable))) + (when-let* ((output (describe-variable-custom-version-info variable))) (princ output)))) (add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local) @@ -1835,7 +1864,7 @@ If FRAME is omitted or nil, use the selected frame." (add-hook 'help-fns-describe-face-functions #'help-fns--face-custom-version-info) (defun help-fns--face-custom-version-info (face _frame) - (when-let ((version-info (describe-variable-custom-version-info face 'face))) + (when-let* ((version-info (describe-variable-custom-version-info face 'face))) (insert version-info) (terpri))) @@ -2194,7 +2223,7 @@ is enabled in the Help buffer." (lambda (_) (describe-function major)))) (insert " mode") - (when-let ((file-name (find-lisp-object-file-name major nil))) + (when-let* ((file-name (find-lisp-object-file-name major nil))) (insert (format " defined in %s:\n\n" (buttonize (help-fns-short-filename file-name) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index e16408be7b0..33b8eccab2c 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -505,27 +505,15 @@ This should be called very early, before the output buffer is cleared, because we want to record the \"previous\" position of point so we can restore it properly when going back." (with-current-buffer (help-buffer) - ;; Disable `outline-minor-mode' in a reused Help buffer - ;; created by `describe-bindings' that enables this mode. - (when (bound-and-true-p outline-minor-mode) - (outline-minor-mode -1) - (mapc #'kill-local-variable - '(outline-search-function - outline-regexp - outline-heading-end-regexp - outline-level - outline-minor-mode-cycle - outline-minor-mode-highlight - outline-minor-mode-use-buttons - outline-default-state - outline-default-rules))) + ;; Re-enable major mode, killing all unrelated local vars. + (funcall major-mode) (when help-xref-stack-item (push (cons (point) help-xref-stack-item) help-xref-stack) (setq help-xref-forward-stack nil)) (when interactive-p (let ((tail (nthcdr 10 help-xref-stack))) - ;; Truncate the stack. - (if tail (setcdr tail nil)))) + ;; Truncate the stack. + (if tail (setcdr tail nil)))) (setq help-xref-stack-item item))) (defvar help-xref-following nil @@ -658,7 +646,7 @@ that." ;; Quoted symbols (save-excursion (while (re-search-forward help-xref-symbol-regexp nil t) - (when-let ((sym (intern-soft (match-string 9)))) + (when-let* ((sym (intern-soft (match-string 9)))) (if (match-string 8) (delete-region (match-beginning 8) (match-end 8)) diff --git a/lisp/help.el b/lisp/help.el index 5efe207c624..ef0b7ffc01d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -883,8 +883,8 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (let ((otherstring (help--key-description-fontified untranslated))) (if (equal string otherstring) string - (if-let ((char-name (and (length= string 1) - (char-to-name (aref string 0))))) + (if-let* ((char-name (and (length= string 1) + (char-to-name (aref string 0))))) (format "%s '%s' (translated from %s)" string char-name otherstring) (format "%s (translated from %s)" string otherstring))))))) @@ -1668,7 +1668,7 @@ Return nil if the key sequence is too long." (cond ((or (stringp definition) (vectorp definition)) (if translation (insert (concat (key-description definition nil) - (when-let ((char-name (char-to-name (aref definition 0)))) + (when-let* ((char-name (char-to-name (aref definition 0)))) (format "\t%s" char-name)) "\n")) ;; These should be rare nowadays, replaced by `kmacro's. @@ -1884,79 +1884,6 @@ in `help--describe-map-tree'." (- width (car elem)) (mod width tab-width)))))) -;;;; This Lisp version is 100 times slower than its C equivalent: -;; -;; (defun help--describe-vector -;; (vector prefix transl partial shadow entire-map mention-shadow) -;; "Insert in the current buffer a description of the contents of VECTOR. -;; -;; PREFIX a prefix key which leads to the keymap that this vector is -;; in. -;; -;; If PARTIAL, it means do not mention suppressed commands -;; (that assumes the vector is in a keymap). -;; -;; SHADOW is a list of keymaps that shadow this map. If it is -;; non-nil, look up the key in those maps and don't mention it if it -;; is defined by any of them. -;; -;; ENTIRE-MAP is the vector in which this vector appears. -;; If the definition in effect in the whole map does not match -;; the one in this vector, we ignore this one." -;; ;; Converted from describe_vector in keymap.c. -;; (let* ((first t) -;; (idx 0)) -;; (while (< idx (length vector)) -;; (let* ((val (aref vector idx)) -;; (definition (keymap--get-keyelt val nil)) -;; (start-idx idx) -;; this-shadowed -;; found-range) -;; (when (and definition -;; ;; Don't mention suppressed commands. -;; (not (and partial -;; (symbolp definition) -;; (get definition 'suppress-keymap))) -;; ;; If this binding is shadowed by some other map, -;; ;; ignore it. -;; (not (and shadow -;; (help--shadow-lookup shadow (vector start-idx) t nil) -;; (if mention-shadow -;; (prog1 nil (setq this-shadowed t)) -;; t))) -;; ;; Ignore this definition if it is shadowed by an earlier -;; ;; one in the same keymap. -;; (not (and entire-map -;; (not (eq (lookup-key entire-map (vector start-idx) t) -;; definition))))) -;; (when first -;; (insert "\n") -;; (setq first nil)) -;; (when (and prefix (> (length prefix) 0)) -;; (insert (format "%s" prefix))) -;; (insert (help--key-description-fontified (vector start-idx) prefix)) -;; ;; Find all consecutive characters or rows that have the -;; ;; same definition. -;; (while (equal (keymap--get-keyelt (aref vector (1+ idx)) nil) -;; definition) -;; (setq found-range t) -;; (setq idx (1+ idx))) -;; ;; If we have a range of more than one character, -;; ;; print where the range reaches to. -;; (when found-range -;; (insert " .. ") -;; (when (and prefix (> (length prefix) 0)) -;; (insert (format "%s" prefix))) -;; (insert (help--key-description-fontified (vector idx) prefix))) -;; (if transl -;; (help--describe-translation definition) -;; (help--describe-command definition)) -;; (when this-shadowed -;; (goto-char (1- (point))) -;; (insert " (binding currently shadowed)") -;; (goto-char (1+ (point)))))) -;; (setq idx (1+ idx))))) - (declare-function x-display-pixel-height "xfns.c" (&optional terminal)) (declare-function x-display-pixel-width "xfns.c" (&optional terminal)) diff --git a/lisp/hfy-cmap.el b/lisp/hfy-cmap.el index e9956222e9c..b500c664ff1 100644 --- a/lisp/hfy-cmap.el +++ b/lisp/hfy-cmap.el @@ -835,7 +835,7 @@ Loads the variable `hfy-rgb-txt-color-map', which is used by (when (and rgb-txt (file-readable-p rgb-txt)) (setq rgb-buffer (find-file-noselect rgb-txt 'nowarn)) - (when-let ((result (hfy-cmap--parse-buffer rgb-buffer))) + (when-let* ((result (hfy-cmap--parse-buffer rgb-buffer))) (setq hfy-rgb-txt-color-map result)) (kill-buffer rgb-buffer)))) diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 6d827a055a5..b751fc61789 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -891,7 +891,7 @@ Apply the previous patterns after reverting the buffer." (let ((face (hi-lock-keyword->face (cdr pattern)))) (highlight-regexp (or (get-text-property 0 'regexp (car pattern)) (car pattern)) - face) + face nil (car pattern)) (setq hi-lock--unused-faces (remove (face-name face) hi-lock--unused-faces))))))))) diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 53cb00eb1ba..cfa780ed586 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -766,7 +766,7 @@ may happen." (defcustom hfy-font-zoom 1.05 "Font scaling from Emacs to HTML." - :type 'float) + :type 'number) (defun hfy-size (height) "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT. diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 33b68b96ff2..4cbe3c4ba15 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -857,7 +857,7 @@ specification, with the same structure as an element of the list "Move point to the filter group whose name is NAME." (interactive (list (ibuffer-read-filter-group-name "Jump to filter group: "))) - (if-let ((it (assoc name (ibuffer-current-filter-groups-with-position)))) + (if-let* ((it (assoc name (ibuffer-current-filter-groups-with-position)))) (goto-char (cdr it)) (error "No filter group with name %s" name))) @@ -868,7 +868,7 @@ The group will be added to `ibuffer-filter-group-kill-ring'." (interactive (list (ibuffer-read-filter-group-name "Kill filter group: " t))) (when (equal name "Default") (error "Can't kill default filter group")) - (if-let ((it (assoc name ibuffer-filter-groups))) + (if-let* ((it (assoc name ibuffer-filter-groups))) (progn (push (copy-tree it) ibuffer-filter-group-kill-ring) (setq ibuffer-filter-groups (ibuffer-remove-alist @@ -883,9 +883,9 @@ The group will be added to `ibuffer-filter-group-kill-ring'." "Kill the filter group at point. See also `ibuffer-kill-filter-group'." (interactive "P\np") - (if-let ((it (save-excursion - (ibuffer-forward-line 0) - (get-text-property (point) 'ibuffer-filter-group-name)))) + (if-let* ((it (save-excursion + (ibuffer-forward-line 0) + (get-text-property (point) 'ibuffer-filter-group-name)))) (ibuffer-kill-filter-group it) (funcall (if interactive-p #'call-interactively #'funcall) #'kill-line arg))) @@ -944,7 +944,7 @@ prompt for NAME, and use the current filters." (list (read-from-minibuffer "Save current filter groups as: ") ibuffer-filter-groups))) - (if-let ((it (assoc name ibuffer-saved-filter-groups))) + (if-let* ((it (assoc name ibuffer-saved-filter-groups))) (setcdr it groups) (push (cons name groups) ibuffer-saved-filter-groups)) (ibuffer-maybe-save-stuff)) @@ -1116,7 +1116,7 @@ Interactively, prompt for NAME, and use the current filters." (list (read-from-minibuffer "Save current filters as: ") ibuffer-filtering-qualifiers))) - (if-let ((it (assoc name ibuffer-saved-filters))) + (if-let* ((it (assoc name ibuffer-saved-filters))) (setcdr it filters) (push (cons name filters) ibuffer-saved-filters)) (ibuffer-maybe-save-stuff)) @@ -1296,7 +1296,7 @@ For example, for a buffer associated with file '/a/b/c.d', this matches against '/a/b/c.d'." (:description "full file name" :reader (read-from-minibuffer "Filter by full file name (regexp): ")) - (when-let ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) (string-match qualifier it))) ;;;###autoload (autoload 'ibuffer-filter-by-basename "ibuf-ext") @@ -1308,7 +1308,7 @@ matches against `c.d'." (:description "file basename" :reader (read-from-minibuffer "Filter by file name, without directory part (regex): ")) - (when-let ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) (string-match qualifier (file-name-nondirectory it)))) ;;;###autoload (autoload 'ibuffer-filter-by-file-extension "ibuf-ext") @@ -1321,7 +1321,7 @@ pattern. For example, for a buffer associated with file (:description "filename extension" :reader (read-from-minibuffer "Filter by filename extension without separator (regex): ")) - (when-let ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((it (with-current-buffer buf (ibuffer-buffer-file-name)))) (string-match qualifier (or (file-name-extension it) "")))) ;;;###autoload (autoload 'ibuffer-filter-by-directory "ibuf-ext") @@ -1656,7 +1656,7 @@ a prefix argument reverses the meaning of that variable." "Compare BUFFER with its associated file, if any. Unlike `diff-no-select', insert output into current buffer without erasing it." - (when-let ((old (buffer-file-name buffer))) + (when-let* ((old (buffer-file-name buffer))) (defvar diff-use-labels) (let* ((new buffer) (oldtmp (diff-file-local-copy old)) @@ -1822,7 +1822,7 @@ When BUF nil, default to the buffer at current line." (interactive (list (read-regexp "Mark by file name (regexp)"))) (ibuffer-mark-on-buffer (lambda (buf) - (when-let ((name (with-current-buffer buf (ibuffer-buffer-file-name)))) + (when-let* ((name (with-current-buffer buf (ibuffer-buffer-file-name)))) ;; Match on the displayed file name (which is abbreviated). (string-match-p regexp (ibuffer--abbreviate-file-name name)))))) @@ -1843,7 +1843,7 @@ Otherwise buffers whose name matches an element of (or (memq mode ibuffer-never-search-content-mode) (cl-dolist (x ibuffer-never-search-content-name nil) - (when-let ((found (string-match x (buffer-name buf)))) + (when-let* ((found (string-match x (buffer-name buf)))) (cl-return found))))) (setq res nil)) (t diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 1fd94967836..f04c436f6e2 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -35,7 +35,7 @@ If TEST returns non-nil, bind `it' to the value, and evaluate TRUE-BODY. Otherwise, evaluate forms in FALSE-BODY as if in `progn'. Compare with `if'." - (declare (obsolete if-let "29.1") (indent 2)) + (declare (obsolete if-let* "29.1") (indent 2)) (let ((sym (make-symbol "ibuffer-aif-sym"))) `(let ((,sym ,test)) (if ,sym @@ -47,8 +47,8 @@ Compare with `if'." (defmacro ibuffer-awhen (test &rest body) "Evaluate BODY if TEST returns non-nil. During evaluation of body, bind `it' to the value returned by TEST." - (declare (indent 1) (obsolete when-let "29.1")) - `(when-let ((it ,test)) + (declare (indent 1) (obsolete when-let* "29.1")) + `(when-let* ((it ,test)) ,@body)) (defmacro ibuffer-save-marks (&rest body) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index c1e7788d2e8..405fb98d4d4 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -832,7 +832,7 @@ width and the longest string in LIST." (let ((pt (save-excursion (mouse-set-point event) (point)))) - (if-let ((it (get-text-property (point) 'ibuffer-filter-group-name))) + (if-let* ((it (get-text-property (point) 'ibuffer-filter-group-name))) (ibuffer-toggle-marks it) (goto-char pt) (let ((mark (ibuffer-current-mark))) @@ -1263,7 +1263,7 @@ become unmarked. If point is on a group name, then this function operates on that group." (interactive) - (when-let ((it (get-text-property (point) 'ibuffer-filter-group-name))) + (when-let* ((it (get-text-property (point) 'ibuffer-filter-group-name))) (setq group it)) (let ((count (ibuffer-map-lines @@ -1336,7 +1336,7 @@ If point is on a group name, this function operates on that group." (when (and movement (< movement 0)) (setq arg (- arg))) (ibuffer-forward-line 0) - (if-let ((it (get-text-property (point) 'ibuffer-filter-group-name))) + (if-let* ((it (get-text-property (point) 'ibuffer-filter-group-name))) (progn (require 'ibuf-ext) (ibuffer-mark-on-buffer #'identity mark it)) @@ -1540,7 +1540,7 @@ If point is on a group name, this function operates on that group." ;; `ibuffer-inline-columns' alist and insert it ;; into our generated code. Otherwise, we just ;; generate a call to the column function. - (if-let ((it (assq sym ibuffer-inline-columns))) + (if-let* ((it (assq sym ibuffer-inline-columns))) (nth 1 it) `(or (,sym buffer mark) ""))) ;; You're not expected to understand this. Hell, I @@ -1737,7 +1737,7 @@ If point is on a group name, this function operates on that group." (cond ((zerop total) "No processes") ((= 1 total) "1 process") (t (format "%d processes" total)))))) - (if-let ((it (get-buffer-process buffer))) + (if-let* ((it (get-buffer-process buffer))) (format "(%s %s)" it (process-status it)) "")) @@ -1872,8 +1872,8 @@ the buffer object itself and the current mark symbol." (let ((result (if (buffer-live-p (ibuffer-current-buffer)) (when (or (null group) - (when-let ((it (get-text-property - (point) 'ibuffer-filter-group))) + (when-let* ((it (get-text-property + (point) 'ibuffer-filter-group))) (equal group it))) (save-excursion (funcall function diff --git a/lisp/icomplete.el b/lisp/icomplete.el index f3569789e64..a79db644cab 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -1015,7 +1015,11 @@ matches exist." (or determ (concat open-bracket close-bracket))) (string-width icomplete-separator) (+ 2 (string-width ellipsis)) ;; take {…} into account - (string-width (buffer-string)))) + (string-width + (buffer-substring (save-excursion + (goto-char (icomplete--field-beg)) + (pos-bol)) + (icomplete--field-end))))) (prospects-max ;; Max total length to use, including the minibuffer content. (* (+ icomplete-prospects-height diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 7cf7845e935..e75f6ea918f 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -867,6 +867,13 @@ The limits are given by the user option (or (<= mw (* (car size) scale)) (<= mh (* (cdr size) scale)))))) +(defun image--update-properties (image properties) + "Update IMAGE with the new PROPERTIES set." + (let (prop) + (while (setq prop (pop properties)) + (plist-put (cdr image) prop (pop properties))) + image)) + (defun image-toggle-display-image () "Show the image of the image file. Turn the image data into a real image, but only if the whole file @@ -959,7 +966,7 @@ was inserted." ;; Discard any stale image data before looking it up again. (image-flush image) - (setq image (append image (image-transform-properties image))) + (setq image (image--update-properties image (image-transform-properties image))) (setq props `(display ,image ;; intangible ,image diff --git a/lisp/image.el b/lisp/image.el index 3d60b485c6b..ce97eeb3ca1 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -1434,7 +1434,7 @@ Also return nil if rotation is not a multiples of 90 degrees (0, 90, Return a copy of :original-map transformed based on IMAGE's :scale, :rotation, and :flip. When IMAGE's :original-map is nil, return nil. When :rotation is not a multiple of 90, return copy of :original-map." - (when-let ((map (image-property image :original-map))) + (when-let* ((map (image-property image :original-map))) (setq map (copy-tree map t)) (let* ((size (image-size image t)) ;; The image can be scaled for many reasons (:scale, @@ -1469,7 +1469,7 @@ When :rotation is not a multiple of 90, return copy of :original-map." "Return original map for IMAGE. If IMAGE lacks :map property, return nil. When there is no transformation, return copy of :map." - (when-let ((original-map (image-property image :map))) + (when-let* ((original-map (image-property image :map))) (setq original-map (copy-tree original-map t)) (let* ((size (image-size image t)) ;; The image can be scaled for many reasons (:scale, diff --git a/lisp/image/exif.el b/lisp/image/exif.el index 2c1c4850bef..86e47da8bcc 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -127,10 +127,10 @@ from the return value of this function." (encode-coding-region (point-min) (point-max) buffer-file-coding-system dest)) - (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) + (when-let* ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) (exif--parse-exif-chunk app1)))) (save-excursion - (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) + (when-let* ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) (exif--parse-exif-chunk app1)))))) (defun exif-field (field data) diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index 2e2010e06f0..10f1598912a 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -85,7 +85,7 @@ like \"image/gif\"." (image-converter-initialize) ;; When image-converter was customized (when (and image-converter (not image-converter-regexp)) - (when-let ((formats (image-converter--probe image-converter))) + (when-let* ((formats (image-converter--probe image-converter))) (setq image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")) (setq image-converter-file-name-extensions formats))) @@ -136,8 +136,8 @@ converted image data as a string." (extra-converter (gethash type image-converter--extra-converters))) (if extra-converter (funcall extra-converter source format) - (when-let ((err (image-converter--convert - image-converter source format))) + (when-let* ((err (image-converter--convert + image-converter source format))) (error "%s" err)))) (if (listp image) ;; Return an image object that's the same as we were passed, @@ -217,8 +217,8 @@ converted image data as a string." "Find an installed image converter Emacs can use." (catch 'done (dolist (elem image-converter--converters) - (when-let ((formats (image-converter--filter-formats - (image-converter--probe (car elem))))) + (when-let* ((formats (image-converter--filter-formats + (image-converter--probe (car elem))))) (setq image-converter (car elem) image-converter-regexp (concat "\\." (regexp-opt formats) "\\'") image-converter-file-name-extensions formats) diff --git a/lisp/image/image-dired-util.el b/lisp/image/image-dired-util.el index e9048e157cd..e620c688b1b 100644 --- a/lisp/image/image-dired-util.el +++ b/lisp/image/image-dired-util.el @@ -125,7 +125,7 @@ See also `image-dired-thumbnail-storage' and (defun image-dired-file-name-at-point () "Get abbreviated file name for thumbnail or display image at point." - (when-let ((f (image-dired-original-file-name))) + (when-let* ((f (image-dired-original-file-name))) (abbreviate-file-name f))) (defun image-dired-associated-dired-buffer () diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el index 90c6f7663b5..83745e88f09 100644 --- a/lisp/image/image-dired.el +++ b/lisp/image/image-dired.el @@ -663,7 +663,7 @@ only useful if `image-dired-track-movement' is nil." (image-dired--with-dired-buffer (if (not (dired-goto-file file-name)) (message "Could not find image in Dired buffer for tracking") - (when-let (window (image-dired-get-buffer-window (current-buffer))) + (when-let* ((window (image-dired-get-buffer-window (current-buffer)))) (set-window-point window (point))))))) (defun image-dired-toggle-movement-tracking () @@ -863,7 +863,7 @@ for. The default is to look for `dired-marker-char'." "Run BODY in associated Dired buffer with point on current file's line. Should be called from commands in `image-dired-thumbnail-mode'." (declare (indent defun) (debug t)) - `(if-let ((file-name (image-dired-original-file-name))) + `(if-let* ((file-name (image-dired-original-file-name))) (image-dired--with-dired-buffer (when (dired-goto-file file-name) ,@body)) @@ -871,9 +871,9 @@ Should be called from commands in `image-dired-thumbnail-mode'." (defmacro image-dired--with-thumbnail-buffer (&rest body) (declare (indent defun) (debug t)) - `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + `(if-let* ((buf (get-buffer image-dired-thumbnail-buffer))) (with-current-buffer buf - (if-let ((win (get-buffer-window buf))) + (if-let* ((win (get-buffer-window buf))) (with-selected-window win ,@body) ,@body)) @@ -932,7 +932,7 @@ You probably want to use this together with `image-dired-track-original-file'." (interactive nil image-dired-thumbnail-mode) (image-dired--with-dired-buffer - (if-let ((window (image-dired-get-buffer-window (current-buffer)))) + (if-let* ((window (image-dired-get-buffer-window (current-buffer)))) (progn (if (not (equal (selected-frame) (window-frame window))) (select-frame-set-input-focus (window-frame window))) @@ -1078,7 +1078,7 @@ Resized or in full-size." (defcustom image-dired-slideshow-delay 5.0 "Seconds to wait before showing the next image in a slideshow. This is used by `image-dired-slideshow-start'." - :type 'float + :type 'number :version "29.1") (define-obsolete-variable-alias 'image-dired-slideshow-timer @@ -1090,7 +1090,7 @@ This is used by `image-dired-slideshow-start'." (defun image-dired--slideshow-step () "Step to the next image in a slideshow." - (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (if-let* ((buf (get-buffer image-dired-thumbnail-buffer))) (with-current-buffer buf (image-dired-display-next)) (image-dired--slideshow-stop))) @@ -1272,7 +1272,7 @@ which is based on `image-mode'." (cur-win (selected-window))) (when buf (kill-buffer buf)) - (when-let ((buf (find-file-noselect file nil t))) + (when-let* ((buf (find-file-noselect file nil t))) (pop-to-buffer buf) (rename-buffer image-dired-display-image-buffer) (if (string-match (image-file-name-regexp) file) diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el index 79682e921b0..399971b5ac0 100644 --- a/lisp/image/wallpaper.el +++ b/lisp/image/wallpaper.el @@ -131,14 +131,14 @@ continue running even after exiting Emacs." The returned function kills any process named PROCESS-NAME owned by the current effective user id." (lambda () - (when-let ((procs - (seq-filter (lambda (p) (let-alist p - (and (= .euid (user-uid)) - (equal .comm process-name)))) - (mapcar (lambda (pid) - (cons (cons 'pid pid) - (process-attributes pid))) - (list-system-processes))))) + (when-let* ((procs + (seq-filter (lambda (p) (let-alist p + (and (= .euid (user-uid)) + (equal .comm process-name)))) + (mapcar (lambda (pid) + (cons (cons 'pid pid) + (process-attributes pid))) + (list-system-processes))))) (dolist (proc procs) (let-alist proc (when (y-or-n-p (format "Kill \"%s\" process with PID %d?" .comm .pid)) @@ -297,7 +297,7 @@ order in which they appear.") (dolist (setter wallpaper--default-setters) (wallpaper-debug "Testing setter %s" (wallpaper-setter-name setter)) (when (and (executable-find (wallpaper-setter-command setter)) - (if-let ((pred (wallpaper-setter-predicate setter))) + (if-let* ((pred (wallpaper-setter-predicate setter))) (funcall pred) t)) (wallpaper-debug "Found setter %s" (wallpaper-setter-name setter)) @@ -305,12 +305,12 @@ order in which they appear.") (defun wallpaper--find-command () "Return the appropriate command to set the wallpaper." - (when-let ((setter (wallpaper--find-setter))) + (when-let* ((setter (wallpaper--find-setter))) (wallpaper-setter-command setter))) (defun wallpaper--find-command-args () "Return command line arguments matching `wallpaper-command'." - (when-let ((setter (wallpaper--find-setter))) + (when-let* ((setter (wallpaper--find-setter))) (wallpaper-setter-args setter))) @@ -449,23 +449,23 @@ This function is meaningful only on X and is used only there." (if (and .name (member .source '("XRandr" "XRandR 1.5" "Gdk"))) .name "0")) - (if-let ((name - (and (getenv "DISPLAY") - (or - (cdr (assq 'name - (progn - (x-open-connection (getenv "DISPLAY")) - (car (display-monitor-attributes-list - (car (last (terminal-list)))))))) - (and (executable-find "xrandr") - (with-temp-buffer - (call-process "xrandr" nil t nil) - (goto-char (point-min)) - (re-search-forward (rx bol - (group (+ (not (in " \n")))) - " connected") - nil t) - (match-string 1))))))) + (if-let* ((name + (and (getenv "DISPLAY") + (or + (cdr (assq 'name + (progn + (x-open-connection (getenv "DISPLAY")) + (car (display-monitor-attributes-list + (car (last (terminal-list)))))))) + (and (executable-find "xrandr") + (with-temp-buffer + (call-process "xrandr" nil t nil) + (goto-char (point-min)) + (re-search-forward (rx bol + (group (+ (not (in " \n")))) + " connected") + nil t) + (match-string 1))))))) ;; Prefer "0" to "default" as that works in XFCE. (if (equal name "default") "0" name) (read-string (format-prompt "Monitor name" nil))))) diff --git a/lisp/info-look.el b/lisp/info-look.el index 37f6a6dbb8e..d51a59f7ac6 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -48,11 +48,9 @@ "Major mode sensitive help agent." :group 'help :group 'languages) -(defvar info-lookup-mode nil +(defvar-local info-lookup-mode nil "Symbol of the current buffer's help mode. -Help is provided according to the buffer's major mode if value is nil. -Automatically becomes buffer local when set in any fashion.") -(make-variable-buffer-local 'info-lookup-mode) +Help is provided according to the buffer's major mode if value is nil.") (defcustom info-lookup-other-window-flag t "Non-nil means pop up the Info buffer in another window." @@ -329,7 +327,7 @@ string of `info-lookup-alist'. If optional argument QUERY is non-nil, query for the help mode." (let* ((mode (cond (query (info-lookup-change-mode topic)) - ((when-let + ((when-let* ((info (info-lookup->mode-value topic (info-lookup-select-mode)))) (info-lookup--expand-info info)) @@ -793,7 +791,7 @@ Return nil if there is nothing appropriate in the buffer near point." (defun info-complete (topic mode) "Try to complete a help item." (barf-if-buffer-read-only) - (when-let ((info (info-lookup->mode-value topic mode))) + (when-let* ((info (info-lookup->mode-value topic mode))) (info-lookup--expand-info info)) (let ((data (info-lookup-completions-at-point topic mode))) (if (null data) @@ -870,12 +868,12 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'texinfo-mode :regexp "@\\([a-zA-Z]+\\|[^a-zA-Z]\\)" - :doc-spec '(("(texinfo)Command and Variable Index" - ;; Ignore Emacs commands and prepend a `@'. - (lambda (item) - (if (string-match "^\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\( .*\\)?$" item) - (concat "@" (match-string 1 item)))) - "['`‘]" "['’ ]"))) + :doc-spec `(("(texinfo)Command and Variable Index" + ;; Ignore Emacs commands and prepend a `@'. + ,(lambda (item) + (if (string-match "^\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\( .*\\)?$" item) + (concat "@" (match-string 1 item)))) + "['`‘]" "['’ ]"))) (info-lookup-maybe-add-help :mode 'm4-mode @@ -886,31 +884,31 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'autoconf-mode :regexp "A[CM]_[_A-Z0-9]+" - :doc-spec '(;; Autoconf Macro Index entries are without an "AC_" prefix, - ;; but with "AH_" or "AU_" for those. So add "AC_" if there - ;; isn't already an "A._". + :doc-spec `(;; Autoconf Macro Index entries are without an "AC_" prefix, + ;; but with "AH_" or "AU_" for those. So add "AC_" if there + ;; isn't already an "A._". ("(autoconf)Autoconf Macro Index" - (lambda (item) - (if (string-match "^A._" item) item (concat "AC_" item))) - "^[ \t]+-+ \\(Macro\\|Variable\\): .*\\<" "\\>") + ,(lambda (item) + (if (string-match "^A._" item) item (concat "AC_" item))) + "^[ \t]+-+ \\(Macro\\|Variable\\): .*\\<" "\\>") ;; M4 Macro Index entries are without "AS_" prefixes, and ;; mostly without "m4_" prefixes. "dnl" is an exception, not ;; wanting any prefix. So AS_ is added back to upper-case ;; names (if needed), m4_ to others which don't already an m4_. ("(autoconf)M4 Macro Index" - (lambda (item) - (let ((case-fold-search nil)) - (cond ((or (string-equal item "dnl") - (string-match "^m4_" item) - ;; Autoconf 2.62 index includes some macros - ;; (e.g., AS_HELP_STRING), so avoid prefixing. - (string-match "^AS_" item)) - item) - ((string-match "^[A-Z0-9_]+$" item) - (concat "AS_" item)) - (t - (concat "m4_" item))))) - "^[ \t]+-+ Macro: .*\\<" "\\>") + ,(lambda (item) + (let ((case-fold-search nil)) + (cond ((or (string-equal item "dnl") + (string-match "^m4_" item) + ;; Autoconf 2.62 index includes some macros + ;; (e.g., AS_HELP_STRING), so avoid prefixing. + (string-match "^AS_" item)) + item) + ((string-match "^[A-Z0-9_]+$" item) + (concat "AS_" item)) + (t + (concat "m4_" item))))) + "^[ \t]+-+ Macro: .*\\<" "\\>") ;; Autotest Macro Index entries are without "AT_". ("(autoconf)Autotest Macro Index" "AT_" "^[ \t]+-+ Macro: .*\\<" "\\>") @@ -929,62 +927,65 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'awk-mode :regexp "[_a-zA-Z]+" - :doc-spec '(("(gawk)Index" - (lambda (item) - (let ((case-fold-search nil)) - (cond - ;; `BEGIN' and `END'. - ((string-match "^\\([A-Z]+\\) special pattern\\b" item) - (match-string 1 item)) - ;; `if', `while', `do', ... - ((string-match "^\\([a-z]+\\) statement\\b" item) - (if (not (string-equal (match-string 1 item) "control")) - (match-string 1 item))) - ;; `NR', `NF', ... - ((string-match "^[A-Z]+$" item) - item) - ;; Built-in functions (matches to many entries). - ((string-match "^[a-z]+$" item) - item)))) - "['`‘]" "\\([ \t]*([^)]*)\\)?['’]"))) + :doc-spec `(("(gawk)Index" + ,(lambda (item) + (let ((case-fold-search nil)) + (cond + ;; `BEGIN' and `END'. + ((string-match "^\\([A-Z]+\\) special pattern\\b" item) + (match-string 1 item)) + ;; `if', `while', `do', ... + ((string-match "^\\([a-z]+\\) statement\\b" item) + (if (not (string-equal (match-string 1 item) "control")) + (match-string 1 item))) + ;; `NR', `NF', ... + ((string-match "^[A-Z]+$" item) + item) + ;; Built-in functions (matches to many entries). + ((string-match "^[a-z]+$" item) + item)))) + "['`‘]" "\\([ \t]*([^)]*)\\)?['’]"))) (info-lookup-maybe-add-help :mode 'perl-mode :regexp "[$@%][^a-zA-Z]\\|\\$\\^[A-Z]\\|[$@%]?[a-zA-Z][_a-zA-Z0-9]*" - :doc-spec '(("(perl5)Function Index" - (lambda (item) - (if (string-match "^\\([a-zA-Z0-9]+\\)" item) - (match-string 1 item))) - "^" "\\b") - ("(perl5)Variable Index" - (lambda (item) - ;; Work around bad formatted array variables. - (let ((sym (cond ((or (string-match "^\\$\\(.\\|@@\\)$" item) - (string-match "^\\$\\^[A-Z]$" item)) - item) - ((string-match - "^\\([$%@]\\|@@\\)?[_a-zA-Z0-9]+" item) - (match-string 0 item)) - (t "")))) - (if (string-match "@@" sym) - (setq sym (concat (substring sym 0 (match-beginning 0)) - (substring sym (1- (match-end 0)))))) - (if (string-equal sym "") nil sym))) - "^" "\\b")) + :doc-spec `(("(perl5)Function Index" + ,(lambda (item) + (if (string-match "^\\([a-zA-Z0-9]+\\)" item) + (match-string 1 item))) + "^" "\\b") + ("(perl5)Variable Index" + ,(lambda (item) + ;; Work around bad formatted array variables. + (let ((sym (cond ((or (string-match "^\\$\\(.\\|@@\\)$" item) + (string-match "^\\$\\^[A-Z]$" item)) + item) + ((string-match + "^\\([$%@]\\|@@\\)?[_a-zA-Z0-9]+" item) + (match-string 0 item)) + (t "")))) + (if (string-match "@@" sym) + (setq sym (concat (substring sym 0 (match-beginning 0)) + (substring sym (1- (match-end 0)))))) + (if (string-equal sym "") nil sym))) + "^" "\\b")) :parse-rule "[$@%]?\\([_a-zA-Z0-9]+\\|[^a-zA-Z]\\)") (info-lookup-maybe-add-help :mode 'python-mode ;; Debian includes Python info files, but they're version-named ;; instead of having a symlink. - :doc-spec-function (lambda () - (list - (list - (cl-loop for version from 20 downto 7 - for name = (format "python3.%d" version) - if (Info-find-file name t) - return (format "(%s)Index" name) - finally return "(python)Index"))))) + :doc-spec-function + (lambda () + ;; Python is released annually (PEP 602). + (let* ((yy (- (decoded-time-year (decode-time (current-time))) 2000)) + (manual (cl-loop for version from yy downto 7 + for name = (format "python3.%d" version) + if (Info-find-file name t) + return name + finally return "python"))) + `((,(format "(%s)Index" manual)) + (,(format "(%s)Python Module Index" manual)))))) (info-lookup-maybe-add-help :mode 'perl-mode @@ -994,9 +995,11 @@ Return nil if there is nothing appropriate in the buffer near point." :mode 'latex-mode :regexp "\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)" :doc-spec `((,(if (Info-find-file "latex2e" t) - ;; From http://home.gna.org/latexrefman - "(latex2e)Command Index" - "(latex)Command Index") + ;; From CTAN's https://ctan.org/pkg/latex2e-help-texinfo + ;; and https://puszcza.gnu.org.ua/projects/latexrefman/ + "(latex2e)Index" + ;; From https://savannah.nongnu.org/projects/latex-manual/ + "(latex-manual)Command Index") ;; \frac{NUM}{DEN} etc can have more than one {xx} argument. ;; \sqrt[ROOT]{num} and others can have square brackets. nil "[`'‘]" "\\({[^}]*}|\\[[^]]*\\]\\)*['’]"))) @@ -1104,6 +1107,11 @@ Return nil if there is nothing appropriate in the buffer near point." :other-modes '(emacs-lisp-mode)) (info-lookup-maybe-add-help + :mode 'inferior-emacs-lisp-mode + :regexp "[^][()`'‘’,:\" \t\n]+" + :other-modes '(emacs-lisp-mode)) + +(info-lookup-maybe-add-help :mode 'lisp-mode :regexp "[^()`'‘’,\" \t\n]+" :parse-rule 'ignore @@ -1120,19 +1128,19 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'octave-mode :regexp "[_a-zA-Z0-9]+\\|\\s.+\\|[-!=^|*/.\\,><~&+]\\{1,3\\}\\|[][();,\"']" - :doc-spec '(("(octave)Function Index" nil - "^ -+ [^:]+:[ ]+\\(\\[[^=]*=[ ]+\\)?" nil) - ("(octave)Variable Index" nil "^ -+ [^:]+:[ ]+" nil) + :doc-spec `(("(octave)Function Index" nil + "^ -+ [^:]+:[ ]+\\(\\[[^=]*=[ ]+\\)?" nil) + ("(octave)Variable Index" nil "^ -+ [^:]+:[ ]+" nil) ("(octave)Operator Index" nil nil nil) - ;; Catch lines of the form "xyz statement" - ("(octave)Concept Index" - (lambda (item) - (cond - ((string-match "^\\([A-Z]+\\) statement\\b" item) - (match-string 1 item)) - (t nil))) - nil; "^ -+ [^:]+:[ ]+" don't think this prefix is useful here. - nil))) + ;; Catch lines of the form "xyz statement" + ("(octave)Concept Index" + ,(lambda (item) + (cond + ((string-match "^\\([A-Z]+\\) statement\\b" item) + (match-string 1 item)) + (t nil))) + nil; "^ -+ [^:]+:[ ]+" don't think this prefix is useful here. + nil))) (info-lookup-maybe-add-help :mode 'maxima-mode @@ -1163,7 +1171,7 @@ Return nil if there is nothing appropriate in the buffer near point." ;; bash has "." and ":" in its index, but those chars will probably never ;; work in info, so don't bother matching them in the regexp. :regexp "\\([a-zA-Z0-9_-]+\\|[!{}@*#?$]\\|\\[\\[?\\|]]?\\)" - :doc-spec '(("(bash)Builtin Index" nil "^['`‘]" "[ .'’]") + :doc-spec `(("(bash)Builtin Index" nil "^['`‘]" "[ .'’]") ("(bash)Reserved Word Index" nil "^['`‘]" "[ .'’]") ("(bash)Variable Index" nil "^['`‘]" "[ .'’]") @@ -1174,30 +1182,30 @@ Return nil if there is nothing appropriate in the buffer near point." ;; versions have node "Index", look for both, whichever is ;; absent is quietly ignored ("(coreutils)Index" - (lambda (item) (if (string-match "\\`[a-z]+\\'" item) item))) + ,(lambda (item) (if (string-match "\\`[a-z]+\\'" item) item))) ("(coreutils)Concept Index" - (lambda (item) (if (string-match "\\`[a-z]+\\'" item) item))) + ,(lambda (item) (if (string-match "\\`[a-z]+\\'" item) item))) ;; diff (version 2.8.1) has only a few programs, index entries ;; are things like "foo invocation". ("(diff)Index" - (lambda (item) - (if (string-match "\\`\\([a-z]+\\) invocation\\'" item) - (match-string 1 item)))) + ,(lambda (item) + (if (string-match "\\`\\([a-z]+\\) invocation\\'" item) + (match-string 1 item)))) ;; there's no plain "sed" index entry as such, mung another ;; hopefully unique one to get to the invocation section ("(sed)Concept Index" - (lambda (item) - (if (string-equal item "Standard input, processing as input") - "sed"))) + ,(lambda (item) + (if (string-equal item "Standard input, processing as input") + "sed"))) ;; there's no plain "awk" or "gawk" index entries, mung other ;; hopefully unique ones to get to the command line options ("(gawk)Index" - (lambda (item) - (cond ((string-equal item "gawk, extensions, disabling") - "awk") - ((string-equal item "gawk, versions of, information about, printing") - "gawk")))))) + ,(lambda (item) + (cond ((string-equal item "gawk, extensions, disabling") + "awk") + ((string-equal item "gawk, versions of, information about, printing") + "gawk")))))) ;; This misses some things which occur as node names but not in the ;; index. Unfortunately it also picks up the wrong one of multiple @@ -1205,22 +1213,22 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'cfengine-mode :regexp "[[:alnum:]_]+\\(?:()\\)?" - :doc-spec '(("(cfengine-Reference)Variable Index" - (lambda (item) - ;; Index entries may be like `IsPlain()' - (if (string-match "\\([[:alnum:]_]+\\)()" item) - (match-string 1 item) - item)) - ;; This gets functions in evaluated classes. Other - ;; possible patterns don't seem to work too well. - "['`‘]" "("))) + :doc-spec `(("(cfengine-Reference)Variable Index" + ,(lambda (item) + ;; Index entries may be like `IsPlain()' + (if (string-match "\\([[:alnum:]_]+\\)()" item) + (match-string 1 item) + item)) + ;; This gets functions in evaluated classes. Other + ;; possible patterns don't seem to work too well. + "['`‘]" "("))) (info-lookup-maybe-add-help :mode 'Custom-mode :ignore-case t :regexp "[^][()`'‘’,:\" \t\n]+" :parse-rule (lambda () - (when-let ((symbol (get-text-property (point) 'custom-data))) + (when-let* ((symbol (get-text-property (point) 'custom-data))) (symbol-name symbol))) :other-modes '(emacs-lisp-mode)) diff --git a/lisp/info.el b/lisp/info.el index d151c6365b8..9025fd13363 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -223,7 +223,7 @@ These directories are searched after those in `Info-directory-list'." "org" "pcl-cvs" "pgg" "rcirc" "reftex" "remember" "sasl" "sc" "semantic" "ses" "sieve" "smtpmail" "speedbar" "srecode" "todo-mode" "tramp" "transient" "url" "use-package" "vhdl-mode" - "vip" "viper" "vtable" "widget" "wisent" "woman") . + "viper" "vtable" "widget" "wisent" "woman") . "https://www.gnu.org/software/emacs/manual/html_node/%m/%e")) "Alist telling `Info-mode' where manuals are accessible online. @@ -667,7 +667,7 @@ in `Info-file-supports-index-cookies-list'." (goto-char (point-min)) (condition-case () (if (and (re-search-forward - "makeinfo[ \n]version[ \n]\\([0-9]+.[0-9]+\\)" + "\\(?:makeinfo\\|texi2any\\)[ \n]version[ \n]\\([0-9]+.[0-9]+\\)" (line-beginning-position 4) t) (not (version< (match-string 1) "4.7"))) (setq found t)) @@ -823,10 +823,10 @@ Select the window used, if it has been made." ;; If we just created the Info buffer, go to the directory. (Info-directory)))) - (when-let ((window (display-buffer buffer - (if other-window - '(nil (inhibit-same-window . t)) - '(display-buffer-same-window))))) + (when-let* ((window (display-buffer buffer + (if other-window + '(nil (inhibit-same-window . t)) + '(display-buffer-same-window))))) (select-window window)))) @@ -1032,6 +1032,48 @@ If NOERROR, inhibit error messages when we can't find the node." Info-history)) (Info-find-node-2 filename nodename no-going-back strict-case)) +(defun Info--record-tag-table (nodename) + "If the current Info file has a tag table, record its location for NODENAME. + +This creates a tag-table buffer, sets `Info-tag-table-buffer' to +name that buffer, and records the buffer and the tag table in +the marker `Info-tag-table-buffer'. If the Info file has no +tag table, or if NODENAME is \"*\", the function sets the marker +to nil to indicate the tag table is not available/relevant. + +The function assumes that the Info buffer is widened, and does +not preserve point." + (goto-char (point-max)) + (forward-line -8) + ;; Use string-equal, not equal, to ignore text props. + (if (not (or (string-equal nodename "*") + (not + (search-forward "\^_\nEnd tag table\n" nil t)))) + (let (pos) + ;; We have a tag table. Find its beginning. + ;; Is this an indirect file? + (search-backward "\nTag table:\n") + (setq pos (point)) + (if (save-excursion + (forward-line 2) + (looking-at "(Indirect)\n")) + ;; It is indirect. Copy it to another buffer + ;; and record that the tag table is in that buffer. + (let ((buf (current-buffer)) + (tagbuf + (or Info-tag-table-buffer + (generate-new-buffer " *info tag table*")))) + (setq Info-tag-table-buffer tagbuf) + (with-current-buffer tagbuf + (buffer-disable-undo (current-buffer)) + (setq case-fold-search t) + (erase-buffer) + (insert-buffer-substring buf)) + (set-marker Info-tag-table-marker + (match-end 0) tagbuf)) + (set-marker Info-tag-table-marker pos))) + (set-marker Info-tag-table-marker nil))) + ;;;###autoload (defun Info-on-current-buffer (&optional nodename) "Use Info mode to browse the current Info buffer. @@ -1048,6 +1090,7 @@ otherwise, that defaults to `Top'." (or buffer-file-name ;; If called on a non-file buffer, make a fake file name. (concat default-directory (buffer-name)))) + (Info--record-tag-table nodename) (Info-find-node-2 nil nodename)) (defun Info-revert-find-node (filename nodename) @@ -1210,36 +1253,7 @@ is non-nil)." (Info-file-supports-index-cookies filename)) ;; See whether file has a tag table. Record the location if yes. - (goto-char (point-max)) - (forward-line -8) - ;; Use string-equal, not equal, to ignore text props. - (if (not (or (string-equal nodename "*") - (not - (search-forward "\^_\nEnd tag table\n" nil t)))) - (let (pos) - ;; We have a tag table. Find its beginning. - ;; Is this an indirect file? - (search-backward "\nTag table:\n") - (setq pos (point)) - (if (save-excursion - (forward-line 2) - (looking-at "(Indirect)\n")) - ;; It is indirect. Copy it to another buffer - ;; and record that the tag table is in that buffer. - (let ((buf (current-buffer)) - (tagbuf - (or Info-tag-table-buffer - (generate-new-buffer " *info tag table*")))) - (setq Info-tag-table-buffer tagbuf) - (with-current-buffer tagbuf - (buffer-disable-undo (current-buffer)) - (setq case-fold-search t) - (erase-buffer) - (insert-buffer-substring buf)) - (set-marker Info-tag-table-marker - (match-end 0) tagbuf)) - (set-marker Info-tag-table-marker pos))) - (set-marker Info-tag-table-marker nil)) + (Info--record-tag-table nodename) (setq Info-current-file filename) ))) @@ -2006,7 +2020,7 @@ See `completing-read' for a description of arguments and usage." (lambda (string pred action) (complete-with-action action - (when-let ((file2 (Info-find-file file1 'noerror t))) + (when-let* ((file2 (Info-find-file file1 'noerror t))) (Info-build-node-completions file2)) string pred)) nodename predicate code)))) @@ -4661,7 +4675,7 @@ Advanced commands: (defvar Info-file-list-for-emacs '("ediff" "eudc" "forms" "gnus" "info" ("Info" . "info") ("mh" . "mh-e") - "sc" "message" ("dired" . "dired-x") "viper" "vip" "idlwave" + "sc" "message" ("dired" . "dired-x") "viper" "idlwave" ("c" . "ccmode") ("c++" . "ccmode") ("objc" . "ccmode") ("java" . "ccmode") ("idl" . "ccmode") ("pike" . "ccmode") ("skeleton" . "autotype") ("auto-insert" . "autotype") diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 1e5963f89f3..44293b033c7 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -849,6 +849,19 @@ with L, LRE, or LRO Unicode bidi character type.") ;; Fixme: syntax for symbols &c ) + +;; Symbols and digits +;;; Each character whose script is 'symbol' gets the symbol category, +;;; see charscript.el. +;;; Each character whose Unicode general-category is Nd gets the digit +;;; category: +(let ((table (unicode-property-table-internal 'general-category))) + (when table + (map-char-table (lambda (key val) + (if (eq val 'Nd) + (modify-category-entry key ?6))) + table))) + (let ((pairs '("⁅⁆" ; U+2045 U+2046 "⁽⁾" ; U+207D U+207E @@ -1181,7 +1194,9 @@ with L, LRE, or LRO Unicode bidi character type.") (#x10A01 . #x10A0F) (#x10A38 . #x10A3F) (#x10AE5 . #x10AE6) + (#x10D69 . #x10D6D) (#x10EAB . #x10EAC) + (#x10EFC . #x10EFF) (#x11001 . #x11001) (#x11038 . #x11046) (#x1107F . #x11081) @@ -1207,6 +1222,11 @@ with L, LRE, or LRO Unicode bidi character type.") (#x11340 . #x11340) (#x11366 . #x1136C) (#x11370 . #x11374) + (#x113BB . #x113C0) + (#x113CE . #x113CE) + (#x113D0 . #x113D0) + (#x113D2 . #x113D2) + (#x113E1 . #x113E2) (#x11438 . #x1143F) (#x11442 . #x11444) (#x11446 . #x11446) @@ -1236,12 +1256,18 @@ with L, LRE, or LRO Unicode bidi character type.") (#x11CAA . #x11CB0) (#x11CB2 . #x11CB3) (#x11CB5 . #x11CB6) + (#x11F5A . #x11F5A) + (#x13430 . #x13440) + (#x13447 . #x13455) + (#x1611E . #x16129) + (#x1612D . #x1612F) (#x16AF0 . #x16AF4) (#x16B30 . #x16B36) (#x16F8F . #x16F92) (#x16FE4 . #x16FE4) (#x1BC9D . #x1BC9E) (#x1BCA0 . #x1BCA3) + (#x1CF00 . #x1CF02) (#x1D167 . #x1D169) (#x1D173 . #x1D182) (#x1D185 . #x1D18B) @@ -1258,6 +1284,7 @@ with L, LRE, or LRO Unicode bidi character type.") (#x1E01B . #x1E021) (#x1E023 . #x1E024) (#x1E026 . #x1E02A) + (#x1E5EE . #x1E5EF) (#x1E8D0 . #x1E8D6) (#x1E944 . #x1E94A) (#xE0001 . #xE01EF)))) @@ -1273,8 +1300,10 @@ with L, LRE, or LRO Unicode bidi character type.") (#x23F3 . #x23F3) (#x25FD . #x25FE) (#x2614 . #x2615) + (#x2630 . #x2637) (#x2648 . #x2653) (#x267F . #x267F) + (#x268A . #x268F) (#x2693 . #x2693) (#x26A1 . #x26A1) (#x26AA . #x26AB) @@ -1308,7 +1337,7 @@ with L, LRE, or LRO Unicode bidi character type.") (#x3041 . #x3096) (#x3099 . #x30FF) (#x3105 . #x312F) - (#x3131 . #x31E3) + (#x3131 . #x31E5) (#x31EF . #x31EF) (#x31F0 . #x3247) (#x3250 . #x4DBF) @@ -1326,6 +1355,7 @@ with L, LRE, or LRO Unicode bidi character type.") (#x17000 . #x187F7) (#x18800 . #x18AFF) (#x18B00 . #x18CD5) + (#x18CFF . #x18CFF) (#x18D00 . #x18D08) (#x1AFF0 . #x1AFF3) (#x1AFF5 . #x1AFFB) @@ -1336,6 +1366,8 @@ with L, LRE, or LRO Unicode bidi character type.") (#x1B155 . #x1B155) (#x1B164 . #x1B167) (#x1B170 . #x1B2FB) + (#x1D300 . #x1D356) + (#x1D360 . #x1D376) (#x1F004 . #x1F004) (#x1F0CF . #x1F0CF) (#x1F18E . #x1F18E) @@ -1383,11 +1415,10 @@ with L, LRE, or LRO Unicode bidi character type.") (#x1FA60 . #x1FA6D) (#x1FA70 . #x1FA74) (#x1FA78 . #x1FA7C) - (#x1FA80 . #x1FA88) - (#x1FA90 . #x1FABD) - (#x1FABF . #x1FAC5) - (#x1FACE . #x1FADB) - (#x1FAE0 . #x1FAE8) + (#x1FA80 . #x1FA89) + (#x1FA8F . #x1FAC6) + (#x1FACE . #x1FADC) + (#x1FADF . #x1FAE9) (#x1FAF0 . #x1FAF8) (#x1FB00 . #x1FB92) (#x20000 . #x2FFFF) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el index e8cd869a571..7ede6ac8058 100644 --- a/lisp/international/emoji.el +++ b/lisp/international/emoji.el @@ -328,14 +328,14 @@ the name is not known." (let ((glyph (cadr alist))) ;; Store all the emojis for later retrieval by ;; the search feature. - (when-let ((name (emoji--name glyph))) + (when-let* ((name (emoji--name glyph))) (setf (gethash (downcase name) emoji--all-bases) glyph)) (if (display-graphic-p) ;; Remove glyphs we don't have in graphical displays. (if (let ((char (elt glyph 0))) (if emoji--font (font-has-char-p emoji--font char) - (when-let ((font (car (internal-char-font nil char)))) + (when-let* ((font (car (internal-char-font nil char)))) (setq emoji--font font)))) (setq alist (cdr alist)) ;; Remove the element. @@ -575,7 +575,7 @@ the name is not known." (setq recent (delete glyph recent)) (push glyph recent) ;; Shorten the list. - (when-let ((tail (nthcdr 30 recent))) + (when-let* ((tail (nthcdr 30 recent))) (setcdr tail nil)) (setf (multisession-value emoji--recent) recent))) diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index b52ac1994c2..9743782a672 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -88,6 +88,7 @@ ("iso10646-1$" . (unicode-bmp . nil)) ("iso10646.indian-1" . (unicode-bmp . nil)) ("unicode-bmp" . (unicode-bmp . nil)) + ("unicode-sip" . (unicode-sip . nil)) ; used by w32font.c ("abobe-symbol" . symbol) ("sisheng_cwnn" . chinese-sisheng) ("mulearabic-0" . arabic-digit) @@ -199,6 +200,7 @@ (tai-tham #x1A20 #x1A55 #x1A61 #x1A80) (symbol . [#x201C #x2200 #x2500]) (braille #x2800) + (tifinagh #x2D30 #x2D60) (ideographic-description #x2FF0) ;; Noto Sans Phags Pa is broken and reuses the CJK misc code ;; points for some of its own characters. Add one actual CJK @@ -207,7 +209,7 @@ (kana #x304B) (bopomofo #x3105) (kanbun #x319D) - (han #x5B57) + (han #x3410 #x4e10 #x5B57 #xfe30 #xf900) (yi #xA288) (syloti-nagri #xA807 #xA823 #xA82C) (rejang #xA930 #xA947 #xA95F) @@ -235,6 +237,7 @@ (elbasan #x10500) (caucasian-albanian #x10530) (vithkuqi #x10570) + (todhri #x105C0 #x105ED) (linear-a #x10600) (cypriot-syllabary #x10800) (palmyrene #x10860) @@ -244,6 +247,7 @@ (kharoshthi #x10A00) (manichaean #x10AC0) (hanifi-rohingya #x10D00 #x10D24 #x10D39) + (garay #x10D50 #x10D70 #x10D4A #x10D41) (yezidi #x10E80) (old-sogdian #x10F00) (sogdian #x10F30) @@ -257,6 +261,7 @@ (khojki #x11200) (khudawadi #x112B0) (grantha #x11315 #x1133E #x11374) + (tulu-tigalari #x11380 #x113B8) (newa #x11400) (tirhuta #x11481 #x1148F #x114D0) (siddham #x1158E #x115AF #x115D4) @@ -269,6 +274,7 @@ (zanabazar-square #x11A00) (soyombo #x11A50) (pau-cin-hau #x11AC0) + (sunuwar #x11BC0 #x11BF1) (bhaiksuki #x11C00) (marchen #x11C72) (masaram-gondi #x11D00) @@ -278,10 +284,12 @@ (cuneiform #x12000) (cypro-minoan #x12F90) (egyptian #x13000) + (gurung-khema #x16100 #x1611E #x16131) (mro #x16A40) (tangsa #x16A70 #x16AC0) (bassa-vah #x16AD0) (pahawh-hmong #x16B11) + (kirat-rai #x16D43 #x16D63 #x16D71) (medefaidrin #x16E40) (tangut #x17000) (khitan-small-script #x18B00) @@ -298,6 +306,7 @@ (toto #x1E290 #x1E295 #x1E2AD) (wancho #x1E2C0 #x1E2E8 #x1E2EF) (nag-mundari #x1E4D0 #x1E4EB #x1E4F0) + (ol-onal #x1E5D0 #x1E5F2) (mende-kikakui #x1E810 #x1E8A6) (adlam #x1E900 #x1E943) (indic-siyaq-number #x1EC71 #x1EC9F) @@ -309,7 +318,7 @@ (defvar otf-script-alist) -;; The below was synchronized with the latest Sep 12, 2021 version of +;; The below was synchronized with the latest May 31, 2024 version of ;; https://docs.microsoft.com/en-us/typography/opentype/spec/scripttags (setq otf-script-alist '((adlm . adlam) @@ -354,6 +363,7 @@ (elba . elbasan) (elym . elymaic) (ethi . ethiopic) + (gara . garay) (geor . georgian) (glag . glagolitic) (goth . gothic) @@ -364,6 +374,7 @@ (gong . gunjala-gondi) (guru . gurmukhi) (gur2 . gurmukhi) + (gukh . gurung-khema) (hani . han) (hang . hangul) (jamo . hangul) ; Not recommended; use 'hang' instead. @@ -386,6 +397,7 @@ (khmr . khmer) (khoj . khojki) (sind . khudawadi) + (krai . kirat-rai) (lao\ . lao) (latn . latin) (lepc . lepcha) @@ -426,6 +438,7 @@ (hmnp . nyiakeng-puachue-hmong) (ogam . ogham) (olck . ol-chiki) + (omao . ol-onal) (ital . old-italic) (xpeo . old-persian) (narb . old-north-arabian) @@ -459,6 +472,7 @@ (sora . sora-sompeng) (soyo . soyombo) (sund . sundanese) + (sunu . sunuwar) (sylo . syloti-nagri) (syrc . syriac) (tglg . tagalog) @@ -479,7 +493,9 @@ (tibt . tibetan) (tfng . tifinagh) (tirh . tirhuta) + (todr . todhri) (toto . toto) + (tutg . tulu-tigalari) (ugar . ugaritic) (vith . vithkuqi) (vai\ . vai) @@ -852,6 +868,17 @@ pahawh-hmong medefaidrin znamenny-musical-notation + khudawadi + khojki + mahajani + sogdian + old-sogdian + nabataean + palmyrene + linear-a + linear-b + caucasian-albanian + elbasan byzantine-musical-symbol musical-symbol ancient-greek-musical-notation @@ -862,14 +889,26 @@ wancho nag-mundari mende-kikakui + nyiakeng-puachue-hmong + mro + masaram-gondi + pau-cin-hau + soyombo + zanabazar-square + warang-citi + dogra + takri adlam + tifinagh tai-tham indic-siyaq-number ottoman-siyaq-number mahjong-tile domino-tile emoji - chess-symbol)) + chess-symbol + garay + sunuwar)) (set-fontset-font "fontset-default" script (font-spec :registry "iso10646-1" :script script) nil 'append)) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 42b4f0034f1..cefb6ddf9da 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -3108,10 +3108,11 @@ on encoding." ;; (#x4E00 . #x9FFF) CJK Unified Ideographs (#xA000 . #xD7FF) ;; (#xD800 . #xF8FF) Surrogate/Private - (#xFB00 . #x134FF) - ;; (#x13500 . #x143FF) unused + (#xFB00 . #x143FA) (#x14400 . #x14646) - ;; (#x14647 . #x167FF) unused + ;; (#x14647 . #x160FF) unused + (#x16100 . #x16139) + ;; (#x1613A . #x167FF) unused (#x16800 . #x16F9F) (#x16FE0 . #x16FF1) ;; (#x17000 . #x187FF) Tangut Ideographs @@ -3127,8 +3128,8 @@ on encoding." (#x1B170 . #x1B2FF) ;; (#x1B300 . #x1BBFF) unused (#x1BC00 . #x1BCAF) - ;; (#x1BCB0 . #x1CEFF) unused - (#x1CF00 . #x1FFFF) + ;; (#x1BCB0 . #x1CBFF) unused + (#x1CC00 . #x1FFFF) ;; (#x20000 . #xDFFFF) CJK Ideograph Extension A, B, etc, unused (#xE0000 . #xE01FF))) (gc-cons-threshold (max gc-cons-threshold 10000000)) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index 48d2ccb8828..cb7aa89b252 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -1334,9 +1334,13 @@ If STR has `advice' text property, append the following special event: (quail-setup-overlays (quail-conversion-keymap)) (with-silent-modifications (unwind-protect - (let ((input-string (if (quail-conversion-keymap) + (let* (;; `with-silent-modifications' inhibits the modification + ;; hooks, but that's a part of `with-silent-modifications' + ;; we don't actually want here (bug#70541). + (inhibit-modification-hooks nil) + (input-string (if (quail-conversion-keymap) (quail-start-conversion key) - (quail-start-translation key)))) + (quail-start-translation key)))) (setq quail-guidance-str "") (when (and (stringp input-string) (> (length input-string) 0)) @@ -1871,10 +1875,9 @@ sequence counting from the head." (defsubst quail-point-in-conversion-region () "Return non-nil value if the point is in conversion region of Quail mode." - (let (start pos) - (and (setq start (overlay-start quail-conv-overlay)) - (>= (setq pos (point)) start) - (<= pos (overlay-end quail-conv-overlay))))) + (let ((start (overlay-start quail-conv-overlay))) + (and start + (<= start (point) (overlay-end quail-conv-overlay))))) (defun quail-conversion-backward-char () (interactive) diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index ccb2022375c..94712a92bf7 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -142,7 +142,8 @@ (defvar check-range nil) (setq check-range '((#x00A0 . #x3400) (#xA600 . #xAC00) (#xF900 . #x11100) - (#x11100 . #x11A00) (#x1D000 . #x1E100) (#x1EE00 . #x1F300) + (#x11100 . #x11A00) (#x16100 . #x16DFF) (#x1CCD0 . #x1CCFF) + (#x1D000 . #x1E100) (#x1EE00 . #x1F300) (#x1FBF0 . #x1FC00) (#x2F800 . #x2FB00))) ;; Basic normalization functions diff --git a/lisp/international/utf7.el b/lisp/international/utf7.el index 63009b0744a..2b23bee1038 100644 --- a/lisp/international/utf7.el +++ b/lisp/international/utf7.el @@ -63,7 +63,6 @@ ;;; Code: -(require 'base64) (require 'mm-util) (defconst utf7-direct-encoding-chars " -%'-*,-[]-}" diff --git a/lisp/isearch.el b/lisp/isearch.el index dc9edf267f2..315fd36cfea 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -972,6 +972,7 @@ Each element is an `isearch--state' struct where the slots are ;; The value of input-method-function when isearch is invoked. (defvar isearch-input-method-function nil) +(defvar isearch--saved-local-map nil) (defvar isearch--saved-overriding-local-map nil) ;; Minor-mode-alist changes - kind of redundant with the @@ -1321,6 +1322,7 @@ used to set the value of `isearch-regexp-function'." (setq isearch-mode " Isearch") ;; forward? regexp? (force-mode-line-update) + (setq isearch--saved-local-map overriding-terminal-local-map) (setq overriding-terminal-local-map isearch-mode-map) (run-hooks 'isearch-mode-hook) ;; Remember the initial map possibly modified @@ -1337,6 +1339,7 @@ used to set the value of `isearch-regexp-function'." (add-hook 'pre-command-hook 'isearch-pre-command-hook) (add-hook 'post-command-hook 'isearch-post-command-hook) (add-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer) + (add-hook 'delete-frame-functions 'isearch-done) (add-hook 'kbd-macro-termination-hook 'isearch-done) ;; If the keyboard is not up and the last event did not come from @@ -1439,10 +1442,12 @@ The last thing is to trigger a new round of lazy highlighting." (defun isearch-done (&optional nopush edit) "Exit Isearch mode. +Called by all commands that terminate isearch-mode. For successful search, pass no args. For a failing search, NOPUSH is t. For going to the minibuffer to edit the search string, -NOPUSH is t and EDIT is t." +NOPUSH is t and EDIT is t. +If NOPUSH is non-nil, we don't push the string on the search ring." (when isearch-resume-in-command-history (add-to-history 'command-history @@ -1454,15 +1459,14 @@ NOPUSH is t and EDIT is t." (remove-hook 'pre-command-hook 'isearch-pre-command-hook) (remove-hook 'post-command-hook 'isearch-post-command-hook) (remove-hook 'mouse-leave-buffer-hook 'isearch-mouse-leave-buffer) + (remove-hook 'delete-frame-functions 'isearch-done) (remove-hook 'kbd-macro-termination-hook 'isearch-done) (when (buffer-live-p isearch--current-buffer) (with-current-buffer isearch--current-buffer (setq isearch--current-buffer nil) (setq cursor-sensor-inhibit (delq 'isearch cursor-sensor-inhibit)))) - ;; Called by all commands that terminate isearch-mode. - ;; If NOPUSH is non-nil, we don't push the string on the search ring. - (setq overriding-terminal-local-map nil) + (setq overriding-terminal-local-map isearch--saved-local-map) ;; (setq pre-command-hook isearch-old-pre-command-hook) ; for lemacs (setq minibuffer-message-timeout isearch-original-minibuffer-message-timeout) (isearch-dehighlight) @@ -2676,7 +2680,7 @@ Otherwise invoke whatever the calling mouse-2 command sequence is bound to outside of Isearch." (interactive "e") (let ((w (posn-window (event-start click))) - (binding (let ((overriding-terminal-local-map nil) + (binding (let ((overriding-terminal-local-map isearch--saved-local-map) ;; Key search depends on mode (bug#47755) (isearch-mode nil)) (key-binding (this-command-keys-vector) t)))) diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el index ced998fafb6..7e502f02b3c 100644 --- a/lisp/jka-cmpr-hook.el +++ b/lisp/jka-cmpr-hook.el @@ -160,8 +160,8 @@ and `inhibit-local-variables-suffixes'." (append auto-mode-alist jka-compr-mode-alist-additions)) ;; Make sure that (load "foo") will find /bla/foo.el.gz. - (setq load-file-rep-suffixes - (append load-file-rep-suffixes jka-compr-load-suffixes nil))) + (dolist (suff jka-compr-load-suffixes load-file-rep-suffixes) + (add-to-list 'load-file-rep-suffixes suff t))) (defun jka-compr-installed-p () "Return non-nil if jka-compr is installed. @@ -379,14 +379,14 @@ compressed when writing." "Evaluate BODY with automatic file compression and uncompression enabled." (declare (indent 0)) (let ((already-installed (make-symbol "already-installed"))) - `(let ((,already-installed (jka-compr-installed-p))) + `(let ((,already-installed auto-compression-mode)) (unwind-protect (progn (unless ,already-installed - (jka-compr-install)) + (auto-compression-mode 1)) ,@body) (unless ,already-installed - (jka-compr-uninstall)))))) + (auto-compression-mode -1)))))) ;; This is what we need to know about jka-compr-handler ;; in order to decide when to call it. diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 4971e13fae3..7a53f3fc108 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -667,7 +667,7 @@ and delete the network process." (defun jsonrpc--call-deferred (connection) "Call CONNECTION's deferred actions, who may again defer themselves." - (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) + (when-let* ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) (jsonrpc--event connection 'internal :log-text (format "re-attempting deferred requests %s" @@ -698,7 +698,7 @@ and delete the network process." (jsonrpc--continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) - (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) + (when-let* ((p (slot-value connection '-autoport-inferior))) (delete-process p)) (funcall (jsonrpc--on-shutdown connection) connection))))) (defvar jsonrpc--in-process-filter nil @@ -816,7 +816,7 @@ Also cancel \"deferred actions\" if DEFERRED-SPEC. Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" (with-slots ((conts -continuations) (defs -deferred-actions)) conn (if deferred-spec (remhash deferred-spec defs)) - (when-let ((ass (assq id conts))) + (when-let* ((ass (assq id conts))) (cl-destructuring-bind (_ _ _ _ timer) ass (when timer (cancel-timer timer))) (setf conts (delete ass conts)) diff --git a/lisp/keymap.el b/lisp/keymap.el index 861d6724c9e..43c8d918ba7 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -392,9 +392,16 @@ This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it. Both FROM and TO should be specified by strings that satisfy `key-valid-p'. -If TO is nil, remove any existing translation for FROM." +If TO is nil, remove any existing translation for FROM. + +Interactively, prompt for FROM and TO with `read-char'." (declare (compiler-macro (lambda (form) (keymap--compile-check from to) form))) + ;; Using `key-description' is a necessary evil here, so that the + ;; values can be passed to keymap-* functions, even though those + ;; functions immediately undo it with `key-parse'. + (interactive `(,(key-description `[,(read-char "From: ")]) + ,(key-description `[,(read-char "To: ")]))) (keymap--check from) (when to (keymap--check to)) @@ -417,6 +424,56 @@ If TO is nil, remove any existing translation for FROM." (aref from-key 0) (and to (aref to-key 0))))) +(defun key-translate-select () + "Prompt for a current keyboard translation pair with `completing-read'. + +Each pair is formatted as \"FROM -> TO\". + +Return the \"FROM\" as a key string." + (let* ((formatted-trans-alist nil) + ;; Alignment helpers + (pad 0) + (key-code-func + (lambda (kc trans) + (let* ((desc (key-description `[,kc])) + (len (length desc))) + (when (> len pad) + (setq pad len)) + (push + `(,desc . ,(key-description `[,trans])) + formatted-trans-alist)))) + (format-func + (lambda (pair) ;; (key . value) + (format + "%s -> %s" + (string-pad (key-description `[,(car pair)]) pad) + (key-description `[,(cdr pair)]))))) + ;; Set `pad' and `formatted-trans-alist' + (map-char-table + (lambda (chr trans) + (if (characterp chr) + (funcall key-code-func chr trans) + (require 'range) + (declare-function range-map "range" (func range)) + (range-map + (lambda (kc) (funcall key-code-func kc trans)) + chr))) + keyboard-translate-table) + (car + (split-string + (completing-read + "Key Translation: " + (mapcar format-func formatted-trans-alist) + nil t))))) + +(defun key-translate-remove (from) + "Remove translation of FROM from `keyboard-translate-table'. + +FROM must satisfy `key-valid-p'. If FROM has no entry in +`keyboard-translate-table', this has no effect." + (interactive (list (key-translate-select))) + (key-translate from nil)) + (defun keymap-lookup (keymap key &optional accept-default no-remap position) "Return the binding for command KEY in KEYMAP. KEY is a string that satisfies `key-valid-p'. @@ -471,7 +528,7 @@ If optional argument ACCEPT-DEFAULT is non-nil, recognize default bindings; see the description of `keymap-lookup' for more details about this." (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) - (when-let ((map (current-local-map))) + (when-let* ((map (current-local-map))) (keymap-lookup map keys accept-default))) (defun keymap-global-lookup (keys &optional accept-default message) @@ -630,6 +687,7 @@ value can also be a property list with properties `:enter', `:exit' and `:hints', for example: :repeat (:enter (commands ...) :exit (commands ...) + :continue-only (commands ...) :hints ((command . \"hint\") ...)) `:enter' specifies the list of additional commands that only @@ -645,6 +703,10 @@ Specifying a list of commands is useful when those commands exist in this specific map, but should not have the `repeat-map' symbol property. +`:continue-only' specifies the list of commands that should not +enter `repeat-mode'. These command should only continue the +already activated repeating sequence. + `:hints' is a list of cons pairs where car is a command and cdr is a string that is displayed alongside of the repeatable key in the echo area. @@ -683,6 +745,10 @@ in the echo area. def) (dolist (def (plist-get repeat :enter)) (push `(put ',def 'repeat-map ',variable-name) props)) + (dolist (def (plist-get repeat :continue-only)) + (push `(put ',def 'repeat-continue-only + (cons ',variable-name (get ',def 'repeat-continue-only))) + props)) (while defs (pop defs) (setq def (pop defs)) diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el index 1de424252e8..74711f876ee 100644 --- a/lisp/language/misc-lang.el +++ b/lisp/language/misc-lang.el @@ -364,6 +364,19 @@ language environment.")) (vector "[\u1820-\u18AF\u202F\u180B-\u180F\u1807]+" 0 'font-shape-gstring))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tifinagh +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(set-language-info-alist + "Tifinagh" + '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "tifinagh") + (sample-text . "Tifinagh ⴰⵣⵓⵍ") + (documentation . "Tifinagh a script used to write the Berber languages.")) + '("Misc")) + (provide 'misc-lang) ;;; misc-lang.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 06797a17e18..648633004c9 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -2949,7 +2949,7 @@ and corresponding effects. ;;; Generated autoloads from progmodes/c-ts-common.el -(register-definition-prefixes "c-ts-common" '("c-ts-common-")) +(register-definition-prefixes "c-ts-common" '("c-ts-")) ;;; Generated autoloads from progmodes/c-ts-mode.el @@ -4247,6 +4247,7 @@ Returns non-nil if any false statements are found. (put 'checkdoc-spellcheck-documentation-flag 'safe-local-variable #'booleanp) (put 'checkdoc-ispell-list-words 'safe-local-variable #'list-of-strings-p) (put 'checkdoc-arguments-in-order-flag 'safe-local-variable #'booleanp) +(put 'checkdoc-package-keywords-flag 'safe-local-variable #'booleanp) (put 'checkdoc-verb-check-experimental-flag 'safe-local-variable #'booleanp) (put 'checkdoc-symbol-words 'safe-local-variable #'list-of-strings-p) (put 'checkdoc-proper-noun-regexp 'safe-local-variable 'stringp) @@ -4329,7 +4330,7 @@ Optional argument TAKE-NOTES causes all errors to be logged. Evaluate the current form with `eval-defun' and check its documentation. Evaluation is done first so the form will be read before the documentation is checked. If there is a documentation error, then the display -of what was evaluated will be overwritten by the diagnostic message." t) +of what was evaluated will be overwritten by the diagnostic message." '(emacs-lisp-mode)) (autoload 'checkdoc-defun "checkdoc" "\ Examine the doc string of the function or variable under point. Call `error' if the doc string has problems. If NO-ERROR is @@ -4337,7 +4338,7 @@ non-nil, then do not call error, but call `message' instead. If the doc string passes the test, then check the function for rogue white space at the end of each line. -(fn &optional NO-ERROR)" t) +(fn &optional NO-ERROR)" '(emacs-lisp-mode)) (autoload 'checkdoc-dired "checkdoc" "\ In Dired, run `checkdoc' on marked files. Skip anything that doesn't have the Emacs Lisp library file @@ -4406,7 +4407,7 @@ disabled. (fn &optional ARG)" t) (autoload 'checkdoc-package-keywords "checkdoc" "\ -Find package keywords that aren't in `finder-known-keywords'." t) +Find package keywords that aren't in `finder-known-keywords'." '(emacs-lisp-mode)) (register-definition-prefixes "checkdoc" '("checkdoc-")) @@ -4763,6 +4764,25 @@ displayed. If FRAME is omitted or nil, use the selected frame. If FRAME cannot display COLOR, return nil. (fn COLOR &optional FRAME)") +(autoload 'color-rgb-to-hex "color" "\ +Return hexadecimal #RGB notation for the color specified by RED GREEN BLUE. +RED, GREEN, and BLUE should be numbers between 0.0 and 1.0, inclusive. +Optional argument DIGITS-PER-COMPONENT can be either 4 (the default) +or 2; use the latter if you need a 24-bit specification of a color. + +(fn RED GREEN BLUE &optional DIGITS-PER-COMPONENT)") +(autoload 'color-blend "color" "\ +Blend the two colors A and B in linear space with ALPHA. +A and B should be lists (RED GREEN BLUE), where each element is +between 0.0 and 1.0, inclusive. ALPHA controls the influence A +has on the result and should be between 0.0 and 1.0, inclusive. + +For instance: + + (color-blend \\='(1 0.5 1) \\='(0 0 0) 0.75) + => (0.75 0.375 0.75) + +(fn A B &optional ALPHA)") (register-definition-prefixes "color" '("color-")) @@ -4889,17 +4909,23 @@ Search happens in `native-comp-eln-load-path'. (fn FILENAME)") (autoload 'native-compile "comp" "\ Compile FUNCTION-OR-FILE into native code. -This is the synchronous entry-point for the Emacs Lisp native -compiler. FUNCTION-OR-FILE is a function symbol, a form, or the -filename of an Emacs Lisp source file. If OUTPUT is non-nil, use -it as the filename for the compiled object. If FUNCTION-OR-FILE -is a filename, if the compilation was successful return the -filename of the compiled object. If FUNCTION-OR-FILE is a -function symbol or a form, if the compilation was successful -return the compiled function. +This is the synchronous entry-point for the Emacs Lisp native compiler. +FUNCTION-OR-FILE is a function symbol, a form, an interpreted-function, +or the filename of an Emacs Lisp source file. If OUTPUT is non-nil, use +it as the filename for the compiled object. If FUNCTION-OR-FILE is a +filename, if the compilation was successful return the filename of the +compiled object. If FUNCTION-OR-FILE is a function symbol or a form, if +the compilation was successful return the compiled function. (fn FUNCTION-OR-FILE &optional OUTPUT)") (function-put 'native-compile 'function-type '(function ((or string symbol) &optional string) (or native-comp-function string))) +(autoload 'native-compile-directory "comp" "\ +Native compile if necessary all the .el files present in DIRECTORY. +Each .el file is native-compiled if the corresponding .eln file is not +found in any directory mentioned in `native-comp-eln-load-path'. +The search within DIRECTORY is performed recursively. + +(fn DIRECTORY)") (autoload 'batch-native-compile "comp" "\ Perform batch native compilation of remaining command-line arguments. @@ -5148,6 +5174,13 @@ the function in `compilation-buffer-name-function', so you can set that to a function that generates a unique name. (fn COMMAND &optional COMINT)" t) +(autoload 'recompile "compile" "\ +Re-compile the program including the current buffer. +If this is run in a Compilation mode buffer, reuse the arguments from the +original use. Otherwise, recompile using `compile-command'. +If the optional argument `edit-command' is non-nil, the command can be edited. + +(fn &optional EDIT-COMMAND)" t) (autoload 'compilation--default-buffer-name "compile" "\ @@ -5213,8 +5246,6 @@ evaluate the variable `compilation-shell-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{compilation-shell-minor-mode-map} - (fn &optional ARG)" t) (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. @@ -5237,15 +5268,13 @@ evaluate the variable `compilation-minor-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{compilation-minor-mode-map} - (fn &optional ARG)" t) (autoload 'compilation-next-error-function "compile" "\ Advance to the next error message and visit the file where the error was. This is the value of `next-error-function' in Compilation buffers. (fn N &optional RESET)" t) -(register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation" "recompile")) +(register-definition-prefixes "compile" '("compil" "define-compilation-mode" "kill-compilation")) ;;; Generated autoloads from cedet/srecode/compile.el @@ -5386,6 +5415,11 @@ list.") (register-definition-prefixes "completion-preview" '("completion-preview-")) +;;; Generated autoloads from emacs-lisp/cond-star.el + +(register-definition-prefixes "cond-star" '("cond*" "match*")) + + ;;; Generated autoloads from textmodes/conf-mode.el (autoload 'conf-mode "conf-mode" "\ @@ -5757,7 +5791,7 @@ Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith CPerl knows several indentation styles, and may bulk set the corresponding variables. Use \\[cperl-set-style] to do this or -set the `cperl-file-style' user option. Use +set the variable `cperl-file-style' user option. Use \\[cperl-set-style-back] to restore the memorized preexisting values (both available from menu). See examples in `cperl-style-examples'. @@ -6956,6 +6990,29 @@ The mode's hook is called both when the mode is enabled and when it is disabled. (fn &optional ARG)" t) +(autoload 'delete-selection-local-mode "delsel" "\ +Toggle `delete-selection-mode' only in this buffer. + +For compatibility with features and packages that are aware of +`delete-selection-mode', this local mode sets the variable +`delete-selection-mode' in the current buffer as needed. + +This is a minor mode. If called interactively, toggle the +`Delete-Selection-Local mode' mode. If the prefix argument is positive, +enable the mode, and if it is zero or negative, disable the mode. + +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 `(buffer-local-value \\='delete-selection-mode +(current-buffer))'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) (autoload 'delete-active-region "delsel" "\ Delete the active region. If KILLP is non-nil, or if called interactively with a prefix argument, @@ -8817,7 +8874,7 @@ A second call of this function without changing point inserts the next match. A call with prefix PREFIX reads the symbol to insert from the minibuffer with completion. -(fn PREFIX)" t) +(fn PREFIX)" '("P")) (autoload 'ebrowse-tags-loop-continue "ebrowse" "\ Repeat last operation on files in tree. FIRST-TIME non-nil means this is not a repetition, but the first time. @@ -9502,7 +9559,7 @@ Turn on EDT Emulation." t) ;;; Generated autoloads from progmodes/eglot.el -(push (purecopy '(eglot 1 17 30)) package--builtin-versions) +(push (purecopy '(eglot 1 17)) package--builtin-versions) (define-obsolete-function-alias 'eglot-update #'eglot-upgrade-eglot "29.1") (autoload 'eglot "eglot" "\ Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES. @@ -9927,13 +9984,19 @@ displayed." t) (autoload 'eshell-execute-file "em-script" "\ Execute a series of Eshell commands in FILE, passing ARGS. -If DESTINATION is t, write the command output to the current buffer. If -nil, don't write the output anywhere. For any other value, output to -the corresponding Eshell target (see `eshell-get-target'). +If OUTPUT-TARGET is t (interactively, with the prefix argument), write +the command's standard output to the current buffer at point. If nil, +don't write the output anywhere. For any other value, output to that +Eshell target (see `eshell-get-target'). + +ERROR-TARGET is similar to OUTPUT-TARGET, except that it controls where +to write standard error, and a nil value means to write standard error +to the same place as standard output. (To suppress standard error, you +can write to the Eshell virtual target \"/dev/null\".) Comments begin with `#'. -(fn FILE &optional ARGS DESTINATION)") +(fn FILE &optional ARGS OUTPUT-TARGET ERROR-TARGET)" t) (autoload 'eshell-batch-file "em-script" "\ Execute an Eshell script as a batch script from the command line. Inside your Eshell script file, you can add the following at the @@ -10502,11 +10565,10 @@ Look at CONFIG and try to expand GROUP. ;;; Generated autoloads from erc/erc.el -(push (purecopy '(erc 5 6 0 30 1)) package--builtin-versions) +(push (purecopy '(erc 5 6 1 -4)) package--builtin-versions) (dolist (symbol '( erc-sasl erc-spelling ; 29 erc-imenu erc-nicks)) ; 30 (custom-add-load symbol symbol)) -(custom-autoload 'erc-modules "erc") (autoload 'erc-select-read-args "erc" "\ Prompt for connection parameters and return them in a plist. By default, collect `:server', `:port', `:nickname', and @@ -10552,7 +10614,7 @@ ERC assigns SERVER and FULL-NAME the associated keyword values and defers to `erc-compute-port', `erc-compute-user', and `erc-compute-nick' for those respective parameters. -(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" t) +(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" '((let ((erc--display-context `((erc-interactive-display . erc) ,@erc--display-context))) (erc-select-read-args)))) (defalias 'erc-select #'erc) (autoload 'erc-tls "erc" "\ Connect to an IRC server over a TLS-encrypted connection. @@ -10575,7 +10637,7 @@ See the alternative entry-point command `erc' as well as Info node `(erc) Connecting' for a fuller description of the various parameters, like ID. -(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" t) +(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" '((let ((erc-default-port erc-default-port-tls) (erc--display-context `((erc-interactive-display . erc-tls) ,@erc--display-context))) (erc-select-read-args)))) (autoload 'erc-handle-irc-url "erc" "\ Use ERC to IRC on HOST:PORT in CHANNEL. If ERC is already connected to HOST:PORT, simply /join CHANNEL. @@ -10807,9 +10869,7 @@ it has to be wrapped in `(eval (quote ...))'. If NAME is already defined as a test and Emacs is running in batch mode, an error is signaled. -(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t) -(function-put 'ert-deftest 'doc-string-elt 3) -(function-put 'ert-deftest 'lisp-indent-function 2) +(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil 'macro) (autoload 'ert-run-tests-batch "ert" "\ Run the tests specified by SELECTOR, printing results to the terminal. @@ -10986,10 +11046,22 @@ information on Eshell, see Info node `(eshell)Top'. (fn &optional ARG)" t) (autoload 'eshell-command "eshell" "\ Execute the Eshell command string COMMAND. -If TO-CURRENT-BUFFER is non-nil (interactively, with the prefix -argument), then insert output into the current buffer at point. - -(fn COMMAND &optional TO-CURRENT-BUFFER)" t) +If OUTPUT-TARGET is t (interactively, with the prefix argument), write +the command's standard output to the current buffer at point. If nil, +write the output to a new output buffer. For any other value, output to +that Eshell target (see `eshell-get-target'). + +ERROR-TARGET is similar to OUTPUT-TARGET, except that it controls where +to write standard error, and a nil value means to write standard error +to the same place as standard output. (To suppress standard error, you +can write to the Eshell virtual target \"/dev/null\".) + +When \"&\" is added at end of command, the command is async and its +output appears in a specific buffer. You can customize +`eshell-command-async-buffer' to specify what to do when this output +buffer is already taken by another running shell command. + +(fn COMMAND &optional OUTPUT-TARGET ERROR-TARGET)" t) (autoload 'eshell-command-result "eshell" "\ Execute the given Eshell COMMAND, and return the result. The result might be any Lisp object. @@ -11247,7 +11319,7 @@ For non-interactive use, this is superseded by `fileloop-initialize-replace'. (autoload 'list-tags "etags" "\ Display list of tags in file FILE. Interactively, prompt for FILE, with completion, offering the current -buffer's file name as the defaul. +buffer's file name as the default. This command searches only the first table in the list of tags tables, and does not search included tables. FILE should be as it was submitted to the `etags' command, which usually @@ -12458,9 +12530,14 @@ This command deletes all existing settings of VARIABLE (except `mode' and `eval') and adds a new file-local VARIABLE with VALUE to the Local Variables list. -If there is no Local Variables list in the current file buffer -then this function adds the first line containing the string -`Local Variables:' and the last line containing the string `End:'. +If there is no Local Variables list in the current file buffer, +then this function adds it at the end of the file, with the first +line containing the string `Local Variables:' and the last line +containing the string `End:'. + +For adding local variables on the first line of a file, for example +for settings like `lexical-binding, which must be specified there, +use the `add-file-local-variable-prop-line' command instead. (fn VARIABLE VALUE &optional INTERACTIVE)" t) (autoload 'delete-file-local-variable "files-x" "\ @@ -12472,11 +12549,14 @@ Add file-local VARIABLE with its VALUE to the -*- line. This command deletes all existing settings of VARIABLE (except `mode' and `eval') and adds a new file-local VARIABLE with VALUE to -the -*- line. +the -*- line at the beginning of the file. If there is no -*- line at the beginning of the current file buffer then this function adds it. +To add variables to the Local Variables list at the end of the file, +use the `add-file-local-variable' command instead. + (fn VARIABLE VALUE &optional INTERACTIVE)" t) (autoload 'delete-file-local-variable-prop-line "files-x" "\ Delete all settings of file-local VARIABLE from the -*- line. @@ -12972,8 +13052,34 @@ See `find-function-on-key'. Find directly the function at point in the other window." t) (autoload 'find-variable-at-point "find-func" "\ Find directly the variable at point in the other window." t) +(defvar find-function-mode nil "\ +Non-nil if Find-Function mode is enabled. +See the `find-function-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `find-function-mode'.") +(custom-autoload 'find-function-mode "find-func" nil) +(autoload 'find-function-mode "find-func" "\ +Enable some key bindings for the `find-function' family of functions. + +This is a global minor mode. If called interactively, toggle the +`Find-Function mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +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 \\='find-function-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) (autoload 'find-function-setup-keys "find-func" "\ -Define some key bindings for the `find-function' family of functions.") +Turn on `find-function-mode', which see.") (register-definition-prefixes "find-func" '("find-" "read-library-name--find-files")) @@ -13150,8 +13256,6 @@ evaluate the variable `flymake-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{flymake-mode-map} - (fn &optional ARG)" t) (autoload 'flymake-mode-on "flymake" "\ Turn Flymake mode on.") @@ -16855,8 +16959,7 @@ inlined into the compiled format versions. This means that if you change its definition, you should explicitly call `ibuffer-recompile-formats'. -(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil t) -(function-put 'define-ibuffer-column 'lisp-indent-function 'defun) +(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-sorter "ibuf-macs" "\ Define a method of sorting named NAME. DOCUMENTATION is the documentation of the function, which will be called @@ -16867,9 +16970,7 @@ For sorting, the forms in BODY will be evaluated with `a' bound to one buffer object, and `b' bound to another. BODY should return a non-nil value if and only if `a' is \"less than\" `b'. -(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil t) -(function-put 'define-ibuffer-sorter 'lisp-indent-function 1) -(function-put 'define-ibuffer-sorter 'doc-string-elt 2) +(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-op "ibuf-macs" "\ Generate a function which operates on a buffer. OP becomes the name of the function; if it doesn't begin with @@ -16908,9 +17009,7 @@ BODY define the operation; they are forms to evaluate per each marked buffer. BODY is evaluated with `buf' bound to the buffer object. -(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil t) -(function-put 'define-ibuffer-op 'lisp-indent-function 2) -(function-put 'define-ibuffer-op 'doc-string-elt 3) +(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING BEFORE AFTER COMPLEX) &rest BODY)" nil 'macro) (autoload 'define-ibuffer-filter "ibuf-macs" "\ Define a filter named NAME. DOCUMENTATION is the documentation of the function. @@ -16925,9 +17024,7 @@ not a particular buffer should be displayed or not. The forms in BODY will be evaluated with BUF bound to the buffer object, and QUALIFIER bound to the current value of the filter. -(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil t) -(function-put 'define-ibuffer-filter 'lisp-indent-function 2) -(function-put 'define-ibuffer-filter 'doc-string-elt 2) +(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)" nil 'macro) (register-definition-prefixes "ibuf-macs" '("ibuffer-")) @@ -17211,172 +17308,6 @@ Pop to a buffer to describe ICON. (register-definition-prefixes "semantic/idle" '("define-semantic-idle-service" "global-semantic-idle-summary-mode" "semantic-")) -;;; Generated autoloads from progmodes/idlw-complete-structtag.el - -(register-definition-prefixes "idlw-complete-structtag" '("idlwave-")) - - -;;; Generated autoloads from progmodes/idlw-help.el - -(register-definition-prefixes "idlw-help" '("idlwave-")) - - -;;; Generated autoloads from progmodes/idlw-shell.el - -(autoload 'idlwave-shell "idlw-shell" "\ -Run an inferior IDL, with I/O through buffer `(idlwave-shell-buffer)'. -If buffer exists but shell process is not running, start new IDL. -If buffer exists and shell process is running, just switch to the buffer. - -When called with a prefix ARG, or when `idlwave-shell-use-dedicated-frame' -is non-nil, the shell buffer and the source buffers will be in -separate frames. - -The command to run comes from variable `idlwave-shell-explicit-file-name', -with options taken from `idlwave-shell-command-line-options'. - -The buffer is put in `idlwave-shell-mode', providing commands for sending -input and controlling the IDL job. See help on `idlwave-shell-mode'. -See also the variable `idlwave-shell-prompt-pattern'. - -(Type \\[describe-mode] in the shell buffer for a list of commands.) - -(fn &optional ARG)" t) -(register-definition-prefixes "idlw-shell" '("idlwave-")) - - -;;; Generated autoloads from progmodes/idlw-toolbar.el - -(register-definition-prefixes "idlw-toolbar" '("idlwave-toolbar")) - - -;;; Generated autoloads from progmodes/idlwave.el - -(push (purecopy '(idlwave 6 1 22)) package--builtin-versions) -(autoload 'idlwave-mode "idlwave" "\ -Major mode for editing IDL source files (version 6.1_em22). - -The main features of this mode are - -1. Indentation and Formatting - -------------------------- - Like other Emacs programming modes, C-j inserts a newline and indents. - TAB is used for explicit indentation of the current line. - - To start a continuation line, use \\[idlwave-split-line]. This - function can also be used in the middle of a line to split the line - at that point. When used inside a long constant string, the string - is split at that point with the `+' concatenation operator. - - Comments are indented as follows: - - `;;;' Indentation remains unchanged. - `;;' Indent like the surrounding code - `;' Indent to a minimum column. - - The indentation of comments starting in column 0 is never changed. - - Use \\[idlwave-fill-paragraph] to refill a paragraph inside a - comment. The indentation of the second line of the paragraph - relative to the first will be retained. Use - \\[auto-fill-mode] to toggle auto-fill mode for these - comments. When the variable `idlwave-fill-comment-line-only' is - nil, code can also be auto-filled and auto-indented. - - To convert pre-existing IDL code to your formatting style, mark the - entire buffer with \\[mark-whole-buffer] and execute - \\[idlwave-expand-region-abbrevs]. Then mark the entire buffer - again followed by \\[indent-region] (`indent-region'). - -2. Routine Info - ------------ - IDLWAVE displays information about the calling sequence and the - accepted keyword parameters of a procedure or function with - \\[idlwave-routine-info]. \\[idlwave-find-module] jumps to the - source file of a module. These commands know about system - routines, all routines in idlwave-mode buffers and (when the - idlwave-shell is active) about all modules currently compiled under - this shell. It also makes use of pre-compiled or custom-scanned - user and library catalogs many popular libraries ship with by - default. Use \\[idlwave-update-routine-info] to update this - information, which is also used for completion (see item 4). - -3. Online IDL Help - --------------- - - \\[idlwave-context-help] displays the IDL documentation relevant - for the system variable, keyword, or routines at point. A single - key stroke gets you directly to the right place in the docs. See - the manual to configure where and how the HTML help is displayed. - -4. Completion - ---------- - \\[idlwave-complete] completes the names of procedures, functions - class names, keyword parameters, system variables and tags, class - tags, structure tags, filenames and much more. It is context - sensitive and figures out what is expected at point. Lower case - strings are completed in lower case, other strings in mixed or - upper case. - -5. Code Templates and Abbreviations - -------------------------------- - Many Abbreviations are predefined to expand to code fragments and templates. - The abbreviations start generally with a `\\'. Some examples: - - \\pr PROCEDURE template - \\fu FUNCTION template - \\c CASE statement template - \\sw SWITCH statement template - \\f FOR loop template - \\r REPEAT Loop template - \\w WHILE loop template - \\i IF statement template - \\elif IF-ELSE statement template - \\b BEGIN - - For a full list, use \\[idlwave-list-abbrevs]. Some templates also - have direct keybindings - see the list of keybindings below. - - \\[idlwave-doc-header] inserts a documentation header at the - beginning of the current program unit (pro, function or main). - Change log entries can be added to the current program unit with - \\[idlwave-doc-modification]. - -6. Automatic Case Conversion - ------------------------- - The case of reserved words and some abbrevs is controlled by - `idlwave-reserved-word-upcase' and `idlwave-abbrev-change-case'. - -7. Automatic END completion - ------------------------ - If the variable `idlwave-expand-generic-end' is non-nil, each END typed - will be converted to the specific version, like ENDIF, ENDFOR, etc. - -8. Hooks - ----- - Turning on `idlwave-mode' runs `idlwave-mode-hook'. - -9. Documentation and Customization - ------------------------------- - Info documentation for this package is available. Use - \\[idlwave-info] to display (complain to your sysadmin if that does - not work). For Postscript, PDF, and HTML versions of the - documentation, check IDLWAVE's website at URL - `https://github.com/jdtsmith/idlwave'. - IDLWAVE has customize support - see the group `idlwave'. - -10.Keybindings - ----------- - Here is a list of all keybindings of this mode. - If some of the key bindings below show with ??, use \\[describe-key] - followed by the key sequence to see what the key sequence does. - -\\{idlwave-mode-map} - -(fn)" t) -(register-definition-prefixes "idlwave" '("idlwave-")) - - ;;; Generated autoloads from ido.el (defvar ido-mode nil "\ @@ -18812,6 +18743,11 @@ See Info node `(elisp)Defining Functions' for more details. (register-definition-prefixes "quail/ipa" '("ipa-x-sampa-")) +;;; Generated autoloads from leim/quail/iroquoian.el + +(register-definition-prefixes "quail/iroquoian" '("iroquoian-")) + + ;;; Generated autoloads from international/isearch-x.el (autoload 'isearch-toggle-specified-input-method "isearch-x" "\ @@ -19697,22 +19633,23 @@ Special commands: Let-bind dotted symbols to their cdrs in ALIST and execute BODY. Dotted symbol is any symbol starting with a `.'. Only those present in BODY are let-bound and this search is done at compile time. +A number will result in a list index. For instance, the following code (let-alist alist - (if (and .title .body) + (if (and .title.0 .body) .body .site .site.contents)) essentially expands to - (let ((.title (cdr (assq \\='title alist))) + (let ((.title (nth 0 (cdr (assq \\='title alist)))) (.body (cdr (assq \\='body alist))) (.site (cdr (assq \\='site alist))) (.site.contents (cdr (assq \\='contents (cdr (assq \\='site alist)))))) - (if (and .title .body) + (if (and .title.0 .body) .body .site .site.contents)) @@ -22196,15 +22133,18 @@ values: used to decode and encode the data which the process reads and writes. See `make-network-process' for details. -:return-list specifies this function's return value. - If omitted or nil, return a process object. A non-nil means to - return (PROC . PROPS), where PROC is a process object and PROPS - is a plist of connection properties, with these keywords: +:return-list controls the form of the function's return value. + If omitted or nil, return a process object. Anything else means to + return (PROC . PROPS), where PROC is a process object, and PROPS is a + plist of connection properties, which may include the following + keywords: :greeting -- the greeting returned by HOST (a string), or nil. :capabilities -- a string representing HOST's capabilities, or nil if none could be found. :type -- the resulting connection type; `plain' (unencrypted) or `tls' (TLS-encrypted). + :error -- A string describing any error when attempting + to negotiate STARTTLS. :end-of-command specifies a regexp matching the end of a command. @@ -22243,8 +22183,9 @@ writes. See `make-network-process' for details. :use-starttls-if-possible is a boolean that says to do opportunistic STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality. -:warn-unless-encrypted is a boolean which, if :return-list is -non-nil, is used warn the user if the connection isn't encrypted. +:warn-unless-encrypted, if non-nil, warn the user if the connection +isn't encrypted (i.e. STARTTLS failed). Additionally, setting +:return-list non-nil allows capturing any error response. :nogreeting is a boolean that can be used to inhibit waiting for a greeting from the server. @@ -24109,8 +24050,9 @@ directory. (autoload 'package-install-selected-packages "package" "\ Ensure packages in `package-selected-packages' are installed. If some packages are not installed, propose to install them. -If optional argument NOCONFIRM is non-nil, don't ask for -confirmation to install packages. + +If optional argument NOCONFIRM is non-nil, or when invoked with a prefix +argument, don't ask for confirmation to install packages. (fn &optional NOCONFIRM)" t) (autoload 'package-reinstall "package" "\ @@ -24134,7 +24076,12 @@ Remove packages that are no longer needed. Packages that are no more needed by other packages in `package-selected-packages' and their dependencies -will be deleted." t) +will be deleted. + +If optional argument NOCONFIRM is non-nil, or when invoked with a prefix +argument, don't ask for confirmation to install packages. + +(fn &optional NOCONFIRM)" t) (autoload 'describe-package "package" "\ Display the full documentation of PACKAGE (a symbol). @@ -24200,7 +24147,7 @@ If PACKAGE is a string, it specifies the URL of the package repository. In this case, optional argument BACKEND specifies the VC backend to use for cloning the repository; if it's nil, this function tries to infer which backend to use according to -the value of `package-vc-heuristic-alist' and if that fails it +the value of `vc-clone-heuristic-alist' and if that fails it uses `package-vc-default-backend'. Optional argument NAME specifies the package name in this case; if it's nil, this package uses `file-name-base' on the URL to obtain the package @@ -24454,9 +24401,14 @@ not signal an error. (function-put 'pcase-exhaustive 'lisp-indent-function 1) (autoload 'pcase-lambda "pcase" "\ Like `lambda' but allow each argument to be a pattern. -I.e. accepts the usual &optional and &rest keywords, but every -formal argument can be any pattern accepted by `pcase' (a mere -variable name being but a special case of it). +I.e. accepts the usual &optional and &rest keywords, but every formal +argument can be any pattern destructed by `pcase-let' (a mere variable +name being but a special case of it). + +Each argument should match its respective pattern in the parameter +list (i.e. be of a compatible structure); a mismatch may signal an error +or may go undetected, binding arguments to arbitrary values, such as +nil. (fn LAMBDA-LIST &rest BODY)" nil t) (function-put 'pcase-lambda 'doc-string-elt 2) @@ -25034,12 +24986,14 @@ ROUTER-SCRIPT: Path of the router PHP script, see `https://www.php.net/manual/en/features.commandline.webserver.php' NUM-OF-WORKERS: Before run the web server set the PHP_CLI_SERVER_WORKERS env variable useful for testing code against -multiple simultaneous requests. +multiple simultaneous requests +CONFIG: Alternative php.ini config, default `php-ts-mode-php-config'. -Interactively, when invoked with prefix argument, always prompt -for PORT, HOSTNAME, DOCUMENT-ROOT and ROUTER-SCRIPT. +Interactively, when invoked with prefix argument, always prompt for +PORT, HOSTNAME, DOCUMENT-ROOT, ROUTER-SCRIPT, NUM-OF-WORKERS and +CONFIG. -(fn &optional PORT HOSTNAME DOCUMENT-ROOT ROUTER-SCRIPT NUM-OF-WORKERS)" t) +(fn &optional PORT HOSTNAME DOCUMENT-ROOT ROUTER-SCRIPT NUM-OF-WORKERS CONFIG)" t) (autoload 'run-php "php-ts-mode" "\ Run an PHP interpreter as a inferior process. @@ -25909,7 +25863,8 @@ else prompt the user for the project to use. To prompt for a project, call the function specified by `project-prompter', which returns the directory in which to look for the project. If no project is found in that directory, return a \"transient\" -project instance. +project instance. When MAYBE-PROMPT is a string, it's passed to the +prompter function as an argument. The \"transient\" project instance is a special kind of value which denotes a project rooted in that directory and includes all @@ -25965,6 +25920,14 @@ requires quoting, e.g. `\\[quoted-insert]<space>'. Find all matches for REGEXP in the project roots or external roots. (fn REGEXP)" t) +(autoload 'project-root-find-file "project" "\ +Edit file FILENAME. + +Interactively, prompt for FILENAME, defaulting to the root directory of +the current project. + +(fn FILENAME)" t) +(function-put 'project-root-find-file 'interactive-only 'find-file) (autoload 'project-find-file "project" "\ Visit a file (with completion) in the current project. @@ -26088,9 +26051,11 @@ is non-nil, the command will not ask the user for confirmation. NO-CONFIRM is always nil when the command is invoked interactively. +If PROJECT is non-nil, kill buffers for that project instead. + Also see the `project-kill-buffers-display-buffer-list' variable. -(fn &optional NO-CONFIRM)" t) +(fn &optional NO-CONFIRM PROJECT)" t) (autoload 'project-remember-project "project" "\ Add project PR to the front of the project list. Save the result in `project-list-file' if the list of projects @@ -26442,7 +26407,8 @@ Optional argument FACE specifies the face to do the highlighting. ;;; Generated autoloads from progmodes/python.el (push (purecopy '(python 0 28)) package--builtin-versions) -(add-to-list 'auto-mode-alist (cons (purecopy "\\.py[iw]?\\'") 'python-mode)) +(defconst python--auto-mode-alist-regexp "\\(?:\\.\\(?:p\\(?:th\\|y[iw]?\\)\\)\\|/\\(?:SCons\\(?:\\(?:crip\\|truc\\)t\\)\\)\\)\\'") +(add-to-list 'auto-mode-alist (cons python--auto-mode-alist-regexp 'python-mode)) (add-to-list 'interpreter-mode-alist (cons (purecopy "python[0-9.]*") 'python-mode)) (autoload 'run-python "python" "\ Run an inferior Python process. @@ -26515,7 +26481,7 @@ Major mode for editing Python files, using tree-sitter library. (fn)" t) (add-to-list 'auto-mode-alist '("/\\(?:Pipfile\\|\\.?flake8\\)\\'" . conf-mode)) -(register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal")) +(register-definition-prefixes "python" '("inferior-python-mode" "python-" "run-python-internal" "subword-mode")) ;;; Generated autoloads from cedet/semantic/wisent/python.el @@ -27028,8 +26994,6 @@ evaluate the variable `rectangle-mark-mode'. The mode's hook is called both when the mode is enabled and when it is disabled. -\\{rectangle-mark-mode-map} - (fn &optional ARG)" t) (register-definition-prefixes "rect" '("apply-on-rectangle" "clear-rectangle-line" "delete-" "extract-rectangle-" "killed-rectangle" "ope" "rectangle-" "spaces-string" "string-rectangle-")) @@ -29763,6 +29727,7 @@ twice for the others. ;;; Generated autoloads from vc/smerge-mode.el + (global-set-key "\C-c^" (make-sparse-keymap)) (autoload 'smerge-refine-regions "smerge-mode" "\ Show fine differences in the two regions BEG1..END1 and BEG2..END2. PROPS-C is an alist of properties to put (via overlays) on the changes. @@ -31154,14 +31119,22 @@ This construct can only be used with lexical binding. (fn NAME BINDINGS &rest BODY)" nil t) (function-put 'named-let 'lisp-indent-function 2) +(autoload 'with-work-buffer "subr-x" "\ +Create a work buffer, and evaluate BODY there like `progn'. +Like `with-temp-buffer', but reuse an already created temporary +buffer when possible, instead of creating a new one on each call. + +(fn &rest BODY)" nil t) +(function-put 'with-work-buffer 'lisp-indent-function 0) (autoload 'string-pixel-width "subr-x" "\ Return the width of STRING in pixels. - +If BUFFER is non-nil, use the face remappings from that buffer when +determining the width. If you call this function to measure pixel width of a string with embedded newlines, it returns the width of the widest substring that does not include newlines. -(fn STRING)") +(fn STRING &optional BUFFER)") (function-put 'string-pixel-width 'important-return-value 't) (autoload 'string-glyph-split "subr-x" "\ Split STRING into a list of strings representing separate glyphs. @@ -31185,7 +31158,7 @@ this defaults to the current buffer. Query the user for a process and return the process object. (fn PROMPT)") -(register-definition-prefixes "subr-x" '("emacs-etc--hide-local-variables" "hash-table-" "internal--thread-argument" "replace-region-contents" "string-remove-" "thread-" "with-buffer-unmodified-if-unchanged")) +(register-definition-prefixes "subr-x" '("emacs-etc--hide-local-variables" "hash-table-" "internal--thread-argument" "replace-region-contents" "string-remove-" "thread-" "with-buffer-unmodified-if-unchanged" "work-buffer-")) ;;; Generated autoloads from progmodes/subword.el @@ -32991,7 +32964,7 @@ the default format \"%f seconds\" is used. (autoload 'date-to-time "time-date" "\ Parse a string DATE that represents a date-time and return a time value. DATE should be in one of the forms recognized by `parse-time-string'. -If DATE lacks timezone information, GMT is assumed. +If DATE lacks time zone information, local time is assumed. (fn DATE)") (defalias 'time-to-seconds #'float-time) @@ -33092,13 +33065,13 @@ Valid ZONE values are described in the documentation of `format-time-string'. (put 'time-stamp-line-limit 'safe-local-variable 'integerp) (put 'time-stamp-start 'safe-local-variable 'stringp) (put 'time-stamp-end 'safe-local-variable 'stringp) -(put 'time-stamp-inserts-lines 'safe-local-variable 'symbolp) +(put 'time-stamp-inserts-lines 'safe-local-variable 'booleanp) (put 'time-stamp-count 'safe-local-variable 'integerp) (put 'time-stamp-pattern 'safe-local-variable 'stringp) (autoload 'time-stamp "time-stamp" "\ Update any time stamp string(s) in the buffer. -This function looks for a time stamp template and updates it with -the current date, time, and/or other info. +Look for a time stamp template and update it with the current date, +time, and/or other info. The template, which you manually create on one of the first 8 lines of the file before running this function, by default can look like @@ -33107,7 +33080,7 @@ one of the following (your choice): Time-stamp: \" \" This function writes the current time between the brackets or quotes, by default formatted like this: - Time-stamp: <2020-08-07 17:10:21 gildea> + Time-stamp: <2024-08-07 17:10:21 gildea> Although you can run this function manually to update a time stamp once, usually you want automatic time stamp updating. @@ -33121,7 +33094,7 @@ To enable automatic time-stamping for only a specific file, add this line to a local variables list near the end of the file: eval: (add-hook \\='before-save-hook \\='time-stamp nil t) -If the file has no time-stamp template, this function does nothing. +If the file has no time stamp template, this function does nothing. You can set `time-stamp-pattern' in a file's local variables list to customize the information in the time stamp and where it is written. @@ -33296,8 +33269,10 @@ DEFAULT-ITEM, if non-nil, specifies an initial default choice. Its value should be an event that has a binding in MENU. NO-EXECUTE, if non-nil, means to return the command the user selects instead of executing it. +PATH is a stack that keeps track of your path through sub-menus. It +is used to go back through those sub-menus. -(fn MENU &optional IN-POPUP DEFAULT-ITEM NO-EXECUTE)") +(fn MENU &optional IN-POPUP DEFAULT-ITEM NO-EXECUTE PATH)") (register-definition-prefixes "tmm" '("tmm-")) @@ -33603,8 +33578,9 @@ the output buffer or changing the window configuration. (load "tramp-compat" 'noerror 'nomessage)) (defvar tramp-mode t "\ Whether Tramp is enabled. -If it is set to nil, all remote file names are used literally.") -(custom-autoload 'tramp-mode "tramp" t) +If it is set to nil, all remote file names are used literally. Don't +set it manually, use `inhibit-remote-files' or `without-remote-files' +instead.") (defconst tramp-initial-file-name-regexp (rx bos "/" (+ (not (any "/:"))) ":" (* (not (any "/:"))) ":") "\ Value for `tramp-file-name-regexp' for autoload. It must match the initial `tramp-syntax' settings.") @@ -33760,13 +33736,13 @@ Add archive file name handler to `file-name-handler-alist'." (when (and tramp-ar ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 7 1 30 1)) package--builtin-versions) +(push (purecopy '(tramp 2 8 0 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) ;;; Generated autoloads from transient.el -(push (purecopy '(transient 0 7 2 2)) package--builtin-versions) +(push (purecopy '(transient 0 7 4)) package--builtin-versions) (autoload 'transient-insert-suffix "transient" "\ Insert a SUFFIX into PREFIX before LOC. PREFIX is a prefix command, a symbol. @@ -35208,8 +35184,8 @@ remove from the list of ignored files. (autoload 'vc-version-diff "vc" "\ Report diffs between revisions REV1 and REV2 in the repository history. This compares two revisions of the current fileset. -If REV1 is nil, it defaults to the current revision, i.e. revision -of the last commit. +If REV1 is nil, it defaults to the previous revision, i.e. revision +before the last commit. If REV2 is nil, it defaults to the work tree, i.e. the current state of each file in the fileset. @@ -35827,7 +35803,7 @@ Key bindings: ;;; Generated autoloads from progmodes/verilog-mode.el -(push (purecopy '(verilog-mode 2024 3 1 121933719)) package--builtin-versions) +(push (purecopy '(verilog-mode 2024 10 9 140346409)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. \\<verilog-mode-map> @@ -37112,7 +37088,7 @@ disabled. ;;; Generated autoloads from which-key.el -(push (purecopy '(which-key 3 6 0)) package--builtin-versions) +(push (purecopy '(which-key 3 6 1)) package--builtin-versions) (defvar which-key-mode nil "\ Non-nil if Which-Key mode is enabled. See the `which-key-mode' command @@ -37630,6 +37606,11 @@ The problems cleaned up are: If `whitespace-style' includes the value `space-after-tab::space', replace TABs by SPACEs. +5. missing newline at end of file. + If `whitespace-style' includes the value `missing-newline-at-eof', + and the cleanup region includes the end of file, add a final newline + if it is not there already. + See `whitespace-style', `indent-tabs-mode' and `tab-width' for documentation. diff --git a/lisp/leim/quail/greek.el b/lisp/leim/quail/greek.el index 7cf839f2f58..ff335558a2e 100644 --- a/lisp/leim/quail/greek.el +++ b/lisp/leim/quail/greek.el @@ -1245,6 +1245,8 @@ e.g. ("K" ?Κ) ("L" ?Λ) (":" ?¨) + (";:" ?΅) + (":;" ?΅) ("\"" ?\") ("|" ?|) ("Z" ?Ζ) @@ -1281,7 +1283,9 @@ e.g. (";:y" ?ΰ) (":;y" ?ΰ) (";<" ?«) - (";>" ?»)) + (";>" ?») + ("<<" ?«) + (">>" ?»)) (quail-define-package "greek-postfix" "GreekPost" "Ψ" nil @@ -1429,4 +1433,717 @@ e.g. (">>" ?»)) +(quail-define-package + "greek-polytonic" "Greek" "ῶ" t + "Ἑλληνικά: Greek input method, with support for polytonic & archaic +Greek letters." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("1" ?1) + ("2" ?2) + ("3" ?3) + ("4" ?4) + ("5" ?5) + ("6" ?6) + ("7" ?7) + ("8" ?8) + ("9" ?9) + ("0" ?0) + ("-" ?-) + ("=" ?=) + ("[" ?\[) + ("]" ?\]) + ;; Changed punction from greek.el + ("`" ?·) + ("~" ?:) + ;; tonoi + (";" ?΄) ;; U+1FFD (oxia) + ("q" ?`) ;; U+1FEF (varia) + ("'" ?῀) ;; U+1FC0 (perispomeni) + ("\"" ?ι) ;; U+1FBE (ypogegrammeni) + ;; pneumata + (":" ?᾿) ;; U+1FBF (psili) + ("Q" ?῾) ;; U+1FFE (dasia) + ("W" ?¨) ;; U+00A8 (dialytika) + ;; apostrophe combinations + ("; " ["’ "]) ;; U+2019 (apostrophe) + (";g" ["’γ"]) + (";d" ["’δ"]) + (";z" ["’ζ"]) + (";u" ["’θ"]) + (";k" ["’κ"]) + (";l" ["’λ"]) + (";m" ["’μ"]) + (";n" ["’ν"]) + (";j" ["’ξ"]) + (";p" ["’π"]) + (";ρ" ["’r"]) + (";s" ["’σ"]) + (";t" ["’τ"]) + (";f" ["’φ"]) + (";x" ["’χ"]) + (";c" ["’ψ"]) + ;; + (";G" ["’Γ"]) + (";D" ["’Δ"]) + (";Z" ["’Ζ"]) + (";U" ["’Θ"]) + (";K" ["’Κ"]) + (";L" ["’Λ"]) + (";M" ["’Μ"]) + (";N" ["’Ν"]) + (";J" ["’Ξ"]) + (";P" ["’Π"]) + (";Ρ" ["’R"]) + (";S" ["’Σ"]) + (";T" ["’Τ"]) + (";F" ["’Φ"]) + (";X" ["’Χ"]) + (";C" ["’Ψ"]) + ;; Combinations + ("W;" ?΅) ;; U+1FEE + (";W" ?΅) ;; U+1FEE + ("Wq" ?῭) ;; U+1FED + ("qW" ?῭) ;; U+1FED + (":;" ?῎) ;; U+1FCE + (";:" ?῎) ;; U+1FCE + ("qQ" ?῝) ;; U+1FDD + ("Qq" ?῝) ;; U+1FDD + ("q:" ?῍) ;; U+1FCD + (":q" ?῍) ;; U+1FCD + ("Q;" ?῞) ;; U+1FDE + (";Q" ?῞) ;; U+1FDE + ("':" ?῏) ;; U+1FCF + (":'" ?῏) ;; U+1FCF + ("'Q" ?῟) ;; U+1FDF + ("Q'" ?῟) ;; U+1FDF + ("'W" ?῁) ;; U+1FC1 + ("W'" ?῁) ;; U+1FC1 + ;; perispomeni combinations, used for vrachy and macron + ("''" ["῀῀"]) + ("'''" ["῀῀῀"]) + ;; ypogegrammeni combinations + ("\"'" ["῀ι"]) + ("'\"" ["῀ι"]) + ("\";" ["΄ι"]) + (";\"" ["ι΄"]) + ("\":" ["ι᾿"]) + (":\"" ["ι᾿"]) + ("\"q" ["ι`"]) + ("q\"" ["ι`"]) + ("\"Q" ["ι῾"]) + ("Q\"" ["ι῾"]) + ("Q\"'" ["ι῟"]) + ("\"Q'" ["ι῟"]) + + ("Q'\"" ["ι῟"]) + ("'Q\"" ["ι῟"]) + (":q\"" ["῍ι"]) + ("q:\"" ["῍ι"]) + ("\"q:" ["῍ι"]) + ("\":q" ["῍ι"]) + + (":;\"" ["῎ι"]) + (";:\"" ["῎ι"]) + ("\";:" ["῎ι"]) + ("\":;" ["῎ι"]) + ("Qq\"" ["῝ι"]) + ("qQ\"" ["῝ι"]) + ("\"Qq" ["῝ι"]) + ("\"qQ" ["῝ι"]) + + ("Q;\"" ["῞ι"]) + (";Q\"" ["῞ι"]) + ("\";Q" ["῞ι"]) + ("\"Q;" ["῞ι"]) + + (":'\"" ["῏ι"]) + ("':\"" ["῏ι"]) + ("\"':" ["῏ι"]) + ("\":'" ["῏ι"]) + ;; Misc characters + ("~" ?:) + ("``" "~") + ;; + ("W" ?¨) + ("," ?,) + ("." ?.) + ("/" ?/) + ("!" ?!) + ("@" ?@) + ("#" ?#) + ("$" ?€) + ("%" ?%) + ("^" ?^) + ("&" ?&) + ("*" ?*) + ("(" ?\() + (")" ?\)) + ("_" ?_) + ("+" ?+) + ("{" ?{) + ("}" ?}) + (";;" "\"") + ("<" ?<) + (">" ?>) + ("?" ?;) ;; U+037E (Greek Question Mark) + (">>" ?») ;; U+00BB + ("<<" ?«) ;; U+00AB + ;; Alpha + ("A" ?Α) ;; U+0391 + (":A" ?Ἀ) ;; U+1F08 + ("QA" ?Ἁ) ;; U+1F09 + (":qA" ?Ἂ) ;; U+1F0A + ("q:A" ?Ἂ) ;; U+1F0A + ("qQA" ?Ἃ) ;; U+1F0B + ("QqA" ?Ἃ) ;; U+1F0B + (":;A" ?Ἄ) ;; U+1F0C + ("Q;A" ?Ἅ) ;; U+1F0D + (";QA" ?Ἅ) ;; U+1F0D + (":'A" ?Ἆ) ;; U+1F0E + ("':A" ?Ἆ) ;; U+1F0E + ("Q'A" ?Ἇ) ;; U+1F0F + ("'QA" ?Ἇ) ;; U+1F0F + (":\"A" ?ᾈ) ;; U+1F88 + ("Q\"A" ?ᾉ) ;; U+1F89 + (":q\"A" ?ᾊ) ;; U+1F8A + ("q:\"A" ?ᾊ) ;; U+1F8A + ("q\":A" ?ᾊ) ;; U+1F8A + ("\"q:A" ?ᾊ) ;; U+1F8A + ("Qq\"A" ?ᾋ) ;; U+1F8B + ("qQ\"A" ?ᾋ) ;; U+1F8B + ("q\"QA" ?ᾋ) ;; U+1F8B + ("\"qQA" ?ᾋ) ;; U+1F8B + (":;\"A" ?ᾌ) ;; U+1F8C + (";:\"A" ?ᾌ) ;; U+1F8C + (";\":A" ?ᾌ) ;; U+1F8C + ("\";:A" ?ᾌ) ;; U+1F8C + ("Q;\"A" ?ᾍ) ;; U+1F8D + ("Q\";A" ?ᾍ) ;; U+1F8D + ("\"Q;A" ?ᾍ) ;; U+1F8D + ("\";QA" ?ᾍ) ;; U+1F8D + (":'\"A" ?ᾎ) ;; U+1F8E + (":\"'A" ?ᾎ) ;; U+1F8E + ("\":'A" ?ᾎ) ;; U+1F8E + ("\"':A" ?ᾎ) ;; U+1F8E + ("Q'\"A" ?ᾏ) ;; U+1F8F + ("'Q\"A" ?ᾏ) ;; U+1F8F + ("'\"QA" ?ᾏ) ;; U+1F8F + ("\"'QA" ?ᾏ) ;; U+1F8F + ("''A" ?Ᾰ) ;; U+1FB8 + ("'''A" ?Ᾱ) ;; U+1FB9 + ("qA" ?Ὰ) ;; U+1FBA + (";A" ?Ά) ;; U+1FBB + ("\"A" ?ᾼ) ;; U+1FBC + ("a" ?α) ;; U+03B1 + (":a" ?ἀ) ;; U+1F00 + ("Qa" ?ἁ) ;; U+1F01 + (":qa" ?ἂ) ;; U+1F02 + ("q:a" ?ἂ) ;; U+1F02 + ("Qqa" ?ἃ) ;; U+1F03 + ("qQa" ?ἃ) ;; U+1F03 + (":;a" ?ἄ) ;; U+1F04 + (";:a" ?ἄ) ;; U+1F04 + ("Q;a" ?ἅ) ;; U+1F05 + (";Qa" ?ἅ) ;; U+1F05 + (":'a" ?ἆ) ;; U+1F06 + ("':a" ?ἆ) ;; U+1F06 + ("Q'a" ?ἇ) ;; U+1F07 + ("'Qa" ?ἇ) ;; U+1F07 + ("qa" ?ὰ) ;; U+1F70 + (";a" ?ά) ;; U+1F71 + (":\"a" ?ᾀ) ;; U+1F80 + ("\":a" ?ᾀ) ;; U+1F80 + ("Q\"a" ?ᾁ) ;; U+1F81 + (":q\"a" ?ᾂ) ;; U+1F82 + (":\"qa" ?ᾂ) ;; U+1F82 + ("\":qa" ?ᾂ) ;; U+1F82 + ("\"q:a" ?ᾂ) ;; U+1F82 + ("Qq\"a" ?ᾃ) ;; U+1F83 + ("Q\"qa" ?ᾃ) ;; U+1F83 + ("\"qQa" ?ᾃ) ;; U+1F83 + ("\"Qqa" ?ᾃ) ;; U+1F83 + (":;\"a" ?ᾄ) ;; U+1F84 + (";\":a" ?ᾄ) ;; U+1F84 + ("\";:a" ?ᾄ) ;; U+1F84 + (";:\"a" ?ᾄ) ;; U+1F84 + (":;\"a" ?ᾄ) ;; U+1F84 + ("Q;\"a" ?ᾅ) ;; U+1F85 + ("Q\";a" ?ᾅ) ;; U+1F85 + ("\"Q;a" ?ᾅ) ;; U+1F85 + ("\";Qa" ?ᾅ) ;; U+1F85 + (";\"Qa" ?ᾅ) ;; U+1F85 + (":'\"a" ?ᾆ) ;; U+1F86 + ("':\"a" ?ᾆ) ;; U+1F86 + ("'\":a" ?ᾆ) ;; U+1F86 + ("\"':a" ?ᾆ) ;; U+1F86 + ("\":'a" ?ᾆ) ;; U+1F86 + ("Q'\"a" ?ᾇ) ;; U+1F87 + ("'Q\"a" ?ᾇ) ;; U+1F87 + ("'\"Qa" ?ᾇ) ;; U+1F87 + ("\"'Qa" ?ᾇ) ;; U+1F87 + ("\"Q'a" ?ᾇ) ;; U+1F87 + ("''a" ?ᾰ) ;; U+1FB0 + ("'''a" ?ᾱ) ;; U+1FB1 + ("q\"a" ?ᾲ) ;;U+1FB2 + ("\"qa" ?ᾲ) ;;U+1FB2 + ("\"a" ?ᾳ) ;; U+1FB3 + (";\"a" ?ᾴ) ;; U+1FB4 + ("'a" ?ᾶ) ;; U+1FB6 + ("'\"a" ?ᾷ) ;; U+1FB7 + ("\"'a" ?ᾷ) ;; U+1FB7 + ;; Beta + ("B" ?Β) ;; U+0392 + ("b" ?β) ;; U+03B2 + ;; Gamma + ("G" ?Γ) ;; U+0393 + ("g" ?γ) ;; U+03B3 + ;; Delta + ("D" ?Δ) ;; U+0394 + ("d" ?δ) ;; U+03B4 + ;; Epsilon + ("E" ?Ε) ;; U+0395 + (":E" ?Ἐ) ;; U+1F18 + ("QE" ?Ἑ) ;; U+1F19 + (":qE" ?Ἒ) ;; U+1F1A + ("q:E" ?Ἒ) ;; U+1F1A + ("QqE" ?Ἓ) ;; U+1F1B + ("qQE" ?Ἓ) ;; U+1F1B + (":;E" ?Ἔ) ;; U+1F1C + (";:E" ?Ἔ) ;; U+1F1C + ("Q;E" ?Ἕ) ;; U+1F1D + (";QE" ?Ἕ) ;; U+1F1D + ("qE" ?Ὲ) ;; U+1FC8 + (";E" ?Έ) ;; U+1FC9 + ("e" ?ε) ;; U+03B5 + ("qe" ?ὲ) ;; U+1F72 + (";e" ?έ) ;; U+1F73 + (":e" ?ἐ) ;; U+1F10 + ("Qe" ?ἑ) ;; U+1F11 + (":qe" ?ἒ) ;; U+1F12 + ("q:e" ?ἒ) ;; U+1F12 + ("Qqe" ?ἓ) ;; U+1F13 + ("qQe" ?ἓ) ;; U+1F13 + (":;e" ?ἔ) ;; U+1F14 + (";:e" ?ἔ) ;; U+1F14 + ("Q;e" ?ἕ) ;; U+1F15 + (";Qe" ?ἕ) ;; U+1F15 + ;; Zeta + ("Z" ?Ζ) ;; U+0396 + ("z" ?ζ) ;; U+03B6 + ;; Eta + ("H" ?Η) ;; U+0397 + (":H" ?Ἠ) ;; U+1F28 + ("QH" ?Ἡ) ;; U+1F29 + (":qH" ?Ἢ) ;; U+1F2A + ("q:H" ?Ἢ) ;; U+1F2A + ("QqH" ?Ἣ) ;; U+1F2B + ("qQH" ?Ἣ) ;; U+1F2B + (":;H" ?Ἤ) ;; U+1F2C + (";:H" ?Ἤ) ;; U+1F2C + ("Q;H" ?Ἥ) ;; U+1F2D + (";QH" ?Ἥ) ;; U+1F2D + (":'H" ?Ἦ) ;; U+1F2E + ("':H" ?Ἦ) ;; U+1F2E + ("Q'H" ?Ἧ) ;; U+1F2F + ("'QH" ?Ἧ) ;; U+1F2F + (":\"H" ?ᾘ) ;; U+1F98 + ("\":H" ?ᾘ) ;; U+1F98 + ("Q\"H" ?ᾙ) ;; U+1F99 + ("\"QH" ?ᾙ) ;; U+1F99 + (":q\"H" ?ᾚ) ;; U+1F9A + (":\"qH" ?ᾚ) ;; U+1F9A + ("\":qH" ?ᾚ) ;; U+1F9A + ("\"q:H" ?ᾚ) ;; U+1F9A + ("q\":H" ?ᾚ) ;; U+1F9A + ("Qq\"H" ?ᾛ) ;; U+1F9B + ("Q\"qH" ?ᾛ) ;; U+1F9B + ("\"QqH" ?ᾛ) ;; U+1F9B + ("\"qQH" ?ᾛ) ;; U+1F9B + ("q\"QH" ?ᾛ) ;; U+1F9B + (":;\"H" ?ᾜ) ;; U+1F9C + (":\";H" ?ᾜ) ;; U+1F9C + ("\":;H" ?ᾜ) ;; U+1F9C + ("\";:H" ?ᾜ) ;; U+1F9C + (";\":H" ?ᾜ) ;; U+1F9C + ("Q;\"H" ?ᾝ) ;; U+1F9D + ("Q\";H" ?ᾝ) ;; U+1F9D + ("\"Q;H" ?ᾝ) ;; U+1F9D + ("\";QH" ?ᾝ) ;; U+1F9D + (";\"QH" ?ᾝ) ;; U+1F9D + (":'\"H" ?ᾞ) ;; U+1F9E + (":\"'H" ?ᾞ) ;; U+1F9E + ("\":'H" ?ᾞ) ;; U+1F9E + ("\"':H" ?ᾞ) ;; U+1F9E + ("'\":H" ?ᾞ) ;; U+1F9E + ("Q'\"H" ?ᾟ) ;; U+1F9F + ("Q\"'H" ?ᾟ) ;; U+1F9F + ("\"Q'H" ?ᾟ) ;; U+1F9F + ("\"'QH" ?ᾟ) ;; U+1F9F + ("'\"QH" ?ᾟ) ;; U+1F9F + ("qH" ?Ὴ) ;; U+1FCA + (";H" ?Ή) ;; U+1FCB + ("\"H" ?ῌ) ;; U+1FCC + ;; + ("h" ?η) ;; U+03B7 + ("qh" ?ὴ) ;; U+1F74 + (";h" ?ή) ;; U+1F75 + (":h" ?ἠ) ;; U+1F20 + ("Qh" ?ἡ) ;; U+1F21 + (":qh" ?ἢ) ;; U+1F22 + ("q:h" ?ἢ) ;; U+1F22 + ("Qqh" ?ἣ) ;; U+1F23 + ("qQh" ?ἣ) ;; U+1F23 + (":;h" ?ἤ) ;; U+1F24 + (";:h" ?ἤ) ;; U+1F24 + ("Q;h" ?ἥ) ;; U+1F25 + (";Qh" ?ἥ) ;; U+1F25 + (":'h" ?ἦ) ;; U+1F26 + ("':h" ?ἦ) ;; U+1F26 + ("Q'h" ?ἧ) ;; U+1F27 + ("'Qh" ?ἧ) ;; U+1F27 + (":\"h" ?ᾐ) ;; U+1F90 + ("\":h" ?ᾐ) ;; U+1F90 + ("Q\"h" ?ᾑ) ;; U+1F91 + ("\"Qh" ?ᾑ) ;; U+1F91 + (":q\"h" ?ᾒ) ;; U+1F92 + (":\"qh" ?ᾒ) ;; U+1F92 + ("\":qh" ?ᾒ) ;; U+1F92 + ("\"q:h" ?ᾒ) ;; U+1F92 + ("q\":h" ?ᾒ) ;; U+1F92 + ("Qq\"h" ?ᾓ) ;; U+1F93 + ("Q\"qh" ?ᾓ) ;; U+1F93 + ("\"Qqh" ?ᾓ) ;; U+1F93 + ("\"qQh" ?ᾓ) ;; U+1F93 + ("q\"Qh" ?ᾓ) ;; U+1F93 + (":;\"h" ?ᾔ) ;; U+1F94 + (":\";h" ?ᾔ) ;; U+1F94 + ("\":;h" ?ᾔ) ;; U+1F94 + ("\";:h" ?ᾔ) ;; U+1F94 + (";\":h" ?ᾔ) ;; U+1F94 + ("Q;\"h" ?ᾕ) ;; U+1F95 + ("Q\";h" ?ᾕ) ;; U+1F95 + ("\"Q;h" ?ᾕ) ;; U+1F95 + ("\";Qh" ?ᾕ) ;; U+1F95 + (";\"Qh" ?ᾕ) ;; U+1F95 + (":'\"h" ?ᾖ) ;; U+1F96 + (":\"'h" ?ᾖ) ;; U+1F96 + ("\":'h" ?ᾖ) ;; U+1F96 + ("\"':h" ?ᾖ) ;; U+1F96 + ("'\":h" ?ᾖ) ;; U+1F96 + ("Q'\"h" ?ᾗ) ;; U+1F97 + ("Q\"'h" ?ᾗ) ;; U+1F97 + ("\"Q'h" ?ᾗ) ;; U+1F97 + ("\"'Qh" ?ᾗ) ;; U+1F97 + ("'\"Qh" ?ᾗ) ;; U+1F97 + ("q\"h" ?ῂ) ;; U+1FC2 + ("\"qh" ?ῂ) ;; U+1FC2 + ("\"h" ?ῃ) ;; U+1FC3 + (";\"h" ?ῄ) ;; U+1FC4 + ("\";h" ?ῄ) ;; U+1FC4 + ("'h" ?ῆ) ;; U+1FC6 + ("\"'h" ?ῇ) ;; U+1FC7 + ("'\"h" ?ῇ) ;; U+1FC7 + ;; Theta + ("U" ?Θ) ;; U+0398 + ("u" ?θ) ;; U+03B8 + ;; Iota + ("I" ?Ι) ;; U+0399 + ("WI" ?Ϊ) ;; U+03AA + (":I" ?Ἰ) ;; U+1F38 + ("QI" ?Ἱ) ;; U+1F39 + (":qI" ?Ἲ) ;; U+1F3A + ("q:I" ?Ἲ) ;; U+1F3A + ("QqI" ?Ἳ) ;; U+1F3B + ("qQI" ?Ἳ) ;; U+1F3B + (":;I" ?Ἴ) ;; U+1F3C + (";:I" ?Ἴ) ;; U+1F3C + ("Q;I" ?Ἵ) ;; U+1F3D + (";QI" ?Ἵ) ;; U+1F3D + (":'I" ?Ἶ) ;; U+1F3E + ("':I" ?Ἶ) ;; U+1F3E + ("Q'I" ?Ἷ) ;; U+1F3F + ("''I" ?Ῐ) ;; U+1FD8 + ("'''I" ?Ῑ) ;; U+1FD9 + ("qI" ?Ὶ) ;; U+1FDA + (";I" ?Ί) ;; U+1FDB + ("i" ?ι) ;; U+03B9 + ("Wi" ?ϊ) ;; U+03CA + ("qi" ?ὶ) ;; U+1F76 + (";i" ?ί) ;; U+1F77 + (":i" ?ἰ) ;; U+1F30 + ("Qi" ?ἱ) ;; U+1F31 + (":qi" ?ἲ) ;; U+1F32 + ("q:i" ?ἲ) ;; U+1F32 + ("Qqi" ?ἳ) ;; U+1F33 + ("qQi" ?ἳ) ;; U+1F33 + (":;i" ?ἴ) ;; U+1F34 + (";:i" ?ἴ) ;; U+1F34 + ("Q;i" ?ἵ) ;; U+1F35 + (";Qi" ?ἵ) ;; U+1F35 + (":'i" ?ἶ) ;; U+1F36 + ("':i" ?ἶ) ;; U+1F36 + ("Q'i" ?ἷ) ;; U+1F37 + ("'Qi" ?ἷ) ;; U+1F37 + ("''i" ?ῐ) ;; U+1FD0 + ("'''i" ?ῑ) ;; U+1FD1 + ("Wqi" ?ῒ) ;; U+1FD2 + ("qWi" ?ῒ) ;; U+1FD2 + (";Wi" ?ΐ) ;; U+1FD3 + ("W;i" ?ΐ) ;; U+1FD3 + ("'i" ?ῖ) ;; U+1FD6 + ("W'i" ?ῗ) ;; U+1FD7 + ("'Wi" ?ῗ) ;; U+1FD7 + ;; Kappa + ("K" ?Κ) ;; U+039A + ("k" ?κ) ;; U+03BA + ;; Lambda + ("L" ?Λ) ;; U+039B + ("l" ?λ) ;; U+03BB + ;; Mu + ("M" ?Μ) ;; U+039C + ("m" ?μ) ;; U+03BC + ;; Nu + ("N" ?Ν) ;; U+039D + ("n" ?ν) ;; U+03BD + ;; Xi + ("J" ?Ξ) ;; U+039E + ("j" ?ξ) ;; U+03BE + ;; Omicron + ("O" ?Ο) ;; U+039F + (":O" ?Ὀ) ;; U+1F48 + ("QO" ?Ὁ) ;; U+1F49 + (":qO" ?Ὂ) ;; U+1F4A + ("q:O" ?Ὂ) ;; U+1F4A + ("QqO" ?Ὃ) ;; U+1F4B + (":;O" ?Ὄ) ;; U+1F4C + ("Q;O" ?Ὅ) ;; U+1F4D + ("qO" ?Ὸ) ;; U+1FF8 + (";O" ?Ό) ;; U+1FF9 + ("o" ?ο) ;; U+03BF + ("qo" ?ὸ) ;; U+1F78 + (";o" ?ό) ;; U+1F79 + (":o" ?ὀ) ;; U+1F40 + ("Qo" ?ὁ) ;; U+1F41 + (":qo" ?ὂ) ;; U+1F42 + ("q:o" ?ὂ) ;; U+1F42 + ("Qqo" ?ὃ) ;; U+1F43 + ("qQo" ?ὃ) ;; U+1F43 + (":;o" ?ὄ) ;; U+1F44 + (";:o" ?ὄ) ;; U+1F44 + ("Q;o" ?ὅ) ;; U+1F45 + ;; Pi + ("P" ?Π) ;; U+03A0 + ("p" ?π) ;; U+03C0 + ;; Rho + ("R" ?Ρ) ;; U+03A1 + ("QR" ?Ῥ) ;; U+1FEC + ("r" ?ρ) ;; U+03C1 + (":r" ?ῤ) ;; U+1FE4 + ("Qr" ?ῥ) ;; U+1FE5 + ;; Sigma + ("S" ?Σ) ;; U+03A3 + ("s" ?σ) ;; U+03C3 + ("w" ?ς) ;; U+03C2 + ;; Tau + ("T" ?Τ) ;; U+03A4 + ("t" ?τ) ;; U+03C4 + ;; Upsilon + ("Y" ?Υ) ;; U+03A5 + ("WY" ?Ϋ) ;; U+03AB + ("QY" ?Ὑ) ;; U+1F59 + ("QqY" ?Ὓ) ;; U+1F5B + ("qQY" ?Ὓ) ;; U+1F5B + ("Q;Y" ?Ὕ) ;; U+1F5D + (";QY" ?Ὕ) ;; U+1F5D + ("Q'Y" ?Ὗ) ;; U+1F5F + ("'QY" ?Ὗ) ;; U+1F5F + ("y" ?υ) ;; U+03C5 + ("Wy" ?ϋ) ;; U+03CB + ("qy" ?ὺ) ;; U+1F7A + (";y" ?ύ) ;; U+1F7B + (":y" ?ὐ) ;; U+1F50 + ("Qy" ?ὑ) ;; U+1F51 + (":qy" ?ὒ) ;; U+1F52 + ("q:y" ?ὒ) ;; U+1F52 + ("Qqy" ?ὓ) ;; U+1F53 + ("qQy" ?ὓ) ;; U+1F53 + (":;y" ?ὔ) ;; U+1F54 + (";:y" ?ὔ) ;; U+1F54 + ("Q;y" ?ὕ) ;; U+1F55 + (";Qy" ?ὕ) ;; U+1F55 + (":'y" ?ὖ) ;; U+1F56 + ("':y" ?ὖ) ;; U+1F56 + ("Q'y" ?ὗ) ;; U+1F57 + ("'Qy" ?ὗ) ;; U+1F57 + ("''y" ?ῠ) ;; U+1FE0 + ("'''y" ?ῡ) ;; U+1FE1 + ("Wqy" ?ῢ) ;; U+1FE2 + ("qWy" ?ῢ) ;; U+1FE2 + ("W;y" ?ΰ) ;; U+1FE3 + (";Wy" ?ΰ) ;; U+1FE3 + ("'y" ?ῦ) ;; U+1FE6 + ("W'y" ?ῧ) ;; U+1FE7 + ("'Wy" ?ῧ) ;; U+1FE7 + ("''Y" ?Ῠ) ;; U+1FE8 + ("'''Y" ?Ῡ) ;; U+1FE8 + ("qY" ?Ὺ) ;; U+1FEA + (";Y" ?Ύ) ;; U+1FEB + ;; Phi + ("F" ?Φ) ;; U+03A6 + ("f" ?φ) ;; U+03C6 + ;; Chi + ("X" ?Χ) ;; U+03A7 + ("x" ?χ) ;; U+03C7 + ;; Chi + ("C" ?Ψ) ;; U+03A8 + ("c" ?ψ) ;; U+03C8 + ;; Omega + ("V" ?Ω) ;; U+03A9 + (":V" ?Ὠ) ;; U+1F68 + ("QV" ?Ὡ) ;; U+1F69 + (":qV" ?Ὢ) ;; U+1F6A + ("q:V" ?Ὢ) ;; U+1F6A + ("QqV" ?Ὣ) ;; U+1F6B + ("qQV" ?Ὣ) ;; U+1F6B + (":;V" ?Ὤ) ;; U+1F6C + (";:V" ?Ὤ) ;; U+1F6C + ("Q;V" ?Ὥ) ;; U+1F6D + (";QV" ?Ὥ) ;; U+1F6D + (":'V" ?Ὦ) ;; U+1F6E + ("':V" ?Ὦ) ;; U+1F6E + ("Q'V" ?Ὧ) ;; U+1F6F + (":\"V" ?ᾨ) ;; U+1FA8 + ("\":V" ?ᾨ) ;; U+1FA8 + ("Q\"V" ?ᾩ) ;; U+1FA9 + ("\"QV" ?ᾩ) ;; U+1FA9 + + (":q\"V" ?ᾪ) ;; U+1FAA + (":\"qV" ?ᾪ) ;; U+1FAA + ("\":qV" ?ᾪ) ;; U+1FAA + ("\"q:V" ?ᾪ) ;; U+1FAA + ("q\":V" ?ᾪ) ;; U+1FAA + ("q:\"V" ?ᾪ) ;; U+1FAA + + ("Qq\"V" ?ᾫ) ;; U+1FAB + ("qQ\"V" ?ᾫ) ;; U+1FAB + ("q\"QV" ?ᾫ) ;; U+1FAB + ("\"qQV" ?ᾫ) ;; U+1FAB + ("\"QqV" ?ᾫ) ;; U+1FAB + + (":\"qV" ?ᾫ) ;; U+1FAB + (":;\"V" ?ᾬ) ;; U+1FAC + (":\";V" ?ᾬ) ;; U+1FAC + ("\":;V" ?ᾬ) ;; U+1FAC + ("\";:V" ?ᾬ) ;; U+1FAC + (";\":V" ?ᾬ) ;; U+1FAC + ("Q;\"V" ?ᾭ) ;; U+1FAD + ("Q\";V" ?ᾭ) ;; U+1FAD + ("\"Q;V" ?ᾭ) ;; U+1FAD + ("\";QV" ?ᾭ) ;; U+1FAD + (";\"QV" ?ᾭ) ;; U+1FAD + (":'\"V" ?ᾮ) ;; U+1FAE + (":\"'V" ?ᾮ) ;; U+1FAE + ("\":'V" ?ᾮ) ;; U+1FAE + ("\"':V" ?ᾮ) ;; U+1FAE + ("'\":V" ?ᾮ) ;; U+1FAE + + ("Q'\"V" ?ᾯ) ;; U+1FAF + ("'Q\"V" ?ᾯ) ;; U+1FAF + ("Q\"'V" ?ᾯ) ;; U+1FAF + ("\"Q'V" ?ᾯ) ;; U+1FAF + ("\"'QV" ?ᾯ) ;; U+1FAF + ("'\"QV" ?ᾯ) ;; U+1FAF + + ("qV" ?Ὼ) ;; U+1FFA + (";V" ?Ώ) ;; U+1FFB + ("\"V" ?ῼ) ;; U+1FFC + ("v" ?ω) ;; U+03C9 + ("qv" ?ὼ) ;; U+1F7C + (";v" ?ώ) ;; U+1F7D + (":v" ?ὠ) ;; U+1F60 + ("Qv" ?ὡ) ;; U+1F61 + (":qv" ?ὢ) ;; U+1F62 + ("q:v" ?ὢ) ;; U+1F62 + ("Qqv" ?ὣ) ;; U+1F63 + ("qQv" ?ὣ) ;; U+1F63 + (":;v" ?ὤ) ;; U+1F64 + (";:v" ?ὤ) ;; U+1F64 + ("Q;v" ?ὥ) ;; U+1F65 + (";Qv" ?ὥ) ;; U+1F65 + (":'v" ?ὦ) ;; U+1F66 + ("':v" ?ὦ) ;; U+1F66 + ("Q'v" ?ὧ) ;; U+1F67 + ("'Qv" ?ὧ) ;; U+1F67 + (":\"v" ?ᾠ) ;; U+1FA0 + ("\":v" ?ᾠ) ;; U+1FA0 + ("Q\"v" ?ᾡ) ;; U+1FA1 + ("\"Qv" ?ᾡ) ;; U+1FA1 + (":q\"v" ?ᾢ) ;; U+1FA2 + (":\"qv" ?ᾢ) ;; U+1FA2 + ("\":qv" ?ᾢ) ;; U+1FA2 + ("\"q:v" ?ᾢ) ;; U+1FA2 + ("q\":v" ?ᾢ) ;; U+1FA2 + + ("Qq\"v" ?ᾣ) ;; U+1FA3 + ("q\"Qv" ?ᾣ) ;; U+1FA3 + ("\"qQv" ?ᾣ) ;; U+1FA3 + ("\"Qqv" ?ᾣ) ;; U+1FA3 + ("Q\"qv" ?ᾣ) ;; U+1FA3 + + (":;\"v" ?ᾤ) ;; U+1FA4 + (":\";v" ?ᾤ) ;; U+1FA4 + ("\":;v" ?ᾤ) ;; U+1FA4 + ("\";:v" ?ᾤ) ;; U+1FA4 + (";\":v" ?ᾤ) ;; U+1FA4 + (";:\"v" ?ᾤ) ;; U+1FA4 + + ("Q;\"v" ?ᾥ) ;; U+1FA5 + ("Q\";v" ?ᾥ) ;; U+1FA5 + ("\"Q;v" ?ᾥ) ;; U+1FA5 + ("\";Qv" ?ᾥ) ;; U+1FA5 + (";\"Qv" ?ᾥ) ;; U+1FA5 + (";Q\"v" ?ᾥ) ;; U+1FA5 + + (":'\"v" ?ᾦ) ;; U+1FA6 + (":\"'v" ?ᾦ) ;; U+1FA6 + ("\":'v" ?ᾦ) ;; U+1FA6 + ("\"':v" ?ᾦ) ;; U+1FA6 + ("'\":v" ?ᾦ) ;; U+1FA6 + ("':\"v" ?ᾦ) ;; U+1FA6 + + ("Q'\"v" ?ᾧ) ;; U+1FA7 + ("Q\"'v" ?ᾧ) ;; U+1FA7 + ("\"Q'v" ?ᾧ) ;; U+1FA7 + ("\"'Qv" ?ᾧ) ;; U+1FA7 + ("'\"Qv" ?ᾧ) ;; U+1FA7 + ("'Q\"v" ?ᾧ) ;; U+1FA7 + + ("q\"v" ?ῲ) ;; U+1FF2 + ("\"qv" ?ῲ) ;; U+1FF2 + ("\"v" ?ῳ) ;; U+1FF3 + (";\"v" ?ῴ) ;; U+1FF4 + ("'v" ?ῶ) ;; U+1FF6 + ("'\"v" ?ῷ) ;; U+1FF7 + ("\"'v" ?ῷ) ;; U+1FF7 + ;;; Archaic Letters ;;; + ;; Stigma + ("ww" ?ϛ) ;; U+03DB Note that capital stigma (U+03DA) is an invalid letter. + ;; Digamma + ("wF" ?Ϝ) ;; U+03DC + ("wf" ?ϝ) ;; U+03DD + ;; Koppa + ("wK" ?Ϟ) ;; U+03DE + ("wk" ?ϟ) ;; U+03DF + ;; Sampi + ("wP" ?Ϡ) ;; U+03E0 + ("wp" ?ϡ) ;; U+03E1 + ;; Koppa + ("wO" ?Ϙ) ;; U+03D8 + ("wo" ?ϙ) ;; U+03D9 + ) + +(provide 'greek-polytonic) + ;;; greek.el ends here diff --git a/lisp/leim/quail/iroquoian.el b/lisp/leim/quail/iroquoian.el new file mode 100644 index 00000000000..3b4fdad62c2 --- /dev/null +++ b/lisp/leim/quail/iroquoian.el @@ -0,0 +1,1051 @@ +;;; iroquoian.el --- Quail packages for inputting Iroquoian languages -*- lexical-binding: t; coding: utf-8; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Kierin Bell <fernseed@fernseed.me> +;; Keywords: i18n + +;; This file is part of GNU Emacs. + +;; This program 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. + +;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file implements input methods for Northern Iroquoian languages. + +;; Input methods are implemented for all Five Nations Iroquois +;; languages: + +;; - Mohawk (Kanien’kéha / Onkwehonwehnéha) +;; - Oneida (Onʌyota:ká: / Ukwehuwehnéha) +;; - Onondaga (Onųdaʔgegáʔ) +;; - Cayuga (Gayogo̱ho:nǫhnéha:ˀ) +;; - Seneca (Onödowá’ga:’) + +;; A composite input method for all of the languages above is also +;; defined: `haudenosaunee-postfix'. + +;; Input methods are not yet implemented for the remaining Northern +;; Iroquoian languages, including: + +;; - Tuscarora (Skarù:ręʔ) +;; - Wendat (Huron) / Wyandot + +;;; Code: + +(require 'quail) +(require 'seq) +(require 'pcase) + + +;;; Mohawk + +;; +;; There are several orthographies used today to write Mohawk in +;; different communities, but differences are small and mainly involve +;; differences in representation of the palatal glide [j] (written <i> +;; in Eastern/Central dialects and <y> in Western dialects). The +;; following input method should work for all of variants. +;; +;; Reference work for orthographies used by speakers of Eastern +;; (Kahnawà:ke, Kanehsatà:ke, Wáhta) and Central (Ahkwesahsne) dialects +;; of Mohawk: +;; +;; Lazore, Dorothy Karihwénhawe. 1993. The Mohawk language +;; Standardisation Project, Conference Report. Ontario: Literacy +;; Ontario. +;; +;; Reference work for the orthography commonly used by speakers of +;; Western dialects of Mohawk (Tyendinaga, Ohswé:ken): +;; +;; Brian Maracle. 2021. 1st Year Adult Immersion Program 2020-21. +;; Ohsweken, ON, Canada: Onkwawenna Kentyohkwa. Unpublished curriculum +;; document written by staff for the Okwawenna Kentyohkwa adult +;; immersion program. +;; + +(defconst iroquoian-mohawk-modifier-alist nil + "Alist of rules for modifier letters in Mohawk input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-mohawk-vowel-alist + '(("a'" ?á) + ("a`" ?à) + ("A'" ?Á) + ("A`" ?À) + ("e'" ?é) + ("e`" ?è) + ("E'" ?É) + ("E`" ?È) + ("i'" ?í) + ("i`" ?ì) + ("I'" ?Í) + ("I`" ?Ì) + ("o'" ?ó) + ("o`" ?ò) + ("O'" ?Ó) + ("O`" ?Ò) + + ("a''" ["a'"]) + ("a``" ["a`"]) + ("A''" ["A'"]) + ("A``" ["A`"]) + ("e''" ["e'"]) + ("e``" ["e`"]) + ("E''" ["E'"]) + ("E``" ["E`"]) + ("i''" ["i'"]) + ("i``" ["i`"]) + ("I''" ["I'"]) + ("I``" ["I`"]) + ("o''" ["o'"]) + ("o``" ["o`"]) + ("O''" ["O'"]) + ("O``" ["O`"])) + "Alist of rules for vowel letters in Mohawk input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-mohawk-consonant-alist + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK})) + "Alist of rules for consonant letters in Mohawk input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "mohawk-postfix" "Mohawk" "MOH<" t + "Mohawk (Kanien’kéha) input method with postfix modifiers + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | +| \\=` | Grave accent | a` -> à | + +Doubling any of these postfixes separates the letter and the postfix. + +Vowels: + +a, e, i, and o are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-----+-------------+--------------| +| ;; | \\=’ | Glottal stop | + +h, k, n, r, s, t, w, and y are bound to a single key. + +b, m, and p are used rarely in ideophones and loan words. They are also +each bound to a single key. + +All Haudenosaunee languages, including Mohawk, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-mohawk-modifier-alist + iroquoian-mohawk-consonant-alist + iroquoian-mohawk-vowel-alist)) + (quail-defrule key trans)) + + +;;; Oneida + +;; +;; There are slight variations in the orthographies used today to write +;; Oneida. The differences mainly involve in representation of vowel +;; length and glottal stops. +;; +;; Reference work for Oneida orthography: +;; +;; Michelson, K., Doxtator, M. and Doxtator, M.A.. 2002. +;; Oneida-English/English-Oneida dictionary. Toronto: University of +;; Toronto Press. +;; +;; Orthographic variation from personal familiarity with community +;; language programs and curricula. +;; + +(defconst iroquoian-oneida-modifier-alist + '(("::" ?\N{MIDDLE DOT})) + "Alist of rules for modifier letters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-oneida-vowel-alist + '(("a'" ?á) + ("A'" ?Á) + ("e'" ?é) + ("E'" ?É) + ("i'" ?í) + ("I'" ?Í) + ("o'" ?ó) + ("O'" ?Ó) + ("u'" ?ú) + ("U'" ?Ú) + ("e/" ?ʌ) + ("e/'" ["ʌ́"]) + ("E/" ?Ʌ) + ("E/'" ["Ʌ́"]) + + ("a''" ["a'"]) + ("A''" ["A'"]) + ("e''" ["e'"]) + ("E''" ["E'"]) + ("i''" ["i'"]) + ("I''" ["I'"]) + ("o''" ["o'"]) + ("O''" ["O'"]) + ("u''" ["u'"]) + ("U''" ["U'"]) + ("e//" ["e/"]) + ("e/''" ["ʌ'"]) + ("E//" ["E/"]) + ("E/''" ["Ʌ'"])) + "Alist of rules for vowel letters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-oneida-consonant-alist + '((";;" ?\N{MODIFIER LETTER GLOTTAL STOP}) + (";'" ?\N{RIGHT SINGLE QUOTATION MARK})) + "Alist of rules for consonant letters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-oneida-devoicing-alist + '(("_" ?\N{COMBINING LOW LINE}) + ("__" ?_)) + "Alist of rules for devoicing characters in Oneida input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "oneida-postfix" "Oneida" "ONE<" t + "Oneida (Onʌyota:ká:) input method with postfix modifiers + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+-----------------------------------| +| e/ | ʌ | Mid central nasal vowel | +| E/ | Ʌ | Mid central nasal vowel (capital) | + +a, e, i, o, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| ;; | ˀ | Glottal stop | +| ;\\=' | \\=’ | Glottal stop (alternate) | + +h, k, l, n, s, t, w, and y are bound to a single key. + +Devoicing: + +| Key | Description | Example | +|-----+--------------------+----------| +| _ | Combining low line | a_ -> a̲ | + +Note: Not all fonts can properly display a combining low line on all +letters. + +Underlining is commonly used in Oneida to indicate devoiced syllables on +pre-pausal forms (also called utterance-final forms). Alternatively, +markup or other methods can be used to create an underlining effect. + +To enter a plain underscore, type the underscore twice. + +All Haudenosaunee languages, including Oneida, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-oneida-modifier-alist + iroquoian-oneida-consonant-alist + iroquoian-oneida-vowel-alist + iroquoian-oneida-devoicing-alist)) + (quail-defrule key trans)) + + +;;; Onondaga + +;; +;; There are three main orthographies for Onondaga in contemporary use: +;; the community orthography used at Six Nations of the Grand River, the +;; community orthography used at Onondaga Nation in New York, and the +;; orthography used by Hanni Woodbury in her 2003 dictionary (see +;; below). The latter is included because of its adoption in academia +;; and also by some contemporary second-language learners. +;; Additionally, Woodbury's dictionary provides a helpful description of +;; the community orthographies that is still applicable today. +;; +;; The differences between the orthographies are small, involving +;; representation of nasal vowels (ęand ǫat Six Nations of the Grand +;; River, eñ and oñ at Onondaga in New York, and ęand ųfollowing +;; Woodbury's dictionary), the low front rounded vowel (äat Six Nations +;; and Onondaga Nation and æ following Woodbury), vowel length (: +;; [colon] after a vowel in community orthographies and · [middle dot] +;; following Woodbury), and glottal stops (’ [right single quotation +;; mark] in community orthographies and ʔ [latin letter glottal stop] +;; following Woodbury). The input method here aims to accommodate all +;; three of these orthographies. +;; +;; Reference work for Onondaga orthography: +;; +;; Hanni Woodbury. 2003. Onondaga-English/English-Onondaga +;; Dictionary. Toronto: University of Toronto Press. +;; + +(defconst iroquoian-onondaga-modifier-alist + '(("::" ?\N{MIDDLE DOT})) + "Alist of rules for modifier letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-onondaga-vowel-alist + '(("a'" ?á) + ("A'" ?Á) + ("e'" ?é) + ("E'" ?É) + ("i'" ?í) + ("I'" ?Í) + ("o'" ?ó) + ("O'" ?Ó) + ("e," ?ę) + ("e,'" ["ę́"]) + ("E," ?Ę) + ("E,'" ["Ę́"]) + ("o," ?ǫ) + ("o,'" ["ǫ́"]) + ("O," ?Ǫ) + ("O,'" ["Ǫ́"]) + ("a\"" ?ä) + ("a\"'" ["ä́"]) + ("A\"" ?Ä) + ("A\"'" ["Ä́"]) + ;; From Woodbury (2003) orthography: + ("a/" ?æ) + ("a/'" ["ǽ"]) + ("A/" ?Æ) + ("A/'" ["Ǽ"]) + ("u," ?ų) + ("u,'" ["ų́"]) + ("U," ?Ų) + ("U,'" ["Ų́"]) + + ("a''" ["a'"]) + ("A''" ["A'"]) + ("e''" ["e'"]) + ("E''" ["E'"]) + ("i''" ["i'"]) + ("I''" ["I'"]) + ("o''" ["o'"]) + ("O''" ["O'"]) + ("e,," ["e,"]) + ("e,''" ["ę'"]) + ("E,," ["E,"]) + ("E,''" ["Ę'"]) + ("o,," ["o,"]) + ("o,''" ["ǫ'"]) + ("O,," ["O,"]) + ("O,''" ["Ǫ'"]) + ("a\"\"" ["a\""]) + ("a\"''" ["ä'"]) + ("A\"\"" ["A\""]) + ("A\"''" ["Ä'"]) + ("a//" ["a/"]) + ("a/''" ["æ'"]) + ("A//" ["A/"]) + ("A/''" ["Æ'"]) + ("u,," ["u,"]) + ("u,''" ["ų'"]) + ("U,," ["U,"]) + ("U,''" ["Ų'"])) + "Alist of rules for vowel letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-onondaga-consonant-alist + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK}) + (";:" ?\N{LATIN LETTER GLOTTAL STOP})) + "Alist of rules for consonant letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-onondaga-nasal-alist + '(("n-" ?ñ) + ("n--" ["n-"]) + ("N-" ?Ñ) + ("N--" ["N-"])) + "Alist of rules for nasal modifier letters in Onondaga input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "onondaga-postfix" "Onondaga" "ONO<" t + "Onondaga (Onųdaʔgegáʔ) input method with postfix modifiers + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length (alternate) | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+---------------------------------------| +| Six Nations of the Grand River orthography | +|-----------------------------------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Back high nasal vowel | +| O, | Ǫ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +|-----------------------------------------------------------| +| Onondaga Nation, New York orthography | +|-----------------------------------------------------------| +| en- | eñ | Mid front nasal vowel | +| EN- | EÑ | Mid front nasal vowel (capital) | +| on- | oñ | Back high nasal vowel | +| ON- | OÑ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +|-----------------------------------------------------------| +| Dictionary orthography (Hanni Woodbury, 2003) | +|-----------------------------------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| u, | ų | Back high nasal vowel | +| U, | Ų | Back high nasal vowel (capital) | +| a/ | æ | Low front rounded vowel | +| A/ | Æ | Low front rounded vowel (capital) | + +a, e, i, and o are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| ;; | \\=’ | Glottal stop | +| ;: | ʔ | Glottal stop (alternate) | + +c, d, g, h, j, k, n, s, t, w, and y are bound to a single key. + +All Haudenosaunee languages, including Onondaga, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-onondaga-modifier-alist + iroquoian-onondaga-consonant-alist + iroquoian-onondaga-nasal-alist + iroquoian-onondaga-vowel-alist)) + (quail-defrule key trans)) + + +;;; Cayuga + +;; +;; The primary community orthography used for the Cayuga language is +;; called the Henry orthography, after important language revitalist +;; Reginald Henry. There are slight variations, particularly in which +;; letter is used to represent the glottal stop. While the most common +;; seems to be <ˀ> [modifier letter glottal stop], this input method +;; provides mappings for other glottal stop letters in common use. +;; Other common orthographies should be covered by this input method as +;; well. +;; +;; Reference work for Cayuga orthography: +;; +;; Carrie Dyck, Frances Froman, Alfred Keye & Lottie Keye. 2024. A +;; grammar and dictionary of Gayogo̱hó:nǫˀ (Cayuga) (Estudios de +;; Lingüística Amerindia 1). Berlin: Language Science Press. +;; + +(defconst iroquoian-cayuga-modifier-alist nil + "Alist of rules for modifier letters in Cayuga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-cayuga-vowel-alist + '(("a'" ?á) + ("a-" ["a̱"]) + ("A'" ?Á) + ("A-" ["A̱"]) + ("e'" ?é) + ("e-" ["e̱"]) + ("E'" ?É) + ("E-" ["E̱"]) + ("i'" ?í) + ("i-" ["i̱"]) + ("I'" ?Í) + ("I-" ["I̱"]) + ("o'" ?ó) + ("o-" ["o̱"]) + ("O'" ?Ó) + ("O-" ["O̱"]) + ("u'" ?ú) + ("u-" ["u̱"]) + ("U'" ?Ú) + ("U-" ["U̱"]) + ("e," ?ę) + ("e,'" ["ę́"]) + ("e,-" ["ę̱"]) + ("E," ?Ę) + ("E,'" ["Ę́"]) + ("E,-" ["Ę̱"]) + ("o," ?ǫ) + ("o,'" ["ǫ́"]) + ("o,-" ["ǫ̱"]) + ("O," ?Ǫ) + ("O,'" ["Ǫ́"]) + ("O,-" ["Ǫ̱"]) + + ("a''" ["a'"]) + ("a--" ["a-"]) + ("A''" ["A'"]) + ("A--" ["A-"]) + ("e''" ["e'"]) + ("e--" ["e-"]) + ("E''" ["E'"]) + ("E--" ["E-"]) + ("i''" ["i'"]) + ("i--" ["i-"]) + ("I''" ["I'"]) + ("I--" ["I-"]) + ("o''" ["o'"]) + ("o--" ["o-"]) + ("O''" ["O'"]) + ("O--" ["O-"]) + ("u''" ["u'"]) + ("u--" ["u-"]) + ("U''" ["U'"]) + ("U--" ["U-"]) + ("e,," ["e,"]) + ("e,''" ["ę'"]) + ("e,--" ["ę-"]) + ("E,," ["E,"]) + ("E,''" ["Ę'"]) + ("E,--" ["Ę-"]) + ("o,," ["o,"]) + ("o,''" ["ǫ'"]) + ("o,--" ["ǫ-"]) + ("O,," ["O,"]) + ("O,''" ["Ǫ'"]) + ("O,--" ["Ǫ-"])) + "Alist of rules for vowel letters in Cayuga input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-cayuga-consonant-alist + '((";;" ?\N{MODIFIER LETTER GLOTTAL STOP}) + (";'" ?\N{RIGHT SINGLE QUOTATION MARK})) + "Alist of rules for consonant letters in Cayuga input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "cayuga-postfix" "Cayuga" "CAY<" t + "Cayuga (Gayogo̱ho:nǫhnéha:ˀ) input method with postfix modifiers + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | + +Doubling the postfix separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+---------------------------------| +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Mid back nasal vowel | +| O, | Ǫ | Mid back nasal vowel (capital) | + +a, e, i, o, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-------+-------------+--------------------------| +| ;; | ˀ | Glottal stop | +| ;\\=' | \\=’ | Glottal stop (alternate) | + +d, g, h, j, k, n, r, s, t, w, y, and f are bound to a single key. + +Devoicing: + +| Key | Description | Example | +|-----+------------------------+----------| +| - | Combining macron below | a- -> a̱ | + +Note: Not all fonts can properly display a combining macron low on all +vowels. + +To enter a plain hyphen after a vowel, simply type the hyphen twice. + +All Haudenosaunee languages, including Cayuga, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-cayuga-modifier-alist + iroquoian-cayuga-consonant-alist + iroquoian-cayuga-vowel-alist)) + (quail-defrule key trans)) + + +;;; Seneca + +;; +;; The orthography for the Seneca language is fairly stable with only +;; minor variations, for example, <sy> vs. <š> (currently preferred in +;; community orthography) for the voiceless postalveolar fricative. +;; +;; In the common community orthography, I'm told that acute and grave +;; accents occur rarely and only on nasal vowels (personal +;; communication). However, in works by Wallace Chafe, stress is +;; indicated on non-nasal vowels, as well. The maximal set of letters +;; with accent diacritics is included for the input method, even though +;; many of them apparently don't occur in community orthographies. +;; +;; Reference works for Seneca orthography: +;; +;; Phyllis E. Wms. Bardeau. 2002. Onondowa'ga:' Gawe:no': New Reference +;; Edition. Salamanca, NY: The Seneca Nation of Indians Allegany +;; Education Department. +;; +;; Wallace Chafe. 2015. A Grammar of the Seneca Language. Oakland, CA: +;; University of California Press. +;; + +(defconst iroquoian-seneca-modifier-alist nil + "Alist of rules for modifier letters in Seneca input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-seneca-vowel-alist + '(("a'" ?á) + ("a`" ?à) + ("A'" ?Á) + ("A`" ?À) + ("e'" ?é) + ("e`" ?è) + ("E'" ?É) + ("E`" ?È) + ("i'" ?í) + ("i`" ?ì) + ("I'" ?Í) + ("I`" ?Ì) + ("o'" ?ó) + ("o`" ?ò) + ("O'" ?Ó) + ("O`" ?Ò) + ("a\"" ?ä) + ("a\"'" ["ä́"]) + ("a\"`" ["ä̀"]) + ("A\"" ?Ä) + ("A\"'" ["Ä́"]) + ("A\"`" ["Ä̀"]) + ("e\"" ?ë) + ("e\"'" ["ë́"]) + ("e\"`" ["ë̀"]) + ("E\"" ?Ë) + ("E\"'" ["Ë́"]) + ("E\"`" ["Ë̀"]) + ("o\"" ?ö) + ("o\"'" ["ö́"]) + ("o\"`" ["ö̀"]) + ("O\"" ?Ö) + ("O\"'" ["Ö́"]) + ("O\"`" ["Ö̀"]) + ;; Rare (e.g., niwú’u:h 'it is tiny' [Chafe 2015]): + ("u'" ?ú) + ("u`" ?ù) + ("U'" ?Ú) + ("U`" ?Ù) + + ("a''" ["a'"]) + ("a``" ["a`"]) + ("A''" ["A'"]) + ("A``" ["A`"]) + ("e''" ["e'"]) + ("e``" ["e`"]) + ("E''" ["E'"]) + ("E``" ["E`"]) + ("i''" ["i'"]) + ("i``" ["i`"]) + ("I''" ["I'"]) + ("I``" ["I`"]) + ("o''" ["o'"]) + ("o``" ["o`"]) + ("O''" ["O'"]) + ("O``" ["O`"]) + ("a\"\"" ["a\""]) + ("a\"''" ["ä'"]) + ("a\"``" ["ä`"]) + ("A\"\"" ["A\""]) + ("A\"''" ["Ä'"]) + ("A\"``" ["Ä`"]) + ("e\"\"" ["e\""]) + ("e\"''" ["ë'"]) + ("e\"``" ["ë`"]) + ("E\"\"" ["E\""]) + ("E\"''" ["Ë'"]) + ("E\"``" ["Ë`"]) + ("o\"\"" ["o\""]) + ("o\"''" ["ö'"]) + ("o\"``" ["ö`"]) + ("O\"\"" ["O\""]) + ("O\"''" ["Ö'"]) + ("O\"``" ["Ö`"]) + ("u''" ["u'"]) + ("u``" ["u`"]) + ("U''" ["U'"]) + ("U``" ["U`"])) + "Alist of rules for vowel letters in Seneca input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-seneca-consonant-alist + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK}) + ("s/" ?š) + ("s//" ["s/"]) + ("S/" ?Š) + ("S//" ["S/"])) + "Alist of rules for consonant letters in Seneca input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "seneca-postfix" "Seneca" "SEE<" t + "Seneca (Onödowá’ga:’) input method with postfix modifiers + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á| +| \\=` | Grave accent | a` -> à| + +Doubling any of these postfixes separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|-----+-------------+------------------------------------| +| e\" | ë | Mid front nasal vowel | +| E\" | Ë | Mid front nasal vowel (capital) | +| o\" | ö | Low-mid back nasal vowel | +| O\" | Ö | Low-mid back nasal vowel (capital) | +| a\" | ä | Low front vowel | +| A\" | Ä | Low front vowel (capital) | + +a, e, i, o, and u are bound to a single key. + +Consonants: + +| Key | Translation | Description | +|-------+-------------+--------------------------------------------| +| ;; | \\=’ | Glottal stop | +| s/ | š | Voiceless postalveolar fricative | +| S/ | Š | Voiceless postalveolar fricative (capital) | + +d, g, h, j, k, n, s, t, w, y, and z are bound to a single key. + +b, m, and p are used rarely in ideophones and nicknames. They are also +each bound to a single key. + +All Haudenosaunee languages, including Seneca, can be input +simultaneously using the input method `haudenosaunee-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-seneca-modifier-alist + iroquoian-seneca-consonant-alist + iroquoian-seneca-vowel-alist)) + (quail-defrule key trans)) + + +;;; Haudenosaunee (composite Northern Iroquoian) + +;; +;; This input method represents a composite input method for all of the +;; Northern Iroquoian languages included above. +;; +;; Although the "Iroquoian languages" is a standard term employed by +;; linguists and scholars, some believe the term "Iroquois" to be of +;; derogatory origin (see Dyck 2024). Hence, some prefer to refer to +;; what are collectively termed by linguists the "Five Nations Iroquois" +;; languages (Mohawk, Oneida, Onondaga, Cayuga, Seneca) by the autonym +;; "Haudenosaunee" (e.g., "Haudenosaunee languages"). +;; +;; However, it should be noted that the term "Haudenosaunee" is itself +;; an Anglicized form, probably from Seneca Hodínöhsö:ni:h 'they make +;; houses' or Hodínöhšo:ni:h 'People of the Long House'. Speakers of +;; Cayuga may prefer the word Hodinǫhsǫ:nih, and speakers of Mohawk may +;; prefer Rotinonhsón:ni or Rotinonhsíón:ni. These terms themselves +;; collectively relate to the confederacy of Indigenous nations that has +;; existed in what is now known as New York State in Northeastern North +;; America for many centuries, the founding of which is retold in oral +;; tradition in the story of The Peacemaker. +;; +;; It should also be noted that while Tuscarora and Wendat languages are +;; both sometimes included under the "Haudenosaunee languages" umbrella +;; (and by implication, those groups as a part of the Haudenosaunee +;; Confederacy), the exact extent of what defines "Haudenosaunee" has +;; occasionally caused controversy. +;; +;; Additionally, some prefer to collectively refer to the "Haudenosaunee +;; languages" using the terms Onkwehonwehnéha (Mohawk), Ukwehuwehnéha +;; (Oneida), Ǫgwehǫwekhá’ (Onondaga), Ǫgwehǫwéhneha:ˀ (Cayuga), and +;; Ögwé’öwe:ka:’ (Seneca), which all mean 'in the manner of the Original +;; People'. +;; +;; Bearing all of this in mind, I have opted to retain the term +;; "Iroquoian" in the name of this file (`iroquoian.el') (and hence, in +;; the symbol names in its namespace), while using "Haudenosaunee" in +;; the name of the input method that encompasses all of the languages so +;; far implemented: "haudenosaunee-postfix" --- this is the name shown +;; as a completion candidate after users enter M-x set-input-method RET. +;; Note that those searching for input methods for the individual +;; languages should have no problem finding them knowing only their +;; Anglicized names (e.g., Mohawk, Oneida, etc.), as these have been +;; retained in the names of the corresponding input methods. +;; +;; Above all, I hope that these decisions help those who wish to speak, +;; read, and write Onkwehonwehnéha. +;; +;; Iorihowá:nen ne aiónhnheke’ ne raotiwén:na’! +;; It is important that the language continues to live! +;; + +(defconst iroquoian-haudenosaunee-modifier-alist + (seq-uniq (append iroquoian-mohawk-modifier-alist + iroquoian-oneida-modifier-alist + iroquoian-onondaga-modifier-alist + iroquoian-cayuga-modifier-alist + iroquoian-seneca-modifier-alist)) + "Alist of rules for modifier letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-vowel-alist + (seq-uniq (append iroquoian-mohawk-vowel-alist + iroquoian-oneida-vowel-alist + iroquoian-onondaga-vowel-alist + iroquoian-cayuga-vowel-alist + iroquoian-seneca-vowel-alist)) + "Alist of rules for vowel letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-consonant-alist + (seq-uniq (append + '((";;" ?\N{RIGHT SINGLE QUOTATION MARK}) + (";'" ?\N{MODIFIER LETTER GLOTTAL STOP}) + (";:" ?\N{LATIN LETTER GLOTTAL STOP})) + iroquoian-mohawk-consonant-alist + iroquoian-oneida-consonant-alist + iroquoian-onondaga-consonant-alist + iroquoian-cayuga-consonant-alist + iroquoian-seneca-consonant-alist) + (lambda (c1 c2) + (equal (car c1) (car c2)))) + "Alist of rules for consonant letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-devoicing-alist + '(("_" ?\N{COMBINING LOW LINE}) + ("__" ?_)) + "Alist of rules for devoicing characters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(defconst iroquoian-haudenosaunee-nasal-alist iroquoian-onondaga-nasal-alist + "Alist of rules for nasal modifier letters in Haudenosaunee input methods. +Entries are as with rules in `quail-define-rules'.") + +(quail-define-package + "haudenosaunee-postfix" "Haudenosaunee" "HOD<" t + "Composite input method for Haudenosaunee (Northern Iroquoian) languages + +This input method can be used to enter the following languages: + +- Mohawk (Kanien’kéha / Onkwehonwehnéha) +- Oneida (Onʌyota:ká: / Ukwehuwehnéha) +- Cayuga (Gayogo̱ho:nǫhnéha:ˀ) +- Onondaga (Onųdaʔgegáʔ) +- Seneca (Onödowá’ga:’) + +Modifiers: + +| Key | Translation | Description | +|-----+-------------+--------------------------| +| :: | · | Vowel length (alternate) | + +Stress diacritics: + +| Key | Description | Example | +|------+--------------+---------| +| \\=' | Acute accent | a' -> á | +| \\=` | Grave accent | a` -> à | + +Doubling any of these postfixes separates the letter and the postfix. + +Vowels: + +| Key | Translation | Description | +|----------------------------------------------------------------------| +| Mohawk | +| -------------------------------------------------------------------- | +| Single-key vowels: a e i o | +|----------------------------------------------------------------------| +| Oneida | +| -------------------------------------------------------------------- | +| e/ | ʌ | Mid central nasal vowel | +| E/ | Ʌ | Mid central nasal vowel (capital) | +| Single-key vowels: a e i o u | +|----------------------------------------------------------------------| +| Onondaga | +| (Six Nations of the Grand River) | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Back high nasal vowel | +| O, | Ǫ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +| -------------------------------------------------------------------- | +| (Onondaga Nation, New York) | +| -------------------------------------------------------------------- | +| en~ | eñ | Mid front nasal vowel | +| EN~ | EÑ | Mid front nasal vowel (capital) | +| on~ | oñ | Back high nasal vowel | +| ON~ | OÑ | Back high nasal vowel (capital) | +| a\" | ä | Low front rounded vowel | +| A\" | Ä | Low front rounded vowel (capital) | +| -------------------------------------------------------------------- | +| (Hanni Woodbury, 2003) | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| u, | ų | Back high nasal vowel | +| U, | Ų | Back high nasal vowel (capital) | +| a/ | æ | Low front rounded vowel | +| A/ | Æ | Low front rounded vowel (capital) | +| -------------------------------------------------------------------- | +| (all) | +| -------------------------------------------------------------------- | +| Single-key vowels: a e i o | +|----------------------------------------------------------------------| +| Cayuga | +| -------------------------------------------------------------------- | +| e, | ę | Mid front nasal vowel | +| E, | Ę | Mid front nasal vowel (capital) | +| o, | ǫ | Mid back nasal vowel | +| O, | Ǫ | Mid back nasal vowel (capital) | +| Single-key vowels: a e i o u | +|----------------------------------------------------------------------| +| Seneca | +| -------------------------------------------------------------------- | +| e\" | ë | Mid front nasal vowel | +| E\" | Ë | Mid front nasal vowel (capital) | +| o\" | ö | Low-mid back nasal vowel | +| O\" | Ö | Low-mid back nasal vowel (capital) | +| a\" | ä | Low front vowel | +| A\" | Ä | Low front vowel (capital) | +| Single-key vowels: a e i o u | + +Consonants: + +| Key | Translation | Description | +|----------------------------------------------------------------------| +| Mohawk | +| -------------------------------------------------------------------- | +| ;; | \\=’ | Glottal stop | +| Single-key consonants: h k n r s t w y (b m p) | +|----------------------------------------------------------------------| +| Oneida | +| -------------------------------------------------------------------- | +| ;\\=' | ˀ | Glottal stop | +| ;; | \\=’ | Glottal stop (alternate) | +| Single-key consonants: h k l n s t w y | +|----------------------------------------------------------------------| +| Onondaga | +| -------------------------------------------------------------------- | +| ;; | \\=’ | Glottal stop | +| ;: | ʔ | Glottal stop (alternate) | +| Single-key consonants: c d g h j k n s t w y | +|----------------------------------------------------------------------| +| Cayuga | +| -------------------------------------------------------------------- | +| ;\\=' | ˀ | Glottal stop | +| ;; | \\=’ | Glottal stop (alternate) | +| Single-key consonants: d g h j k n r s t w y (f) | +|----------------------------------------------------------------------| +| Seneca | +| -------------------------------------------------------------------- | +| ;; | \\=’ | Glottal stop | +| s/ | š | Voiceless postalveolar fricative | +| S/ | Š | Voiceless postalveolar fricative (capital) | +| Single-key consonants: d g h j k n s t w y z (b m p) | + +Devoicing: + +| Key | Description | Examples | +|-----+------------------------+------------------------------| +| _ | Combining low line | a_ -> a̲, · -> ·̲ | +| - | Combining macron below | a- -> a̱(after vowels only) | + +Note: Not all fonts can properly display a combining low line on all +letters and a combining macron below on all vowels. + +Underlining is commonly used in Oneida to indicate devoiced syllables on +pre-pausal forms (also called utterance-final forms). Alternatively, +markup or other methods can be used to create an underlining effect. + +To enter a plain underscore, the underscore twice. + +Macron below is commonly used in Cayuga to indicate devoiced vowels. + +To enter a plain hyphen after a vowel, simply type the hyphen twice. + +There are individual input methods for each of the languages that can be +entered with this input method: `mohawk-postfix', `oneida-postfix', +`onondaga-postfix', `cayuga-postfix', `seneca-postfix'." + nil t nil nil nil nil nil nil nil nil t) + +(pcase-dolist (`(,key ,trans) + (append iroquoian-haudenosaunee-modifier-alist + iroquoian-haudenosaunee-consonant-alist + iroquoian-haudenosaunee-nasal-alist + iroquoian-haudenosaunee-vowel-alist + iroquoian-haudenosaunee-devoicing-alist)) + (quail-defrule key trans)) + +(provide 'iroquoian) +;;; iroquoian.el ends here diff --git a/lisp/leim/quail/tifinagh.el b/lisp/leim/quail/tifinagh.el new file mode 100644 index 00000000000..6a138396143 --- /dev/null +++ b/lisp/leim/quail/tifinagh.el @@ -0,0 +1,67 @@ +;;; tifinagh.el --- Quail package for inputting Tifinagh -*- coding: utf-8; lexical-binding:t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Adam Oudad <adam.oudad@gmail.com> +;; Keywords: mule, input method, Tifinagh + +(require 'quail) + +(quail-define-package + "tifinagh" "Tininagh" "ⵣ" nil "Tifinagh input method. + +Based on Tifinagh table in X Keyboard Configuration DB. +" nil t t t t nil nil nil nil nil t) + +;; FIXME: This doesn't cover all of the codepoints that Unicode has +;; defined for the Tifinagh script. +(quail-define-rules + ("Q" ?ⵈ) + ("W" ?ⵯ) + ("R" ?ⵕ) + ("T" ?ⵟ) + ("P" ?ⵒ) + + ("S" ?ⵚ) + ("D" ?ⴹ) + ("G" ?ⴶ) + ("H" ?ⵂ) + ("J" ?ⵌ) + ("K" ?ⴾ) + + ("Z" ?ⵥ) + ("X" ?ⵝ) + ("C" ?ⵞ) + ("V" ?ⵗ) + + ("q" ?ⵇ) + ("w" ?ⵡ) + ("e" ?ⴻ) + ("r" ?ⵔ) + ("t" ?ⵜ) + ("y" ?ⵢ) + ("u" ?ⵓ) + ("i" ?ⵉ) + ("o" ?ⵄ) + ("p" ?ⵃ) + + ("a" ?ⴰ) + ("s" ?ⵙ) + ("d" ?ⴷ) + ("f" ?ⴼ) + ("g" ?ⴳ) + ("h" ?ⵀ) + ("j" ?ⵊ) + ("k" ?ⴽ) + ("l" ?ⵍ) + + ("z" ?ⵣ) + ("x" ?ⵅ) + ("c" ?ⵛ) + ("v" ?ⵖ) + ("b" ?ⴱ) + ("n" ?ⵏ) + ("m" ?ⵎ) + ) + +;;; tifinagh.el ends here diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index e89e66cc7cb..285095f9264 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -493,7 +493,7 @@ and send the mail again%s." (re-search-forward "^From: " nil t) (error "Please edit the From address and try again")))) ;; Bury the help buffer (if it's shown). - (when-let ((help (get-buffer "*Bug Help*"))) + (when-let* ((help (get-buffer "*Bug Help*"))) (when (get-buffer-window help) (quit-window nil (get-buffer-window help))))) @@ -532,6 +532,8 @@ Message buffer where you can explain more about the patch." (view-mode 1) (button-mode 1)) (compose-mail-other-window report-emacs-bug-address subject) + (rfc822-goto-eoh) + (insert "X-Debbugs-Cc: \n") (message-goto-body) (insert "\n\n\n") (emacs-build-description) @@ -547,7 +549,7 @@ Message buffer where you can explain more about the patch." (message-add-action (lambda () ;; Bury the help buffer (if it's shown). - (when-let ((help (get-buffer "*Patch Help*"))) + (when-let* ((help (get-buffer "*Patch Help*"))) (when (get-buffer-window help) (quit-window nil (get-buffer-window help))))) 'send)) diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index 919490ec5aa..d4ad7d45982 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -78,7 +78,9 @@ RFC 2646 suggests 66 characters for readability." (let ((start (point-min)) end) ;; Go through each paragraph, filling it and adding SPC ;; as the last character on each line. - (while (setq end (text-property-any start (point-max) 'hard 't)) + (while (and (< start (point-max)) + (setq end (or (text-property-any start (point-max) 'hard 't) + (point-max)))) (save-restriction (narrow-to-region start end) (let ((fill-column (eval fill-flowed-encode-column t))) diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index eaccbff0b13..e314b3d13ae 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -275,11 +275,11 @@ a list of address strings." ((eq c ?:) (setq beg (1+ (point))) (skip-chars-forward "^;") - (when-let ((address - (condition-case nil - (ietf-drums-parse-addresses - (buffer-substring beg (point)) rawp) - (error nil)))) + (when-let* ((address + (condition-case nil + (ietf-drums-parse-addresses + (buffer-substring beg (point)) rawp) + (error nil)))) (if (listp address) (setq pairs (append address pairs)) (push address pairs))) diff --git a/lisp/mail/mailclient.el b/lisp/mail/mailclient.el index 1233d9ace95..fe4e49d0e1b 100644 --- a/lisp/mail/mailclient.el +++ b/lisp/mail/mailclient.el @@ -143,7 +143,7 @@ The mail client is taken to be the handler of mailto URLs." (narrow-to-region (point-min) delimline) ;; We can't send multipart/* messages (i. e. with ;; attachments or the like) via this method. - (when-let ((type (mail-fetch-field "content-type"))) + (when-let* ((type (mail-fetch-field "content-type"))) (when (and (string-match "multipart" (car (mail-header-parse-content-type type))) diff --git a/lisp/mail/rfc6068.el b/lisp/mail/rfc6068.el index 06fe92f0ca7..562e2312f3f 100644 --- a/lisp/mail/rfc6068.el +++ b/lisp/mail/rfc6068.el @@ -72,7 +72,7 @@ calling this function." (when address (setq address (rfc6068-unhexify-string address)) ;; Deal with multiple 'To' recipients. - (if-let ((elem (assoc "To" headers-alist))) + (if-let* ((elem (assoc "To" headers-alist))) (setcdr elem (concat address ", " (cdr elem))) (push (cons "To" address) headers-alist))) diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 5e3633d221c..e38ab12fae6 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -2955,51 +2955,56 @@ charset= headers. This function assumes that the current message is already decoded and displayed in the RMAIL buffer, but the coding system used to decode it was incorrect. It then decodes the message again, -using the coding system CODING." +using the coding system CODING. + +This function does nothing (except reporting a user-error) +if `rmail-enable-mime' is non-nil." (interactive "zCoding system for re-decoding this message: ") - (when (not rmail-enable-mime) - (with-current-buffer rmail-buffer - (rmail-swap-buffers-maybe) - (save-restriction - (widen) - (let ((msgbeg (rmail-msgbeg rmail-current-message)) - (msgend (rmail-msgend rmail-current-message)) - (buffer-read-only nil) - body-start x-coding-header old-coding) - (narrow-to-region msgbeg msgend) - (goto-char (point-min)) - (unless (setq body-start (search-forward "\n\n" (point-max) 1)) - (error "No message body")) - - (save-restriction - ;; Narrow to headers - (narrow-to-region (point-min) body-start) - (setq x-coding-header (goto-char (point-min))) - (if (not (re-search-forward "^X-Coding-System: *\\(.*\\)$" nil t)) - (setq old-coding (rmail-get-coding-system)) - (setq old-coding (intern (match-string 1))) - (setq x-coding-header (point))) - (check-coding-system old-coding) - ;; Make sure the new coding system uses the same EOL - ;; conversion, to prevent ^M characters from popping up - ;; all over the place. - (let ((eol-type (coding-system-eol-type old-coding))) - (if (numberp eol-type) - (setq coding - (coding-system-change-eol-conversion coding eol-type)))) - (when (not (coding-system-equal - (coding-system-base old-coding) - (coding-system-base coding))) - ;; Rewrite the coding-system header. - (goto-char x-coding-header) - (if (> (point) (point-min)) - (delete-region (line-beginning-position) (point)) - (forward-line) - (insert "\n") - (forward-line -1)) - (insert "X-Coding-System: " - (symbol-name coding)))) - (rmail-show-message)))))) + (if (not rmail-enable-mime) + (with-current-buffer rmail-buffer + (rmail-swap-buffers-maybe) + (save-restriction + (widen) + (let ((msgbeg (rmail-msgbeg rmail-current-message)) + (msgend (rmail-msgend rmail-current-message)) + (buffer-read-only nil) + body-start x-coding-header old-coding) + (narrow-to-region msgbeg msgend) + (goto-char (point-min)) + (unless (setq body-start (search-forward "\n\n" (point-max) 1)) + (error "No message body")) + + (save-restriction + ;; Narrow to headers + (narrow-to-region (point-min) body-start) + (setq x-coding-header (goto-char (point-min))) + (if (not (re-search-forward "^X-Coding-System: *\\(.*\\)$" nil t)) + (setq old-coding (rmail-get-coding-system)) + (setq old-coding (intern (match-string 1))) + (setq x-coding-header (point))) + (check-coding-system old-coding) + ;; Make sure the new coding system uses the same EOL + ;; conversion, to prevent ^M characters from popping up + ;; all over the place. + (let ((eol-type (coding-system-eol-type old-coding))) + (if (numberp eol-type) + (setq coding + (coding-system-change-eol-conversion coding eol-type)))) + (when (not (coding-system-equal + (coding-system-base old-coding) + (coding-system-base coding))) + ;; Rewrite the coding-system header. + (goto-char x-coding-header) + (if (> (point) (point-min)) + (delete-region (line-beginning-position) (point)) + (forward-line) + (insert "\n") + (forward-line -1)) + (insert "X-Coding-System: " + (symbol-name coding)))) + (rmail-show-message)))) + (user-error + (substitute-quotes "`rmail-enable-mime' is non-nil; disable it first")))) (defun rmail-highlight-headers () "Highlight the headers specified by `rmail-highlighted-headers'. diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index d2dcedce93e..38fded9b4c3 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -84,6 +84,11 @@ Message A is parent of message B if the id of A appears in the \"References\" or \"In-reply-to\" fields of B, or if A is the first message with the same \"Subject\" as B. First element is ignored.") +(defcustom rmail-summary-starting-message 1 + "Message number to start summarizing at." + :type 'integer + :group 'rmail-summary) + (defvar rmail-summary-message-descendants-vector nil "Vector that holds the direct descendants of each message. This is the antipode of `rmail-summary-message-parents-vector'. @@ -700,7 +705,7 @@ message." (sumbuf (rmail-get-create-summary-buffer))) ;; Scan the messages, getting their summary strings ;; and putting the list of them in SUMMARY-MSGS. - (let ((msgnum 1) + (let ((msgnum rmail-summary-starting-message) (main-buffer (current-buffer)) (total rmail-total-messages) (inhibit-read-only t)) diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 98083c0489a..c98fdfd10ed 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -800,11 +800,7 @@ Returns an error if the server cannot be contacted." (smtpmail-command-or-throw process (format "HELO %s" (smtpmail-fqdn))) ;; EHLO was successful, so we parse the extensions. - (dolist (line (delete - "" - (split-string - (plist-get (cdr result) :capabilities) - "\r\n"))) + (dolist (line (delete "" (split-string capabilities "\r\n"))) (let ((name ;; Use ASCII case-table to prevent I ;; downcasing to a dotless i under some diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index add1582d72a..a3b5542bfdc 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -1244,9 +1244,7 @@ to the auto-selected attribution string." ;; ====================================================================== -;; filladapt hooks for supercite 3.1. you shouldn't need anything -;; extra to make gin-mode understand supercited lines. Even this -;; stuff might not be entirely necessary... +;; filladapt hooks for supercite 3.1. (defun sc-cite-regexp (&optional root-regexp) "Return a regexp describing a Supercited line. diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el index 98ac17a99ed..c70880b0632 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -65,7 +65,7 @@ each undigestified message as markers.") (defun rmail-digest-parse-mixed-mime () "Like `rmail-digest-parse-mime', but for multipart/mixed messages." - (when-let ((boundary (rmail-content-type-boundary "multipart/mixed"))) + (when-let* ((boundary (rmail-content-type-boundary "multipart/mixed"))) (let ((global-sep (concat "\n--" boundary)) (digest (concat "^Content-type: multipart/digest;" "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]")) diff --git a/lisp/man.el b/lisp/man.el index 816c75d749c..d5ac8b93d99 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -973,6 +973,27 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description" (search-forward-regexp "\\=, *\\([^ \t,]+\\)" bound t))))) (nreverse table))) +(defvar Man-man-k-flags + ;; It's not clear which man page will "always" be available, `man -k man' + ;; seems like the safest choice, but `man -k apropos' seems almost as safe + ;; and usually returns a much shorter output. + (with-temp-buffer + (with-demoted-errors "%S" (call-process "man" nil t nil "-k" "apropos")) + (let ((lines (count-lines (point-min) (point-max))) + (completions (Man-parse-man-k))) + (if (>= (length completions) lines) + '("-k") ;; "-k" seems to return sane results: look no further! + (erase-buffer) + ;; Try "-k -l" (bug#73656). + (with-demoted-errors "%S" (call-process "man" nil t nil + "-k" "-l" "apropos")) + (let ((lines (count-lines (point-min) (point-max))) + (completions (Man-parse-man-k))) + (if (and (> lines 0) (>= (length completions) lines)) + '("-k" "-l") ;; "-k -l" seems to return sane results. + '("-k")))))) + "List of arguments to pass to get the expected \"man -k\" output.") + (defun Man-completion-table (string pred action) (cond ;; This ends up returning t for pretty much any string, and hence leads to @@ -1007,9 +1028,13 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description" ;; error later. (when (eq 0 (ignore-errors - (process-file + (apply + #'process-file manual-program nil '(t nil) nil - "-k" (concat (when (or Man-man-k-use-anchor + ;; FIXME: When `process-file' runs on a remote hosts, + ;; `Man-man-k-flags' may be wrong. + `(,@Man-man-k-flags + ,(concat (when (or Man-man-k-use-anchor (string-equal prefix "")) "^") (if (string-equal prefix "") @@ -1021,7 +1046,7 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description" ;; But we don't have that, and ;; shell-quote-argument does ;; the job... - (shell-quote-argument prefix)))))) + (shell-quote-argument prefix))))))) (setq table (Man-parse-man-k))))) ;; Cache the table for later reuse. (when table diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index efce55032c8..b85cc834588 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1359,8 +1359,7 @@ mail status in mode line")) :visible (seq-some #'local-variable-p '(outline-search-function outline-regexp outline-level)) - :button (:toggle . (and (boundp 'outline-minor-mode) - outline-minor-mode)))) + :button (:toggle . (bound-and-true-p outline-minor-mode)))) (bindings--define-key menu [showhide-tab-line-mode] '(menu-item "Window Tab Line" global-tab-line-mode diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index 3d686b4a777..0a72773549e 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -2008,9 +2008,9 @@ absolute pathname, it is assumed to be in the `mh-progs' directory. You may link another program to `scan' (see \"mh-profile(5)\") to produce a different type of listing." :type 'string + :local t :group 'mh-scan-line-formats :package-version '(MH-E . "6.0")) -(make-variable-buffer-local 'mh-scan-prog) ;;; Searching (:group 'mh-search) diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index c90537f1502..7cbcf9f1c0f 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -454,11 +454,10 @@ FACE is the font-lock face used to display the matching scan lines." (let ((cache (intern (format "mh-folder-%s-seq-cache" prefix))) (func (intern (format "mh-folder-font-lock-%s" prefix)))) `(progn - (defvar ,cache nil + (defvar-local ,cache nil "Internal cache variable used for font-lock in MH-E. Should only be non-nil through font-lock stepping, and nil once font-lock is done highlighting.") - (make-variable-buffer-local ',cache) (defun ,func (limit) "Return unseen message lines to font-lock between point and LIMIT." diff --git a/lisp/midnight.el b/lisp/midnight.el index 3578d702f07..a7c33f331f7 100644 --- a/lisp/midnight.el +++ b/lisp/midnight.el @@ -52,12 +52,12 @@ the time when it is run.") "Non-nil means run `midnight-hook' at midnight." :global t :initialize #'custom-initialize-default - ;; Disable first, since the ':initialize' function above already - ;; starts the timer when the mode is turned on for the first time, - ;; via setting 'midnight-delay', which calls 'midnight-delay-set', - ;; which starts the timer. - (when (timerp midnight-timer) (cancel-timer midnight-timer)) - (if midnight-mode (timer-activate midnight-timer))) + ;; Call `midnight-delay-set' again because it takes care of starting + ;; the timer if the mode is on. The ':initialize' function above + ;; (which ends up calling `midnight-delay-set') did not know yet if + ;; the mode was on or not. + (defvar midnight-delay) + (midnight-delay-set 'midnight-delay midnight-delay)) ;;; clean-buffer-list stuff @@ -167,7 +167,7 @@ lifetime, i.e., its \"age\" when it will be purged." bn (buffer-name buf) delay (if bts (round (float-time (time-subtract tm bts))) 0) cbld (clean-buffer-list-delay bn)) - (message "[%s] `%s' [%s %d]" ts bn delay cbld) + (message "[%s] `%s' [%d %d]" ts bn delay cbld) (unless (or (cl-find bn clean-buffer-list-kill-never-regexps :test (lambda (bn re) (if (functionp re) @@ -179,7 +179,8 @@ lifetime, i.e., its \"age\" when it will be purged." (and (buffer-file-name buf) (buffer-modified-p buf)) (get-buffer-window buf 'visible) (< delay cbld)) - (message "[%s] killing `%s'" ts bn) + (message "[%s] killing `%s' (last displayed %s ago)" ts bn + (format-seconds "%Y, %D, %H, %M, %z%S" delay)) (kill-buffer buf)))))) ;;; midnight hook @@ -206,9 +207,11 @@ to its second argument TM." "Invalid argument to `midnight-delay-set': `%s'") (set symb tm) (when (timerp midnight-timer) (cancel-timer midnight-timer)) - (setq midnight-timer - (run-at-time (if (numberp tm) (+ (midnight-next) tm) tm) - midnight-period #'run-hooks 'midnight-hook))) + ;; Only start the timer if the mode is turned on. + (when midnight-mode + (setq midnight-timer + (run-at-time (if (numberp tm) (+ (midnight-next) tm) tm) + midnight-period #'run-hooks 'midnight-hook)))) (defcustom midnight-delay 3600 "The number of seconds after the midnight when the `midnight-timer' is run. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index fef8e1df86e..405ee21cdb2 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -168,9 +168,9 @@ specify the property, the `completion-extra-properties' plist is consulted. Note that the keys of the `completion-extra-properties' plist are keyword symbols, not plain symbols." - (if-let (((not (eq prop 'category))) - (cat (completion--metadata-get-1 metadata 'category)) - (over (completion--category-override cat prop))) + (if-let* (((not (eq prop 'category))) + (cat (completion--metadata-get-1 metadata 'category)) + (over (completion--category-override cat prop))) (cdr over) (completion--metadata-get-1 metadata prop))) @@ -1119,8 +1119,10 @@ and DOC describes the way this style of completion works.") widget)) (defconst completion--styles-type - `(repeat :tag "insert a new menu to add more styles" - (choice :convert-widget completion--update-styles-options))) + '(repeat :tag "insert a new menu to add more styles" + (single-or-list + (choice :convert-widget completion--update-styles-options) + (repeat :tag "Variable overrides" (group variable sexp))))) (defconst completion--cycling-threshold-type '(choice (const :tag "No cycling" nil) @@ -1141,12 +1143,20 @@ and DOC describes the way this style of completion works.") ;; and simply add "bar" to the end of the result. emacs22) "List of completion styles to use. -The available styles are listed in `completion-styles-alist'. +An element should be a symbol which is listed in +`completion-styles-alist'. + +An element can also be a list of the form +(STYLE ((VARIABLE VALUE) ...)) +STYLE must be a symbol listed in `completion-styles-alist', followed by +a `let'-style list of variable/value pairs. VARIABLE will be bound to +VALUE (without evaluating it) while the style is handling completion. +This allows repeating the same style with different configurations. Note that `completion-category-overrides' may override these styles for specific categories, such as files, buffers, etc." :type completion--styles-type - :version "23.1") + :version "31.1") (defvar completion-category-defaults '((buffer (styles . (basic substring))) @@ -1197,7 +1207,7 @@ completing buffer and file names, respectively. If a property in a category is specified by this variable, it overrides the default specified in `completion-category-defaults'." - :version "25.1" + :version "31.1" :type `(alist :key-type (choice :tag "Category" (const buffer) (const file) @@ -1284,11 +1294,18 @@ overrides the default specified in `completion-category-defaults'." (result-and-style (seq-some (lambda (style) - (let ((probe (funcall - (or (nth n (assq style completion-styles-alist)) - (error "Invalid completion style %s" style)) - string table pred point))) - (and probe (cons probe style)))) + (let (symbols values) + (when (consp style) + (dolist (binding (cadr style)) + (push (car binding) symbols) + (push (cadr binding) values)) + (setq style (car style))) + (cl-progv symbols values + (let ((probe (funcall + (or (nth n (assq style completion-styles-alist)) + (error "Invalid completion style %s" style)) + string table pred point))) + (and probe (cons probe style)))))) (completion--styles md))) (adjust-fn (get (cdr result-and-style) 'completion--adjust-metadata))) (when (and adjust-fn metadata) @@ -2547,7 +2564,7 @@ The candidate will still be chosen by `choose-completion' unless (defun completions--after-change (_start _end _old-len) "Update displayed *Completions* buffer after change in buffer contents." (when completion-auto-deselect - (when-let (window (get-buffer-window "*Completions*" 0)) + (when-let* ((window (get-buffer-window "*Completions*" 0))) (with-selected-window window (completions--deselect))))) @@ -2607,6 +2624,13 @@ The candidate will still be chosen by `choose-completion' unless (sort-fun (completion-metadata-get all-md 'display-sort-function)) (group-fun (completion-metadata-get all-md 'group-function)) (mainbuf (current-buffer)) + (current-candidate-and-offset + (when-let* ((buffer (get-buffer "*Completions*")) + (window (get-buffer-window buffer 0))) + (with-current-buffer buffer + (when-let* ((cand (completion-list-candidate-at-point + (window-point window)))) + (cons (car cand) (- (point) (cadr cand))))))) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in ;; minibuffer-hide-completions will know whether to @@ -2630,7 +2654,7 @@ The candidate will still be chosen by `choose-completion' unless ,(when temp-buffer-resize-mode '(preserve-size . (nil . t))) (body-function - . ,#'(lambda (_window) + . ,#'(lambda (window) (with-current-buffer mainbuf (when completion-auto-deselect (add-hook 'after-change-functions #'completions--after-change nil t)) @@ -2720,7 +2744,16 @@ The candidate will still be chosen by `choose-completion' unless (if (eq (car bounds) (length result)) 'exact 'finished)))))) - (display-completion-list completions nil group-fun))))) + (display-completion-list completions nil group-fun) + (when current-candidate-and-offset + (with-current-buffer standard-output + (when-let* ((match (text-property-search-forward + 'completion--string (car current-candidate-and-offset) t))) + (goto-char (prop-match-beginning match)) + ;; Preserve the exact offset for the sake of + ;; `choose-completion-deselect-if-after'. + (forward-char (cdr current-candidate-and-offset)) + (set-window-point window (point))))))))) nil))) nil)) @@ -2729,8 +2762,12 @@ The candidate will still be chosen by `choose-completion' unless ;; FIXME: We could/should use minibuffer-scroll-window here, but it ;; can also point to the minibuffer-parent-window, so it's a bit tricky. (interactive) - (let ((win (get-buffer-window "*Completions*" 0))) - (if win (with-selected-window win (bury-buffer))))) + (when-let* ((win (get-buffer-window "*Completions*" 0))) + (with-selected-window win + ;; Move point off any completions, so we don't move point there + ;; again the next time `minibuffer-completion-help' is called. + (goto-char (point-min)) + (bury-buffer)))) (defun exit-minibuffer () "Terminate this minibuffer argument." @@ -3175,7 +3212,7 @@ and `RET' accepts the input typed into the minibuffer." "Return CMD if `minibuffer-visible-completions' bindings should be active." (if minibuffer-visible-completions--always-bind cmd - (when-let ((window (get-buffer-window "*Completions*" 0))) + (when-let* ((window (get-buffer-window "*Completions*" 0))) (when (and (eq (buffer-local-value 'completion-reference-buffer (window-buffer window)) (window-buffer (active-minibuffer-window))) @@ -3868,6 +3905,21 @@ the commands start with a \"-\" or a SPC." (setq trivial nil))) trivial))) +(defcustom completion-pcm-leading-wildcard nil + "If non-nil, partial-completion completes as if there's a leading wildcard. + +If nil (the default), partial-completion requires a matching completion +alternative to have the same beginning as the first \"word\" in the +minibuffer text, where \"word\" is determined by +`completion-pcm-word-delimiters'. + +If non-nil, partial-completion allows any string of characters to occur +at the beginning of a completion alternative, as if a wildcard such as +\"*\" was present at the beginning of the minibuffer text. This makes +partial-completion behave more like the substring completion style." + :version "31.1" + :type 'boolean) + (defun completion-pcm--string->pattern (string &optional point) "Split STRING into a pattern. A pattern is a list where each element is either a string @@ -3918,7 +3970,11 @@ or a symbol, see `completion-pcm--merge-completions'." (when (> (length string) p0) (if pending (push pending pattern)) (push (substring string p0) pattern)) - (nreverse pattern)))) + (setq pattern (nreverse pattern)) + (when completion-pcm-leading-wildcard + (when (stringp (car pattern)) + (push 'prefix pattern))) + pattern))) (defun completion-pcm--optimize-pattern (p) ;; Remove empty strings in a separate phase since otherwise a "" @@ -3948,7 +4004,7 @@ or a symbol, see `completion-pcm--merge-completions'." (t (let ((re (if (eq x 'any-delim) (concat completion-pcm--delim-wild-regex "*?") - ".*?"))) + "[^z-a]*?"))) (if (if (consp group) (memq x group) group) (concat "\\(" re "\\)") re))))) @@ -4869,8 +4925,6 @@ insert the selected completion candidate to the minibuffer." (interactive "p") (let ((auto-choose minibuffer-completion-auto-choose)) (with-minibuffer-completions-window - (when completions-highlight-face - (setq-local cursor-face-highlight-nonselected-window t)) (if vertical (next-line-completion (or n 1)) (next-completion (or n 1))) diff --git a/lisp/mpc.el b/lisp/mpc.el index 768c70c2e3a..a0ecb21e454 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -63,7 +63,7 @@ ;; e.g. filename regexp -> compilation flag ;; - window/buffer management. ;; - menubar, tooltips, ... -;; - add mpc-describe-song, mpc-describe-album, ... +;; - add mpc-describe-album, ... ;; - add import/export commands (especially export to an MP3 player). ;; - add a real notion of album (as opposed to just album-name): ;; if all songs with same album-name have same artist -> it's an album @@ -91,9 +91,11 @@ ;; UI-commands : mpc- ;; internal : mpc-- -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) +(require 'cl-lib) + +(require 'notifications) + +(require 'vtable) (defgroup mpc () "Client for the Music Player Daemon (mpd)." @@ -460,6 +462,7 @@ which will be concatenated with proper quoting before passing them to MPD." (state . mpc--faster-toggle-refresh) ;Only ffwd/rewind while play/pause. (volume . mpc-volume-refresh) (file . mpc-songpointer-refresh) + (file . mpc-notifications-notify) ;; The song pointer may need updating even if the file doesn't change, ;; if the same song appears multiple times in a row. (song . mpc-songpointer-refresh) @@ -467,8 +470,9 @@ which will be concatenated with proper quoting before passing them to MPD." (updating_db . mpc--status-timers-refresh) (t . mpc-current-refresh)) "Alist associating properties to the functions that care about them. -Each entry has the form (PROP . FUN) where PROP can be t to mean -to call FUN for any change whatsoever.") +Each entry has the form (PROP . FUN) to call FUN (without arguments) +whenever property PROP changes. PROP can be t, which means to call +FUN for any change whatsoever.") (defun mpc--status-callback () (let ((old-status mpc-status)) @@ -916,6 +920,16 @@ If PLAYLIST is t or nil or missing, use the main playlist." "Directory where MPC.el stores auxiliary data." :type 'directory) +(defcustom mpc-crossfade-time 3 + "Number of seconds to crossfade between songs." + :version "31.1" + :type 'natnum) + +(defun mpc-cmd-crossfade (&optional arg) + "Set duration of crossfade to `mpc-crossfade-time' or ARG seconds." + (mpc-proc-cmd (list "crossfade" (or arg mpc-crossfade-time)) + #'mpc-status-refresh)) + (defun mpc-data-directory () (unless (file-directory-p mpc-data-directory) (make-directory mpc-data-directory)) @@ -966,11 +980,15 @@ If PLAYLIST is t or nil or missing, use the main playlist." :version "28.1") (defun mpc-secs-to-time (secs) + "Convert SECS from a string, integer or float value to a time string." ;; We could use `format-seconds', but it doesn't seem worth the trouble ;; because we'd still need to check (>= secs (* 60 100)) since the special ;; %z only allows us to drop the large units for small values but ;; not to drop the small units for large values. (if (stringp secs) (setq secs (string-to-number secs))) + ;; Ensure secs is an integer. The Time tag has been deprecated by MPD + ;; and its replacement (the duration tag) includes fractional seconds. + (if (floatp secs) (setq secs (round secs))) (if (>= secs (* 60 100)) ;More than 100 minutes. (format "%dh%02d" ;"%d:%02d:%02d" (/ secs 3600) (% (/ secs 60) 60)) ;; (% secs 60) @@ -992,7 +1010,18 @@ If PLAYLIST is t or nil or missing, use the main playlist." (push file mpc-tempfiles)) (defun mpc-format (format-spec info &optional hscroll) - "Format the INFO according to FORMAT-SPEC, inserting the result at point." + "Format the INFO according to FORMAT-SPEC, inserting the result at point. + +FORMAT-SPEC is a string that includes elements of the form +'%-WIDTH{NAME-POST}' that get expanded to the value of +property NAME. +The first '-', WIDTH, and -POST are optional. +% followed by the optional '-' means to right align the output. +WIDTH limits the output to the specified number of characters by +replacing any further output with a horizontal ellipsis. +The optional -POST means to use the empty string if NAME is +absent or else use the concatenation of the content of NAME with the +string POST." (let* ((pos 0) (start (point)) (col (if hscroll (- hscroll) 0)) @@ -1026,7 +1055,8 @@ If PLAYLIST is t or nil or missing, use the main playlist." (substring time (match-end 0)) time))))) ('Cover - (let ((dir (file-name-directory (cdr (assq 'file info))))) + (let* ((file (alist-get 'file info)) + (dir (file-name-directory file))) ;; (debug) (setq pred ;; We want the closure to capture the current @@ -1037,12 +1067,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." (and (funcall oldpred info) (equal dir (file-name-directory (cdr (assq 'file info)))))))) - (if-let* ((covers '(".folder.png" "folder.png" "cover.jpg" "folder.jpg")) - (cover (cl-loop for file in (directory-files (mpc-file-local-copy dir)) - if (or (member (downcase file) covers) - (and mpc-cover-image-re - (string-match mpc-cover-image-re file))) - return (concat dir file))) + (if-let* ((cover (mpc-cover-image-find file)) (file (with-demoted-errors "MPC: %s" (mpc-file-local-copy cover)))) (let (image) @@ -1122,6 +1147,20 @@ If PLAYLIST is t or nil or missing, use the main playlist." (insert (substring format-spec pos)) (put-text-property start (point) 'mpc--uptodate-p pred))) +(defun mpc-cover-image-find (file) + "Find cover image for FILE in suitable MPC directory." + (when-let* ((default-directory mpc-mpd-music-directory) + (dir (mpc-file-local-copy (file-name-directory file))) + (files (directory-files dir)) + (cover (seq-find #'mpc-cover-image-p files))) + (expand-file-name cover dir))) + +(defun mpc-cover-image-p (file) + "Check if FILE is a cover image suitable for MPC." + (let ((covers '(".folder.png" "folder.png" "cover.jpg" "folder.jpg"))) + (or (member-ignore-case file covers) + (and mpc-cover-image-re (string-match-p mpc-cover-image-re file))))) + ;;; The actual UI code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar-keymap mpc-mode-map @@ -1147,7 +1186,8 @@ If PLAYLIST is t or nil or missing, use the main playlist." ">" #'mpc-next "<" #'mpc-prev "g" #'mpc-seek-current - "o" #'mpc-goto-playing-song) + "o" #'mpc-goto-playing-song + "d" #'mpc-describe-song) (easy-menu-define mpc-mode-menu mpc-mode-map "Menu for MPC mode." @@ -1156,6 +1196,7 @@ If PLAYLIST is t or nil or missing, use the main playlist." ["Next Track" mpc-next] ;FIXME: Add ⇥ there? ["Previous Track" mpc-prev] ;FIXME: Add ⇤ there? ["Seek Within Track" mpc-seek-current] + ["Song Details" mpc-describe-song] "--" ["Repeat Playlist" mpc-toggle-repeat :style toggle :selected (member '(repeat . "1") mpc-status)] @@ -1165,6 +1206,8 @@ If PLAYLIST is t or nil or missing, use the main playlist." :selected (member '(single . "1") mpc-status)] ["Consume Mode" mpc-toggle-consume :style toggle :selected (member '(consume . "1") mpc-status)] + ["Crossfade Songs" mpc-toggle-crossfade :style toggle + :selected (alist-get 'xfade mpc-status)] "--" ["Add new browser" mpc-tagbrowser] ["Update DB" mpc-update] @@ -1549,9 +1592,10 @@ when constructing the set of constraints." (t (concat (symbol-name tag) "s")))) (defun mpc-tagbrowser-buf (tag) - (let ((buf (mpc-proc-buffer (mpc-proc) tag))) + (let ((buf (mpc-proc-buffer (mpc-proc) tag)) + (tag-name (mpc-tagbrowser-tag-name tag))) (if (buffer-live-p buf) buf - (setq buf (get-buffer-create (format "*MPC %ss*" tag))) + (setq buf (get-buffer-create (format "*MPC %s*" tag-name))) (mpc-proc-buffer (mpc-proc) tag buf) (with-current-buffer buf (let ((inhibit-read-only t)) @@ -1562,7 +1606,7 @@ when constructing the set of constraints." (insert mpc-tagbrowser-all-name "\n")) (forward-line -1) (setq mpc-tag tag) - (setq mpc-tag-name (mpc-tagbrowser-tag-name tag)) + (setq mpc-tag-name tag-name) (mpc-tagbrowser-all-select) (mpc-tagbrowser-refresh) buf)))) @@ -2404,6 +2448,12 @@ This is used so that they can be compared with `eq', which is needed for (mpc-cmd-random (if (string= "0" (cdr (assq 'random (mpc-cmd-status)))) "1" "0"))) +(defun mpc-toggle-crossfade () + "Toggle crossfading between songs." + (interactive) + (mpc-cmd-crossfade + (if (alist-get 'xfade mpc-status) "0" mpc-crossfade-time))) + (defun mpc-stop () "Stop playing the current queue of songs." (interactive) @@ -2766,6 +2816,152 @@ If stopped, start playback." (t (error "Unsupported drag'n'drop gesture")))))) +;;; Notifications ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare-function notifications-notify "notifications") + +(defcustom mpc-notifications nil + "Non-nil means MPC should display notifications when the song changes." + :version "31.1" + :type 'boolean) + +(defcustom mpc-notifications-title + '("%{Title}" "Unknown Title") + "List of FORMAT-SPECs used in the notification title. + +The first element in the list that expands to a non-empty string +will be used. See `mpc-format' for the definition of FORMAT-SPEC." + :version "31.1" + :type '(repeat string)) + +(defcustom mpc-notifications-body + '("%{Artist}" "%{AlbumArtist}" "Unknown Artist") + "List of FORMAT-SPEC used in the notification body. + +The first element in the list that expands to a non-empty string +will be used. See `mpc-format' for the definition of FORMAT-SPEC." + :version "31.1" + :type '(repeat string)) + +(defvar mpc--notifications-id nil) + +(defun mpc--notifications-format (format-specs) + "Use FORMAT-SPECS to get string for use in notification." + (with-temp-buffer + (cl-some + (lambda (spec) + (mpc-format spec mpc-status) + (if (< (point-min) (point-max)) + (buffer-string))) + format-specs))) + +(defun mpc-notifications-notify () + "Display a notification with information about the current song." + (when-let* ((mpc-notifications) + ((notifications-get-server-information)) + ((string= "play" (alist-get 'state mpc-status))) + (title (mpc--notifications-format mpc-notifications-title)) + (body (mpc--notifications-format mpc-notifications-body)) + (icon (or (mpc-cover-image-find (alist-get 'file mpc-status)) + notifications-application-icon))) + (setq mpc--notifications-id + (notifications-notify :title title + :body body + :app-icon icon + :replaces-id mpc--notifications-id)))) + +;;; Song Viewer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defface mpc-song-viewer-value + '((t (:inherit vtable))) + "Face for tag values in the MPC song viewer.") + +(defface mpc-song-viewer-tag + '((t (:inherit (mpc-song-viewer-value bold)))) + "Face for tag types in the MPC song viewer.") + +(defface mpc-song-viewer-empty + '((t (:inherit (mpc-song-viewer-value italic shadow)))) + "Face for empty tag values in the MPC song viewer.") + +(defcustom mpc-song-viewer-tags + '("Title" "Artist" "Album" "Performer" "Composer" + "Date" "Duration" "Disc" "Track" "Genre" "File") + "The list of tags to display with `mpc-describe-song'. + +The list of supported tags are available by evaluating +`mpc-cmd-tagtypes'. In addition to the standard MPD tags: Bitrate, +Duration, File, and Format are also supported." + :version "31.1" + :type '(repeat string)) + +(defun mpc-describe-song (file) + "Show details of the selected song or FILE in the MPC song viewer. + +If there is no song at point then information about the currently +playing song is displayed." + (interactive + ;; Handle being called from the context menu. In that case you want + ;; to see details for the song you clicked on to invoke the menu not + ;; whatever `point' happens to be on at that time. + (list (when-let* ((event last-nonmenu-event) + ((listp event)) + (position (nth 1 (event-start event)))) + (get-text-property position 'mpc-file)))) + (let ((tags (or (when (and file (stringp file)) + (mpc-proc-cmd-to-alist (list "search" "file" file))) + (when-let* (((string= (buffer-name) "*MPC-Songs*")) + (file (get-text-property (point) 'mpc-file))) + (mpc-proc-cmd-to-alist (list "search" "file" file))) + (when (assoc 'file mpc-status) mpc-status))) + (buffer "*MPC Song Viewer*")) + (when tags + (with-current-buffer (get-buffer-create buffer) + (special-mode) + (visual-line-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (make-vtable + :columns '(( :name "Tag" + :align right + :min-width 3 + :displayer + (lambda (tag &rest _) + (propertize tag 'face 'mpc-song-viewer-tag))) + ( :name "Value" + :align left + :min-width 5 + :displayer + (lambda (value &rest _) + (if (and value (not (string-blank-p value))) + (propertize value 'face 'mpc-song-viewer-value) + (propertize "empty" 'face 'mpc-song-viewer-empty))))) + :objects (mapcar + (lambda (tag) + (pcase tag + ("Bitrate" + (list tag (let ((bitrate (alist-get 'bitrate tags))) + (when bitrate + (format "%s kpbs" bitrate))))) + ("Duration" (list tag (mpc-secs-to-time + (alist-get 'duration tags)))) + ("File" (list tag (alist-get 'file tags))) + ;; Concatenate all the values of tags which may + ;; occur multiple times. + ((or "Composer" "Genre" "Performer") + (list tag (mapconcat + (lambda (val) (cdr val)) + (seq-filter + (lambda (val) (eq (car val) (intern tag))) + tags) + "; "))) + (_ (list tag (alist-get (intern tag) tags))))) + mpc-song-viewer-tags)) + (goto-char (point-min)))) + (pop-to-buffer buffer '((display-buffer-reuse-window + display-buffer-same-window) + (reusable-frames . t)))))) + ;;; Toplevel ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom mpc-frame-alist '((name . "MPC") (tool-bar-lines . 1) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 3048b8f6c22..c10bc671a88 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -683,12 +683,13 @@ websites are increasingly rare, but they do still exist." :type '(choice (const :tag "HTTP" "http") (const :tag "HTTPS" "https") (string :tag "Something else" "https")) + :risky t :version "29.1") (defun browse-url-url-at-point () (or (thing-at-point 'url t) ;; assume that the user is pointing at something like gnu.org/gnu - (when-let ((f (thing-at-point 'filename t))) + (when-let* ((f (thing-at-point 'filename t))) (if (string-match-p browse-url-button-regexp f) f (concat browse-url-default-scheme "://" f))))) @@ -763,7 +764,7 @@ interactively. Turn the filename into a URL with function (defun browse-url-file-url (file) "Return the URL corresponding to FILE. Use variable `browse-url-filename-alist' to map filenames to URLs." - (when-let ((coding (browse-url--file-name-coding-system))) + (when-let* ((coding (browse-url--file-name-coding-system))) (setq file (encode-coding-string file coding))) (if (and (file-remote-p file) ;; We're applying special rules for FTP URLs for historical @@ -1360,7 +1361,7 @@ currently selected window instead." (if (equal (url-type parsed) "file") ;; It's a file; just open it. (let ((file (url-unhex-string (url-filename parsed)))) - (when-let ((coding (browse-url--file-name-coding-system))) + (when-let* ((coding (browse-url--file-name-coding-system))) (setq file (decode-coding-string file 'utf-8))) ;; The local-part of file: URLs on Windows is supposed to ;; start with an extra slash. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index dd5f0e88859..ed1fc00f541 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -192,6 +192,10 @@ See /usr/include/dbus-1.0/dbus/dbus-protocol.h.") (defconst dbus-error-failed (concat dbus-error-dbus ".Failed") "A generic error; \"something went wrong\" - see the error message for more.") +(defconst dbus-error-interactive-authorization-required + (concat dbus-error-dbus ".InteractiveAuthorizationRequired") + "Interactive authentication required.") + (defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs") "Invalid arguments passed to a method call.") @@ -243,7 +247,9 @@ Otherwise, return result of last form in BODY, or all other errors." (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) -(defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) +(defvar dbus-event-error-functions + '(dbus-notice-synchronous-call-errors + dbus-warn-interactive-authorization-required) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable caught in `condition-case' by `dbus-error'.") @@ -282,6 +288,18 @@ The result will be made available in `dbus-return-values-table'." (setcar result :error) (setcdr result er)))) +(defun dbus-warn-interactive-authorization-required (ev er) + "Detect `dbus-error-interactive-authorization-required'." + (when (string-equal (cadr er) dbus-error-interactive-authorization-required) + (lwarn 'dbus :warning "%S" (cdr er)) + (let* ((key (list :serial + (dbus-event-bus-name ev) + (dbus-event-serial-number ev))) + (result (gethash key dbus-return-values-table))) + (when (consp result) + (setcar result :complete) + (setcdr result nil))))) + (defun dbus-call-method (bus service path interface method &rest args) "Call METHOD on the D-Bus BUS. @@ -297,6 +315,10 @@ TIMEOUT specifies the maximum number of milliseconds before the method call must return. The default value is 25,000. If the method call doesn't return in time, a D-Bus error is raised. +If the parameter `:authorizable' is given and the following AUTH +is non-nil, the invoked method may interactively prompt the user +for authorization. The default is nil. + All other arguments ARGS are passed to METHOD as arguments. They are converted into D-Bus types via the following rules: @@ -427,6 +449,10 @@ TIMEOUT specifies the maximum number of milliseconds before the method call must return. The default value is 25,000. If the method call doesn't return in time, a D-Bus error is raised. +If the parameter `:authorizable' is given and the following AUTH +is non-nil, the invoked method may interactively prompt the user +for authorization. The default is nil. + All other arguments ARGS are passed to METHOD as arguments. They are converted into D-Bus types via the following rules: @@ -1009,8 +1035,8 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array', and the individual bytes must be a valid UTF-8 byte sequence." (declare (advertised-calling-convention (byte-array) "30.1")) - (if-let ((bytes (seq-filter #'characterp byte-array)) - (string (apply #'unibyte-string bytes))) + (if-let* ((bytes (seq-filter #'characterp byte-array)) + (string (apply #'unibyte-string bytes))) (let (last-coding-system-used) (decode-coding-string string 'utf-8 'nocopy)) "")) @@ -2074,7 +2100,7 @@ either a method name, a signal name, or an error name." "Goto D-Bus message with the same serial number." (interactive) (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) - (when-let ((point (get-text-property (point) 'dbus-serial))) + (when-let* ((point (get-text-property (point) 'dbus-serial))) (goto-char point))) (defun dbus-monitor-handler (&rest _args) diff --git a/lisp/net/dictionary.el b/lisp/net/dictionary.el index 9c932c0c6d5..42fb8c57b40 100644 --- a/lisp/net/dictionary.el +++ b/lisp/net/dictionary.el @@ -321,7 +321,11 @@ Otherwise, `dictionary-search' displays definitions in a *Dictionary* buffer." :version "30.1") (defface dictionary-word-definition-face - '((((supports (:family "DejaVu Serif"))) + ;; w32 first, because 'supports' doesn't really tell whether the font + ;; family exists, and MS-Windows selects an ugly font as result. + '((((type w32)) + (:font "Sans Serif")) + (((supports (:family "DejaVu Serif"))) (:family "DejaVu Serif")) (((type x)) (:font "Sans Serif")) @@ -329,7 +333,7 @@ Otherwise, `dictionary-search' displays definitions in a *Dictionary* buffer." (:font "default"))) "The face that is used for displaying the definition of the word." :group 'dictionary -:version "28.1") +:version "31.1") (defface dictionary-word-entry-face '((((type x)) @@ -337,7 +341,7 @@ Otherwise, `dictionary-search' displays definitions in a *Dictionary* buffer." (((type tty) (class color)) (:foreground "green")) (t - (:inverse t))) + (:inverse-video t))) "The face that is used for displaying the initial word entry line." :group 'dictionary :version "28.1") @@ -1275,7 +1279,7 @@ prompt for DICTIONARY." (unless dictionary (setq dictionary dictionary-default-dictionary)) (if dictionary-display-definition-function - (if-let ((definition (dictionary-define-word word dictionary))) + (if-let* ((definition (dictionary-define-word word dictionary))) (funcall dictionary-display-definition-function word dictionary definition) (user-error "No definition found for \"%s\"" word)) ;; if called by pressing the button diff --git a/lisp/net/eww.el b/lisp/net/eww.el index f9db0559853..4d4d4d6beac 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -33,6 +33,7 @@ (require 'url) (require 'url-queue) (require 'url-file) +(require 'vtable) (require 'xdg) (eval-when-compile (require 'subr-x)) @@ -78,7 +79,7 @@ if that directory doesn't exist and the DOWNLOAD XDG user directory is defined, use the latter instead." (or (and (file-exists-p eww-default-download-directory) eww-default-download-directory) - (when-let ((dir (xdg-user-dir "DOWNLOAD"))) + (when-let* ((dir (xdg-user-dir "DOWNLOAD"))) (file-name-as-directory dir)) eww-default-download-directory)) @@ -108,6 +109,20 @@ duplicate entries (if any) removed." eww-current-url eww-bookmark-urls)) +(defcustom eww-guess-content-type-functions + '(eww--html-if-doctype) + "List of functions used by EWW to guess the content-type of Web pages. +These are only used when the page does not have a valid Content-Type +header. Functions are called in order, until one of them returns a +non-nil value to be used as Content-Type. The functions receive two +arguments: an alist of page's headers, and the buffer that holds the +complete response of the server from which the page was requested. +If the list of the functions is exhausted without any non-nil value, +EWW assumes content-type is \"application/octet-stream\", per RFC-9110." + :version "31.1" + :group 'eww + :type '(repeat function)) + (defcustom eww-bookmarks-directory user-emacs-directory "Directory where bookmark files will be stored." :version "25.1" @@ -229,8 +244,8 @@ determine the renaming scheme, as follows: (defun my-eww-rename-buffer () (when (eq major-mode \\='eww-mode) - (when-let ((string (or (plist-get eww-data :title) - (plist-get eww-data :url)))) + (when-let* ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) (format \"*%s*\" string)))) The string of `title' and `url' is always truncated to the value @@ -610,7 +625,7 @@ for the search engine used." NO-SELECT non-nil means do not make the new buffer the current buffer." (interactive "P") - (if-let ((url (or url (eww-suggested-uris)))) + (if-let* ((url (or url (eww-suggested-uris)))) (if (or (eq eww-browse-url-new-window-is-tab t) (and (eq eww-browse-url-new-window-is-tab 'tab-bar) tab-bar-mode)) @@ -630,6 +645,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--guess-content-type (headers response-buffer) + "Use HEADERS and RESPONSE-BUFFER to guess the Content-Type. +Will call each function in `eww-guess-content-type-functions', until one +of them returns a value. This mechanism is used only if there isn't a +valid Content-Type header. If none of the functions can guess, return +\"application/octet-stream\"." + (save-excursion + (or (run-hook-with-args-until-success + 'eww-guess-content-type-functions headers response-buffer) + "application/octet-stream"))) + +(defun eww--html-if-doctype (_headers response-buffer) + "Return \"text/html\" if RESPONSE-BUFFER has an HTML doctype declaration. +HEADERS is unused." + ;; https://html.spec.whatwg.org/multipage/syntax.html#the-doctype + (with-current-buffer response-buffer + (let ((case-fold-search t)) + (save-excursion + (goto-char (point-min)) + ;; Match basic "<!doctype html>" and also legacy variants as + ;; specified in link above -- being purposely lax about it. + (when (search-forward "<!doctype html" nil t) + "text/html"))))) + (defun eww--rename-buffer () "Rename the current EWW buffer. The renaming scheme is performed in accordance with @@ -659,7 +698,7 @@ The renaming scheme is performed in accordance with (content-type (mail-header-parse-content-type (if (zerop (length (cdr (assoc "content-type" headers)))) - "text/plain" + (eww--guess-content-type headers (current-buffer)) (cdr (assoc "content-type" headers))))) (charset (intern (downcase @@ -709,7 +748,8 @@ The renaming scheme is performed in accordance with (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) (unless shr-fill-text - (visual-line-mode)) + (visual-line-mode) + (visual-wrap-prefix-mode)) (run-hooks 'eww-after-render-hook) ;; Enable undo again so that undo works in text input ;; boxes. @@ -1336,6 +1376,8 @@ within text input fields." ;; desktop support (setq-local desktop-save-buffer #'eww-desktop-misc-data) (setq truncate-lines t) + ;; visual-wrap-prefix-mode support + (setq-local adaptive-fill-function #'shr-adaptive-fill-function) ;; thingatpt support (setq-local thing-at-point-provider-alist (cons '(url . eww--url-at-point) @@ -1370,8 +1412,13 @@ within text input fields." (save-excursion (goto-char (point-min)) (while-let ((match (text-property-search-forward - 'display nil (lambda (_ value) (imagep value))))) - (let* ((image (prop-match-value match)) + 'display nil + (lambda (_ value) + (and value (get-display-property + nil 'image nil value)))))) + (let* ((image (cons 'image + (get-display-property nil 'image nil + (prop-match-value match)))) (original-scale (or (image-property image :original-scale) (setf (image-property image :original-scale) (or (image-property image :scale) @@ -2022,14 +2069,19 @@ Interactively, EVENT is the value of `last-nonmenu-event'." (push (cons name (or (plist-get input :value) "on")) values))) ((equal (plist-get input :type) "file") - (when-let ((file (plist-get input :filename))) + (when-let* ((file (plist-get input :filename))) (push (list "file" (cons "filedata" (with-temp-buffer (insert-file-contents file) (buffer-string))) (cons "name" name) - (cons "filename" file)) + ;; RFC 2183 declares that recipients should + ;; only respect the basename of the filename + ;; parameter, and the leading directories + ;; might divulge private information, so we + ;; only send the basename in our request. + (cons "filename" (file-name-nondirectory file))) values))) ((equal (plist-get input :type) "submit") ;; We want the values from buttons if we hit a button if @@ -2138,7 +2190,7 @@ If EXTERNAL is double prefix, browse in new buffer." (eww--before-browse) (plist-put eww-data :url url) (goto-char (point-min)) - (if-let ((match (text-property-search-forward 'shr-target-id target #'member))) + (if-let* ((match (text-property-search-forward 'shr-target-id target #'member))) (goto-char (prop-match-beginning match)) (goto-char (if (equal target "top") (point-min) @@ -2596,58 +2648,47 @@ see)." ;;; eww buffers list +(defun eww-buffer-list () + "Return a list of all live eww buffers." + (match-buffers '(derived-mode . eww-mode))) + (defun eww-list-buffers () - "Enlist eww buffers." + "Pop a buffer with a list of eww buffers." (interactive) - (let (buffers-info - (current (current-buffer))) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (derived-mode-p 'eww-mode) - (push (vector buffer (plist-get eww-data :title) - (plist-get eww-data :url)) - buffers-info)))) - (unless buffers-info - (error "No eww buffers")) - (setq buffers-info (nreverse buffers-info)) ;more recent on top - (set-buffer (get-buffer-create "*eww buffers*")) + (with-current-buffer (get-buffer-create "*eww buffers*") (eww-buffers-mode) - (let ((inhibit-read-only t) - (domain-length 0) - (title-length 0) - url title format start) - (erase-buffer) - (dolist (buffer-info buffers-info) - (setq title-length (max title-length - (length (elt buffer-info 1))) - domain-length (max domain-length - (length (elt buffer-info 2))))) - (setq format (format "%%-%ds %%-%ds" title-length domain-length) - header-line-format - (concat " " (format format "Title" "URL"))) - (let ((line 0) - (current-buffer-line 1)) - (dolist (buffer-info buffers-info) - (setq start (point) - title (elt buffer-info 1) - url (elt buffer-info 2) - line (1+ line)) - (insert (format format title url)) - (insert "\n") - (let ((buffer (elt buffer-info 0))) - (put-text-property start (1+ start) 'eww-buffer - buffer) - (when (eq current buffer) - (setq current-buffer-line line)))) - (goto-char (point-min)) - (forward-line (1- current-buffer-line))))) + (eww--list-buffers-display-table)) (pop-to-buffer "*eww buffers*")) +(defun eww--list-buffers-display-table (&optional _ignore-auto _noconfirm) + "Display a table with the list of eww buffers. +Will remove all buffer contents first. The parameters IGNORE-AUTO and +NOCONFIRM are ignored, they are for compatibility with +`revert-buffer-function'." + (let ((inhibit-read-only t)) + (erase-buffer) + (make-vtable + :columns '((:name "Title" :min-width "25%" :max-width "50%") + (:name "URL")) + :objects-function #'eww--list-buffers-get-data + ;; use fixed-font face + :face 'default))) + +(defun eww--list-buffers-get-data () + "Return the eww-data of BUF, assumed to be a eww buffer. +The format of the data is (title url buffer), for use in of +`eww-buffers-mode'." + (mapcar (lambda (buf) + (let ((buf-eww-data (buffer-local-value 'eww-data buf))) + (list (plist-get buf-eww-data :title) + (plist-get buf-eww-data :url) + buf))) + (eww-buffer-list))) + (defun eww-buffer-select () "Switch to eww buffer." (interactive nil eww-buffers-mode) - (let ((buffer (get-text-property (line-beginning-position) - 'eww-buffer))) + (let ((buffer (nth 2 (vtable-current-object)))) (unless buffer (error "No buffer on current line")) (quit-window) @@ -2655,8 +2696,7 @@ see)." (defun eww-buffer-show () "Display buffer under point in eww buffer list." - (let ((buffer (get-text-property (line-beginning-position) - 'eww-buffer))) + (let ((buffer (nth 2 (vtable-current-object)))) (unless buffer (error "No buffer on current line")) (other-window -1) @@ -2684,7 +2724,7 @@ see)." "Kill buffer from eww list." (interactive nil eww-buffers-mode) (let* ((start (line-beginning-position)) - (buffer (get-text-property start 'eww-buffer)) + (buffer (nth 2 (vtable-current-object))) (inhibit-read-only t)) (unless buffer (user-error "No buffer on the current line")) @@ -2703,10 +2743,9 @@ see)." :menu '("Eww Buffers" ["Exit" quit-window t] ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] + :active (nth 2 (vtable-current-object))] ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) - 'eww-buffer)])) + :active (nth 2 (vtable-current-object))])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. @@ -2714,7 +2753,10 @@ see)." \\{eww-buffers-mode-map}" :interactive nil (buffer-disable-undo) - (setq truncate-lines t)) + (setq truncate-lines t + ;; This is set so that pressing "g" with point just below the + ;; table will still update the listing. + revert-buffer-function #'eww--list-buffers-display-table)) ;;; Desktop support @@ -2868,9 +2910,9 @@ these attributes is absent, the corresponding element is nil." If there is just one alternate link, return its URL. If there are multiple alternate links, prompt for one in the minibuffer with completion. If there are none, return nil." - (when-let ((alternates (eww--alternate-urls - (plist-get eww-data :dom) - (plist-get eww-data :url)))) + (when-let* ((alternates (eww--alternate-urls + (plist-get eww-data :dom) + (plist-get eww-data :url)))) (let ((url-max-width (seq-max (mapcar #'string-pixel-width (mapcar #'car alternates)))) @@ -2914,7 +2956,7 @@ Alternate links are references that an HTML page may include to point to its alternative representations, such as a translated version or an RSS feed." (interactive nil eww-mode) - (if-let ((url (eww-read-alternate-url))) + (if-let* ((url (eww-read-alternate-url))) (progn (kill-new url) (message "Copied %s to kill ring" url)) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 7c72c67f187..ac36bfe05ce 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -241,7 +241,7 @@ using `browse-url-secondary-browser-function' instead." (line-beginning-position))) (not (looking-at goto-address-url-regexp)))) (compose-mail address) - (if-let ((url (browse-url-url-at-point))) + (if-let* ((url (browse-url-url-at-point))) (browse-url-button-open-url url) (error "No e-mail address or URL found")))))) diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el index 1c4ac24a9c4..af323b0d2b0 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -29,7 +29,6 @@ (eval-when-compile (require 'hmac-def)) (require 'hex-util) ; (decode-hex-string STRING) -(require 'md5) ; expects (md5 STRING) (defun md5-binary (string) "Return the MD5 of STRING in binary form." diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 5ff75deb4e6..d3ca899216a 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -856,10 +856,10 @@ If NO-DECODE is non-nil, don't decode STRING." ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. (when mailcap-prefer-mailcap-viewers - (when-let ((user-entries - (seq-filter (lambda (elem) - (eq (cdr (assq 'source elem)) 'user)) - passed))) + (when-let* ((user-entries + (seq-filter (lambda (elem) + (eq (cdr (assq 'source elem)) 'user)) + passed))) (setq passed user-entries))) (setq viewer (car passed)))) (when (and (stringp (cdr (assq 'viewer viewer))) @@ -1084,10 +1084,17 @@ For instance, \"foo.png\" will result in \"image/png\"." (defun mailcap-mime-type-to-extension (mime-type) "Return a file name extension based on a MIME-TYPE. For instance, `image/png' will result in `png'." - (intern (cadr (split-string (if (symbolp mime-type) - (symbol-name mime-type) - mime-type) - "/")))) + (intern + (let ((e (cadr (split-string (if (symbolp mime-type) + (symbol-name mime-type) + mime-type) + "/")))) + ;; Usually, the normal extension is the same as the MIME subtype. + ;; But for SVG files, the extension is "svg" and the MIME type is + ;; "svg+xml". + (if (string= e "svg+xml") + "svg" + e)))) (defun mailcap-mime-types () "Return a list of MIME media types." diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 0ff7985f0dc..4122777ac8c 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -805,6 +805,7 @@ not get changed." (widen) (put-text-property (point) pos 'nt-age 'old) (newsticker--buffer-set-faces (point) pos))) + (newsticker--cache-save-feed (newsticker--cache-get-feed feed)) (set-buffer-modified-p nil))))))) (defun newsticker-mark-item-at-point-as-immortal () @@ -1279,7 +1280,7 @@ FEED-NAME-SYMBOL tells to which feed this item belongs." (let ((img (newsticker--image-read feed-name-symbol disabled))) (when img - (newsticker--insert-image img (car item))))) + (newsticker--insert-image img (format "[logo: %s]" (car item)))))) (setq format (substring format 2))) ((string= "%L" prefix) ;; logo or title @@ -1292,7 +1293,7 @@ FEED-NAME-SYMBOL tells to which feed this item belongs." (let ((img (newsticker--image-read feed-name-symbol disabled))) (if img - (newsticker--insert-image img (car item)) + (newsticker--insert-image img (format "[logo: %s]" (car item))) (when (car item) (setq pos-text-start (point-marker)) (if (eq (newsticker--age item) 'feed) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index ab655dbb13b..1ce2ff33ae6 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -100,21 +100,20 @@ This means that no queries should be performed.") (defun nsm-verify-connection (process host port &optional save-fingerprint warn-unencrypted) "Verify the security status of PROCESS that's connected to HOST:PORT. -If PROCESS is a gnutls connection, the certificate validity will -be examined. If it's a non-TLS connection, it may be compared -against previous connections. If the function determines that -there is something odd about the connection, the user will be -queried about what to do about it. +If PROCESS is a GnuTLS connection, the certificate validity will be +examined. If it's a non-TLS connection, it may be compared against +previous connections. If the function determines that there is +something odd about the connection, the user will be queried about what +to do about it. -The process is returned if everything is OK, and otherwise, the -process will be deleted and nil is returned. +Return the process if all the checks pass. Otherwise, delete the +process and return nil. -If SAVE-FINGERPRINT, always save the fingerprint of the -server (if the connection is a TLS connection). This is useful -to keep track of the TLS status of STARTTLS servers. +If SAVE-FINGERPRINT, always save the fingerprint of the server (if the +connection is a TLS connection). This is useful to keep track of the +TLS status of STARTTLS servers. -If WARN-UNENCRYPTED, query the user if the connection is -unencrypted." +If WARN-UNENCRYPTED, query the user if the connection is unencrypted." (let* ((status (gnutls-peer-status process)) (id (nsm-id host port)) (settings (nsm-host-settings id))) @@ -227,27 +226,18 @@ If `nsm-trust-local-network' is or returns non-nil, and if the host address is a localhost address, or in the same subnet as one of the local interfaces, this function returns nil. Non-nil otherwise." - (let ((addresses (network-lookup-address-info host)) - (network-interface-list (network-interface-list t)) - (off-net t)) - (when - (or (and (functionp nsm-trust-local-network) - (funcall nsm-trust-local-network)) - nsm-trust-local-network) - (mapc - (lambda (ip) - (mapc - (lambda (info) - (let ((local-ip (nth 1 info)) - (mask (nth 3 info))) - (when - (nsm-network-same-subnet (substring local-ip 0 -1) - (substring mask 0 -1) - (substring ip 0 -1)) - (setq off-net nil)))) - network-interface-list)) - addresses)) - off-net)) + (not (and-let* (((or (and (functionp nsm-trust-local-network) + (funcall nsm-trust-local-network)) + nsm-trust-local-network)) + (addresses (network-lookup-address-info host)) + (network-interface-list (network-interface-list t))) + (catch 'nsm-should-check + (dolist (ip addresses) + (dolist (info network-interface-list) + (when (nsm-network-same-subnet (substring (nth 1 info) 0 -1) + (substring (nth 3 info) 0 -1) + (substring ip 0 -1)) + (throw 'nsm-should-check t)))))))) (defun nsm-check-tls-connection (process host port status settings) "Check TLS connection against potential security problems. diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 2a713de83c2..c41e2ec153f 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -576,11 +576,11 @@ If ARG is non-nil, instead prompt for connection parameters." 'certfp) (rcirc-get-server-cert (car c)))) contact) - (when-let (((not password)) - (auth (auth-source-search :host server - :user user-name - :port port)) - (pwd (auth-info-password (car auth)))) + (when-let* (((not password)) + (auth (auth-source-search :host server + :user user-name + :port port)) + (pwd (auth-info-password (car auth)))) (setq password pwd)) (when server (let (connected) @@ -709,7 +709,7 @@ that are joined after authentication." process) ;; Ensure any previous process is killed - (when-let ((old-process (get-process (or server-alias server)))) + (when-let* ((old-process (get-process (or server-alias server)))) (set-process-sentinel old-process #'ignore) (delete-process process)) @@ -1158,7 +1158,7 @@ element in PARTS is a list, append it to PARTS." (let ((last (car (last parts)))) (when (listp last) (setf parts (append (butlast parts) last)))) - (when-let (message (memq : parts)) + (when-let* ((message (memq : parts))) (cl-check-type (cadr message) string) (setf (cadr message) (concat ":" (cadr message)) parts (remq : parts))) @@ -1630,7 +1630,7 @@ with it." rcirc-log-directory) (rcirc-log-write)) (rcirc-clean-up-buffer "Killed buffer") - (when-let ((process (get-buffer-process (current-buffer)))) + (when-let* ((process (get-buffer-process (current-buffer)))) (delete-process process)) (when (and rcirc-buffer-alist ;; it's a server buffer rcirc-kill-channel-buffers) @@ -2041,7 +2041,7 @@ connection." ;; do not ignore if we sent the message (not (string= sender (rcirc-nick process)))) (let* ((buffer (rcirc-target-buffer process sender response target text)) - (time (if-let ((time (rcirc-get-tag "time"))) + (time (if-let* ((time (rcirc-get-tag "time"))) (parse-iso8601-time-string time t) (current-time))) (inhibit-read-only t)) @@ -2178,7 +2178,7 @@ connection." (defun rcirc-when () "Show the time of reception of the message at point." (interactive) - (if-let (time (get-text-property (point) 'rcirc-time)) + (if-let* ((time (get-text-property (point) 'rcirc-time))) (message (format-time-string "%c" time)) (message "No time information at point."))) @@ -3133,13 +3133,13 @@ indicated by RESPONSE)." (or #x03 #x0f eol)) nil t) (let (foreground background) - (when-let ((fg-raw (match-string 1)) - (fg (string-to-number fg-raw)) - ((<= 0 fg (1- (length rcirc-color-codes))))) + (when-let* ((fg-raw (match-string 1)) + (fg (string-to-number fg-raw)) + ((<= 0 fg (1- (length rcirc-color-codes))))) (setq foreground (aref rcirc-color-codes fg))) - (when-let ((bg-raw (match-string 2)) - (bg (string-to-number bg-raw)) - ((<= 0 bg (1- (length rcirc-color-codes))))) + (when-let* ((bg-raw (match-string 2)) + (bg (string-to-number bg-raw)) + ((<= 0 bg (1- (length rcirc-color-codes))))) (setq background (aref rcirc-color-codes bg))) (rcirc-add-face (match-beginning 0) (match-end 0) `(face (,@(and foreground (list :foreground foreground)) @@ -3475,7 +3475,7 @@ PROCESS is the process object for the current connection." (dolist (target channels) (rcirc-print process sender "NICK" target new-nick)) ;; update chat buffer, if it exists - (when-let ((chat-buffer (rcirc-get-buffer process old-nick))) + (when-let* ((chat-buffer (rcirc-get-buffer process old-nick))) (with-current-buffer chat-buffer (rcirc-print process sender "NICK" old-nick new-nick) (setq rcirc-target new-nick) @@ -3799,8 +3799,8 @@ is the process object for the current connection." "Handle a empty tag message from SENDER. PROCESS is the process object for the current connection." (dolist (tag rcirc-message-tags) - (when-let ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag)))) - ((fboundp handler))) + (when-let* ((handler (intern-soft (concat "rcirc-tag-handler-" (car tag)))) + ((fboundp handler))) (funcall handler process sender (cdr tag))))) (defun rcirc-handler-BATCH (process _sender args _text) @@ -3837,7 +3837,7 @@ object for the current connection." (args (nth 3 message)) (text (nth 4 message)) (rcirc-message-tags (nth 5 message))) - (if-let (handler (intern-soft (concat "rcirc-handler-" cmd))) + (if-let* ((handler (intern-soft (concat "rcirc-handler-" cmd)))) (funcall handler process sender args text) (rcirc-handler-generic process cmd sender args text)))))))) (setq rcirc-batch-attributes diff --git a/lisp/net/shr.el b/lisp/net/shr.el index fb72ea6aa67..6d8b235a2b8 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -58,6 +58,20 @@ fit these criteria." :version "24.1" :type 'float) +(defcustom shr-sliced-image-height 0.9 + "How tall images can be before slicing in relation to the window they're in. +A value of 0.7 means that images are allowed to take up 70% of the +height of the window before being sliced by `insert-sliced-image'. If +nil, never slice images. + +Sliced images allow for more intuitive scrolling up/down by letting you +scroll past each slice, instead of jumping past the entire image. +Alternately, you can use `pixel-scroll-precision-mode' to scroll +pixel-wise past images, in which case you can set this option to nil." + :version "31.1" + :type '(choice (const :tag "Never slice images") + float)) + (defcustom shr-allowed-images nil "If non-nil, only images that match this regexp are displayed. If nil, all URLs are allowed. Also see `shr-blocked-images'." @@ -205,6 +219,25 @@ interpreted as a multiple of the height of default font." :version "30.1" :type '(choice (const nil) (cons number number))) +(defcustom shr-image-zoom-levels '(fit original fill-height) + "A list of image zoom levels to cycle through with `shr-zoom-image'. +The first element in the list is the initial zoom level. Each element +can be one of the following symbols: + +* `fit': Display the image at its original size as requested by the + page, shrinking it to fit in the current window if necessary. +* `original': Display the image at its original size as requested by the + page. +* `image': Display the image at its full size (ignoring the width/height + specified by the HTML). +* `fill-height': Display the image zoomed to fill the height of the +current window." + :version "31.1" + :type '(set (const :tag "Fit to window size" fit) + (const :tag "Original size" original) + (const :tag "Full image size" image) + (const :tag "Fill window height" fill-height))) + (defvar shr-content-function nil "If bound, this should be a function that will return the content. This is used for cid: URLs, and the function is called with the @@ -607,35 +640,60 @@ the URL of the image to the kill buffer instead." (list (current-buffer) (1- (point)) (point-marker)) t)))) -(defun shr-zoom-image () - "Cycle the image size. +(defvar shr-image-zoom-level-alist + `((fit "Zoom to fit" shr-rescale-image) + (original "Zoom to original size" shr--image-zoom-original-size) + (image "Zoom to full image size" shr--image-zoom-image-size) + (fill-height "Zoom to fill window height" shr--image-zoom-fill-height)) + "An alist of possible image zoom levels. +Each element is of the form (SYMBOL DESC FUNCTION). SYMBOL is the +symbol identifying this level, as used by `shr-image-zoom-levels' (which +see). DESC is a string describing the level. + +FUNCTION is a function that returns a properly-zoomed image; it takes +the following arguments: + +* DATA: The image data in string form. +* CONTENT-TYPE: The content-type of the image, if any. +* WIDTH: The width as specified by the HTML \"width\" attribute, if any. +* HEIGHT: The height as specified by the HTML \"height\" attribute, if + any.") + +(defun shr-zoom-image (&optional position zoom-level) + "Change the zoom level of the image at POSITION. + The size will cycle through the default size, the original size, and full-buffer size." - (interactive) - (let ((url (get-text-property (point) 'image-url))) + (interactive "d") + (unless position (setq position (point))) + (let ((url (get-text-property position 'image-url))) (if (not url) (message "No image under point") - (let* ((end (or (next-single-property-change (point) 'image-url) + (unless zoom-level + (let ((last-zoom (get-text-property position 'image-zoom))) + (setq zoom-level (or (cadr (memq last-zoom shr-image-zoom-levels)) + (car shr-image-zoom-levels))))) + (let* ((end (or (next-single-property-change position 'image-url) (point-max))) (start (or (previous-single-property-change end 'image-url) (point-min))) - (size (get-text-property (point) 'image-size)) - (next-size (cond ((or (eq size 'default) - (null size)) - 'original) - ((eq size 'original) - 'full) - ((eq size 'full) - 'default))) + (dom-size (get-text-property position 'image-dom-size)) + (flags `( :zoom ,zoom-level + :width ,(car dom-size) + :height ,(cdr dom-size))) (buffer-read-only nil)) ;; Delete the old picture. (put-text-property start end 'display nil) - (message "Inserting %s..." url) - (url-retrieve url #'shr-image-fetched - `(,(current-buffer) ,start - ,(set-marker (make-marker) end) - ((size . ,next-size))) - t))))) + (message "%s" (cadr (assq zoom-level shr-image-zoom-level-alist))) + (if (and (not shr-ignore-cache) + (url-is-cached url)) + (shr-replace-image (shr-get-image-data url) start + (set-marker (make-marker) end) flags) + (url-retrieve url #'shr-image-fetched + `(,(current-buffer) ,start + ,(set-marker (make-marker) end) + ,flags) + t)))))) ;;; Utility functions. @@ -693,7 +751,7 @@ full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when-let ((id (dom-attr dom 'id))) + (when-let* ((id (dom-attr dom 'id))) (push (cons id (set-marker (make-marker) start)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style @@ -880,6 +938,11 @@ When `shr-fill-text' is nil, only indent." (when (looking-at " $") (delete-region (point) (line-end-position))))))) +(defun shr-adaptive-fill-function () + "Return a fill prefix for the paragraph at point." + (when-let* ((prefix (get-text-property (point) 'shr-prefix-length))) + (buffer-substring (point) (+ (point) prefix)))) + (defun shr-parse-base (url) ;; Always chop off anchors. (when (string-match "#.*" url) @@ -887,7 +950,7 @@ When `shr-fill-text' is nil, only indent." ;; NB: <base href=""> URI may itself be relative to the document's URI. (setq url (shr-expand-url url)) (let* ((parsed (url-generic-parse-url url)) - (local (url-filename parsed))) + (local (or (url-filename parsed) ""))) (setf (url-filename parsed) "") ;; Chop off the bit after the last slash. (when (string-match "\\`\\(.*/\\)[^/]+\\'" local) @@ -983,11 +1046,24 @@ When `shr-fill-text' is nil, only indent." (defun shr-indent () (when (> shr-indentation 0) - (if (not shr-use-fonts) - (insert-char ?\s shr-indentation) - (insert ?\s) - (put-text-property (1- (point)) (point) - 'display `(space :width (,shr-indentation)))))) + (let ((start (point)) + (prefix (or (get-text-property (point) 'shr-prefix-length) 0))) + (if (not shr-use-fonts) + (insert-char ?\s shr-indentation) + (insert ?\s) + ;; Set the specified space width in units of the average-width + ;; of the current font, like (N . width). That way, the + ;; indentation is calculated correctly when using + ;; `text-scale-adjust'. + (let ((avg-space (propertize (buffer-substring (1- (point)) (point)) + 'display '(space :width 1)))) + (put-text-property + (1- (point)) (point) 'display + `(space :width (,(/ (float shr-indentation) + (string-pixel-width avg-space (current-buffer))) + . width))))) + (put-text-property start (+ (point) prefix) + 'shr-prefix-length (+ prefix (- (point) start)))))) (defun shr-fontize-dom (dom &rest types) (let ((start (point))) @@ -1056,6 +1132,25 @@ the mouse click event." (expand-file-name (file-name-nondirectory url) directory))))) +(defun shr-replace-image (data start end &optional flags) + (save-excursion + (save-restriction + (widen) + (let ((alt (buffer-substring start end)) + (properties (text-properties-at start)) + ;; We don't want to record these changes. + (buffer-undo-list t) + (inhibit-read-only t)) + (remove-overlays start end) + (delete-region start end) + (goto-char start) + (funcall shr-put-image-function data alt flags) + (while properties + (let ((type (pop properties)) + (value (pop properties))) + (unless (memq type '(display image-zoom)) + (put-text-property start (point) type value)))))))) + (defun shr-image-fetched (status buffer start end &optional flags) (let ((image-buffer (current-buffer))) (when (and (buffer-name buffer) @@ -1066,23 +1161,7 @@ the mouse click event." (search-forward "\r\n\r\n" nil t)) (let ((data (shr-parse-image-data))) (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (let ((alt (buffer-substring start end)) - (properties (text-properties-at start)) - ;; We don't want to record these changes. - (buffer-undo-list t) - (inhibit-read-only t)) - (remove-overlays start end) - (delete-region start end) - (goto-char start) - (funcall shr-put-image-function data alt flags) - (while properties - (let ((type (pop properties)) - (value (pop properties))) - (unless (memq type '(display image-size)) - (put-text-property start (point) type value))))))))))) + (shr-replace-image data start end flags))))) (kill-buffer image-buffer))) (defun shr-image-from-data (data) @@ -1118,32 +1197,32 @@ the mouse click event." (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. SPEC is either an image data blob, or a list where the first -element is the data blob and the second element is the content-type." +element is the data blob and the second element is the content-type. + +FLAGS is a property list specifying optional parameters for the image. +You can specify the following optional properties: + +* `:zoom': The zoom level for the image. One of `default', `original', + or `full'. +* `:width': The width of the image as specified by the HTML \"width\" + attribute. +* `:height': The height of the image as specified by the HTML + \"height\" attribute." (if (display-graphic-p) - (let* ((size (cdr (assq 'size flags))) + (let* ((zoom (or (plist-get flags :zoom) + (car shr-image-zoom-levels))) + (zoom-function (or (nth 2 (assq zoom shr-image-zoom-level-alist)) + (error "Unrecognized zoom level %s" zoom))) (data (if (consp spec) (car spec) spec)) (content-type (and (consp spec) (cadr spec))) (start (point)) - (image (cond - ((eq size 'original) - (create-image data nil t :ascent shr-image-ascent - :format content-type)) - ((eq content-type 'image/svg+xml) - (when (image-type-available-p 'svg) - (create-image data 'svg t :ascent shr-image-ascent))) - ((eq size 'full) - (ignore-errors - (shr-rescale-image data content-type - (plist-get flags :width) - (plist-get flags :height)))) - (t - (ignore-errors - (shr-rescale-image data content-type - (plist-get flags :width) - (plist-get flags :height))))))) + (image (ignore-errors + (funcall zoom-function data content-type + (plist-get flags :width) + (plist-get flags :height))))) (when image ;; The trailing space can confuse shr-insert into not ;; putting any space after inline images. @@ -1157,20 +1236,28 @@ element is the data blob and the second element is the content-type." (when (and (> (current-column) 0) (not inline)) (insert "\n")) - (let ((image-pos (point))) - (if (eq size 'original) + (let ((image-pos (point)) + image-height body-height) + (if (and shr-sliced-image-height + (setq image-height (cdr (image-size image t)) + body-height (window-body-height + (get-buffer-window (current-buffer)) + t)) + (> (/ image-height body-height 1.0) + shr-sliced-image-height)) ;; Normally, we try to keep the buffer text the same ;; by preserving ALT. With a sliced image, we have to ;; repeat the text for each line, so we can't do that. ;; Just use "*" for the string to insert instead. (progn - (insert-sliced-image image "*" nil 20 1) + (insert-sliced-image + image "*" nil (/ image-height (default-line-height)) 1) (let ((overlay (make-overlay start (point)))) ;; Avoid displaying unsightly decorations on the ;; image slices. (overlay-put overlay 'face 'shr-sliced-image))) (insert-image image alt)) - (put-text-property start (point) 'image-size size) + (put-text-property start (point) 'image-zoom zoom) (when (and (not inline) shr-max-inline-image-size) (insert "\n")) (when (and shr-image-animate @@ -1208,27 +1295,33 @@ width/height instead." (or max-height (- (nth 3 edges) (nth 1 edges)))))) (scaling (image-compute-scaling-factor image-scaling-factor))) - (when (or (and width - (> width max-width)) - (and height - (> height max-height))) - (setq width nil - height nil)) - (if (and width height - (< (* width scaling) max-width) - (< (* height scaling) max-height)) - (create-image - data (shr--image-type) t - :ascent shr-image-ascent - :width width - :height height - :format content-type) - (create-image - data (shr--image-type) t - :ascent shr-image-ascent - :max-width max-width - :max-height max-height - :format content-type))))) + (when (and width (> (* width scaling) max-width)) + (setq width nil)) + (when (and height (> (* height scaling) max-height)) + (setq height nil)) + (create-image + data (shr--image-type) t + :ascent shr-image-ascent + :width width + :height height + :max-width max-width + :max-height max-height + :format content-type)))) + +(defun shr--image-zoom-original-size (data content-type width height) + (create-image data (shr--image-type) t :ascent shr-image-ascent + :width width :height height :format content-type)) + +(defun shr--image-zoom-image-size (data content-type _width _height) + (create-image data nil t :ascent shr-image-ascent :format content-type)) + +(defun shr--image-zoom-fill-height (data content-type _width _height) + (let* ((edges (window-inside-pixel-edges + (get-buffer-window (current-buffer)))) + (height (truncate (* shr-max-image-proportion + (- (nth 3 edges) (nth 1 edges)))))) + (create-image data (shr--image-type) t :ascent shr-image-ascent + :height height :format content-type))) ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) @@ -1522,7 +1615,7 @@ Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-infore (defun shr-correct-dom-case (dom) "Correct the case for SVG segments." (dolist (attr (dom-attributes dom)) - (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case))) + (when-let* ((rep (assoc-default (car attr) shr-correct-attribute-case))) (setcar attr rep))) (dolist (child (dom-children dom)) (when (consp child) @@ -1663,13 +1756,13 @@ Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-infore (funcall shr-url-transformer (shr-expand-url url)) title) ;; Check whether the URL is suspicious. - (when-let ((warning (or (textsec-suspicious-p - (shr-expand-url url) 'url) - (textsec-suspicious-p - (cons (shr-expand-url url) - (buffer-substring (or shr-start start) - (point))) - 'link)))) + (when-let* ((warning (or (textsec-suspicious-p + (shr-expand-url url) 'url) + (textsec-suspicious-p + (cons (shr-expand-url url) + (buffer-substring (or shr-start start) + (point))) + 'link)))) (add-text-properties (or shr-start start) (point) (list 'face '(shr-link textsec-suspicious))) (insert (propertize "⚠️" 'help-echo warning)))))) @@ -1885,6 +1978,7 @@ The preference is a float determined from `shr-prefer-media-type'." (put-text-property start (point) 'keymap shr-image-map) (put-text-property start (point) 'shr-alt alt) (put-text-property start (point) 'image-url url) + (put-text-property start (point) 'image-dom-size (cons width height)) (put-text-property start (point) 'image-displayer (shr-image-displayer shr-content-function)) (put-text-property start (point) 'help-echo @@ -2170,6 +2264,18 @@ BASE is the URL of the HTML being rendered." (shr-generic dom) (insert ?\N{POP DIRECTIONAL ISOLATE})) +(defun shr-tag-math (dom) + ;; Sometimes a math element contains a plain text annotation + ;; (typically TeX notation) in addition to MathML markup. If we pass + ;; that to `dom-generic', the formula is printed twice. So we select + ;; only the annotation if available. + (shr-generic + (thread-first + dom + (dom-child-by-tag 'semantics) + (dom-child-by-tag 'annotation) + (or dom)))) + ;;; Outline Support (defun shr-outline-search (&optional bound move backward looking-at) "A function that can be used as `outline-search-function' for rendered html. diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el index 4fbdd183973..a648cf1e1e0 100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@ -67,7 +67,7 @@ "Face used for Sieve Test Commands.") (defface sieve-tagged-arguments - '((t :inherit font-lock-keyword face)) + '((t :inherit font-lock-keyword-face)) "Face used for Sieve Tagged Arguments.") diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el index a6ba556e7ae..68426ff91ec 100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@ -152,7 +152,7 @@ require \"fileinto\"; (interactive) (sieve-manage-close sieve-manage-buffer) (kill-buffer sieve-manage-buffer) - (when-let ((buffer (get-buffer sieve-buffer))) + (when-let* ((buffer (get-buffer sieve-buffer))) (kill-buffer buffer))) (defun sieve-bury-buffer () diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index b26a93fc6e4..7fbb2332e89 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -43,14 +43,18 @@ "Name of the Android Debug Bridge program." :group 'tramp :version "24.4" - :type 'string) + :type '(choice (const "adb") + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-adb-program)) (defcustom tramp-adb-connect-if-not-connected nil "Try to run `adb connect' if provided device is not connected currently. It is used for TCP/IP devices." :group 'tramp :version "25.1" - :type 'boolean) + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" + tramp-adb-connect-if-not-connected)) ;;;###tramp-autoload (defconst tramp-adb-method "adb" @@ -201,15 +205,15 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defsubst tramp-adb-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for ADB." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-adb-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-adb-method))))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) "Invoke the ADB handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-adb-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -228,7 +232,7 @@ arguments to pass to the OPERATION." (when (string-match (rx bol (group (+ (not blank))) (+ blank) "device" eol) line) ;; Replace ":" by "#". - `(nil ,(tramp-compat-string-replace + `(nil ,(string-replace ":" tramp-prefix-port-format (match-string 1 line))))) (tramp-process-lines nil tramp-adb-program "devices"))) @@ -329,10 +333,10 @@ arguments to pass to the OPERATION." v (format "%s -d -a -l %s %s | cat" (tramp-adb-get-ls-command v) (tramp-shell-quote-argument - (tramp-compat-file-name-concat localname ".")) + (file-name-concat localname ".")) (tramp-shell-quote-argument - (tramp-compat-file-name-concat localname "..")))) - (tramp-compat-replace-regexp-in-region + (file-name-concat localname "..")))) + (replace-regexp-in-region (rx (literal (file-name-unquote (file-name-as-directory localname)))) "" (point-min)) (widen))) @@ -373,7 +377,7 @@ Emacs dired can't find files." (search-forward-regexp (rx blank (group blank (regexp tramp-adb-ls-date-year-regexp) blank)) nil t) - (replace-match "0\\1" "\\1" nil) + (replace-match "0\\1" "\\1") ;; Insert missing "/". (when (looking-at-p (rx (regexp tramp-adb-ls-date-time-regexp) (+ blank) eol)) @@ -616,7 +620,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-shell-quote-argument l2)) "Error copying %s to %s" filename newname)) - (if-let ((tmpfile (file-local-copy filename))) + (if-let* ((tmpfile (file-local-copy filename))) ;; Remote filename. (condition-case err (rename-file tmpfile newname ok-if-already-exists) @@ -650,7 +654,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; KEEP-DATE handling. (when keep-date - (tramp-compat-set-file-times + (set-file-times newname (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) @@ -763,9 +767,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) - ;; Handle signals. `process-file-return-signal-string' exists - ;; since Emacs 28.1. - (when (and (bound-and-true-p process-file-return-signal-string) + (when (and process-file-return-signal-string (natnump ret) (> ret 128)) (setq ret (nth (- ret 128) (tramp-adb-get-signal-strings v)))))) @@ -809,10 +811,10 @@ will be used." v 'file-error "Cannot apply multibyte command `%s'" command)) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) + (tramp-set-connection-property v " process-name" name) + (tramp-set-connection-property v " process-buffer" buffer) (with-current-buffer (tramp-get-connection-buffer v) (unwind-protect ;; We catch this event. Otherwise, `make-process' @@ -855,8 +857,8 @@ will be used." ;; We must flush them here already; ;; otherwise `rename-file', `delete-file' ;; or `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + (tramp-flush-connection-property v " process-name") + (tramp-flush-connection-property v " process-buffer") ;; Copy tmpstderr file. (when (and (stringp stderr) (not (tramp-tramp-file-p stderr))) @@ -946,7 +948,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) - (tramp-compat-string-replace + (string-replace tramp-prefix-port-format ":" (cond ((member host devices) host) ;; This is the case when the host is connected to the default port. @@ -956,15 +958,14 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; An empty host name shall be mapped as well, when there ;; is exactly one entry in `devices'. ((and (tramp-string-empty-or-nil-p host) - (tramp-compat-length= devices 1)) + (length= devices 1)) (car devices)) ;; Try to connect device. ((and tramp-adb-connect-if-not-connected - (tramp-compat-length> host 0) + (length> host 0) (tramp-adb-execute-adb-command vec "connect" - (tramp-compat-string-replace - tramp-prefix-port-format ":" host))) + (string-replace tramp-prefix-port-format ":" host))) ;; When new device connected, running other adb command (e.g. ;; adb shell) immediately will fail. To get around this ;; problem, add sleep 0.1 second here. @@ -977,7 +978,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 (tramp-compat-length> (tramp-file-name-host vec) 0) + (when (and (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))) @@ -1021,7 +1022,7 @@ error and non-nil on success." ;; system, but this requires changes in core Tramp. (goto-char (point-min)) (while (search-forward-regexp (rx (+ "\r") eol) nil t) - (replace-match "" nil nil))))))) + (replace-match ""))))))) (defun tramp-adb-send-command-and-check (vec command &optional exit-status command-augmented-p) @@ -1105,7 +1106,8 @@ connection if a previous connection has died for some reason." ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet ;; whether it is still the same device. - (when (and user (not (tramp-get-file-property vec "/" "su-command-p" t))) + (when + (and user (not (tramp-get-connection-property vec " su-command-p" t))) (tramp-error vec 'file-error "Cannot switch to user `%s'" user)) (unless (process-live-p p) @@ -1125,6 +1127,11 @@ connection if a previous connection has died for some reason." tramp-adb-program args))) (prompt (md5 (concat (prin1-to-string process-environment) (current-time-string))))) + + ;; Set sentinel. Initialize variables. + (set-process-sentinel p #'tramp-process-sentinel) + (tramp-post-process-creation p vec) + ;; Wait for initial prompt. On some devices, it needs ;; an initial RET, in order to get it. (sleep-for 0.1) @@ -1133,10 +1140,6 @@ connection if a previous connection has died for some reason." (unless (process-live-p p) (tramp-error vec 'file-error "Terminated!")) - ;; Set sentinel. Initialize variables. - (set-process-sentinel p #'tramp-process-sentinel) - (tramp-post-process-creation p vec) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) @@ -1189,7 +1192,7 @@ connection if a previous connection has died for some reason." (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) ;; Do not flush, we need the nil value. - (tramp-set-file-property vec "/" "su-command-p" nil) + (tramp-set-connection-property vec " su-command-p" nil) (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el index dae90202478..9b45b416ff9 100644 --- a/lisp/net/tramp-androidsu.el +++ b/lisp/net/tramp-androidsu.el @@ -111,7 +111,7 @@ multibyte mode and waits for the shell prompt to appear." (with-tramp-debug-message vec "Opening connection" (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name")) + (process-name (tramp-get-connection-property vec " process-name")) (process-environment (copy-sequence process-environment))) ;; Open a new connection. (condition-case err @@ -304,15 +304,14 @@ FUNCTION." "Like `tramp-handle-make-process', but modified for Android." (tramp-skeleton-make-process args nil nil (let* ((env (mapcar - (lambda (elt) - (when (tramp-compat-string-search "=" elt) elt)) + (lambda (elt) (when (string-search "=" elt) elt)) tramp-remote-process-environment)) ;; We use as environment the difference to toplevel ;; `process-environment'. (env (dolist (elt process-environment env) (when (and - (tramp-compat-string-search "=" elt) + (string-search "=" elt) (not (member elt (default-toplevel-value 'process-environment)))) @@ -503,15 +502,15 @@ FUNCTION." ;;;###tramp-autoload (defsubst tramp-androidsu-file-name-p (vec-or-filename) "Check whether VEC-OR-FILENAME is for the `androidsu' method." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (equal (tramp-file-name-method vec) tramp-androidsu-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((equal (tramp-file-name-method vec) tramp-androidsu-method))))) ;;;###tramp-autoload (defun tramp-androidsu-file-name-handler (operation &rest args) "Invoke the `androidsu' handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-androidsu-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-androidsu-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 59c4223794c..3e6c483a47f 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -602,7 +602,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 (tramp-compat-length> localname 0) + (if (and (length> localname 0) (eq (aref localname (1- (length localname))) ?/) (not (string= localname "/"))) (substring directory 0 -1) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 30c38d19fb7..9cbd20c21cb 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -68,7 +68,7 @@ ;; Some properties are handled special: ;; -;; - "process-name", "process-buffer" and "first-password-request" are +;; - Properties which start with a space, like " process-name", are ;; not saved in the file `tramp-persistency-file-name', although ;; being connection properties related to a `tramp-file-name' ;; structure. @@ -103,13 +103,16 @@ details see the info pages." :version "24.4" :type '(repeat (list (choice :tag "File Name regexp" regexp (const nil)) (choice :tag " Property" string) - (choice :tag " Value" sexp)))) + (choice :tag " Value" sexp))) + :link '(info-link :tag "Tramp manual" + "(tramp) Predefined connection information")) ;;;###tramp-autoload (defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp") "File which keeps connection history for Tramp connections." :group 'tramp - :type 'file) + :type 'file + :link '(info-link :tag "Tramp manual" "(tramp) Connection caching")) ;;;###tramp-autoload (defconst tramp-cache-version (make-tramp-file-name :method "cache") @@ -122,12 +125,13 @@ details see the info pages." (defconst tramp-cache-undefined 'undef "The symbol marking undefined hash keys and values.") +;;;###tramp-autoload (defun tramp-get-hash-table (key) "Return the hash table for KEY. If it doesn't exist yet, it is created and initialized with matching entries of `tramp-connection-properties'. If KEY is `tramp-cache-undefined', don't create anything, and return nil." - (declare (tramp-suppress-trace t)) + ;; (declare (tramp-suppress-trace t)) (unless (eq key tramp-cache-undefined) (or (gethash key tramp-cache-data) (let ((hash @@ -140,6 +144,11 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash)))) +;; We cannot use the `declare' form for `tramp-suppress-trace' in +;; autoloaded functions, because the tramp-loaddefs.el generation +;; would fail. +(function-put #'tramp-get-hash-table 'tramp-suppress-trace t) + ;;;###tramp-autoload (defun tramp-get-file-property (key file property &optional default) "Get the PROPERTY of FILE from the cache context of KEY. @@ -234,8 +243,8 @@ Return VALUE." "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) ;; `file-name-directory' can return nil, for example for "~". - (when-let ((file (file-name-directory file)) - (file (directory-file-name file))) + (when-let* ((file (file-name-directory file)) + (file (directory-file-name file))) (setq key (tramp-file-name-unify key file)) (unless (eq key tramp-cache-undefined) (dolist (property (hash-table-keys (tramp-get-hash-table key))) @@ -271,8 +280,7 @@ Remove also properties of all files in subdirectories." (dolist (key (hash-table-keys tramp-cache-data)) (when (and (tramp-file-name-p key) (stringp (tramp-file-name-localname key)) - (tramp-compat-string-search - directory (tramp-file-name-localname key))) + (string-search directory (tramp-file-name-localname key))) (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) @@ -388,7 +396,8 @@ the connection, return DEFAULT." (not (and (processp key) (not (process-live-p key))))) (setq value cached cache-used t)) - (tramp-message key 7 "%s %s; cache used: %s" property value cache-used) + (unless (eq key tramp-cache-version) + (tramp-message key 7 "%s %s; cache used: %s" property value cache-used)) value)) ;;;###tramp-autoload @@ -401,11 +410,12 @@ is `tramp-cache-undefined', nothing is set. PROPERTY is set persistent when KEY is a `tramp-file-name' structure. Return VALUE." (setq key (tramp-file-name-unify key)) - (when-let ((hash (tramp-get-hash-table key))) + (when-let* ((hash (tramp-get-hash-table key))) (puthash property value hash)) (setq tramp-cache-data-changed (or tramp-cache-data-changed (tramp-file-name-p key))) - (tramp-message key 7 "%s %s" property value) + (unless (eq key tramp-cache-version) + (tramp-message key 7 "%s %s" property value)) value) ;;;###tramp-autoload @@ -425,7 +435,7 @@ KEY identifies the connection, it is either a process or a used to cache connection properties of the local machine. PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (tramp-file-name-unify key)) - (when-let ((hash (tramp-get-hash-table key))) + (when-let* ((hash (tramp-get-hash-table key))) (remhash property hash)) (setq tramp-cache-data-changed (or tramp-cache-data-changed (tramp-file-name-p key))) @@ -440,7 +450,7 @@ used to cache connection properties of the local machine." (setq key (tramp-file-name-unify key)) (tramp-message key 7 "%s %s" key - (when-let ((hash (gethash key tramp-cache-data))) + (when-let* ((hash (gethash key tramp-cache-data))) (hash-table-keys hash))) (setq tramp-cache-data-changed (or tramp-cache-data-changed (tramp-file-name-p key))) @@ -544,7 +554,7 @@ PROPERTIES is a list of file properties (strings)." (lambda (key) (and (tramp-file-name-p key) (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer") + (tramp-connection-property-p key " process-buffer") key)) (hash-table-keys tramp-cache-data)))) @@ -576,17 +586,15 @@ PROPERTIES is a list of file properties (strings)." (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) - (progn - (remhash "process-name" value) - (remhash "process-buffer" value) - (remhash "first-password-request" value)) + (dolist (k (hash-table-keys value)) + (when (string-prefix-p " " k) + (remhash k value))) (remhash key cache))) cache) ;; Dump it. (with-temp-file tramp-persistency-file-name (insert - ;; Starting with Emacs 28, we could use `lisp-data'. - (format ";; -*- emacs-lisp -*- <%s %s>\n" + (format ";; -*- lisp-data -*- <%s %s>\n" (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") tramp-persistency-file-name) ";; Tramp connection history. Don't change this file.\n" @@ -609,7 +617,8 @@ example if the host configuration changes often, or if you plug your laptop to different networks frequently." :group 'tramp :version "29.1" - :type 'boolean) + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" tramp-completion-use-cache)) ;;;###tramp-autoload (defun tramp-parse-connection-properties (method) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 5b2646a0b03..d38250d4e09 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -39,6 +39,8 @@ (defvar mm-7bit-chars) (defvar reporter-eval-buffer) (defvar reporter-prompt-for-summary-p) +(defvar tramp-repository-branch) +(defvar tramp-repository-version) ;;;###tramp-autoload (defun tramp-change-syntax (&optional syntax) @@ -54,6 +56,36 @@ SYNTAX can be one of the symbols `default' (default), (when syntax (customize-set-variable 'tramp-syntax syntax))) +;;;###tramp-autoload +(defun tramp-enable-method (method) + "Enable optional METHOD if possible." + (interactive + (list + (completing-read + "method: " + (tramp-compat-seq-keep + (lambda (x) + (when-let* ((name (symbol-name x)) + ;; It must match `tramp-enable-METHOD-method'. + ((string-match + (rx "tramp-enable-" + (group (regexp tramp-method-regexp)) + "-method") + name)) + (method (match-string 1 name)) + ;; It must not be enabled yet. + ((not (assoc method tramp-methods)))) + method)) + ;; All method enabling functions. + (mapcar + #'intern (all-completions "tramp-enable-" obarray #'functionp)))))) + + (when-let* (((not (assoc method tramp-methods))) + (fn (intern (format "tramp-enable-%s-method" method))) + ((functionp fn))) + (funcall fn) + (message "Tramp method \"%s\" enabled" method))) + ;; Use `match-buffers' starting with Emacs 29.1. ;;;###tramp-autoload (defun tramp-list-tramp-buffers () @@ -86,11 +118,12 @@ Each function is called with the current vector as argument.") (defun tramp-cleanup-connection (vec &optional keep-debug keep-password keep-processes) "Flush all connection related objects. -This includes password cache, file cache, connection cache, -buffers, processes. KEEP-DEBUG non-nil preserves the debug -buffer. KEEP-PASSWORD non-nil preserves the password cache. -KEEP-PROCESSES non-nil preserves the asynchronous processes. -When called interactively, a Tramp connection has to be selected." +This includes password cache, file cache, connection cache, buffers, +processes. KEEP-DEBUG non-nil preserves the debug and trace buffer. +KEEP-PASSWORD non-nil preserves the password cache. KEEP-PROCESSES +non-nil preserves the asynchronous processes. When called +interactively, a Tramp connection has to be selected." + (declare (completion tramp-active-command-completion-p)) (interactive ;; When interactive, select the Tramp remote identification. ;; Return nil when there is no Tramp connection. @@ -140,7 +173,7 @@ When called interactively, a Tramp connection has to be selected." (get-buffer (tramp-debug-buffer-name vec))) (unless keep-debug (get-buffer (tramp-trace-buffer-name vec))) - (tramp-get-connection-property vec "process-buffer"))) + (tramp-get-connection-property vec " process-buffer"))) (when (bufferp buf) (kill-buffer buf))) ;; Flush file cache. @@ -155,18 +188,12 @@ When called interactively, a Tramp connection has to be selected." ;;;###tramp-autoload (defun tramp-cleanup-this-connection () "Flush all connection related objects of the current buffer's connection." - ;; (declare (completion tramp-command-completion-p))) + (declare (completion tramp-command-completion-p)) (interactive) (and (tramp-tramp-file-p default-directory) (tramp-cleanup-connection (tramp-dissect-file-name default-directory 'noexpand)))) -;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. -;;;###tramp-autoload -(function-put - #'tramp-cleanup-this-connection 'completion-predicate - #'tramp-command-completion-p) - ;;;###tramp-autoload (defvar tramp-cleanup-all-connections-hook nil "List of functions to be called after all Tramp connections are cleaned up.") @@ -175,6 +202,7 @@ When called interactively, a Tramp connection has to be selected." (defun tramp-cleanup-all-connections () "Flush all Tramp internal objects. This includes password cache, file cache, connection cache, buffers." + (declare (completion tramp-active-command-completion-p)) (interactive) ;; Flush password cache. @@ -218,7 +246,8 @@ happens when at least one of the functions returns non-nil. The functions are called with `current-buffer' set." :group 'tramp :version "30.1" - :type 'hook) + :type 'hook + :link '(info-link :tag "Tramp manual" "(tramp) Cleanup remote connections")) (add-hook 'tramp-cleanup-some-buffers-hook #'buffer-file-name) @@ -271,6 +300,7 @@ functions are called with `current-buffer' set." A buffer is killed when it has a remote `default-directory', and one of the functions in `tramp-cleanup-some-buffers-hook' returns non-nil." + (declare (completion tramp-active-command-completion-p)) (interactive) ;; Remove all Tramp related connections. @@ -286,8 +316,9 @@ non-nil." ;;;###tramp-autoload (defun tramp-cleanup-all-buffers () "Kill all remote buffers." + (declare (completion tramp-active-command-completion-p)) (interactive) - (let ((tramp-cleanup-some-buffers-hook '(tramp-compat-always))) + (let ((tramp-cleanup-some-buffers-hook '(always))) (tramp-cleanup-some-buffers))) ;;; Rename @@ -312,13 +343,15 @@ expression which always matches." :group 'tramp :version "27.1" :type '(repeat (cons (choice :tag "Source regexp" regexp sexp) - (choice :tag "Target name" string (const nil))))) + (choice :tag "Target name" string (const nil)))) + :link '(info-link :tag "Tramp manual" "(tramp) Renaming remote files")) (defcustom tramp-confirm-rename-file-names t "Whether renaming a buffer file name must be confirmed." :group 'tramp :version "27.1" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) Renaming remote files")) (defun tramp-default-rename-file (string) "Determine default file name for renaming according to STRING. @@ -335,7 +368,7 @@ function returns nil" (when (string-match-p (or (eval (car item) t) "") string) (setq tdra nil result - (format-spec + (tramp-format-spec (cdr item) (format-spec-make ?m method ?u user ?h host))))) result))) @@ -382,6 +415,7 @@ without confirmation if the prefix argument is non-nil. The remote connection identified by SOURCE is flushed by `tramp-cleanup-connection'." + (declare (completion tramp-active-command-completion-p)) (interactive (let ((connections (mapcar #'tramp-make-tramp-file-name (tramp-list-connections))) @@ -472,8 +506,7 @@ ESC or `q' to quit without changing further buffers, (dolist (buffer (tramp-list-remote-buffers)) (switch-to-buffer buffer) (let* ((bfn (buffer-file-name)) - (new-bfn (and (stringp bfn) - (tramp-compat-string-replace source target bfn))) + (new-bfn (and (stringp bfn) (string-replace source target bfn))) (prompt (format-message "Set visited file name to `%s' [Type yn!eq or %s] " new-bfn (key-description (vector help-char))))) @@ -520,7 +553,7 @@ Interactively, TARGET is selected from `tramp-default-rename-alist' without confirmation if the prefix argument is non-nil. For details, see `tramp-rename-files'." - ;; (declare (completion tramp-command-completion-p)) + (declare (completion tramp-command-completion-p)) (interactive (let ((source default-directory) target @@ -551,11 +584,6 @@ For details, see `tramp-rename-files'." (tramp-rename-files default-directory target)) -;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. -;;;###tramp-autoload -(function-put - #'tramp-rename-these-files 'completion-predicate #'tramp-command-completion-p) - ;;; Run as sudo (defcustom tramp-file-name-with-method "sudo" @@ -566,7 +594,8 @@ For details, see `tramp-rename-files'." (const "sudo") (const "doas") (const "run0") - (const "ksu"))) + (const "ksu")) + :link '(tramp-info-link :tag "Tramp manual" tramp-file-name-with-method)) (defun tramp-file-name-with-sudo (filename) "Convert FILENAME into a multi-hop file name with \"sudo\". @@ -624,9 +653,8 @@ If the buffer runs `dired', the buffer is reverted." ;;; Recompile on ELPA -;; This function takes action since Emacs 28.1, when -;; `read-extended-command-predicate' is set to -;; `command-completion-default-include-p'. +;; This function takes action, when `read-extended-command-predicate' +;; is set to `command-completion-default-include-p'. ;;;###tramp-autoload (defun tramp-recompile-elpa-command-completion-p (_symbol _buffer) "A predicate for `tramp-recompile-elpa'. @@ -641,10 +669,10 @@ Tramp is an installed ELPA package." (defun tramp-recompile-elpa () "Recompile the installed Tramp ELPA package. This is needed if there are compatibility problems." - ;; (declare (completion tramp-recompile-elpa-command-completion-p)) + (declare (completion tramp-recompile-elpa-command-completion-p)) (interactive) ;; We expect just one Tramp package is installed. - (when-let + (when-let* ((dir (tramp-compat-funcall 'package-desc-dir (car (alist-get 'tramp (bound-and-true-p package-alist)))))) @@ -661,12 +689,6 @@ This is needed if there are compatibility problems." "--eval" (format "(byte-recompile-directory %S 0 t)" dir)) (message "Package `tramp' recompiled."))))) -;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. -;;;###tramp-autoload -(function-put - #'tramp-recompile-elpa 'completion-predicate - #'tramp-recompile-elpa-command-completion-p) - ;; Tramp version is useful in a number of situations. ;;;###tramp-autoload @@ -741,8 +763,8 @@ buffer in your bug report. (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." - (when-let ((reporter-eval-buffer reporter-eval-buffer) - (val (buffer-local-value varsym reporter-eval-buffer))) + (when-let* ((reporter-eval-buffer reporter-eval-buffer) + (val (buffer-local-value varsym reporter-eval-buffer))) (if (hash-table-p val) ;; Pretty print the cache. @@ -827,7 +849,7 @@ buffer in your bug report. (insert "\nload-path shadows:\n==================\n") (ignore-errors (mapc - (lambda (x) (when (tramp-compat-string-search "tramp" x) (insert x "\n"))) + (lambda (x) (when (string-search "tramp" x) (insert x "\n"))) (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 8781230c00c..b58930a7957 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -24,8 +24,8 @@ ;;; Commentary: ;; Tramp's main Emacs version for development is Emacs 30. This -;; package provides compatibility functions for Emacs 27, Emacs 28 and -;; Emacs 29. +;; package provides compatibility functions for Emacs 28, Emacs 29 and +;; Emacs 30. ;;; Code: @@ -76,11 +76,10 @@ ;; an infloop. We try to follow the XDG specification, for security reasons. (defconst tramp-compat-temporary-file-directory (file-name-as-directory - (if-let ((xdg (xdg-cache-home)) - ((file-directory-p xdg)) - ((file-writable-p xdg))) - ;; We can use `file-name-concat' starting with Emacs 28.1. - (prog1 (setq xdg (concat (file-name-as-directory xdg) "emacs")) + (if-let* ((xdg (xdg-cache-home)) + ((file-directory-p xdg)) + ((file-writable-p xdg))) + (prog1 (setq xdg (file-name-concat xdg "emacs")) (make-directory xdg t)) (eval (car (get 'temporary-file-directory 'standard-value)) t))) "The default value of `temporary-file-directory' for Tramp.") @@ -99,152 +98,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-modes', `set-file-modes' and `set-file-times' got argument -;; FLAG in Emacs 28.1. -(defalias 'tramp-compat-file-modes - (if (equal (func-arity #'file-modes) '(1 . 2)) - #'file-modes - (lambda (filename &optional _flag) - (file-modes filename)))) - -(defalias 'tramp-compat-set-file-modes - (if (equal (func-arity #'set-file-modes) '(2 . 3)) - #'set-file-modes - (lambda (filename mode &optional _flag) - (set-file-modes filename mode)))) - -(defalias 'tramp-compat-set-file-times - (if (equal (func-arity #'set-file-times) '(1 . 3)) - #'set-file-times - (lambda (filename &optional timestamp _flag) - (set-file-times filename timestamp)))) - -;; `directory-files' and `directory-files-and-attributes' got argument -;; COUNT in Emacs 28.1. -(defalias 'tramp-compat-directory-files - (if (equal (func-arity #'directory-files) '(1 . 5)) - #'directory-files - (lambda (directory &optional full match nosort _count) - (directory-files directory full match nosort)))) - -(defalias 'tramp-compat-directory-files-and-attributes - (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6)) - #'directory-files-and-attributes - (lambda (directory &optional full match nosort id-format _count) - (directory-files-and-attributes directory full match nosort id-format)))) - -;; `directory-empty-p' is new in Emacs 28.1. -(defalias 'tramp-compat-directory-empty-p - (if (fboundp 'directory-empty-p) - #'directory-empty-p - (lambda (dir) - (and (file-directory-p dir) - (null (tramp-compat-directory-files - dir nil directory-files-no-dot-files-regexp t 1)))))) - -;; Function `null-device' is new in Emacs 28.1. -(defalias 'tramp-compat-null-device - (if (fboundp 'null-device) - #'null-device - (lambda () - (if (tramp-tramp-file-p default-directory) "/dev/null" null-device)))) - -;; Function `string-replace' is new in Emacs 28.1. -(defalias 'tramp-compat-string-replace - (if (fboundp 'string-replace) - #'string-replace - (lambda (from-string to-string in-string) - (let (case-fold-search) - (replace-regexp-in-string - (regexp-quote from-string) to-string in-string t t))))) - -;; Function `string-search' is new in Emacs 28.1. -(defalias 'tramp-compat-string-search - (if (fboundp 'string-search) - #'string-search - (lambda (needle haystack &optional start-pos) - (let (case-fold-search) - (string-match-p (regexp-quote needle) haystack start-pos))))) - -;; Function `make-lock-file-name' is new in Emacs 28.1. -(defalias 'tramp-compat-make-lock-file-name - (if (fboundp 'make-lock-file-name) - #'make-lock-file-name - (lambda (filename) - (expand-file-name - (concat - ".#" (file-name-nondirectory filename)) - (file-name-directory filename))))) - -;; Function `file-name-concat' is new in Emacs 28.1. -(defalias 'tramp-compat-file-name-concat - (if (fboundp 'file-name-concat) - #'file-name-concat - (lambda (directory &rest components) - (let ((components (cl-remove-if (lambda (el) - (or (null el) (equal "" el))) - components)) - file-name-handler-alist) - (if (null components) - directory - (apply #'tramp-compat-file-name-concat - (concat (unless (or (equal "" directory) (null directory)) - (file-name-as-directory directory)) - (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 (search-forward-regexp 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)))) - -;; `always' is introduced with Emacs 28.1. -(defalias 'tramp-compat-always - (if (fboundp 'always) - #'always - (lambda (&rest _arguments) - "Do nothing and return t. -This function accepts any number of ARGUMENTS, but ignores them. -Also see `ignore'." - t))) - ;; `permission-denied' is introduced in Emacs 29.1. (defconst tramp-permission-denied (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error) @@ -274,7 +127,7 @@ Also see `ignore'." #'take (lambda (n list) (when (and (natnump n) (> n 0)) - (if (tramp-compat-length< list n) + (if (length< list n) list (butlast list (- (length list) n))))))) ;; Function `ntake' is new in Emacs 29.1. @@ -283,7 +136,7 @@ Also see `ignore'." #'ntake (lambda (n list) (when (and (natnump n) (> n 0)) - (if (tramp-compat-length< list n) + (if (length< list n) list (nbutlast list (- (length list) n))))))) ;; Function `string-equal-ignore-case' is new in Emacs 29.1. @@ -368,7 +221,7 @@ value is the default binding of the variable." (if (not criteria) ,variable (hack-connection-local-variables criteria) - (if-let ((result (assq ',variable connection-local-variables-alist))) + (if-let* ((result (assq ',variable connection-local-variables-alist))) (cdr result) ,variable))))) diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el index 02512e64ef6..c76bf5af696 100644 --- a/lisp/net/tramp-container.el +++ b/lisp/net/tramp-container.el @@ -50,18 +50,14 @@ ;; ;; Open file in a Kubernetes container: ;; -;; C-x C-f /kubernetes:[CONTAINER.]POD:/path/to/file +;; C-x C-f /kubernetes:[CONTAINER.]POD[%NAMESPACE]:/path/to/file ;; ;; Where: ;; POD is the pod to connect to. ;; CONTAINER is the container to connect to (optional). ;; By default, the first container in that pod will ;; be used. -;; -;; Completion for POD and accessing it operate in the current -;; namespace, use this command to change it: -;; -;; "kubectl config set-context --current --namespace=<name>" +;; NAMESPACE is the namespace to be used (optional). ;; ;; ;; @@ -125,7 +121,8 @@ :group 'tramp :version "29.1" :type '(choice (const "docker") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-docker-program)) ;;;###tramp-autoload (defcustom tramp-podman-program "podman" @@ -133,7 +130,8 @@ :group 'tramp :version "29.1" :type '(choice (const "podman") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-podman-program)) ;;;###tramp-autoload (defcustom tramp-kubernetes-program "kubectl" @@ -141,7 +139,8 @@ :group 'tramp :version "29.1" :type '(choice (const "kubectl") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-kubernetes-program)) (defcustom tramp-kubernetes-context nil "Context of Kubernetes. @@ -149,13 +148,18 @@ If it is nil, the default context will be used." :group 'tramp :version "30.1" :type '(choice (const :tag "Use default" nil) - (string))) + (string)) + :link '(info-link :tag "Tramp manual" "(tramp) Kubernetes setup")) -(defcustom tramp-kubernetes-namespace "default" - "Namespace of Kubernetes." +(defcustom tramp-kubernetes-namespace nil + "Namespace of Kubernetes. +If it is nil, the current namespace will be used. An explicit NAMESPACE +in the remote file name host part will override it." :group 'tramp - :version "30.1" - :type 'string) + :version "31.1" + :type '(choice (const :tag "Use default" nil) + (string)) + :link '(info-link :tag "Tramp manual" "(tramp) Kubernetes setup")) ;;;###tramp-autoload (defcustom tramp-toolbox-program "toolbox" @@ -163,7 +167,8 @@ If it is nil, the default context will be used." :group 'tramp :version "30.1" :type '(choice (const "toolbox") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-toolbox-program)) ;;;###tramp-autoload (defcustom tramp-distrobox-program "distrobox" @@ -171,7 +176,8 @@ If it is nil, the default context will be used." :group 'tramp :version "30.1" :type '(choice (const "distrobox") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-distrobox-program)) ;;;###tramp-autoload (defcustom tramp-flatpak-program "flatpak" @@ -179,7 +185,8 @@ If it is nil, the default context will be used." :group 'tramp :version "30.1" :type '(choice (const "flatpak") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-flatpak-program)) ;;;###tramp-autoload (defcustom tramp-apptainer-program "apptainer" @@ -187,14 +194,16 @@ If it is nil, the default context will be used." :group 'tramp :version "30.1" :type '(choice (const "apptainer") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-apptainer-program)) (defcustom tramp-nspawn-program "machinectl" "Name of the machinectl program." :group 'tramp :version "30.1" :type '(choice (const "machinectl") - (string))) + (string)) + :link '(tramp-info-link :tag "Tramp manual" tramp-nspawn-program)) ;;;###tramp-autoload (defconst tramp-docker-method "docker" @@ -279,19 +288,19 @@ or `tramp-podmancp-method'. This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string - (concat program " ps --format '{{.ID}}\t{{.Names}}'"))) - (lines (split-string raw-list "\n" 'omit)) - (names - (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (group (1+ nonl)) - "\t" (? (group (1+ nonl))) eol) - line) - (or (match-string 2 line) (match-string 1 line)))) - lines))) + (when-let* ((raw-list + (shell-command-to-string + (concat program " ps --format '{{.ID}}\t{{.Names}}'"))) + (lines (split-string raw-list "\n" 'omit)) + (names + (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (group (1+ nonl)) + "\t" (? (group (1+ nonl))) eol) + line) + (or (match-string 2 line) (match-string 1 line)))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -301,19 +310,19 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string - (concat - program " " - (tramp-kubernetes--context-namespace vec) - " get pods --no-headers" - ;; We separate pods by "|". Inside a pod, its name - ;; is separated from the containers by ":". - ;; Containers are separated by ",". - " -o jsonpath='{range .items[*]}{\"|\"}{.metadata.name}" - "{\":\"}{range .spec.containers[*]}{.name}{\",\"}" - "{end}{end}'"))) - (lines (split-string raw-list "|" 'omit))) + (when-let* ((raw-list + (shell-command-to-string + (concat + program " " + (tramp-kubernetes--context-namespace vec) + " get pods --no-headers" + ;; We separate pods by "|". Inside a pod, its name + ;; is separated from the containers by ":". + ;; Containers are separated by ",". + " -o jsonpath='{range .items[*]}{\"|\"}{.metadata.name}" + "{\":\"}{range .spec.containers[*]}{.name}{\",\"}" + "{end}{end}'"))) + (lines (split-string raw-list "|" 'omit))) (let (names) (dolist (line lines) (setq line (split-string line ":" 'omit)) @@ -324,27 +333,44 @@ see its function help for a description of the format." (push (concat elt "." (car line)) names))) (mapcar (lambda (name) (list nil name)) (delq nil names)))))) +;; <https://kubernetes.io/docs/concepts/overview/working-with-objects/names/> +;; `lower' could also match non-ascii letters. But since this regexp +;; is only used for strings matching `tramp-host-regexp', this doesn't +;; hurt. +(defconst tramp-kubernetes--name-regexp (rx (** 1 63 (any lower digit "-"))) + "Regexp matching kubernetes names.") + (defconst tramp-kubernetes--host-name-regexp - (rx (? (group (regexp tramp-host-regexp)) ".") - (group (regexp tramp-host-regexp))) - "The CONTAINER.POD syntax of kubernetes host names in Tramp.") + (rx bos (? (group (regexp tramp-kubernetes--name-regexp)) ".") + (group (regexp tramp-kubernetes--name-regexp)) + (? "%" (group (regexp tramp-kubernetes--name-regexp))) eos) + "The CONTAINER.POD%NAMESPACE syntax of kubernetes host names in Tramp.") ;;;###tramp-autoload (defun tramp-kubernetes--container (vec) "Extract the container name from a kubernetes host name in VEC." - (or (let ((host (tramp-file-name-host vec))) - (and (string-match tramp-kubernetes--host-name-regexp host) - (match-string 1 host))) + (or (when-let* ((host (and vec (tramp-file-name-host vec))) + ((string-match tramp-kubernetes--host-name-regexp host))) + (match-string 1 host)) "")) ;;;###tramp-autoload (defun tramp-kubernetes--pod (vec) "Extract the pod name from a kubernetes host name in VEC." - (or (let ((host (tramp-file-name-host vec))) - (and (string-match tramp-kubernetes--host-name-regexp host) - (match-string 2 host))) + (or (when-let* ((host (and vec (tramp-file-name-host vec))) + ((string-match tramp-kubernetes--host-name-regexp host))) + (match-string 2 host)) "")) +;;;###tramp-autoload +(defun tramp-kubernetes--namespace (vec) + "Extract the namespace from a kubernetes host name in VEC. +Use `tramp-kubernetes-namespace' otherwise." + (or (when-let* ((host (and vec (tramp-file-name-host vec))) + ((string-match tramp-kubernetes--host-name-regexp host))) + (match-string 3 host)) + tramp-kubernetes-namespace)) + ;; We must change `vec' and `default-directory' to the previous hop, ;; in order to run `process-file' in a proper environment. (defmacro tramp-skeleton-kubernetes-vector (vec &rest body) @@ -355,6 +381,11 @@ BODY is the backend specific code." (cond ((null ,vec) tramp-null-hop) ((equal (tramp-file-name-method ,vec) tramp-kubernetes-method) + ;; Sanity check. We don't support `user' or `port' in + ;; Kubernetes file names. + (when (or (tramp-file-name-user-domain ,vec) + (tramp-file-name-port ,vec)) + (tramp-user-error ,vec "Wrong kubernetes file name syntax")) (if (tramp-file-name-hop ,vec) (tramp-dissect-hop-name (tramp-file-name-hop ,vec)) tramp-null-hop)) @@ -382,7 +413,7 @@ Obey `tramp-kubernetes-context'" (defun tramp-kubernetes--current-context-data (vec) "Return Kubernetes current context data as JSON string." - (when-let ((current-context (tramp-kubernetes--current-context vec))) + (when-let* ((current-context (tramp-kubernetes--current-context vec))) (tramp-skeleton-kubernetes-vector vec (with-temp-buffer (when (zerop @@ -398,10 +429,11 @@ Obey `tramp-kubernetes-context'" "The kubectl options for context and namespace as string." (mapconcat #'identity - `(,(when-let ((context (tramp-kubernetes--current-context vec))) - (format "--context=%s" context)) - ,(when tramp-kubernetes-namespace - (format "--namespace=%s" tramp-kubernetes-namespace))) + (delq nil + `(,(when-let* ((context (tramp-kubernetes--current-context vec))) + (format "--context=%s" context)) + ,(when-let* ((namespace (tramp-kubernetes--namespace vec))) + (format "--namespace=%s" namespace)))) " ")) ;;;###tramp-autoload @@ -411,18 +443,18 @@ Obey `tramp-kubernetes-context'" This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list (shell-command-to-string (concat program " list -c"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n" 'omit))) - ;; We do not show container IDs. - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (1+ (not space)) - (1+ space) (group (1+ (not space))) space) - line) - (match-string 1 line))) - lines))) + (when-let* ((raw-list (shell-command-to-string (concat program " list -c"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + ;; We do not show container IDs. + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (1+ (not space)) + (1+ space) (group (1+ (not space))) space) + line) + (match-string 1 line))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -432,19 +464,19 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list (shell-command-to-string (concat program " list"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n" 'omit))) - ;; We do not show container IDs. - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (1+ (not space)) - (1+ space) "|" (1+ space) - (group (1+ (not space))) space) - line) - (match-string 1 line))) - lines))) + (when-let* ((raw-list (shell-command-to-string (concat program " list"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + ;; We do not show container IDs. + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (1+ (not space)) + (1+ space) "|" (1+ space) + (group (1+ (not space))) space) + line) + (match-string 1 line))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -456,19 +488,19 @@ ID, instance IDs. This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string - ;; Ignore header line. - (concat program " ps --columns=instance,application | cat -"))) - (lines (split-string raw-list "\n" 'omit)) - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (* space) (group (+ (not space))) - (? (+ space) (group (+ (not space)))) eol) - line) - (or (match-string 2 line) (match-string 1 line)))) - lines))) + (when-let* ((raw-list + (shell-command-to-string + ;; Ignore header line. + (concat program " ps --columns=instance,application | cat -"))) + (lines (split-string raw-list "\n" 'omit)) + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (* space) (group (+ (not space))) + (? (+ space) (group (+ (not space)))) eol) + line) + (or (match-string 2 line) (match-string 1 line)))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) ;;;###tramp-autoload @@ -478,19 +510,19 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string (concat program " instance list"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n" 'omit))) - (names (tramp-compat-seq-keep - (lambda (line) - (when (string-match - (rx bol (group (1+ (not space))) - (1+ space) (1+ (not space)) - (1+ space) (1+ (not space))) - line) - (match-string 1 line))) - lines))) + (when-let* ((raw-list + (shell-command-to-string (concat program " instance list"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n" 'omit))) + (names (tramp-compat-seq-keep + (lambda (line) + (when (string-match + (rx bol (group (1+ (not space))) + (1+ space) (1+ (not space)) + (1+ space) (1+ (not space))) + line) + (match-string 1 line))) + lines))) (mapcar (lambda (name) (list nil name)) names)))) (defun tramp-nspawn--completion-function (method) @@ -499,13 +531,13 @@ see its function help for a description of the format." This function is used by `tramp-set-completion-function', please see its function help for a description of the format." (tramp-skeleton-completion-function method - (when-let ((raw-list - (shell-command-to-string (concat program " list --all -q"))) - ;; Ignore header line. - (lines (cdr (split-string raw-list "\n"))) - (first-words (mapcar (lambda (line) (car (split-string line))) - lines)) - (machines (seq-take-while (lambda (name) name) first-words))) + (when-let* ((raw-list + (shell-command-to-string (concat program " list --all -q"))) + ;; Ignore header line. + (lines (cdr (split-string raw-list "\n"))) + (first-words + (mapcar (lambda (line) (car (split-string line))) lines)) + (machines (seq-take-while (lambda (name) name) first-words))) (mapcar (lambda (m) (list nil m)) machines)))) ;;;###tramp-autoload @@ -617,9 +649,9 @@ see its function help for a description of the format." ;; This variable will be eval'ed in `tramp-expand-args'. (tramp-extra-expand-args . (?a (tramp-kubernetes--container (car tramp-current-connection)) - ?h (tramp-kubernetes--pod (car tramp-current-connection)) - ?x (tramp-kubernetes--context-namespace - (car tramp-current-connection))))) + ?h (tramp-kubernetes--pod (car tramp-current-connection)) + ?x (tramp-kubernetes--context-namespace + (car tramp-current-connection))))) "Default connection-local variables for remote kubernetes connections.") (connection-local-set-profile-variables diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index d44a656035d..059b49714ab 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -84,13 +84,15 @@ "Name of the encfs program." :group 'tramp :version "28.1" - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Keeping files encrypted")) (defcustom tramp-crypt-encfsctl-program "encfsctl" "Name of the encfsctl program." :group 'tramp :version "28.1" - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Keeping files encrypted")) (defcustom tramp-crypt-encfs-option "--standard" "Configuration option for encfs. @@ -100,7 +102,8 @@ initializing a new encrypted remote directory." :group 'tramp :version "28.1" :type '(choice (const "--standard") - (const "--paranoia"))) + (const "--paranoia")) + :link '(info-link :tag "Tramp manual" "(tramp) Keeping files encrypted")) ;; We check only for encfs, assuming that encfsctl will be available ;; as well. The autoloaded value is nil, the check will run when @@ -112,9 +115,8 @@ initializing a new encrypted remote directory." "Non-nil when encryption support is available.") (setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) -;; This function takes action since Emacs 28.1, when -;; `read-extended-command-predicate' is set to -;; `command-completion-default-include-p'. +;; This function takes action, when `read-extended-command-predicate' +;; is set to `command-completion-default-include-p'. (defun tramp-crypt-command-completion-p (symbol _buffer) "A predicate for Tramp interactive commands. They are completed by `M-x TAB' only when encryption support is enabled." @@ -132,7 +134,8 @@ They are completed by `M-x TAB' only when encryption support is enabled." "Whether to keep the encfs configuration file in the encrypted remote directory." :group 'tramp :version "28.1" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) Keeping files encrypted")) ;;;###tramp-autoload (defvar tramp-crypt-directories nil @@ -231,7 +234,7 @@ If NAME doesn't belong to an encrypted remote directory, return nil." (set-file-modes . tramp-crypt-handle-set-file-modes) (set-file-selinux-context . ignore) (set-file-times . tramp-crypt-handle-set-file-times) - (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (set-visited-file-modtime . tramp-crypt-handle-set-visited-file-modtime) (shell-command . ignore) (start-file-process . ignore) ;; `substitute-in-file-name' performed by default handler. @@ -244,7 +247,8 @@ If NAME doesn't belong to an encrypted remote directory, return nil." (unhandled-file-name-directory . ignore) (unlock-file . tramp-crypt-handle-unlock-file) (vc-registered . ignore) - (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (verify-visited-file-modtime + . tramp-crypt-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) "Alist of handler functions for crypt method. Operations not mentioned here will be handled by the default Emacs primitives.") @@ -277,10 +281,10 @@ arguments to pass to the OPERATION." "Invoke the encrypted remote file related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((filename - (apply #'tramp-crypt-file-name-for-operation operation args)) - (fn (and (tramp-crypt-file-name-p filename) - (assoc operation tramp-crypt-file-name-handler-alist)))) + (if-let* ((filename + (apply #'tramp-crypt-file-name-for-operation operation args)) + ((tramp-crypt-file-name-p filename)) + (fn (assoc operation tramp-crypt-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-crypt-run-real-handler operation args) @@ -348,7 +352,7 @@ connection if a previous connection has died for some reason." (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) ;; Enable `auth-source', unless "emacs -Q" has been called. (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) + vec " first-password-request" tramp-cache-read-persistent-data) (with-temp-buffer (insert (tramp-read-passwd @@ -404,7 +408,7 @@ ARGS are the arguments. It returns t if ran successful, and nil otherwise." (args (delq nil args))) ;; Enable `auth-source', unless "emacs -Q" has been called. (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) + vec " first-password-request" tramp-cache-read-persistent-data) (insert (tramp-read-passwd (tramp-get-connection-process vec) @@ -425,11 +429,11 @@ ARGS are the arguments. It returns t if ran successful, and nil otherwise." "Return encrypted / decrypted NAME if NAME belongs to an encrypted directory. OP must be `encrypt' or `decrypt'. Raise an error if this fails. Otherwise, return NAME." - (if-let ((tramp-crypt-enabled t) - (dir (tramp-crypt-file-name-p name)) - ;; It must be absolute for the cache. - (localname (substring name (1- (length dir)))) - (crypt-vec (tramp-crypt-dissect-file-name dir))) + (if-let* ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p name)) + ;; It must be absolute for the cache. + (localname (substring name (1- (length dir)))) + (crypt-vec (tramp-crypt-dissect-file-name dir))) ;; Preserve trailing "/". (funcall (if (directory-name-p name) #'file-name-as-directory #'identity) @@ -465,9 +469,9 @@ Otherwise, return NAME." Both files must be local files. OP must be `encrypt' or `decrypt'. If OP is `decrypt', the basename of INFILE must be an encrypted file name. Raise an error if this fails." - (when-let ((tramp-crypt-enabled t) - (dir (tramp-crypt-file-name-p root)) - (crypt-vec (tramp-crypt-dissect-file-name dir))) + (when-let* ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p root)) + (crypt-vec (tramp-crypt-dissect-file-name dir))) (let ((coding-system-for-read (if (eq op 'decrypt) 'binary coding-system-for-read)) (coding-system-for-write @@ -521,7 +525,7 @@ directory. File names will be also encrypted." "Unmark expanded remote directory NAME for encryption. Existing files in that directory and its subdirectories will be kept in their encrypted form." - ;; (declare (completion tramp-crypt-command-completion-p)) + (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled")) @@ -535,11 +539,6 @@ kept in their encrypted form." (setq tramp-crypt-directories (delete name tramp-crypt-directories)) (tramp-register-file-name-handlers))) -;; Starting with Emacs 28.1, this can be replaced by the "(declare ...)" form. -(function-put - #'tramp-crypt-remove-directory 'completion-predicate - #'tramp-crypt-command-completion-p) - ;; `auth-source' requires a user. (defun tramp-crypt-dissect-file-name (name) "Return a `tramp-file-name' structure for NAME. @@ -547,7 +546,7 @@ The structure consists of the `tramp-crypt-method' method, the local user name, the hexlified directory NAME as host, and the localname." (save-match-data - (if-let ((dir (tramp-crypt-file-name-p name))) + (if-let* ((dir (tramp-crypt-file-name-p name))) (make-tramp-file-name :method tramp-crypt-method :user (user-login-name) :host (url-hexify-string dir)) @@ -802,10 +801,11 @@ WILDCARD is not supported." (defun tramp-crypt-handle-lock-file (filename) "Like `lock-file' for Tramp files." - (let (tramp-crypt-enabled) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall - 'lock-file (tramp-crypt-encrypt-file-name filename)))) + ;; `tramp-handle-lock-file' calls `verify-visited-file-modtime', so + ;; we must care `buffer-file-name'. + (let (tramp-crypt-enabled + (buffer-file-name (tramp-crypt-encrypt-file-name (buffer-file-name)))) + (lock-file (tramp-crypt-encrypt-file-name filename)))) (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -831,15 +831,13 @@ WILDCARD is not supported." "Like `set-file-modes' for Tramp files." (tramp-skeleton-set-file-modes-times-uid-gid filename (let (tramp-crypt-enabled) - (tramp-compat-set-file-modes - (tramp-crypt-encrypt-file-name filename) mode flag)))) + (set-file-modes (tramp-crypt-encrypt-file-name filename) mode flag)))) (defun tramp-crypt-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (tramp-skeleton-set-file-modes-times-uid-gid filename (let (tramp-crypt-enabled) - (tramp-compat-set-file-times - (tramp-crypt-encrypt-file-name filename) time flag)))) + (set-file-times (tramp-crypt-encrypt-file-name filename) time flag)))) (defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -848,12 +846,27 @@ WILDCARD is not supported." (tramp-set-file-uid-gid (tramp-crypt-encrypt-file-name filename) uid gid)))) +(defun tramp-crypt-handle-set-visited-file-modtime (&optional time-list) + "Like `set-visited-file-modtime' for Tramp files." + (unless (buffer-file-name) + (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" + (buffer-name))) + (let (tramp-crypt-enabled + (buffer-file-name (tramp-crypt-encrypt-file-name (buffer-file-name)))) + (set-visited-file-modtime time-list))) + (defun tramp-crypt-handle-unlock-file (filename) "Like `unlock-file' for Tramp files." (let (tramp-crypt-enabled) - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall - 'unlock-file (tramp-crypt-encrypt-file-name filename)))) + (unlock-file (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-verify-visited-file-modtime (&optional buf) + "Like `verify-visited-file-modtime' for Tramp files." + (with-current-buffer (or buf (current-buffer)) + (let (tramp-crypt-enabled + (buffer-file-name + (tramp-crypt-encrypt-file-name (buffer-file-name buf)))) + (verify-visited-file-modtime buf)))) (defun tramp-crypt-cleanup-connection (vec) "Cleanup crypt resources determined by VEC." diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 28ef8c67777..824ea0ee653 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -186,8 +186,8 @@ pass to the OPERATION." ;;;###tramp-autoload (defsubst tramp-ftp-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-ftp-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-ftp-method))))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index 3d42948043c..e34f735fa00 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -63,8 +63,7 @@ (append '("." "..") (tramp-fuse-remove-hidden-files - (tramp-compat-directory-files - (tramp-fuse-local-file-name directory)))))))) + (directory-files (tramp-fuse-local-file-name directory)))))))) (if full ;; Massage the result. (let ((local (rx @@ -129,8 +128,8 @@ (defun tramp-fuse-mount-spec (vec) "Return local mount spec of VEC." - (if-let ((host (tramp-file-name-host vec)) - (user (tramp-file-name-user vec))) + (if-let* ((host (tramp-file-name-host vec)) + (user (tramp-file-name-user vec))) (format "%s@%s:/" user host) (format "%s:/" host))) @@ -139,13 +138,17 @@ "Time period to check whether the mount point still exists. It has the same meaning as `remote-file-name-inhibit-cache'.") +;;;###tramp-autoload +(defconst tramp-fuse-name-prefix "tramp-" + "Prefix to use for temporary FUSE mount points.") + (defun tramp-fuse-mount-point (vec) "Return local mount point of VEC." (let ((remote-file-name-inhibit-cache tramp-fuse-mount-timeout)) (or (tramp-get-file-property vec "/" "mount-point") (expand-file-name (concat - tramp-temp-name-prefix + tramp-fuse-name-prefix (tramp-file-name-method vec) "." (when (tramp-file-name-user vec) (concat (tramp-file-name-user-domain vec) "@")) @@ -207,7 +210,7 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") (delete (tramp-file-name-unify vec) tramp-fuse-mount-points)) ;; Give the caches a chance to expire. (sleep-for 1) - (when (tramp-compat-directory-empty-p mount-point) + (when (directory-empty-p mount-point) (delete-directory mount-point)))) (defun tramp-fuse-local-file-name (filename) @@ -234,7 +237,8 @@ It has the same meaning as `remote-file-name-inhibit-cache'.") "Whether fuse volumes shall be unmounted on cleanup." :group 'tramp :version "28.1" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) FUSE setup")) (defun tramp-fuse-cleanup (vec) "Cleanup fuse volume determined by VEC." diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 381a5efc77f..683f8cc12bd 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -108,6 +108,7 @@ (require 'url-util) ;; Pacify byte-compiler. +(declare-function file-notify-callback "filenotify") (declare-function zeroconf-init "zeroconf") (declare-function zeroconf-list-service-types "zeroconf") (declare-function zeroconf-list-services "zeroconf") @@ -141,7 +142,8 @@ (const "mtp") (const "nextcloud") (const "sftp") - (const "smb")))) + (const "smb"))) + :link '(tramp-info-link :tag "Tramp manual" tramp-gvfs-methods)) ;;;###tramp-autoload (defconst tramp-goa-methods '("gdrive" "nextcloud") @@ -879,9 +881,9 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;;;###tramp-autoload (defsubst tramp-gvfs-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (let ((method (tramp-file-name-method vec))) - (and (stringp method) (member method tramp-gvfs-methods))))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + (method (tramp-file-name-method vec)) + ((member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) @@ -891,11 +893,11 @@ arguments to pass to the OPERATION." ;; `file-remote-p' must not return an error. (Bug#68976) (unless (or tramp-gvfs-enabled (eq operation 'file-remote-p)) (tramp-user-error nil "Package `tramp-gvfs' not supported")) - (if-let ((filename (apply #'tramp-file-name-for-operation operation args)) - (tramp-gvfs-dbus-event-vector - (and (tramp-tramp-file-p filename) - (tramp-dissect-file-name filename))) - (fn (assoc operation tramp-gvfs-file-name-handler-alist))) + (if-let* ((filename (apply #'tramp-file-name-for-operation operation args)) + (tramp-gvfs-dbus-event-vector + (and (tramp-tramp-file-p filename) + (tramp-dissect-file-name filename))) + (fn (assoc operation tramp-gvfs-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -928,9 +930,9 @@ arguments to pass to the OPERATION." "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists. Return nil for null BYTE-ARRAY." ;; The byte array could be a variant. Take care. - (when-let ((byte-array - (if (and (consp byte-array) (atom (car byte-array))) - byte-array (car byte-array)))) + (when-let* ((byte-array + (if (and (consp byte-array) (atom (car byte-array))) + byte-array (car byte-array)))) (dbus-byte-array-to-string (if (and (consp byte-array) (zerop (car (last byte-array)))) (butlast byte-array) byte-array)))) @@ -1169,7 +1171,7 @@ file names." (delete-file file))) (directory-files directory 'full directory-files-no-dot-files-regexp)) - (unless (tramp-compat-directory-empty-p directory) + (unless (directory-empty-p directory) (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) @@ -1203,7 +1205,7 @@ file names." (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))) + (setq name (file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name)) @@ -1403,7 +1405,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (or (cdr (assoc "standard::size" attributes)) "0"))) ;; ... file mode flags (setq res-filemodes - (if-let ((n (cdr (assoc "unix::mode" attributes)))) + (if-let* ((n (cdr (assoc "unix::mode" attributes)))) (tramp-file-mode-from-int (string-to-number n)) (format "%s%s%s%s------" @@ -1419,11 +1421,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." "-" "x")))) ;; ... inode and device (setq res-inode - (if-let ((n (cdr (assoc "unix::inode" attributes)))) + (if-let* ((n (cdr (assoc "unix::inode" attributes)))) (string-to-number n) (tramp-get-inode (tramp-dissect-file-name filename)))) (setq res-device - (if-let ((n (cdr (assoc "unix::device" attributes)))) + (if-let* ((n (cdr (assoc "unix::device" attributes)))) (string-to-number n) (tramp-get-device (tramp-dissect-file-name filename)))) @@ -1465,7 +1467,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (defun tramp-gvfs-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (tramp-skeleton-file-name-all-completions filename directory - (unless (tramp-compat-string-search "/" filename) + (unless (string-search "/" filename) (all-completions filename (with-parsed-tramp-file-name (expand-file-name directory) nil @@ -1533,12 +1535,9 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) ;; Fix action names. - string (tramp-compat-string-replace - "attributes changed" "attribute-changed" string) - string (tramp-compat-string-replace - "changes done" "changes-done-hint" string) - string (tramp-compat-string-replace - "renamed to" "moved" string)) + string (string-replace "attributes changed" "attribute-changed" string) + string (string-replace "changes done" "changes-done-hint" string) + string (string-replace "renamed to" "moved" string)) ;; https://bugs.launchpad.net/bugs/1742946 (when (string-match-p @@ -1574,8 +1573,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the callback directly. (when (member action events) - (tramp-compat-funcall - 'file-notify-callback (list proc action file file1))))) + (file-notify-callback (list proc action file file1))))) ;; Save rest of the string. (when (string-empty-p string) (setq string nil)) @@ -1677,19 +1675,21 @@ ID-FORMAT valid values are `string' and `integer'." ;; The result is cached in `tramp-get-remote-uid'. (if (equal id-format 'string) (tramp-file-name-user vec) - (when-let ((localname - (tramp-get-connection-property (tramp-get-process vec) "share"))) - (file-attribute-user-id - (file-attributes (tramp-make-tramp-file-name vec localname) id-format))))) + (and-let* ((localname + (tramp-get-connection-property (tramp-get-process vec) "share")) + ((file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))))) (defun tramp-gvfs-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." ;; The result is cached in `tramp-get-remote-gid'. - (when-let ((localname - (tramp-get-connection-property (tramp-get-process vec) "share"))) - (file-attribute-group-id - (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) + (and-let* ((localname + (tramp-get-connection-property (tramp-get-process vec) "share")) + ((file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1722,12 +1722,12 @@ ID-FORMAT valid values are `string' and `integer'." (setq method "davs" localname (concat (tramp-gvfs-get-remote-prefix v) localname))) - (when (string-equal "mtp" method) - (when-let - ((media (tramp-get-connection-property v "media-device"))) - (setq method (tramp-media-device-method media) - host (tramp-media-device-host media) - port (tramp-media-device-port media)))) + (when-let* + (((string-equal "mtp" method)) + (media (tramp-get-connection-property v "media-device"))) + (setq method (tramp-media-device-method media) + host (tramp-media-device-host media) + port (tramp-media-device-port media))) (when (and user domain) (setq user (concat domain ";" user))) (url-recreate-url @@ -1801,7 +1801,7 @@ a downcased host name only." (setq domain (read-string "Domain name: "))) (tramp-message l 6 "%S %S %S %d" message user domain flags) - (unless (tramp-get-connection-property l "first-password-request") + (unless (tramp-get-connection-property l " first-password-request") (tramp-clear-passwd l)) (setq password (tramp-read-passwd @@ -1924,10 +1924,10 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (when (member method tramp-media-methods) ;; Ensure that media devices are cached. (tramp-get-media-devices nil) - (when-let ((v (tramp-get-connection-property - (make-tramp-media-device - :method method :host host :port port) - "vector" nil))) + (when-let* ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) (setq method (tramp-file-name-method v) host (tramp-file-name-host v) port (tramp-file-name-port v)))) @@ -2024,10 +2024,10 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and (when (member method tramp-media-methods) ;; Ensure that media devices are cached. (tramp-get-media-devices vec) - (when-let ((v (tramp-get-connection-property - (make-tramp-media-device - :method method :host host :port port) - "vector"))) + (when-let* ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector"))) (setq method (tramp-file-name-method v) host (tramp-file-name-host v) port (tramp-file-name-port v)))) @@ -2145,7 +2145,7 @@ Their full names are (vec (make-tramp-file-name :method "mtp" ;; A host name cannot contain spaces. - :host (tramp-compat-string-replace " " "_" (nth 1 volume)))) + :host (string-replace " " "_" (nth 1 volume)))) (media (make-tramp-media-device :method method :host (tramp-gvfs-url-host (nth 5 volume)) @@ -2252,7 +2252,7 @@ connection if a previous connection has died for some reason." ;; Enable `auth-source'. (tramp-set-connection-property - vec "first-password-request" tramp-cache-read-persistent-data) + vec " first-password-request" tramp-cache-read-persistent-data) ;; There will be a callback of "askPassword" when a password is needed. (dbus-register-method @@ -2442,8 +2442,8 @@ It checks for registered GNOME Online Accounts." (defun tramp-get-media-device (vec) "Transform VEC into a `tramp-media-device' structure. Check, that respective cache values do exist." - (if-let ((media (tramp-get-connection-property vec "media-device")) - (prop (tramp-get-connection-property media "vector"))) + (if-let* ((media (tramp-get-connection-property vec "media-device")) + (prop (tramp-get-connection-property media "vector"))) media (tramp-get-media-devices vec) (tramp-get-connection-property vec "media-device"))) @@ -2462,7 +2462,7 @@ VEC is used only for traces." (vec (make-tramp-file-name :method "mtp" ;; A host name cannot contain spaces. - :host (tramp-compat-string-replace " " "_" (nth 1 volume)))) + :host (string-replace " " "_" (nth 1 volume)))) (media (make-tramp-media-device :method method :host (tramp-gvfs-url-host (nth 5 volume)) @@ -2476,7 +2476,7 @@ VEC is used only for traces." ;; Adapt default host name, supporting /mtp:: when possible. (setq tramp-default-host-alist (append - `(("mtp" nil ,(if (tramp-compat-length= devices 1) (car devices) ""))) + `(("mtp" nil ,(if (length= devices 1) (car devices) ""))) (delete (assoc "mtp" tramp-default-host-alist) tramp-default-host-alist))))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 465b7dbbaec..a06e4b50677 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -273,6 +273,33 @@ NAME must be equal to `tramp-current-connection'." (delete (info-lookup->mode-cache 'symbol ',mode) (info-lookup->topic-cache 'symbol)))))))) +;;; Integration of new `:link' type in `defcustom': + +(define-widget 'tramp-info-link 'link + "A link to the Tramp info file." + :action 'tramp-widget-info-link-action) + +(defun tramp-widget-info-link-action (widget &optional _event) + "Open the info node specified by WIDGET. +It's value must be a Tramp user option, indexed in the Tramp manual via +`@vindex'." + (let* ((topic (widget-value widget)) + (pattern + (rx "\n*" (1+ " ") (0+ nonl) + (literal (if (stringp topic) topic (symbol-name topic))) + (0+ nonl) ":" (1+ (any "\t ")) + (group (0+ nonl)) + "." (0+ (any "\t\n ")) "(line" (1+ " ") + (group (1+ digit)) + ")"))) + (info "(tramp) Variable Index") + (goto-char (point-min)) + (when (re-search-forward pattern nil t) + (let ((nodename (concat "(tramp) " (match-string-no-properties 1))) + (line (string-to-number (match-string 2)))) + (info nodename) + (forward-line (- line 2)))))) + ;;; Integration of shortdoc.el: (tramp--with-startup @@ -551,11 +578,11 @@ See `tramp-process-attributes-ps-format'.") ;; Preset default "ps" profile for local hosts, based on system type. -(when-let ((local-profile - (cond ((eq system-type 'darwin) - 'tramp-connection-local-darwin-ps-profile) - ;; ... Add other system types here. - ))) +(when-let* ((local-profile + (cond ((eq system-type 'darwin) + 'tramp-connection-local-darwin-ps-profile) + ;; ... Add other system types here. + ))) (connection-local-set-profiles `(:application tramp :machine ,(system-name)) local-profile) diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el index 36079c8844c..2681be3a0c2 100644 --- a/lisp/net/tramp-message.el +++ b/lisp/net/tramp-message.el @@ -53,6 +53,8 @@ (declare-function tramp-file-name-host-port "tramp") (declare-function tramp-file-name-user-domain "tramp") (declare-function tramp-get-default-directory "tramp") +(defvar tramp-repository-branch) +(defvar tramp-repository-version) ;;;###tramp-autoload (defcustom tramp-verbose 3 @@ -72,7 +74,8 @@ Any level x includes messages for all levels 1 .. x-1. The levels are 10 traces (huge) 11 call traces (maintainer only)." :group 'tramp - :type 'integer) + :type 'integer + :link '(info-link :tag "Tramp manual" "(tramp) Traces and Profiles")) (defcustom tramp-debug-to-file nil "Whether Tramp debug messages shall be saved to file. @@ -80,14 +83,16 @@ The debug file has the same name as the debug buffer, written to `tramp-compat-temporary-file-directory'." :group 'tramp :version "28.1" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) Traces and Profiles")) (defcustom tramp-debug-command-messages nil "Whether to write only command messages to the debug buffer. This increases `tramp-verbose' to 6 if necessary." :group 'tramp :version "30.1" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) Traces and Profiles")) (defconst tramp-debug-outline-regexp (rx ;; Timestamp. @@ -122,9 +127,8 @@ The outline level is equal to the verbosity of the Tramp message." (declare (tramp-suppress-trace t)) (1+ (string-to-number (match-string 3)))) -;; This function takes action since Emacs 28.1, when -;; `read-extended-command-predicate' is set to -;; `command-completion-default-include-p'. +;; This function takes action, when `read-extended-command-predicate' +;; is set to `command-completion-default-include-p'. (defun tramp-debug-buffer-command-completion-p (_symbol buffer) "A predicate for Tramp interactive commands. They are completed by `M-x TAB' only in Tramp debug buffers." @@ -136,9 +140,8 @@ They are completed by `M-x TAB' only in Tramp debug buffers." (defun tramp-setup-debug-buffer () "Function to setup debug buffers." - (declare (tramp-suppress-trace t)) - ;; (declare (completion tramp-debug-buffer-command-completion-p) - ;; (tramp-suppress-trace t)) + (declare (completion tramp-debug-buffer-command-completion-p) + (tramp-suppress-trace t)) (interactive) (set-buffer-file-coding-system 'utf-8) (setq buffer-undo-list t) @@ -164,10 +167,6 @@ They are completed by `M-x TAB' only in Tramp debug buffers." (local-set-key "\M-n" 'clone-buffer) (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) -(function-put - #'tramp-setup-debug-buffer 'completion-predicate - #'tramp-debug-buffer-command-completion-p) - (defun tramp-debug-buffer-name (vec) "A name for the debug buffer of VEC." (declare (tramp-suppress-trace t)) @@ -190,13 +189,13 @@ They are completed by `M-x TAB' only in Tramp debug buffers." "Get the debug file name for VEC." (declare (tramp-suppress-trace t)) (expand-file-name - (tramp-compat-string-replace "/" " " (tramp-debug-buffer-name vec)) + (string-replace "/" " " (tramp-debug-buffer-name vec)) tramp-compat-temporary-file-directory)) (defun tramp-trace-buffer-name (vec) "A name for the trace buffer for VEC." (declare (tramp-suppress-trace t)) - (tramp-compat-string-replace "*debug" "*trace" (tramp-debug-buffer-name vec))) + (string-replace "*debug" "*trace" (tramp-debug-buffer-name vec))) (defvar tramp-trace-functions nil "A list of non-Tramp functions to be traced with `tramp-verbose' > 10.") @@ -422,7 +421,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." ;; Show buffer. (pop-to-buffer buf) (discard-input) - (sit-for tramp-error-show-message-timeout))) + (sit-for tramp-error-show-message-timeout 'nodisp))) ;; Reset timestamp. It would be wrong after waiting for a while. (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) @@ -444,7 +443,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." ;; `tramp-error' does not show messages. So we must do it ourselves. (apply #'message fmt-string arguments) (discard-input) - (sit-for tramp-error-show-message-timeout) + (sit-for tramp-error-show-message-timeout 'nodisp) ;; Reset timestamp. It would be wrong after waiting for a while. (when (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) @@ -468,7 +467,7 @@ to `tramp-message'." (declare (tramp-suppress-trace t)) (let (signal-hook-function) (apply 'tramp-message vec-or-proc 2 fmt-string arguments) - (lwarn 'tramp :warning fmt-string arguments))) + (apply 'lwarn 'tramp :warning fmt-string arguments))) (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." @@ -486,7 +485,7 @@ to `tramp-message'." "Goto the linked message in debug buffer at place." (declare (tramp-suppress-trace t)) (when (mouse-event-p last-input-event) (mouse-set-point last-input-event)) - (when-let ((point (button-get button 'position))) + (when-let* ((point (button-get button 'position))) (goto-char point))) (define-button-type 'tramp-debug-button-type diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 03b0dedbb70..dbbe6680fe2 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -46,7 +46,8 @@ "Name of the rclone program." :group 'tramp :version "27.1" - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Setup of rclone method")) ;;;###tramp-autoload (tramp--with-startup @@ -166,15 +167,15 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;;;###tramp-autoload (defsubst tramp-rclone-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for rclone." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-rclone-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-rclone-method))))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) "Invoke the rclone handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-rclone-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 8fde854a97b..5535ed3ab60 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -38,9 +38,6 @@ (declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) -;; Added in Emacs 28.1. -(defvar process-file-return-signal-string) -(defvar vc-handled-backends) (defvar vc-bzr-program) (defvar vc-git-program) (defvar vc-hg-program) @@ -56,13 +53,15 @@ size is this value or above (up to `tramp-copy-size-limit' for out-of-band methods). If it is nil, no compression at all will be applied." :group 'tramp - :type '(choice (const nil) integer)) + :type '(choice (const nil) integer) + :link '(info-link :tag "Tramp manual" "(tramp) Inline methods")) (defcustom tramp-copy-size-limit 10240 "Maximum file size where inline copying is preferred to an out-of-the-band copy. If it is nil, out-of-the-band copy will be used without a check." :group 'tramp - :type '(choice (const nil) integer)) + :type '(choice (const nil) integer) + :link '(info-link :tag "Tramp manual" "(tramp) External methods")) ;;;###tramp-autoload (defcustom tramp-histfile-override "~/.tramp_history" @@ -79,7 +78,8 @@ the default storage location, e.g. \"$HOME/.sh_history\"." :version "25.2" :type '(choice (const :tag "Do not override HISTFILE" nil) (const :tag "Unset HISTFILE" t) - (string :tag "Redirect to a file"))) + (string :tag "Redirect to a file")) + :link '(info-link :tag "Tramp manual" "(tramp) Managing remote shell history")) (put 'tramp-histfile-override 'permanent-local t) @@ -119,7 +119,8 @@ Set it to `suppress' if you want to disable settings in your (const :tag "Don't set ControlMaster" nil) (const :tag "Suppress ControlMaster" suppress)) ;; Check with (safe-local-variable-p 'tramp-use-connection-share 'suppress) - :safe (lambda (val) (and (memq val '(t nil suppress)) t))) + :safe (lambda (val) (and (memq val '(t nil suppress)) t)) + :link '(info-link :tag "Tramp manual" "(tramp) Using ssh connection sharing")) (defvar tramp-ssh-controlmaster-options nil "Which ssh Control* arguments to use. @@ -157,7 +158,9 @@ The string is used in `tramp-methods'.") "Whether to use direct copying between two remote hosts." :group 'tramp :version "29.1" - :type 'boolean) + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" + tramp-use-scp-direct-remote-copying)) ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload @@ -590,13 +593,15 @@ for tilde expansion. The extra arguments should typically prevent the shell from reading its init file." :group 'tramp :version "30.1" - :type '(alist :key-type regexp :value-type string)) + :type '(alist :key-type regexp :value-type string) + :link '(info-link :tag "Tramp manual" "(tramp) Remote shell setup")) ;;;###tramp-autoload (defconst tramp-actions-before-shell '((tramp-login-prompt-regexp tramp-action-login) (tramp-password-prompt-regexp tramp-action-password) (tramp-otp-password-prompt-regexp tramp-action-otp-password) + (tramp-fingerprint-prompt-regexp tramp-action-fingerprint) (tramp-wrong-passwd-regexp tramp-action-permission-denied) (shell-prompt-pattern tramp-action-succeed) (tramp-shell-prompt-pattern tramp-action-succeed) @@ -1808,7 +1813,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; be expected that this is always a directory. (or (tramp-string-empty-or-nil-p localname) (with-tramp-file-property v localname "file-directory-p" - (if-let + (if-let* ((truename (tramp-get-file-property v localname "file-truename")) ((tramp-file-property-p v (tramp-file-local-name truename) "file-attributes"))) @@ -1909,9 +1914,9 @@ ID-FORMAT valid values are `string' and `integer'." "Like `file-name-all-completions' for Tramp files." (tramp-skeleton-file-name-all-completions filename directory (with-parsed-tramp-file-name (expand-file-name directory) nil - (when (and (not (tramp-compat-string-search "/" filename)) + (when (and (not (string-search "/" filename)) (tramp-connectable-p v)) - (unless (tramp-compat-string-search "/" filename) + (unless (string-search "/" filename) (all-completions filename (with-tramp-file-property v localname "file-name-all-completions" @@ -2023,49 +2028,55 @@ ID-FORMAT valid values are `string' and `integer'." (t2 (tramp-tramp-file-p newname)) target) (with-parsed-tramp-file-name (if t1 dirname newname) nil - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - - ;; `copy-directory-create-symlink' exists since Emacs 28.1. - (if (and (bound-and-true-p copy-directory-create-symlink) - (setq target (file-symlink-p dirname)) - (tramp-equal-remote dirname newname)) - (make-symbolic-link - target - (if (directory-name-p newname) - (concat newname (file-name-nondirectory dirname)) newname) - t) - - (if (and (not copy-contents) - (tramp-get-method-parameter v 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must - ;; have the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method - (tramp-dissect-file-name dirname)) - (tramp-file-name-method - (tramp-dissect-file-name newname))))) - ;; scp or rsync DTRT. - (progn - (when (and (file-directory-p newname) - (not (directory-name-p newname))) - (tramp-error v 'file-already-exists newname)) - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname))) - (unless (file-directory-p (file-name-directory newname)) - (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname 'ok-if-already-exists keep-date)) - - ;; We must do it file-wise. - (tramp-run-real-handler + (cond + ((and copy-directory-create-symlink + (setq target (file-symlink-p dirname)) + (tramp-equal-remote dirname newname)) + (make-symbolic-link + target + (if (directory-name-p newname) + (concat newname (file-name-nondirectory dirname)) newname) + t)) + + ;; Shortcut: if method, host, user are the same for both + ;; files, we invoke `cp' on the remote host directly. + ((and (not copy-contents) + (tramp-equal-remote dirname newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (tramp-do-copy-or-rename-file-directly + 'copy dirname newname + 'ok-if-already-exists keep-date 'preserve-uid-gid)) + + ;; scp or rsync DTRT. + ((and (not copy-contents) + (tramp-get-method-parameter v 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must have + ;; the same method. + (or (null t1) (null t2) + (string-equal + (tramp-file-name-method (tramp-dissect-file-name dirname)) + (tramp-file-name-method (tramp-dissect-file-name newname))))) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-already-exists newname)) + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name (file-name-nondirectory dirname) newname))) + (unless (file-directory-p (file-name-directory newname)) + (make-directory (file-name-directory newname) parents)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname 'ok-if-already-exists keep-date)) + + ;; We must do it file-wise. + (t (tramp-run-real-handler #'copy-directory (list dirname newname keep-date parents copy-contents)))) @@ -2221,14 +2232,14 @@ file names." ;; Handle `preserve-extended-attributes'. We ignore ;; possible errors, because ACL strings could be ;; incompatible. - (when-let ((attributes (and preserve-extended-attributes - (file-extended-attributes filename)))) + (when-let* ((attributes (and preserve-extended-attributes + (file-extended-attributes filename)))) (ignore-errors (set-file-extended-attributes newname attributes))) ;; KEEP-DATE handling. (when (and keep-date (not copy-keep-date)) - (tramp-compat-set-file-times + (set-file-times newname file-times (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -2505,8 +2516,7 @@ The method used must be an out-of-band method." copy-args (flatten-tree (mapcar - (lambda (x) (if (tramp-compat-string-search " " x) - (split-string x) x)) + (lambda (x) (if (string-search " " x) (split-string x) x)) copy-args)) copy-env (apply #'tramp-expand-args v 'tramp-copy-env nil spec) remote-copy-program @@ -2549,16 +2559,16 @@ The method used must be an out-of-band method." (with-temp-buffer (unwind-protect (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; The default directory must be remote. (let ((default-directory (file-name-directory (if v1 filename newname))) (process-environment (copy-sequence process-environment))) ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) (when copy-env (tramp-message v 6 "%s=\"%s\"" @@ -2805,7 +2815,7 @@ The method used must be an out-of-band method." (save-restriction (narrow-to-region beg-marker end-marker) ;; Some busyboxes are reluctant to discard colors. - (unless (tramp-compat-string-search + (unless (string-search "color" (tramp-get-connection-property v "ls" "")) (goto-char (point-min)) (while (search-forward-regexp ansi-color-control-seq-regexp nil t) @@ -2859,7 +2869,7 @@ The method used must be an out-of-band method." (rx bol (group (* blank) "total")) nil t) ;; Emacs 29.1 or later. (not (fboundp 'dired--insert-disk-space))) - (when-let ((available (get-free-disk-space "."))) + (when-let* ((available (get-free-disk-space "."))) ;; Replace "total" with "total used", to avoid confusion. (replace-match "\\1 used in directory") (end-of-line) @@ -2892,7 +2902,7 @@ the result will be a local, non-Tramp, file name." (tramp-run-real-handler #'expand-file-name (list name dir)) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) - (setq name (tramp-compat-file-name-concat dir name))) + (setq name (file-name-concat dir name))) ;; Dissect NAME. (with-parsed-tramp-file-name name nil ;; If connection is not established yet, run the real handler. @@ -2983,7 +2993,7 @@ will be used." (heredoc (and (not (bufferp stderr)) (stringp program) (string-match-p (rx "sh" eol) program) - (tramp-compat-length= args 2) + (length= args 2) (string-equal "-c" (car args)) ;; Don't if there is a quoted string. (not (string-match-p (rx (any "'\"")) (cadr args))) @@ -2992,7 +3002,7 @@ will be used." ;; When PROGRAM is nil, we just provide a tty. (args (if (not heredoc) args (let ((i 250)) - (while (and (not (tramp-compat-length< (cadr args) i)) + (while (and (not (length< (cadr args) i)) (string-match " " (cadr args) i)) (setcdr args @@ -3011,7 +3021,7 @@ will be used." (env (dolist (elt (cons prompt process-environment) env) (or (member elt (default-toplevel-value 'process-environment)) - (if (tramp-compat-string-search "=" elt) + (if (string-search "=" elt) (setq env (append env `(,elt))) (setq uenv (cons elt uenv)))))) (env (setenv-internal @@ -3066,10 +3076,10 @@ will be used." :file-handler t)) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) + (tramp-set-connection-property v " process-name" name) + (tramp-set-connection-property v " process-buffer" buffer) (with-current-buffer (tramp-get-connection-buffer v) (unwind-protect ;; We catch this event. Otherwise, `make-process' @@ -3094,8 +3104,7 @@ will be used." ;; needed when sending signals remotely. (let ((pid (tramp-send-command-and-read v "echo $$"))) (setq p (tramp-get-connection-process v)) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) + (process-put p 'remote-pid pid)) (when (memq connection-type '(nil pipe)) ;; Disable carriage return to newline ;; translation. This does not work on @@ -3151,8 +3160,8 @@ will be used." (set-marker (process-mark p) (point))) ;; We must flush them here already; otherwise ;; `delete-file' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + (tramp-flush-connection-property v " process-name") + (tramp-flush-connection-property v " process-buffer") ;; Kill stderr process and delete named pipe. (when (bufferp stderr) (add-function @@ -3244,7 +3253,7 @@ will be used." ;; We use as environment the difference to toplevel `process-environment'. (dolist (elt process-environment) (or (member elt (default-toplevel-value 'process-environment)) - (if (tramp-compat-string-search "=" elt) + (if (string-search "=" elt) (setq env (append env `(,elt))) (setq uenv (cons elt uenv))))) (setq env (setenv-internal env "INSIDE_EMACS" (tramp-inside-emacs) 'keep)) @@ -3289,9 +3298,8 @@ will be used." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) - ;; Handle signals. `process-file-return-signal-string' exists - ;; since Emacs 28.1. - (when (and (bound-and-true-p process-file-return-signal-string) + ;; Handle signals. + (when (and process-file-return-signal-string (natnump ret) (>= ret 128)) (setq ret (nth (- ret 128) (tramp-sh-get-signal-strings v))))))) @@ -3305,7 +3313,7 @@ will be used." (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (tramp-skeleton-file-local-copy filename - (if-let ((size (file-attribute-size (file-attributes filename)))) + (if-let* ((size (file-attribute-size (file-attributes filename)))) (let (rem-enc loc-dec) (condition-case err @@ -3619,14 +3627,14 @@ filled are described in `tramp-bundle-read-file-names'." ;; requires a remote command (the file cache must be invalidated). ;; Therefore, we apply a kind of optimization. We install the file ;; name handler `tramp-vc-file-name-handler', which does nothing but -;; remembers all file names for which `file-exists-p' or -;; `file-readable-p' has been applied. A first run of `vc-registered' -;; is performed. Afterwards, a script is applied for all collected -;; file names, using just one remote command. The result of this -;; script is used to fill the file cache with actual values. Now we -;; can reset the file name handlers, and we make a second run of -;; `vc-registered', which returns the expected result without sending -;; any other remote command. +;; remembers all file names for which `file-exists-p', +;; `file-readable-p' or `file-directory-p' has been applied. A first +;; run of `vc-registered' is performed. Afterwards, a script is +;; applied for all collected file names, using just one remote +;; command. The result of this script is used to fill the file cache +;; with actual values. Now we can reset the file name handlers, and +;; we make a second run of `vc-registered', which returns the expected +;; result without sending any other remote command. ;; When called during `revert-buffer', it shouldn't spam the echo area ;; and the *Messages* buffer. (defun tramp-sh-handle-vc-registered (file) @@ -3658,10 +3666,11 @@ filled are described in `tramp-bundle-read-file-names'." ;; Send just one command, in order to fill the cache. (tramp-bundle-read-file-names v tramp-vc-registered-file-names)) - ;; Second run. Now all `file-exists-p' or `file-readable-p' - ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' - ;; in order to keep the cache. + ;; Second run. Now all `file-exists-p', `file-readable-p' + ;; or `file-directory-p' calls shall be answered from the + ;; file cache. We unset `process-file-side-effects' and + ;; `remote-file-name-inhibit-cache' in order to keep the + ;; cache. (let ((vc-handled-backends (copy-sequence vc-handled-backends)) remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize @@ -3696,7 +3705,7 @@ filled are described in `tramp-bundle-read-file-names'." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-sh-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -3718,33 +3727,35 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-vc-file-name-handler (operation &rest args) "Invoke special file name handler, which collects files to be handled." (save-match-data - (let ((filename - (tramp-replace-environment-variables - (apply #'tramp-file-name-for-operation operation args))) - (fn (assoc operation tramp-sh-file-name-handler-alist))) - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (cond - ;; That's what we want: file names, for which checks are - ;; applied. We assume that VC uses only `file-exists-p' - ;; and `file-readable-p' checks; otherwise we must extend - ;; the list. We do not perform any action, but return - ;; nil, in order to keep `vc-registered' running. - ((and fn (memq operation '(file-exists-p file-readable-p))) - (add-to-list 'tramp-vc-registered-file-names localname 'append) - nil) - ;; `process-file' and `start-file-process' shall be ignored. - ((and fn (eq operation 'process-file) 0)) - ((and fn (eq operation 'start-file-process) nil)) - ;; Tramp file name handlers like `expand-file-name'. They - ;; must still work. - (fn (save-match-data (apply (cdr fn) args))) - ;; Default file name handlers, we don't care. - (t (tramp-run-real-handler operation args)))) - - ;; When `tramp-mode' is not enabled, or the file name is - ;; quoted, we don't do anything. - (tramp-run-real-handler operation args))))) + (if-let* ((filename + (tramp-replace-environment-variables + (apply #'tramp-file-name-for-operation operation args))) + ((tramp-tramp-file-p filename)) + (fn (assoc operation tramp-sh-file-name-handler-alist))) + (with-parsed-tramp-file-name filename nil + (cond + ;; That's what we want: file names, for which checks are + ;; applied. We assume that VC uses only `file-exists-p', + ;; `file-readable-p' and `file-directory-p' checks; + ;; otherwise we must extend the list. The respective cache + ;; value must be set for these functions in + ;; `tramp-bundle-read-file-names'. + ;; We do not perform any action, but return nil, in order + ;; to keep `vc-registered' running. + ((memq operation '(file-exists-p file-readable-p file-directory-p)) + (add-to-list 'tramp-vc-registered-file-names localname 'append) + nil) + ;; `process-file' and `start-file-process' shall be ignored. + ((eq operation 'process-file) 0) + ((eq operation 'start-file-process) nil) + ;; Tramp file name handlers like `expand-file-name'. They + ;; must still work. + (t (save-match-data (apply (cdr fn) args))))) + + ;; When `tramp-mode' is not enabled, or the file name is not a + ;; remote file name, we don't do anything. Same for default + ;; file name handlers. + (tramp-run-real-handler operation args)))) (defun tramp-sh-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -3773,7 +3784,7 @@ Fall back to normal file name handler if no Tramp handler exists." ;; Make events a list of symbols. events (mapcar - (lambda (x) (intern-soft (tramp-compat-string-replace "_" "-" x))) + (lambda (x) (intern-soft (string-replace "_" "-" x))) (split-string events "," 'omit)))) ;; "gio monitor". ((setq command (tramp-get-remote-gio-monitor v)) @@ -3831,12 +3842,9 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) ;; Fix action names. - string (tramp-compat-string-replace - "attributes changed" "attribute-changed" string) - string (tramp-compat-string-replace - "changes done" "changes-done-hint" string) - string (tramp-compat-string-replace - "renamed to" "moved" string)) + string (string-replace "attributes changed" "attribute-changed" string) + string (string-replace "changes done" "changes-done-hint" string) + string (string-replace "renamed to" "moved" string)) (catch 'doesnt-work ;; https://bugs.launchpad.net/bugs/1742946 @@ -3871,7 +3879,7 @@ Fall back to normal file name handler if no Tramp handler exists." (setq string (substring string pos))) ;; Delete empty lines. - (setq string (tramp-compat-string-replace "\n\n" "\n" string)) + (setq string (string-replace "\n\n" "\n" string)) (while (string-match (rx @@ -3924,9 +3932,7 @@ Fall back to normal file name handler if no Tramp handler exists." (list proc (mapcar - (lambda (x) - (intern-soft - (tramp-compat-string-replace "_" "-" (downcase x)))) + (lambda (x) (intern-soft (string-replace "_" "-" (downcase x)))) (split-string (match-string 1 line) "," 'omit)) (or (match-string 2 line) (file-name-nondirectory @@ -4050,8 +4056,8 @@ Only send the definition if it has not already been done." vec 5 (format-message "Sending script `%s'" name) ;; In bash, leading TABs like in `tramp-bundle-read-file-names' ;; could result in unwanted command expansion. Avoid this. - (setq script (tramp-compat-string-replace - (make-string 1 ?\t) (make-string 8 ? ) script)) + (setq script + (string-replace (make-string 1 ?\t) (make-string 8 ? ) script)) ;; Expand format specifiers. (unless (setq script (tramp-expand-script vec script)) (tramp-error @@ -4141,7 +4147,7 @@ variable PATH." (pipe-buf (tramp-get-remote-pipe-buf vec)) tmpfile chunk chunksize) (tramp-message vec 5 "Setting $PATH environment variable") - (if (tramp-compat-length< command pipe-buf) + (if (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 @@ -4313,7 +4319,7 @@ file exists and nonzero exit status otherwise." (defun tramp-find-shell (vec) "Open a shell on the remote host which groks tilde expansion." ;; If we are in `make-process', we don't need another shell. - (unless (tramp-get-connection-property vec "process-name") + (unless (tramp-get-connection-property vec " process-name") (with-current-buffer (tramp-get-buffer vec) (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) shell) @@ -4418,7 +4424,7 @@ process to set up. VEC specifies the connection." (let* ((old-uname (tramp-get-connection-property vec "uname")) (uname ;; If we are in `make-process', we don't need to recompute. - (if (and old-uname (tramp-get-connection-property vec "process-name")) + (if (and old-uname (tramp-get-connection-property vec " process-name")) old-uname (tramp-set-connection-property vec "uname" @@ -4432,7 +4438,7 @@ process to set up. VEC specifies the connection." (and config-check-function ;; If we are in `make-process', we don't need to recompute. (if (and old-config-check - (tramp-get-connection-property vec "process-name")) + (tramp-get-connection-property vec " process-name")) old-config-check (tramp-set-connection-property vec "config-check-data" @@ -4793,12 +4799,12 @@ means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process nil tramp-encoding-shell - (when (and input (not (tramp-compat-string-search "%s" cmd))) input) + (when (and input (not (string-search "%s" cmd))) input) (if (eq output t) t nil) nil tramp-encoding-command-switch (concat - (if (tramp-compat-string-search "%s" cmd) (format cmd input) cmd) + (if (string-search "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat " >" output) "")))) (defconst tramp-inline-compress-commands @@ -5100,7 +5106,7 @@ connection if a previous connection has died for some reason." (with-tramp-debug-message vec "Opening connection" (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name")) + (process-name (tramp-get-connection-property vec " process-name")) (process-environment (copy-sequence process-environment)) (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) @@ -5240,9 +5246,10 @@ connection if a previous connection has died for some reason." (setq r-shell t))) (setq current-host l-host) - ;; Set password prompt vector. + ;; Set hop and password prompt vector. + (tramp-set-connection-property p "hop-vector" hop) (tramp-set-connection-property - p "password-vector" + p "pw-vector" (if (tramp-get-method-parameter hop 'tramp-password-previous-hop) (let ((pv (copy-tramp-file-name previous-hop))) @@ -5253,9 +5260,9 @@ connection if a previous connection has died for some reason." :host l-host :port l-port))) ;; Set session timeout. - (when-let ((timeout - (tramp-get-method-parameter - hop 'tramp-session-timeout))) + (when-let* ((timeout + (tramp-get-method-parameter + hop 'tramp-session-timeout))) (tramp-set-connection-property p "session-timeout" timeout)) @@ -5298,6 +5305,8 @@ connection if a previous connection has died for some reason." tramp-actions-before-shell connection-timeout)) ;; Next hop. + (tramp-flush-connection-property p "hop-vector") + (tramp-flush-connection-property p "pw-vector") (setq options "" target-alist (cdr target-alist) previous-hop hop))) @@ -5903,37 +5912,37 @@ Nonexistent directories are removed from spec." (with-tramp-connection-property vec "awk" (tramp-message vec 5 "Finding a suitable `awk' command") (or (tramp-find-executable vec "awk" (tramp-get-remote-path vec)) - (let* ((busybox (tramp-get-remote-busybox vec)) - (command (format "%s %s" busybox "awk"))) - (and busybox - (tramp-send-command-and-check - vec (concat command " {} <" (tramp-get-remote-null-device vec))) - command))))) + (when-let* + ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "awk")) + ((tramp-send-command-and-check + vec (concat command " {} <" (tramp-get-remote-null-device vec))))) + command)))) (defun tramp-get-remote-hexdump (vec) "Determine remote `hexdump' command." (with-tramp-connection-property vec "hexdump" (tramp-message vec 5 "Finding a suitable `hexdump' command") (or (tramp-find-executable vec "hexdump" (tramp-get-remote-path vec)) - (let* ((busybox (tramp-get-remote-busybox vec)) - (command (format "%s %s" busybox "hexdump"))) - (and busybox - (tramp-send-command-and-check - vec (concat command " <" (tramp-get-remote-null-device vec))) - command))))) + (when-let* + ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "hexdump")) + ((tramp-send-command-and-check + vec (concat command " <" (tramp-get-remote-null-device vec))))) + command)))) (defun tramp-get-remote-od (vec) "Determine remote `od' command." (with-tramp-connection-property vec "od" (tramp-message vec 5 "Finding a suitable `od' command") (or (tramp-find-executable vec "od" (tramp-get-remote-path vec)) - (let* ((busybox (tramp-get-remote-busybox vec)) - (command (format "%s %s" busybox "od"))) - (and busybox - (tramp-send-command-and-check - vec - (concat command " -A n <" (tramp-get-remote-null-device vec))) - command))))) + (when-let* + ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "od")) + ((tramp-send-command-and-check + vec + (concat command " -A n <" (tramp-get-remote-null-device vec))))) + command)))) (defun tramp-get-remote-chmod-h (vec) "Check whether remote `chmod' supports nofollow argument." @@ -6003,13 +6012,12 @@ function cell is returned to be applied on a buffer." (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) (tramp-get-connection-property (tramp-get-process vec) prop))) - (prop1 (if (tramp-compat-string-search "encoding" prop) + (prop1 (if (string-search "encoding" prop) "inline-compress" "inline-decompress")) compress) ;; The connection property might have been cached. So we must ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) - (tramp-compat-string-search "remote" prop)) + (when (and coding (symbolp coding) (string-search "remote" prop)) (let ((name (symbol-name coding))) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) @@ -6021,7 +6029,7 @@ function cell is returned to be applied on a buffer." ;; Return the value. (cond ((and compress (symbolp coding)) - (if (tramp-compat-string-search "decompress" prop1) + (if (string-search "decompress" prop1) `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) @@ -6040,16 +6048,15 @@ function cell is returned to be applied on a buffer." (,coding (point-min) (point-max))))) ((symbolp coding) coding) - ((and compress (tramp-compat-string-search "decoding" prop)) + ((and compress (string-search "decoding" prop)) (format ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. (cond - ((and (tramp-compat-string-search "local" prop) - (eq system-type 'windows-nt)) - "(%s | \"%s\")") - ((tramp-compat-string-search "local" prop) "(%s | %s)") + ((and (string-search "local" prop) (eq system-type 'windows-nt)) + "(%s | \"%s\")") + ((string-search "local" prop) "(%s | %s)") (t "(%s | %s >%%s)")) coding compress)) (compress @@ -6057,14 +6064,13 @@ function cell is returned to be applied on a buffer." ;; Windows shells need the program file name after ;; the pipe symbol be quoted if they use forward ;; slashes as directory separators. - (if (and (tramp-compat-string-search "local" prop) - (eq system-type 'windows-nt)) + (if (and (string-search "local" prop) (eq system-type 'windows-nt)) "(%s <%%s | \"%s\")" "(%s <%%s | %s)") compress coding)) - ((tramp-compat-string-search "decoding" prop) + ((string-search "decoding" prop) (cond - ((tramp-compat-string-search "local" prop) (format "%s" coding)) + ((string-search "local" prop) (format "%s" coding)) (t (format "%s >%%s" coding)))) (t (format "%s <%%s" coding))))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index c6c3caabdcf..8d090a6969f 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -340,15 +340,15 @@ This can be used to disable echo etc." ;;;###tramp-autoload (defsubst tramp-smb-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for SMB servers." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-smb-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-smb-method))))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) "Invoke the SMB related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-smb-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -428,11 +428,7 @@ arguments to pass to the OPERATION." (t2 (tramp-tramp-file-p newname)) target) (with-parsed-tramp-file-name (if t1 dirname newname) nil - (unless (file-exists-p dirname) - (tramp-error v 'file-missing dirname)) - - ;; `copy-directory-create-symlink' exists since Emacs 28.1. - (if (and (bound-and-true-p copy-directory-create-symlink) + (if (and copy-directory-create-symlink (setq target (file-symlink-p dirname)) (tramp-equal-remote dirname newname)) (make-symbolic-link @@ -485,7 +481,7 @@ arguments to pass to the OPERATION." (let* ((share (tramp-smb-get-share v)) (localname (file-name-as-directory - (tramp-compat-string-replace + (string-replace "\\" "/" (tramp-smb-get-localname v)))) (tmpdir (tramp-compat-make-temp-name)) (args (list (concat "//" host "/" share) "-E")) @@ -530,13 +526,13 @@ arguments to pass to the OPERATION." (unwind-protect (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (with-temp-buffer ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) (when t1 ;; The smbclient tar command creates @@ -572,7 +568,7 @@ arguments to pass to the OPERATION." ;; Handle KEEP-DATE argument. (when keep-date - (tramp-compat-set-file-times + (set-file-times newname (file-attribute-modification-time (file-attributes dirname)) (unless ok-if-already-exists 'nofollow))) @@ -617,8 +613,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; `file-local-copy' returns a file name also for a local file ;; with `jka-compr-handler', so we cannot trust its result as ;; indication for a remote file name. - (if-let ((tmpfile - (and (tramp-tramp-file-p filename) (file-local-copy filename)))) + (if-let* ((tmpfile + (and (tramp-tramp-file-p filename) (file-local-copy filename)))) ;; Remote filename. (condition-case err (rename-file tmpfile newname ok-if-already-exists) @@ -656,7 +652,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; KEEP-DATE handling. (when keep-date - (tramp-compat-set-file-times + (set-file-times newname (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) @@ -716,7 +712,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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))) + (setq name (file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name)) @@ -769,7 +765,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (forward-line) (delete-region (point-min) (point))) (while (and (not (eobp)) (looking-at-p (rx bol (+ nonl) ":" (+ nonl)))) - (forward-line)) + (forward-line)) (delete-region (point) (point-max)) (throw 'tramp-action 'ok)))) @@ -780,7 +776,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-tramp-file-property v localname "file-acl" (when (tramp-smb-remote-acl-p v) (let* ((share (tramp-smb-get-share v)) - (localname (tramp-compat-string-replace + (localname (string-replace "\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E")) (options tramp-smb-options)) @@ -803,13 +799,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (concat "2>" (tramp-get-remote-null-device v))))) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (with-temp-buffer ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) ;; Use an asynchronous process. By this, password ;; can be handled. @@ -845,8 +841,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Check result. (when entry - (list (and (tramp-compat-string-search "d" (nth 1 entry)) - t) ;0 file type + (list (and (string-search "d" (nth 1 entry)) t) ;0 file type -1 ;1 link count (cons tramp-unknown-id-string tramp-unknown-id-integer) ;2 uid @@ -865,7 +860,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Implement `file-attributes' for Tramp files using `stat' command." (tramp-message vec 5 "file attributes with stat: %s" (tramp-file-name-localname vec)) - (let* (size id link uid gid atime mtime ctime mode inode) + (let (size id link uid gid atime mtime ctime mode inode) (when (tramp-smb-send-command vec (format "stat %s" (tramp-smb-shell-quote-localname vec))) @@ -981,7 +976,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (mapcar (lambda (x) (list - (if (tramp-compat-string-search "d" (nth 1 x)) + (if (string-search "d" (nth 1 x)) (file-name-as-directory (nth 0 x)) (nth 0 x)))) (tramp-smb-get-file-entries directory)))))))) @@ -1020,7 +1015,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) - (tramp-compat-string-search + (string-search "w" (or (file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) (and (file-exists-p dir) @@ -1083,14 +1078,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (sort entries (lambda (x y) - (if (tramp-compat-string-search "t" switches) + (if (string-search "t" switches) ;; Sort by date. (time-less-p (nth 3 y) (nth 3 x)) ;; Sort by name. (string-lessp (nth 0 x) (nth 0 y)))))) ;; Handle "-F" switch. - (when (tramp-compat-string-search "F" switches) + (when (string-search "F" switches) (mapc (lambda (x) (unless (string-empty-p (car x)) @@ -1121,7 +1116,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (expand-file-name (nth 0 x) (file-name-directory filename)) 'string))))) - (when (tramp-compat-string-search "l" switches) + (when (string-search "l" switches) (insert (format "%10s %3d %-8s %-8s %8s %s " @@ -1150,7 +1145,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (put-text-property start (point) 'dired-filename t)) ;; Insert symlink. - (when (and (tramp-compat-string-search "l" switches) + (when (and (string-search "l" switches) (stringp (file-attribute-type attr))) (insert " -> " (file-attribute-type attr)))) @@ -1252,11 +1247,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Call it. (condition-case nil (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) + (tramp-set-connection-property v " process-name" name1) (tramp-set-connection-property - v "process-buffer" + v " process-buffer" (or outbuf (generate-new-buffer tramp-temp-buffer-name))) (with-current-buffer (tramp-get-connection-buffer v) ;; Preserve buffer contents. @@ -1292,9 +1287,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - ;; FIXME: Does connection-property "process-buffer" still exist? + ;; FIXME: Does connection-property " process-buffer" still exist? (unless outbuf - (kill-buffer (tramp-get-connection-property v "process-buffer"))) + (kill-buffer (tramp-get-connection-property v " process-buffer"))) (when process-file-side-effects (tramp-flush-directory-properties v "/")) @@ -1369,11 +1364,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (stringp acl-string) (tramp-smb-remote-acl-p v)) (let* ((share (tramp-smb-get-share v)) - (localname (tramp-compat-string-replace - "\\" "/" (tramp-smb-get-localname v))) + (localname (string-replace "\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" - (tramp-compat-string-replace - "\n" "," acl-string))) + (string-replace "\n" "," acl-string))) (options tramp-smb-options)) (if (tramp-string-empty-or-nil-p user) @@ -1395,13 +1388,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "||" "echo" "tramp_exit_status" "1"))) (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (with-temp-buffer ;; Set the transfer process properties. (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) + v " process-name" (buffer-name (current-buffer))) (tramp-set-connection-property - v "process-buffer" (current-buffer)) + v " process-buffer" (current-buffer)) ;; Use an asynchronous process. By this, password ;; can be handled. @@ -1457,7 +1450,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." p) (unwind-protect (with-tramp-saved-connection-properties - v '("process-name" "process-buffer") + v '(" process-name" " process-buffer") (save-excursion (save-restriction (while (get-process name1) @@ -1465,8 +1458,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq i (1+ i) name1 (format "%s<%d>" name i))) ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name1) - (tramp-set-connection-property v "process-buffer" buffer) + (tramp-set-connection-property v " process-name" name1) + (tramp-set-connection-property v " process-buffer" buffer) ;; Activate narrowing in order to save BUFFER contents. (with-current-buffer (tramp-get-connection-buffer v) (let ((buffer-undo-list t)) @@ -1492,7 +1485,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Save exit. ;; FIXME: Does `tramp-get-connection-buffer' return the proper value? (with-current-buffer (tramp-get-connection-buffer v) - (if (tramp-compat-string-search tramp-temp-buffer-name (buffer-name)) + (if (string-search tramp-temp-buffer-name (buffer-name)) (progn (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) @@ -1765,12 +1758,10 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." mode (or (match-string 1 line) "") mode (format "%s%s" - (if (tramp-compat-string-search "D" mode) "d" "-") + (if (string-search "D" mode) "d" "-") (mapconcat (lambda (_x) "") " " - (format - "r%sx" - (if (tramp-compat-string-search "R" mode) "-" "w")))) + (format "r%sx" (if (string-search "R" mode) "-" "w")))) line (substring line 0 -6)) (cl-return)) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index c75796d3b36..43fb718bc82 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -44,7 +44,8 @@ "The sshfs mount command." :group 'tramp :version "28.1" - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Setup of sshfs method")) ;;;###tramp-autoload (defvar tramp-default-remote-shell) ;; Silence byte compiler. @@ -169,15 +170,15 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;;;###tramp-autoload (defsubst tramp-sshfs-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for sshfs." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-sshfs-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-sshfs-method))))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) "Invoke the sshfs handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-sshfs-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -254,10 +255,10 @@ arguments to pass to the OPERATION." (let ((coding-system-for-read 'utf-8-dos)) ; Is this correct? (setq command - (format - "cd %s && exec %s" - (tramp-unquote-shell-quote-argument localname) - (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) + (format + "cd %s && exec %s" + (tramp-unquote-shell-quote-argument localname) + (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) (when input (setq command (format "%s <%s" command input))) (when stderr (setq command (format "%s 2>%s" command stderr))) @@ -301,15 +302,13 @@ arguments to pass to the OPERATION." "Like `set-file-modes' for Tramp files." (unless (and (eq flag 'nofollow) (file-symlink-p filename)) (tramp-skeleton-set-file-modes-times-uid-gid filename - (tramp-compat-set-file-modes - (tramp-fuse-local-file-name filename) mode flag)))) + (set-file-modes (tramp-fuse-local-file-name filename) mode flag)))) (defun tramp-sshfs-handle-set-file-times (filename &optional timestamp flag) "Like `set-file-times' for Tramp files." (unless (and (eq flag 'nofollow) (file-symlink-p filename)) (tramp-skeleton-set-file-modes-times-uid-gid filename - (tramp-compat-set-file-times - (tramp-fuse-local-file-name filename) timestamp flag)))) + (set-file-times (tramp-fuse-local-file-name filename) timestamp flag)))) (defun tramp-sshfs-handle-write-region (start end filename &optional append visit lockname mustbenew) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index c82cd2dc0e1..bd10a0eb922 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -161,15 +161,15 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defsubst tramp-sudoedit-file-name-p (vec-or-filename) "Check if it's a VEC-OR-FILENAME for SUDOEDIT." - (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) - (string= (tramp-file-name-method vec) tramp-sudoedit-method))) + (and-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)) + ((string= (tramp-file-name-method vec) tramp-sudoedit-method))))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) "Invoke the SUDOEDIT handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (if-let* ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) (prog1 (save-match-data (apply (cdr fn) args)) (setq tramp-debug-message-fnh-function (cdr fn))) (prog1 (tramp-run-real-handler operation args) @@ -305,7 +305,7 @@ absolute file names." ;; Set the time and mode. Mask possible errors. (when keep-date (ignore-errors - (tramp-compat-set-file-times + (set-file-times newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes))) @@ -371,7 +371,7 @@ the result will be a local, non-Tramp, file 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))) + (setq name (file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name)) @@ -785,7 +785,7 @@ in case of error, t otherwise." ;; Avoid process status message in output buffer. (set-process-sentinel p #'ignore) (tramp-post-process-creation p vec) - (tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop) + (tramp-set-connection-property p "pw-vector" tramp-sudoedit-null-hop) (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) (prog1 diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8e98f805234..c23eed0bc1b 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -118,14 +118,15 @@ :group 'files :group 'comm :version "22.1" - :link '(custom-manual "(tramp)Top")) + :link '(info-link :tag "Tramp manual" "(tramp) Top")) ;; Maybe we need once a real Tramp mode, with key bindings etc. ;;;###autoload -(defcustom tramp-mode t +(defvar tramp-mode t "Whether Tramp is enabled. -If it is set to nil, all remote file names are used literally." - :type 'boolean) +If it is set to nil, all remote file names are used literally. Don't +set it manually, use `inhibit-remote-files' or `without-remote-files' +instead.") (defcustom tramp-backup-directory-alist nil "Alist of filename patterns and backup directory names. @@ -139,14 +140,16 @@ name prefix \(method, user, host) of file. gives the same backup policy for Tramp files on their hosts like the policy for local files." :type '(repeat (cons (regexp :tag "Regexp matching filename") - (directory :tag "Backup directory name")))) + (directory :tag "Backup directory name"))) + :link '(tramp-info-link :tag "Tramp manual" tramp-backup-directory-alist)) (defcustom tramp-auto-save-directory nil "Put auto-save files in this directory, if set. The idea is to use a local directory so that auto-saving is faster. This setting has precedence over `auto-save-file-name-transforms'." :type '(choice (const :tag "Use default" nil) - (directory :tag "Auto save directory name"))) + (directory :tag "Auto save directory name")) + :link '(tramp-info-link :tag "Tramp manual" tramp-auto-save-directory)) ;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-shell @@ -176,7 +179,8 @@ If the shell must be forced to be interactive, see Note that this variable is not used for remote commands. There are mechanisms in tramp.el which automatically determine the right shell to use for the remote host." - :type '(file :must-match t)) + :type '(file :must-match t) + :link '(info-link :tag "Tramp manual" "(tramp) Remote shell setup")) ;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-command-switch @@ -184,7 +188,8 @@ use for the remote host." (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c")) "Use this switch together with `tramp-encoding-shell' for local commands. See the variable `tramp-encoding-shell' for more information." - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Remote shell setup")) ;; Suppress `shell-file-name' for w32 systems. (defcustom tramp-encoding-command-interactive @@ -193,7 +198,8 @@ See the variable `tramp-encoding-shell' for more information." "Use this switch together with `tramp-encoding-shell' for interactive shells. See the variable `tramp-encoding-shell' for more information." :version "24.1" - :type '(choice (const nil) string)) + :type '(choice (const nil) string) + :link '(info-link :tag "Tramp manual" "(tramp) Remote shell setup")) ;; Since Emacs 26.1, `system-name' can return nil at build time if ;; Emacs is compiled with "--no-build-details". We do expect it to be @@ -429,7 +435,8 @@ Another host name is useful only in combination with "Default method to use for transferring files. See `tramp-methods' for possibilities. Also see `tramp-default-method-alist'." - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Default Method")) ;;;###tramp-autoload (defcustom tramp-default-method-alist nil @@ -448,7 +455,8 @@ empty string for the user name. See `tramp-methods' for a list of possibilities for METHOD." :type '(repeat (list (choice :tag "Host regexp" regexp sexp) (choice :tag "User regexp" regexp sexp) - (choice :tag "Method name" string (const nil))))) + (choice :tag "Method name" string (const nil)))) + :link '(info-link :tag "Tramp manual" "(tramp) Default Method")) (defconst tramp-default-method-marker "-" "Marker for default method in remote file names.") @@ -459,7 +467,8 @@ See `tramp-methods' for a list of possibilities for METHOD." "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'." - :type '(choice (const nil) string)) + :type '(choice (const nil) string) + :link '(info-link :tag "Tramp manual" "(tramp) Default User")) ;;;###tramp-autoload (defcustom tramp-default-user-alist nil @@ -476,12 +485,14 @@ If the file name does not specify the method, lookup is done using the empty string for the method name." :type '(repeat (list (choice :tag "Method regexp" regexp sexp) (choice :tag " Host regexp" regexp sexp) - (choice :tag " User name" string (const nil))))) + (choice :tag " User name" string (const nil)))) + :link '(info-link :tag "Tramp manual" "(tramp) Default User")) (defcustom tramp-default-host tramp-system-name "Default host to use for transferring files. Useful for su and sudo methods mostly." - :type 'string) + :type 'string + :link '(info-link :tag "Tramp manual" "(tramp) Default Host")) ;;;###tramp-autoload (defcustom tramp-default-host-alist nil @@ -499,7 +510,8 @@ empty string for the method name." :version "24.4" :type '(repeat (list (choice :tag "Method regexp" regexp sexp) (choice :tag " User regexp" regexp sexp) - (choice :tag " Host name" string (const nil))))) + (choice :tag " Host name" string (const nil)))) + :link '(info-link :tag "Tramp manual" "(tramp) Default Host")) (defcustom tramp-default-proxies-alist nil ;; FIXME: This is not an "alist", because its elements are not of @@ -525,17 +537,20 @@ evaluated. The result must be a string or nil, which is interpreted as a regular expression which always matches." :type '(repeat (list (choice :tag "Host regexp" regexp sexp) (choice :tag "User regexp" regexp sexp) - (choice :tag " Proxy name" string (const nil))))) + (choice :tag " Proxy name" string (const nil)))) + :link '(info-link :tag "Tramp manual" "(tramp) Multi-hops")) (defcustom tramp-save-ad-hoc-proxies nil "Whether to save ad-hoc proxies persistently." :version "24.3" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) Ad-hoc multi-hops")) (defcustom tramp-show-ad-hoc-proxies nil "Whether to show ad-hoc proxies in file names." :version "29.2" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) Ad-hoc multi-hops")) ;; For some obscure technical reasons, `system-name' on w32 returns ;; either lower case or upper case letters. See @@ -553,7 +568,8 @@ a restricted shell like \"rbash\". Those hosts can be used as proxies only, see `tramp-default-proxies-alist'. If the local host runs a restricted shell, it shall be added to this list, too." :version "27.1" - :type '(repeat (regexp :tag "Host regexp"))) + :type '(repeat (regexp :tag "Host regexp")) + :link '(info-link :tag "Tramp manual" "(tramp) Multi-hops")) ;;;###tramp-autoload (defcustom tramp-local-host-regexp @@ -571,7 +587,8 @@ host runs a restricted shell, it shall be added to this list, too." If the local host runs a chrooted environment, set this to nil." :version "30.1" :type '(choice (const :tag "Chrooted environment" nil) - (regexp :tag "Host regexp"))) + (regexp :tag "Host regexp")) + :link '(tramp-info-link :tag "Tramp manual" tramp-local-host-regexp)) (defvar tramp-completion-function-alist nil "Alist of methods for remote files. @@ -658,7 +675,8 @@ which should work well in many cases. This regexp must match both `tramp-initial-end-of-output' and `tramp-end-of-output'." - :type 'regexp) + :type 'regexp + :link '(tramp-info-link :tag "Tramp manual" tramp-shell-prompt-pattern)) (defcustom tramp-password-prompt-regexp (rx-to-string @@ -676,18 +694,23 @@ instead of altering this variable. The `sudo' program appears to insert a `^@' character into the prompt." :version "29.1" - :type 'regexp) + :type 'regexp + :link '(tramp-info-link :tag "Tramp manual" tramp-password-prompt-regexp)) (defcustom tramp-otp-password-prompt-regexp (rx-to-string `(: bol (* nonl) - ;; JumpCloud. - (group (| "Verification code")) + (group (| + ;; JumpCloud. + "Verification code" + ;; TACC HPC. <https://docs.tacc.utexas.edu/basics/mfa/> + "TACC Token Code")) (* nonl) (any . ,tramp-compat-password-colon-equivalents) (* blank))) "Regexp matching one-time password prompts. The regexp should match at end of buffer." - :version "29.2" - :type 'regexp) + :version "30.2" + :type 'regexp + :link '(tramp-info-link :tag "Tramp manual" tramp-otp-password-prompt-regexp)) (defcustom tramp-wrong-passwd-regexp (rx bol (* nonl) @@ -700,10 +723,50 @@ The regexp should match at end of buffer." "No supported authentication methods left to try!" (: "Login " (| "Incorrect" "incorrect")) (: "Connection " (| "refused" "closed")) - (: "Received signal " (+ digit))) + (: "Received signal " (+ digit)) + ;; Fingerprint. + "Verification timed out" + "Failed to match fingerprint" + "An unknown error occurred") (* nonl)) "Regexp matching a `login failed' message. The regexp should match at end of buffer." + :type 'regexp + :link '(tramp-info-link :tag "Tramp manual" tramp-wrong-passwd-regexp)) + +;; <https://gitlab.freedesktop.org/libfprint/fprintd/-/blob/master/pam/fingerprint-strings.h?ref_type=heads> +(defcustom tramp-fingerprint-prompt-regexp + (rx (| "Place your finger on" + "Swipe your finger across" + "Place your left thumb on" + "Swipe your left thumb across" + "Place your left index finger on" + "Swipe your left index finger across" + "Place your left middle finger on" + "Swipe your left middle finger across" + "Place your left ring finger on" + "Swipe your left ring finger across" + "Place your left little finger on" + "Swipe your left little finger across" + "Place your right thumb on" + "Swipe your right thumb across" + "Place your right index finger on" + "Swipe your right index finger across" + "Place your right middle finger on" + "Swipe your right middle finger across" + "Place your right ring finger on" + "Swipe your right ring finger across" + "Place your right little finger on" + "Swipe your right little finger across" + "Place your finger on the reader again" + "Swipe your finger again" + "Swipe was too short, try again" + "Your finger was not centred, try swiping your finger again" + "Remove your finger, and try swiping your finger again") + (* nonl) (* (any "\r\n"))) + "Regexp matching fingerprint prompts. +The regexp should match at end of buffer." + :version "30.2" :type 'regexp) (defcustom tramp-yesno-prompt-regexp @@ -733,7 +796,8 @@ Because Tramp wants to parse the output of the remote shell, it is easily confused by ANSI control escape sequences and suchlike. Often, shell init files conditionalize this setup based on the TERM environment variable." :group 'tramp - :type 'string) + :type 'string + :link '(tramp-info-link :tag "Tramp manual" tramp-terminal-type)) (defcustom tramp-terminal-prompt-regexp (rx (| (: "TERM = (" (* nonl) ")") @@ -828,11 +892,9 @@ filename part, though.") "Buffer name for a temporary buffer. It shall be used in combination with `generate-new-buffer-name'.") -(defvar tramp-temp-buffer-file-name nil +(defvar-local tramp-temp-buffer-file-name nil "File name of a persistent local temporary file. Useful for \"rsync\" like methods.") - -(make-variable-buffer-local 'tramp-temp-buffer-file-name) (put 'tramp-temp-buffer-file-name 'permanent-local t) (defcustom tramp-syntax 'default @@ -853,7 +915,8 @@ Customize. See also `tramp-change-syntax'." (const :tag "XEmacs" separate)) :require 'tramp :initialize #'custom-initialize-default - :set #'tramp-set-syntax) + :set #'tramp-set-syntax + :link '(info-link :tag "Tramp manual" "(tramp) Change file name syntax")) (defun tramp-set-syntax (symbol value) "Set SYMBOL to value VALUE. @@ -1184,7 +1247,10 @@ See also `tramp-file-name-regexp'.") ;;;###autoload (defconst tramp-initial-file-name-regexp - (rx bos "/" (+ (not (any "/:"))) ":" (* (not (any "/:"))) ":") + ;; We shouldn't use `rx' in autoloaded objects, because we don't + ;; know whether it does exist already. (Bug#74490) + ;; (rx bos "/" (+ (not (any "/:"))) ":" (* (not (any "/:"))) ":") + "\\`/[^/:]+:[^/:]*:" "Value for `tramp-file-name-regexp' for autoload. It must match the initial `tramp-syntax' settings.") @@ -1199,7 +1265,8 @@ initial value is overwritten by the car of `tramp-file-name-structure'.") (defcustom tramp-ignored-file-name-regexp nil "Regular expression matching file names that are not under Tramp's control." :version "27.1" - :type '(choice (const nil) regexp)) + :type '(choice (const nil) regexp) + :link '(tramp-info-link :tag "Tramp manual" tramp-ignored-file-name-regexp)) (defconst tramp-volume-letter-regexp (if (eq system-type 'windows-nt) @@ -1262,7 +1329,10 @@ Also see `tramp-file-name-structure'.") ;;;###autoload (defconst tramp-autoload-file-name-regexp ;; The method is either "-", or at least two characters. - (rx bos "/" (| "-" (>= 2 (not (any "/:|")))) ":") + ;; We shouldn't use `rx' in autoloaded objects, because we don't + ;; know whether it does exist already. (Bug#74490) + ;; (rx bos "/" (| "-" (>= 2 (not (any "/:|")))) ":") + "\\`/\\(?:-\\|[^/:|]\\{2,\\}\\):" "Regular expression matching file names handled by Tramp autoload. It must match the initial `tramp-syntax' settings. It should not match file names at root of the underlying local file system, @@ -1333,7 +1403,8 @@ in the third line of the code. Please raise a bug report via \\[tramp-bug] if your system needs this variable to be set as well." - :type '(choice (const nil) integer)) + :type '(choice (const nil) integer) + :link '(tramp-info-link :tag "Tramp manual" tramp-chunksize)) ;; Logging in to a remote host normally requires obtaining a pty. But ;; Emacs on macOS has `process-connection-type' set to nil by default, @@ -1343,7 +1414,8 @@ this variable to be set as well." "Overrides `process-connection-type' for connections from Tramp. Tramp binds `process-connection-type' to the value given here before opening a connection to a remote host." - :type '(choice (const nil) (const t) (const pipe) (const pty))) + :type '(choice (const nil) (const t) (const pipe) (const pty)) + :link '(tramp-info-link :tag "Tramp manual" tramp-process-connection-type)) (defcustom tramp-connection-timeout 60 "Defines the max time to wait for establishing a connection (in seconds). @@ -1407,7 +1479,8 @@ For a full discussion, see Info node `(tramp) Remote programs'." :type '(repeat (choice (const :tag "Default Directories" tramp-default-remote-path) (const :tag "Private Directories" tramp-own-remote-path) - (string :tag "Directory")))) + (string :tag "Directory"))) + :link '(info-link :tag "Tramp manual" "(tramp) Remote programs")) (defcustom tramp-remote-process-environment '("ENV=''" "TMOUT=0" "LC_CTYPE=''" @@ -1429,7 +1502,8 @@ The TERM environment variable should be set via `tramp-terminal-type'. The INSIDE_EMACS environment variable will automatically be set based on the Tramp and Emacs versions, and should not be set here." :version "26.1" - :type '(repeat string)) + :type '(repeat string) + :link '(info-link :tag "Tramp manual" "(tramp) Remote processes")) ;;; Internal Variables: @@ -1474,35 +1548,6 @@ calling HANDLER.") ;;; Internal functions which must come first: -(defun tramp-enable-method (method) - "Enable optional METHOD if possible." - (interactive - (list - (completing-read - "method: " - (tramp-compat-seq-keep - (lambda (x) - (when-let ((name (symbol-name x)) - ;; It must match `tramp-enable-METHOD-method'. - ((string-match - (rx "tramp-enable-" - (group (regexp tramp-method-regexp)) - "-method") - name)) - (method (match-string 1 name)) - ;; It must not be enabled yet. - ((not (assoc method tramp-methods)))) - method)) - ;; All method enabling functions. - (mapcar - #'intern (all-completions "tramp-enable-" obarray #'functionp)))))) - - (when-let (((not (assoc method tramp-methods))) - (fn (intern (format "tramp-enable-%s-method" method))) - ((functionp fn))) - (funcall fn) - (message "Tramp method \"%s\" enabled" method))) - ;; Conversion functions between external representation and ;; internal data structure. Convenience functions for internal ;; data structure. @@ -1521,13 +1566,15 @@ calling HANDLER.") (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop)) -(function-put #'tramp-file-name-method 'tramp-suppress-trace t) -(function-put #'tramp-file-name-user 'tramp-suppress-trace t) -(function-put #'tramp-file-name-domain 'tramp-suppress-trace t) -(function-put #'tramp-file-name-host 'tramp-suppress-trace t) -(function-put #'tramp-file-name-port 'tramp-suppress-trace t) -(function-put #'tramp-file-name-localname 'tramp-suppress-trace t) -(function-put #'tramp-file-name-hop 'tramp-suppress-trace t) +(tramp--with-startup + (function-put #'tramp-file-name-method 'tramp-suppress-trace t) + (function-put #'tramp-file-name-user 'tramp-suppress-trace t) + (function-put #'tramp-file-name-domain 'tramp-suppress-trace t) + (function-put #'tramp-file-name-host 'tramp-suppress-trace t) + (function-put #'tramp-file-name-port 'tramp-suppress-trace t) + (function-put #'tramp-file-name-localname 'tramp-suppress-trace t) + (function-put #'tramp-file-name-hop 'tramp-suppress-trace t) + (function-put #'make-tramp-file-name 'tramp-suppress-trace t)) ;;;###tramp-autoload (defconst tramp-null-hop @@ -1608,9 +1655,9 @@ entry does not exist, return DEFAULT." ;; We use the cached property. (tramp-get-connection-property vec hash-entry) ;; Use the static value from `tramp-methods'. - (if-let ((methods-entry - (assoc - param (assoc (tramp-file-name-method vec) tramp-methods)))) + (if-let* ((methods-entry + (assoc + param (assoc (tramp-file-name-method vec) tramp-methods)))) (cadr methods-entry) ;; Return the default value. default)))) @@ -1716,7 +1763,7 @@ This is HOST, if non-nil. Otherwise, do a lookup in `tramp-default-host-alist' and `tramp-default-host'." (declare (tramp-suppress-trace t)) (let ((result - (or (and (tramp-compat-length> host 0) host) + (or (and (length> host 0) host) (let ((choices tramp-default-host-alist) lhost item) (while choices @@ -1728,7 +1775,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 (tramp-compat-length> host 0) (null result)) + (if (or (length> host 0) (null result)) result (propertize result 'tramp-default t)))) @@ -1770,18 +1817,18 @@ default values are used." (unless nodefault (when hop (setq v (tramp-dissect-hop-name hop) - hop (and hop (tramp-make-tramp-hop-name v)))) + hop (tramp-make-tramp-hop-name v))) (let ((tramp-default-host - (or (and v (not (tramp-compat-string-search - "%h" (tramp-file-name-host v))) + (or (and v (not (string-search "%h" (tramp-file-name-host v))) (tramp-file-name-host v)) tramp-default-host))) (setq method (tramp-find-method method user host) user (tramp-find-user method user host) - host (tramp-find-host method user host) - hop - (and hop - (format-spec hop (format-spec-make ?h host ?u user)))))) + host (tramp-find-host method user host)) + (when hop + ;; Replace placeholders. + (setq + hop (tramp-format-spec hop (format-spec-make ?h host ?u user)))))) ;; Return result. (prog1 @@ -1879,7 +1926,8 @@ expected to be a string, which will be used." ;; Assure that the hops are in `tramp-default-proxies-alist'. ;; In tramp-archive.el, the slot `hop' is used for the archive ;; file name. - (unless (string-equal method tramp-archive-method) + (unless (or minibuffer-completing-file-name + (string-equal method tramp-archive-method)) (tramp-add-hops (car args))))) (t (setq method (nth 0 args) @@ -1948,11 +1996,11 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." (or (get-buffer (tramp-buffer-name vec)) (unless dont-create (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) - ;; We use the existence of connection property "process-buffer" + ;; We use the existence of connection property " process-buffer" ;; as indication, whether a connection is active. (tramp-set-connection-property - vec "process-buffer" - (tramp-get-connection-property vec "process-buffer")) + vec " process-buffer" + (tramp-get-connection-property vec " process-buffer")) (setq buffer-undo-list t default-directory (tramp-make-tramp-file-name vec 'noloc)) @@ -1964,14 +2012,14 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." Unless DONT-CREATE, the buffer is created when it doesn't exist yet. In case a second asynchronous communication has been started, it is different from `tramp-get-buffer'." - (or (tramp-get-connection-property vec "process-buffer") + (or (tramp-get-connection-property vec " process-buffer") (tramp-get-buffer vec dont-create))) (defun tramp-get-connection-name (vec) "Get the connection name to be used for VEC. In case a second asynchronous communication has been started, it is different from the default one." - (or (tramp-get-connection-property vec "process-name") + (or (tramp-get-connection-property vec " process-name") (tramp-buffer-name vec))) (defun tramp-get-unique-process-name (name) @@ -2100,7 +2148,7 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) (message (aref parameters 3))) - (when (tramp-compat-string-search message (or (current-message) "")) + (when (string-search message (or (current-message) "")) (progress-reporter-update reporter value suffix)))) ;;;###tramp-autoload @@ -2121,9 +2169,9 @@ without a visible progress reporter." ;; We start a pulsing progress reporter after 3 seconds. ;; Start only when there is no other progress reporter ;; running, and when there is a minimum level. - (when-let ((pr (and (null tramp-inhibit-progress-reporter) - (<= ,level (min tramp-verbose 3)) - (make-progress-reporter ,message)))) + (when-let* ((pr (and (null tramp-inhibit-progress-reporter) + (<= ,level (min tramp-verbose 3)) + (make-progress-reporter ,message)))) (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. @@ -2145,8 +2193,8 @@ without a visible progress reporter." (let ((seconds (car list)) (timeout-forms (cdr list))) ;; If non-nil, `seconds' must be a positive number. - `(if-let (((natnump ,seconds)) - ((not (zerop timeout)))) + `(if-let* (((natnump ,seconds)) + ((not (zerop timeout)))) (with-timeout (,seconds ,@timeout-forms) ,@body) ,@body))) @@ -2180,6 +2228,14 @@ letter into the file name. This function removes it." (rx (regexp tramp-volume-letter-regexp) "/") "/" result)) (if quoted (file-name-quote result 'top) result)))) +(defun tramp-format-spec (format specification) + "Implement `format-spec' in Tramp. +FORMAT could contain \"%\" which is not intended as format character, +for example in USER%DOMAIN or POD%NAMESPACE." + (format-spec + (replace-regexp-in-string (rx "%" (group (= 2 alnum))) "%%\\1" format) + specification)) + ;;; Config Manipulation Functions: (defconst tramp-dns-sd-service-regexp @@ -2269,7 +2325,7 @@ If optional FLAG is `nofollow', do not follow FILENAME if it is a symbolic link. If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." - (or (tramp-compat-file-modes filename flag) + (or (file-modes filename flag) (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) @@ -2330,26 +2386,22 @@ Must be handled by the callers." ((member operation '(access-file byte-compiler-base-file-name delete-directory delete-file diff-latest-backup-file directory-file-name - directory-files directory-files-and-attributes - dired-compress-file dired-uncache file-acl - file-accessible-directory-p file-attributes - file-directory-p file-executable-p file-exists-p - file-local-copy file-modes file-name-as-directory + directory-files directory-files-and-attributes dired-compress-file + dired-uncache file-acl file-accessible-directory-p file-attributes + file-directory-p file-executable-p file-exists-p file-local-copy + file-locked-p file-modes file-name-as-directory file-name-case-insensitive-p file-name-directory 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-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 + file-notify-add-watch file-ownership-preserved-p file-readable-p + file-regular-p file-remote-p 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 lock-file make-directory + make-lock-file-name set-file-acl set-file-modes + set-file-selinux-context set-file-times substitute-in-file-name + unhandled-file-name-directory unlock-file vc-registered ;; Emacs 28- only. make-directory-internal - ;; Emacs 28+ only. - file-locked-p lock-file make-lock-file-name unlock-file ;; Emacs 29+ only. abbreviate-file-name ;; Tramp internal magic file name function. @@ -2472,7 +2524,14 @@ Fall back to normal file name handler if no Tramp file name handler exists." (autoload-do-load sf foreign))) (with-tramp-debug-message v (format "Running `%S'" (cons operation args)) - ;; If `non-essential' is non-nil, Tramp shall + ;; We flush connection properties + ;; " process-name" and " process-buffer", + ;; because the operations shall be applied + ;; in the main connection process. In order + ;; to avoid superfluous debug buffers during + ;; host name completion, we adapt + ;; `tramp-verbose'. + ;; If `non-essential' is non-nil, Tramp shall ;; not open a new connection. ;; If Tramp detects that it shouldn't continue ;; to work, it throws the `suppress' event. @@ -2480,10 +2539,17 @@ Fall back to normal file name handler if no Tramp file name handler exists." ;; tries to open the same connection twice in ;; a short time frame. ;; In both cases, we try the default handler then. - (setq result - (catch 'non-essential - (catch 'suppress - (apply foreign operation args))))) + (with-tramp-saved-connection-properties + v '(" process-name" " process-buffer") + (let ((tramp-verbose + (if minibuffer-completing-file-name + 0 tramp-verbose))) + (tramp-flush-connection-property v " process-name") + (tramp-flush-connection-property v " process-buffer")) + (setq result + (catch 'non-essential + (catch 'suppress + (apply foreign operation args)))))) (cond ((eq result 'non-essential) (tramp-message @@ -2521,7 +2587,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." - (if-let + (if-let* ((fn (and tramp-mode minibuffer-completing-file-name (assoc operation tramp-completion-file-name-handler-alist)))) (save-match-data (apply (cdr fn) args)) @@ -2617,7 +2683,7 @@ remote file names." ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) - (when-let ((entry (rassoc fnh file-name-handler-alist))) + (when-let* ((entry (rassoc fnh file-name-handler-alist))) (setq file-name-handler-alist (cons entry (delete entry file-name-handler-alist)))))) @@ -2694,14 +2760,29 @@ Run BODY." ;;; File name handler functions for completion mode: -;; This function takes action since Emacs 28.1, when -;; `read-extended-command-predicate' is set to -;; `command-completion-default-include-p'. +;; This function takes action, when `read-extended-command-predicate' +;; is set to `command-completion-default-include-p'. (defun tramp-command-completion-p (_symbol buffer) "A predicate for Tramp interactive commands. They are completed by `M-x TAB' only if the current buffer is remote." (tramp-tramp-file-p (tramp-get-default-directory buffer))) +;; This function takes action, when `read-extended-command-predicate' +;; is set to `command-completion-default-include-p'. +;;;###tramp-autoload +(defun tramp-active-command-completion-p (_symbol _buffer) + "A predicate for Tramp interactive commands. +They are completed by `M-x TAB' only if there's an active connection or buffer." + ;; (declare (tramp-suppress-trace t)) + (or (and (hash-table-p tramp-cache-data) + (not (zerop (hash-table-count tramp-cache-data)))) + (tramp-list-remote-buffers))) + +;; We cannot use the `declare' form for `tramp-suppress-trace' in +;; autoloaded functions, because the tramp-loaddefs.el generation +;; would fail. +(function-put #'tramp-active-command-completion-p 'tramp-suppress-trace t) + (defun tramp-connectable-p (vec-or-filename) "Check if it is possible to connect the remote host without side-effects. This is true, if either the remote host is already connected, or if we are @@ -3106,7 +3187,7 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (defun tramp-completion-handle-file-name-nondirectory (filename) "Like `file-name-nondirectory' for partial Tramp files." - (tramp-compat-string-replace (file-name-directory filename) "" filename)) + (string-replace (file-name-directory filename) "" filename)) (defun tramp-parse-default-user-host (method) "Return a list of (user host) tuples allowed to access for METHOD. @@ -3118,14 +3199,16 @@ for all methods. Resulting data are derived from default settings." (defcustom tramp-completion-multi-hop-methods nil "Methods for which to provide completions over multi-hop connections." :version "30.1" - :type '(repeat (string :tag "Method name"))) + :type '(repeat (string :tag "Method name")) + :link '(info-link :tag "Tramp manual" "(tramp) Ad-hoc multi-hops")) (defcustom tramp-completion-use-auth-sources auth-source-do-cache "Whether to use `auth-source-search' for completion of user and host names. This could be disturbing, if it requires a password / passphrase, as for \"~/.authinfo.gpg\"." :version "27.1" - :type 'boolean) + :type 'boolean + :link '(info-link :tag "Tramp manual" "(tramp) File name completion")) (defun tramp-parse-auth-sources (method) "Return a list of (user host) tuples allowed to access for METHOD. @@ -3354,7 +3437,7 @@ BODY is the backend specific code." (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))) + (if (not (or ,recursive (directory-empty-p ,directory))) (tramp-error v 'file-error "Directory is not empty, not moving to trash") (move-file-to-trash ,directory)) @@ -3462,7 +3545,8 @@ systems using NFS4_ACL, the permission string as returned from `stat' or `ls', is not sufficient to provide more fine-grained information. This variable is intended as connection-local variable." :version "30.1" - :type 'boolean) + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" tramp-use-file-attributes)) (defsubst tramp-use-file-attributes (vec) "Whether to use \"file-attributes\" file property for check." @@ -3737,7 +3821,9 @@ BODY is the backend specific code." (defcustom tramp-inhibit-errors-if-setting-file-attributes-fail nil "Whether to warn only if `tramp-*-set-file-{modes,times,uid-gid}' fails." :version "30.1" - :type 'boolean) + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" + tramp-inhibit-errors-if-setting-file-attributes-fail)) (defmacro tramp-skeleton-set-file-modes-times-uid-gid (filename &rest body) @@ -3818,8 +3904,7 @@ BODY is the backend specific code." (tramp-tramp-file-p lockname) (not file-locked)) (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) + (lock-file lockname)) ;; The body. ,@body @@ -3834,7 +3919,7 @@ BODY is the backend specific code." (let (last-coding-system-used (need-chown t)) ;; Set file modification time. (when (or (eq ,visit t) (stringp ,visit)) - (when-let ((file-attr (file-attributes filename 'integer))) + (when-let* ((file-attr (file-attributes filename 'integer))) (set-visited-file-modtime ;; We must pass modtime explicitly, because FILENAME ;; can be different from (buffer-file-name), f.e. if @@ -3857,8 +3942,7 @@ BODY is the backend specific code." ;; Unlock file. (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) + (unlock-file lockname)) ;; Sanity check. (unless (equal curbuf (current-buffer)) @@ -3948,9 +4032,9 @@ Let-bind it when necessary.") (tramp-dont-suspend-timers t)) (with-tramp-timeout (timeout - (unless (when-let ((p (tramp-get-connection-process v))) - (and (process-live-p p) - (tramp-get-connection-property p "connected"))) + (unless (and-let* ((p (tramp-get-connection-process v)) + ((process-live-p p)) + ((tramp-get-connection-property p "connected")))) (tramp-cleanup-connection v 'keep-debug 'keep-password)) (tramp-error v 'file-error @@ -4011,7 +4095,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 (tramp-compat-length> localname 0) + (and (length> localname 0) (eq (aref localname (1- (length localname))) ?/) (not (string= localname "/")))) (setq directory (substring directory 0 -1))) @@ -4029,7 +4113,7 @@ Let-bind it when necessary.") (lambda (x) (cons x (file-attributes (if full x (expand-file-name x directory)) id-format))) - (tramp-compat-directory-files directory full match nosort count))) + (directory-files directory full match nosort count))) (defun tramp-handle-dired-uncache (dir) "Like `dired-uncache' for Tramp files." @@ -4046,7 +4130,7 @@ Let-bind it when necessary.") (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))) + (setq name (file-name-concat dir name))) ;; If NAME is not a Tramp file, run the real handler. (if (not (tramp-tramp-file-p name)) (tramp-run-real-handler #'expand-file-name (list name)) @@ -4129,8 +4213,8 @@ Let-bind it when necessary.") (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." - (when-let ((attrs (file-attributes filename)) - (mode-string (file-attribute-modes attrs))) + (when-let* ((attrs (file-attributes filename)) + (mode-string (file-attribute-modes attrs))) (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) (file-modes (file-truename filename)) (tramp-mode-string-to-int mode-string)))) @@ -4142,7 +4226,7 @@ Let-bind it when necessary.") ;; the empty string. Suppress adding a hop to ;; `tramp-default-proxies-alist' due to non-expanded default values. (let ((v (tramp-dissect-file-name file t)) - tramp-default-proxies-alist) + (tramp-default-proxies-alist tramp-cache-undefined)) ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name @@ -4212,8 +4296,7 @@ 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) - (tramp-compat-length= (delete "./" (delete "../" fnac)) 1)) + (when (and (consp fnac) (length= (delete "./" (delete "../" fnac)) 1)) (setq fnac (delete "./" (delete "../" fnac)))) (or (try-completion @@ -4237,7 +4320,7 @@ Let-bind it when necessary.") ;; the remote file name parts. Suppress adding a hop to ;; `tramp-default-proxies-alist' due to non-expanded default values. (let ((v (tramp-dissect-file-name file t)) - tramp-default-proxies-alist) + (tramp-default-proxies-alist tramp-cache-undefined)) ;; Run the command on the localname portion only. If this returns ;; nil, mark also the localname part of `v' as nil. (tramp-make-tramp-file-name @@ -4270,10 +4353,10 @@ Let-bind it when necessary.") (or (tramp-check-cached-permissions v ?r) ;; `tramp-check-cached-permissions' doesn't handle symbolic ;; links. - (when-let ((symlink (file-symlink-p filename))) - (and (stringp symlink) - (file-readable-p - (concat (file-remote-p filename) symlink)))))))) + (and-let* ((symlink (file-symlink-p filename)) + ((stringp symlink)) + ((file-readable-p + (concat (file-remote-p filename) symlink))))))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." @@ -4283,7 +4366,7 @@ Let-bind it when necessary.") ;; because `file-truename' could raise an error for cyclic ;; symlinks. (ignore-errors - (when-let ((attr (file-attributes filename))) + (when-let* ((attr (file-attributes filename))) (cond ((eq ?- (aref (file-attribute-modes attr) 0))) ((eq ?l (aref (file-attribute-modes attr) 0)) @@ -4375,7 +4458,9 @@ existing) are returned." (defcustom tramp-allow-unsafe-temporary-files nil "Whether root-owned auto-save, backup or lock files can be written to \"/tmp\"." :version "28.1" - :type 'boolean) + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" + tramp-allow-unsafe-temporary-files)) (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." @@ -4446,7 +4531,7 @@ existing) are returned." (list filename switches wildcard full-directory-p)) ;; `ls-lisp' always returns full listings. We must remove ;; superfluous parts. - (unless (tramp-compat-string-search "l" switches) + (unless (string-search "l" switches) (save-excursion (goto-char (point-min)) (while (setq start @@ -4670,7 +4755,7 @@ 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." - (with-tramp-file-property vec "/" "process-attributes" + (with-tramp-connection-property vec " process-attributes" (ignore-errors (with-temp-buffer (hack-connection-local-variables-apply @@ -4717,13 +4802,13 @@ It is not guaranteed, that all process attributes as described in (defun tramp-handle-list-system-processes () "Like `list-system-processes' for Tramp files." (let ((v (tramp-dissect-file-name default-directory))) - (tramp-flush-file-property v "/" "process-attributes") + (tramp-flush-connection-property v " process-attributes") (mapcar (lambda (x) (cdr (assq 'pid x))) (tramp-get-process-attributes v)))) (defun tramp-get-lock-file (file) "Read lockfile info of FILE. Return nil when there is no lockfile." - (when-let ((lockname (tramp-compat-make-lock-file-name file))) + (when-let* ((lockname (make-lock-file-name file))) (or (file-symlink-p lockname) (and (file-readable-p lockname) (with-temp-buffer @@ -4754,8 +4839,8 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defun tramp-handle-file-locked-p (file) "Like `file-locked-p' for Tramp files." - (when-let ((info (tramp-get-lock-file file)) - (match (string-match tramp-lock-file-info-regexp info))) + (when-let* ((info (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-info-regexp info))) (or ; Locked by me. (and (string-equal (match-string 1 info) (user-login-name)) (string-equal (match-string 2 info) tramp-system-name) @@ -4777,20 +4862,20 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ;; for remote files. (ask-user-about-supersession-threat file)) - (when-let ((info (tramp-get-lock-file file)) - (match (string-match tramp-lock-file-info-regexp info))) + (when-let* ((info (tramp-get-lock-file file)) + (match (string-match tramp-lock-file-info-regexp info))) (unless (ask-user-about-lock file (format "%s@%s (pid %s)" (match-string 1 info) (match-string 2 info) (match-string 3 info))) (throw 'dont-lock nil))) - (when-let ((lockname (tramp-compat-make-lock-file-name file)) - ;; USER@HOST.PID[:BOOT_TIME] - (info - (format - "%s@%s.%s" (user-login-name) tramp-system-name - (tramp-get-lock-pid file)))) + (when-let* ((lockname (make-lock-file-name file)) + ;; USER@HOST.PID[:BOOT_TIME] + (info + (format + "%s@%s.%s" (user-login-name) tramp-system-name + (tramp-get-lock-pid file)))) ;; Protect against security hole. (with-parsed-tramp-file-name file nil @@ -4821,8 +4906,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defun tramp-handle-make-lock-file-name (file) "Like `make-lock-file-name' for Tramp files." (and create-lockfiles - ;; This variable has been introduced with Emacs 28.1. - (not (bound-and-true-p remote-file-name-inhibit-locks)) + (not remote-file-name-inhibit-locks) (tramp-run-real-handler 'make-lock-file-name (list file)))) (defun tramp-handle-unlock-file (file) @@ -4831,21 +4915,19 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") ;; When there is no connection, we don't do it. Otherwise, ;; functions like `kill-buffer' would try to reestablish the ;; connection. See Bug#61663. - (if-let ((v (tramp-dissect-file-name file)) - ((process-live-p (tramp-get-process v))) - (lockname (tramp-compat-make-lock-file-name file))) + (if-let* ((v (tramp-dissect-file-name file)) + ((process-live-p (tramp-get-process v))) + (lockname (make-lock-file-name file))) (delete-file lockname) ;; Trigger the unlock error. Be quiet if user isn't ;; interested in lock files. See Bug#70900. (unless (or (not create-lockfiles) (bound-and-true-p remote-file-name-inhibit-locks)) (signal 'file-error `("Cannot remove lock file for" ,file)))) - ;; `userlock--handle-unlock-error' exists since Emacs 28.1. It - ;; checks for `create-lockfiles' since Emacs 30.1, we don't need - ;; this check here, then. - (error (unless (or (not create-lockfiles) - (bound-and-true-p remote-file-name-inhibit-locks)) - (tramp-compat-funcall 'userlock--handle-unlock-error err))))) + ;; `userlock--handle-unlock-error' checks for `create-lockfiles' + ;; since Emacs 30.1, we don't need this check here, then. + (error (unless (or (not create-lockfiles) remote-file-name-inhibit-locks) + (userlock--handle-unlock-error err))))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." @@ -4879,21 +4961,37 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (defun tramp-add-hops (vec) "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'." - (when-let ((hops (tramp-file-name-hop vec)) - (item vec)) + ;; `tramp-default-proxies-alist' is bound to `tramp-cache-undefined' + ;; in `tramp-handle-file-name-as-directory' and + ;; `tramp-handle-file-name-directory' suppressing to add a hop. + (when-let* (((not (eq tramp-default-proxies-alist tramp-cache-undefined))) + (hops (tramp-file-name-hop vec)) + (item vec)) (let (signal-hook-function changed) (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) (let* ((host-port (tramp-file-name-host-port item)) + (host-port (and (stringp host-port) + (rx bol (literal host-port) eol))) (user-domain (tramp-file-name-user-domain item)) + (user-domain (and (stringp user-domain) + (rx bol (literal user-domain) eol))) (proxy (concat tramp-prefix-format proxy tramp-postfix-host-format)) (entry - (list (and (stringp host-port) - (rx bol (literal host-port) eol)) - (and (stringp user-domain) - (rx bol (literal user-domain) eol)) - (propertize proxy 'tramp-ad-hoc t)))) + (list host-port user-domain (propertize proxy 'tramp-ad-hoc t)))) + ;; Remove superfluous entries. + (when tramp-show-ad-hoc-proxies + (dolist (entry1 tramp-default-proxies-alist) + (when (and (equal host-port (car entry1)) + (equal user-domain (cadr entry1)) + (not (equal proxy (caddr entry1)))) + (tramp-message + vec 5 "Remove %S from `tramp-default-proxies-alist'" entry1) + (tramp-cleanup-connection + vec 'keep-debug 'keep-password 'keep-processes) + (setq tramp-default-proxies-alist + (delete entry1 tramp-default-proxies-alist))))) ;; Add the hop. (unless (member entry tramp-default-proxies-alist) (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) @@ -4912,69 +5010,74 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (item vec) choices proxy) - ;; Ad-hoc proxy definitions. - (tramp-add-hops vec) - - ;; Look for proxy hosts to be passed. - (setq choices tramp-default-proxies-alist) - (while choices - (setq item (pop choices) - proxy (eval (nth 2 item) t)) - (when (and - ;; Host. - (string-match-p - (or (eval (nth 0 item) t) "") - (or (tramp-file-name-host-port (car target-alist)) "")) - ;; User. - (string-match-p - (or (eval (nth 1 item) t) "") - (or (tramp-file-name-user-domain (car target-alist)) ""))) - (if (null proxy) - ;; No more hops needed. - (setq choices nil) - ;; Replace placeholders. - (setq proxy - (format-spec - proxy - (format-spec-make - ?u (or (tramp-file-name-user (car target-alist)) "") - ?h (or (tramp-file-name-host (car target-alist)) "")))) - (with-parsed-tramp-file-name proxy l - ;; Add the hop. - (push l target-alist) - ;; Start next search. - (setq choices tramp-default-proxies-alist))))) - - ;; Foreign and out-of-band methods are not supported for multi-hops. - (when (cdr target-alist) - (setq choices target-alist) - (while (setq item (pop choices)) - (unless (tramp-multi-hop-p item) - (setq tramp-default-proxies-alist saved-tdpa) - (tramp-user-error - vec "Method `%s' is not supported for multi-hops" - (tramp-file-name-method item))))) - - ;; Some methods ("su", "sg", "sudo", "doas", "run0", "ksu") do not - ;; use the host name in their command template. In this case, the - ;; remote file name must use either a local host name (first hop), - ;; or a host name matching the previous hop. - (let ((previous-host (or tramp-local-host-regexp ""))) - (setq choices target-alist) - (while (setq item (pop choices)) - (let ((host (tramp-file-name-host item))) - (unless - (or - ;; The host name is used for the remote shell command. - (member - "%h" (flatten-tree - (tramp-get-method-parameter item 'tramp-login-args))) - ;; The host name must match previous hop. - (string-match-p previous-host host)) + ;; `tramp-compute-multi-hops' could be called also for other file + ;; name handlers, for example in `tramp-clear-passwd'. + (when (tramp-sh-file-name-handler-p vec) + + ;; Ad-hoc proxy definitions. + (tramp-add-hops vec) + + ;; Look for proxy hosts to be passed. + (setq choices tramp-default-proxies-alist) + (while choices + (setq item (pop choices) + proxy (eval (nth 2 item) t)) + (when (and + ;; Host. + (string-match-p + (or (eval (nth 0 item) t) "") + (or (tramp-file-name-host-port (car target-alist)) "")) + ;; User. + (string-match-p + (or (eval (nth 1 item) t) "") + (or (tramp-file-name-user-domain (car target-alist)) ""))) + (if (null proxy) + ;; No more hops needed. + (setq choices nil) + ;; Replace placeholders. + (setq proxy + (tramp-format-spec + proxy + (format-spec-make + ?u (or (tramp-file-name-user (car target-alist)) "") + ?h (or (tramp-file-name-host (car target-alist)) "")))) + (with-parsed-tramp-file-name proxy l + ;; Add the hop. + (push l target-alist) + ;; Start next search. + (setq choices tramp-default-proxies-alist))))) + + ;; Foreign and out-of-band methods are not supported for + ;; multi-hops. + (when (cdr target-alist) + (setq choices target-alist) + (while (setq item (pop choices)) + (unless (tramp-multi-hop-p item) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error - vec "Host name `%s' does not match `%s'" host previous-host)) - (setq previous-host (rx bol (literal host) eol))))) + vec "Method `%s' is not supported for multi-hops" + (tramp-file-name-method item))))) + + ;; Some methods ("su", "sg", "sudo", "doas", "run0", "ksu") do + ;; not use the host name in their command template. In this + ;; case, the remote file name must use either a local host name + ;; (first hop), or a host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + "%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 (rx bol (literal host) eol)))))) ;; Result. target-alist)) @@ -5008,7 +5111,7 @@ a connection-local variable." (flatten-tree (mapcar (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (setq x (mapcar (lambda (y) (tramp-format-spec y spec)) x)) (unless (member "" x) x)) args)))) @@ -5076,25 +5179,25 @@ should be set connection-local.") (adb-file-name-handler-p (tramp-adb-file-name-p v)) (env (mapcar (lambda (elt) - (when (tramp-compat-string-search "=" elt) elt)) + (when (string-search "=" elt) elt)) tramp-remote-process-environment)) ;; We use as environment the difference to toplevel ;; `process-environment'. (env (dolist (elt process-environment env) (when (and - (tramp-compat-string-search "=" elt) + (string-search "=" elt) (not (member elt (default-toplevel-value 'process-environment)))) (setq env (cons elt env))))) ;; Add remote path if exists. - (env (if-let ((sh-file-name-handler-p) - (remote-path - (string-join (tramp-get-remote-path v) ":"))) + (env (if-let* ((sh-file-name-handler-p) + (remote-path + (string-join (tramp-get-remote-path v) ":"))) (setenv-internal env "PATH" remote-path 'keep) env)) ;; Add HISTFILE if indicated. - (env (if-let ((sh-file-name-handler-p)) + (env (if sh-file-name-handler-p (cond ((stringp tramp-histfile-override) (setenv-internal @@ -5149,8 +5252,7 @@ should be set connection-local.") ;; Command could be too long, for example due to a longish PATH. (when (and sh-file-name-handler-p - (tramp-compat-length> - (string-join command) (tramp-get-remote-pipe-buf v))) + (length> (string-join command) (tramp-get-remote-pipe-buf v))) (signal 'error (cons "Command too long:" command))) (setq @@ -5304,12 +5406,9 @@ support symbolic links." (setq current-buffer-p t) (current-buffer)) (t (get-buffer-create - ;; These variables have been introduced with Emacs 28.1. (if asynchronous - (or (bound-and-true-p shell-command-buffer-name-async) - "*Async Shell Command*") - (or (bound-and-true-p shell-command-buffer-name) - "*Shell Command Output*")))))) + (or shell-command-buffer-name-async "*Async Shell Command*") + (or shell-command-buffer-name "*Shell Command Output*")))))) (error-buffer (cond ((bufferp error-buffer) error-buffer) @@ -5643,7 +5742,11 @@ of." ;; Sometimes, the process returns a new password request ;; immediately after rejecting the previous (wrong) one. (unless (or tramp-password-prompt-not-unique - (tramp-get-connection-property vec "first-password-request")) + (tramp-get-connection-property + (tramp-get-connection-property + proc "hop-vector" + (process-get proc 'tramp-vector)) + " first-password-request")) (tramp-clear-passwd vec)) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) @@ -5681,6 +5784,23 @@ of." (narrow-to-region (point-max) (point-max)))) t) +(defcustom tramp-use-fingerprint t + "Whether fingerprint prompts shall be used for authentication." + :version "30.2" + :type 'boolean + :link '(tramp-info-link :tag "Tramp manual" tramp-use-fingerprint)) + +(defun tramp-action-fingerprint (proc vec) + "Query the user for a fingerprint verification. +Interrupt the query if `tramp-use-fingerprint' is nil." + (with-current-buffer (process-buffer proc) + (if tramp-use-fingerprint + (tramp-action-show-message proc vec) + (interrupt-process proc) + ;; Hide message. + (narrow-to-region (point-max) (point-max)))) + t) + (defun tramp-action-succeed (_proc _vec) "Signal success in finding shell prompt." (throw 'tramp-action 'ok)) @@ -5727,6 +5847,26 @@ The terminal type can be configured with `tramp-terminal-type'." (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) t) +(defun tramp-action-show-message (proc vec) + "Show the user a message for confirmation. +Wait, until the connection buffer changes." + (with-current-buffer (process-buffer proc) + (let ((cursor-in-echo-area t) + set-message-function clear-message-function tramp-dont-suspend-timers) + (with-tramp-suspended-timers + ;; Silence byte compiler. + (ignore set-message-function clear-message-function) + (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-min)) + (tramp-check-for-regexp proc tramp-process-action-regexp) + (with-temp-message (concat (string-trim (match-string 0)) " ") + ;; Hide message in buffer. + (narrow-to-region (point-max) (point-max)) + ;; Wait for new output. + (while (length= (buffer-string) 0) + (tramp-accept-process-output proc)))))) + t) + (defun tramp-action-confirm-message (_proc vec) "Return RET in order to confirm the message." (tramp-message @@ -5744,6 +5884,7 @@ Wait, until the connection buffer changes." ;; Silence byte compiler. (ignore set-message-function clear-message-function) (tramp-message vec 6 "\n%s" (buffer-string)) + (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) (with-temp-message (concat (string-trim (match-string 0)) " ") ;; Hide message in buffer. @@ -5846,11 +5987,11 @@ because the shell prompt has been detected), it shall throw a result. The symbol `ok' means that all ACTIONs have been performed successfully. Any other value means an error." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use the "password-vector" property in case we have several hops. + ;; use the "hop-vector" property in case we have several hops. (tramp-set-connection-property (tramp-get-connection-property - proc "password-vector" (process-get proc 'tramp-vector)) - "first-password-request" tramp-cache-read-persistent-data) + proc "hop-vector" (process-get proc 'tramp-vector)) + " first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter proc 3 "Waiting for prompts from remote shell" @@ -5930,8 +6071,8 @@ If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." ;; communication. This could block the output for the current ;; process. Read such output first. (Bug#61350) ;; The process property isn't set anymore due to Bug#62194. - (when-let (((process-get proc 'tramp-shared-socket)) - (v (process-get proc 'tramp-vector))) + (when-let* (((process-get proc 'tramp-shared-socket)) + (v (process-get proc 'tramp-vector))) (dolist (p (delq proc (process-list))) (when (tramp-file-name-equal-p v (process-get p 'tramp-vector)) (with-tramp-suspended-timers @@ -6014,6 +6155,8 @@ nil." (let ((found (tramp-check-for-regexp proc regexp))) (with-tramp-timeout (timeout) (while (not found) + ;; This is needed to yield the CPU, otherwise we'll see 100% CPU load. + (sit-for 0 'nodisp) (tramp-accept-process-output proc) (unless (process-live-p proc) (tramp-error-with-buffer @@ -6241,10 +6384,10 @@ depending whether FILENAME is remote or local. Both parameters must be non-negative integers. The setgid bit of the upper directory is respected. If FILENAME is remote, a file name handler is called." - (let* ((dir (file-name-directory filename)) - (modes (file-modes dir))) - (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (file-attribute-group-id (file-attributes dir))))) + (when-let* ((dir (file-name-directory filename)) + (modes (file-modes dir)) + ((not (zerop (logand modes #o2000))))) + (setq gid (file-attribute-group-id (file-attributes dir)))) (if (tramp-tramp-file-p filename) (funcall (if (tramp-crypt-file-name-p filename) @@ -6302,14 +6445,14 @@ VEC is used for tracing." "Check `file-attributes' caches for VEC. Return t if according to the cache access type ACCESS is known to be granted." - (when-let ((offset (cond - ((eq ?r access) 1) - ((eq ?w access) 2) - ((eq ?x access) 3) - ((eq ?s access) 3))) - (file-attr (file-attributes (tramp-make-tramp-file-name vec))) - (remote-uid (tramp-get-remote-uid vec 'integer)) - (remote-gid (tramp-get-remote-gid vec 'integer))) + (when-let* ((offset (cond + ((eq ?r access) 1) + ((eq ?w access) 2) + ((eq ?x access) 3) + ((eq ?s access) 3))) + (file-attr (file-attributes (tramp-make-tramp-file-name vec))) + (remote-uid (tramp-get-remote-uid vec 'integer)) + (remote-gid (tramp-get-remote-gid vec 'integer))) (or ;; Not a symlink. (eq t (file-attribute-type file-attr)) @@ -6346,112 +6489,110 @@ Convert file mode bits to string and set virtual device number. Set file uid and gid according to ID-FORMAT. LOCALNAME is used to cache the result. Return the modified ATTR." (declare (indent 3) (debug t)) - `(with-tramp-file-property - ,vec ,localname (format "file-attributes-%s" (or ,id-format 'integer)) - (when-let - ((result - (with-tramp-file-property ,vec ,localname "file-attributes" - (when-let ((attr ,attr)) - (save-match-data - ;; Remove ANSI control escape sequences from symlink. + `(when-let* + ((result + (with-tramp-file-property ,vec ,localname "file-attributes" + (when-let* ((attr ,attr)) + (save-match-data + ;; Remove ANSI control escape sequences from symlink. + (when (stringp (car attr)) + (while (string-match ansi-color-control-seq-regexp (car attr)) + (setcar attr (replace-match "" nil nil (car attr))))) + ;; Convert uid and gid. Use `tramp-unknown-id-integer' + ;; as indication of unusable value. + (when (consp (nth 2 attr)) + (when (and (numberp (cdr (nth 2 attr))) + (< (cdr (nth 2 attr)) 0)) + (setcdr (car (nthcdr 2 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 2 attr))) + (<= (cdr (nth 2 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 2 attr)) (round (cdr (nth 2 attr)))))) + (when (consp (nth 3 attr)) + (when (and (numberp (cdr (nth 3 attr))) + (< (cdr (nth 3 attr)) 0)) + (setcdr (car (nthcdr 3 attr)) tramp-unknown-id-integer)) + (when (and (floatp (cdr (nth 3 attr))) + (<= (cdr (nth 3 attr)) most-positive-fixnum)) + (setcdr (car (nthcdr 3 attr)) (round (cdr (nth 3 attr)))))) + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) most-positive-fixnum)) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) + (tramp-file-mode-from-int (nth 8 attr))) (when (stringp (car attr)) - (while (string-match ansi-color-control-seq-regexp (car attr)) - (setcar attr (replace-match "" nil nil (car attr))))) - ;; Convert uid and gid. Use `tramp-unknown-id-integer' - ;; as indication of unusable value. - (when (consp (nth 2 attr)) - (when (and (numberp (cdr (nth 2 attr))) - (< (cdr (nth 2 attr)) 0)) - (setcdr (car (nthcdr 2 attr)) tramp-unknown-id-integer)) - (when (and (floatp (cdr (nth 2 attr))) - (<= (cdr (nth 2 attr)) most-positive-fixnum)) - (setcdr (car (nthcdr 2 attr)) (round (cdr (nth 2 attr)))))) - (when (consp (nth 3 attr)) - (when (and (numberp (cdr (nth 3 attr))) - (< (cdr (nth 3 attr)) 0)) - (setcdr (car (nthcdr 3 attr)) tramp-unknown-id-integer)) - (when (and (floatp (cdr (nth 3 attr))) - (<= (cdr (nth 3 attr)) most-positive-fixnum)) - (setcdr (car (nthcdr 3 attr)) (round (cdr (nth 3 attr)))))) - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) (seconds-to-time (nth 4 attr)))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) (seconds-to-time (nth 5 attr)))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) (seconds-to-time (nth 6 attr)))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) most-positive-fixnum)) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) - (tramp-file-mode-from-int (nth 8 attr))) - (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-prefix-p "d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - ;; Decode also multibyte string. - (when (consp (car attr)) - (setcar attr - (and (stringp (caar attr)) - (string-match - (rx (+ nonl) " -> " nonl (group (+ nonl)) nonl) - (caar attr)) - (decode-coding-string - (match-string 1 (caar attr)) 'utf-8)))) - ;; Set file's gid change bit. - (setcar - (nthcdr 9 attr) - (not (= (cdr (nth 3 attr)) - (or (tramp-get-remote-gid ,vec 'integer) - tramp-unknown-id-integer)))) - ;; Convert inode. - (when (floatp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (let ((high (nth 10 attr)) - middle low) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-prefix-p "d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + ;; Decode also multibyte string. + (when (consp (car attr)) + (setcar attr + (and (stringp (caar attr)) + (string-match + (rx (+ nonl) " -> " nonl (group (+ nonl)) nonl) + (caar attr)) + (decode-coding-string + (match-string 1 (caar attr)) 'utf-8)))) + ;; Set file's gid change bit. + (setcar + (nthcdr 9 attr) + (not (= (cdr (nth 3 attr)) + (or (tramp-get-remote-gid ,vec 'integer) + tramp-unknown-id-integer)))) + ;; Convert inode. + (when (floatp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (let ((high (nth 10 attr)) + middle low) + (if (<= high most-positive-fixnum) + (floor high) + ;; The low 16 bits. + (setq low (mod high #x10000) + high (/ high #x10000)) (if (<= high most-positive-fixnum) - (floor high) - ;; The low 16 bits. - (setq low (mod high #x10000) - high (/ high #x10000)) - (if (<= high most-positive-fixnum) - (cons (floor high) (floor low)) - ;; The middle 24 bits. - (setq middle (mod high #x1000000) - high (/ high #x1000000)) - (cons (floor high) - (cons (floor middle) (floor low)))))) - ;; Inodes can be incredible huge. We - ;; must hide this. - (error (tramp-get-inode ,vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device ,vec)) - ;; Set SELinux context. - (when (stringp (nth 12 attr)) - (tramp-set-file-property - ,vec ,localname "file-selinux-context" - (split-string (nth 12 attr) ":" 'omit))) - ;; Remove optional entries. - (setcdr (nthcdr 11 attr) nil) - attr))))) - - ;; Return normalized result. - (append (tramp-compat-take 2 result) - (if (eq ,id-format 'string) - (list (car (nth 2 result)) (car (nth 3 result))) - (list (cdr (nth 2 result)) (cdr (nth 3 result)))) - (nthcdr 4 result))))) + (cons (floor high) (floor low)) + ;; The middle 24 bits. + (setq middle (mod high #x1000000) + high (/ high #x1000000)) + (cons (floor high) + (cons (floor middle) (floor low)))))) + ;; Inodes can be incredible huge. We must + ;; hide this. + (error (tramp-get-inode ,vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device ,vec)) + ;; Set SELinux context. + (when (stringp (nth 12 attr)) + (tramp-set-file-property + ,vec ,localname "file-selinux-context" + (split-string (nth 12 attr) ":" 'omit))) + ;; Remove optional entries. + (setcdr (nthcdr 11 attr) nil) + attr))))) + + ;; Return normalized result. + (append (tramp-compat-take 2 result) + (if (eq ,id-format 'string) + (list (car (nth 2 result)) (car (nth 3 result))) + (list (cdr (nth 2 result)) (cdr (nth 3 result)))) + (nthcdr 4 result)))) (defun tramp-get-home-directory (vec &optional user) "The remote home directory for connection VEC as local file name. @@ -6769,13 +6910,15 @@ verbosity of 6." (catch 'result (let ((default-directory temporary-file-directory)) (dolist (pid (list-system-processes)) - (when-let ((attributes (process-attributes pid)) - (comm (cdr (assoc 'comm attributes)))) - (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) - ;; The returned command name could be truncated to 15 - ;; characters. Therefore, we cannot check for `string-equal'. - (string-prefix-p comm process-name) - (throw 'result t)))))))) + (and-let* ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes))) + ((string-equal + (cdr (assoc 'user attributes)) (user-login-name))) + ;; The returned command name could be truncated + ;; to 15 characters. Therefore, we cannot check + ;; for `string-equal'. + ((string-prefix-p comm process-name)) + ((throw 'result t))))))))) ;; When calling "emacs -Q", `auth-source-search' won't be called. If ;; you want to debug exactly this case, call "emacs -Q --eval '(setq @@ -6790,15 +6933,16 @@ Consults the auth-source package." ;; adapt `default-directory'. (Bug#39389, Bug#39489) (default-directory tramp-compat-temporary-file-directory) (case-fold-search t) - ;; In tramp-sh.el, we must use "password-vector" due to - ;; multi-hop. - (vec (tramp-get-connection-property - proc "password-vector" (process-get proc 'tramp-vector))) - (key (tramp-make-tramp-file-name vec 'noloc)) - (method (tramp-file-name-method vec)) - (user-domain (or (tramp-file-name-user-domain vec) - (tramp-get-connection-property key "login-as"))) - (host-port (tramp-file-name-host-port vec)) + ;; In tramp-sh.el, we must use "hop-vector" and "pw-vector" + ;; due to multi-hop. + (vec (process-get proc 'tramp-vector)) + (hop-vec (tramp-get-connection-property proc "hop-vector" vec)) + (pw-vec (tramp-get-connection-property proc "pw-vector" hop-vec)) + (key (tramp-make-tramp-file-name pw-vec 'noloc)) + (method (tramp-file-name-method pw-vec)) + (user-domain (or (tramp-file-name-user-domain pw-vec) + (tramp-get-connection-property pw-vec "login-as"))) + (host-port (tramp-file-name-host-port pw-vec)) (pw-prompt (string-trim-left (or prompt @@ -6807,29 +6951,23 @@ Consults the auth-source package." (if (string-match-p "passphrase" (match-string 1)) (match-string 0) (format "%s for %s " (capitalize (match-string 1)) key)))))) + ;; If there is no user name, `:create' triggers to ask for. + ;; We suppress it. + (pw-spec (list :max 1 :user user-domain :host host-port :port method + :require (cons :secret (and user-domain '(:user))) + :create (and user-domain t))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) auth-info auth-passwd tramp-dont-suspend-timers) (unwind-protect - ;; We cannot use `with-parsed-tramp-file-name', because it - ;; expands the file name. (or (setq tramp-password-save-function nil) - ;; See if auth-sources contains something useful. + ;; See if `auth-sources' contains something useful. (ignore-errors - (and auth-sources - (tramp-get-connection-property vec "first-password-request") - ;; Try with Tramp's current method. If there is no - ;; user name, `:create' triggers to ask for. We - ;; suppress it. - (setq auth-info - (car - (auth-source-search - :max 1 :user user-domain :host host-port :port method - :require (cons :secret (and user-domain '(:user))) - :create (and user-domain t))) + (and (tramp-get-connection-property hop-vec " first-password-request") + (setq auth-info (car (apply #'auth-source-search pw-spec)) tramp-password-save-function (plist-get auth-info :save-function) auth-passwd @@ -6837,16 +6975,19 @@ Consults the auth-source package." ;; Try the password cache. (with-tramp-suspended-timers - (setq auth-passwd (password-read pw-prompt key) + (setq auth-passwd + (password-read + pw-prompt (auth-source-format-cache-entry pw-spec)) tramp-password-save-function - (lambda () (password-cache-add key auth-passwd))) + (when auth-source-do-cache + (lambda () + (password-cache-add + (auth-source-format-cache-entry pw-spec) auth-passwd)))) auth-passwd)) - ;; Workaround. Prior Emacs 28.1, auth-source has saved empty - ;; passwords. See discussion in Bug#50399. - (when (tramp-string-empty-or-nil-p auth-passwd) - (setq tramp-password-save-function nil)) - (tramp-set-connection-property vec "first-password-request" nil)))) + ;; Remember the values. + (tramp-set-connection-property hop-vec " pw-spec" pw-spec) + (tramp-set-connection-property hop-vec " first-password-request" nil)))) (defun tramp-read-passwd-without-cache (proc &optional prompt) "Read a password from user (compat function)." @@ -6863,17 +7004,11 @@ Consults the auth-source package." (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (declare (tramp-suppress-trace t)) - (let ((method (tramp-file-name-method vec)) - (user-domain (tramp-file-name-user-domain vec)) - (host-port (tramp-file-name-host-port vec)) - (hop (tramp-file-name-hop vec))) - (when hop - ;; Clear also the passwords of the hops. - (tramp-clear-passwd (tramp-dissect-hop-name hop))) - (auth-source-forget - `(:max 1 ,(and user-domain :user) ,user-domain - :host ,host-port :port ,method)) - (password-cache-remove (tramp-make-tramp-file-name vec 'noloc)))) + (when-let* ((hop (cadr (reverse (tramp-compute-multi-hops vec))))) + ;; Clear also the passwords of the hops. + (tramp-clear-passwd hop)) + (when-let* ((pw-spec (tramp-get-connection-property vec " pw-spec"))) + (auth-source-forget pw-spec))) (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. @@ -7022,7 +7157,7 @@ If VEC is `tramp-null-hop', return local null device." null-device (with-tramp-connection-property vec "null-device" (let ((default-directory (tramp-make-tramp-file-name vec))) - (tramp-compat-null-device))))) + (null-device))))) ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index d746aa55f45..894b05814af 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.7.1.30.1 -;; Package-Requires: ((emacs "27.1")) +;; Version: 2.8.0-pre +;; Package-Requires: ((emacs "28.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,14 +40,13 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.7.1.30.1" +(defconst tramp-version "2.8.0-pre" "This version of Tramp.") ;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") -;;;###tramp-autoload (defconst tramp-repository-branch (ignore-errors ;; Suppress message from `emacs-repository-get-branch'. We must @@ -61,7 +60,6 @@ (emacs-repository-get-branch dir)))) "The repository branch of the Tramp sources.") -;;;###tramp-autoload (defconst tramp-repository-version (ignore-errors ;; Suppress message from `emacs-repository-get-version'. We must @@ -76,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-version-lessp emacs-version "27.1")) +(let ((x (if (not (string-version-lessp emacs-version "28.1")) "ok" - (format "Tramp 2.7.1.30.1 is not fit for %s" + (format "Tramp 2.8.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/newcomment.el b/lisp/newcomment.el index ee7b2ea34d8..04b5746eeae 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -109,8 +109,8 @@ can set the value for a particular mode using that mode's hook. Comments might be indented to a different value in order not to go beyond `comment-fill-column' or in order to align them with surrounding comments." :type 'integer + :local t :group 'comment) -(make-variable-buffer-local 'comment-column) ;;;###autoload (put 'comment-column 'safe-local-variable 'integerp) diff --git a/lisp/obsolete/cc-compat.el b/lisp/obsolete/cc-compat.el deleted file mode 100644 index b3643f888e4..00000000000 --- a/lisp/obsolete/cc-compat.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; cc-compat.el --- cc-mode compatibility with c-mode.el confusion -*- lexical-binding: t; -*- - -;; Copyright (C) 1985, 1987, 1992-2024 Free Software Foundation, Inc. - -;; Authors: 1998- Martin Stjernholm -;; 1994-1999 Barry A. Warsaw -;; Maintainer: bug-cc-mode@gnu.org -;; Created: August 1994, split from cc-mode.el -;; Keywords: c languages -;; Package: cc-mode -;; Obsolete-Since: 24.5 - -;; 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: -;; -;; Boring old c-mode.el (BOCM) is confusion and brain melt. cc-mode.el -;; is clarity of thought and purity of chi. If you are still unwilling -;; to accept enlightenment, this might help, or it may prolong your -;; agony. -;; -;; To use, add the following to your c-mode-hook: -;; -;; (require 'cc-compat) -;; (c-set-style "BOCM") -;; -;; This file is completely unsupported! Although it has been patched -;; superficially to keep pace with the rest of CC Mode, it hasn't been -;; tested for a long time. - -;;; Code: - -(eval-when-compile - (let ((load-path - (if (and (boundp 'byte-compile-dest-file) - (stringp byte-compile-dest-file)) - (cons (file-name-directory byte-compile-dest-file) load-path) - load-path))) - (load "cc-bytecomp" nil t))) - -(cc-require 'cc-defs) -(cc-require 'cc-vars) -(cc-require 'cc-styles) -(cc-require 'cc-engine) - - -;; In case c-mode.el isn't loaded -(defvar c-indent-level 2 - "Indentation of C statements with respect to containing block.") -;;;###autoload(put 'c-indent-level 'safe-local-variable 'integerp) - -(defvar c-brace-imaginary-offset 0 - "Imagined indentation of a C open brace that actually follows a statement.") -(defvar c-brace-offset 0 - "Extra indentation for braces, compared with other text in same context.") -(defvar c-argdecl-indent 5 - "Indentation level of declarations of C function arguments.") -(defvar c-label-offset -2 - "Offset of C label lines and case statements relative to usual indentation.") -(defvar c-continued-statement-offset 2 - "Extra indent for lines not starting new statements.") -(defvar c-continued-brace-offset 0 - "Extra indent for substatements that start with open-braces. -This is in addition to c-continued-statement-offset.") - - - -;; these offsets are taken by brute force testing c-mode.el, since -;; there's no logic to what it does. -(let* ((offsets '((c-offsets-alist . - ((defun-block-intro . cc-block-intro-offset) - (statement-block-intro . cc-block-intro-offset) - (defun-open . 0) - (class-open . 0) - (inline-open . c-brace-offset) - (block-open . c-brace-offset) - (block-close . cc-block-close-offset) - (brace-list-open . c-brace-offset) - (substatement-open . cc-substatement-open-offset) - (substatement . c-continued-statement-offset) - (knr-argdecl-intro . c-argdecl-indent) - (case-label . c-label-offset) - (access-label . c-label-offset) - (label . c-label-offset) - ))))) - (c-add-style "BOCM" offsets)) - - -(defun cc-block-intro-offset (langelem) - ;; taken directly from calculate-c-indent confusion - (save-excursion - (c-backward-syntactic-ws) - (if (eq (char-before) ?{) - (forward-char -1) - (goto-char (cdr langelem))) - (let* ((curcol (save-excursion - (goto-char (cdr langelem)) - (current-column))) - (bocm-lossage - ;; If no previous statement, indent it relative to line - ;; brace is on. For open brace in column zero, don't let - ;; statement start there too. If c-indent-level is zero, - ;; use c-brace-offset + c-continued-statement-offset - ;; instead. For open-braces not the first thing in a line, - ;; add in c-brace-imaginary-offset. - (+ (if (and (bolp) (zerop c-indent-level)) - (+ c-brace-offset c-continued-statement-offset) - c-indent-level) - ;; Move back over whitespace before the openbrace. If - ;; openbrace is not first nonwhite thing on the line, - ;; add the c-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 c-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; possibly a different - ;; line - (progn - (if (eq (char-before) ?\)) - (c-forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation))))) - (- bocm-lossage curcol)))) - - -(defun cc-block-close-offset (langelem) - (save-excursion - (let* ((here (point)) - bracep - (curcol (progn - (goto-char (cdr langelem)) - (current-column))) - (bocm-lossage (progn - (goto-char (cdr langelem)) - (if (eq (char-after) ?{) - (setq bracep t) - (goto-char here) - (beginning-of-line) - (backward-up-list 1) - (forward-char 1) - (c-forward-syntactic-ws)) - (current-column)))) - (- bocm-lossage curcol - (if bracep 0 c-indent-level))))) - - -(defun cc-substatement-open-offset (_langelem) - (+ c-continued-statement-offset c-continued-brace-offset)) - - -(cc-provide 'cc-compat) - -;;; cc-compat.el ends here diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/obsolete/idlw-complete-structtag.el index bcc2ee2f005..02a3c1bccfd 100644 --- a/lisp/progmodes/idlw-complete-structtag.el +++ b/lisp/obsolete/idlw-complete-structtag.el @@ -7,6 +7,7 @@ ;; Old-Version: 1.2 ;; Keywords: languages ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -25,6 +26,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x list-packages' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; Completion of structure tags can be done automatically in the ;; shell, since the list of tags can be determined dynamically through ;; interaction with IDL. diff --git a/lisp/progmodes/idlw-help.el b/lisp/obsolete/idlw-help.el index c311e1c5377..4fed46b2157 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/obsolete/idlw-help.el @@ -6,6 +6,7 @@ ;; Carsten Dominik <dominik@science.uva.nl> ;; Maintainer: emacs-devel@gnu.org ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -24,6 +25,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x list-packages' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; The help link information for IDLWAVE's online help feature for ;; system routines is extracted automatically from the IDL ;; documentation, and is available, along with general routine diff --git a/lisp/progmodes/idlw-shell.el b/lisp/obsolete/idlw-shell.el index b5d91f46b17..ae32a50bcc8 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/obsolete/idlw-shell.el @@ -8,6 +8,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Keywords: processes ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -25,7 +26,12 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; + +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x list-packages' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; This mode is for IDL version 5 or later. ;; ;; Runs IDL as an inferior process of Emacs, much like the Emacs diff --git a/lisp/progmodes/idlw-toolbar.el b/lisp/obsolete/idlw-toolbar.el index c6cb47baa40..900177c2cb3 100644 --- a/lisp/progmodes/idlw-toolbar.el +++ b/lisp/obsolete/idlw-toolbar.el @@ -6,6 +6,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Keywords: processes ;; Package: idlwave +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -24,6 +25,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x list-packages' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; This file implements a debugging toolbar for IDLWAVE. ;; It requires toolbar and xpm support. diff --git a/lisp/progmodes/idlwave.el b/lisp/obsolete/idlwave.el index b3e9eb58196..8dd98b192b6 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/obsolete/idlwave.el @@ -8,6 +8,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Version: 6.1.22 ;; Keywords: languages +;; Obsolete-since: 31.1 ;; This file is part of GNU Emacs. @@ -26,6 +27,11 @@ ;;; Commentary: +;; NOTE: IDLWAVE has been moved to GNU ELPA. The version bundled with +;; Emacs is out-of-date, marked as obsolete, and will be removed +;; in a future release. Please use `M-x list-packages' to install +;; IDLWAVE from GNU ELPA instead of using this version. + ;; IDLWAVE enables feature-rich development and interaction with IDL, ;; the Interactive Data Language. It provides a compelling, ;; full-featured alternative to the IDLDE development environment @@ -3900,7 +3906,7 @@ you specify /." "sh" nil errbuf nil "-c" (concat cmd append item))) 0 - 1))) + 1))) ;; ;; Append additional tags (setq append " --append ") @@ -4610,7 +4616,7 @@ Gets set in cached XML rinfo, or `idlw-rinfo.el'.") (if (setq master-elt (assoc master-link linkfiles)) (if (eq (car linkfiles) master-elt) linkfiles - (cons master-elt (delq master-elt linkfiles))) + (cons master-elt (delq master-elt linkfiles))) (push (list master-link) linkfiles)))) (defun idlwave-convert-xml-clean-statement-aliases (aliases) @@ -6326,7 +6332,7 @@ ARROW: Location of the arrow" (idlwave-routines) (let* (;(bos (save-excursion (idlwave-beginning-of-statement) (point))) (bos (save-excursion (idlwave-start-of-substatement 'pre) (point))) - (func-entry (idlwave-what-function bos)) + (func-entry (idlwave-what-function bos)) (func (car func-entry)) (func-class (nth 1 func-entry)) (func-arrow (nth 2 func-entry)) diff --git a/lisp/obsolete/info-edit.el b/lisp/obsolete/info-edit.el deleted file mode 100644 index fb6de736590..00000000000 --- a/lisp/obsolete/info-edit.el +++ /dev/null @@ -1,89 +0,0 @@ -;;; info-edit.el --- Editing info files -*- lexical-binding:t -*- - -;; Copyright (C) 1985-1986, 1992-2024 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: help -;; Obsolete-since: 24.4 - -;; 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 'info) - -(defvar Info-edit-mode-hook nil - "Hook run when `Info-edit-mode' is activated.") - -(make-obsolete-variable 'Info-edit-mode-hook - "editing Info nodes by hand is not recommended." "24.4") - -(defvar Info-edit-mode-map (let ((map (make-sparse-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\C-c\C-c" #'Info-cease-edit) - map) - "Local keymap used within `e' command of Info.") - -(make-obsolete-variable 'Info-edit-mode-map - "editing Info nodes by hand is not recommended." - "24.4") - -;; Info-edit mode is suitable only for specially formatted data. -(put 'Info-edit-mode 'mode-class 'special) - -(define-derived-mode Info-edit-mode text-mode "Info Edit" - "Major mode for editing the contents of an Info node. -Like text mode with the addition of `Info-cease-edit' -which returns to Info mode for browsing." - (setq buffer-read-only nil) - (force-mode-line-update) - (buffer-enable-undo (current-buffer))) - -(defun Info-edit () - "Edit the contents of this Info node." - (interactive) - (Info-edit-mode) - (message "%s" (substitute-command-keys - "Editing: Type \\<Info-edit-mode-map>\\[Info-cease-edit] to return to info"))) - -(put 'Info-edit 'disabled "Editing Info nodes by hand is not recommended. -This feature will be removed in future.") - -(defun Info-cease-edit () - "Finish editing Info node; switch back to Info proper." - (interactive) - ;; Do this first, so nothing has changed if user C-g's at query. - (and (buffer-modified-p) - (y-or-n-p "Save the file? ") - (save-buffer)) - (Info-mode) - (force-mode-line-update) - (and (marker-position Info-tag-table-marker) - (buffer-modified-p) - (message "Tags may have changed. Use Info-tagify if necessary"))) - -(with-eval-after-load 'ibuffer - (defvar ibuffer-help-buffer-modes) - ;; Moved here from definition of ibuffer-help-buffer-modes to make - ;; that variable customizable even though this code is obsolete. See - ;; also Bug#30990. - (add-to-list 'ibuffer-help-buffer-modes 'Info-edit-mode)) - -(provide 'info-edit) - -;;; info-edit.el ends here diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index e1ea9141f0d..abd5005e54d 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -410,10 +410,9 @@ Its value is one of `samewindow', `otherwindow', `display', `otherframe', `maybe-frame' or `always-frame'. See `iswitchb-default-method' for details of values.") -(defvar iswitchb-eoinput 1 +(defvar-local iswitchb-eoinput 1 "Point where minibuffer input ends and completion info begins. Copied from `icomplete-eoinput'.") -(make-variable-buffer-local 'iswitchb-eoinput) (defvar iswitchb-buflist nil "Stores the current list of buffers that will be searched through. diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el index f065bcaff26..3cfde4cb298 100644 --- a/lisp/obsolete/longlines.el +++ b/lisp/obsolete/longlines.el @@ -80,17 +80,11 @@ This is used when `longlines-show-hard-newlines' is on." ;;; Internal variables -(defvar longlines-wrap-beg nil) -(defvar longlines-wrap-end nil) -(defvar longlines-wrap-point nil) -(defvar longlines-showing nil) -(defvar longlines-decoded nil) - -(make-variable-buffer-local 'longlines-wrap-beg) -(make-variable-buffer-local 'longlines-wrap-end) -(make-variable-buffer-local 'longlines-wrap-point) -(make-variable-buffer-local 'longlines-showing) -(make-variable-buffer-local 'longlines-decoded) +(defvar-local longlines-wrap-beg nil) +(defvar-local longlines-wrap-end nil) +(defvar-local longlines-wrap-point nil) +(defvar-local longlines-showing nil) +(defvar-local longlines-decoded nil) ;;; Mode diff --git a/lisp/obsolete/meese.el b/lisp/obsolete/meese.el deleted file mode 100644 index 7443bacc8b2..00000000000 --- a/lisp/obsolete/meese.el +++ /dev/null @@ -1,38 +0,0 @@ -;;; meese.el --- protect the impressionable young minds of America -*- lexical-binding: t; -*- - -;; This is in the public domain on account of being distributed since -;; 1985 or 1986 without a copyright notice. - -;; This file is part of GNU Emacs. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: games -;; Obsolete-since: 24.4 - -;;; Commentary: - -;; Adds a hook to protect the impressionable young minds of America -;; from reading certain files in the Emacs distribution using Emacs. - -;; This file is named after Ed Meese, the US Attorney General -;; under President Reagan, because of his support for censorship. - -;;; Code: - -(defun protect-innocence-hook () - (let ((dir (file-name-directory buffer-file-name))) - (if (and (equal buffer-file-name (expand-file-name "sex.6" dir)) - (file-exists-p buffer-file-name) - (not (y-or-n-p "Are you over 18? "))) - (progn - (clear-visited-file-modtime) - (setq buffer-file-name (expand-file-name "celibacy.1" dir)) - (let ((inhibit-read-only t)) ; otherwise (erase-buffer) may bomb. - (erase-buffer) - (insert-file-contents buffer-file-name t)) - (rename-buffer (file-name-nondirectory buffer-file-name)))))) - -;;;(add-hook 'find-file-hook 'protect-innocence-hook) -(provide 'meese) - -;;; meese.el ends here diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el deleted file mode 100644 index deca885b44b..00000000000 --- a/lisp/obsolete/otodo-mode.el +++ /dev/null @@ -1,965 +0,0 @@ -;;; otodo-mode.el --- major mode for editing TODO list files -*- lexical-binding: t; -*- - -;; Copyright (C) 1997, 1999, 2001-2024 Free Software Foundation, Inc. - -;; Author: Oliver Seidel <privat@os10000.net> -;; Maintainer: Stephen Berman <stephen.berman@gmx.net> -;; Created: 2 Aug 1997 -;; Keywords: calendar, todo -;; Obsolete-since: 24.4 - -;; 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: - -;; Mode Description -;; -;; TODO is a major mode for EMACS which offers functionality to -;; treat most lines in one buffer as a list of items one has to -;; do. There are facilities to add new items, which are -;; categorized, to edit or even delete items from the buffer. -;; The buffer contents are currently compatible with the diary, -;; so that the list of todo-items will show up in the FANCY diary -;; mode. -;; -;; Notice: Besides the major mode, this file also exports the -;; function `todo-show' which will change to the one specific -;; TODO file that has been specified in the todo-file-do -;; variable. If this file does not conform to the TODO mode -;; conventions, the todo-show function will add the appropriate -;; header and footer. I don't anticipate this to cause much -;; grief, but be warned, in case you attempt to read a plain text -;; file. -;; -;; Preface, Quickstart Installation -;; -;; To get this to work, make Emacs execute the line -;; -;; (autoload 'todo-mode "todo-mode" -;; "Major mode for editing TODO lists." t) -;; (autoload 'todo-show "todo-mode" -;; "Show TODO items." t) -;; (autoload 'todo-insert-item "todo-mode" -;; "Add TODO item." t) -;; -;; You may now enter new items by typing "M-x todo-insert-item", -;; or enter your TODO list file by typing "M-x todo-show". -;; -;; The TODO list file has a special format and some auxiliary -;; information, which will be added by the todo-show function if -;; it attempts to visit an un-initialized file. Hence it is -;; recommended to use the todo-show function for the first time, -;; in order to initialize the file, but it is not necessary -;; afterwards. -;; -;; As these commands are quite long to type, I would recommend -;; the addition of two bindings to your to your global keymap. I -;; personally have the following in my initialization file: -;; -;; (global-set-key "\C-ct" 'todo-show) ; switch to TODO buffer -;; (global-set-key "\C-ci" 'todo-insert-item) ; insert new item -;; -;; Note, however, that this recommendation has prompted some -;; criticism, since the keys C-c LETTER are reserved for user -;; functions. I believe my recommendation is acceptable, since -;; the Emacs Lisp Manual *Tips* section also details that the -;; mode itself should not bind any functions to those keys. The -;; express aim of the above two bindings is to work outside the -;; mode, which doesn't need the show function and offers a -;; different binding for the insert function. They serve as -;; shortcuts and are not even needed (since the TODO mode will be -;; entered by visiting the TODO file, and later by switching to -;; its buffer). -;; -;; If you are an advanced user of this package, please consult -;; the whole source code for autoloads, because there are several -;; extensions that are not explicitly listed in the above quick -;; installation. -;; -;; Pre-Requisites -;; -;; This package will require the following packages to be -;; available on the load-path: -;; -;; time-stamp -;; easymenu -;; -;; Operation -;; -;; You will have the following facilities available: -;; -;; M-x todo-show will enter the todo list screen, here type -;; -;; + to go to next category -;; - to go to previous category -;; d to file the current entry, including a -;; comment and timestamp -;; e to edit the current entry -;; E to edit a multi-line entry -;; f to file the current entry, including a -;; comment and timestamp -;; i to insert a new entry, with prefix, omit category -;; I to insert a new entry at current cursor position -;; j jump to category -;; k to kill the current entry -;; l to lower the current entry's priority -;; n for the next entry -;; p for the previous entry -;; P print -;; q to save the list and exit the buffer -;; r to raise the current entry's priority -;; s to save the list -;; S to save the list of top priorities -;; t show top priority items for each category -;; -;; When you add a new entry, you are asked for the text and then -;; for the category. I for example have categories for things -;; that I want to do in the office (like mail my mum), that I -;; want to do in town (like buy cornflakes) and things I want to -;; do at home (move my suitcases). The categories can be -;; selected with the cursor keys and if you type in the name of a -;; category which didn't exist before, an empty category of the -;; desired name will be added and filled with the new entry. -;; -;; Configuration -;; -;; Variable todo-prefix -;; -;; I would like to recommend that you use the prefix "*/*" (by -;; leaving the variable 'todo-prefix' untouched) so that the -;; diary displays each entry every day. -;; -;; To understand what I mean, please read the documentation that -;; goes with the calendar since that will tell you how you can -;; set up the fancy diary display and use the #include command to -;; include your todo list file as part of your diary. -;; -;; If you have the diary package set up to usually display more -;; than one day's entries at once, consider using -;; -;; "&%%(equal (calendar-current-date) date)" -;; -;; as the value of `todo-prefix'. Please note that this may slow -;; down the processing of your diary file some. -;; -;; Carsten Dominik <dominik@strw.LeidenUniv.nl> suggested that -;; -;; "&%%(todo-cp)" -;; -;; might be nicer and to that effect a function has been declared -;; further down in the code. You may wish to auto-load this. -;; -;; Carsten also writes that *changing* the prefix after the -;; todo list is already established is not as simple as changing -;; the variable - the todo files have to be changed by hand. -;; -;; Variable todo-file-do -;; -;; This variable is fairly self-explanatory. You have to store -;; your TODO list somewhere. This variable tells the package -;; where to go and find this file. -;; -;; Variable todo-file-done -;; -;; Even when you're done, you may wish to retain the entries. -;; Given that they're timestamped and you are offered to add a -;; comment, this can make a useful diary of past events. It will -;; even blend in with the EMACS diary package. So anyway, this -;; variable holds the name of the file for the filed todo-items. -;; -;; Variable todo-file-top -;; -;; File storing the top priorities of your TODO list when -;; todo-save-top-priorities is non-nil. Nice to include in your -;; diary instead of the complete TODO list. -;; -;; Variable todo-mode-hook -;; -;; Just like other modes, too, this mode offers to call your -;; functions before it goes about its business. This variable -;; will be inspected for any functions you may wish to have -;; called once the other TODO mode preparations have been -;; completed. -;; -;; Variable todo-insert-threshold -;; -;; Another nifty feature is the insertion accuracy. If you have -;; 8 items in your TODO list, then you may get asked 4 questions -;; by the binary insertion algorithm. However, you may not -;; really have a need for such accurate priorities amongst your -;; TODO items. If you now think about the binary insertion -;; halving the size of the window each time, then the threshold -;; is the window size at which it will stop. If you set the -;; threshold to zero, the upper and lower bound will coincide at -;; the end of the loop and you will insert your item just before -;; that point. If you set the threshold to, e.g. 8, it will stop -;; as soon as the window size drops below that amount and will -;; insert the item in the approximate center of that window. I -;; got the idea for this feature after reading a very helpful -;; e-mail reply from Trey Jackson <trey@cs.berkeley.edu> who -;; corrected some of my awful coding and pointed me towards some -;; good reading. Thanks Trey! -;; -;; Things to do -;; -;; These originally were my ideas, but now also include all the -;; suggestions that I included before forgetting them: -;; -;; o Fancy fonts for todo/top-priority buffer -;; o Remove todo-prefix option in todo-top-priorities -;; o Rename category -;; o Move entry from one category to another one -;; o Entries which both have the generic */* prefix and a -;; "deadline" entry which are understood by diary, indicating -;; an event (unless marked by &) -;; o The optional COUNT variable of todo-forward-item should be -;; applied to the other functions performing similar tasks -;; o Modularization could be done for repeated elements of -;; the code, like the completing-read lines of code. -;; o license / version function -;; o export to diary file -;; o todo-report-bug -;; o GNATS support -;; o elide multiline (as in bbdb, or, to a lesser degree, in -;; outline mode) -;; o rewrite complete package to store data as Lisp objects -;; and have display modes for display, for diary export, -;; etc. (Richard Stallman pointed out this is a bad idea) -;; o so base todo-mode.el on generic-mode.el instead -;; -;; History and Gossip -;; -;; Many thanks to all the ones who have contributed to the -;; evolution of this package! I hope I have listed all of you -;; somewhere in the documentation or at least in the RCS history! -;; -;; Enjoy this package and express your gratitude by sending nice -;; things to my parents' address! -;; -;; Oliver Seidel -;; (Lessingstr. 8, 65760 Eschborn, Federal Republic of Germany) - -;;; Code: - -(require 'time-stamp) - - -;; User-configurable variables: - -(defgroup todo nil - "Maintain a list of todo items." - :link '(emacs-commentary-link "todo-mode") - :version "21.1" - :group 'calendar) - -(defcustom todo-prefix "*/*" - "TODO mode prefix for entries. - -This is useful in conjunction with `calendar' and `diary' if you use - -#include \"~/.emacs.d/todo-do\" - -in your diary file to include your todo list file as part of your -diary. With the default value \"*/*\" the diary displays each entry -every day and it may also be marked on every day of the calendar. -Using \"&%%(equal (calendar-current-date) date)\" instead will only -show and mark todo entries for today, but may slow down processing of -the diary file somewhat." - :type 'string) -(defcustom todo-file-do (locate-user-emacs-file "todo-do" ".todo-do") - "TODO mode list file." - :version "24.4" ; added locate-user-emacs-file - :type 'file) -(defcustom todo-file-done (locate-user-emacs-file "todo-done" ".todo-done") - "TODO mode archive file." - :version "24.4" ; added locate-user-emacs-file - :type 'file) -(defcustom todo-mode-hook nil - "TODO mode hooks." - :type 'hook) -(defcustom todo-edit-mode-hook nil - "TODO Edit mode hooks." - :type 'hook) -(defcustom todo-insert-threshold 0 - "TODO mode insertion accuracy. - -If you have 8 items in your TODO list, then you may get asked 4 -questions by the binary insertion algorithm. However, you may not -really have a need for such accurate priorities amongst your TODO -items. If you now think about the binary insertion halving the size -of the window each time, then the threshold is the window size at -which it will stop. If you set the threshold to zero, the upper and -lower bound will coincide at the end of the loop and you will insert -your item just before that point. If you set the threshold to, -e.g. 8, it will stop as soon as the window size drops below that -amount and will insert the item in the approximate center of that -window." - :type 'integer) -(defvar todo-edit-buffer " *TODO Edit*" - "TODO Edit buffer name.") -(defcustom todo-file-top (locate-user-emacs-file "todo-top" ".todo-top") - "TODO mode top priorities file. - -Not in TODO format, but diary compatible. -Automatically generated when `todo-save-top-priorities' is non-nil." - :version "24.4" ; added locate-user-emacs-file - :type 'string) - -(defcustom todo-print-function 'ps-print-buffer-with-faces - "Function to print the current buffer." - :type 'symbol) -(defcustom todo-show-priorities 1 - "Default number of priorities to show by \\[todo-top-priorities]. -0 means show all entries." - :type 'integer) -(defcustom todo-print-priorities 0 - "Default number of priorities to print by \\[todo-print]. -0 means print all entries." - :type 'integer) -(defcustom todo-remove-separator t - "Non-nil to remove category separators in\ -\\[todo-top-priorities] and \\[todo-print]." - :type 'boolean) -(defcustom todo-save-top-priorities-too t - "Non-nil makes `todo-save' automatically save top-priorities in `todo-file-top'." - :type 'boolean) - -;; Thanks for the ISO time stamp format go to Karl Eichwalder <ke@suse.de> -;; My format string for the appt.el package is "%3b %2d, %y, %02I:%02M%p". -;; -(defcustom todo-time-string-format - "%:y-%02m-%02d %02H:%02M" - "TODO mode time string format for done entries. -For details see the variable `time-stamp-format'." - :type 'string) - -(defcustom todo-entry-prefix-function 'todo-entry-timestamp-initials - "Function producing text to insert at start of todo entry." - :type 'symbol) -(defcustom todo-initials (or (getenv "INITIALS") (user-login-name)) - "Initials of todo item author." - :type 'string) - -(defun todo-entry-timestamp-initials () - "Prepend timestamp and your initials to the head of a TODO entry." - (let ((time-stamp-format todo-time-string-format)) - (concat (time-stamp-string) " " todo-initials ": "))) - -;; --------------------------------------------------------------------------- - -;; Set up some helpful context ... - -(defvar todo-categories nil - "TODO categories.") - -(defvar todo-cats nil - "Old variable for holding the TODO categories. -Use `todo-categories' instead.") - -(defvar todo-previous-line 0 - "Previous line asked about.") - -(defvar todo-previous-answer 0 - "Previous answer got.") - -(defvar todo-mode-map - (let ((map (make-keymap))) - (suppress-keymap map t) - (define-key map "+" #'todo-forward-category) - (define-key map "-" #'todo-backward-category) - (define-key map "d" #'todo-file-item) ;done/delete - (define-key map "e" #'todo-edit-item) - (define-key map "E" #'todo-edit-multiline) - (define-key map "f" #'todo-file-item) - (define-key map "i" #'todo-insert-item) - (define-key map "I" #'todo-insert-item-here) - (define-key map "j" #'todo-jump-to-category) - (define-key map "k" #'todo-delete-item) - (define-key map "l" #'todo-lower-item) - (define-key map "n" #'todo-forward-item) - (define-key map "p" #'todo-backward-item) - (define-key map "P" #'todo-print) - (define-key map "q" #'todo-quit) - (define-key map "r" #'todo-raise-item) - (define-key map "s" #'todo-save) - (define-key map "S" #'todo-save-top-priorities) - (define-key map "t" #'todo-top-priorities) - map) - "TODO mode keymap.") - -(defvar todo-category-number 0 "TODO category number.") - -(defvar todo-tmp-buffer-name " *todo tmp*") - -(defvar todo-category-sep (make-string 75 ?-) - "Category separator.") - -(defvar todo-category-beg " --- " - "Category start separator to be prepended onto category name.") - -(defvar todo-category-end "--- End" - "Separator after a category.") - -(defvar todo-header "-*- mode: todo; " - "Header of todo files.") - -;; --------------------------------------------------------------------------- - -(defun todo-category-select () - "Make TODO mode display the current category correctly." - (let ((name (nth todo-category-number todo-categories))) - (setq mode-line-buffer-identification -;; (concat "Category: " name)) - (concat "Category: " (format "%18s" name))) - (widen) - (goto-char (point-min)) - (search-forward-regexp - (concat "^" - (regexp-quote (concat todo-prefix todo-category-beg name)) - "$")) - (let ((begin (1+ (line-end-position)))) - (search-forward-regexp (concat "^" todo-category-end)) - (narrow-to-region begin (line-beginning-position)) - (goto-char (point-min))))) -(defalias 'todo-cat-slct #'todo-category-select) - -(defun todo-forward-category () - "Go forward to TODO list of next category." - (interactive) - (setq todo-category-number - (mod (1+ todo-category-number) (length todo-categories))) - (todo-category-select)) -(defalias 'todo-cmd-forw #'todo-forward-category) - -(defun todo-backward-category () - "Go back to TODO list of previous category." - (interactive) - (setq todo-category-number - (mod (1- todo-category-number) (length todo-categories))) - (todo-category-select)) -(defalias 'todo-cmd-back #'todo-backward-category) - -(defun todo-backward-item () - "Select previous entry of TODO list." - (interactive) - (search-backward-regexp (concat "^" (regexp-quote todo-prefix)) nil t) - (message "")) -(defalias 'todo-cmd-prev #'todo-backward-item) - -(defun todo-forward-item (&optional count) - "Select COUNT-th next entry of TODO list." - (interactive "P") - (if (listp count) (setq count (car count))) - (end-of-line) - (search-forward-regexp (concat "^" (regexp-quote todo-prefix)) - nil 'goto-end count) - (beginning-of-line) - (message "")) -(defalias 'todo-cmd-next #'todo-forward-item) - -(defun todo-save () - "Save the TODO list." - (interactive) - (save-excursion - (save-restriction - (save-buffer))) - (if todo-save-top-priorities-too (todo-save-top-priorities))) -(defalias 'todo-cmd-save #'todo-save) - -(defun todo-quit () - "Done with TODO list for now." - (interactive) - (widen) - (todo-save) - (message "") - (bury-buffer)) -(defalias 'todo-cmd-done #'todo-quit) - -(defun todo-edit-item () - "Edit current TODO list entry." - (interactive) - (if (< (point-min) (point-max)) - (let ((item (todo-item-string))) - (if (todo-string-multiline-p item) - (todo-edit-multiline) - (let ((new (read-from-minibuffer "Edit: " item))) - (todo-remove-item) - (insert new "\n") - (todo-backward-item) - (message "")))) - (error "No TODO list entry to edit"))) -(defalias 'todo-cmd-edit #'todo-edit-item) - -(defun todo-edit-multiline () - "Set up a buffer for editing a multiline TODO list entry." - (interactive) - (let ((buffer-name (generate-new-buffer-name todo-edit-buffer))) - (switch-to-buffer - (make-indirect-buffer - (file-name-nondirectory todo-file-do) buffer-name)) - (message "To exit, simply kill this buffer and return to list.") - (todo-edit-mode) - (narrow-to-region (todo-item-start) (todo-item-end)))) - -;;;###autoload -(defun todo-add-category (&optional cat) - "Add new category CAT to the TODO list." - (interactive) - (let ((buf (find-file-noselect todo-file-do t)) - (prompt "Category: ")) - (unless (zerop (buffer-size buf)) - (and (null todo-categories) - (null todo-cats) - (error "Error in %s: File is non-empty but contains no category" - todo-file-do))) - (unless cat (setq cat (read-from-minibuffer prompt))) - (with-current-buffer buf - ;; reject names that could induce bugs and confusion - (while (and (cond ((string= "" cat) - (setq prompt "Enter a non-empty category name: ")) - ((string-match "\\`\\s-+\\'" cat) - (setq prompt "Enter a category name that is not only white space: ")) - ((member cat todo-categories) - (setq prompt "Enter a non-existing category name: "))) - (setq cat (read-from-minibuffer prompt)))) - ;; initialize a newly created Todo buffer for Todo mode - (unless (file-exists-p todo-file-do) (todo-mode)) - (setq todo-categories (cons cat todo-categories)) - (widen) - (goto-char (point-min)) - (if (search-forward "-*- mode: todo; " (+ (point-min) 16) t) - (kill-line) - (insert "-*- mode: todo; \n") - (forward-char -1)) - (insert (format "todo-categories: %S; -*-" todo-categories)) - (forward-char 1) - (insert (format "%s%s%s\n%s\n%s %s\n" - todo-prefix todo-category-beg cat - todo-category-end - todo-prefix todo-category-sep)) - (if (called-interactively-p 'interactive) - ;; properly display the newly added category - (progn (setq todo-category-number 0) (todo-show)) - 0)))) - -;;;###autoload -(defun todo-add-item-non-interactively (new-item category) - "Insert NEW-ITEM in TODO list as a new entry in CATEGORY." - (save-excursion - (todo-show)) - (save-excursion - (if (string= "" category) - (setq category (nth todo-category-number todo-categories))) - (let ((cat-exists (member category todo-categories))) - (setq todo-category-number - (if cat-exists - (- (length todo-categories) (length cat-exists)) - (todo-add-category category)))) - (todo-show) - (setq todo-previous-line 0) - (let ((top 1) - (bottom (1+ (count-lines (point-min) (point-max))))) - (while (> (- bottom top) todo-insert-threshold) - (let* ((current (/ (+ top bottom) 2)) - (answer (if (< current bottom) - (todo-more-important-p current) nil))) - (if answer - (setq bottom current) - (setq top (1+ current))))) - (setq top (/ (+ top bottom) 2)) - ;; goto-line doesn't have the desired behavior in a narrowed buffer. - (goto-char (point-min)) - (forward-line (1- top))) - (insert new-item "\n") - (todo-backward-item) - (todo-save) - (message ""))) - -;;;###autoload -(defun todo-insert-item (arg) - "Insert new TODO list entry. -With a prefix argument ARG solicit the category, otherwise use the current -category." - (interactive "P") - (save-excursion - (if (not (derived-mode-p 'todo-mode)) (todo-show)) - (let* ((new-item (concat todo-prefix " " - (read-from-minibuffer - "New TODO entry: " - (if todo-entry-prefix-function - (funcall todo-entry-prefix-function))))) - (current-category (nth todo-category-number todo-categories)) - (category (if arg (todo-completing-read) current-category))) - (todo-add-item-non-interactively new-item category)))) - -(defalias 'todo-cmd-inst #'todo-insert-item) - -(defun todo-insert-item-here () - "Insert a new TODO list entry directly above the entry at point. -If point is on an empty line, insert the entry there." - (interactive) - (if (not (derived-mode-p 'todo-mode)) (todo-show)) - (let ((new-item (concat todo-prefix " " - (read-from-minibuffer - "New TODO entry: " - (if todo-entry-prefix-function - (funcall todo-entry-prefix-function)))))) - (unless (and (bolp) (eolp)) (todo-item-start)) - (insert (concat new-item "\n")) - (backward-char) - ;; put point at start of new entry - (todo-item-start))) - -(defun todo-more-important-p (line) - "Ask whether entry is more important than the one at LINE." - (unless (equal todo-previous-line line) - (setq todo-previous-line line) - (goto-char (point-min)) - (forward-line (1- todo-previous-line)) - (let ((item (todo-item-string-start))) - (setq todo-previous-answer - (y-or-n-p (format-message "More important than `%s'? " item))))) - todo-previous-answer) -(defalias 'todo-ask-p #'todo-more-important-p) - -(defun todo-delete-item () - "Delete current TODO list entry." - (interactive) - (if (> (count-lines (point-min) (point-max)) 0) - (let* ((todo-entry (todo-item-string-start)) - (todo-answer (y-or-n-p (concat "Permanently remove '" - todo-entry "'? ")))) - (when todo-answer - (todo-remove-item) - (todo-backward-item)) - (message "")) - (error "No TODO list entry to delete"))) -(defalias 'todo-cmd-kill #'todo-delete-item) - -(defun todo-raise-item () - "Raise priority of current entry." - (interactive) - (if (> (count-lines (point-min) (point)) 0) - (let ((item (todo-item-string))) - (todo-remove-item) - (todo-backward-item) - (save-excursion - (insert item "\n")) - (message "")) - (error "No TODO list entry to raise"))) -(defalias 'todo-cmd-rais #'todo-raise-item) - -(defun todo-lower-item () - "Lower priority of current entry." - (interactive) - (if (> (count-lines (point) (point-max)) 1) - ;; Assume there is a final newline - (let ((item (todo-item-string))) - (todo-remove-item) - (todo-forward-item) - (save-excursion - (insert item "\n")) - (message "")) - (error "No TODO list entry to lower"))) -(defalias 'todo-cmd-lowr #'todo-lower-item) - -(defun todo-file-item (&optional comment) - "File the current TODO list entry away, annotated with an optional COMMENT." - (interactive "sComment: ") - (or (> (count-lines (point-min) (point-max)) 0) - (error "No TODO list entry to file away")) - (let ((time-stamp-format todo-time-string-format)) - (when (and comment (> (length comment) 0)) - (goto-char (todo-item-end)) - (insert - (if (save-excursion (beginning-of-line) - (looking-at (regexp-quote todo-prefix))) - " " - "\n\t") - "(" comment ")")) - (goto-char (todo-item-end)) - (insert " [" (nth todo-category-number todo-categories) "]") - (todo-item-start) - (let ((temp-point (point))) - (if (looking-at (regexp-quote todo-prefix)) - (replace-match (time-stamp-string)) - ;; Standard prefix -> timestamp - ;; Else prefix non-standard item start with timestamp - (insert (time-stamp-string))) - (append-to-file temp-point (todo-item-end 'include-sep) todo-file-done) - (delete-region temp-point (todo-item-end 'include-sep))) - (todo-backward-item) - (message ""))) - -;; --------------------------------------------------------------------------- - -;; Utility functions: - - -;;;###autoload -(defun todo-top-priorities (&optional nof-priorities category-pr-page - interactive) - "List top priorities for each category. - -Number of entries for each category is given by NOF-PRIORITIES which -defaults to `todo-show-priorities'. - -If CATEGORY-PR-PAGE is non-nil, a page separator `^L' is inserted -between each category. -INTERACTIVE should be non-nil if this function is called interactively." - - (interactive "P\ni\nP") - (or nof-priorities (setq nof-priorities todo-show-priorities)) - (if (listp nof-priorities) ;universal argument - (setq nof-priorities (car nof-priorities))) - (let ((todo-print-buffer-name todo-tmp-buffer-name) - ;;(todo-print-category-number 0) - (todo-category-break (if category-pr-page " " "")) - (cat-end - (concat - (if todo-remove-separator - (concat todo-category-end "\n" - (regexp-quote todo-prefix) " " todo-category-sep "\n") - (concat todo-category-end "\n")))) - beg end) - (save-excursion - (todo-show) - (save-restriction - (save-current-buffer - (widen) - (copy-to-buffer todo-print-buffer-name (point-min) (point-max)) - (set-buffer todo-print-buffer-name) - (goto-char (point-min)) - (when (re-search-forward (regexp-quote todo-header) nil t) - (beginning-of-line 1) - (delete-region (point) (line-end-position))) - (while (re-search-forward ;Find category start - (regexp-quote (concat todo-prefix todo-category-beg)) - nil t) - (setq beg (+ (line-end-position) 1)) ;Start of first entry. - (re-search-forward cat-end nil t) - (setq end (match-beginning 0)) - (replace-match todo-category-break) - (narrow-to-region beg end) ;In case we have too few entries. - (goto-char (point-min)) - (if (zerop nof-priorities) ;Traverse entries. - (goto-char end) ;All entries - (todo-forward-item nof-priorities)) - (setq beg (point)) - (delete-region beg end) - (widen)) - (and (looking-at " ") (replace-match "")) ;Remove trailing form-feed. - (goto-char (point-min)) ;Due to display buffer - ))) - (when interactive (display-buffer todo-print-buffer-name)) - (message "Type C-x 1 to remove %s window. M-C-v to scroll the help." - todo-print-buffer-name))) - -(defun todo-save-top-priorities (&optional nof-priorities) - "Save top priorities for each category in `todo-file-top'. - -Number of entries for each category is given by NOF-PRIORITIES which -defaults to `todo-show-priorities'." - (interactive "P") - (save-window-excursion - (save-excursion - (save-restriction - (todo-top-priorities nof-priorities) - (set-buffer todo-tmp-buffer-name) - (write-file todo-file-top) - (kill-this-buffer))))) - -;;;###autoload -(defun todo-print (&optional category-pr-page) - "Print todo summary using `todo-print-function'. -If CATEGORY-PR-PAGE is non-nil, a page separator `^L' is inserted -between each category. - -Number of entries for each category is given by `todo-print-priorities'." - (interactive "P") - (save-window-excursion - (save-excursion - (save-restriction - (todo-top-priorities todo-print-priorities - category-pr-page) - (set-buffer todo-tmp-buffer-name) - (and (funcall todo-print-function) - (kill-this-buffer)) - (message "Todo printing done."))))) - -(defun todo-jump-to-category () - "Jump to a category. Default is previous category." - (interactive) - (let ((category (todo-completing-read))) - (if (string= "" category) - (setq category (nth todo-category-number todo-categories))) - (setq todo-category-number - (if (member category todo-categories) - (- (length todo-categories) - (length (member category todo-categories))) - (todo-add-category category))) - (todo-show))) - -(defun todo-line-string () - "Return current line in buffer as a string." - (buffer-substring (line-beginning-position) (line-end-position))) - -(defun todo-item-string-start () - "Return the start of this TODO list entry as a string." - ;; Suitable for putting in the minibuffer when asking the user - (let ((item (todo-item-string))) - (if (> (length item) 60) - (setq item (concat (substring item 0 56) "..."))) - item)) - -(defun todo-item-start () - "Go to start of current TODO list item and return point." - (beginning-of-line) - (if (not (looking-at (regexp-quote todo-prefix))) - (search-backward-regexp - (concat "^" (regexp-quote todo-prefix)) nil t)) - (point)) - -(defun todo-item-end (&optional include-sep) - "Return point at end of current TODO list item. -If INCLUDE-SEP is non-nil, return point after the separator." - (save-excursion - (end-of-line) - (if (search-forward-regexp - (concat "^" (regexp-quote todo-prefix)) nil 'goto-end) - (goto-char (match-beginning 0))) - (unless include-sep (skip-chars-backward "\n")) - (point))) - -(defun todo-remove-item () - "Delete the current entry from the TODO list." - (delete-region (todo-item-start) (todo-item-end 'include-sep))) - -(defun todo-item-string () - "Return current TODO list entry as a string." - (buffer-substring (todo-item-start) (todo-item-end))) - -(defun todo-string-count-lines (string) - "Return the number of lines STRING spans." - (length (split-string string "\n"))) - -(defun todo-string-multiline-p (string) - "Return non-nil if STRING spans several lines." - (> (todo-string-count-lines string) 1)) - -(defun todo-completing-read () - "Return a category name, with completion, for use in Todo mode." - ;; make a copy of todo-categories in case history-delete-duplicates is - ;; non-nil, which makes completing-read alter todo-categories - (let* ((categories (copy-sequence todo-categories)) - (history (cons 'todo-categories (1+ todo-category-number))) - (default (nth todo-category-number todo-categories)) - (category (completing-read - (concat "Category [" default "]: ") - todo-categories nil nil nil history default))) - ;; restore the original value of todo-categories - (setq todo-categories categories) - category)) - -;; --------------------------------------------------------------------------- - -(easy-menu-define todo-menu todo-mode-map "Todo Menu" - '("Todo" - ["Next category" todo-forward-category t] - ["Previous category" todo-backward-category t] - ["Jump to category" todo-jump-to-category t] - ["Show top priority items" todo-top-priorities t] - ["Print categories" todo-print t] - "---" - ["Edit item" todo-edit-item t] - ["File item" todo-file-item t] - ["Insert new item" todo-insert-item t] - ["Insert item here" todo-insert-item-here t] - ["Kill item" todo-delete-item t] - "---" - ["Lower item priority" todo-lower-item t] - ["Raise item priority" todo-raise-item t] - "---" - ["Next item" todo-forward-item t] - ["Previous item" todo-backward-item t] - "---" - ["Save" todo-save t] - ["Save Top Priorities" todo-save-top-priorities t] - "---" - ["Quit" todo-quit t] - )) - -;; As calendar reads todo-file-do before todo-mode is loaded. -;;;###autoload -(define-derived-mode todo-mode nil "TODO" - "Major mode for editing TODO lists." - nil) - -(with-suppressed-warnings ((lexical date entry)) - (defvar date) - (defvar entry)) - -;; t-c should be used from diary code, which requires calendar. -(declare-function calendar-current-date "calendar" (&optional offset)) - -;; Read about this function in the setup instructions above! -;;;###autoload -(defun todo-cp () - "Make a diary entry appear only in the current date's diary." - (if (equal (calendar-current-date) date) - entry)) - -(define-derived-mode todo-edit-mode text-mode "TODO Edit" - "Major mode for editing items in the TODO list. - -\\{todo-edit-mode-map}") - -;;;###autoload -(defun todo-show () - "Show TODO list." - (interactive) - ;; Call todo-initial-setup only if there is neither a Todo file nor - ;; a corresponding unsaved buffer. - (if (or (file-exists-p todo-file-do) - (let* ((buf (get-buffer (file-name-nondirectory todo-file-do))) - (bufname (buffer-file-name buf))) - (equal (expand-file-name todo-file-do) bufname))) - (find-file todo-file-do) - (todo-initial-setup)) - (if (null todo-categories) - (if (null todo-cats) - (error "Error in %s: No categories in list `todo-categories'" - todo-file-do) - (goto-char (point-min)) - (and (search-forward "todo-cats:" nil t) - (replace-match "todo-categories:")) - (make-local-variable 'todo-categories) - (setq todo-categories todo-cats))) - (beginning-of-line) - (todo-category-select)) - -(defun todo-initial-setup () - "Set up things to work properly in TODO mode." - (find-file todo-file-do) - (erase-buffer) - (todo-mode) - (todo-add-category "Todo")) - -(provide 'todo-mode) - -;;; otodo-mode.el ends here diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el deleted file mode 100644 index 258b2b519d9..00000000000 --- a/lisp/obsolete/rcompile.el +++ /dev/null @@ -1,180 +0,0 @@ -;;; rcompile.el --- run a compilation on a remote machine -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1994, 2001-2024 Free Software Foundation, Inc. - -;; Author: Alon Albert <alon@milcse.rtsg.mot.com> -;; Maintainer: emacs-devel@gnu.org -;; Created: 1993 Oct 6 -;; Keywords: tools, processes -;; Obsolete-since: 24.4 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package is for running a remote compilation and using emacs to parse -;; the error messages. It works by rsh'ing the compilation to a remote host -;; and parsing the output. If the file visited at the time remote-compile was -;; called was loaded remotely (ange-ftp), the host and user name are obtained -;; by the calling ange-ftp-ftp-name on the current directory. In this case the -;; next-error command will also ange-ftp the files over. This is achieved -;; automatically because the compilation-parse-errors function uses -;; default-directory to build its file names. If however the file visited was -;; loaded locally, remote-compile prompts for a host and user and assumes the -;; files mounted locally (otherwise, how was the visited file loaded). - -;; See the user defined variables section for more info. - -;; I was contemplating redefining "compile" to "remote-compile" automatically -;; if the file visited was ange-ftp'ed but decided against it for now. If you -;; feel this is a good idea, let me know and I'll consider it again. - -;; Installation: - -;; To use rcompile, you also need to give yourself permission to connect to -;; the remote host. You do this by putting lines like: - -;; monopoly alon -;; vme33 -;; -;; in a file named .rhosts in the home directory (of the remote machine). -;; Be careful what you put in this file. A line like: -;; -;; + -;; -;; Will allow anyone access to your account without a password. I suggest you -;; read the rhosts(5) manual page before you edit this file (if you are not -;; familiar with it already) - -;;; Code: - -(provide 'rcompile) -(require 'compile) -;;; The following should not be needed. -;;; (eval-when-compile (require 'ange-ftp)) - -;;;; user defined variables - -(defgroup remote-compile nil - "Run a compilation on a remote machine." - :group 'processes - :group 'tools) - - -(defcustom remote-compile-host nil - "Host for remote compilations." - :type '(choice string (const nil))) - -(defcustom remote-compile-user nil - "User for remote compilations. -nil means use the value returned by \\[user-login-name]." - :type '(choice string (const nil))) - -(defcustom remote-compile-run-before nil - "Command to run before compilation. -This can be used for setting up environment variables, -since rsh does not invoke the shell as a login shell and files like .login -\(tcsh) and .bash_profile \(bash) are not run. -nil means run no commands." - :type '(choice string (const nil))) - -(defcustom remote-compile-prompt-for-host nil - "Non-nil means prompt for host if not available from filename." - :type 'boolean) - -(defcustom remote-compile-prompt-for-user nil - "Non-nil means prompt for user if not available from filename." - :type 'boolean) - -;;;; internal variables - -;; History of remote compile hosts and users -(defvar remote-compile-host-history nil) -(defvar remote-compile-user-history nil) - - -;;;; entry point - -;; We use the Tramp internal function `tramp-make-tramp-file-name'. -;; It has changed its signature in Emacs 27.1, supporting still the -;; old calling convention. Let's assume rcompile.el has been removed -;; once Tramp does not support it any longer. -;; Better would be, if there are functions to provide user, host and -;; localname of a remote filename, independent of Tramp's implementation. -;; The function calls are wrapped by `funcall' in order to pacify the byte -;; compiler. ange-ftp check removed, because it is handled also by Tramp. -;;;###autoload -(defun remote-compile (host user command) - "Compile the current buffer's directory on HOST. Log in as USER. -See \\[compile]." - (interactive - (let (host user command prompt) ;; l l-host l-user - (setq prompt (if (stringp remote-compile-host) - (format "Compile on host (default %s): " - remote-compile-host) - "Compile on host: ") - host (if (or remote-compile-prompt-for-host - (null remote-compile-host)) - (read-from-minibuffer prompt - "" nil nil - 'remote-compile-host-history) - remote-compile-host) - user (if remote-compile-prompt-for-user - (read-from-minibuffer (format - "Compile by user (default %s): " - (or remote-compile-user - (user-login-name))) - "" nil nil - 'remote-compile-user-history) - remote-compile-user)) - (setq command (read-from-minibuffer "Compile command: " - compile-command nil nil - '(compile-history . 1))) - (list (if (string= host "") remote-compile-host host) - (if (string= user "") remote-compile-user user) - command))) - (setq compile-command command) - (cond (user - (setq remote-compile-user user)) - ((null remote-compile-user) - (setq remote-compile-user (user-login-name)))) - (let* (;; localname ;; Pacify byte-compiler. - (compile-command - (format "%s %s -l %s \"(%scd %s; %s)\"" - remote-shell-program - host - remote-compile-user - (if remote-compile-run-before - (concat remote-compile-run-before "; ") - "") - "" - compile-command))) - (setq remote-compile-host host) - (save-some-buffers nil nil) - (compilation-start compile-command) - ;; Set comint-file-name-prefix in the compilation buffer so - ;; compilation-parse-errors will find referenced files by Tramp. - (with-current-buffer next-error-last-buffer - (when (fboundp 'tramp-make-tramp-file-name) - (setq-local comint-file-name-prefix - (funcall - #'tramp-make-tramp-file-name - nil ;; method. - remote-compile-user - remote-compile-host - "")))))) - -;;; rcompile.el ends here diff --git a/lisp/obsolete/rlogin.el b/lisp/obsolete/rlogin.el index f285165ba21..d875405ac8b 100644 --- a/lisp/obsolete/rlogin.el +++ b/lisp/obsolete/rlogin.el @@ -99,10 +99,9 @@ re-syncing of directories." :type '(choice (const :tag "off" nil) (const :tag "ftp" t) (other :tag "local" local)) + :local t :group 'rlogin) -(make-variable-buffer-local 'rlogin-directory-tracking-mode) - (defcustom rlogin-host nil "The name of the default remote host. This variable is buffer-local." :type '(choice (const nil) string) diff --git a/lisp/obsolete/sup-mouse.el b/lisp/obsolete/sup-mouse.el deleted file mode 100644 index e7bb58950a0..00000000000 --- a/lisp/obsolete/sup-mouse.el +++ /dev/null @@ -1,203 +0,0 @@ -;;; sup-mouse.el --- supdup mouse support for lisp machines -*- lexical-binding: t; -*- - -;; Copyright (C) 1985-1986, 2001-2024 Free Software Foundation, Inc. - -;; Author: Wolfgang Rupprecht -;; Maintainer: emacs-devel@gnu.org -;; Created: 21 Nov 1986 -;; Keywords: hardware -;; Obsolete-since: 24.4 - -;; (from code originally written by John Robinson@bbn for the bitgraph) - -;; 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: - -;;; User customization option: - -(defcustom sup-mouse-fast-select-window nil - "Non-nil means mouse hits select new window, then execute. -Otherwise just select." - :type 'boolean - :group 'mouse) - -(defconst mouse-left 0) -(defconst mouse-center 1) -(defconst mouse-right 2) - -(defconst mouse-2left 4) -(defconst mouse-2center 5) -(defconst mouse-2right 6) - -(defconst mouse-3left 8) -(defconst mouse-3center 9) -(defconst mouse-3right 10) - -;;; Defuns: - -(defun sup-mouse-report () - "This function is called directly by the mouse, it parses and -executes the mouse commands. - - L move point * |---- These apply for mouse click in a window. -2L delete word | -3L copy word | If sup-mouse-fast-select-window is nil, - C move point and yank * | just selects that window. -2C yank pop | - R set mark * | -2R delete region | -3R copy region | - -on mode line on \"scroll bar\" in minibuffer - L scroll-up line to top execute-extended-command - C proportional goto-char line to middle mouse-help - R scroll-down line to bottom eval-expression" - - (interactive) - (let* -;; expect a string of <esc>:<buttons>;<x-pos>;<y-pos>c - ((buttons (sup-get-tty-num ?\;)) - (x (sup-get-tty-num ?\;)) - (y (sup-get-tty-num ?c)) - (window (sup-pos-to-window x y)) - (edges (window-edges window)) - (old-window (selected-window)) - (in-minibuf-p (eq y (1- (frame-height)))) - (same-window-p (and (not in-minibuf-p) (eq window old-window))) - (in-mode-line-p (eq y (1- (nth 3 edges)))) - (in-scrollbar-p (>= x (1- (nth 2 edges))))) - (setq x (- x (nth 0 edges))) - (setq y (- y (nth 1 edges))) - -; (error "mouse-hit %d %d %d" buttons x y) ;;;; debug - - (cond (in-mode-line-p - (select-window window) - (cond ((= buttons mouse-left) - (scroll-up)) - ((= buttons mouse-right) - (scroll-down)) - ((= buttons mouse-center) - (goto-char (/ (* x - (- (point-max) (point-min))) - (1- (window-width)))) - (beginning-of-line) - (what-cursor-position))) - (select-window old-window)) - (in-scrollbar-p - (select-window window) - (scroll-up - (cond ((= buttons mouse-left) - y) - ((= buttons mouse-right) - (+ y (- 2 (window-height)))) - ((= buttons mouse-center) - (/ (+ 2 y y (- (window-height))) 2)) - (t - 0))) - (select-window old-window)) - (same-window-p - (cond ((= buttons mouse-left) - (sup-move-point-to-x-y x y)) - ((= buttons mouse-2left) - (sup-move-point-to-x-y x y) - (kill-word 1)) - ((= buttons mouse-3left) - (sup-move-point-to-x-y x y) - (save-excursion - (copy-region-as-kill - (point) (progn (forward-word 1) (point)))) - (setq this-command 'yank) - ) - ((= buttons mouse-right) - (push-mark) - (sup-move-point-to-x-y x y) - (exchange-point-and-mark)) - ((= buttons mouse-2right) - (push-mark) - (sup-move-point-to-x-y x y) - (kill-region (mark) (point))) - ((= buttons mouse-3right) - (push-mark) - (sup-move-point-to-x-y x y) - (copy-region-as-kill (mark) (point)) - (setq this-command 'yank)) - ((= buttons mouse-center) - (sup-move-point-to-x-y x y) - (setq this-command 'yank) - (yank)) - ((= buttons mouse-2center) - (yank-pop 1)) - ) - ) - (in-minibuf-p - (cond ((= buttons mouse-right) - (call-interactively 'eval-expression)) - ((= buttons mouse-left) - (call-interactively 'execute-extended-command)) - ((= buttons mouse-center) - (describe-function 'sup-mouse-report)); silly self help - )) - (t ;in another window - (select-window window) - (cond ((not sup-mouse-fast-select-window)) - ((= buttons mouse-left) - (sup-move-point-to-x-y x y)) - ((= buttons mouse-right) - (push-mark) - (sup-move-point-to-x-y x y) - (exchange-point-and-mark)) - ((= buttons mouse-center) - (sup-move-point-to-x-y x y) - (setq this-command 'yank) - (yank)) - )) - ))) - - -(defun sup-get-tty-num (term-char) - "Read from terminal until TERM-CHAR is read, and return intervening number. -Upon non-numeric not matching TERM-CHAR signal an error." - (let - ((num 0) - (char (read-char))) - (while (and (>= char ?0) - (<= char ?9)) - (setq num (+ (* num 10) (- char ?0))) - (setq char (read-char))) - (or (eq term-char char) - (error "Invalid data format in mouse command")) - num)) - -(defun sup-move-point-to-x-y (x y) - "Position cursor in window coordinates. -X and Y are 0-based character positions in the window." - (move-to-window-line y) - (move-to-column x) - ) - -(defun sup-pos-to-window (x y) - "Find window corresponding to frame coordinates. -X and Y are 0-based character positions on the frame." - (get-window-with-predicate (lambda (w) - (coordinates-in-window-p (cons x y) w)))) - -(provide 'sup-mouse) - -;;; sup-mouse.el ends here diff --git a/lisp/obsolete/terminal.el b/lisp/obsolete/terminal.el deleted file mode 100644 index 13667589c9e..00000000000 --- a/lisp/obsolete/terminal.el +++ /dev/null @@ -1,1333 +0,0 @@ -;;; terminal.el --- terminal emulator for GNU Emacs -*- lexical-binding: t; -*- - -;; Copyright (C) 1986-1989, 1993-1994, 2001-2024 Free Software -;; Foundation, Inc. - -;; Author: Richard Mlynarik <mly@eddie.mit.edu> -;; Maintainer: emacs-devel@gnu.org -;; Obsolete-since: 24.4 -;; Keywords: comm, terminals - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This file has been censored by the Communications Decency Act. -;; That law was passed under the guise of a ban on pornography, but -;; it bans far more than that. This file did not contain pornography, -;; but it was censored nonetheless. - -;; For information on US government censorship of the Internet, and -;; what you can do to bring back freedom of the press, see the web -;; site https://www.eff.org/ [used to be vtw.org but that link is dead] - -;;; Code: - -;;>>TODO -;;>> ** Nothing can be done about emacs' meta-lossage ** -;;>> (without redoing keymaps `sanely' -- ask Mly for details) - -;;>> One probably wants to do setenv MORE -c when running with -;;>> more-processing enabled. - -(require 'ehelp) -(require 'shell) - -(defgroup terminal nil - "Terminal emulator for Emacs." - :group 'terminals) - - -(defcustom terminal-escape-char ?\C-^ - "All characters except for this are passed verbatim through the -terminal-emulator. This character acts as a prefix for commands -to the emulator program itself. Type this character twice to send -it through the emulator. Type ? after typing it for a list of -possible commands. -This variable is local to each terminal-emulator buffer." - :type 'character) - -(defcustom terminal-scrolling t ;;>> Setting this to t sort-of defeats my whole aim in writing this package... - "If non-nil, the terminal-emulator will losingly `scroll' when output occurs -past the bottom of the screen. If nil, output will win and `wrap' to the top -of the screen. -This variable is local to each terminal-emulator buffer." - :type 'boolean) - -(defcustom terminal-more-processing t - "If non-nil, do more-processing. -This variable is local to each terminal-emulator buffer." - :type 'boolean) - -;; If you are the sort of loser who uses scrolling without more breaks -;; and expects to actually see anything, you should probably set this to -;; around 400 -(defcustom terminal-redisplay-interval 5000 - "Maximum number of characters which will be processed by the -terminal-emulator before a screen redisplay is forced. -Set this to a large value for greater throughput, -set it smaller for more frequent updates but overall slower -performance." - :type 'integer) - -(defvar terminal-more-break-insertion - "*** More break -- Press space to continue ***") - -(defvar terminal-meta-map nil) -(if terminal-meta-map - nil - (let ((map (make-sparse-keymap))) - (define-key map [t] #'te-pass-through) - (setq terminal-meta-map map))) - -(defvar terminal-map nil) -(if terminal-map - nil - (let ((map (make-sparse-keymap))) - ;; Prevent defining [menu-bar] as te-pass-through - ;; so we allow the global menu bar to be visible. - (define-key map [menu-bar] (make-sparse-keymap)) - (define-key map [t] #'te-pass-through) - (define-key map [switch-frame] #'handle-switch-frame) - (define-key map "\e" terminal-meta-map) - ;;(define-key map "\C-l" - ;; (lambda () (interactive) (te-pass-through) (redraw-display))) - (setq terminal-map map))) - -(defvar terminal-escape-map nil) -(if terminal-escape-map - nil - (let ((map (make-sparse-keymap))) - (define-key map [t] #'undefined) - (dotimes (i 10) - (let ((s (make-string 1 (+ ?0 i)))) - (define-key map s #'digit-argument))) - (define-key map "b" #'switch-to-buffer) - (define-key map "o" #'other-window) - (define-key map "e" #'te-set-escape-char) - (define-key map "\C-l" #'redraw-display) - (define-key map "\C-o" #'te-flush-pending-output) - (define-key map "m" #'te-toggle-more-processing) - (define-key map "x" #'te-escape-extended-command) - ;;>> What use is this? Why is it in the default terminal-emulator map? - (define-key map "w" #'te-edit) - (define-key map "?" #'te-escape-help) - (define-key map (char-to-string help-char) #'te-escape-help) - (setq terminal-escape-map map))) - -(defvar te-escape-command-alist nil) -(if te-escape-command-alist - nil - (setq te-escape-command-alist - '(("Set Escape Character" . te-set-escape-char) - ;;>> What use is this? Why is it in the default terminal-emulator map? - ("Edit" . te-edit) - ("Refresh" . redraw-display) - ("Record Output" . te-set-output-log) - ("Photo" . te-set-output-log) - ("Tofu" . te-tofu) ;; confuse the uninitiated - ("Stuff Input" . te-stuff-string) - ("Flush Pending Output" . te-flush-pending-output) - ("Enable More Processing" . te-enable-more-processing) - ("Disable More Processing" . te-disable-more-processing) - ("Scroll at end of page" . te-do-scrolling) - ("Wrap at end of page" . te-do-wrapping) - ("Switch To Buffer" . switch-to-buffer) - ("Other Window" . other-window) - ("Kill Buffer" . kill-buffer) - ("Help" . te-escape-help) - ("Set Redisplay Interval" . te-set-redisplay-interval) - ))) - -(defvar terminal-more-break-map nil) -(if terminal-more-break-map - nil - (let ((map (make-sparse-keymap))) - (define-key map [t] #'te-more-break-unread) - (define-key map (char-to-string help-char) #'te-more-break-help) - (define-key map " " #'te-more-break-resume) - (define-key map "\C-l" #'redraw-display) - (define-key map "\C-o" #'te-more-break-flush-pending-output) - ;;>>> this isn't right - ;(define-key map "\^?" #'te-more-break-flush-pending-output) ;DEL - (define-key map "\r" #'te-more-break-advance-one-line) - - (setq terminal-more-break-map map))) - - -;;; Pacify the byte compiler -(defvar te-process nil) -(defvar te-log-buffer nil) -(defvar te-height nil) -(defvar te-width nil) -(defvar te-more-count nil) -(defvar te-redisplay-count nil) -(defvar te-pending-output nil) -(defvar te-saved-point) -(defvar te-more-old-point nil) -(defvar te-more-old-local-map nil) -(defvar te-more-old-filter nil) -(defvar te-more-old-mode-line-format nil) -(defvar te-pending-output-info nil) - -;; Required to support terminfo systems -(defconst te-terminal-name-prefix "emacs-em" - "Prefix used for terminal type names for Terminfo.") -(defconst te-terminfo-directory - (file-name-as-directory - (expand-file-name "emacs-terminfo" temporary-file-directory)) - "Directory used for run-time terminal definition files for Terminfo.") -(defvar te-terminal-name nil) - -;;;; escape map - -(defun te-escape () - (interactive) - (let (s - (local (current-local-map)) - (global (current-global-map))) - (unwind-protect - (progn - (use-global-map terminal-escape-map) - (use-local-map terminal-escape-map) - (setq s (read-key-sequence - (if current-prefix-arg - (format "Emacs Terminal escape[%s for help]> %d " - (substitute-command-keys - "\\<terminal-escape-map>\\[te-escape-help]") - (prefix-numeric-value current-prefix-arg)) - (format "Emacs Terminal escape[%s for help]> " - (substitute-command-keys - "\\<terminal-escape-map>\\[te-escape-help]")))))) - (use-global-map global) - (use-local-map local)) - - (message "") - - (cond - ;; Certain keys give vector notation, like [escape] when - ;; you hit esc key... - ((and (stringp s) - (string= s (make-string 1 terminal-escape-char))) - (setq last-command-event terminal-escape-char) - (let ((terminal-escape-char -259)) - (te-pass-through))) - - ((setq s (lookup-key terminal-escape-map s)) - (call-interactively s))) - - )) - - -(defun te-escape-help () - "Provide help on commands available after terminal-escape-char is typed." - (interactive) - (message "Terminal emulator escape help...") - (let ((char (single-key-description terminal-escape-char))) - (with-electric-help - (function (lambda () - (princ (format "Terminal-emulator escape, invoked by \"%s\" -Type \"%s\" twice to send a single \"%s\" through. - -Other chars following \"%s\" are interpreted as follows:\n" - char char char char)) - - (princ (substitute-command-keys "\\{terminal-escape-map}\n")) - (princ (format "\nSubcommands of \"%s\" (%s)\n" - (where-is-internal 'te-escape-extended-command - terminal-escape-map t) - 'te-escape-extended-command)) - (let ((l (sort (copy-sequence te-escape-command-alist) - (function (lambda (a b) - (string< (car a) (car b))))))) - (while l - (let ((doc (or (documentation (cdr (car l))) - "Not documented"))) - (if (string-match "\n" doc) - ;; just use first line of documentation - (setq doc (substring doc 0 (match-beginning 0)))) - (princ " \"") - (princ (car (car l))) - (princ "\":\n ") - (princ doc) - (write-char ?\n)) - (setq l (cdr l)))) - nil))))) - - - -(defun te-escape-extended-command () - (interactive) - (let ((c (let ((completion-ignore-case t)) - (completing-read "terminal command: " - te-escape-command-alist - nil t)))) - (if c - (catch 'foo - (setq c (downcase c)) - (let ((l te-escape-command-alist)) - (while l - (if (string= c (downcase (car (car l)))) - (throw 'foo (call-interactively (cdr (car l)))) - (setq l (cdr l))))))))) - -;; not used. -(defun te-escape-extended-command-unread () - (interactive) - (setq unread-command-events - (nconc (listify-key-sequence (this-command-keys)) - unread-command-events)) - (te-escape-extended-command)) - -(defun te-set-escape-char (c) - "Change the terminal-emulator escape character." - (interactive "cSet escape character to: ") - (let ((o terminal-escape-char)) - (message (if (= o c) - "\"%s\" is the escape char" - "\"%s\" is now the escape; \"%s\" passes through") - (single-key-description c) - (single-key-description o)) - (setq terminal-escape-char c))) - - -(defun te-stuff-string (string) - "Read a string to send to through the terminal emulator -as though that string had been typed on the keyboard. - -Very poor man's file transfer protocol." - (interactive "sStuff string: ") - (process-send-string te-process string)) - -(defun te-set-output-log (name) - "Record output from the terminal emulator in a buffer." - (interactive (list (if te-log-buffer - nil - (read-buffer "Record output in buffer: " - (format "%s output-log" - (buffer-name (current-buffer))) - nil)))) - (if (or (null name) (equal name "")) - (progn (setq te-log-buffer nil) - (message "Output logging off.")) - (if (get-buffer name) - nil - (with-current-buffer (get-buffer-create name) - (fundamental-mode) - (buffer-disable-undo (current-buffer)) - (erase-buffer))) - (setq te-log-buffer (get-buffer name)) - (message "Recording terminal emulator output into buffer \"%s\"" - (buffer-name te-log-buffer)))) - -(defun te-tofu () - "Discontinue output log." - (interactive) - (te-set-output-log nil)) - - -(defun te-toggle (sym arg) - (set sym (cond ((not (numberp arg)) arg) - ((= arg 1) (not (symbol-value sym))) - ((< arg 0) nil) - (t t)))) - -(defun te-toggle-more-processing (arg) - (interactive "p") - (message (if (te-toggle 'terminal-more-processing arg) - "More processing on" "More processing off")) - (if terminal-more-processing (setq te-more-count -1))) - -(defun te-toggle-scrolling (arg) - (interactive "p") - (message (if (te-toggle 'terminal-scrolling arg) - "Scroll at end of page" "Wrap at end of page"))) - -(defun te-enable-more-processing () - "Enable ** MORE ** processing" - (interactive) - (te-toggle-more-processing t)) - -(defun te-disable-more-processing () - "Disable ** MORE ** processing" - (interactive) - (te-toggle-more-processing nil)) - -(defun te-do-scrolling () - "Scroll at end of page (yuck)" - (interactive) - (te-toggle-scrolling t)) - -(defun te-do-wrapping () - "Wrap to top of window at end of page" - (interactive) - (te-toggle-scrolling nil)) - - -(defun te-set-redisplay-interval (arg) - "Set the maximum interval (in output characters) between screen updates. -Set this number to large value for greater throughput, -set it smaller for more frequent updates (but overall slower performance." - (interactive "NMax number of output chars between redisplay updates: ") - (setq arg (max arg 1)) - (setq terminal-redisplay-interval arg - te-redisplay-count 0)) - -;;;; more map - -;; every command -must- call te-more-break-unwind -;; or grave lossage will result - -(put 'te-more-break-unread 'suppress-keymap t) -(defun te-more-break-unread () - (interactive) - (if (eq last-input-event terminal-escape-char) - (call-interactively 'te-escape) - (message "Continuing from more break (\"%s\" typed, %d chars output pending...)" - (single-key-description last-input-event) - (te-pending-output-length)) - (setq te-more-count 259259) - (te-more-break-unwind) - (let ((terminal-more-processing nil)) - (te-pass-through)))) - -(defun te-more-break-resume () - "Proceed past the **MORE** break, -allowing the next page of output to appear" - (interactive) - (message "Continuing from more break") - (te-more-break-unwind)) - -(defun te-more-break-help () - "Provide help on commands available in a terminal-emulator **MORE** break" - (interactive) - (message "Terminal-emulator more break help...") - (sit-for 0) - (with-electric-help - (function (lambda () - (princ "Terminal-emulator more break.\n\n") - (princ (format "Type \"%s\" (te-more-break-resume)\n%s\n" - (where-is-internal 'te-more-break-resume - terminal-more-break-map t) - (documentation 'te-more-break-resume))) - (princ (substitute-command-keys "\\{terminal-more-break-map}\n")) - (princ "Any other key is passed through to the program -running under the terminal emulator and disables more processing until -all pending output has been dealt with.") - nil)))) - - -(defun te-more-break-advance-one-line () - "Allow one more line of text to be output before doing another more break." - (interactive) - (setq te-more-count 1) - (te-more-break-unwind)) - -(defun te-more-break-flush-pending-output () - "Discard any output which has been received by the terminal emulator but -not yet processed and then proceed from the more break." - (interactive) - (te-more-break-unwind) - (te-flush-pending-output)) - -(defun te-flush-pending-output () - "Discard any as-yet-unprocessed output which has been received by -the terminal emulator." - (interactive) - ;; this could conceivably be confusing in the presence of - ;; escape-sequences spanning process-output chunks - (if (null (cdr te-pending-output)) - (message "(There is no output pending)") - (let ((length (te-pending-output-length))) - (message "Flushing %d chars of pending output" length) - (setq te-pending-output - (list 0 (format "\n*** %d chars of pending output flushed ***\n" - length))) - (te-update-pending-output-display) - (te-process-output nil) - (sit-for 0)))) - - -(defun te-pass-through () - "Character is passed to the program running under the terminal emulator. -One characters is treated specially: -the terminal escape character (normally C-^) -lets you type a terminal emulator command." - (interactive) - (cond ((eq last-input-event terminal-escape-char) - (call-interactively 'te-escape)) - (t - ;; Convert `return' to C-m, etc. - (if (and (symbolp last-input-event) - (get last-input-event 'ascii-character)) - (setq last-input-event (get last-input-event 'ascii-character))) - ;; Convert meta characters to 8-bit form for transmission. - (if (and (integerp last-input-event) - (not (zerop (logand last-input-event ?\M-\^@)))) - (setq last-input-event (+ 128 (logand last-input-event 127)))) - ;; Now ignore all but actual characters. - ;; (It ought to be possible to send through function - ;; keys as character sequences if we add a description - ;; to our termcap entry of what they should look like.) - (if (integerp last-input-event) - (progn - (and terminal-more-processing (null (cdr te-pending-output)) - (te-set-more-count nil)) - (process-send-string te-process (make-string 1 last-input-event)) - (te-process-output t)) - (message "Function key `%s' ignored" - (single-key-description last-input-event)))))) - - -(defun te-set-window-start () - (let* ((w (get-buffer-window (current-buffer))) - (h (if w (window-height w)))) - (cond ((not w)) ; buffer not displayed - ((>= h (/ (- (point) (point-min)) (1+ te-width))) - ;; this is the normal case - (set-window-start w (point-min))) - ;; this happens if some vandal shrinks our window. - ((>= h (/ (- (point-max) (point)) (1+ te-width))) - (set-window-start w (- (point-max) (* h (1+ te-width)) -1))) - ;; I give up. - (t nil)))) - -(defun te-pending-output-length () - (let ((length (car te-pending-output)) - (tem (cdr te-pending-output))) - (while tem - (setq length (+ length (length (car tem))) tem (cdr tem))) - length)) - -;;>> What use is this terminal-edit stuff anyway? -;;>> If nothing else, it was written by somebody who didn't -;;>> competently understand the terminal-emulator... - -(defvar terminal-edit-map nil) -(if terminal-edit-map - nil - (setq terminal-edit-map (make-sparse-keymap)) - (define-key terminal-edit-map "\C-c\C-c" #'terminal-cease-edit)) - -;; Terminal Edit mode is suitable only for specially formatted data. -(put 'terminal-edit-mode 'mode-class 'special) - -(defun terminal-edit-mode () - "Major mode for editing the contents of a terminal-emulator buffer. -The editing commands are the same as in Fundamental mode, -together with a command \\<terminal-edit-map>to return to terminal emulation: \\[terminal-cease-edit]." - (use-local-map terminal-edit-map) - (setq major-mode 'terminal-edit-mode) - (setq mode-name "Terminal Edit") - (setq mode-line-modified (default-value 'mode-line-modified)) - (setq mode-line-process nil) - (run-mode-hooks 'terminal-edit-mode-hook)) - -(defun te-edit () - "Start editing the terminal emulator buffer with ordinary Emacs commands." - (interactive) - (terminal-edit-mode) - (force-mode-line-update) - ;; Make mode line update. - (if (eq (key-binding "\C-c\C-c") 'terminal-cease-edit) - (message "Editing: Type C-c C-c to return to Terminal") - (message "%s" - (substitute-command-keys - "Editing: Type \\[terminal-cease-edit] to return to Terminal")))) - -(defun terminal-cease-edit () - "Finish editing message; switch back to Terminal proper." - (interactive) - - ;;>> emulator will blow out if buffer isn't exactly te-width x te-height - (let ((buffer-read-only nil)) - (widen) - (let ((opoint (point-marker)) - (width te-width) - (h (1- te-height))) - (goto-char (point-min)) - (while (>= h 0) - (let ((p (point))) - (cond ((search-forward "\n" (+ p width) 'move) - (forward-char -1) - (insert-char ?\s (- width (- (point) p))) - (forward-char 1)) - ((eobp) - (insert-char ?\s (- width (- (point) p)))) - ((= (following-char) ?\n) - (forward-char 1)) - (t - (setq p (point)) - (if (search-forward "\n" nil t) - (delete-region p (1- (point))) - (delete-region p (point-max)))))) - (if (= h 0) - (if (not (eobp)) (delete-region (point) (point-max))) - (if (eobp) (insert ?\n))) - (setq h (1- h))) - (goto-char opoint) - (set-marker opoint nil nil) - (setq te-saved-point (point)) - (setq te-redisplay-count 0) - (setq te-more-count -1))) - - (setq mode-line-modified (default-value 'mode-line-modified)) - (use-local-map terminal-map) - (setq major-mode 'terminal-mode) - (setq mode-name "terminal") - (setq mode-line-process '(":%s"))) - -;;;; more break hair - -(defun te-more-break () - (te-set-more-count t) - (make-local-variable 'te-more-old-point) - (setq te-more-old-point (point)) - (make-local-variable 'te-more-old-local-map) - (setq te-more-old-local-map (current-local-map)) - (use-local-map terminal-more-break-map) - (make-local-variable 'te-more-old-filter) - (setq te-more-old-filter (process-filter te-process)) - (make-local-variable 'te-more-old-mode-line-format) - (setq te-more-old-mode-line-format mode-line-format - mode-line-format (list "-- **MORE** " - mode-line-buffer-identification - "%-")) - (set-process-filter te-process - (function (lambda (process string) - (with-current-buffer (process-buffer process) - (setq te-pending-output (nconc te-pending-output - (list string)))) - (te-update-pending-output-display)))) - (te-update-pending-output-display) - (if (eq (window-buffer (selected-window)) (current-buffer)) - (message "More break ")) - (or (eobp) - (null terminal-more-break-insertion) - (save-excursion - (forward-char 1) - (delete-region (point) (+ (point) te-width)) - (insert terminal-more-break-insertion))) - (run-hooks 'terminal-more-break-hook) - (sit-for 0) ;get display to update - (throw 'te-process-output t)) - -(defun te-more-break-unwind () - (use-local-map te-more-old-local-map) - (set-process-filter te-process te-more-old-filter) - (goto-char te-more-old-point) - (setq mode-line-format te-more-old-mode-line-format) - (force-mode-line-update) - (let ((buffer-read-only nil)) - (cond ((eobp)) - (terminal-more-break-insertion - (forward-char 1) - (delete-region (point) - (+ (point) (length terminal-more-break-insertion))) - (insert-char ?\s te-width) - (goto-char te-more-old-point))) - (setq te-more-old-point nil) - (let ((te-more-count 259259)) - (te-newline))) - ;(sit-for 0) - (te-process-output t)) - -(defun te-set-more-count (newline) - (let ((line (/ (- (point) (point-min)) (1+ te-width)))) - (if newline (setq line (1+ line))) - (cond ((= line te-height) - (setq te-more-count te-height)) - ;>>>> something is strange. Investigate this! - ((= line (1- te-height)) - (setq te-more-count te-height)) - ((or (< line (/ te-height 2)) - (> (- te-height line) 10)) - ;; break at end of this page - (setq te-more-count (- te-height line))) - (t - ;; migrate back towards top (ie bottom) of screen. - (setq te-more-count (- te-height - (if (> te-height 10) 2 1))))))) - - -;;;; More or less straight-forward terminal escapes - -;; ^j, meaning `newline' to non-display programs. -;; (Who would think of ever writing a system which doesn't understand -;; display terminals natively? Un*x: The Operating System of the Future.) -(defun te-newline () - "Move down a line, optionally do more processing, perhaps wrap/scroll, -move to start of new line, clear to end of line." - (end-of-line) - (cond ((not terminal-more-processing)) - ((< (setq te-more-count (1- te-more-count)) 0) - (te-set-more-count t)) - ((eq te-more-count 0) - ;; this doesn't return - (te-more-break))) - (if (eobp) - (progn - (delete-region (point-min) (+ (point-min) te-width)) - (goto-char (point-min)) - (if terminal-scrolling - (progn (delete-char 1) - (goto-char (point-max)) - (insert ?\n)))) - (forward-char 1) - (delete-region (point) (+ (point) te-width))) - (insert-char ?\s te-width) - (beginning-of-line) - (te-set-window-start)) - -; ^p = x+32 y+32 -(defun te-move-to-position () - ;; must offset by #o40 since cretinous unix won't send a 004 char through - (let ((y (- (te-get-char) 32)) - (x (- (te-get-char) 32))) - (if (or (> x te-width) - (> y te-height)) - () - (goto-char (+ (point-min) x (* y (1+ te-width)))) - ;(te-set-window-start?) - )) - (setq te-more-count -1)) - - - -;; ^p c -(defun te-clear-rest-of-line () - (save-excursion - (let ((n (- (point) (progn (end-of-line) (point))))) - (delete-region (point) (+ (point) n)) - (insert-char ?\s (- n))))) - - -;; ^p C -(defun te-clear-rest-of-screen () - (save-excursion - (te-clear-rest-of-line) - (while (progn (end-of-line) (not (eobp))) - (forward-char 1) (end-of-line) - (delete-region (- (point) te-width) (point)) - (insert-char ?\s te-width)))) - - -;; ^p ^l -(defun te-clear-screen () - ;; regenerate buffer to compensate for (nonexistent!!) bugs. - (erase-buffer) - (let ((i 0)) - (while (< i te-height) - (setq i (1+ i)) - (insert-char ?\s te-width) - (insert ?\n))) - (delete-region (1- (point-max)) (point-max)) - (goto-char (point-min)) - (setq te-more-count -1)) - - -;; ^p ^o count+32 -(defun te-insert-lines () - (if (not (bolp)) - ();(error "fooI") - (save-excursion - (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1)) - (n (min (- (te-get-char) ?\s) line)) - (i 0)) - (delete-region (- (point-max) (* n (1+ te-width))) (point-max)) - (if (eq (point) (point-max)) (insert ?\n)) - (while (< i n) - (setq i (1+ i)) - (insert-char ?\s te-width) - (or (eq i line) (insert ?\n)))))) - (setq te-more-count -1)) - - -;; ^p ^k count+32 -(defun te-delete-lines () - (if (not (bolp)) - ();(error "fooD") - (let* ((line (- te-height (/ (- (point) (point-min)) (1+ te-width)) -1)) - (n (min (- (te-get-char) ?\s) line)) - (i 0)) - (delete-region (point) - (min (+ (point) (* n (1+ te-width))) (point-max))) - (save-excursion - (goto-char (point-max)) - (while (< i n) - (setq i (1+ i)) - (insert-char ?\s te-width) - (or (eq i line) (insert ?\n)))))) - (setq te-more-count -1)) - -;; ^p ^a -(defun te-beginning-of-line () - (beginning-of-line)) - -;; ^p ^b -(defun te-backward-char () - (if (not (bolp)) - (backward-char 1))) - -;; ^p ^f -(defun te-forward-char () - (if (not (eolp)) - (forward-char 1))) - - -;; 0177 -(defun te-delete () - (if (bolp) - () - (delete-region (1- (point)) (point)) - (insert ?\s) - (forward-char -1))) - -;; ^p ^g -(defun te-beep () - (beep)) - - -;; ^p _ count+32 -(defun te-insert-spaces () - (let* ((p (point)) - (n (min (- (te-get-char) 32) - (- (progn (end-of-line) (point)) p)))) - (if (<= n 0) - nil - (delete-char (- n)) - (goto-char p) - (insert-char ?\s n)) - (goto-char p))) - -;; ^p d count+32 (should be ^p ^d but cretinous un*x won't send ^d chars!!!) -(defun te-delete-char () - (let* ((p (point)) - (n (min (- (te-get-char) 32) - (- (progn (end-of-line) (point)) p)))) - (if (<= n 0) - nil - (insert-char ?\s n) - (goto-char p) - (delete-char n)) - (goto-char p))) - - - -;; disgusting unix-required excrement -;; Are we living twenty years in the past yet? - -(defun te-losing-unix () - nil) - -;; ^i -(defun te-output-tab () - (let* ((p (point)) - (x (- p (progn (beginning-of-line) (point)))) - (l (min (- 8 (logand x 7)) - (progn (end-of-line) (- (point) p))))) - (goto-char (+ p l)))) - -;; ^p ^j -;; Handle the `do' or `nl' termcap capability. -;;>> I am not sure why this broken, obsolete, capability is here. -;;>> Perhaps it is for VIle. No comment was made about why it -;;>> was added (in "Sun Dec 6 01:22:27 1987 Richard Stallman") -(defun te-down-vertically-or-scroll () - "Move down a line vertically, or scroll at bottom." - (let ((column (current-column))) - (end-of-line) - (if (eobp) - (progn - (delete-region (point-min) (+ (point-min) te-width)) - (goto-char (point-min)) - (delete-char 1) - (goto-char (point-max)) - (insert ?\n) - (insert-char ?\s te-width) - (beginning-of-line)) - (forward-line 1)) - (move-to-column column)) - (te-set-window-start)) - -;; Also: -;; ^m => beginning-of-line (for which it -should- be using ^p ^a, right?!!) -;; ^g => te-beep (for which it should use ^p ^g) -;; ^h => te-backward-char (for which it should use ^p ^b) - - - -(defun te-filter (process string) - (with-current-buffer (process-buffer process) - (goto-char te-saved-point) - (and (bufferp te-log-buffer) - (if (null (buffer-name te-log-buffer)) - ;; killed - (setq te-log-buffer nil) - (set-buffer te-log-buffer) - (goto-char (point-max)) - (insert-before-markers string) - (set-buffer (process-buffer process)))) - (setq te-pending-output (nconc te-pending-output (list string))) - (te-update-pending-output-display) - (te-process-output (eq (current-buffer) - (window-buffer (selected-window)))) - (set-buffer (process-buffer process)) - (setq te-saved-point (point)))) - -;; (A version of the following comment which might be distractingly offensive -;; to some readers has been moved to term-nasty.el.) -;; unix lacks ITS-style tty control... -(defun te-process-output (preemptible) - ;;>> There seems no good reason to ever disallow preemption - (setq preemptible t) - (catch 'te-process-output - (let ((buffer-read-only nil) - (string nil) ostring start char (matchpos nil)) - (while (cdr te-pending-output) - (setq ostring string - start (car te-pending-output) - string (car (cdr te-pending-output)) - char (aref string start)) - (if (eq (setq start (1+ start)) (length string)) - (progn (setq te-pending-output - (cons 0 (cdr (cdr te-pending-output))) - start 0 - string (car (cdr te-pending-output))) - (te-update-pending-output-display)) - (setcar te-pending-output start)) - (if (and (> char ?\037) (< char ?\377)) - (cond ((eolp) - ;; unread char - (if (eq start 0) - (setq te-pending-output - (cons 0 (cons (make-string 1 char) - (cdr te-pending-output)))) - (setcar te-pending-output (1- start))) - (te-newline)) - ((null string) - (delete-char 1) (insert char) - (te-redisplay-if-necessary 1)) - (t - (let ((end (or (and (eq ostring string) matchpos) - (setq matchpos (string-match - "[\000-\037\177-\377]" - string start)) - (length string)))) - (delete-char 1) (insert char) - (setq char (point)) (end-of-line) - (setq end (min end (+ start (- (point) char)))) - (goto-char char) - (if (eq end matchpos) (setq matchpos nil)) - (delete-region (point) (+ (point) (- end start))) - (insert (if (and (eq start 0) - (eq end (length string))) - string - (substring string start end))) - (if (eq end (length string)) - (setq te-pending-output - (cons 0 (cdr (cdr te-pending-output)))) - (setcar te-pending-output end)) - (te-redisplay-if-necessary (1+ (- end start)))))) - ;; I suppose if I split the guts of this out into a separate - ;; function we could trivially emulate different terminals - ;; Who cares in any case? (Apart from stupid losers using rlogin) - (funcall - (if (eq char ?\^p) - (or (cdr (assq (te-get-char) - '((?= . te-move-to-position) - (?c . te-clear-rest-of-line) - (?C . te-clear-rest-of-screen) - (?\C-o . te-insert-lines) - (?\C-k . te-delete-lines) - ;; not necessary, but help sometimes. - (?\C-a . te-beginning-of-line) - (?\C-b . te-backward-char) - ;; should be C-d, but un*x - ;; pty's won't send \004 through! - ;; Can you believe this? - (?d . te-delete-char) - (?_ . te-insert-spaces) - ;; random - (?\C-f . te-forward-char) - (?\C-g . te-beep) - (?\C-j . te-down-vertically-or-scroll) - (?\C-l . te-clear-screen) - ))) - 'te-losing-unix) - (or (cdr (assq char - '((?\C-j . te-newline) - (?\177 . te-delete) - ;; Did I ask to be sent these characters? - ;; I don't remember doing so, either. - ;; (Perhaps some operating system or - ;; other is completely incompetent...) - (?\C-m . te-beginning-of-line) - (?\C-g . te-beep) - (?\C-h . te-backward-char) - (?\C-i . te-output-tab)))) - 'te-losing-unix))) - (te-redisplay-if-necessary 1)) - (and preemptible - (input-pending-p) - ;; preemptible output! Oh my!! - (throw 'te-process-output t))))) - ;; We must update window-point in every window displaying our buffer - (walk-windows (lambda (w) - (when (and (not (eq w (selected-window))) - (eq (window-buffer w) (current-buffer))) - (set-window-point w (point)))))) - -(defun te-get-char () - (if (cdr te-pending-output) - (let ((start (car te-pending-output)) - (string (car (cdr te-pending-output)))) - (prog1 (aref string start) - (if (eq (setq start (1+ start)) (length string)) - (setq te-pending-output (cons 0 (cdr (cdr te-pending-output)))) - (setcar te-pending-output start)))) - (catch 'char - (let ((filter (process-filter te-process))) - (unwind-protect - (progn - (set-process-filter te-process - (function (lambda (_p s) - (or (eq (length s) 1) - (setq te-pending-output (list 1 s))) - (throw 'char (aref s 0))))) - (accept-process-output te-process)) - (set-process-filter te-process filter)))))) - - -(defun te-redisplay-if-necessary (length) - (and (<= (setq te-redisplay-count (- te-redisplay-count length)) 0) - (eq (current-buffer) (window-buffer (selected-window))) - (waiting-for-user-input-p) - (progn (te-update-pending-output-display) - (sit-for 0) - (setq te-redisplay-count terminal-redisplay-interval)))) - -(defun te-update-pending-output-display () - (if (null (cdr te-pending-output)) - (setq te-pending-output-info "") - (let ((length (te-pending-output-length))) - (if (< length 1500) - (setq te-pending-output-info "") - (setq te-pending-output-info (format "(%dK chars output pending) " - (/ (+ length 512) 1024)))))) - (force-mode-line-update)) - - -(defun te-sentinel (process message) - (cond ((eq (process-status process) 'run)) - ((null (buffer-name (process-buffer process)))) ;deleted - (t (let ((b (current-buffer))) - (with-current-buffer (process-buffer process) - (setq buffer-read-only nil) - (fundamental-mode) - (goto-char (point-max)) - (delete-blank-lines) - (delete-horizontal-space) - (insert "\n*******\n" message "*******\n")) - (if (and (eq b (process-buffer process)) - (waiting-for-user-input-p)) - (progn (goto-char (point-max)) - (recenter -1))))))) - -(defvar te-stty-string "stty -nl erase '^?' kill '^u' intr '^c' echo pass8" - "Shell command to set terminal modes for terminal emulator.") -;; This used to have `new' in it, but that loses outside BSD -;; and it's apparently not needed in BSD. - -;;;###autoload -(defun terminal-emulator (buffer program args &optional width height) - "Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS. -ARGS is a list of argument-strings. Remaining arguments are WIDTH and HEIGHT. -BUFFER's contents are made an image of the display generated by that program, -and any input typed when BUFFER is the current Emacs buffer is sent to that -program as keyboard input. - -Interactively, BUFFER defaults to \"*terminal*\" and PROGRAM and ARGS -are parsed from an input-string using your usual shell. -WIDTH and HEIGHT are determined from the size of the current window --- WIDTH will be one less than the window's width, HEIGHT will be its height. - -To switch buffers and leave the emulator, or to give commands -to the emulator itself (as opposed to the program running under it), -type Control-^. The following character is an emulator command. -Type Control-^ twice to send it to the subprogram. -This escape character may be changed using the variable `terminal-escape-char'. - -`Meta' characters may not currently be sent through the terminal emulator. - -Here is a list of some of the variables which control the behavior -of the emulator -- see their documentation for more information: -terminal-escape-char, terminal-scrolling, terminal-more-processing, -terminal-redisplay-interval. - -This function calls the value of terminal-mode-hook if that exists -and is non-nil after the terminal buffer has been set up and the -subprocess started." - (interactive - (cons (with-current-buffer (get-buffer-create "*terminal*") - (buffer-name (if (or (not (boundp 'te-process)) - (null te-process) - (not (eq (process-status te-process) - 'run))) - (current-buffer) - (generate-new-buffer "*terminal*")))) - (append - (let* ((default-s - ;; Default shell is same thing M-x shell uses. - (or explicit-shell-file-name - (getenv "ESHELL") - (getenv "SHELL") - (if (eq system-type 'android) - "/system/bin/sh" - "/bin/sh"))) - (s (read-string - (format "Run program in emulator (default %s): " - default-s)))) - (if (equal s "") - (list default-s '()) - (te-parse-program-and-args s)))))) - (switch-to-buffer buffer) - (if (null width) (setq width (- (window-width (selected-window)) 1))) - (if (null height) (setq height (- (window-height (selected-window)) 1))) - (terminal-mode) - (setq te-width width te-height height) - (setq te-terminal-name (concat te-terminal-name-prefix - (number-to-string te-width) - (number-to-string te-height))) - (setq mode-line-buffer-identification - (list (format "Emacs terminal %dx%d: %%b " te-width te-height) - 'te-pending-output-info)) - (let ((buffer-read-only nil)) - (te-clear-screen)) - (let (process) - (while (setq process (get-buffer-process (current-buffer))) - (if (y-or-n-p (format "Kill process %s? " (process-name process))) - (delete-process process) - (error "Process %s not killed" (process-name process))))) - (condition-case err - (let ((process-environment - (cons (concat "TERM=" te-terminal-name) - (cons (concat "TERMCAP=" (te-create-termcap)) - (cons (concat "TERMINFO=" (te-create-terminfo)) - process-environment))))) - (setq te-process - (start-process "terminal-emulator" (current-buffer) - "/bin/sh" "-c" - ;; Yuck!!! Start a shell to set some terminal - ;; control characteristics. Then start the - ;; "env" program to setup the terminal type - ;; Then finally start the program we wanted. - (format "%s; exec %s" - te-stty-string - (mapconcat #'te-quote-arg-for-sh - (cons program args) " ")))) - (set-process-filter te-process #'te-filter) - (set-process-sentinel te-process #'te-sentinel)) - (error (fundamental-mode) - (signal (car err) (cdr err)))) - (setq inhibit-quit t) ;sport death - (use-local-map terminal-map) - (run-hooks 'terminal-mode-hook) - (message "Entering Emacs terminal-emulator... Type %s %s for help" - (single-key-description terminal-escape-char) - (mapconcat #'single-key-description - (where-is-internal #'te-escape-help terminal-escape-map t) - " "))) - - -(defun te-parse-program-and-args (s) - (cond ((string-match "\\`[-a-zA-Z0-9+=_.@/:][-a-zA-Z0-9+=_.@/: \t]*\\'" s) - (let ((l ()) (p 0)) - (while p - (setq l (cons (if (string-match - "\\([-a-zA-Z0-9+=_.@/:]+\\)[ \t]*" - s p) - (prog1 (substring s p (match-end 1)) - (setq p (match-end 0)) - (if (eq p (length s)) (setq p nil))) - (prog1 (substring s p) - (setq p nil))) - l))) - (setq l (nreverse l)) - (list (car l) (cdr l)))) - ((and (string-match "[ \t]" s) (not (file-exists-p s))) - (list shell-file-name (list "-c" (concat "exec " s)))) - (t (list s ())))) - -(put 'terminal-mode 'mode-class 'special) -;; This is only separated out from function terminal-emulator -;; to keep the latter a little more manageable. -(defun terminal-mode () - "Set up variables for use with the terminal-emulator. -One should not call this -- it is an internal function -of the terminal-emulator" - (kill-all-local-variables) - (buffer-disable-undo (current-buffer)) - (setq major-mode 'terminal-mode) - (setq mode-name "terminal") -; (make-local-variable 'Helper-return-blurb) -; (setq Helper-return-blurb "return to terminal simulator") - (setq mode-line-process '(":%s")) - (setq buffer-read-only t) - (setq truncate-lines t) - (make-local-variable 'terminal-escape-char) - (setq terminal-escape-char (default-value 'terminal-escape-char)) - (make-local-variable 'terminal-scrolling) - (setq terminal-scrolling (default-value 'terminal-scrolling)) - (make-local-variable 'terminal-more-processing) - (setq terminal-more-processing (default-value 'terminal-more-processing)) - (make-local-variable 'terminal-redisplay-interval) - (setq terminal-redisplay-interval (default-value 'terminal-redisplay-interval)) - (make-local-variable 'te-width) - (make-local-variable 'te-height) - (make-local-variable 'te-process) - (make-local-variable 'te-pending-output) - (setq te-pending-output (list 0)) - (make-local-variable 'te-saved-point) - (setq te-saved-point (point-min)) - (make-local-variable 'te-pending-output-info) ;for the mode line - (setq te-pending-output-info "") - (make-local-variable 'inhibit-quit) - ;(setq inhibit-quit t) - (make-local-variable 'te-log-buffer) - (setq te-log-buffer nil) - (make-local-variable 'te-more-count) - (setq te-more-count -1) - (make-local-variable 'te-redisplay-count) - (setq te-redisplay-count terminal-redisplay-interval) - ;(use-local-map terminal-mode-map) - ;; terminal-mode-hook is called above in function terminal-emulator - ) - -;;;; what a complete loss - -(defun te-quote-arg-for-sh (string) - (cond ((string-match "\\`[-a-zA-Z0-9+=_.@/:]+\\'" - string) - string) - ((not (string-search "$" string)) - ;; "[\"\\]" are special to sh and the lisp reader in the same way - (prin1-to-string string)) - (t - (let ((harder "") - (start 0) - (end 0)) - (while (cond ((>= start (length string)) - nil) - ;; this is the set of chars magic with "..." in `sh' - ((setq end (string-match "[\"\\$]" - string start)) - t) - (t (setq harder (concat harder - (substring string start))) - nil)) - (setq harder (concat harder (substring string start end) - ;; Can't use ?\\ since `concat' - ;; unfortunately does prin1-to-string - ;; on fixna. Amazing. - "\\" - (substring string - end - (1+ end))) - start (1+ end))) - (concat "\"" harder "\""))))) - -(defun te-create-terminfo () - "Create and compile a terminfo entry for the virtual terminal. This is kept -in the directory specified by `te-terminfo-directory'." - (when (and system-uses-terminfo - (not (file-exists-p (concat te-terminfo-directory - (substring te-terminal-name-prefix 0 1) - "/" te-terminal-name)))) - (let ( (terminfo - (concat - ;; The first newline avoids trouble with ncurses. - (format "%s,\n\tmir, xon,cols#%d, lines#%d," - te-terminal-name te-width te-height) - "bel=^P^G, clear=^P\\f, cr=^P^A, cub1=^P^B, cud1=^P\\n," - "cuf1=^P^F, cup=^P=%p1%'\\s'%+%c%p2%'\\s'%+%c," - "dch=^Pd%p1%'\\s'%+%c, dch1=^Pd!, dl=^P^K%p1%'\\s'%+%c," - "dl1=^P^K!, ed=^PC, el=^Pc, home=^P=\\s\\s," - "ich=^P_%p1%'\\s'%+%c, ich1=^P_!, il=^P^O%p1%'\\s'%+%c," - ;; The last newline avoids trouble with ncurses. - "il1=^P^O!, ind=^P\\n, nel=\\n,\n")) - ;; This is the desired name for the source file. - (file-name (concat te-terminfo-directory te-terminal-name ".tif")) ) - (make-directory te-terminfo-directory t) - (let ((temp-file - (make-temp-file (expand-file-name "tif" te-terminfo-directory)))) - ;; Store the source file under a random temp name. - (with-temp-file temp-file - (insert terminfo)) - ;; Rename it to the desired name. - ;; We use this roundabout approach - ;; to avoid any risk of writing a name that - ;; was mischievously set up as a symlink. - (rename-file temp-file file-name)) - ;; Now compile that source to make the binary that the - ;; programs actually use. - (let ((process-environment - (cons (concat "TERMINFO=" - (directory-file-name te-terminfo-directory)) - process-environment))) - (set-process-sentinel (start-process "tic" nil "tic" file-name) - #'te-tic-sentinel)))) - (directory-file-name te-terminfo-directory)) - -(defun te-create-termcap () - "Create a termcap entry for the virtual terminal" - ;; Because of Unix Brain Death(tm), we can't change - ;; the terminal type of a running process, and so - ;; terminal size and scrollability are wired-down - ;; at this point. ("Detach? What's that?") - (concat (format "%s:co#%d:li#%d:%s" - ;; Sigh. These can't be dynamically changed. - te-terminal-name te-width te-height (if terminal-scrolling - "" "ns:")) - ;;-- Basic things - ;; cursor-motion, bol, forward/backward char - "cm=^p=%+ %+ :cr=^p^a:le=^p^b:nd=^p^f:" - ;; newline, clear eof/eof, audible bell - "nw=^j:ce=^pc:cd=^pC:cl=^p^l:bl=^p^g:" - ;; insert/delete char/line - "IC=^p_%+ :DC=^pd%+ :AL=^p^o%+ :DL=^p^k%+ :" - ;;-- Not-widely-known (ie nonstandard) flags, which mean - ;; o writing in the last column of the last line - ;; doesn't cause idiotic scrolling, and - ;; o don't use idiotische c-s/c-q sogenannte - ;; ``flow control'' auf keinen Fall. - "LP:NF:" - ;;-- For stupid or obsolete programs - "ic=^p_!:dc=^pd!:al=^p^o!:dl=^p^k!:ho=^p= :" - ;;-- For disgusting programs. - ;; (VI? What losers need these, I wonder?) - "im=:ei=:dm=:ed=:mi:do=^p^j:nl=^p^j:bs:") -) - -(defun te-tic-sentinel (_proc state-change) - "If tic has finished, delete the .tif file" - (if (equal state-change "finished -") - (delete-file (concat te-terminfo-directory te-terminal-name ".tif")))) - -(provide 'terminal) - -;;; terminal.el ends here diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el index 62431662baa..4447a8d1001 100644 --- a/lisp/obsolete/tpu-edt.el +++ b/lisp/obsolete/tpu-edt.el @@ -604,21 +604,17 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.") ;;; ;;; Buffer Local Variables ;;; -(defvar tpu-newline-and-indent-p nil +(defvar-local tpu-newline-and-indent-p nil "If non-nil, Return produces a newline and indents.") -(make-variable-buffer-local 'tpu-newline-and-indent-p) -(defvar tpu-newline-and-indent-string nil +(defvar-local tpu-newline-and-indent-string nil "Mode line string to identify AutoIndent mode.") -(make-variable-buffer-local 'tpu-newline-and-indent-string) -(defvar tpu-saved-delete-func nil +(defvar-local tpu-saved-delete-func nil "Saved value of the delete key.") -(make-variable-buffer-local 'tpu-saved-delete-func) -(defvar tpu-buffer-local-map nil +(defvar-local tpu-buffer-local-map nil "TPU-edt buffer local key map.") -(make-variable-buffer-local 'tpu-buffer-local-map) ;;; @@ -631,8 +627,7 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.") ;;; (defvar tpu-original-mm-alist minor-mode-alist) -(defvar tpu-mark-flag "") -(make-variable-buffer-local 'tpu-mark-flag) +(defvar-local tpu-mark-flag "") (defun tpu-set-mode-line (for-tpu) "Set `minor-mode-alist' for TPU-edt, or reset it to default Emacs." diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el deleted file mode 100644 index afc6284b348..00000000000 --- a/lisp/obsolete/vi.el +++ /dev/null @@ -1,1495 +0,0 @@ -;;; vi.el --- major mode for emulating "vi" editor under GNU Emacs -*- lexical-binding: t; -*- - -;; This file is in the public domain because the authors distributed it -;; without a copyright notice before the US signed the Bern Convention. - -;; This file is part of GNU Emacs. - -;; Author: Neal Ziring <nz@rsch.wisc.edu> -;; Felix S. T. Wu <wu@crys.wisc.edu> -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;;; Commentary: - -;; This file is obsolete. Consider using viper instead. - -;; Originally written by : seismo!wucs!nz@rsch.wisc.edu (Neal Ziring) -;; Extensively redesigned and rewritten by wu@crys.wisc.edu (Felix S.T. Wu) -;; Last revision: 01/07/87 Wed (for GNU Emacs 18.33) - -;; INSTALLATION PROCEDURE: -;; 1) Add a global key binding for command "vi-mode" (I use ESC ESC instead of -;; the single ESC used in real "vi", so I can access other ESC prefixed emacs -;; commands while I'm in "vi"), say, by putting the following line in your -;; ".emacs" file: -;; (define-key global-map "\e\e" 'vi-mode) ;quick switch into vi-mode -;; 2) If you wish you can define "find-file-hook" to enter "vi" automatically -;; after a file is loaded into the buffer. For example, I defined it as: -;; (setq find-file-hook (list -;; (function (lambda () -;; (if (not (or (eq major-mode 'Info-mode) -;; (eq major-mode 'vi-mode))) -;; (vi-mode)))))) -;; 3) In your init file you can define the command "vi-mode" to be "autoload" -;; or you can execute the "load" command to load "vi" directly. -;; 4) Read the comments for command "vi-mode" before you start using it. - -;; COULD DO -;; 1). A general 'define-operator' function to replace current hack -;; 2). In operator handling, should allow other point moving Emacs commands -;; (such as ESC <, ESC >) to be used as arguments. - -;;; Code: - -(defvar vi-mode-old-major-mode) -(defvar vi-mode-old-mode-name) -(defvar vi-mode-old-local-map) -(defvar vi-mode-old-case-fold) - -(if (null (where-is-internal 'vi-switch-mode (current-local-map))) - (define-key ctl-x-map "~" #'vi-switch-mode)) - -(defvar vi-tilde-map nil - "Keymap used for \\[vi-switch-mode] prefix key. Link to various major modes.") - -(if vi-tilde-map - nil - (setq vi-tilde-map (make-keymap)) - (define-key vi-tilde-map "a" #'abbrev-mode) - (define-key vi-tilde-map "c" #'c-mode) - (define-key vi-tilde-map "d" #'vi-debugging) - (define-key vi-tilde-map "e" #'emacs-lisp-mode) - (define-key vi-tilde-map "f" #'auto-fill-mode) - (define-key vi-tilde-map "g" #'prolog-mode) - (define-key vi-tilde-map "h" #'hanoi) - ;; (define-key vi-tilde-map "i" #'info-mode) - (define-key vi-tilde-map "l" #'lisp-mode) - (define-key vi-tilde-map "n" #'nroff-mode) - (define-key vi-tilde-map "o" #'overwrite-mode) - (define-key vi-tilde-map "O" #'outline-mode) - (define-key vi-tilde-map "P" #'picture-mode) - (define-key vi-tilde-map "r" #'vi-readonly-mode) - (define-key vi-tilde-map "t" #'text-mode) - (define-key vi-tilde-map "v" #'vi-mode) - (define-key vi-tilde-map "x" #'tex-mode) - (define-key vi-tilde-map "~" #'vi-back-to-old-mode)) - -(defun vi-switch-mode (arg mode-char) - "Switch the major mode of current buffer as specified by the following char \\{vi-tilde-map}" - (interactive "P\nc") - (let ((mode-cmd (lookup-key vi-tilde-map (char-to-string mode-char)))) - (if (null mode-cmd) - (with-output-to-temp-buffer "*Help*" - (princ (substitute-command-keys "Possible major modes to switch to: \\{vi-tilde-map}")) - (with-current-buffer standard-output - (help-mode))) - (setq prefix-arg arg) ; prefix arg will be passed down - (command-execute mode-cmd nil) ; may need to save mode-line-format etc - (force-mode-line-update)))) ; just in case - - -(defun vi-debugging (arg) - "Toggle debug-on-error flag. If prefix arg is given, set t." - (interactive "P") - (if arg - (setq debug-on-error t) - (setq debug-on-error (not debug-on-error))) - (if debug-on-error - (message "Debug-on-error ...") - (message "NO more debug-on-error"))) - -(defun vi-back-to-old-mode () - "Go back to the previous mode without setting up for insertion." - (interactive) - (if vi-mode-old-major-mode - (progn - (setq mode-name vi-mode-old-mode-name) - (use-local-map vi-mode-old-local-map) - (setq major-mode vi-mode-old-major-mode) - (setq case-fold-search vi-mode-old-case-fold) - (force-mode-line-update)))) - -(defun vi-readonly-mode () - "Toggle current buffer's readonly flag." - (interactive) - (setq buffer-read-only (not buffer-read-only))) - -(defvar vi-com-map nil - "Keymap used in Evi's command state -Command state includes most of the vi editing commands, with some Emacs -command extensions.") - -(put 'vi-undefined 'suppress-keymap t) -(if vi-com-map nil - (setq vi-com-map (make-keymap)) -;;(fillarray vi-com-map #'vi-undefined) - (define-key vi-com-map "\C-@" #'vi-mark-region) ; extension - (define-key vi-com-map "\C-a" #'vi-ask-for-info) ; extension - (define-key vi-com-map "\C-b" #'vi-backward-windowful) - (define-key vi-com-map "\C-c" #'vi-do-old-mode-C-c-command) ; extension - (define-key vi-com-map "\C-d" #'vi-scroll-down-window) - (define-key vi-com-map "\C-e" #'vi-expose-line-below) - (define-key vi-com-map "\C-f" #'vi-forward-windowful) - (define-key vi-com-map "\C-g" #'keyboard-quit) - (define-key vi-com-map "\C-i" #'indent-relative-first-indent-point) ; TAB - (define-key vi-com-map "\C-j" #'vi-next-line) ; LFD - (define-key vi-com-map "\C-k" #'vi-kill-line) ; extension - (define-key vi-com-map "\C-l" #'recenter) - (define-key vi-com-map "\C-m" #'vi-next-line-first-nonwhite) ; RET - (define-key vi-com-map "\C-n" #'vi-next-line) - (define-key vi-com-map "\C-o" #'vi-split-open-line) - (define-key vi-com-map "\C-p" #'previous-line) - (define-key vi-com-map "\C-q" #'vi-query-replace) ; extension - (define-key vi-com-map "\C-r" #'vi-isearch-backward) ; modification - (define-key vi-com-map "\C-s" #'vi-isearch-forward) ; extension - (define-key vi-com-map "\C-t" #'vi-transpose-objects) ; extension - (define-key vi-com-map "\C-u" #'vi-scroll-up-window) - (define-key vi-com-map "\C-v" #'scroll-up-command) ; extension - (define-key vi-com-map "\C-w" #'vi-kill-region) ; extension - (define-key vi-com-map "\C-x" 'Control-X-prefix) ; extension - (define-key vi-com-map "\C-y" #'vi-expose-line-above) - (define-key vi-com-map "\C-z" #'suspend-emacs) - - (define-key vi-com-map "\e" 'ESC-prefix); C-[ (ESC) - (define-key vi-com-map "\C-\\" #'vi-unimplemented) - (define-key vi-com-map "\C-]" #'xref-find-definitions) - (define-key vi-com-map "\C-^" #'vi-locate-def) ; extension - (define-key vi-com-map "\C-_" #'vi-undefined) - - (define-key vi-com-map " " #'forward-char) - (define-key vi-com-map "!" #'vi-operator) - (define-key vi-com-map "\"" #'vi-char-argument) - (define-key vi-com-map "#" #'universal-argument) ; extension - (define-key vi-com-map "$" #'end-of-line) - (define-key vi-com-map "%" #'vi-find-matching-paren) - (define-key vi-com-map "&" #'vi-unimplemented) - (define-key vi-com-map "'" #'vi-goto-line-mark) - (define-key vi-com-map "(" #'backward-sexp) - (define-key vi-com-map ")" #'forward-sexp) - (define-key vi-com-map "*" #'vi-name-last-change-or-macro) ; extension - (define-key vi-com-map "+" #'vi-next-line-first-nonwhite) - (define-key vi-com-map "," #'vi-reverse-last-find-char) - (define-key vi-com-map "-" #'vi-previous-line-first-nonwhite) - (define-key vi-com-map "." #'vi-redo-last-change-command) - (define-key vi-com-map "/" #'vi-search-forward) - (define-key vi-com-map "0" #'beginning-of-line) - - (define-key vi-com-map "1" #'vi-digit-argument) - (define-key vi-com-map "2" #'vi-digit-argument) - (define-key vi-com-map "3" #'vi-digit-argument) - (define-key vi-com-map "4" #'vi-digit-argument) - (define-key vi-com-map "5" #'vi-digit-argument) - (define-key vi-com-map "6" #'vi-digit-argument) - (define-key vi-com-map "7" #'vi-digit-argument) - (define-key vi-com-map "8" #'vi-digit-argument) - (define-key vi-com-map "9" #'vi-digit-argument) - - (define-key vi-com-map ":" #'vi-ex-cmd) - (define-key vi-com-map ";" #'vi-repeat-last-find-char) - (define-key vi-com-map "<" #'vi-operator) - (define-key vi-com-map "=" #'vi-operator) - (define-key vi-com-map ">" #'vi-operator) - (define-key vi-com-map "?" #'vi-search-backward) - (define-key vi-com-map "@" #'vi-call-named-change-or-macro) ; extension - - (define-key vi-com-map "A" #'vi-append-at-end-of-line) - (define-key vi-com-map "B" #'vi-backward-blank-delimited-word) - (define-key vi-com-map "C" #'vi-change-rest-of-line) - (define-key vi-com-map "D" #'vi-kill-line) - (define-key vi-com-map "E" #'vi-end-of-blank-delimited-word) - (define-key vi-com-map "F" #'vi-backward-find-char) - (define-key vi-com-map "G" #'vi-goto-line) - (define-key vi-com-map "H" #'vi-home-window-line) - (define-key vi-com-map "I" #'vi-insert-before-first-nonwhite) - (define-key vi-com-map "J" #'vi-join-lines) - (define-key vi-com-map "K" #'vi-undefined) - (define-key vi-com-map "L" #'vi-last-window-line) - (define-key vi-com-map "M" #'vi-middle-window-line) - (define-key vi-com-map "N" #'vi-reverse-last-search) - (define-key vi-com-map "O" #'vi-open-above) - (define-key vi-com-map "P" #'vi-put-before) - (define-key vi-com-map "Q" #'vi-quote-words) ; extension - (define-key vi-com-map "R" #'vi-replace-chars) - (define-key vi-com-map "S" #'vi-substitute-lines) - (define-key vi-com-map "T" #'vi-backward-upto-char) - (define-key vi-com-map "U" #'vi-unimplemented) - (define-key vi-com-map "V" #'vi-undefined) - (define-key vi-com-map "W" #'vi-forward-blank-delimited-word) - (define-key vi-com-map "X" #'call-last-kbd-macro) ; modification/extension - (define-key vi-com-map "Y" #'vi-yank-line) - (define-key vi-com-map "Z" (make-sparse-keymap)) ;allow below prefix command - (define-key vi-com-map "ZZ" #'vi-save-all-and-exit) - - (define-key vi-com-map "[" #'vi-unimplemented) - (define-key vi-com-map "\\" #'vi-operator) ; extension for vi-narrow-op - (define-key vi-com-map "]" #'vi-unimplemented) - (define-key vi-com-map "^" #'back-to-indentation) - (define-key vi-com-map "_" #'vi-undefined) - (define-key vi-com-map "`" #'vi-goto-char-mark) - - (define-key vi-com-map "a" #'vi-insert-after) - (define-key vi-com-map "b" #'backward-word) - (define-key vi-com-map "c" #'vi-operator) - (define-key vi-com-map "d" #'vi-operator) - (define-key vi-com-map "e" #'vi-end-of-word) - (define-key vi-com-map "f" #'vi-forward-find-char) - (define-key vi-com-map "g" #'vi-beginning-of-buffer) ; extension - (define-key vi-com-map "h" #'backward-char) - (define-key vi-com-map "i" #'vi-insert-before) - (define-key vi-com-map "j" #'vi-next-line) - (define-key vi-com-map "k" #'previous-line) - (define-key vi-com-map "l" #'forward-char) - (define-key vi-com-map "m" #'vi-set-mark) - (define-key vi-com-map "n" #'vi-repeat-last-search) - (define-key vi-com-map "o" #'vi-open-below) - (define-key vi-com-map "p" #'vi-put-after) - (define-key vi-com-map "q" #'vi-replace) - (define-key vi-com-map "r" #'vi-replace-1-char) - (define-key vi-com-map "s" #'vi-substitute-chars) - (define-key vi-com-map "t" #'vi-forward-upto-char) - (define-key vi-com-map "u" #'undo) - (define-key vi-com-map "v" #'vi-verify-spelling) - (define-key vi-com-map "w" #'vi-forward-word) - (define-key vi-com-map "x" #'vi-kill-char) - (define-key vi-com-map "y" #'vi-operator) - (define-key vi-com-map "z" #'vi-adjust-window) - - (define-key vi-com-map "{" #'backward-paragraph) - (define-key vi-com-map "|" #'vi-goto-column) - (define-key vi-com-map "}" #'forward-paragraph) - (define-key vi-com-map "~" #'vi-change-case) - (define-key vi-com-map "\177" #'delete-backward-char)) - -(put 'backward-char 'point-moving-unit 'char) -(put 'vi-next-line 'point-moving-unit 'line) -(put 'next-line 'point-moving-unit 'line) -(put 'forward-line 'point-moving-unit 'line) -(put 'previous-line 'point-moving-unit 'line) -(put 'vi-isearch-backward 'point-moving-unit 'search) -(put 'vi-search-backward 'point-moving-unit 'search) -(put 'vi-isearch-forward 'point-moving-unit 'search) -(put 'vi-search-forward 'point-moving-unit 'search) -(put 'forward-char 'point-moving-unit 'char) -(put 'end-of-line 'point-moving-unit 'char) -(put 'vi-find-matching-paren 'point-moving-unit 'match) -(put 'vi-goto-line-mark 'point-moving-unit 'line) -(put 'backward-sexp 'point-moving-unit 'sexp) -(put 'forward-sexp 'point-moving-unit 'sexp) -(put 'vi-next-line-first-nonwhite 'point-moving-unit 'line) -(put 'vi-previous-line-first-nonwhite 'point-moving-unit 'line) -(put 'vi-reverse-last-find-char 'point-moving-unit 'rev-find) -(put 'vi-re-search-forward 'point-moving-unit 'search) -(put 'beginning-of-line 'point-moving-unit 'char) -(put 'vi-beginning-of-buffer 'point-moving-unit 'char) -(put 'vi-repeat-last-find-char 'point-moving-unit 'find) -(put 'vi-re-search-backward 'point-moving-unit 'search) -(put 'vi-backward-blank-delimited-word 'point-moving-unit 'WORD) -(put 'vi-end-of-blank-delimited-word 'point-moving-unit 'match) -(put 'vi-backward-find-char 'point-moving-unit 'find) -(put 'vi-goto-line 'point-moving-unit 'line) -(put 'vi-home-window-line 'point-moving-unit 'line) -(put 'vi-last-window-line 'point-moving-unit 'line) -(put 'vi-middle-window-line 'point-moving-unit 'line) -(put 'vi-reverse-last-search 'point-moving-unit 'rev-search) -(put 'vi-backward-upto-char 'point-moving-unit 'find) -(put 'vi-forward-blank-delimited-word 'point-moving-unit 'WORD) -(put 'back-to-indentation 'point-moving-unit 'char) -(put 'vi-goto-char-mark 'point-moving-unit 'char) -(put 'backward-word 'point-moving-unit 'word) -(put 'vi-end-of-word 'point-moving-unit 'match) -(put 'vi-forward-find-char 'point-moving-unit 'find) -(put 'backward-char 'point-moving-unit 'char) -(put 'vi-forward-char 'point-moving-unit 'char) -(put 'vi-repeat-last-search 'point-moving-unit 'search) -(put 'vi-forward-upto-char 'point-moving-unit 'find) -(put 'vi-forward-word 'point-moving-unit 'word) -(put 'vi-goto-column 'point-moving-unit 'match) -(put 'forward-paragraph 'point-moving-unit 'paragraph) -(put 'backward-paragraph 'point-moving-unit 'paragraph) - -;;; region mark commands -(put 'mark-page 'point-moving-unit 'region) -(put 'mark-paragraph 'point-moving-unit 'region) -(put 'mark-word 'point-moving-unit 'region) -(put 'mark-sexp 'point-moving-unit 'region) -(put 'mark-defun 'point-moving-unit 'region) -(put 'mark-whole-buffer 'point-moving-unit 'region) -(put 'mark-end-of-sentence 'point-moving-unit 'region) -(put 'c-mark-function 'point-moving-unit 'region) -;;; - -(defvar vi-mark-alist nil - "Alist of (NAME . MARK), marks are local to each buffer.") - -(defvar vi-scroll-amount (/ (window-height) 2) - "Default amount of lines for scrolling (used by \"^D\"/\"^U\").") - -(defvar vi-shift-width 4 - "Shift amount for \"<\"/\">\" operators.") - -(defvar vi-ins-point nil ; integer - "Last insertion point. Should use `mark' instead.") - -(defvar vi-ins-length nil ; integer - "Length of last insertion.") - -(defvar vi-ins-repetition nil ; integer - "The repetition required for last insertion.") - -(defvar vi-ins-overwrt-p nil ; boolean - "T if last insertion was a replace actually.") - -(defvar vi-ins-prefix-code nil ; ready-to-eval sexp - "Code to be eval'ed before (redo-)insertion begins.") - -(defvar vi-last-find-char nil ; cons cell - "Save last direction, char and upto-flag used for char finding.") - -(defvar vi-last-change-command nil ; cons cell - "Save commands for redoing last changes. Each command is in (FUNC . ARGS) -form that is ready to be `apply'ed.") - -(defvar vi-last-shell-command nil ; last shell op command line - "Save last shell command given for \"!\" operator.") - -(defvar vi-insert-state nil ; boolean - "Non-nil if it is in insert state.") - -; in "loaddefs.el" -;(defvar search-last-string "" -; "Last string search for by a search command.") - -(defvar vi-search-last-command nil ; (re-)search-forward(backward) - "Save last search command for possible redo.") - -(defvar vi-mode-old-local-map nil - "Save the local-map used before entering vi-mode.") - -(defvar vi-mode-old-mode-name nil - "Save the mode-name before entering vi-mode.") - -(defvar vi-mode-old-major-mode nil - "Save the major-mode before entering vi-mode.") - -(defvar vi-mode-old-case-fold nil) - -;(defconst vi-add-to-mode-line-1 -; '(overwrite-mode nil " Insert")) - -;; Value is same as vi-add-to-mode-line-1 when in vi mode, -;; but nil in other buffers. -;(defvar vi-add-to-mode-line nil) - -(defun vi-mode-setup () - "Setup a buffer for vi-mode by creating necessary buffer-local variables." -; (make-local-variable 'vi-add-to-mode-line) -; (setq vi-add-to-mode-line vi-add-to-mode-line-1) -; (or (memq vi-add-to-mode-line minor-mode-alist) -; (setq minor-mode-alist (cons vi-add-to-mode-line minor-mode-alist))) - (make-local-variable 'vi-scroll-amount) - (setq vi-scroll-amount (/ (window-height) 2)) - (make-local-variable 'vi-shift-width) - (setq vi-shift-width 4) - (make-local-variable 'vi-ins-point) - (make-local-variable 'vi-ins-length) - (make-local-variable 'vi-ins-repetition) - (make-local-variable 'vi-ins-overwrt-p) - (make-local-variable 'vi-ins-prefix-code) - (make-local-variable 'vi-last-change-command) - (make-local-variable 'vi-last-shell-command) - (make-local-variable 'vi-last-find-char) - (make-local-variable 'vi-mark-alist) - (make-local-variable 'vi-insert-state) - (make-local-variable 'vi-mode-old-local-map) - (make-local-variable 'vi-mode-old-mode-name) - (make-local-variable 'vi-mode-old-major-mode) - (make-local-variable 'vi-mode-old-case-fold) - (run-mode-hooks 'vi-mode-hook)) - -;;;###autoload -(defun vi-mode () - "Major mode that acts like the `vi' editor. -The purpose of this mode is to provide you the combined power of vi (namely, -the \"cross product\" effect of commands and repeat last changes) and Emacs. - -This command redefines nearly all keys to look like vi commands. -It records the previous major mode, and any vi command for input -\(`i', `a', `s', etc.) switches back to that mode. -Thus, ordinary Emacs (in whatever major mode you had been using) -is \"input\" mode as far as vi is concerned. - -To get back into vi from \"input\" mode, you must issue this command again. -Therefore, it is recommended that you assign it to a key. - -Major differences between this mode and real vi : - -* Limitations and unsupported features - - Search patterns with line offset (e.g. /pat/+3 or /pat/z.) are - not supported. - - Ex commands are not implemented; try ':' to get some hints. - - No line undo (i.e. the `U' command), but multi-undo is a standard feature. - -* Modifications - - The stopping positions for some point motion commands (word boundary, - pattern search) are slightly different from standard `vi'. - Also, no automatic wrap around at end of buffer for pattern searching. - - Since changes are done in two steps (deletion then insertion), you need - to undo twice to completely undo a change command. But this is not needed - for undoing a repeated change command. - - No need to set/unset `magic', to search for a string with regular expr - in it just put a prefix arg for the search commands. Replace cmds too. - - ^R is bound to incremental backward search, so use ^L to redraw screen. - -* Extensions - - Some standard (or modified) Emacs commands were integrated, such as - incremental search, query replace, transpose objects, and keyboard macros. - - In command state, ^X links to the `ctl-x-map', and ESC can be linked to - esc-map or set undefined. These can give you the full power of Emacs. - - See vi-com-map for those keys that are extensions to standard vi, e.g. - `vi-name-last-change-or-macro', `vi-verify-spelling', `vi-locate-def', - `vi-mark-region', and `vi-quote-words'. Some of them are quite handy. - - Use \\[vi-switch-mode] to switch among different modes quickly. - -Syntax table and abbrevs while in vi mode remain as they were in Emacs." - (interactive) - (if (null vi-mode-old-major-mode) ; very first call for current buffer - (vi-mode-setup)) - - (if (eq major-mode 'vi-mode) - (progn (ding) (message "Already in vi-mode.")) - (setq vi-mode-old-local-map (current-local-map)) - (setq vi-mode-old-mode-name mode-name) - (setq vi-mode-old-major-mode major-mode) - (setq vi-mode-old-case-fold case-fold-search) ; this is needed !! - (setq case-fold-search nil) ; exact case match in searching - (use-local-map vi-com-map) - (setq major-mode 'vi-mode) - (setq mode-name "VI") - (force-mode-line-update) ; force mode line update - (if vi-insert-state ; this is a return from insertion - (vi-end-of-insert-state)))) - -(defun vi-ding() - "Ding !" - (interactive) - (ding)) - -(defun vi-save-all-and-exit () - "Save all modified buffers without asking, then exits emacs." - (interactive) - (save-some-buffers t) - (kill-emacs)) - -;; to be used by "ex" commands -(defvar vi-replaced-string nil) -(defvar vi-replacing-string nil) - -(defun vi-ex-cmd () - "Ex commands are not implemented in Evi mode. For some commonly used ex -commands, you can use the following alternatives for similar effect : -w C-x C-s (save-buffer) -wq C-x C-c (save-buffers-kill-emacs) -w fname C-x C-w (write-file) -e fname C-x C-f (find-file) -r fname C-x i (insert-file) -s/old/new use q (vi-replace) to do unconditional replace - use C-q (vi-query-replace) to do query replace -set sw=n M-x set-variable vi-shift-width n " - (interactive) -;; (let ((cmd (read-string ":")) (lines 1)) -;; (cond ((string-match "s")))) - (with-output-to-temp-buffer "*Help*" - (princ (documentation 'vi-ex-cmd)) - (with-current-buffer standard-output - (help-mode)))) - -(defun vi-undefined () - (interactive) - (message "Command key \"%s\" is undefined in Evi." - (single-key-description last-command-event)) - (ding)) - -(defun vi-unimplemented () - (interactive) - (message "Command key \"%s\" is not implemented in Evi." - (single-key-description last-command-event)) - (ding)) - -;;;;; -(defun vi-goto-insert-state (repetition &optional prefix-code do-it-now-p) - "Go into insert state, the text entered will be repeated if REPETITION > 1. -If PREFIX-CODE is given, do it before insertion begins if DO-IT-NOW-P is T. -In any case, the prefix-code will be done before each `redo-insert'. -This function expects `overwrite-mode' being set properly beforehand." - (if do-it-now-p (apply (car prefix-code) (cdr prefix-code))) - (setq vi-ins-point (point)) - (setq vi-ins-repetition repetition) - (setq vi-ins-prefix-code prefix-code) - (setq mode-name vi-mode-old-mode-name) - (setq case-fold-search vi-mode-old-case-fold) - (use-local-map vi-mode-old-local-map) - (setq major-mode vi-mode-old-major-mode) - (force-mode-line-update) - (setq vi-insert-state t)) - -(defun vi-end-of-insert-state () - "Terminate insertion and set up last change command." - (if (or (< (point) vi-ins-point) ;Check if there is any effective change - (and (= (point) vi-ins-point) (null vi-ins-prefix-code)) - (<= vi-ins-repetition 0)) - (vi-goto-command-state t) - (if (> vi-ins-repetition 1) - (progn - (let ((str (buffer-substring vi-ins-point (point)))) - (while (> vi-ins-repetition 1) - (insert str) - (setq vi-ins-repetition (1- vi-ins-repetition)))))) - (vi-set-last-change-command 'vi-first-redo-insertion vi-ins-point (point) - overwrite-mode vi-ins-prefix-code) - (vi-goto-command-state t))) - -(defun vi-first-redo-insertion (begin end &optional overwrite-p prefix-code) - "Redo last insertion the first time. Extract the string and save it for -future redoes. Do prefix-code if it's given, use overwrite mode if asked." - (let ((str (buffer-substring begin end))) - (if prefix-code (apply (car prefix-code) (cdr prefix-code))) - (if overwrite-p (delete-region (point) (+ (point) (length str)))) - (insert str) - (vi-set-last-change-command 'vi-more-redo-insertion str overwrite-p prefix-code))) - -(defun vi-more-redo-insertion (str &optional overwrite-p prefix-code) - "Redo more insertion : copy string from STR to point, use overwrite mode -if overwrite-p is T; apply prefix-code first if it's non-nil." - (if prefix-code (apply (car prefix-code) (cdr prefix-code))) - (if overwrite-p (delete-region (point) (+ (point) (length str)))) - (insert str)) - -(defun vi-goto-command-state (&optional from-insert-state-p) - "Go to vi-mode command state. If optional arg exists, means return from -insert state." - (use-local-map vi-com-map) - (setq vi-insert-state nil) - (if from-insert-state-p - (if overwrite-mode - (overwrite-mode 0) -; (set-minor-mode 'ins "Insert" nil) - ))) - -(defun vi-kill-line (arg) - "kill specified number of lines (=d$), text saved in the kill ring." - (interactive "*P") - (kill-line arg) - (vi-set-last-change-command 'kill-line arg)) - -(defun vi-kill-region (start end) - (interactive "*r") - (kill-region start end) - (vi-set-last-change-command 'kill-region)) - -(defun vi-append-at-end-of-line (arg) - "go to end of line and then go into vi insert state." - (interactive "*p") - (vi-goto-insert-state arg '(end-of-line) t)) - -(defun vi-change-rest-of-line (arg) - "Change the rest of (ARG) lines (= c$ in vi)." - (interactive "*P") - (vi-goto-insert-state 1 (list 'kill-line arg) t)) - -(defun vi-insert-before-first-nonwhite (arg) - "(= ^i in vi)" - (interactive "*p") - (vi-goto-insert-state arg '(back-to-indentation) t)) - -(defun vi-open-above (arg) - "open new line(s) above current line and enter insert state." - (interactive "*p") - (vi-goto-insert-state 1 - (list (function (lambda (x) - (or (beginning-of-line) - (open-line x)))) arg) - t)) - -(defun vi-open-below (arg) - "open new line(s) and go into insert mode on the last line." - (interactive "*p") - (vi-goto-insert-state 1 - (list (function (lambda (x) - (or (end-of-line) - (open-line x) - (forward-line x)))) arg) - t)) - -(defun vi-insert-after (arg) - "start vi insert state after cursor." - (interactive "*p") - (vi-goto-insert-state arg - (list (function (lambda () - (if (not (eolp)) (forward-char))))) - t)) - -(defun vi-insert-before (arg) - "enter insert state before the cursor." - (interactive "*p") - (vi-goto-insert-state arg)) - -(defun vi-goto-line (arg) - "Go to ARGth line." - (interactive "P") - (if (null (vi-raw-numeric-prefix arg)) - (with-no-warnings - (end-of-buffer)) - (with-no-warnings (goto-line (vi-prefix-numeric-value arg))))) - -(defun vi-beginning-of-buffer () - "Move point to the beginning of current buffer." - (interactive) - (goto-char (point-min))) - -;;;;; not used now -;;(defvar regexp-search t ; string -;; "*T if search string can contain regular expressions. (= set magic in vi)") -;;;;; - -(defun vi-isearch-forward (arg) - "Incremental search forward. Use regexp version if ARG is non-nil." - (interactive "P") - (let ((scmd (if arg 'isearch-forward-regexp 'isearch-forward)) - (opoint (point))) - (call-interactively scmd) - (if (= opoint (point)) - nil - (setq vi-search-last-command (if arg 're-search-forward 'search-forward))))) - -(defun vi-isearch-backward (arg) - "Incremental search backward. Use regexp version if ARG is non-nil." - (interactive "P") - (let ((scmd (if arg 'isearch-backward-regexp 'isearch-backward)) - (opoint (point))) - (call-interactively scmd) - (if (= opoint (point)) - nil - (setq vi-search-last-command (if arg 're-search-backward 'search-backward))))) - -(defun vi-search-forward (arg string) - "Nonincremental search forward. Use regexp version if ARG is non-nil." - (interactive (if current-prefix-arg - (list t (read-string "regexp/" nil)) - (list nil (read-string "/" nil)))) - (setq vi-search-last-command (if arg 're-search-forward 'search-forward)) - (if (> (length string) 0) - (isearch-update-ring string arg)) - (funcall vi-search-last-command string nil nil 1)) - -(defun vi-search-backward (arg string) - "Nonincremental search backward. Use regexp version if ARG is non-nil." - (interactive (if current-prefix-arg - (list t (read-string "regexp?" nil)) - (list nil (read-string "?" nil)))) - (setq vi-search-last-command (if arg 're-search-backward 'search-backward)) - (if (> (length string) 0) - (isearch-update-ring string arg)) - (funcall vi-search-last-command string nil nil 1)) - -(defun vi-repeat-last-search (arg &optional search-command search-string) - "Repeat last search command. -If optional search-command/string are given, -use those instead of the ones saved." - (interactive "p") - (if (null search-command) (setq search-command vi-search-last-command)) - (if (null search-string) - (setq search-string - (car (if (memq search-command - '(re-search-forward re-search-backward)) - regexp-search-ring - search-ring)))) - (if (null search-command) - (progn (ding) (message "No last search command to repeat.")) - (funcall search-command search-string nil nil arg))) - -(defun vi-reverse-last-search (arg &optional search-command search-string) - "Redo last search command in reverse direction. -If the optional search args are given, use those instead of the ones saved." - (interactive "p") - (if (null search-command) (setq search-command vi-search-last-command)) - (if (null search-string) - (setq search-string - (car (if (memq search-command - '(re-search-forward re-search-backward)) - regexp-search-ring - search-ring)))) - (if (null search-command) - (progn (ding) (message "No last search command to repeat.")) - (funcall (cond ((eq search-command 're-search-forward) 're-search-backward) - ((eq search-command 're-search-backward) 're-search-forward) - ((eq search-command 'search-forward) 'search-backward) - ((eq search-command 'search-backward) 'search-forward)) - search-string nil nil arg))) - -(defun vi-join-lines (arg) - "join ARG lines from current line (default 2), cleaning up white space." - (interactive "P") - (if (null (vi-raw-numeric-prefix arg)) - (delete-indentation t) - (let ((count (vi-prefix-numeric-value arg))) - (while (>= count 2) - (delete-indentation t) - (setq count (1- count))))) - (vi-set-last-change-command 'vi-join-lines arg)) - -(defun vi-backward-kill-line () - "kill the current line. Only works in insert state." - (interactive) - (if (not vi-insert-state) - nil - (beginning-of-line 1) - (kill-line nil))) - -(defun vi-abort-ins () - "abort insert state, kill inserted text and go back to command state." - (interactive) - (if (not vi-insert-state) - nil - (if (> (point) vi-ins-point) - (kill-region vi-ins-point (point))) - (vi-goto-command-state t))) - -(defun vi-backward-windowful (count) - "Backward COUNT windowfuls. Default is one." - (interactive "p") -; (set-mark-command nil) - (while (> count 0) - (scroll-down nil) - (setq count (1- count)))) - -(defun vi-scroll-down-window (count) - "Scrolls down window COUNT lines. -If COUNT is nil (actually, non-integer), scrolls default amount. -The given COUNT is remembered for future scrollings." - (interactive "P") - (if (integerp count) - (setq vi-scroll-amount count)) - (scroll-up vi-scroll-amount)) - -(defun vi-expose-line-below (count) - "Expose COUNT more lines below the current window. Default COUNT is 1." - (interactive "p") - (scroll-up count)) - -(defun vi-forward-windowful (count) - "Forward COUNT windowfuls. Default is one." - (interactive "p") -; (set-mark-command nil) - (while (> count 0) - (scroll-up nil) - (setq count (1- count)))) - -(defun vi-next-line (count) - "Go down count lines, try to keep at the same column." - (interactive "p") - (setq this-command 'next-line) ; this is a needed trick - (if (= (point) (progn (line-move count) (point))) - (ding) ; no moving, already at end of buffer - (setq last-command 'next-line))) - -(defun vi-next-line-first-nonwhite (count) - "Go down COUNT lines. Stop at first non-white." - (interactive "p") - (if (= (point) (progn (forward-line count) (back-to-indentation) (point))) - (ding))) ; no moving, already at end of buffer - -(defun vi-previous-line-first-nonwhite (count) - "Go up COUNT lines. Stop at first non-white." - (interactive "p") - (forward-line (- count)) - (back-to-indentation)) - -(defun vi-scroll-up-window (count) - "Scrolls up window COUNT lines. -If COUNT is nil (actually, non-integer), scrolls default amount. -The given COUNT is remembered for future scrollings." - (interactive "P") - (if (integerp count) - (setq vi-scroll-amount count)) - (scroll-down vi-scroll-amount)) - -(defun vi-expose-line-above (count) - "Expose COUNT more lines above the current window. Default COUNT is 1." - (interactive "p") - (scroll-down count)) - -(defun vi-char-argument (arg) - "Get following character (could be any CHAR) as part of the prefix argument. -Possible prefix-arg cases are nil, INTEGER, (nil . CHAR) or (INTEGER . CHAR)." - (interactive "P") - (let ((char (read-char))) - (cond ((null arg) (setq prefix-arg (cons nil char))) - ((integerp arg) (setq prefix-arg (cons arg char))) - ; This can happen only if the user changed his/her mind for CHAR, - ; Or there are some leading "universal-argument"s - (t (setq prefix-arg (cons (car arg) char)))))) - -(defun vi-goto-mark (mark-char &optional line-flag) - "Go to marked position or line (if line-flag is given). -Goto mark `@' means jump into and pop the top mark on the mark ring." - (cond ((char-equal mark-char last-command-event) ; `` or '' - (exchange-point-and-mark) (if line-flag (back-to-indentation))) - ((char-equal mark-char ?@) ; jump and pop mark - (set-mark-command t) (if line-flag (back-to-indentation))) - (t - (let ((mark (vi-get-mark mark-char))) - (if (null mark) - (progn (vi-ding) (message "Mark register undefined.")) - (set-mark-command nil) - (goto-char mark) - (if line-flag (back-to-indentation))))))) - -(defun vi-goto-line-mark (char) - "Go to the line (at first non-white) marked by next char." - (interactive "c") - (vi-goto-mark char t)) - -(defun vi-goto-char-mark (char) - "Go to the char position marked by next mark-char." - (interactive "c") - (vi-goto-mark char)) - -(defun vi-digit-argument (arg) - "Set numeric prefix argument." - (interactive "P") - (cond ((null arg) (digit-argument arg)) - ((integerp arg) (digit-argument nil) - (setq prefix-arg (* prefix-arg arg))) - (t (digit-argument nil) ; in (NIL . CHAR) or (NUM . CHAR) form - (setq prefix-arg (cons (* prefix-arg - (if (null (car arg)) 1 (car arg))) - (cdr arg)))))) - -(defun vi-raw-numeric-prefix (arg) - "Return the raw value of numeric part prefix argument." - (if (consp arg) (car arg) arg)) - -(defun vi-prefix-numeric-value (arg) - "Return numeric meaning of the raw prefix argument. This is a modification -to the standard one provided in `callint.c' to handle (_ . CHAR) cases." - (cond ((null arg) 1) - ((integerp arg) arg) - ((consp arg) (if (car arg) (car arg) 1)))) - -(defun vi-reverse-last-find-char (count &optional find-arg) - "Reverse last f F t T operation COUNT times. If the optional FIND-ARG -is given, it is used instead of the saved one." - (interactive "p") - (if (null find-arg) (setq find-arg vi-last-find-char)) - (if (null find-arg) - (progn (ding) (message "No last find char to repeat.")) - (vi-find-char (cons (* (car find-arg) -1) (cdr find-arg)) count))) ;6/13/86 - -(defun vi-find-char (arg count) - "Find in DIRECTION (1/-1) for CHAR of COUNT'th times on current line. -If UPTO-FLAG is T, stop before the char. ARG = (DIRECTION.CHAR.UPTO-FLAG." - (let* ((direction (car arg)) (char (car (cdr arg))) - (upto-flag (cdr (cdr arg))) (pos (+ (point) direction))) - (if (catch 'exit-find-char - (while t - (cond ((null (char-after pos)) (throw 'exit-find-char nil)) - ((char-equal (char-after pos) ?\n) (throw 'exit-find-char nil)) - ((char-equal char (char-after pos)) (setq count (1- count)) - (if (= count 0) - (throw 'exit-find-char - (if upto-flag - (setq pos (- pos direction)) - pos))))) - (setq pos (+ pos direction)))) - (goto-char pos) - (ding)))) - -(defun vi-repeat-last-find-char (count &optional find-arg) - "Repeat last f F t T operation COUNT times. If optional FIND-ARG is given, -it is used instead of the saved one." - (interactive "p") - (if (null find-arg) (setq find-arg vi-last-find-char)) - (if (null find-arg) - (progn (ding) (message "No last find char to repeat.")) - (vi-find-char find-arg count))) - -(defun vi-backward-find-char (count char) - "Find the COUNT'th CHAR backward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons -1 (cons char nil))) - (vi-repeat-last-find-char count)) - -(defun vi-forward-find-char (count char) - "Find the COUNT'th CHAR forward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons 1 (cons char nil))) - (vi-repeat-last-find-char count)) - -(defun vi-backward-upto-char (count char) - "Find up to the COUNT'th CHAR backward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons -1 (cons char t))) - (vi-repeat-last-find-char count)) - -(defun vi-forward-upto-char (count char) - "Find up to the COUNT'th CHAR forward on current line." - (interactive "p\nc") - (setq vi-last-find-char (cons 1 (cons char t))) - (vi-repeat-last-find-char count)) - -(defun vi-end-of-word (count) - "Move forward until encountering the end of a word. -With argument, do this that many times." - (interactive "p") - (if (not (eobp)) (forward-char)) - (if (re-search-forward "\\W*\\w+\\>" nil t count) - (backward-char))) - -(defun vi-replace-1-char (count char) - "Replace char after point by CHAR. Repeat COUNT times." - (interactive "p\nc") - (delete-char count nil) ; don't save in kill ring - (setq last-command-event char) - (self-insert-command count) - (vi-set-last-change-command 'vi-replace-1-char count char)) - -(defun vi-replace-chars (arg) - "Replace chars over old ones." - (interactive "*p") - (overwrite-mode 1) - (vi-goto-insert-state arg)) - -(defun vi-substitute-chars (count) - "Substitute COUNT chars by the input chars, enter insert state." - (interactive "*p") - (vi-goto-insert-state 1 (list (function (lambda (c) ; this is a bit tricky - (delete-region (point) - (+ (point) c)))) - count) t)) - -(defun vi-substitute-lines (count) - "Substitute COUNT lines by the input chars. (=cc in vi)" - (interactive "*p") - (vi-goto-insert-state 1 (list 'vi-delete-op 'next-line (1- count)) t)) - -(defun vi-prefix-char-value (arg) - "Get the char part of the current prefix argument." - (cond ((null arg) nil) - ((integerp arg) nil) - ((consp arg) (cdr arg)) - (t nil))) - -(defun vi-operator (arg) - "Handling vi operators (d/c/</>/!/=/y). Current implementation requires -the key bindings of the operators being fixed." - (interactive "P") - (catch 'vi-exit-op - (let ((this-op-char last-command-event)) - (setq last-command-event (read-char)) - (setq this-command (lookup-key vi-com-map (char-to-string last-command-event))) - (if (not (eq this-command 'vi-digit-argument)) - (setq prefix-arg arg) - (vi-digit-argument arg) - (setq last-command-event (read-char)) - (setq this-command (lookup-key vi-com-map (char-to-string last-command-event)))) - (cond ((char-equal this-op-char last-command-event) ; line op - (vi-execute-op this-op-char 'next-line - (cons (1- (vi-prefix-numeric-value prefix-arg)) - (vi-prefix-char-value prefix-arg)))) - ;; We assume any command that has no property 'point-moving-unit' - ;; as having that property with the value 'CHAR'. 3/12/86 - (t ;; (get this-command 'point-moving-unit) - (vi-execute-op this-op-char this-command prefix-arg)))))) - ;; (t (throw 'vi-exit-op (ding))))))) - -(defun vi-execute-op (op-char motion-command arg) - "Execute vi edit operator as specified by OP-CHAR, the operand is the region -determined by the MOTION-COMMAND with ARG." - (cond ((= op-char ?d) - (if (vi-delete-op motion-command arg) - (vi-set-last-change-command 'vi-delete-op (vi-repeat-command-of motion-command) arg))) - ((= op-char ?c) - (if (vi-delete-op motion-command arg) - (vi-goto-insert-state 1 (list 'vi-delete-op - (vi-repeat-command-of motion-command) arg) nil))) - ((= op-char ?y) - (if (vi-yank-op motion-command arg) - (vi-set-last-change-command 'vi-yank-op (vi-repeat-command-of motion-command) arg))) - ((= op-char ?!) - (if (vi-shell-op motion-command arg) - (vi-set-last-change-command 'vi-shell-op (vi-repeat-command-of motion-command) arg vi-last-shell-command))) - ((= op-char ?<) - (if (vi-shift-op motion-command arg (- vi-shift-width)) - (vi-set-last-change-command 'vi-shift-op (vi-repeat-command-of motion-command) arg (- vi-shift-width)))) - ((= op-char ?>) - (if (vi-shift-op motion-command arg vi-shift-width) - (vi-set-last-change-command 'vi-shift-op (vi-repeat-command-of motion-command) arg vi-shift-width))) - ((= op-char ?=) - (if (vi-indent-op motion-command arg) - (vi-set-last-change-command 'vi-indent-op (vi-repeat-command-of motion-command) arg))) - ((= op-char ?\\) - (vi-narrow-op motion-command arg)))) - -(defun vi-repeat-command-of (command) - "Return the command for redo the given command." - (let ((cmd-type (get command 'point-moving-unit))) - (cond ((eq cmd-type 'search) 'vi-repeat-last-search) - ((eq cmd-type 'find) 'vi-repeat-last-find-char) - (t command)))) - -(defun vi-effective-range (motion-command arg) - "Return (begin . end) of the range spanned by executing the given -MOTION-COMMAND with ARG. - MOTION-COMMAND in ready-to-eval list form is not yet supported." - (save-excursion - (let ((begin (point)) end opoint - (moving-unit (get motion-command 'point-moving-unit))) - (setq prefix-arg arg) - (setq opoint (point)) - (command-execute motion-command nil) -;; Check if there is any effective motion. Note that for single line operation -;; the motion-command causes no effective point movement (since it moves up or -;; down zero lines), but it should be counted as effectively moved. - (if (and (= (point) opoint) (not (eq moving-unit 'line))) - (cons opoint opoint) ; no effective motion - (if (eq moving-unit 'region) - (setq begin (or (mark) (point)))) - (if (<= begin (point)) - (setq end (point)) - (setq end begin) - (setq begin (point))) - (cond ((or (eq moving-unit 'match) (eq moving-unit 'find)) - (setq end (1+ end))) - ((eq moving-unit 'line) - (goto-char begin) (beginning-of-line) (setq begin (point)) - (goto-char end) (forward-line 1) (beginning-of-line) (setq end (point)))) - (if (> end (point-max)) (setq end (point-max))) ; force in buffer region - (cons begin end))))) - -(defun vi-delete-op (motion-command arg) - "Delete range specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range)) reg) - (if (= begin end) - nil ; point not moved, abort op - (setq reg (vi-prefix-char-value arg)) - (if (null reg) - (kill-region begin end) ; kill ring as unnamed registers - (if (and (>= reg ?A) (<= reg ?Z)) - (append-to-register (downcase reg) begin end t) - (copy-to-register reg begin end t))) - t))) - -(defun vi-yank-op (motion-command arg) - "Yank (in vi sense) range specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range)) reg) - (if (= begin end) - nil ; point not moved, abort op - (setq reg (vi-prefix-char-value arg)) - (if (null reg) - (copy-region-as-kill begin end); kill ring as unnamed registers - (if (and (>= reg ?A) (<= reg ?Z)) - (append-to-register (downcase reg) begin end nil) - (copy-to-register reg begin end nil))) - t))) - -(defun vi-yank-line (arg) - "Yank (in vi sense) lines (= `yy' command)." - (interactive "*P") - (setq arg (cons (1- (vi-prefix-numeric-value arg)) (vi-prefix-char-value arg))) - (if (vi-yank-op 'next-line arg) - (vi-set-last-change-command 'vi-yank-op 'next-line arg))) - -(defun vi-string-end-with-nl-p (string) - "See if STRING ends with a newline char. -Used in checking whether the yanked text should be put back as lines or not." - (= (aref string (1- (length string))) ?\n)) - -(defun vi-put-before (arg &optional after-p) - "Put yanked (in vi sense) text back before/above cursor. -If a numeric prefix value (currently it should be >1) is given, put back -text as lines. If the optional after-p is given, put after/below the cursor." - (interactive "P") - (let ((reg (vi-prefix-char-value arg)) put-text) - (if (and reg (or (< reg ?1) (> reg ?9)) (null (get-register reg))) - (error "Nothing in register %c" reg) - (if (null reg) (setq reg ?1)) ; the default is the last text killed - (setq put-text - (cond - ((and (>= reg ?1) (<= reg ?9)) - (setq this-command 'yank) ; So we may yank-pop !! - (current-kill (- reg ?0 1) 'do-not-rotate)) - ((stringp (get-register reg)) (get-register reg)) - (t (error "Register %c is not containing text string" reg)))) - (if (vi-string-end-with-nl-p put-text) ; put back text as lines - (if after-p - (progn (forward-line 1) (beginning-of-line)) - (beginning-of-line)) - (if after-p (forward-char 1))) - (push-mark) - (insert put-text) - (exchange-point-and-mark) -;; (back-to-indentation) ; this is not allowed if we allow yank-pop - (vi-set-last-change-command 'vi-put-before arg after-p)))) - -(defun vi-put-after (arg) - "Put yanked (in vi sense) text back after/below cursor." - (interactive "P") - (vi-put-before arg t)) - -(defun vi-shell-op (motion-command arg &optional shell-command) - "Perform shell command (as filter). -Performs command on range specified by MOTION-COMMAND -with ARG. If SHELL-COMMAND is not given, ask for one from minibuffer. -If char argument is given, it directs the output to a *temp* buffer." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (cond ((null shell-command) - (setq shell-command (read-string "!" nil)) - (setq vi-last-shell-command shell-command))) - (shell-command-on-region begin end shell-command (not (vi-prefix-char-value arg)) - (not (vi-prefix-char-value arg))) - t))) - -(defun vi-shift-op (motion-command arg amount) - "Perform shift command on range specified by MOTION-COMMAND with ARG for -AMOUNT on each line. Negative amount means shift left. -SPECIAL FEATURE: char argument can be used to specify shift amount(1-9)." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (if (vi-prefix-char-value arg) - (setq amount (if (> amount 0) - (- (vi-prefix-char-value arg) ?0) - (- ?0 (vi-prefix-char-value arg))))) - (indent-rigidly begin end amount) - t))) - -(defun vi-indent-op (motion-command arg) - "Perform indent command on range specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (indent-region begin end nil) ; insert TAB as indent command - t))) - -(defun vi-narrow-op (motion-command arg) - "Narrow to region specified by MOTION-COMMAND with ARG." - (let* ((range (vi-effective-range motion-command arg)) - (begin (car range)) (end (cdr range))) - (if (= begin end) - nil ; point not moved, abort op - (narrow-to-region begin end)))) - -(defun vi-get-mark (char) - "Return contents of vi mark register named CHAR, or nil if undefined." - (cdr (assq char vi-mark-alist))) - -(defun vi-set-mark (char) - "Set contents of vi mark register named CHAR to current point. -'@' is the special anonymous mark register." - (interactive "c") - (if (char-equal char ?@) - (set-mark-command nil) - (let ((aelt (assq char vi-mark-alist))) - (if aelt - (move-marker (cdr aelt) (point)) ; fixed 6/12/86 - (setq aelt (cons char (point-marker))) - (setq vi-mark-alist (cons aelt vi-mark-alist)))))) - -(defun vi-find-matching-paren () - "Locate the matching paren. It's a hack right now." - (interactive) - (cond ((looking-at "[[({]") (forward-sexp 1) (backward-char 1)) - ((looking-at "[])}]") (forward-char 1) (backward-sexp 1)) - (t (ding)))) - -(defun vi-backward-blank-delimited-word (count) - "Backward COUNT blank-delimited words." - (interactive "p") - (if (re-search-backward "[ \t\n`][^ \t\n`]+" nil t count) - (if (not (bobp)) (forward-char 1)))) - -(defun vi-forward-blank-delimited-word (count) - "Forward COUNT blank-delimited words." - (interactive "p") - (if (re-search-forward "[^ \t\n]*[ \t\n]+[^ \t\n]" nil t count) - (if (not (eobp)) (backward-char 1)))) - -(defun vi-end-of-blank-delimited-word (count) - "Forward to the end of the COUNT'th blank-delimited word." - (interactive "p") - (if (re-search-forward "[^ \t\n']+[ \t\n']" nil t count) - (if (not (eobp)) (backward-char 2)))) - -(defun vi-home-window-line (arg) - "To window home or arg'th line from the top of the window." - (interactive "p") - (move-to-window-line (1- arg)) - (back-to-indentation)) - -(defun vi-last-window-line (arg) - "To window last line or arg'th line from the bottom of the window." - (interactive "p") - (move-to-window-line (- arg)) - (back-to-indentation)) - -(defun vi-middle-window-line () - "To the middle line of the window." - (interactive) - (move-to-window-line nil) - (back-to-indentation)) - -(defun vi-forward-word (count) - "Stop at the beginning of the COUNT'th words from point." - (interactive "p") - (if (re-search-forward "\\w*\\W+\\<" nil t count) - t - (vi-ding))) - -(defun vi-set-last-change-command (fun &rest args) - "Set (FUN . ARGS) as the `last-change-command'." - (setq vi-last-change-command (cons fun args))) - -(defun vi-redo-last-change-command (count &optional command) - "Redo last change command COUNT times. If the optional COMMAND is given, -it is used instead of the current `last-change-command'." - (interactive "p") - (if (null command) - (setq command vi-last-change-command)) - (if (null command) - (message "No last change command available.") - (while (> count 0) - (apply (car command) (cdr command)) - (setq count (1- count))))) - -(defun vi-kill-char (count) - "Kill COUNT chars from current point." - (interactive "*p") - (delete-char count t) ; save in kill ring - (vi-set-last-change-command 'delete-char count t)) - -(defun vi-transpose-objects (arg unit) - "Transpose objects. -The following char specifies unit of objects to be -transposed -- \"c\" for chars, \"l\" for lines, \"w\" for words, \"s\" for - sexp, \"p\" for paragraph. -For the use of the prefix-arg, refer to individual functions called." - (interactive "*P\nc") - (if (char-equal unit ??) - (progn - (message "Transpose: c(har), l(ine), p(aragraph), s(-exp), w(ord),") - (setq unit (read-char)))) - (vi-set-last-change-command 'vi-transpose-objects arg unit) - (cond ((char-equal unit ?c) (transpose-chars arg)) - ((char-equal unit ?l) (transpose-lines (vi-prefix-numeric-value arg))) - ((char-equal unit ?p) (transpose-paragraphs (vi-prefix-numeric-value arg))) - ((char-equal unit ?s) (transpose-sexps (vi-prefix-numeric-value arg))) - ((char-equal unit ?w) (transpose-words (vi-prefix-numeric-value arg))) - (t (vi-transpose-objects arg ??)))) - -(defun vi-query-replace (arg) - "Query replace, use regexp version if ARG is non-nil." - (interactive "*P") - (let ((rcmd (if arg 'query-replace-regexp 'query-replace))) - (call-interactively rcmd nil))) - -(defun vi-replace (arg) - "Replace strings, use regexp version if ARG is non-nil." - (interactive "*P") - (let ((rcmd (if arg 'replace-regexp 'replace-string))) - (call-interactively rcmd nil))) - -(defun vi-adjust-window (arg position) - "Move current line to the top/center/bottom of the window." - (interactive "p\nc") - (cond ((char-equal position ?\r) (recenter 0)) - ((char-equal position ?-) (recenter -1)) - ((char-equal position ?.) (recenter (/ (window-height) 2))) - (t (message "Move current line to: \\r(top) -(bottom) .(middle)") - (setq position (read-char)) - (vi-adjust-window arg position)))) - -(defun vi-goto-column (col) - "Go to given column of the current line." - (interactive "p") - (let ((opoint (point))) - (beginning-of-line) - (while (> col 1) - (if (eolp) - (setq col 0) - (forward-char 1) - (setq col (1- col)))) - (if (= col 1) - t - (goto-char opoint) - (ding)))) - -(defun vi-name-last-change-or-macro (arg char) - "Give name to the last change command or just defined kbd macro. -If prefix ARG is given, name last macro, otherwise name last change command. -The following CHAR will be the name for the command or macro." - (interactive "P\nc") - (if arg - (name-last-kbd-macro (intern (char-to-string char))) - (if (eq (car vi-last-change-command) 'vi-first-redo-insertion) - (let* ((args (cdr vi-last-change-command)) ; save the insertion text - (str (buffer-substring (nth 0 args) (nth 1 args))) - (overwrite-p (nth 2 args)) - (prefix-code (nth 3 args))) - (vi-set-last-change-command 'vi-more-redo-insertion str - overwrite-p prefix-code))) - (fset (intern (char-to-string char)) vi-last-change-command))) - -(defun vi-call-named-change-or-macro (count char) - "Execute COUNT times the keyboard macro definition named by the following CHAR." - (interactive "p\nc") - (if (stringp (symbol-function (intern (char-to-string char)))) - (execute-kbd-macro (intern (char-to-string char)) count) - (vi-redo-last-change-command count (symbol-function (intern (char-to-string char)))))) - -(defun vi-change-case (arg) ; could be made as an operator ? - "Change the case of the char after point." - (interactive "*p") - (catch 'exit - (if (looking-at "[a-z]") - (upcase-region (point) (+ (point) arg)) - (if (looking-at "[A-Z]") - (downcase-region (point) (+ (point) arg)) - (ding) - (throw 'exit nil))) - (vi-set-last-change-command 'vi-change-case arg) ;should avoid redundant save - (forward-char arg))) - -(defun vi-ask-for-info (char) - "Inquire status info. The next CHAR will specify the particular info requested." - (interactive "c") - (cond ((char-equal char ?l) (what-line)) - ((char-equal char ?c) (what-cursor-position)) - ((char-equal char ?p) (what-page)) - (t (message "Ask for: l(ine number), c(ursor position), p(age number)") - (setq char (read-char)) - (vi-ask-for-info char)))) - -(declare-function c-mark-function "cc-cmds" ()) - -(defun vi-mark-region (arg region) - "Mark region appropriately. The next char REGION is d(efun),s(-exp),b(uffer), -p(aragraph), P(age), f(unction in C/Pascal etc.), w(ord), e(nd of sentence), -l(ines)." - (interactive "p\nc") - (cond ((char-equal region ?d) (mark-defun)) - ((char-equal region ?s) (mark-sexp arg)) - ((char-equal region ?b) (with-no-warnings (mark-whole-buffer))) - ((char-equal region ?p) (mark-paragraph)) - ((char-equal region ?P) (mark-page arg)) - ((char-equal region ?f) (c-mark-function)) - ((char-equal region ?w) (mark-word arg)) - ((char-equal region ?e) (mark-end-of-sentence arg)) - ((char-equal region ?l) (vi-mark-lines arg)) - (t (message "Mark: d(efun),s(-exp),b(uf),p(arag),P(age),f(unct),w(ord),e(os),l(ines)") - (setq region (read-char)) - (vi-mark-region arg region)))) - -(defun vi-mark-lines (num) - "Mark NUM of lines from current line as current region." - (beginning-of-line 1) - (push-mark) - (end-of-line num)) - -(defun vi-verify-spelling (arg unit) - "Verify spelling for the objects specified by char UNIT : [b(uffer), -r(egion), s(tring), w(ord) ]." - (interactive "P\nc") - (setq prefix-arg arg) ; seems not needed - (cond ((char-equal unit ?b) (call-interactively 'spell-buffer)) - ((char-equal unit ?r) (call-interactively 'spell-region)) - ((char-equal unit ?s) (call-interactively 'spell-string)) - ((char-equal unit ?w) (call-interactively 'spell-word)) - (t (message "Spell check: b(uffer), r(egion), s(tring), w(ord)") - (setq unit (read-char)) - (vi-verify-spelling arg unit)))) - -(defun vi-do-old-mode-C-c-command (arg) - "This is a hack for accessing mode specific C-c commands in vi-mode." - (interactive "P") - (let ((cmd (lookup-key vi-mode-old-local-map - (concat "\C-c" (char-to-string (read-char)))))) - (if (catch 'exit-vi-mode ; kludge hack due to dynamic binding - ; of case-fold-search - (if (null cmd) - (progn (ding) nil) - (let ((case-fold-search vi-mode-old-case-fold)) ; a hack - (setq prefix-arg arg) - (command-execute cmd nil) - nil))) - (progn - (vi-back-to-old-mode) - (setq prefix-arg arg) - (command-execute cmd nil))))) - -(defun vi-quote-words (arg char) - "Quote ARG words from the word point is on with pattern specified by CHAR. -Currently, CHAR could be [,{,(,\",',`,<,*, etc." - (interactive "*p\nc") - (while (not (string-match "[[({<\"'`*]" (char-to-string char))) - (message "Enter any of [,{,(,<,\",',`,* as quoting character.") - (setq char (read-char))) - (vi-set-last-change-command 'vi-quote-words arg char) - (if (not (looking-at "\\<")) (forward-word -1)) - (insert char) - (cond ((char-equal char ?\[) (setq char ?\])) - ((char-equal char ?{) (setq char ?})) - ((char-equal char ?<) (setq char ?>)) - ((char-equal char ?\() (setq char ?\))) - ((char-equal char ?`) (setq char ?'))) - (vi-end-of-word arg) - (forward-char 1) - (insert char)) - -(defun vi-locate-def () - "Locate definition in current file for the name before the point. -It assumes a `(def..' always starts at the beginning of a line." - (interactive) - (let (name) - (save-excursion - (setq name (buffer-substring (progn (vi-backward-blank-delimited-word 1) - (skip-chars-forward "^a-zA-Z") - (point)) - (progn (vi-end-of-blank-delimited-word 1) - (forward-char) - (skip-chars-backward "^a-zA-Z") - (point))))) - (set-mark-command nil) - (goto-char (point-min)) - (if (re-search-forward (concat "^(def[unvarconst ]*" name) nil t) - nil - (ding) - (message "No definition for \"%s\" in current file." name) - (set-mark-command t)))) - -(defun vi-split-open-line (arg) - "Insert a newline and leave point before it. -With ARG, inserts that many newlines." - (interactive "*p") - (vi-goto-insert-state 1 - (list (function (lambda (arg) - (let ((flag (and (bolp) (not (bobp))))) - (if flag (forward-char -1)) - (while (> arg 0) - (save-excursion - (insert ?\n) - (if fill-prefix (insert fill-prefix))) - (setq arg (1- arg))) - (if flag (forward-char 1))))) arg) - t)) - -(provide 'vi) - -;;; vi.el ends here diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el deleted file mode 100644 index eecedbd5e74..00000000000 --- a/lisp/obsolete/vip.el +++ /dev/null @@ -1,3050 +0,0 @@ -;;; vip.el --- a VI Package for GNU Emacs -*- lexical-binding: t; -*- - -;; Copyright (C) 1986-1988, 1992-1993, 1998, 2001-2024 Free Software -;; Foundation, Inc. - -;; Author: Masahiko Sato <ms@sail.stanford.edu> -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This file is obsolete. Consider using viper instead. - -;; A full-featured vi(1) emulator. -;; -;; In Japan, the author's address is: masahiko@sato.riec.tohoku.junet -;; -;; Send suggestions and bug reports to one of the above addresses. -;; When you report a bug, be sure to include the version number of VIP and -;; Emacs you are using. - -;; Execute info command by typing "M-x info" to get information on VIP. - -;;; Code: - -(defgroup vip nil - "A VI Package for GNU Emacs." - :prefix "vip-" - :group 'emulations) - -;; external variables - -(defvar vip-emacs-local-map nil - "Local map used in Emacs mode. (Buffer-specific.)") - -(defvar vip-insert-local-map nil - "Local map used in insert command mode. (Buffer-specific.)") - -(make-variable-buffer-local 'vip-emacs-local-map) -(make-variable-buffer-local 'vip-insert-local-map) - -(defvar vip-insert-point nil - "Remember insert point as a marker. (Buffer-specific.)") - -(set-default 'vip-insert-point (make-marker)) -(make-variable-buffer-local 'vip-insert-point) - -(defvar vip-com-point nil - "Remember com point as a marker. (Buffer-specific.)") - -(set-default 'vip-com-point (make-marker)) -(make-variable-buffer-local 'vip-com-point) - -(defvar vip-current-mode nil - "Current mode. One of `emacs-mode', `vi-mode', `insert-mode'.") - -(make-variable-buffer-local 'vip-current-mode) -(setq-default vip-current-mode 'emacs-mode) - -(defvar vip-emacs-mode-line-buffer-identification nil - "Value of mode-line-buffer-identification in Emacs mode within vip.") -(make-variable-buffer-local 'vip-emacs-mode-line-buffer-identification) -(setq-default vip-emacs-mode-line-buffer-identification - '("Emacs: %17b")) - -(defvar vip-current-major-mode nil - "vip-current-major-mode is the major-mode vi considers it is now. -\(buffer specific)") - -(make-variable-buffer-local 'vip-current-major-mode) - -(defvar vip-last-shell-com nil - "Last shell command executed by ! command.") - -(defvar vip-use-register nil - "Name of register to store deleted or yanked strings.") - -(defvar vip-d-com nil - "How to reexecute last destructive command. Value is list (M-COM VAL COM).") - -(defcustom vip-shift-width 8 - "The number of columns shifted by > and < command." - :type 'integer) - -(defcustom vip-re-replace nil - "If t then do regexp replace, if nil then do string replace." - :type 'boolean) - -(defvar vip-d-char nil - "The character remembered by the vi \"r\" command.") - -(defvar vip-f-char nil - "For use by \";\" command.") - -(defvar vip-F-char nil - "For use by \".\" command.") - -(defvar vip-f-forward nil - "For use by \";\" command.") - -(defvar vip-f-offset nil - "For use by \";\" command.") - -(defcustom vip-search-wrap-around t - "If t, search wraps around." - :type 'boolean) - -(defcustom vip-re-search nil - "If t, search is reg-exp search, otherwise vanilla search." - :type 'boolean) - -(defvar vip-s-string nil - "Last vip search string.") - -(defvar vip-s-forward nil - "If t, search is forward.") - -(defcustom vip-case-fold-search nil - "If t, search ignores cases." - :type 'boolean) - -(defcustom vip-re-query-replace nil - "If t then do regexp replace, if nil then do string replace." - :type 'boolean) - -(defcustom vip-open-with-indent nil - "If t, indent when open a new line." - :type 'boolean) - -(defcustom vip-help-in-insert-mode nil - "If t then C-h is bound to help-command in insert mode. -If nil then it is bound to `delete-backward-char'." - :type 'boolean) - -(defvar vip-quote-string "> " - "String inserted at the beginning of region.") - -(defvar vip-tags-file-name "TAGS") - -(defvar vip-inhibit-startup-message nil) - -(defvar vip-startup-file (locate-user-emacs-file "vip" ".vip") - "Filename used as startup file for vip.") - -;; key bindings - -(defvar vip-mode-map - (let ((map (make-keymap))) - (define-key map "\C-a" #'beginning-of-line) - (define-key map "\C-b" #'vip-scroll-back) - (define-key map "\C-c" #'vip-ctl-c) - (define-key map "\C-d" #'vip-scroll-up) - (define-key map "\C-e" #'vip-scroll-up-one) - (define-key map "\C-f" #'vip-scroll) - (define-key map "\C-g" #'vip-keyboard-quit) - (define-key map "\C-h" #'help-command) - (define-key map "\C-m" #'vip-scroll-back) - (define-key map "\C-n" #'vip-other-window) - (define-key map "\C-o" #'vip-open-line-at-point) - (define-key map "\C-u" #'vip-scroll-down) - (define-key map "\C-x" #'vip-ctl-x) - (define-key map "\C-y" #'vip-scroll-down-one) - (define-key map "\C-z" #'vip-change-mode-to-emacs) - (define-key map "\e" #'vip-ESC) - - (define-key map [?\S-\ ] #'vip-scroll-back) - (define-key map " " #'vip-scroll) - (define-key map "!" #'vip-command-argument) - (define-key map "\"" #'vip-command-argument) - (define-key map "#" #'vip-command-argument) - (define-key map "$" #'vip-goto-eol) - (define-key map "%" #'vip-paren-match) - (define-key map "&" #'vip-nil) - (define-key map "'" #'vip-goto-mark-and-skip-white) - (define-key map "(" #'vip-backward-sentence) - (define-key map ")" #'vip-forward-sentence) - (define-key map "*" #'call-last-kbd-macro) - (define-key map "+" #'vip-next-line-at-bol) - (define-key map "," #'vip-repeat-find-opposite) - (define-key map "-" #'vip-previous-line-at-bol) - (define-key map "." #'vip-repeat) - (define-key map "/" #'vip-search-forward) - - (define-key map "0" #'vip-beginning-of-line) - (define-key map "1" #'vip-digit-argument) - (define-key map "2" #'vip-digit-argument) - (define-key map "3" #'vip-digit-argument) - (define-key map "4" #'vip-digit-argument) - (define-key map "5" #'vip-digit-argument) - (define-key map "6" #'vip-digit-argument) - (define-key map "7" #'vip-digit-argument) - (define-key map "8" #'vip-digit-argument) - (define-key map "9" #'vip-digit-argument) - - (define-key map ":" #'vip-ex) - (define-key map ";" #'vip-repeat-find) - (define-key map "<" #'vip-command-argument) - (define-key map "=" #'vip-command-argument) - (define-key map ">" #'vip-command-argument) - (define-key map "?" #'vip-search-backward) - (define-key map "@" #'vip-nil) - - (define-key map "A" #'vip-Append) - (define-key map "B" #'vip-backward-Word) - (define-key map "C" #'vip-ctl-c-equivalent) - (define-key map "D" #'vip-kill-line) - (define-key map "E" #'vip-end-of-Word) - (define-key map "F" #'vip-find-char-backward) - (define-key map "G" #'vip-goto-line) - (define-key map "H" #'vip-window-top) - (define-key map "I" #'vip-Insert) - (define-key map "J" #'vip-join-lines) - (define-key map "K" #'vip-kill-buffer) - (define-key map "L" #'vip-window-bottom) - (define-key map "M" #'vip-window-middle) - (define-key map "N" #'vip-search-Next) - (define-key map "O" #'vip-Open-line) - (define-key map "P" #'vip-Put-back) - (define-key map "Q" #'vip-query-replace) - (define-key map "R" #'vip-replace-string) - (define-key map "S" #'vip-switch-to-buffer-other-window) - (define-key map "T" #'vip-goto-char-backward) - (define-key map "U" #'vip-nil) - (define-key map "V" #'vip-find-file-other-window) - (define-key map "W" #'vip-forward-Word) - (define-key map "X" #'vip-ctl-x-equivalent) - (define-key map "Y" #'vip-yank-line) - (define-key map "ZZ" #'save-buffers-kill-emacs) - - (define-key map "[" #'vip-nil) - (define-key map "\\" #'vip-escape-to-emacs) - (define-key map "]" #'vip-nil) - (define-key map "^" #'vip-bol-and-skip-white) - (define-key map "_" #'vip-nil) - (define-key map "`" #'vip-goto-mark) - - (define-key map "a" #'vip-append) - (define-key map "b" #'vip-backward-word) - (define-key map "c" #'vip-command-argument) - (define-key map "d" #'vip-command-argument) - (define-key map "e" #'vip-end-of-word) - (define-key map "f" #'vip-find-char-forward) - (define-key map "g" #'vip-info-on-file) - (define-key map "h" #'vip-backward-char) - (define-key map "i" #'vip-insert) - (define-key map "j" #'vip-next-line) - (define-key map "k" #'vip-previous-line) - (define-key map "l" #'vip-forward-char) - (define-key map "m" #'vip-mark-point) - (define-key map "n" #'vip-search-next) - (define-key map "o" #'vip-open-line) - (define-key map "p" #'vip-put-back) - (define-key map "q" #'vip-nil) - (define-key map "r" #'vip-replace-char) - (define-key map "s" #'vip-switch-to-buffer) - (define-key map "t" #'vip-goto-char-forward) - (define-key map "u" #'vip-undo) - (define-key map "v" #'vip-find-file) - (define-key map "w" #'vip-forward-word) - (define-key map "x" #'vip-delete-char) - (define-key map "y" #'vip-command-argument) - (define-key map "zH" #'vip-line-to-top) - (define-key map "zM" #'vip-line-to-middle) - (define-key map "zL" #'vip-line-to-bottom) - (define-key map "z\C-m" #'vip-line-to-top) - (define-key map "z." #'vip-line-to-middle) - (define-key map "z-" #'vip-line-to-bottom) - - (define-key map "{" #'vip-backward-paragraph) - (define-key map "|" #'vip-goto-col) - (define-key map "}" #'vip-forward-paragraph) - (define-key map "~" #'vip-nil) - (define-key map "\177" #'vip-delete-backward-char) - map)) - -(defun vip-version () - (interactive) - (message "VIP version 3.5 of September 15, 1987")) - - -;; basic set up - -;;;###autoload -(defun vip-setup () - "Set up bindings for C-x 7 and C-z that are useful for VIP users." - (define-key ctl-x-map "7" #'vip-buffer-in-two-windows) - (global-set-key "\C-z" #'vip-change-mode-to-vi)) - -(defmacro vip-loop (count body) - "(COUNT BODY) Execute BODY COUNT times." - `(let ((count ,count)) - (while (> count 0) - ,body - (setq count (1- count))))) - -(defun vip-push-mark-silent (&optional location) - "Set mark at LOCATION (point, by default) and push old mark on mark ring. -No message." - (if (null (mark t)) - nil - (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring)) - (if (> (length mark-ring) mark-ring-max) - (progn - (move-marker (car (nthcdr mark-ring-max mark-ring)) nil) - (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil)))) - (set-mark (or location (point)))) - -(defun vip-goto-col (arg) - "Go to ARG's column." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (save-excursion - (end-of-line) - (if (> val (1+ (current-column))) (error ""))) - (if com (move-marker vip-com-point (point))) - (beginning-of-line) - (forward-char (1- val)) - (if com (vip-execute-com 'vip-goto-col val com)))) - -(defun vip-copy-keymap (map) - (if (null map) (make-sparse-keymap) (copy-keymap map))) - - -;; changing mode - -(defun vip-change-mode (new-mode) - "Change mode to NEW-MODE---either emacs-mode, vi-mode, or insert-mode." - (or (eq new-mode vip-current-mode) - (progn - (cond ((eq new-mode 'vi-mode) - (if (eq vip-current-mode 'insert-mode) - (progn - (vip-copy-region-as-kill (point) vip-insert-point) - (vip-repeat-insert-command)) - (setq vip-emacs-local-map (current-local-map) - vip-emacs-mode-line-buffer-identification - mode-line-buffer-identification - vip-insert-local-map (vip-copy-keymap - (current-local-map)))) - (vip-change-mode-line "Vi: ") - (use-local-map vip-mode-map)) - ((eq new-mode 'insert-mode) - (move-marker vip-insert-point (point)) - (if (eq vip-current-mode 'emacs-mode) - (setq vip-emacs-local-map (current-local-map) - vip-emacs-mode-line-buffer-identification - mode-line-buffer-identification - vip-insert-local-map (vip-copy-keymap - (current-local-map))) - (setq vip-insert-local-map (vip-copy-keymap - vip-emacs-local-map))) - (vip-change-mode-line "Insert") - (use-local-map vip-insert-local-map) - (define-key vip-insert-local-map "\e" #'vip-change-mode-to-vi) - (define-key vip-insert-local-map "\C-z" #'vip-ESC) - (define-key vip-insert-local-map "\C-h" - (if vip-help-in-insert-mode #'help-command - #'delete-backward-char)) - (define-key vip-insert-local-map "\C-w" - #'vip-delete-backward-word)) - ((eq new-mode 'emacs-mode) - (vip-change-mode-line "Emacs:") - (use-local-map vip-emacs-local-map))) - (setq vip-current-mode new-mode) - (force-mode-line-update)))) - -(defun vip-copy-region-as-kill (beg end) - "If BEG and END do not belong to the same buffer, it copies empty region." - (condition-case nil - (copy-region-as-kill beg end) - (error (copy-region-as-kill beg beg)))) - -(defun vip-change-mode-line (string) - "Assuming that the mode line format contains the string \"Emacs:\", this -function replaces the string by \"Vi: \" etc." - (setq mode-line-buffer-identification - (if (string= string "Emacs:") - vip-emacs-mode-line-buffer-identification - (list (concat string " %17b"))))) - -;;;###autoload -(defun vip-mode () - "Turn on VIP emulation of VI." - (interactive) - (if (not vip-inhibit-startup-message) - (progn - (switch-to-buffer "VIP Startup Message") - (erase-buffer) - (insert - "VIP is a Vi emulation package for GNU Emacs. VIP provides most Vi commands -including Ex commands. VIP is however different from Vi in several points. -You can get more information on VIP by: - 1. Typing `M-x info' and selecting menu item \"vip\". - 2. Typing `C-h k' followed by a key whose description you want. - 3. Printing VIP manual which can be found as GNU/man/vip.texinfo - 4. Printing VIP Reference Card which can be found as GNU/etc/vipcard.tex - -This startup message appears whenever you load VIP unless you type `y' now. -Type `n' to quit this window for now.\n") - (goto-char (point-min)) - (if (y-or-n-p "Inhibit VIP startup message? ") - (progn - (with-current-buffer - (find-file-noselect - (substitute-in-file-name vip-startup-file)) - (goto-char (point-max)) - (insert "\n(setq vip-inhibit-startup-message t)\n") - (save-buffer) - (kill-buffer (current-buffer))) - (message "VIP startup message inhibited.") - (sit-for 2))) - (kill-buffer (current-buffer)) - (message "") - (setq vip-inhibit-startup-message t))) - (vip-change-mode-to-vi)) - -(defun vip-change-mode-to-vi () - "Change mode to vi mode." - (interactive) - (vip-change-mode 'vi-mode)) - -(defun vip-change-mode-to-insert () - "Change mode to insert mode." - (interactive) - (vip-change-mode 'insert-mode)) - -(defun vip-change-mode-to-emacs () - "Change mode to Emacs mode." - (interactive) - (vip-change-mode 'emacs-mode)) - - -;; escape to emacs mode temporarily - -(defun vip-escape-to-emacs (arg &optional events) - "Escape to Emacs mode for one Emacs command. -ARG is used as the prefix value for the executed command. If -EVENTS is a list of events, which become the beginning of the command." - (interactive "P") - (let (com (old-map (current-local-map))) - (if events (setq unread-command-events - (append events unread-command-events))) - (setq prefix-arg arg) - (use-local-map vip-emacs-local-map) - (unwind-protect - (setq com (key-binding (read-key-sequence nil))) - (use-local-map old-map)) - (command-execute com prefix-arg) - (setq prefix-arg nil) ;; reset prefix arg - )) - -(defun vip-message-conditions (conditions) - "Print CONDITIONS as a message." - (let ((case (car conditions)) (msg (cdr conditions))) - (if (null msg) - (message "%s" case) - (message "%s %s" case (prin1-to-string msg))) - (ding))) - -(defun vip-ESC (arg) - "Emulate ESC key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\e))) - -(defun vip-ctl-c (arg) - "Emulate C-c key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\C-c))) - -(defun vip-ctl-x (arg) - "Emulate C-x key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\C-x))) - -(defun vip-ctl-h (arg) - "Emulate C-h key in Emacs mode." - (interactive "P") - (vip-escape-to-emacs arg '(?\C-h))) - - -;; prefix argument for vi mode - -;; In vi mode, prefix argument is a dotted pair (NUM . COM) where NUM -;; represents the numeric value of the prefix argument and COM represents -;; command prefix such as "c", "d", "m" and "y". - -(defun vip-prefix-arg-value (char value com) - "Compute numeric prefix arg value. Invoked by CHAR. VALUE is the value -obtained so far, and COM is the command part obtained so far." - (while (and (>= char ?0) (<= char ?9)) - (setq value (+ (* (if (numberp value) value 0) 10) (- char ?0))) - (setq char (read-char))) - (setq prefix-arg value) - (if com (setq prefix-arg (cons prefix-arg com))) - (while (= char ?U) - (vip-describe-arg prefix-arg) - (setq char (read-char))) - (push char unread-command-events)) - -(defun vip-prefix-arg-com (char value com) - "Vi operator as prefix argument." - (let ((cont t)) - (while (and cont - (or (= char ?c) (= char ?d) (= char ?y) - (= char ?!) (= char ?<) (= char ?>) (= char ?=) - (= char ?#) (= char ?r) (= char ?R) (= char ?\"))) - (if com - ;; this means that we already have a command character, so we - ;; construct a com list and exit while. however, if char is " - ;; it is an error. - (progn - ;; new com is (CHAR . OLDCOM) - (if (or (= char ?#) (= char ?\")) (error "")) - (setq com (cons char com)) - (setq cont nil)) - ;; if com is nil we set com as char, and read more. again, if char - ;; is ", we read the name of register and store it in vip-use-register. - ;; if char is !, =, or #, a complete com is formed so we exit while. - (cond ((or (= char ?!) (= char ?=)) - (setq com char) - (setq char (read-char)) - (setq cont nil)) - ((= char ?#) - ;; read a char and encode it as com - (setq com (+ 128 (read-char))) - (setq char (read-char)) - (setq cont nil)) - ((or (= char ?<) (= char ?>)) - (setq com char) - (setq char (read-char)) - (if (= com char) (setq com (cons char com))) - (setq cont nil)) - ((= char ?\") - (let ((reg (read-char))) - (if (or (and (<= ?A reg) (<= reg ?z)) - (and (<= ?1 reg) (<= reg ?9))) - (setq vip-use-register reg) - (error "")) - (setq char (read-char)))) - (t - (setq com char) - (setq char (read-char))))))) - (if (atom com) - ;; com is a single char, so we construct prefix-arg - ;; and if char is ?, describe prefix arg, otherwise exit by - ;; pushing the char back - (progn - (setq prefix-arg (cons value com)) - (while (= char ?U) - (vip-describe-arg prefix-arg) - (setq char (read-char))) - (push char unread-command-events)) - ;; as com is non-nil, this means that we have a command to execute - (if (or (= (car com) ?r) (= (car com) ?R)) - ;; execute appropriate region command. - (let ((char (car com)) (com (cdr com))) - (setq prefix-arg (cons value com)) - (if (= char ?r) (vip-region prefix-arg) - (vip-Region prefix-arg)) - ;; reset prefix-arg - (setq prefix-arg nil)) - ;; otherwise, reset prefix arg and call appropriate command - (setq value (if (null value) 1 value)) - (setq prefix-arg nil) - (cond ((equal com '(?c . ?c)) (vip-line (cons value ?C))) - ((equal com '(?d . ?d)) (vip-line (cons value ?D))) - ((equal com '(?d . ?y)) (vip-yank-defun)) - ((equal com '(?y . ?y)) (vip-line (cons value ?Y))) - ((equal com '(?< . ?<)) (vip-line (cons value ?<))) - ((equal com '(?> . ?>)) (vip-line (cons value ?>))) - ((equal com '(?! . ?!)) (vip-line (cons value ?!))) - ((equal com '(?= . ?=)) (vip-line (cons value ?=))) - (t (error "")))))) - -(defun vip-describe-arg (arg) - (let (val com) - (setq val (vip-P-val arg) - com (vip-getcom arg)) - (if (null val) - (if (null com) - (message "Value is nil, and command is nil.") - (message "Value is nil, and command is %c." com)) - (if (null com) - (message "Value is %d, and command is nil." val) - (message "Value is %d, and command is %c." val com))))) - -(defun vip-digit-argument (arg) - "Begin numeric argument for the next command." - (interactive "P") - (vip-prefix-arg-value last-command-event nil - (if (consp arg) (cdr arg) nil))) - -(defun vip-command-argument (arg) - "Accept a motion command as an argument." - (interactive "P") - (condition-case nil - (vip-prefix-arg-com - last-command-event - (cond ((null arg) nil) - ((consp arg) (car arg)) - ((numberp arg) arg) - (t (error "Strange arg"))) - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - ((numberp arg) nil) - (t (error "Strange arg")))) - (quit - (setq vip-use-register nil) - (signal 'quit nil)))) - -(defun vip-p-val (arg) - "Get value part of prefix-argument ARG." - (cond ((null arg) 1) - ((consp arg) (if (null (car arg)) 1 (car arg))) - (t arg))) - -(defun vip-P-val (arg) - "Get value part of prefix-argument ARG." - (cond ((consp arg) (car arg)) - (t arg))) - -(defun vip-getcom (arg) - "Get com part of prefix-argument ARG." - (cond ((null arg) nil) - ((consp arg) (cdr arg)) - (t nil))) - -(defun vip-getCom (arg) - "Get com part of prefix-argument ARG and modify it." - (let ((com (vip-getcom arg))) - (cond ((equal com ?c) ?C) - ((equal com ?d) ?D) - ((equal com ?y) ?Y) - (t com)))) - - -;; repeat last destructive command - -(defun vip-append-to-register (reg start end) - "Append region to text in register REG. -START and END are buffer positions indicating what to append." - (set-register reg (concat (or (get-register reg) "") - (buffer-substring start end)))) - -(defun vip-execute-com (m-com val com) - "(M-COM VAL COM) Execute command COM. The list (M-COM VAL COM) is set -to vip-d-com for later use by vip-repeat" - (let ((reg vip-use-register)) - (if com - (cond ((= com ?c) (vip-change vip-com-point (point))) - ((= com (- ?c)) (vip-change-subr vip-com-point (point))) - ((or (= com ?C) (= com (- ?C))) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register (mark) (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (mark) (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (delete-region (mark) (point))) - (open-line 1) - (if (= com ?C) (vip-change-mode-to-insert) (yank))) - ((= com ?d) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register vip-com-point (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) vip-com-point (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command - (if (eq last-command 'd-command) 'kill-region nil)) - (kill-region vip-com-point (point)) - (setq this-command 'd-command)) - ((= com ?D) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register (mark) (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (mark) (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command - (if (eq last-command 'D-command) 'kill-region nil)) - (kill-region (mark) (point)) - (if (eq m-com 'vip-line) (setq this-command 'D-command))) - (back-to-indentation)) - ((= com ?y) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register vip-com-point (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) vip-com-point (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command nil) - (copy-region-as-kill vip-com-point (point)) - (goto-char vip-com-point)) - ((= com ?Y) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if vip-use-register - (progn - (cond ((and (<= ?a vip-use-register) - (<= vip-use-register ?z)) - (copy-to-register - vip-use-register (mark) (point) nil)) - ((and (<= ?A vip-use-register) - (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (mark) (point))) - (t (setq vip-use-register nil) - (error ""))) - (setq vip-use-register nil))) - (setq last-command nil) - (copy-region-as-kill (mark) (point))) - (goto-char vip-com-point)) - ((or (= com ?!) (= com (- ?!))) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (shell-command-on-region - (mark) (point) - (if (= com ?!) - (setq vip-last-shell-com (vip-read-string "!")) - vip-last-shell-com) - t t))) - ((= com ?=) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (if (> (mark) (point)) (exchange-point-and-mark)) - (indent-region (mark) (point) nil))) - ((= com ?<) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (indent-rigidly (mark) (point) (- vip-shift-width))) - (goto-char vip-com-point)) - ((= com ?>) - (save-excursion - (set-mark vip-com-point) - (vip-enlarge-region (mark) (point)) - (indent-rigidly (mark) (point) vip-shift-width)) - (goto-char vip-com-point)) - ((>= com 128) - ;; this is special command # - (vip-special-prefix-com (- com 128))))) - (setq vip-d-com (list m-com val (if (or (= com ?c) (= com ?C) (= com ?!)) - (- com) com) - reg)))) - -(defun vip-repeat (arg) - "(ARG) Re-execute last destructive command. vip-d-com has the form -\(COM ARG CH REG), where COM is the command to be re-executed, ARG is the -argument for COM, CH is a flag for repeat, and REG is optional and if exists -is the name of the register for COM." - (interactive "P") - (if (eq last-command 'vip-undo) - ;; if the last command was vip-undo, then undo-more - (vip-undo-more) - ;; otherwise execute the command stored in vip-d-com. if arg is non-nil - ;; its prefix value is used as new prefix value for the command. - (let ((m-com (car vip-d-com)) - (val (vip-P-val arg)) - (com (car (cdr (cdr vip-d-com)))) - (reg (nth 3 vip-d-com))) - (if (null val) (setq val (car (cdr vip-d-com)))) - (if (null m-com) (error "No previous command to repeat")) - (setq vip-use-register reg) - (funcall m-com (cons val com))))) - -(defun vip-special-prefix-com (char) - "This command is invoked interactively by the key sequence #<char>" - (cond ((= char ?c) - (downcase-region (min vip-com-point (point)) - (max vip-com-point (point)))) - ((= char ?C) - (upcase-region (min vip-com-point (point)) - (max vip-com-point (point)))) - ((= char ?g) - (set-mark vip-com-point) - (vip-global-execute)) - ((= char ?q) - (set-mark vip-com-point) - (vip-quote-region)) - ((= char ?s) (ispell-region vip-com-point (point))))) - - -;; undoing - -(defun vip-undo () - "Undo previous change." - (interactive) - (message "undo!") - (undo-start) - (undo-more 2) - (setq this-command 'vip-undo)) - -(defun vip-undo-more () - "Continue undoing previous changes." - (message "undo more!") - (undo-more 1) - (setq this-command 'vip-undo)) - - -;; utilities - -(defun vip-string-tail (str) - (if (or (null str) (string= str "")) nil - (substring str 1))) - -(defun vip-yank-defun () - (mark-defun) - (copy-region-as-kill (point) (mark))) - -(defun vip-enlarge-region (beg end) - "Enlarge region between BEG and END." - (if (< beg end) - (progn (goto-char beg) (set-mark end)) - (goto-char end) - (set-mark beg)) - (beginning-of-line) - (exchange-point-and-mark) - (if (or (not (eobp)) (not (bolp))) (with-no-warnings (next-line 1))) - (beginning-of-line) - (if (> beg end) (exchange-point-and-mark))) - -(defun vip-global-execute () - "Call last keyboard macro for each line in the region." - (if (> (point) (mark)) (exchange-point-and-mark)) - (beginning-of-line) - (call-last-kbd-macro) - (while (< (point) (mark)) - (forward-line 1) - (beginning-of-line) - (call-last-kbd-macro))) - -(defun vip-quote-region () - "Quote region by inserting the user supplied string at the beginning of -each line in the region." - (setq vip-quote-string - (let ((str - (vip-read-string (format "quote string (default %s): " - vip-quote-string)))) - (if (string= str "") vip-quote-string str))) - (vip-enlarge-region (point) (mark)) - (if (> (point) (mark)) (exchange-point-and-mark)) - (insert vip-quote-string) - (beginning-of-line) - (forward-line 1) - (while (and (< (point) (mark)) (bolp)) - (insert vip-quote-string) - (beginning-of-line) - (forward-line 1))) - -(defun vip-end-with-a-newline-p (string) - "Check if the string ends with a newline." - (or (string= string "") - (= (aref string (1- (length string))) ?\n))) - -(defvar vip-save-minibuffer-local-map) - -(defun vip-read-string (prompt &optional init) - (setq vip-save-minibuffer-local-map (copy-keymap minibuffer-local-map)) - (define-key minibuffer-local-map "\C-h" #'backward-char) - (define-key minibuffer-local-map "\C-w" #'backward-word) - (define-key minibuffer-local-map "\e" #'exit-minibuffer) - (let (str) - (condition-case nil - (setq str (read-string prompt init)) - (quit - (setq minibuffer-local-map vip-save-minibuffer-local-map) - (signal 'quit nil))) - (setq minibuffer-local-map vip-save-minibuffer-local-map) - str)) - - -;; insertion commands - -(defun vip-repeat-insert-command () - "This function is called when mode changes from insertion mode to -vi command mode. It will repeat the insertion command if original insertion -command was invoked with argument > 1." - (let ((i-com (car vip-d-com)) (val (car (cdr vip-d-com)))) - (if (and val (> val 1)) ;; first check that val is non-nil - (progn - (setq vip-d-com (list i-com (1- val) ?r)) - (vip-repeat nil) - (setq vip-d-com (list i-com val ?r)))))) - -(defun vip-insert (arg) "" - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-insert val ?r)) - (if com (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-append (arg) - "Append after point." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-append val ?r)) - (if (not (eolp)) (forward-char)) - (if (equal com ?r) - (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-Append (arg) - "Append at end of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-Append val ?r)) - (end-of-line) - (if (equal com ?r) - (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-Insert (arg) - "Insert before first non-white." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-Insert val ?r)) - (back-to-indentation) - (if (equal com ?r) - (vip-loop val (yank)) - (vip-change-mode-to-insert)))) - -(defun vip-open-line (arg) - "Open line below." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-open-line val ?r)) - (let ((col (current-indentation))) - (if (equal com ?r) - (vip-loop val - (progn - (end-of-line) - (newline 1) - (if vip-open-with-indent (indent-to col)) - (yank))) - (end-of-line) - (newline 1) - (if vip-open-with-indent (indent-to col)) - (vip-change-mode-to-insert))))) - -(defun vip-Open-line (arg) - "Open line above." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-Open-line val ?r)) - (let ((col (current-indentation))) - (if (equal com ?r) - (vip-loop val - (progn - (beginning-of-line) - (open-line 1) - (if vip-open-with-indent (indent-to col)) - (yank))) - (beginning-of-line) - (open-line 1) - (if vip-open-with-indent (indent-to col)) - (vip-change-mode-to-insert))))) - -(defun vip-open-line-at-point (arg) - "Open line at point." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-open-line-at-point val ?r)) - (if (equal com ?r) - (vip-loop val - (progn - (open-line 1) - (yank))) - (open-line 1) - (vip-change-mode-to-insert)))) - -(defun vip-substitute (arg) - "Substitute characters." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (save-excursion - (set-mark (point)) - (forward-char val) - (if (equal com ?r) - (vip-change-subr (mark) (point)) - (vip-change (mark) (point)))) - (setq vip-d-com (list 'vip-substitute val ?r)))) - -(defun vip-substitute-line (arg) - "Substitute lines." - (interactive "p") - (vip-line (cons arg ?C))) - - -;; line command - -(defun vip-line (arg) - (let ((val (car arg)) (com (cdr arg))) - (move-marker vip-com-point (point)) - (with-no-warnings (next-line (1- val))) - (vip-execute-com 'vip-line val com))) - -(defun vip-yank-line (arg) - "Yank ARG lines (in vi's sense)" - (interactive "P") - (let ((val (vip-p-val arg))) - (vip-line (cons val ?Y)))) - - -;; region command - -(defun vip-region (arg) - (interactive "P") - (let ((val (vip-P-val arg)) - (com (vip-getcom arg))) - (move-marker vip-com-point (point)) - (exchange-point-and-mark) - (vip-execute-com 'vip-region val com))) - -(defun vip-Region (arg) - (interactive "P") - (let ((val (vip-P-val arg)) - (com (vip-getCom arg))) - (move-marker vip-com-point (point)) - (exchange-point-and-mark) - (vip-execute-com 'vip-Region val com))) - -(defun vip-replace-char (arg) - "Replace the following ARG chars by the character read." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (setq vip-d-com (list 'vip-replace-char val ?r)) - (vip-replace-char-subr (if (equal com ?r) vip-d-char (read-char)) val))) - -(defun vip-replace-char-subr (char arg) - (delete-char arg t) - (setq vip-d-char char) - (vip-loop (if (> arg 0) arg (- arg)) (insert char)) - (backward-char arg)) - -(defun vip-replace-string () - "Replace string. If you supply null string as the string to be replaced, -the query replace mode will toggle between string replace and regexp replace." - (interactive) - (let (str) - (setq str (vip-read-string - (if vip-re-replace "Replace regexp: " "Replace string: "))) - (if (string= str "") - (progn - (setq vip-re-replace (not vip-re-replace)) - (message "Replace mode changed to %s." - (if vip-re-replace "regexp replace" - "string replace"))) - (if vip-re-replace - ;; (replace-regexp - ;; str - ;; (vip-read-string (format "Replace regexp \"%s\" with: " str))) - (while (re-search-forward str nil t) - (replace-match (vip-read-string - (format "Replace regexp \"%s\" with: " str)) - nil nil)) - (with-no-warnings - (replace-string - str - (vip-read-string (format "Replace \"%s\" with: " str)))))))) - - -;; basic cursor movement. j, k, l, m commands. - -(defun vip-forward-char (arg) - "Move point right ARG characters (left if ARG negative).On reaching end -of buffer, stop and signal error." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-char val) - (if com (vip-execute-com 'vip-forward-char val com)))) - -(defun vip-backward-char (arg) - "Move point left ARG characters (right if ARG negative). On reaching -beginning of buffer, stop and signal error." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (backward-char val) - (if com (vip-execute-com 'vip-backward-char val com)))) - - -;; word command - -(defun vip-forward-word (arg) - "Forward word." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-word val) - (skip-chars-forward " \t\n") - (if com - (progn - (if (or (= com ?c) (= com (- ?c))) - (progn (backward-word 1) (forward-word 1))) - (if (or (= com ?d) (= com ?y)) - (progn - (backward-word 1) - (forward-word 1) - (skip-chars-forward " \t"))) - (vip-execute-com 'vip-forward-word val com))))) - -(defun vip-end-of-word (arg) - "Move point to end of current word." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-char) - (forward-word val) - (backward-char) - (if com - (progn - (forward-char) - (vip-execute-com 'vip-end-of-word val com))))) - -(defun vip-backward-word (arg) - "Backward word." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (backward-word val) - (if com (vip-execute-com 'vip-backward-word val com)))) - -(defun vip-forward-Word (arg) - "Forward word delimited by white character." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (re-search-forward "[^ \t\n]*[ \t\n]+" nil t val) - (if com - (progn - (if (or (= com ?c) (= com (- ?c))) - (progn (backward-word 1) (forward-word 1))) - (if (or (= com ?d) (= com ?y)) - (progn - (backward-word 1) - (forward-word 1) - (skip-chars-forward " \t"))) - (vip-execute-com 'vip-forward-Word val com))))) - -(defun vip-end-of-Word (arg) - "Move forward to end of word delimited by white character." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-char) - (if (re-search-forward "[^ \t\n]+" nil t val) (backward-char)) - (if com - (progn - (forward-char) - (vip-execute-com 'vip-end-of-Word val com))))) - -(defun vip-backward-Word (arg) - "Backward word delimited by white character." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (if (re-search-backward "[ \t\n]+[^ \t\n]+" nil t val) - (forward-char) - (goto-char (point-min))) - (if com (vip-execute-com 'vip-backward-Word val com)))) - -(defun vip-beginning-of-line (arg) - "Go to beginning of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (beginning-of-line val) - (if com (vip-execute-com 'vip-beginning-of-line val com)))) - -(defun vip-bol-and-skip-white (arg) - "Beginning of line at first non-white character." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (back-to-indentation) - (if com (vip-execute-com 'vip-bol-and-skip-white val com)))) - -(defun vip-goto-eol (arg) - "Go to end of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (end-of-line val) - (if com (vip-execute-com 'vip-goto-eol val com)))) - -(defun vip-next-line (arg) - "Go to next line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (line-move val) - (setq this-command 'next-line) - (if com (vip-execute-com 'vip-next-line val com)))) - -(defun vip-next-line-at-bol (arg) - "Next line at beginning of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (with-no-warnings (next-line val)) - (back-to-indentation) - (if com (vip-execute-com 'vip-next-line-at-bol val com)))) - -(defun vip-previous-line (arg) - "Go to previous line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (with-no-warnings (next-line (- val))) - (setq this-command 'previous-line) - (if com (vip-execute-com 'vip-previous-line val com)))) - -(defun vip-previous-line-at-bol (arg) - "Previous line at beginning of line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (with-no-warnings (next-line (- val))) - (back-to-indentation) - (if com (vip-execute-com 'vip-previous-line val com)))) - -(defun vip-change-to-eol (arg) - "Change to end of line." - (interactive "P") - (vip-goto-eol (cons arg ?c))) - -(defun vip-kill-line (arg) - "Delete line." - (interactive "P") - (vip-goto-eol (cons arg ?d))) - - -;; moving around - -(defun vip-goto-line (arg) - "Go to ARG's line. Without ARG go to end of buffer." - (interactive "P") - (let ((val (vip-P-val arg)) (com (vip-getCom arg))) - (move-marker vip-com-point (point)) - (set-mark (point)) - (if (null val) - (goto-char (point-max)) - (goto-char (point-min)) - (forward-line (1- val))) - (back-to-indentation) - (if com (vip-execute-com 'vip-goto-line val com)))) - -(defun vip-find-char (arg char forward offset) - "Find ARG's occurrence of CHAR on the current line. If FORWARD then -search is forward, otherwise backward. OFFSET is used to adjust point -after search." - (let ((arg (if forward arg (- arg))) point) - (save-excursion - (save-restriction - (if (> arg 0) - (narrow-to-region - ;; forward search begins here - (if (eolp) (error "") (point)) - ;; forward search ends here - (progn (with-no-warnings (next-line 1)) (beginning-of-line) (point))) - (narrow-to-region - ;; backward search begins from here - (if (bolp) (error "") (point)) - ;; backward search ends here - (progn (beginning-of-line) (point)))) - ;; if arg > 0, point is forwarded before search. - (if (> arg 0) (goto-char (1+ (point-min))) - (goto-char (point-max))) - (let ((case-fold-search nil)) - (search-forward (char-to-string char) nil 0 arg)) - (setq point (point)) - (if (or (and (> arg 0) (= point (point-max))) - (and (< arg 0) (= point (point-min)))) - (error "")))) - (goto-char (+ point (if (> arg 0) (if offset -2 -1) (if offset 1 0)))))) - -(defun vip-find-char-forward (arg) - "Find char on the line. If called interactively read the char to find -from the terminal, and if called from vip-repeat, the char last used is -used. This behavior is controlled by the sign of prefix numeric value." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward t - vip-f-offset nil) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) t nil) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (forward-char) - (vip-execute-com 'vip-find-char-forward val com))))) - -(defun vip-goto-char-forward (arg) - "Go up to char ARG forward on line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward t - vip-f-offset t) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) t t) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (forward-char) - (vip-execute-com 'vip-goto-char-forward val com))))) - -(defun vip-find-char-backward (arg) - "Find char ARG on line backward." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward nil - vip-f-offset nil) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char - val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) nil nil) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (vip-execute-com 'vip-find-char-backward val com))))) - -(defun vip-goto-char-backward (arg) - "Go up to char ARG backward on line." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (> val 0) - ;; this means that the function was called interactively - (setq vip-f-char (read-char) - vip-f-forward nil - vip-f-offset t) - (setq val (- val))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val (if (> (vip-p-val arg) 0) vip-f-char vip-F-char) nil t) - (setq val (- val)) - (if com - (progn - (setq vip-F-char vip-f-char);; set new vip-F-char - (vip-execute-com 'vip-goto-char-backward val com))))) - -(defun vip-repeat-find (arg) - "Repeat previous find command." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val vip-f-char vip-f-forward vip-f-offset) - (if com - (progn - (if vip-f-forward (forward-char)) - (vip-execute-com 'vip-repeat-find val com))))) - -(defun vip-repeat-find-opposite (arg) - "Repeat previous find command in the opposite direction." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (vip-find-char val vip-f-char (not vip-f-forward) vip-f-offset) - (if com - (progn - (if vip-f-forward (forward-char)) - (vip-execute-com 'vip-repeat-find-opposite val com))))) - - -;; window scrolling etc. - -(defun vip-other-window (arg) - "Switch to other window." - (interactive "p") - (other-window arg) - (or (not (eq vip-current-mode 'emacs-mode)) - (string= (buffer-name (current-buffer)) " *Minibuf-1*") - (vip-change-mode-to-vi))) - -(defun vip-window-top (arg) - "Go to home window line." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (move-to-window-line (1- val)) - (if com (vip-execute-com 'vip-window-top val com)))) - -(defun vip-window-middle (arg) - "Go to middle window line." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (move-to-window-line (+ (/ (1- (window-height)) 2) (1- val))) - (if com (vip-execute-com 'vip-window-middle val com)))) - -(defun vip-window-bottom (arg) - "Go to last window line." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (move-to-window-line (- val)) - (if com (vip-execute-com 'vip-window-bottom val com)))) - -(defun vip-line-to-top (arg) - "Put current line on the home line." - (interactive "p") - (recenter (1- arg))) - -(defun vip-line-to-middle (arg) - "Put current line on the middle line." - (interactive "p") - (recenter (+ (1- arg) (/ (1- (window-height)) 2)))) - -(defun vip-line-to-bottom (arg) - "Put current line on the last line." - (interactive "p") - (recenter (- (window-height) (1+ arg)))) - - -;; paren match - -(defun vip-paren-match (arg) - "Go to the matching parenthesis." - (interactive "P") - (let ((com (vip-getcom arg))) - (if (numberp arg) - (if (or (> arg 99) (< arg 1)) - (error "Prefix must be between 1 and 99") - (goto-char - (if (> (point-max) 80000) - (* (/ (point-max) 100) arg) - (/ (* (point-max) arg) 100))) - (back-to-indentation)) - (cond ((looking-at "[([{]") - (if com (move-marker vip-com-point (point))) - (forward-sexp 1) - (if com - (vip-execute-com 'vip-paren-match nil com) - (backward-char))) - ((looking-at "[])}]") - (forward-char) - (if com (move-marker vip-com-point (point))) - (backward-sexp 1) - (if com (vip-execute-com 'vip-paren-match nil com))) - (t (error "")))))) - - -;; sentence and paragraph - -(defun vip-forward-sentence (arg) - "Forward sentence." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (forward-sentence val) - (if com (vip-execute-com 'vip-forward-sentence nil com)))) - -(defun vip-backward-sentence (arg) - "Backward sentence." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getcom arg))) - (if com (move-marker vip-com-point (point))) - (backward-sentence val) - (if com (vip-execute-com 'vip-backward-sentence nil com)))) - -(defun vip-forward-paragraph (arg) - "Forward paragraph." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (forward-paragraph val) - (if com (vip-execute-com 'vip-forward-paragraph nil com)))) - -(defun vip-backward-paragraph (arg) - "Backward paragraph." - (interactive "P") - (let ((val (vip-p-val arg)) - (com (vip-getCom arg))) - (if com (move-marker vip-com-point (point))) - (backward-paragraph val) - (if com (vip-execute-com 'vip-backward-paragraph nil com)))) - - -;; scrolling - -(defun vip-scroll (arg) - "Scroll to next screen." - (interactive "p") - (if (> arg 0) - (while (> arg 0) - (scroll-up) - (setq arg (1- arg))) - (while (> 0 arg) - (scroll-down) - (setq arg (1+ arg))))) - -(defun vip-scroll-back (arg) - "Scroll to previous screen." - (interactive "p") - (vip-scroll (- arg))) - -(defun vip-scroll-down (arg) - "Scroll up half screen." - (interactive "P") - (if (null arg) (scroll-down (/ (window-height) 2)) - (scroll-down arg))) - -(defun vip-scroll-down-one (arg) - "Scroll up one line." - (interactive "p") - (scroll-down arg)) - -(defun vip-scroll-up (arg) - "Scroll down half screen." - (interactive "P") - (if (null arg) (scroll-up (/ (window-height) 2)) - (scroll-up arg))) - -(defun vip-scroll-up-one (arg) - "Scroll down one line." - (interactive "p") - (scroll-up arg)) - - -;; splitting window - -(defun vip-buffer-in-two-windows () - "Show current buffer in two windows." - (interactive) - (delete-other-windows) - (split-window-below)) - - -;; searching - -(defun vip-search-forward (arg) - "Search a string forward. ARG is used to find the ARG's occurrence -of the string. Default is vanilla search. Search mode can be toggled by -giving null search string." - (interactive "P") - (let ((val (vip-P-val arg)) (com (vip-getcom arg))) - (setq vip-s-forward t - vip-s-string (vip-read-string (if vip-re-search "RE-/" "/"))) - (if (string= vip-s-string "") - (progn - (setq vip-re-search (not vip-re-search)) - (message "Search mode changed to %s search." - (if vip-re-search "regular expression" - "vanilla"))) - (vip-search vip-s-string t val) - (if com - (progn - (move-marker vip-com-point (mark)) - (vip-execute-com 'vip-search-next val com)))))) - -(defun vip-search-backward (arg) - "Search a string backward. ARG is used to find the ARG's occurrence -of the string. Default is vanilla search. Search mode can be toggled by -giving null search string." - (interactive "P") - (let ((val (vip-P-val arg)) (com (vip-getcom arg))) - (setq vip-s-forward nil - vip-s-string (vip-read-string (if vip-re-search "RE-?" "?"))) - (if (string= vip-s-string "") - (progn - (setq vip-re-search (not vip-re-search)) - (message "Search mode changed to %s search." - (if vip-re-search "regular expression" - "vanilla"))) - (vip-search vip-s-string nil val) - (if com - (progn - (move-marker vip-com-point (mark)) - (vip-execute-com 'vip-search-next val com)))))) - -(defun vip-search (string forward arg &optional no-offset init-point) - "(STRING FORWARD COUNT &optional NO-OFFSET) Search COUNT's occurrence of -STRING. Search will be forward if FORWARD, otherwise backward." - (let ((val (vip-p-val arg)) (com (vip-getcom arg)) - (null-arg (null (vip-P-val arg))) (offset (not no-offset)) - (case-fold-search vip-case-fold-search) - (start-point (or init-point (point)))) - (if forward - (condition-case conditions - (progn - (if (and offset (not (eobp))) (forward-char)) - (if vip-re-search - (progn - (re-search-forward string nil nil val) - (re-search-backward string)) - (search-forward string nil nil val) - (search-backward string)) - (push-mark start-point)) - (search-failed - (if (and null-arg vip-search-wrap-around) - (progn - (goto-char (point-min)) - (vip-search string forward (cons 1 com) t start-point)) - (goto-char start-point) - (signal 'search-failed (cdr conditions))))) - (condition-case conditions - (progn - (if vip-re-search - (re-search-backward string nil nil val) - (search-backward string nil nil val)) - (push-mark start-point)) - (search-failed - (if (and null-arg vip-search-wrap-around) - (progn - (goto-char (point-max)) - (vip-search string forward (cons 1 com) t start-point)) - (goto-char start-point) - (signal 'search-failed (cdr conditions)))))))) - -(defun vip-search-next (arg) - "Repeat previous search." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (null vip-s-string) (error "No previous search string")) - (vip-search vip-s-string vip-s-forward arg) - (if com (vip-execute-com 'vip-search-next val com)))) - -(defun vip-search-Next (arg) - "Repeat previous search in the reverse direction." - (interactive "P") - (let ((val (vip-p-val arg)) (com (vip-getcom arg))) - (if (null vip-s-string) (error "No previous search string")) - (vip-search vip-s-string (not vip-s-forward) arg) - (if com (vip-execute-com 'vip-search-Next val com)))) - - -;; visiting and killing files, buffers - -(defun vip-switch-to-buffer () - "Switch to buffer in the current window." - (interactive) - (let (buffer) - (setq buffer - (read-buffer - (format "switch to buffer (%s): " - (buffer-name (other-buffer (current-buffer)))))) - (switch-to-buffer buffer) - (vip-change-mode-to-vi))) - -(defun vip-switch-to-buffer-other-window () - "Switch to buffer in another window." - (interactive) - (let (buffer) - (setq buffer - (read-buffer - (format "Switch to buffer (%s): " - (buffer-name (other-buffer (current-buffer)))))) - (switch-to-buffer-other-window buffer) - (vip-change-mode-to-vi))) - -(defun vip-kill-buffer () - "Kill a buffer." - (interactive) - (let (buffer buffer-name) - (setq buffer-name - (read-buffer - (format "Kill buffer (%s): " - (buffer-name (current-buffer))))) - (setq buffer - (if (null buffer-name) - (current-buffer) - (get-buffer buffer-name))) - (if (null buffer) (error "Buffer %s nonexistent" buffer-name)) - (if (or (not (buffer-modified-p buffer)) - (y-or-n-p "Buffer is modified, are you sure? ")) - (kill-buffer buffer) - (error "Buffer not killed")))) - -(defun vip-find-file () - "Visit file in the current window." - (interactive) - (let (file) - (setq file (read-file-name "visit file: ")) - (switch-to-buffer (find-file-noselect file)) - (vip-change-mode-to-vi))) - -(defun vip-find-file-other-window () - "Visit file in another window." - (interactive) - (let (file) - (setq file (read-file-name "Visit file: ")) - (switch-to-buffer-other-window (find-file-noselect file)) - (vip-change-mode-to-vi))) - -(defun vip-info-on-file () - "Give information of the file associated to the current buffer." - (interactive) - (message "\"%s\" line %d of %d" - (if (buffer-file-name) (buffer-file-name) "") - (1+ (count-lines (point-min) (point))) - (1+ (count-lines (point-min) (point-max))))) - - -;; yank and pop - -(defun vip-yank (text) - "yank TEXT silently." - (save-excursion - (vip-push-mark-silent (point)) - (insert text) - (exchange-point-and-mark)) - (skip-chars-forward " \t")) - -(defun vip-put-back (arg) - "Put back after point/below line." - (interactive "P") - (let ((val (vip-p-val arg)) - (text (if vip-use-register - (if (and (<= ?1 vip-use-register) (<= vip-use-register ?9)) - (current-kill (- vip-use-register ?1) 'do-not-rotate) - (get-register vip-use-register)) - (current-kill 0)))) - (if (null text) - (if vip-use-register - (let ((reg vip-use-register)) - (setq vip-use-register nil) - (error "Nothing in register %c" reg)) - (error ""))) - (setq vip-use-register nil) - (if (vip-end-with-a-newline-p text) - (progn - (with-no-warnings (next-line 1)) - (beginning-of-line)) - (if (and (not (eolp)) (not (eobp))) (forward-char))) - (setq vip-d-com (list 'vip-put-back val nil vip-use-register)) - (vip-loop val (vip-yank text)))) - -(defun vip-Put-back (arg) - "Put back at point/above line." - (interactive "P") - (let ((val (vip-p-val arg)) - (text (if vip-use-register - (if (and (<= ?1 vip-use-register) (<= vip-use-register ?9)) - (current-kill (- vip-use-register ?1) 'do-not-rotate) - (get-register vip-use-register)) - (current-kill 0)))) - (if (null text) - (if vip-use-register - (let ((reg vip-use-register)) - (setq vip-use-register nil) - (error "Nothing in register %c" reg)) - (error ""))) - (setq vip-use-register nil) - (if (vip-end-with-a-newline-p text) (beginning-of-line)) - (setq vip-d-com (list 'vip-Put-back val nil vip-use-register)) - (vip-loop val (vip-yank text)))) - -(defun vip-delete-char (arg) - "Delete character." - (interactive "P") - (let ((val (vip-p-val arg))) - (setq vip-d-com (list 'vip-delete-char val nil)) - (if vip-use-register - (progn - (if (and (<= ?A vip-use-register) (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (point) (- (point) val)) - (copy-to-register vip-use-register (point) (- (point) val) nil)) - (setq vip-use-register nil))) - (delete-char val t))) - -(defun vip-delete-backward-char (arg) - "Delete previous character." - (interactive "P") - (let ((val (vip-p-val arg))) - (setq vip-d-com (list 'vip-delete-backward-char val nil)) - (if vip-use-register - (progn - (if (and (<= ?A vip-use-register) (<= vip-use-register ?Z)) - (vip-append-to-register - (+ vip-use-register 32) (point) (+ (point) val)) - (copy-to-register vip-use-register (point) (+ (point) val) nil)) - (setq vip-use-register nil))) - (with-no-warnings (delete-backward-char val t)))) - - -;; join lines. - -(defun vip-join-lines (arg) - "Join this line to next, if ARG is nil. Otherwise, join ARG lines" - (interactive "*P") - (let ((val (vip-P-val arg))) - (setq vip-d-com (list 'vip-join-lines val nil)) - (vip-loop (if (null val) 1 (1- val)) - (progn - (end-of-line) - (if (not (eobp)) - (progn - (forward-line 1) - (delete-region (point) (1- (point))) - (fixup-whitespace))))))) - - -;; making small changes - -(defvar vip-c-string) - -(defun vip-change (beg end) - (setq vip-c-string - (vip-read-string (format "%s => " (buffer-substring beg end)))) - (vip-change-subr beg end)) - -(defun vip-change-subr (beg end) - (if vip-use-register - (progn - (copy-to-register vip-use-register beg end nil) - (setq vip-use-register nil))) - (kill-region beg end) - (setq this-command 'vip-change) - (insert vip-c-string)) - - -;; query replace - -(defun vip-query-replace () - "Query replace. If you supply null string as the string to be replaced, -the query replace mode will toggle between string replace and regexp replace." - (interactive) - (let (str) - (setq str (vip-read-string - (if vip-re-query-replace "Query replace regexp: " - "Query replace: "))) - (if (string= str "") - (progn - (setq vip-re-query-replace (not vip-re-query-replace)) - (message "Query replace mode changed to %s." - (if vip-re-query-replace "regexp replace" - "string replace"))) - (if vip-re-query-replace - (query-replace-regexp - str - (vip-read-string (format "Query replace regexp \"%s\" with: " str))) - (query-replace - str - (vip-read-string (format "Query replace \"%s\" with: " str))))))) - - -;; marking - -(defun vip-mark-beginning-of-buffer () - (interactive) - (set-mark (point)) - (goto-char (point-min)) - (exchange-point-and-mark) - (message "mark set at the beginning of buffer")) - -(defun vip-mark-end-of-buffer () - (interactive) - (set-mark (point)) - (goto-char (point-max)) - (exchange-point-and-mark) - (message "mark set at the end of buffer")) - -(defun vip-mark-point (char) - (interactive "c") - (cond ((and (<= ?a char) (<= char ?z)) - (point-to-register (- char (- ?a ?\C-a)) nil)) - ((= char ?<) (vip-mark-beginning-of-buffer)) - ((= char ?>) (vip-mark-end-of-buffer)) - ((= char ?.) (push-mark)) - ((= char ?,) (set-mark-command 1)) - ((= char ?D) (mark-defun)) - (t (error "")))) - -(defun vip-goto-mark (arg) - "Go to mark." - (interactive "P") - (let ((char (read-char)) (com (vip-getcom arg))) - (vip-goto-mark-subr char com nil))) - -(defun vip-goto-mark-and-skip-white (arg) - "Go to mark and skip to first non-white on line." - (interactive "P") - (let ((char (read-char)) (com (vip-getCom arg))) - (vip-goto-mark-subr char com t))) - -(defun vip-goto-mark-subr (char com skip-white) - (cond ((and (<= ?a char) (<= char ?z)) - (let ((buff (current-buffer))) - (if com (move-marker vip-com-point (point))) - (goto-char (register-to-point (- char (- ?a ?\C-a)))) - (if skip-white (back-to-indentation)) - (vip-change-mode-to-vi) - (if com - (if (equal buff (current-buffer)) - (vip-execute-com (if skip-white - 'vip-goto-mark-and-skip-white - 'vip-goto-mark) - nil com) - (switch-to-buffer buff) - (goto-char vip-com-point) - (vip-change-mode-to-vi) - (error ""))))) - ((and (not skip-white) (= char ?`)) - (if com (move-marker vip-com-point (point))) - (exchange-point-and-mark) - (if com (vip-execute-com 'vip-goto-mark nil com))) - ((and skip-white (= char ?')) - (if com (move-marker vip-com-point (point))) - (exchange-point-and-mark) - (back-to-indentation) - (if com (vip-execute-com 'vip-goto-mark-and-skip-white nil com))) - (t (error "")))) - -(defun vip-exchange-point-and-mark () - (interactive) - (exchange-point-and-mark) - (back-to-indentation)) - -(defun vip-keyboard-quit () - "Abort partially formed or running command." - (interactive) - (setq vip-use-register nil) - (keyboard-quit)) - -(defun vip-ctl-c-equivalent (arg) - "Emulate C-c in Emacs mode." - (interactive "P") - (vip-ctl-key-equivalent "\C-c" arg)) - -(defun vip-ctl-x-equivalent (arg) - "Emulate C-x in Emacs mode." - (interactive "P") - (vip-ctl-key-equivalent "\C-x" arg)) - -(defun vip-ctl-key-equivalent (key arg) - (let ((char (read-char))) - (if (and (<= ?A char) (<= char ?Z)) - (setq char (- char (- ?A ?\C-a)))) - (vip-escape-to-emacs arg (list (aref key 0) char)))) - -;; commands in insertion mode - -(defun vip-delete-backward-word (arg) - "Delete previous word." - (interactive "p") - (save-excursion - (set-mark (point)) - (backward-word arg) - (delete-region (point) (mark)))) - - -;; implement ex commands - -(defvar ex-token-type nil - "type of token. if non-nil, gives type of address. if nil, it -is a command.") - -(defvar ex-token nil - "value of token.") - -(defvar ex-addresses nil - "list of ex addresses") - -(defvar ex-flag nil - "flag for ex flag") - -(defvar ex-buffer nil - "name of ex buffer") - -(defvar ex-count nil - "value of ex count") - -(defvar ex-g-flag nil - "flag for global command") - -(defvar ex-g-variant nil - "if t global command is executed on lines not matching ex-g-pat") - -(defvar ex-reg-exp nil - "save reg-exp used in substitute") - -(defvar ex-repl nil - "replace pattern for substitute") - -(defvar ex-g-pat nil - "pattern for global command") - -(defvar ex-map (make-sparse-keymap) - "save commands for mapped keys") - -(defvar ex-tag nil - "save ex tag") - -(defvar ex-file nil) - -(defvar ex-variant nil) - -(defvar ex-offset nil) - -(defvar ex-append nil) - -(defun vip-nil () - (interactive) - (error "")) - -(defun vip-looking-back (str) - "returns t if looking back reg-exp STR before point." - (and (save-excursion (re-search-backward str nil t)) - (= (point) (match-end 0)))) - -(defun vip-check-sub (str) - "check if ex-token is an initial segment of STR" - (let ((length (length ex-token))) - (if (and (<= length (length str)) - (string= ex-token (substring str 0 length))) - (setq ex-token str) - (setq ex-token-type "non-command")))) - -(defun vip-get-ex-com-subr () - "get a complete ex command" - (set-mark (point)) - (re-search-forward "[a-z][a-z]*") - (setq ex-token-type "command") - (setq ex-token (buffer-substring (point) (mark))) - (exchange-point-and-mark) - (cond ((looking-at "a") - (cond ((looking-at "ab") (vip-check-sub "abbreviate")) - ((looking-at "ar") (vip-check-sub "args")) - (t (vip-check-sub "append")))) - ((looking-at "[bh]") (setq ex-token-type "non-command")) - ((looking-at "c") - (if (looking-at "co") (vip-check-sub "copy") - (vip-check-sub "change"))) - ((looking-at "d") (vip-check-sub "delete")) - ((looking-at "e") - (if (looking-at "ex") (vip-check-sub "ex") - (vip-check-sub "edit"))) - ((looking-at "f") (vip-check-sub "file")) - ((looking-at "g") (vip-check-sub "global")) - ((looking-at "i") (vip-check-sub "insert")) - ((looking-at "j") (vip-check-sub "join")) - ((looking-at "l") (vip-check-sub "list")) - ((looking-at "m") - (cond ((looking-at "map") (vip-check-sub "map")) - ((looking-at "mar") (vip-check-sub "mark")) - (t (vip-check-sub "move")))) - ((looking-at "n") - (if (looking-at "nu") (vip-check-sub "number") - (vip-check-sub "next"))) - ((looking-at "o") (vip-check-sub "open")) - ((looking-at "p") - (cond ((looking-at "pre") (vip-check-sub "preserve")) - ((looking-at "pu") (vip-check-sub "put")) - (t (vip-check-sub "print")))) - ((looking-at "q") (vip-check-sub "quit")) - ((looking-at "r") - (cond ((looking-at "rec") (vip-check-sub "recover")) - ((looking-at "rew") (vip-check-sub "rewind")) - (t (vip-check-sub "read")))) - ((looking-at "s") - (cond ((looking-at "se") (vip-check-sub "set")) - ((looking-at "sh") (vip-check-sub "shell")) - ((looking-at "so") (vip-check-sub "source")) - ((looking-at "st") (vip-check-sub "stop")) - (t (vip-check-sub "substitute")))) - ((looking-at "t") - (if (looking-at "ta") (vip-check-sub "tag") - (vip-check-sub "t"))) - ((looking-at "u") - (cond ((looking-at "una") (vip-check-sub "unabbreviate")) - ((looking-at "unm") (vip-check-sub "unmap")) - (t (vip-check-sub "undo")))) - ((looking-at "v") - (cond ((looking-at "ve") (vip-check-sub "version")) - ((looking-at "vi") (vip-check-sub "visual")) - (t (vip-check-sub "v")))) - ((looking-at "w") - (if (looking-at "wq") (vip-check-sub "wq") - (vip-check-sub "write"))) - ((looking-at "x") (vip-check-sub "xit")) - ((looking-at "y") (vip-check-sub "yank")) - ((looking-at "z") (vip-check-sub "z"))) - (exchange-point-and-mark)) - -(defun vip-get-ex-token () - "get an ex-token which is either an address or a command. -a token has type \(command, address, end-mark) and value." - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (cond ((looking-at "[k#]") - (setq ex-token-type "command") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - ((looking-at "[a-z]") (vip-get-ex-com-subr)) - ((looking-at "\\.") - (forward-char 1) - (setq ex-token-type "dot")) - ((looking-at "[0-9]") - (set-mark (point)) - (re-search-forward "[0-9]*") - (setq ex-token-type - (cond ((string= ex-token-type "plus") "add-number") - ((string= ex-token-type "minus") "sub-number") - (t "abs-number"))) - (setq ex-token (string-to-number (buffer-substring (point) (mark))))) - ((looking-at "\\$") - (forward-char 1) - (setq ex-token-type "end")) - ((looking-at "%") - (forward-char 1) - (setq ex-token-type "whole")) - ((looking-at "\\+") - (cond ((looking-at "\\+[-+\n|]") - (forward-char 1) - (insert "1") - (backward-char 1) - (setq ex-token-type "plus")) - ((looking-at "\\+[0-9]") - (forward-char 1) - (setq ex-token-type "plus")) - (t - (error "Badly formed address")))) - ((looking-at "-") - (cond ((looking-at "-[-+\n|]") - (forward-char 1) - (insert "1") - (backward-char 1) - (setq ex-token-type "minus")) - ((looking-at "-[0-9]") - (forward-char 1) - (setq ex-token-type "minus")) - (t - (error "Badly formed address")))) - ((looking-at "/") - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - ;;(re-search-forward "[^/]*/") - (re-search-forward "[^/]*\\(/\\|\n\\)") - (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/")) - (setq cont nil)))) - (backward-char 1) - (setq ex-token (buffer-substring (point) (mark))) - (if (looking-at "/") (forward-char 1)) - (setq ex-token-type "search-forward")) - ((looking-at "\\?") - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - ;;(re-search-forward "[^\\?]*\\?") - (re-search-forward "[^\\?]*\\(\\?\\|\n\\)") - (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\\\?")) - (setq cont nil)) - (backward-char 1) - (if (not (looking-at "\n")) (forward-char 1)))) - (setq ex-token-type "search-backward") - (setq ex-token (buffer-substring (1- (point)) (mark)))) - ((looking-at ",") - (forward-char 1) - (setq ex-token-type "comma")) - ((looking-at ";") - (forward-char 1) - (setq ex-token-type "semi-colon")) - ((looking-at "[!=><&~]") - (setq ex-token-type "command") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - ((looking-at "'") - (setq ex-token-type "goto-mark") - (forward-char 1) - (cond ((looking-at "'") (setq ex-token nil)) - ((looking-at "[a-z]") (setq ex-token (following-char))) - (t (error "%s" "Marks are ' and a-z"))) - (forward-char 1)) - ((looking-at "\n") - (setq ex-token-type "end-mark") - (setq ex-token "goto")) - (t - (error "Invalid token"))))) - -(defun vip-ex (&optional string) - "ex commands within VIP." - (interactive) - (or string - (setq ex-g-flag nil - ex-g-variant nil)) - (let ((com-str (or string (vip-read-string ":"))) - (address nil) (cont t) (dot (point))) - (with-current-buffer (get-buffer-create " *ex-working-space*") - (delete-region (point-min) (point-max)) - (insert com-str "\n") - (goto-char (point-min))) - (setq ex-token-type "") - (setq ex-addresses nil) - (while cont - (vip-get-ex-token) - (cond ((or (string= ex-token-type "command") - (string= ex-token-type "end-mark")) - (if address (setq ex-addresses (cons address ex-addresses))) - (cond ((string= ex-token "global") - (ex-global nil) - (setq cont nil)) - ((string= ex-token "v") - (ex-global t) - (setq cont nil)) - (t - (vip-execute-ex-command) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (cond ((looking-at "|") - (forward-char 1)) - ((looking-at "\n") - (setq cont nil)) - (t (error "Extra character at end of a command"))))))) - ((string= ex-token-type "non-command") - (error "%s: Not an editor command" ex-token)) - ((string= ex-token-type "whole") - (setq ex-addresses - (cons (point-max) (cons (point-min) ex-addresses)))) - ((string= ex-token-type "comma") - (setq ex-addresses - (cons (if (null address) (point) address) ex-addresses))) - ((string= ex-token-type "semi-colon") - (if address (setq dot address)) - (setq ex-addresses - (cons (if (null address) (point) address) ex-addresses))) - (t (let ((ans (vip-get-ex-address-subr address dot))) - (if ans (setq address ans)))))))) - -(defun vip-get-ex-pat () - "get a regular expression and set ex-variant if found" - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-g-variant (not ex-g-variant) - ex-g-flag (not ex-g-flag)) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at "/") - (progn - (forward-char 1) - (set-mark (point)) - (let ((cont t)) - (while (and (not (eolp)) cont) - (re-search-forward "[^/]*\\(/\\|\n\\)") - ;;(re-search-forward "[^/]*/") - (if (not (vip-looking-back "[^\\]\\(\\\\\\\\\\)*\\\\/")) - (setq cont nil)))) - (setq ex-token - (if (= (mark) (point)) "" - (buffer-substring (1- (point)) (mark)))) - (backward-char 1)) - (setq ex-token nil)))) - -(defun vip-get-ex-command () - "get an ex command" - (with-current-buffer " *ex-working-space*" - (if (looking-at "/") (forward-char 1)) - (skip-chars-forward " \t") - (cond ((looking-at "[a-z]") - (vip-get-ex-com-subr) - (if (string= ex-token-type "non-command") - (error "%s: Not an editor command" ex-token))) - ((looking-at "[!=><&~]") - (setq ex-token (char-to-string (following-char))) - (forward-char 1)) - (t (error "Could not find an ex command"))))) - -(defun vip-get-ex-opt-gc () - "get an ex option g or c" - (with-current-buffer " *ex-working-space*" - (if (looking-at "/") (forward-char 1)) - (skip-chars-forward " \t") - (cond ((looking-at "g") - (setq ex-token "g") - (forward-char 1) - t) - ((looking-at "c") - (setq ex-token "c") - (forward-char 1) - t) - (t nil)))) - -(defun vip-default-ex-addresses (&optional whole-flag) - "compute default addresses. whole-flag means whole buffer." - (cond ((null ex-addresses) - (setq ex-addresses - (if whole-flag - (cons (point-max) (cons (point-min) nil)) - (cons (point) (cons (point) nil))))) - ((null (cdr ex-addresses)) - (setq ex-addresses - (cons (car ex-addresses) ex-addresses))))) - -(defun vip-get-ex-address () - "get an ex-address as a marker and set ex-flag if a flag is found" - (let ((address (point-marker)) (cont t)) - (setq ex-token "") - (setq ex-flag nil) - (while cont - (vip-get-ex-token) - (cond ((string= ex-token-type "command") - (if (or (string= ex-token "print") (string= ex-token "list") - (string= ex-token "#")) - (progn - (setq ex-flag t) - (setq cont nil)) - (error "Address expected"))) - ((string= ex-token-type "end-mark") - (setq cont nil)) - ((string= ex-token-type "whole") - (error "a trailing address is expected")) - ((string= ex-token-type "comma") - (error "Extra characters after an address")) - (t (let ((ans (vip-get-ex-address-subr address (point-marker)))) - (if ans (setq address ans)))))) - address)) - -(defun vip-get-ex-address-subr (old-address dot) - "returns an address as a point" - (let ((address nil)) - (if (null old-address) (setq old-address dot)) - (cond ((string= ex-token-type "dot") - (setq address dot)) - ((string= ex-token-type "add-number") - (save-excursion - (goto-char old-address) - (forward-line (if (= old-address 0) (1- ex-token) ex-token)) - (setq address (point-marker)))) - ((string= ex-token-type "sub-number") - (save-excursion - (goto-char old-address) - (forward-line (- ex-token)) - (setq address (point-marker)))) - ((string= ex-token-type "abs-number") - (save-excursion - (goto-char (point-min)) - (if (= ex-token 0) (setq address 0) - (forward-line (1- ex-token)) - (setq address (point-marker))))) - ((string= ex-token-type "end") - (setq address (point-max-marker))) - ((string= ex-token-type "plus") t);; do nothing - ((string= ex-token-type "minus") t);; do nothing - ((string= ex-token-type "search-forward") - (save-excursion - (ex-search-address t) - (setq address (point-marker)))) - ((string= ex-token-type "search-backward") - (save-excursion - (ex-search-address nil) - (setq address (point-marker)))) - ((string= ex-token-type "goto-mark") - (save-excursion - (if (null ex-token) - (exchange-point-and-mark) - (goto-char (register-to-point (- ex-token (- ?a ?\C-a))))) - (setq address (point-marker))))) - address)) - -(defun ex-search-address (forward) - "search pattern and set address" - (if (string= ex-token "") - (if (null vip-s-string) (error "No previous search string") - (setq ex-token vip-s-string)) - (setq vip-s-string ex-token)) - (if forward - (progn - (forward-line 1) - (re-search-forward ex-token)) - (forward-line -1) - (re-search-backward ex-token))) - -(defun vip-get-ex-buffer () - "get a buffer name and set ex-count and ex-flag if found" - (setq ex-buffer nil) - (setq ex-count nil) - (setq ex-flag nil) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "[a-zA-Z]") - (progn - (setq ex-buffer (following-char)) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at "[0-9]") - (progn - (set-mark (point)) - (re-search-forward "[0-9][0-9]*") - (setq ex-count (string-to-number (buffer-substring (point) (mark)))) - (skip-chars-forward " \t"))) - (if (looking-at "[pl#]") - (progn - (setq ex-flag t) - (forward-char 1))) - (if (not (looking-at "[\n|]")) - (error "Invalid extra characters")))) - -(defun vip-get-ex-count () - (setq ex-variant nil - ex-count nil - ex-flag nil) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-variant t) - (forward-char 1))) - (skip-chars-forward " \t") - (if (looking-at "[0-9]") - (progn - (set-mark (point)) - (re-search-forward "[0-9][0-9]*") - (setq ex-count (string-to-number (buffer-substring (point) (mark)))) - (skip-chars-forward " \t"))) - (if (looking-at "[pl#]") - (progn - (setq ex-flag t) - (forward-char 1))) - (if (not (looking-at "[\n|]")) - (error "Invalid extra characters")))) - -(defun vip-get-ex-file () - "get a file name and set ex-variant, ex-append and ex-offset if found" - (setq ex-file nil - ex-variant nil - ex-append nil - ex-offset nil) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq ex-variant t) - (forward-char 1) - (skip-chars-forward " \t"))) - (if (looking-at ">>") - (progn - (setq ex-append t - ex-variant t) - (forward-char 2) - (skip-chars-forward " \t"))) - (if (looking-at "\\+") - (progn - (forward-char 1) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq ex-offset (buffer-substring (point) (mark))) - (forward-char 1) - (skip-chars-forward " \t"))) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq ex-file (buffer-substring (point) (mark))))) - -(defun vip-execute-ex-command () - "execute ex command using the value of addresses." - (cond ((string= ex-token "goto") (ex-goto)) - ((string= ex-token "copy") (ex-copy nil)) - ((string= ex-token "delete") (ex-delete)) - ((string= ex-token "edit") (ex-edit)) - ((string= ex-token "file") (vip-info-on-file)) - ;((string= ex-token "global") (ex-global nil)) - ((string= ex-token "join") (ex-line "join")) - ((string= ex-token "k") (ex-mark)) - ((string= ex-token "mark") (ex-mark)) - ((string= ex-token "map") (ex-map)) - ((string= ex-token "move") (ex-copy t)) - ((string= ex-token "put") (ex-put)) - ((string= ex-token "quit") (ex-quit)) - ((string= ex-token "read") (ex-read)) - ((string= ex-token "set") (ex-set)) - ((string= ex-token "shell") (ex-shell)) - ((string= ex-token "substitute") (ex-substitute)) - ((string= ex-token "stop") (suspend-emacs)) - ((string= ex-token "t") (ex-copy nil)) - ((string= ex-token "tag") (ex-tag)) - ((string= ex-token "undo") (vip-undo)) - ((string= ex-token "unmap") (ex-unmap)) - ;((string= ex-token "v") (ex-global t)) - ((string= ex-token "version") (vip-version)) - ((string= ex-token "visual") (ex-edit)) - ((string= ex-token "write") (ex-write nil)) - ((string= ex-token "wq") (ex-write t)) - ((string= ex-token "yank") (ex-yank)) - ((string= ex-token "!") (ex-command)) - ((string= ex-token "=") (ex-line-no)) - ((string= ex-token ">") (ex-line "right")) - ((string= ex-token "<") (ex-line "left")) - ((string= ex-token "&") (ex-substitute t)) - ((string= ex-token "~") (ex-substitute t t)) - ((or (string= ex-token "append") - (string= ex-token "args") - (string= ex-token "change") - (string= ex-token "insert") - (string= ex-token "open") - ) - (error "%s: No such command from VIP" ex-token)) - ((or (string= ex-token "abbreviate") - (string= ex-token "list") - (string= ex-token "next") - (string= ex-token "print") - (string= ex-token "preserve") - (string= ex-token "recover") - (string= ex-token "rewind") - (string= ex-token "source") - (string= ex-token "unabbreviate") - (string= ex-token "xit") - (string= ex-token "z") - ) - (error "%s: Not implemented in VIP" ex-token)) - (t (error "%s: Not an editor command" ex-token)))) - -(defun ex-goto () - "ex goto command" - (if (null ex-addresses) - (setq ex-addresses (cons (point) nil))) - (push-mark) - (goto-char (car ex-addresses)) - (beginning-of-line)) - -(defun ex-copy (del-flag) - "ex copy and move command. DEL-FLAG means delete." - (vip-default-ex-addresses) - (let ((address (vip-get-ex-address)) - (end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (goto-char end) - (save-excursion - (set-mark beg) - (vip-enlarge-region (mark) (point)) - (if del-flag (kill-region (point) (mark)) - (copy-region-as-kill (point) (mark))) - (if ex-flag - (progn - (with-output-to-temp-buffer "*copy text*" - (princ - (if (or del-flag ex-g-flag ex-g-variant) - (current-kill 0) - (buffer-substring (point) (mark))))) - (condition-case nil - (progn - (vip-read-string "[Hit return to continue] ") - (save-excursion (kill-buffer "*copy text*"))) - (quit - (save-excursion (kill-buffer "*copy text*")) - (signal 'quit nil)))))) - (if (= address 0) - (goto-char (point-min)) - (goto-char address) - (forward-line 1)) - (insert (current-kill 0)))) - -(defun ex-delete () - "ex delete" - (vip-default-ex-addresses) - (vip-get-ex-buffer) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (if ex-count - (progn - (set-mark (point)) - (forward-line (1- ex-count))) - (set-mark end)) - (vip-enlarge-region (point) (mark)) - (if ex-flag - ;; show text to be deleted and ask for confirmation - (progn - (with-output-to-temp-buffer " *delete text*" - (princ (buffer-substring (point) (mark)))) - (condition-case nil - (vip-read-string "[Hit return to continue] ") - (quit - (save-excursion (kill-buffer " *delete text*")) - (error ""))) - (save-excursion (kill-buffer " *delete text*"))) - (if ex-buffer - (if (and (<= ?A ex-buffer) (<= ex-buffer ?Z)) - (vip-append-to-register - (+ ex-buffer 32) (point) (mark)) - (copy-to-register ex-buffer (point) (mark) nil))) - (delete-region (point) (mark)))))) - -(defun ex-edit () - "ex-edit" - (vip-get-ex-file) - (if (and (not ex-variant) (buffer-modified-p) buffer-file-name) - (error "No write since last change (:e! overrides)")) - (vip-change-mode-to-emacs) - (set-buffer - (find-file-noselect (concat default-directory ex-file))) - (vip-change-mode-to-vi) - (goto-char (point-min)) - (if ex-offset - (progn - (with-current-buffer " *ex-working-space*" - (delete-region (point-min) (point-max)) - (insert ex-offset "\n") - (goto-char (point-min))) - (goto-char (vip-get-ex-address)) - (beginning-of-line)))) - -(defun ex-global (variant) - "ex global command" - (if (or ex-g-flag ex-g-variant) - (error "Global within global not allowed") - (if variant - (setq ex-g-flag nil - ex-g-variant t) - (setq ex-g-flag t - ex-g-variant nil))) - (vip-get-ex-pat) - (if (null ex-token) - (error "Missing regular expression for global command")) - (if (string= ex-token "") - (if (null vip-s-string) (error "No previous search string") - (setq ex-g-pat vip-s-string)) - (setq ex-g-pat ex-token - vip-s-string ex-token)) - (if (null ex-addresses) - (setq ex-addresses (list (point-max) (point-min)))) - (let ((marks nil) (mark-count 0) - com-str (end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (let ((cont t) (limit (point-marker))) - (exchange-point-and-mark) - ;; skip the last line if empty - (beginning-of-line) - (if (and (eobp) (not (bobp))) (backward-char 1)) - (while (and cont (not (bobp)) (>= (point) limit)) - (beginning-of-line) - (set-mark (point)) - (end-of-line) - (let ((found (re-search-backward ex-g-pat (mark) t))) - (if (or (and ex-g-flag found) - (and ex-g-variant (not found))) - (progn - (end-of-line) - (setq mark-count (1+ mark-count)) - (setq marks (cons (point-marker) marks))))) - (beginning-of-line) - (if (bobp) (setq cont nil) - (forward-line -1) - (end-of-line))))) - (with-current-buffer " *ex-working-space*" - (setq com-str (buffer-substring (1+ (point)) (1- (point-max))))) - (while marks - (goto-char (car marks)) - ;; report progress of execution on a slow machine. - ;;(message "Executing global command...") - ;;(if (zerop (% mark-count 10)) - ;; (message "Executing global command...%d" mark-count)) - (vip-ex com-str) - (setq mark-count (1- mark-count)) - (setq marks (cdr marks))))) -;;(message "Executing global command...done"))) - -(defun ex-line (com) - "ex line commands. COM is join, shift-right or shift-left." - (vip-default-ex-addresses) - (vip-get-ex-count) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses))) point) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (if ex-count - (progn - (set-mark (point)) - (forward-line ex-count))) - (if ex-flag - ;; show text to be joined and ask for confirmation - (progn - (with-output-to-temp-buffer " *text*" - (princ (buffer-substring (point) (mark)))) - (condition-case nil - (progn - (vip-read-string "[Hit return to continue] ") - (ex-line-subr com (point) (mark))) - (quit - (ding))) - (save-excursion (kill-buffer " *text*"))) - (ex-line-subr com (point) (mark))) - (setq point (point))) - (goto-char (1- point)) - (beginning-of-line))) - -(defun ex-line-subr (com beg end) - (cond ((string= com "join") - (goto-char (min beg end)) - (while (and (not (eobp)) (< (point) (max beg end))) - (end-of-line) - (if (and (<= (point) (max beg end)) (not (eobp))) - (progn - (forward-line 1) - (delete-region (point) (1- (point))) - (if (not ex-variant) (fixup-whitespace)))))) - ((or (string= com "right") (string= com "left")) - (indent-rigidly - (min beg end) (max beg end) - (if (string= com "right") vip-shift-width (- vip-shift-width))) - (goto-char (max beg end)) - (end-of-line) - (forward-char 1)))) - -(defun ex-mark () - "ex mark" - (let (char) - (if (null ex-addresses) - (setq ex-addresses - (cons (point) nil))) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "[a-z]") - (progn - (setq char (following-char)) - (forward-char 1) - (skip-chars-forward " \t") - (if (not (looking-at "[\n|]")) - (error "Extra characters at end of \"k\" command"))) - (if (looking-at "[\n|]") - (error "\"k\" requires a following letter") - (error "Mark must specify a letter")))) - (save-excursion - (goto-char (car ex-addresses)) - (point-to-register (- char (- ?a ?\C-a)) nil)))) - -(defun ex-map () - "ex map" - (let (char string) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (setq char (char-to-string (following-char))) - (forward-char 1) - (skip-chars-forward " \t") - (if (looking-at "[\n|]") (error "Missing rhs")) - (set-mark (point)) - (with-no-warnings - (end-of-buffer)) - (backward-char 1) - (setq string (buffer-substring (mark) (point)))) - (if (not (lookup-key ex-map char)) - (define-key ex-map char - (or (lookup-key vip-mode-map char) 'vip-nil))) - (define-key vip-mode-map char - (lambda (count) - (interactive "p") - (execute-kbd-macro string count))))) - -(defun ex-unmap () - "ex unmap" - (let (char) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (setq char (char-to-string (following-char))) - (forward-char 1) - (skip-chars-forward " \t") - (if (not (looking-at "[\n|]")) (error "Macro must be a character"))) - (if (not (lookup-key ex-map char)) - (error "That macro wasn't mapped")) - (define-key vip-mode-map char (lookup-key ex-map char)) - (define-key ex-map char nil))) - -(defun ex-put () - "ex put" - (let ((point (if (null ex-addresses) (point) (car ex-addresses)))) - (vip-get-ex-buffer) - (setq vip-use-register ex-buffer) - (goto-char point) - (if (= point 0) (vip-Put-back 1) (vip-put-back 1)))) - -(defun ex-quit () - "ex quit" - (let (char) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (setq char (following-char))) - (if (= char ?!) (kill-emacs t) (save-buffers-kill-emacs)))) - -(defun ex-read () - "ex read" - (let ((point (if (null ex-addresses) (point) (car ex-addresses))) - (variant nil) command file) - (goto-char point) - (if (not (= point 0)) (with-no-warnings (next-line 1))) - (beginning-of-line) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (if (looking-at "!") - (progn - (setq variant t) - (forward-char 1) - (skip-chars-forward " \t") - (set-mark (point)) - (end-of-line) - (setq command (buffer-substring (mark) (point)))) - (set-mark (point)) - (re-search-forward "[ \t\n]") - (backward-char 1) - (setq file (buffer-substring (point) (mark))))) - (if variant - (shell-command command t) - (with-no-warnings - (insert-file file))))) - -(defalias 'ex-set #'set-variable) - -(defun ex-shell () - "ex shell" - (vip-change-mode-to-emacs) - (shell)) - -(defun ex-substitute (&optional repeat r-flag) - "ex substitute. -If REPEAT use previous reg-exp which is ex-reg-exp or -vip-s-string" - (let (pat repl (opt-g nil) (opt-c nil) (matched-pos nil)) - (if repeat (setq ex-token nil) (vip-get-ex-pat)) - (if (null ex-token) - (setq pat (if r-flag vip-s-string ex-reg-exp) - repl ex-repl) - (setq pat (if (string= ex-token "") vip-s-string ex-token)) - (setq vip-s-string pat - ex-reg-exp pat) - (vip-get-ex-pat) - (if (null ex-token) - (setq ex-token "" - ex-repl "") - (setq repl ex-token - ex-repl ex-token))) - (while (vip-get-ex-opt-gc) - (if (string= ex-token "g") (setq opt-g t) (setq opt-c t))) - (vip-get-ex-count) - (if ex-count - (save-excursion - (if ex-addresses (goto-char (car ex-addresses))) - (set-mark (point)) - (forward-line (1- ex-count)) - (setq ex-addresses (cons (point) (cons (mark) nil)))) - (if (null ex-addresses) - (setq ex-addresses (cons (point) (cons (point) nil))) - (if (null (cdr ex-addresses)) - (setq ex-addresses (cons (car ex-addresses) ex-addresses))))) - ;(setq G opt-g) - (let ((beg (car ex-addresses)) (end (car (cdr ex-addresses))) - eol-mark) ;;(cont t) - (save-excursion - (vip-enlarge-region beg end) - (let ((limit (save-excursion - (goto-char (max (point) (mark))) - (point-marker)))) - (goto-char (min (point) (mark))) - (while (< (point) limit) - (end-of-line) - (setq eol-mark (point-marker)) - (beginning-of-line) - (if opt-g - (progn - (while (and (not (eolp)) - (re-search-forward pat eol-mark t)) - (if (or (not opt-c) (y-or-n-p "Replace? ")) - (progn - (setq matched-pos (point)) - (replace-match repl)))) - (end-of-line) - (forward-char)) - (if (and (re-search-forward pat eol-mark t) - (or (not opt-c) (y-or-n-p "Replace? "))) - (progn - (setq matched-pos (point)) - (replace-match repl))) - (end-of-line) - (forward-char)))))) - (if matched-pos (goto-char matched-pos)) - (beginning-of-line) - (if opt-c (message "done")))) - -(defun ex-tag () - "ex tag" - (let (tag) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (set-mark (point)) - (skip-chars-forward "^ |\t\n") - (setq tag (buffer-substring (mark) (point)))) - (if (not (string= tag "")) (setq ex-tag tag)) - (vip-change-mode-to-emacs) - (condition-case conditions - (progn - (with-suppressed-warnings ((obsolete find-tag find-tag-other-window)) - (if (string= tag "") - (find-tag ex-tag t) - (find-tag-other-window ex-tag))) - (vip-change-mode-to-vi)) - (error - (vip-change-mode-to-vi) - (vip-message-conditions conditions))))) - -(defun ex-write (q-flag) - "ex write" - (vip-default-ex-addresses t) - (vip-get-ex-file) - (if (string= ex-file "") - (progn - (if (null buffer-file-name) - (error "No file associated with this buffer")) - (setq ex-file buffer-file-name)) - (setq ex-file (expand-file-name ex-file))) - (if (and (not (string= ex-file (buffer-file-name))) - (file-exists-p ex-file) - (not ex-variant)) - (error "\"%s\" File exists - use w! to override" ex-file)) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (write-region (point) (mark) ex-file ex-append t))) - (if (null buffer-file-name) (setq buffer-file-name ex-file)) - (if q-flag (save-buffers-kill-emacs))) - -(defun ex-yank () - "ex yank" - (vip-default-ex-addresses) - (vip-get-ex-buffer) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (> beg end) (error "First address exceeds second")) - (save-excursion - (vip-enlarge-region beg end) - (exchange-point-and-mark) - (if (or ex-g-flag ex-g-variant) (error "Can't yank within global")) - (if ex-count - (progn - (set-mark (point)) - (forward-line (1- ex-count))) - (set-mark end)) - (vip-enlarge-region (point) (mark)) - (if ex-flag (error "Extra characters at end of command")) - (if ex-buffer - (copy-to-register ex-buffer (point) (mark) nil)) - (copy-region-as-kill (point) (mark))))) - -(defun ex-command () - "execute shell command" - (let (command) - (with-current-buffer " *ex-working-space*" - (skip-chars-forward " \t") - (set-mark (point)) - (end-of-line) - (setq command (buffer-substring (mark) (point)))) - (if (null ex-addresses) - (shell-command command) - (let ((end (car ex-addresses)) (beg (car (cdr ex-addresses)))) - (if (null beg) (setq beg end)) - (save-excursion - (goto-char beg) - (set-mark end) - (vip-enlarge-region (point) (mark)) - (shell-command-on-region (point) (mark) command t t)) - (goto-char beg))))) - -(defun ex-line-no () - "print line number" - (message "%d" - (1+ (count-lines - (point-min) - (if (null ex-addresses) (point-max) (car ex-addresses)))))) - -(if (file-exists-p vip-startup-file) (load vip-startup-file)) - -(provide 'vip) - -;;; vip.el ends here diff --git a/lisp/obsolete/ws-mode.el b/lisp/obsolete/ws-mode.el deleted file mode 100644 index d8ee63c8a01..00000000000 --- a/lisp/obsolete/ws-mode.el +++ /dev/null @@ -1,539 +0,0 @@ -;;; ws-mode.el --- WordStar emulation mode for GNU Emacs -*- lexical-binding: t -*- - -;; Copyright (C) 1991, 2001-2024 Free Software Foundation, Inc. - -;; Author: Juergen Nickelsen <nickel@cs.tu-berlin.de> -;; Version: 0.7 -;; Keywords: emulations -;; Obsolete-since: 24.5 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This provides emulation of WordStar with a minor mode. - -;;; Code: - -(defgroup wordstar nil - "WordStar emulation within Emacs." - :prefix "wordstar-" - :prefix "ws-" - :group 'emulations) - -(defcustom wordstar-mode-lighter " WordStar" - "Lighter shown in the modeline for `wordstar' mode." - :type 'string) - -(defvar wordstar-C-k-map - (let ((map (make-keymap))) - (define-key map " " ()) - (define-key map "0" #'ws-set-marker-0) - (define-key map "1" #'ws-set-marker-1) - (define-key map "2" #'ws-set-marker-2) - (define-key map "3" #'ws-set-marker-3) - (define-key map "4" #'ws-set-marker-4) - (define-key map "5" #'ws-set-marker-5) - (define-key map "6" #'ws-set-marker-6) - (define-key map "7" #'ws-set-marker-7) - (define-key map "8" #'ws-set-marker-8) - (define-key map "9" #'ws-set-marker-9) - (define-key map "b" #'ws-begin-block) - (define-key map "\C-b" #'ws-begin-block) - (define-key map "c" #'ws-copy-block) - (define-key map "\C-c" #'ws-copy-block) - (define-key map "d" #'save-buffers-kill-emacs) - (define-key map "\C-d" #'save-buffers-kill-emacs) - (define-key map "f" #'find-file) - (define-key map "\C-f" #'find-file) - (define-key map "h" #'ws-show-markers) - (define-key map "\C-h" #'ws-show-markers) - (define-key map "i" #'ws-indent-block) - (define-key map "\C-i" #'ws-indent-block) - (define-key map "k" #'ws-end-block) - (define-key map "\C-k" #'ws-end-block) - (define-key map "p" #'ws-print-block) - (define-key map "\C-p" #'ws-print-block) - (define-key map "q" #'kill-emacs) - (define-key map "\C-q" #'kill-emacs) - (define-key map "r" #'insert-file) - (define-key map "\C-r" #'insert-file) - (define-key map "s" #'save-some-buffers) - (define-key map "\C-s" #'save-some-buffers) - (define-key map "t" #'ws-mark-word) - (define-key map "\C-t" #'ws-mark-word) - (define-key map "u" #'ws-exdent-block) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "v" #'ws-move-block) - (define-key map "\C-v" #'ws-move-block) - (define-key map "w" #'ws-write-block) - (define-key map "\C-w" #'ws-write-block) - (define-key map "x" #'save-buffers-kill-emacs) - (define-key map "\C-x" #'save-buffers-kill-emacs) - (define-key map "y" #'ws-delete-block) - (define-key map "\C-y" #'ws-delete-block) - map)) - -(defvar wordstar-C-o-map - (let ((map (make-keymap))) - (define-key map " " ()) - (define-key map "c" #'wordstar-center-line) - (define-key map "\C-c" #'wordstar-center-line) - (define-key map "b" #'switch-to-buffer) - (define-key map "\C-b" #'switch-to-buffer) - (define-key map "j" #'justify-current-line) - (define-key map "\C-j" #'justify-current-line) - (define-key map "k" #'kill-buffer) - (define-key map "\C-k" #'kill-buffer) - (define-key map "l" #'list-buffers) - (define-key map "\C-l" #'list-buffers) - (define-key map "m" #'auto-fill-mode) - (define-key map "\C-m" #'auto-fill-mode) - (define-key map "r" #'set-fill-column) - (define-key map "\C-r" #'set-fill-column) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "wd" #'delete-other-windows) - (define-key map "wh" #'split-window-right) - (define-key map "wo" #'other-window) - (define-key map "wv" #'split-window-below) - map)) - -(defvar wordstar-C-q-map - (let ((map (make-keymap))) - (define-key map " " ()) - (define-key map "0" #'ws-find-marker-0) - (define-key map "1" #'ws-find-marker-1) - (define-key map "2" #'ws-find-marker-2) - (define-key map "3" #'ws-find-marker-3) - (define-key map "4" #'ws-find-marker-4) - (define-key map "5" #'ws-find-marker-5) - (define-key map "6" #'ws-find-marker-6) - (define-key map "7" #'ws-find-marker-7) - (define-key map "8" #'ws-find-marker-8) - (define-key map "9" #'ws-find-marker-9) - (define-key map "a" #'ws-query-replace) - (define-key map "\C-a" #'ws-query-replace) - (define-key map "b" #'ws-goto-block-begin) - (define-key map "\C-b" #'ws-goto-block-begin) - (define-key map "c" #'end-of-buffer) - (define-key map "\C-c" #'end-of-buffer) - (define-key map "d" #'end-of-line) - (define-key map "\C-d" #'end-of-line) - (define-key map "f" #'ws-search) - (define-key map "\C-f" #'ws-search) - (define-key map "k" #'ws-goto-block-end) - (define-key map "\C-k" #'ws-goto-block-end) - (define-key map "l" #'ws-undo) - (define-key map "\C-l" #'ws-undo) - ;; (define-key map "p" #'ws-last-cursorp) - ;; (define-key map "\C-p" #'ws-last-cursorp) - (define-key map "r" #'beginning-of-buffer) - (define-key map "\C-r" #'beginning-of-buffer) - (define-key map "s" #'beginning-of-line) - (define-key map "\C-s" #'beginning-of-line) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "w" #'ws-last-error) - (define-key map "\C-w" #'ws-last-error) - (define-key map "y" #'ws-kill-eol) - (define-key map "\C-y" #'ws-kill-eol) - (define-key map "\177" #'ws-kill-bol) - map)) - -(defvar wordstar-mode-map - (let ((map (make-keymap))) - (define-key map "\C-a" #'backward-word) - (define-key map "\C-b" #'fill-paragraph) - (define-key map "\C-c" #'scroll-up-command) - (define-key map "\C-d" #'forward-char) - (define-key map "\C-e" #'previous-line) - (define-key map "\C-f" #'forward-word) - (define-key map "\C-g" #'delete-char) - (define-key map "\C-h" #'backward-char) - (define-key map "\C-i" #'indent-for-tab-command) - (define-key map "\C-j" #'help-for-help) - (define-key map "\C-k" wordstar-C-k-map) - (define-key map "\C-l" #'ws-repeat-search) - (define-key map "\C-n" #'open-line) - (define-key map "\C-o" wordstar-C-o-map) - (define-key map "\C-p" #'quoted-insert) - (define-key map "\C-q" wordstar-C-q-map) - (define-key map "\C-r" #'scroll-down-command) - (define-key map "\C-s" #'backward-char) - (define-key map "\C-t" #'kill-word) - (define-key map "\C-u" #'keyboard-quit) - (define-key map "\C-v" #'overwrite-mode) - (define-key map "\C-w" #'scroll-down-line) - (define-key map "\C-x" #'next-line) - (define-key map "\C-y" #'kill-complete-line) - (define-key map "\C-z" #'scroll-up-line) - map)) - -;; wordstar-C-j-map not yet implemented -(defvar wordstar-C-j-map nil) - -;;;###autoload -(define-minor-mode wordstar-mode - "Minor mode with WordStar-like key bindings. - -BUGS: - - Help menus with WordStar commands (C-j just calls help-for-help) - are not implemented - - Options for search and replace - - Show markers (C-k h) is somewhat strange - - Search and replace (C-q a) is only available in forward direction - -No key bindings beginning with ESC are installed, they will work -Emacs-like." - :group 'wordstar - :lighter wordstar-mode-lighter - :keymap wordstar-mode-map) - -(defun turn-on-wordstar-mode () - (when (and (not (minibufferp)) - (not wordstar-mode)) - (wordstar-mode 1))) - -(define-globalized-minor-mode global-wordstar-mode wordstar-mode - turn-on-wordstar-mode) - -(defun wordstar-center-paragraph () - "Center each line in the paragraph at or after point. -See `wordstar-center-line' for more info." - (interactive) - (save-excursion - (forward-paragraph) - (or (bolp) (newline 1)) - (let ((end (point))) - (backward-paragraph) - (wordstar-center-region (point) end)))) - -(defun wordstar-center-region (from to) - "Center each line starting in the region. -See `wordstar-center-line' for more info." - (interactive "r") - (if (> from to) - (let ((tem to)) - (setq to from from tem))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char from) - (while (not (eobp)) - (wordstar-center-line) - (forward-line 1))))) - -(defun wordstar-center-line () - "Center the line point is on, within the width specified by `fill-column'. -This means adjusting the indentation to match -the distance between the end of the text and `fill-column'." - (interactive) - (save-excursion - (let (line-length) - (beginning-of-line) - (delete-horizontal-space) - (end-of-line) - (delete-horizontal-space) - (setq line-length (current-column)) - (beginning-of-line) - (indent-to - (+ left-margin - (/ (- fill-column left-margin line-length) 2)))))) - -;;;;;;;;;;; -;; wordstar special variables: - -(defvar ws-marker-0 nil "Position marker 0 in WordStar mode.") -(defvar ws-marker-1 nil "Position marker 1 in WordStar mode.") -(defvar ws-marker-2 nil "Position marker 2 in WordStar mode.") -(defvar ws-marker-3 nil "Position marker 3 in WordStar mode.") -(defvar ws-marker-4 nil "Position marker 4 in WordStar mode.") -(defvar ws-marker-5 nil "Position marker 5 in WordStar mode.") -(defvar ws-marker-6 nil "Position marker 6 in WordStar mode.") -(defvar ws-marker-7 nil "Position marker 7 in WordStar mode.") -(defvar ws-marker-8 nil "Position marker 8 in WordStar mode.") -(defvar ws-marker-9 nil "Position marker 9 in WordStar mode.") - -(defvar ws-block-begin-marker nil "Beginning of \"Block\" in WordStar mode.") -(defvar ws-block-end-marker nil "End of \"Block\" in WordStar mode.") - -(defvar ws-search-string nil "String of last search in WordStar mode.") -(defvar ws-search-direction t - "Direction of last search in WordStar mode. t if forward, nil if backward.") - -(defvar ws-last-cursorposition nil - "Position before last search etc. in WordStar mode.") - -(defvar ws-last-errormessage nil - "Last error message issued by a WordStar mode function.") - -;;;;;;;;;;; -;; wordstar special functions: - -(defun ws-error (string) - "Report error of a WordStar special function. -Error message is saved in `ws-last-errormessage' for recovery -with C-q w." - (setq ws-last-errormessage string) - (error string)) - -(defun ws-begin-block () - "In WordStar mode: Set block begin marker to current cursor position." - (interactive) - (setq ws-block-begin-marker (point-marker)) - (message "Block begin marker set")) - -(defun ws-show-markers () - "In WordStar mode: Show block markers." - (interactive) - (if (or ws-block-begin-marker ws-block-end-marker) - (save-excursion - (if ws-block-begin-marker - (progn - (goto-char ws-block-begin-marker) - (message "Block begin marker") - (sit-for 2)) - (message "Block begin marker not set") - (sit-for 2)) - (if ws-block-end-marker - (progn - (goto-char ws-block-end-marker) - (message "Block end marker") - (sit-for 2)) - (message "Block end marker not set")) - (message "")) - (message "Block markers not set"))) - -(defun ws-indent-block () - "In WordStar mode: Indent block (not yet implemented)." - (interactive) - (ws-error "Indent block not yet implemented")) - -(defun ws-end-block () - "In WordStar mode: Set block end marker to current cursor position." - (interactive) - (setq ws-block-end-marker (point-marker)) - (message "Block end marker set")) - -(defun ws-print-block () - "In WordStar mode: Print block." - (interactive) - (message "Don't do this. Write block to a file (C-k w) and print this file")) - -(defun ws-mark-word () - "In WordStar mode: Mark current word as block." - (interactive) - (save-excursion - (forward-word 1) - (sit-for 1) - (ws-end-block) - (forward-word -1) - (sit-for 1) - (ws-begin-block))) - -(defun ws-exdent-block () - "I don't know what this (C-k u) should do." - (interactive) - (ws-error "This won't be done -- not yet implemented")) - -(defun ws-move-block () - "In WordStar mode: Move block to current cursor position." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (progn - (kill-region ws-block-begin-marker ws-block-end-marker) - (yank) - (save-excursion - (goto-char (region-beginning)) - (setq ws-block-begin-marker (point-marker)) - (goto-char (region-end)) - (setq ws-block-end-marker (point-marker)))) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defun ws-write-block () - "In WordStar mode: Write block to file." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (let ((filename (read-file-name "Write block to file: "))) - (write-region ws-block-begin-marker ws-block-end-marker filename)) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - - -(defun ws-delete-block () - "In WordStar mode: Delete block." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (progn - (kill-region ws-block-begin-marker ws-block-end-marker) - (setq ws-block-end-marker nil) - (setq ws-block-begin-marker nil)) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defun ws-goto-block-begin () - "In WordStar mode: Go to block begin marker." - (interactive) - (if ws-block-begin-marker - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-block-begin-marker)) - (ws-error "Block begin marker not set"))) - -(defun ws-search (string) - "In WordStar mode: Search string, remember string for repetition." - (interactive "sSearch for: ") - (message "Forward (f) or backward (b)") - (let ((direction - (read-char))) - (cond ((equal (upcase direction) ?F) - (setq ws-search-string string) - (setq ws-search-direction t) - (setq ws-last-cursorposition (point-marker)) - (search-forward string)) - ((equal (upcase direction) ?B) - (setq ws-search-string string) - (setq ws-search-direction nil) - (setq ws-last-cursorposition (point-marker)) - (search-backward string)) - (t (keyboard-quit))))) - -(defun ws-goto-block-end () - "In WordStar mode: Go to block end marker." - (interactive) - (if ws-block-end-marker - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-block-end-marker)) - (ws-error "Block end marker not set"))) - -(defun ws-undo () - "In WordStar mode: Undo and give message about undoing more changes." - (interactive) - (undo) - (message "Repeat C-q l to undo more changes")) - -(defun ws-goto-last-cursorposition () - "In WordStar mode: Go to position before last search." - (interactive) - (if ws-last-cursorposition - (progn - (setq ws-last-cursorposition (point-marker)) - (goto-char ws-last-cursorposition)) - (ws-error "No last cursor position available"))) - -(defun ws-last-error () - "In WordStar mode: repeat last error message. -This will only work for errors raised by WordStar mode functions." - (interactive) - (if ws-last-errormessage - (message "%s" ws-last-errormessage) - (message "No WordStar error yet"))) - -(defun ws-kill-eol () - "In WordStar mode: Kill to end of line (like WordStar, not like Emacs)." - (interactive) - (let ((p (point))) - (end-of-line) - (kill-region p (point)))) - -(defun ws-kill-bol () - "In WordStar mode: Kill to beginning of line (like WordStar, not like Emacs)." - (interactive) - (let ((p (point))) - (beginning-of-line) - (kill-region (point) p))) - -(defun kill-complete-line () - "Kill the complete line." - (interactive) - (beginning-of-line) - (if (eobp) (error "End of buffer")) - (let ((beg (point))) - (forward-line 1) - (kill-region beg (point)))) - -(defun ws-repeat-search () - "In WordStar mode: Repeat last search." - (interactive) - (setq ws-last-cursorposition (point-marker)) - (if ws-search-string - (if ws-search-direction - (search-forward ws-search-string) - (search-backward ws-search-string)) - (ws-error "No search to repeat"))) - -(defun ws-query-replace (from to) - "In WordStar mode: Search string, remember string for repetition." - (interactive "sReplace: \n\ -sWith: " ) - (setq ws-search-string from) - (setq ws-search-direction t) - (setq ws-last-cursorposition (point-marker)) - (query-replace from to)) - -(defun ws-copy-block () - "In WordStar mode: Copy block to current cursor position." - (interactive) - (if (and ws-block-begin-marker ws-block-end-marker) - (progn - (copy-region-as-kill ws-block-begin-marker ws-block-end-marker) - (yank) - (save-excursion - (goto-char (region-beginning)) - (setq ws-block-begin-marker (point-marker)) - (goto-char (region-end)) - (setq ws-block-end-marker (point-marker)))) - (ws-error (cond (ws-block-begin-marker "Block end marker not set") - (ws-block-end-marker "Block begin marker not set") - (t "Block markers not set"))))) - -(defmacro ws-set-marker (&rest indices) - (let (n forms) - (while indices - (setq n (pop indices)) - (push `(defun ,(intern (format "ws-set-marker-%d" n)) () - ,(format "In WordStar mode: Set marker %d to current cursor position" n) - (interactive) - (setq ,(intern (format "ws-marker-%d" n)) (point-marker)) - (message ,(format "Marker %d set" n))) - forms)) - `(progn ,@(nreverse forms)))) - -(ws-set-marker 0 1 2 3 4 5 6 7 8 9) - -(defmacro ws-find-marker (&rest indices) - (let (n forms) - (while indices - (setq n (pop indices)) - (push `(defun ,(intern (format "ws-find-marker-%d" n)) () - ,(format "In WordStar mode: Go to marker %d." n) - (interactive) - (if ,(intern (format "ws-marker-%d" n)) - (progn (setq ws-last-cursorposition (point-marker)) - (goto-char ,(intern (format "ws-marker-%d" n)))) - (ws-error ,(format "Marker %d not set" n)))) - forms)) - `(progn ,@(nreverse forms)))) - -(ws-find-marker 0 1 2 3 4 5 6 7 8 9) - -(provide 'ws-mode) - -;;; ws-mode.el ends here diff --git a/lisp/obsolete/yow.el b/lisp/obsolete/yow.el deleted file mode 100644 index eb4c65c4084..00000000000 --- a/lisp/obsolete/yow.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; yow.el --- quote random zippyisms -*- lexical-binding: t; -*- - -;; Copyright (C) 1993-1995, 2000-2024 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik -;; Maintainer: emacs-devel@gnu.org -;; Keywords: games -;; Obsolete-since: 24.4 - -;; 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: - -;; Important pinheadery for GNU Emacs. -;; This file is obsolete. For similar functionality, see -;; fortune.el and cookie1.el. - -;;; Code: - -(require 'cookie1) - -(defgroup yow nil - "Quote random zippyisms." - :prefix "yow-" - :group 'games) - -(defcustom yow-file (expand-file-name "yow.lines" data-directory) - "File containing pertinent pinhead phrases." - :type 'file) - -(defconst yow-load-message "Am I CONSING yet?...") -(defconst yow-after-load-message "I have SEEN the CONSING!!") - -;;;###autoload -(defun yow (&optional insert display) - "Return or display a random Zippy quotation. With prefix arg, insert it." - (interactive "P\np") - (let ((yow (cookie yow-file yow-load-message yow-after-load-message))) - (cond (insert - (insert yow)) - ((not display) - yow) - (t - (message "%s" yow))))) - -(defsubst read-zippyism (prompt &optional require-match) - "Read a Zippyism from the minibuffer with completion, prompting with PROMPT. -If optional second arg is non-nil, require input to match a completion." - (cookie-read prompt yow-file yow-load-message yow-after-load-message - require-match)) - -;;;###autoload -(defun insert-zippyism (&optional zippyism) - "Prompt with completion for a known Zippy quotation, and insert it at point." - (interactive (list (read-zippyism "Pinhead wisdom: " t))) - (insert zippyism)) - -;;;###autoload -(defun apropos-zippy (regexp) - "Return a list of all Zippy quotes matching REGEXP. -If called interactively, display a list of matches." - (interactive "sApropos Zippy (regexp): ") - (cookie-apropos regexp yow-file (called-interactively-p 'interactive))) - - -;; Yowza!! Feed zippy quotes to the doctor. Watch results. -;; fun, fun, fun. Entertainment for hours... -;; -;; written by Kayvan Aghaiepour - -(declare-function doctor-ret-or-read "doctor" (arg)) - -;;;###autoload -(defun psychoanalyze-pinhead () - "Zippy goes to the analyst." - (interactive) - (cookie-doctor yow-file)) - -(provide 'yow) - -;;; yow.el ends here diff --git a/lisp/org/ob-R.el b/lisp/org/ob-R.el index de2d27a9a70..8074496f881 100644 --- a/lisp/org/ob-R.el +++ b/lisp/org/ob-R.el @@ -288,7 +288,7 @@ Use PARAMS to set default directory when creating a new session." "Associate R code buffer with an R session. Make SESSION be the inferior ESS process associated with the current code buffer." - (when-let ((process (get-buffer-process session))) + (when-let* ((process (get-buffer-process session))) (setq ess-local-process-name (process-name process)) (ess-make-buffer-current)) (setq-local ess-gen-proc-buffer-name-function (lambda (_) session))) diff --git a/lisp/org/ob-clojure.el b/lisp/org/ob-clojure.el index c7ebbbb95e9..eb2d8c34cac 100644 --- a/lisp/org/ob-clojure.el +++ b/lisp/org/ob-clojure.el @@ -120,14 +120,14 @@ :package-version '(Org . "9.6")) (defcustom ob-clojure-nbb-command (or (executable-find "nbb") - (when-let (npx (executable-find "npx")) + (when-let* ((npx (executable-find "npx"))) (concat npx " nbb"))) "Nbb command used by the ClojureScript `nbb' backend." :type '(choice string (const nil)) :group 'org-babel :package-version '(Org . "9.7")) -(defcustom ob-clojure-cli-command (when-let (cmd (executable-find "clojure")) +(defcustom ob-clojure-cli-command (when-let* ((cmd (executable-find "clojure"))) (concat cmd " -M")) "Clojure CLI command used by the Clojure `clojure-cli' backend." :type '(choice string (const nil)) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 7b4ca9b5ea3..b657a93dab3 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -870,7 +870,7 @@ guess will be made." (default-directory (cond ((not dir) default-directory) - ((when-let ((session (org-babel-session-buffer info))) + ((when-let* ((session (org-babel-session-buffer info))) (buffer-local-value 'default-directory (get-buffer session)))) ((member mkdirp '("no" "nil" nil)) (file-name-as-directory (expand-file-name dir))) diff --git a/lisp/org/ob-exp.el b/lisp/org/ob-exp.el index 30b2a42a6c4..b9d5f288ac1 100644 --- a/lisp/org/ob-exp.el +++ b/lisp/org/ob-exp.el @@ -441,7 +441,7 @@ replaced with its value." ("header-args" . ,(org-babel-exp--at-source - (when-let ((params (org-element-property :parameters (org-element-context)))) + (when-let* ((params (org-element-property :parameters (org-element-context)))) (concat " " params)))) ,@(mapcar (lambda (pair) (cons (substring (symbol-name (car pair)) 1) diff --git a/lisp/org/ob-julia.el b/lisp/org/ob-julia.el index 10a331e54d5..224a8ec75e8 100644 --- a/lisp/org/ob-julia.el +++ b/lisp/org/ob-julia.el @@ -75,7 +75,7 @@ "Associate R code buffer with an R session. Make SESSION be the inferior ESS process associated with the current code buffer." - (when-let ((process (get-buffer-process session))) + (when-let* ((process (get-buffer-process session))) (setq ess-local-process-name (process-name process)) (ess-make-buffer-current)) (setq-local ess-gen-proc-buffer-name-function (lambda (_) session))) diff --git a/lisp/org/ob-processing.el b/lisp/org/ob-processing.el index 2733b1d1f6d..f7326f0eea7 100644 --- a/lisp/org/ob-processing.el +++ b/lisp/org/ob-processing.el @@ -56,7 +56,6 @@ (org-assert-version) (require 'ob) -(require 'sha1) (declare-function processing-sketch-run "ext:processing-mode" ()) diff --git a/lisp/org/ob-python.el b/lisp/org/ob-python.el index 8a3c24f7038..f881918c75c 100644 --- a/lisp/org/ob-python.el +++ b/lisp/org/ob-python.el @@ -269,7 +269,7 @@ results as a string." "Return non-nil if the last prompt matches input prompt. Backport of `python-util-comint-end-of-output-p' to emacs28. To be removed after minimum supported version reaches emacs29." - (when-let ((prompt (python-util-comint-last-prompt))) + (when-let* ((prompt (python-util-comint-last-prompt))) (python-shell-comint-end-of-output-p (buffer-substring-no-properties (car prompt) (cdr prompt))))) diff --git a/lisp/org/ol-eshell.el b/lisp/org/ol-eshell.el index 595dd0ee0f8..e364a38c17d 100644 --- a/lisp/org/ol-eshell.el +++ b/lisp/org/ol-eshell.el @@ -51,9 +51,9 @@ followed by a colon." (if (get-buffer eshell-buffer-name) (pop-to-buffer eshell-buffer-name - (if (boundp 'display-comint-buffer-action) ; Emacs >= 29 + (if (boundp 'display-comint-buffer-action) ; Emacs >= 29, <= 30 display-comint-buffer-action - '(display-buffer-same-window (inhibit-same-window)))) + '(display-buffer-same-window (inhibit-same-window) (category . comint)))) (eshell)) (goto-char (point-max)) (eshell-kill-input) diff --git a/lisp/org/ol.el b/lisp/org/ol.el index a16f27c2e30..c3101254f70 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -2028,7 +2028,7 @@ non-interactively, don't allow editing the default description." (setq link (substring link 0 -1)))) (setq link (with-current-buffer origbuf (org-link--try-special-completion link))))) - (when-let ((window (get-buffer-window "*Org Links*" t))) + (when-let* ((window (get-buffer-window "*Org Links*" t))) (quit-window 'kill window)) (set-window-configuration wcf) (when (get-buffer "*Org Links*") diff --git a/lisp/org/org-attach.el b/lisp/org/org-attach.el index fc7f50a08e7..a441971238a 100644 --- a/lisp/org/org-attach.el +++ b/lisp/org/org-attach.el @@ -357,7 +357,7 @@ Shows a list of commands and prompts for another key to execute a command." (while (and (setq c (read-char-exclusive)) (memq c '(?\C-n ?\C-p ?\C-v ?\M-v))) (org-scroll c t))) - (when-let ((window (get-buffer-window "*Org Attach*" t))) + (when-let* ((window (get-buffer-window "*Org Attach*" t))) (quit-window 'kill window)) (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*"))))) (let ((command (cl-some (lambda (entry) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 316cd7eee4b..7ac4f27ad80 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -698,7 +698,7 @@ there is no recent clock to choose from." (fit-window-to-buffer nil nil (if (< chl 10) chl (+ 5 chl))) (message (or prompt "Select task for clocking:")) (unwind-protect (setq cursor-type nil rpl (read-char-exclusive)) - (when-let ((window (get-buffer-window "*Clock Task Select*" t))) + (when-let* ((window (get-buffer-window "*Clock Task Select*" t))) (quit-window 'kill window)) (when (get-buffer "*Clock Task Select*") (kill-buffer "*Clock Task Select*"))) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index 41c26ad72fe..e92b8d718c8 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -115,10 +115,10 @@ This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (when-let ((window (or (display-buffer-reuse-window buffer alist) - (display-buffer-same-window buffer alist) - (display-buffer-pop-up-window buffer alist) - (display-buffer-use-some-window buffer alist)))) + (when-let* ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) (delete-other-windows window) window))) diff --git a/lisp/org/org-element-ast.el b/lisp/org/org-element-ast.el index f3f74928004..e96b129f1fc 100644 --- a/lisp/org/org-element-ast.el +++ b/lisp/org/org-element-ast.el @@ -410,7 +410,7 @@ If PROPERTY is not present, return DFLT." (let ((idx (org-element--property-idx (inline-const-val property)))) (inline-quote (let ((idx (or ,idx (org-element--property-idx ,property)))) - (if-let ((parray (and idx (org-element--parray ,node)))) + (if-let* ((parray (and idx (org-element--parray ,node)))) (pcase (aref parray idx) (`org-element-ast--nil ,dflt) (val val)) @@ -456,7 +456,7 @@ Return modified NODE." (inline-quote (let ((idx (org-element--property-idx ,property))) (if (and idx (not (org-element-type-p ,node 'plain-text))) - (when-let + (when-let* ((parray (or (org-element--parray ,node) (org-element--put-parray ,node)))) @@ -796,7 +796,7 @@ When DATUM is `plain-text', all the properties are removed." (type (let ((node-copy (append (list type (copy-sequence (cadr datum))) (copy-sequence (cddr datum))))) ;; Copy `:standard-properties' - (when-let ((parray (org-element-property-raw :standard-properties node-copy))) + (when-let* ((parray (org-element-property-raw :standard-properties node-copy))) (org-element-put-property node-copy :standard-properties (copy-sequence parray))) ;; Clear `:parent'. (org-element-put-property node-copy :parent nil) @@ -810,7 +810,7 @@ When DATUM is `plain-text', all the properties are removed." ;; properties. So, we need to reassign inner `:parent' ;; properties to the DATUM copy explicitly. (dolist (secondary-prop (org-element-property :secondary node-copy)) - (when-let ((secondary-value (org-element-property secondary-prop node-copy))) + (when-let* ((secondary-value (org-element-property secondary-prop node-copy))) (setq secondary-value (org-element-copy secondary-value t)) (if (org-element-type secondary-value) (org-element-put-property secondary-value :parent node-copy) diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index a3fe427403a..d184165f6cb 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -4455,10 +4455,10 @@ Assume point is at the beginning of the timestamp." (and val (number-to-string val))) (pcase (org-element-property :repeater-unit timestamp) (`hour "h") (`day "d") (`week "w") (`month "m") (`year "y")) - (when-let ((repeater-deadline-value - (org-element-property :repeater-deadline-value timestamp)) - (repeater-deadline-unit - (org-element-property :repeater-deadline-unit timestamp))) + (when-let* ((repeater-deadline-value + (org-element-property :repeater-deadline-value timestamp)) + (repeater-deadline-unit + (org-element-property :repeater-deadline-unit timestamp))) (concat "/" (number-to-string repeater-deadline-value) @@ -6012,7 +6012,7 @@ cache during the synchronization get a new key generated with Such keys are stored inside the element property `:org-element--cache-sync-key'. The property is a cons containing current `org-element--cache-sync-keys-value' and the element key." - (or (when-let ((key-cons (org-element-property :org-element--cache-sync-key element))) + (or (when-let* ((key-cons (org-element-property :org-element--cache-sync-key element))) (when (eq org-element--cache-sync-keys-value (car key-cons)) (cdr key-cons))) (let* ((begin (org-element-begin element)) diff --git a/lisp/org/org-feed.el b/lisp/org/org-feed.el index 4077afa0d3c..c90174f0fa7 100644 --- a/lisp/org/org-feed.el +++ b/lisp/org/org-feed.el @@ -92,7 +92,6 @@ (org-assert-version) (require 'org) -(require 'sha1) (declare-function url-retrieve-synchronously "url" (url &optional silent inhibit-cookies timeout)) diff --git a/lisp/org/org-goto.el b/lisp/org/org-goto.el index cb74942a5e7..f75cc9ed85a 100644 --- a/lisp/org/org-goto.el +++ b/lisp/org/org-goto.el @@ -241,7 +241,7 @@ position or nil." (message "Select location and press RET") (use-local-map org-goto-map) (unwind-protect (recursive-edit) - (when-let ((window (get-buffer-window "*Org Help*" t))) + (when-let* ((window (get-buffer-window "*Org Help*" t))) (quit-window 'kill window))))) (when (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) (cons org-goto-selected-point org-goto-exit-command))) diff --git a/lisp/org/org-lint.el b/lisp/org/org-lint.el index 2d87ae270c4..0f96134587c 100644 --- a/lisp/org/org-lint.el +++ b/lisp/org/org-lint.el @@ -551,7 +551,7 @@ Use :header-args: instead" (defun org-lint-suspicious-language-in-src-block (ast) (org-element-map ast 'src-block (lambda (b) - (when-let ((lang (org-element-property :language b))) + (when-let* ((lang (org-element-property :language b))) (unless (or (functionp (intern (format "org-babel-execute:%s" lang))) ;; No babel backend, but there is corresponding ;; major mode. @@ -859,9 +859,9 @@ Use \"export %s\" instead" (when (member prop common-options) "global ") prop - (if-let ((backends - (and (not (member prop common-options)) - (cdr (assoc-string prop options-alist))))) + (if-let* ((backends + (and (not (member prop common-options)) + (cdr (assoc-string prop options-alist))))) (format " in %S export %s" (if (= 1 (length backends)) (car backends) backends) diff --git a/lisp/org/org-macs.el b/lisp/org/org-macs.el index a6ff0e54512..4071b632fcb 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -573,7 +573,7 @@ is selected, only the bare key is returned." ((assoc current specials) (throw 'exit current)) (t (error "No entry available"))))))) (when buffer - (when-let ((window (get-buffer-window buffer t))) + (when-let* ((window (get-buffer-window buffer t))) (quit-window 'kill window)) (kill-buffer buffer)))))) diff --git a/lisp/org/org-persist.el b/lisp/org/org-persist.el index 7fa836d0d7a..cd66a0a57a8 100644 --- a/lisp/org/org-persist.el +++ b/lisp/org/org-persist.el @@ -810,8 +810,8 @@ COLLECTION is the plist holding data collection." (let ((scope (nth 2 container))) (pcase scope ((pred stringp) - (when-let ((buf (or (get-buffer scope) - (get-file-buffer scope)))) + (when-let* ((buf (or (get-buffer scope) + (get-file-buffer scope)))) ;; FIXME: There is `buffer-local-boundp' introduced in Emacs 28. ;; Not using it yet to keep backward compatibility. (condition-case nil @@ -821,8 +821,8 @@ COLLECTION is the plist holding data collection." (when (boundp (cadr container)) (symbol-value (cadr container)))) (`nil - (if-let ((buf (and (plist-get (plist-get collection :associated) :file) - (get-file-buffer (plist-get (plist-get collection :associated) :file))))) + (if-let* ((buf (and (plist-get (plist-get collection :associated) :file) + (get-file-buffer (plist-get (plist-get collection :associated) :file))))) ;; FIXME: There is `buffer-local-boundp' introduced in Emacs 28. ;; Not using it yet to keep backward compatibility. (condition-case nil diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 8a0943a48b9..222bc7d9658 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -3709,7 +3709,7 @@ With prefix ARG, apply the new formulas to the table." (org-table-store-formulas eql) (set-marker pos nil) (set-marker source nil) - (when-let ((window (get-buffer-window "*Edit Formulas*" t))) + (when-let* ((window (get-buffer-window "*Edit Formulas*" t))) (quit-window 'kill window)) (when (get-buffer "*Edit Formulas*") (kill-buffer "*Edit Formulas*")) (if arg diff --git a/lisp/org/org.el b/lisp/org/org.el index 5bee96fb0b5..4166738c162 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -13219,8 +13219,8 @@ However, if LITERAL-NIL is set, return the string value \"nil\" instead." ;; Consider global properties, if we found no PROPERTY (or maybe ;; only PROPERTY+). (unless found-inherited? - (when-let ((global (org--property-global-or-keyword-value - property t))) + (when-let* ((global (org--property-global-or-keyword-value + property t))) (setq values (cons global values)))) (when values (setq values (mapconcat diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 446698758c4..4eb3a511b00 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -1732,7 +1732,7 @@ targets and targets." (and (memq type '(radio-target target)) (org-element-property :value datum)) (org-element-property :name datum) - (when-let ((id (org-element-property :ID datum))) + (when-let* ((id (org-element-property :ID datum))) (concat org-html--id-attr-prefix id))))) (cond @@ -2052,7 +2052,7 @@ INFO is a plist used as a communication channel." (when value (pcase symbol (`font - (when-let + (when-let* ((value-new (pcase value ("TeX" "mathjax-tex") @@ -2697,7 +2697,7 @@ information." (let ((attributes (org-export-read-attribute :attr_html example-block))) (if (plist-get attributes :textarea) (org-html--textarea-block example-block) - (if-let ((class-val (plist-get attributes :class))) + (if-let* ((class-val (plist-get attributes :class))) (setq attributes (plist-put attributes :class (concat "example " class-val))) (setq attributes (plist-put attributes :class "example"))) (format "<pre%s>\n%s</pre>" diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index 79df1fe119e..4d0935b073d 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -4097,7 +4097,7 @@ a communication channel." (unless (hash-table-p table-head-cache) (setq table-head-cache (make-hash-table :test #'eq)) (plist-put info :org-latex-table-head-cache table-head-cache)) - (if-let ((head-contents (gethash (org-element-parent table-row) table-head-cache))) + (if-let* ((head-contents (gethash (org-element-parent table-row) table-head-cache))) (puthash (org-element-parent table-row) (concat head-contents "\\\\\n" contents) table-head-cache) (puthash (org-element-parent table-row) contents table-head-cache)))) diff --git a/lisp/org/ox.el b/lisp/org/ox.el index 7cdf622ec44..fd8bfa1114a 100644 --- a/lisp/org/ox.el +++ b/lisp/org/ox.el @@ -2672,7 +2672,7 @@ from tree." (let ((type (org-element-type data))) (if (org-export--skip-p data info selected excluded) (if (memq type '(table-cell table-row)) (push data ignore) - (if-let ((keep-spaces (org-export--keep-spaces data info))) + (if-let* ((keep-spaces (org-export--keep-spaces data info))) ;; Keep spaces in place of removed ;; element, if necessary. ;; Example: "Foo.[10%] Bar" would become @@ -3456,7 +3456,7 @@ file." (with-temp-buffer (let ((org-inhibit-startup t) (lines - (if-let ((location (plist-get parameters :location))) + (if-let* ((location (plist-get parameters :location))) (org-export--inclusion-absolute-lines file location (plist-get parameters :only-contents) diff --git a/lisp/outline.el b/lisp/outline.el index 4d72b17e623..3a021a9d1e6 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1856,8 +1856,8 @@ With a prefix argument, show headings up to that LEVEL." (save-excursion (goto-char (point-min)) (while (not (or (eq top-level 1) (eobp))) - (when-let ((level (and (outline-on-heading-p t) - (funcall outline-level)))) + (when-let* ((level (and (outline-on-heading-p t) + (funcall outline-level)))) (when (< level (or top-level most-positive-fixnum)) (setq top-level (max level 1)))) (outline-next-heading))) diff --git a/lisp/pcmpl-git.el b/lisp/pcmpl-git.el index 95b6859dd23..c282e3eb4a8 100644 --- a/lisp/pcmpl-git.el +++ b/lisp/pcmpl-git.el @@ -39,10 +39,10 @@ (defun pcmpl-git--tracked-file-predicate (&rest args) "Return a predicate function determining the Git status of a file. Files listed by `git ls-files ARGS' satisfy the predicate." - (when-let ((files (mapcar #'expand-file-name - (ignore-errors - (apply #'process-lines - vc-git-program "ls-files" args))))) + (when-let* ((files (mapcar #'expand-file-name + (ignore-errors + (apply #'process-lines + vc-git-program "ls-files" args))))) (lambda (file) (setq file (expand-file-name file)) (if (string-suffix-p "/" file) diff --git a/lisp/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index 237e3d62526..2b48255f3f1 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -354,7 +354,7 @@ Return the new list." (while (pcomplete-here '("-amin" "-anewer" "-atime" "-cmin" "-cnewer" "-context" "-ctime" "-daystart" "-delete" "-depth" "-empty" "-exec" - "-execdir" "-executable" "-false" "-fls" "-follow" + "-execdir" "-executable" "-false" "-files0-from" "-fls" "-follow" "-fprint" "-fprint0" "-fprintf" "-fstype" "-gid" "-group" "-help" "-ignore_readdir_race" "-ilname" "-iname" "-inum" "-ipath" "-iregex" "-iwholename" diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 5b2dc089a52..057ff379ef6 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -161,22 +161,22 @@ This is only effective if supported by your mouse or touchpad." (defcustom pixel-scroll-precision-momentum-tick 0.01 "Number of seconds between each momentum scroll." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-momentum-seconds 1.75 "The maximum duration in seconds of momentum scrolling." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-momentum-min-velocity 10.0 "The minimum scrolled pixels per second before momentum scrolling starts." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-initial-velocity-factor (/ 0.0335 4) "Factor applied to the initial velocity before momentum scrolling begins." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-large-scroll-height nil @@ -188,17 +188,17 @@ Nil means to not interpolate such scrolls." (defcustom pixel-scroll-precision-interpolation-total-time 0.1 "The total time in seconds to spend interpolating a large scroll." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-interpolation-factor 2.0 "A factor to apply to the distance of an interpolated scroll." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-interpolation-between-scroll 0.001 "The number of seconds between each step of an interpolated scroll." - :type 'float + :type 'number :version "29.1") (defcustom pixel-scroll-precision-interpolate-page nil diff --git a/lisp/play/animate.el b/lisp/play/animate.el index 33df0a65797..115a9911270 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -102,7 +102,7 @@ "Total number of seconds to wait in between steps. This is added to the total time it takes to run `animate-string' to ensure that the animation is not too fast to be seen." - :type 'float + :type 'number :version "29.1") (defvar animation-buffer-name nil diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el index 56f166c10f1..805d2f93b9a 100644 --- a/lisp/play/decipher.el +++ b/lisp/play/decipher.el @@ -109,8 +109,8 @@ This variable must be set before typing `\\[decipher]'." You should set this to nil if the cipher message is divided into words, or t if it is not. This variable is buffer-local." - :type 'boolean) -(make-variable-buffer-local 'decipher-ignore-spaces) + :type 'boolean + :local t) (defcustom decipher-undo-limit 5000 "The maximum number of entries in the undo list. diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index a098d0f6f69..ec1f3f372fb 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -493,11 +493,7 @@ convert to an Emacs image-spec instead") (defun gamegrid-set-timer (delay) (if gamegrid-timer - (timer-set-time gamegrid-timer - (list (aref gamegrid-timer 1) - (aref gamegrid-timer 2) - (aref gamegrid-timer 3)) - delay))) + (timer-set-time gamegrid-timer (timer--time gamegrid-timer) delay))) (defun gamegrid-kill-timer () (if gamegrid-timer @@ -639,27 +635,31 @@ FILE is created there." (defun gamegrid-add-score-insecure (file score &optional directory reverse) (save-excursion - (setq file (expand-file-name file (or directory - temporary-file-directory))) - (unless (file-exists-p (file-name-directory file)) - (make-directory (file-name-directory file) t)) - (find-file-other-window file) - (setq buffer-read-only nil) - (goto-char (point-max)) - (insert (format "%05d\t%s\t%s <%s>\n" - score - (current-time-string) - (user-full-name) - user-mail-address)) - (sort-fields 1 (point-min) (point-max)) - (unless reverse - (reverse-region (point-min) (point-max))) - (goto-char (point-min)) - (forward-line gamegrid-score-file-length) - (delete-region (point) (point-max)) - (setq buffer-read-only t) - (save-buffer) - (view-mode))) + (let ((score-line (format "%05d\t%s\t%s <%s>\n" + score + (current-time-string) + (user-full-name) + user-mail-address))) + (setq file (expand-file-name file (or directory + temporary-file-directory))) + (unless (file-exists-p (file-name-directory file)) + (make-directory (file-name-directory file) t)) + (find-file-other-window file) + (setq buffer-read-only nil) + (goto-char (point-max)) + (insert score-line) + (sort-fields 1 (point-min) (point-max)) + (unless reverse + (reverse-region (point-min) (point-max))) + (goto-char (point-min)) + (forward-line gamegrid-score-file-length) + (delete-region (point) (point-max)) + (setq buffer-read-only t) + (save-buffer) + (view-mode) + (goto-char (point-min)) + (when (search-forward score-line nil 'end) + (forward-line -1))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/plstore.el b/lisp/plstore.el index db977cb6308..a33d6bca84c 100644 --- a/lisp/plstore.el +++ b/lisp/plstore.el @@ -236,6 +236,7 @@ If neither t nor nil, doesn't ask user." May either be a string or a list of strings. If it is nil, symmetric encryption will be used." :type '(choice (const nil) (repeat :tag "Recipient(s)" string)) + :local 'permanent-only :group 'plstore) ;;;###autoload @@ -250,7 +251,6 @@ symmetric encryption will be used." val) t))))) -(put 'plstore-encrypt-to 'permanent-local t) (defvar plstore-encoded nil "Non-nil if the current buffer shows the decoded alist.") ; [sic!] diff --git a/lisp/proced.el b/lisp/proced.el index 1d257b6bd4d..da9212f6802 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -289,8 +289,8 @@ one, etc." It can be the car of an element of `proced-format-alist'. It can also be a list of keys appearing in `proced-grammar-alist'." :type '(choice (symbol :tag "Format Name") - (repeat :tag "Keys" (symbol :tag "")))) -(make-variable-buffer-local 'proced-format) + (repeat :tag "Keys" (symbol :tag ""))) + :local t) ;; FIXME: is there a better name for filter `user' that does not coincide ;; with an attribute key? @@ -335,8 +335,8 @@ of `proced-filter-alist'." (choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp) (cons :tag "Key . Function" (symbol :tag "Key") function) (cons :tag "Function" (const :tag "Key: function" function) function) - (cons :tag "Fun-all" (const :tag "Key: fun-all" fun-all) function))))) -(make-variable-buffer-local 'proced-filter) + (cons :tag "Fun-all" (const :tag "Key: fun-all" fun-all) function)))) + :local t) (defcustom proced-sort 'pcpu "Current sort scheme for proced listing. @@ -344,13 +344,13 @@ It must be the KEY of an element of `proced-grammar-alist'. It can also be a list of KEYs as in the SORT-SCHEMEs of the elements of `proced-grammar-alist'." :type '(choice (symbol :tag "Sort Scheme") - (repeat :tag "Key List" (symbol :tag "Key")))) -(make-variable-buffer-local 'proced-sort) + (repeat :tag "Key List" (symbol :tag "Key"))) + :local t) (defcustom proced-descend t "Non-nil if proced listing is sorted in descending order." - :type '(boolean :tag "Descending Sort Order")) -(make-variable-buffer-local 'proced-descend) + :type '(boolean :tag "Descending Sort Order") + :local t) (defcustom proced-goal-attribute 'args "If non-nil, key of the attribute that defines the `goal-column'." @@ -368,13 +368,13 @@ displayed in a window. Can be changed interactively via `proced-toggle-auto-update'." :type '(radio (const :tag "Don't auto update" nil) (const :tag "Only update visible proced buffers" visible) - (const :tag "Update all proced buffers" t))) -(make-variable-buffer-local 'proced-auto-update-flag) + (const :tag "Update all proced buffers" t)) + :local t) (defcustom proced-tree-flag nil "Non-nil for display of Proced buffer as process tree." - :type 'boolean) -(make-variable-buffer-local 'proced-tree-flag) + :type 'boolean + :local t) (defcustom proced-post-display-hook nil "Normal hook run after displaying or updating a Proced buffer. @@ -955,11 +955,11 @@ Proced buffers." "Auto-update Proced buffers using `run-at-time'. If there are no proced buffers, cancel the timer." - (if-let (buffers (match-buffers '(derived-mode . proced-mode))) + (if-let* ((buffers (match-buffers '(derived-mode . proced-mode)))) (dolist (buf buffers) - (when-let ((flag (buffer-local-value 'proced-auto-update-flag buf)) - ((or (not (eq flag 'visible)) - (get-buffer-window buf 'visible)))) + (when-let* ((flag (buffer-local-value 'proced-auto-update-flag buf)) + ((or (not (eq flag 'visible)) + (get-buffer-window buf 'visible)))) (with-current-buffer buf (proced-update t t)))) (cancel-timer proced-auto-update-timer) diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el index d47c525c5f9..6fff11bb39f 100644 --- a/lisp/progmodes/asm-mode.el +++ b/lisp/progmodes/asm-mode.el @@ -125,21 +125,24 @@ Turning on Asm mode runs the hook `asm-mode-hook' at the end of initialization. Special commands: \\{asm-mode-map}" + :after-hook + (progn + (run-hooks 'asm-mode-set-comment-hook) + ;; Make our own local child of `asm-mode-map' + ;; so we can define our own comment character. + (use-local-map (make-composed-keymap nil asm-mode-map)) + (local-set-key (vector asm-comment-char) #'asm-comment) + (set-syntax-table (make-syntax-table asm-mode-syntax-table)) + (modify-syntax-entry asm-comment-char "< b") + + (setq-local comment-start (string asm-comment-char))) + (setq local-abbrev-table asm-mode-abbrev-table) (setq-local font-lock-defaults '(asm-font-lock-keywords)) (setq-local indent-line-function #'asm-indent-line) ;; Stay closer to the old TAB behavior (was tab-to-tab-stop). (setq-local tab-always-indent nil) - (run-hooks 'asm-mode-set-comment-hook) - ;; Make our own local child of `asm-mode-map' - ;; so we can define our own comment character. - (use-local-map (nconc (make-sparse-keymap) asm-mode-map)) - (local-set-key (vector asm-comment-char) #'asm-comment) - (set-syntax-table (make-syntax-table asm-mode-syntax-table)) - (modify-syntax-entry asm-comment-char "< b") - - (setq-local comment-start (string asm-comment-char)) (setq-local comment-add 1) (setq-local comment-start-skip "\\(?:\\s<+\\|/[/*]+\\)[ \t]*") (setq-local comment-end-skip "[ \t]*\\(\\s>\\|\\*+/\\)") diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 3bcfc213fc6..a2cb65f2c71 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -380,15 +380,15 @@ URL-REGEXP against the VCS URL and returns the value to be set as Test each configuration in `bug-reference-setup-from-vc-alist' and `bug-reference--setup-from-vc-alist' and apply it if applicable." - (when-let ((file-or-dir (or buffer-file-name - ;; Catches modes such as vc-dir and Magit. - default-directory)) - (backend (vc-responsible-backend file-or-dir t)) - (url (seq-some (lambda (remote) - (ignore-errors - (vc-call-backend backend 'repository-url - file-or-dir remote))) - '("upstream" nil)))) + (when-let* ((file-or-dir (or buffer-file-name + ;; Catches modes such as vc-dir and Magit. + default-directory)) + (backend (vc-responsible-backend file-or-dir t)) + (url (seq-some (lambda (remote) + (ignore-errors + (vc-call-backend backend 'repository-url + file-or-dir remote))) + '("upstream" nil)))) (seq-some (lambda (config) (apply #'bug-reference-maybe-setup-from-vc url config)) (append bug-reference-setup-from-vc-alist diff --git a/lisp/progmodes/c-ts-common.el b/lisp/progmodes/c-ts-common.el index 8630598708d..2689cb51133 100644 --- a/lisp/progmodes/c-ts-common.el +++ b/lisp/progmodes/c-ts-common.el @@ -52,6 +52,12 @@ (declare-function treesit-node-type "treesit.c") (declare-function treesit-node-parent "treesit.c") (declare-function treesit-node-prev-sibling "treesit.c") +(declare-function treesit-parser-language "treesit.c") +(declare-function treesit-node-match-p "treesit.c") +(declare-function treesit-node-child "treesit.c") +(declare-function treesit-node-eq "treesit.c") +(declare-function treesit-parser-root-node "treesit.c") +(declare-function treesit-node-parser "treesit.c") ;;; Comment indentation and filling @@ -128,8 +134,8 @@ ARG is passed to `fill-paragraph'." (looking-at "//")) ;; In rust, NODE will be the body of a comment, and the ;; parent will be the whole comment. - (if-let ((start (treesit-node-start - (treesit-node-parent node)))) + (if-let* ((start (treesit-node-start + (treesit-node-parent node)))) (save-excursion (goto-char start) (looking-at "//")))) @@ -152,20 +158,18 @@ comment." (start-marker (point-marker)) (end-marker nil) (end-len 0) - (start-mask-done nil) (end-mask-done nil)) (move-marker start-marker start) - ;; We mask "/*" and the space before "*/" like - ;; `c-fill-paragraph' does. + ;; If the first line is /* followed by non-text, exclude this line + ;; from filling. (atomic-change-group - ;; Mask "/*". (goto-char start) (when (looking-at (rx (* (syntax whitespace)) - (group "/") "*")) - (goto-char (match-beginning 1)) - (move-marker start-marker (point)) - (setq start-mask-done t) - (replace-match " " nil nil nil 1)) + (group "/") "*" + (* (or "*" "=" "-" "/" (syntax whitespace))) + eol)) + (forward-line) + (move-marker start-marker (point))) ;; Include whitespaces before /*. (goto-char start) @@ -190,9 +194,9 @@ comment." ;; filling region. (when (not end-marker) (goto-char end) - (when (looking-back (rx "*/") 2) - (backward-char 2) - (skip-syntax-backward "-") + (forward-line 0) + (when (looking-at (rx (* (or (syntax whitespace) "*" "=" "-")) + "*/" eol)) (setq end (point)))) ;; Let `fill-paragraph' do its thing. @@ -210,16 +214,63 @@ comment." (fill-region (max start-marker para-start) (min end para-end) arg)) ;; Unmask. - (when (and start-mask-done start-marker) - (goto-char start-marker) - (delete-char 1) - (insert "/")) - (when (and end-mask-done end-marker) + (when (and end-marker end-mask-done) (goto-char end-marker) (delete-region (point) (+ end-len (point))) (insert (make-string end-len ?\s))) (goto-char orig-point)))) +(defun c-ts-common--adaptive-fill-prefix () + "Returns the appropriate fill-prefix for this paragraph. + +This function should be called at BOL. Used by +`adaptive-fill-function'." + (cond + ;; (1) + ;; If current line is /* and next line is * -> prefix is *. + ;; Eg: + ;; /* xxx => /* xxx + ;; * xxx xxx * xxx + ;; * xxx + ;; If current line is /* and next line isn't * or doesn't exist -> + ;; prefix is whitespace. + ;; Eg: + ;; /* xxx xxx */ => /* xxx + ;; xxx */ + ((and (looking-at (rx (* (syntax whitespace)) + "/*" + (* "*") + (* (syntax whitespace)))) + (let ((whitespaces (make-string (length (match-string 0)) ?\s))) + (save-excursion + (if (and (eq (forward-line) 0) + (looking-at (rx (* (syntax whitespace)) + "*" + (* (syntax whitespace))))) + (match-string 0) + whitespaces))))) + ;; (2) + ;; Current line: //, ///, ////... + ;; Prefix: same. + ((looking-at (rx (* (syntax whitespace)) + "//" + (* "/") + (* (syntax whitespace)))) + (match-string 0)) + ;; (3) + ;; Current line: *, |, - + ;; Prefix: same. + ;; This branch must return the same prefix as branch (1), as the + ;; second line in the paragraph; then the whole paragraph will use * + ;; as the prefix. + ((looking-at (rx (* (syntax whitespace)) + (or "*" "|" "-") + (* (syntax whitespace)))) + (match-string 0)) + ;; Other: let `adaptive-fill-regexp' and + ;; `adaptive-fill-first-line-regexp' decide. + (t nil))) + (defun c-ts-common-comment-setup () "Set up local variables for C-like comment. @@ -245,31 +296,15 @@ Set up: (group (or (syntax comment-end) (seq (+ "*") "/"))))) (setq-local adaptive-fill-mode t) - ;; This matches (1) empty spaces (the default), (2) "//", (3) "*", - ;; but do not match "/*", because we don't want to use "/*" as - ;; prefix when filling. (Actually, it doesn't matter, because - ;; `comment-start-skip' matches "/*" which will cause - ;; `fill-context-prefix' to use "/*" as a prefix for filling, that's - ;; why we mask the "/*" in `c-ts-common--fill-paragraph'.) - (setq-local adaptive-fill-regexp - (concat (rx (* (syntax whitespace)) - (group (or (seq "/" (+ "/")) (* "*")))) - adaptive-fill-regexp)) - ;; Note the missing * comparing to `adaptive-fill-regexp'. The - ;; reason for its absence is a bit convoluted to explain. Suffice - ;; to say that without it, filling a single line paragraph that - ;; starts with /* doesn't insert * at the beginning of each - ;; following line, and filling a multi-line paragraph whose first - ;; two lines start with * does insert * at the beginning of each - ;; following line. If you know how does adaptive filling works, you - ;; know what I mean. + (setq-local adaptive-fill-function #'c-ts-common--adaptive-fill-prefix) + ;; Always accept * or | as prefix, even if there's only one line in + ;; the paragraph. (setq-local adaptive-fill-first-line-regexp (rx bos - (seq (* (syntax whitespace)) - (group (seq "/" (+ "/"))) - (* (syntax whitespace))) + (* (syntax whitespace)) + (or "*" "|") + (* (syntax whitespace)) eos)) - ;; Same as `adaptive-fill-regexp'. (setq-local paragraph-start (rx (or (seq (* (syntax whitespace)) (group (or (seq "/" (+ "/")) (* "*"))) @@ -307,7 +342,7 @@ and /* */ comments. SOFT works the same as in (delete-horizontal-space) (if soft (insert-and-inherit ?\n) - (newline 1))))) + (newline 1))))) (cond ;; Line starts with //, or ///, or ////... ;; Or //! (used in rust). @@ -358,6 +393,28 @@ and /* */ comments. SOFT works the same as in (delete-region (line-beginning-position) (point)) (insert whitespaces)))))) +;; Font locking using doxygen parser +(defvar c-ts-mode-doxygen-comment-font-lock-settings + (treesit-font-lock-rules + :language 'doxygen + :feature 'document + :override t + '((document) @font-lock-doc-face) + + :language 'doxygen + :override t + :feature 'keyword + '((tag_name) @font-lock-constant-face + (storageclass) @font-lock-constant-face) + + :language 'doxygen + :override t + :feature 'definition + '((tag (identifier) @font-lock-variable-name-face) + (function (identifier) @font-lock-function-name-face) + (function_link) @font-lock-function-name-face)) + "Tree-sitter font lock rules for doxygen like comment styles.") + ;;; Statement indent (defvar c-ts-common-indent-offset nil @@ -481,6 +538,169 @@ characters on the current line." (setq node (treesit-node-parent node))) (* level (symbol-value c-ts-common-indent-offset)))) +;;; Baseline indent rule + +(defvar c-ts-common-list-indent-style 'align + "Intructs `c-ts-common-baseline-indent-rule' how to indent lists. + +If the value is `align', indent lists like this: + +const a = [ + 1, 2, 3 + 4, 5, 6, + ]; + +If the value is `simple', indent lists like this: + +const a = [ + 1, 2, 3, + 4, 5, 6, +];") + +(defun c-ts-common--standalone-parent (parent) + "Find the first parent that starts on a new line. +Start searching from PARENT, so if PARENT satisfies the condition, it'll +be returned. Return the starting position of the parent, return nil if +no parent satisfies the condition." + (save-excursion + (catch 'term + (while parent + (goto-char (treesit-node-start parent)) + (when (looking-back (rx bol (* whitespace)) + (line-beginning-position)) + (throw 'term (point))) + (setq parent (treesit-node-parent parent)))))) + +(defun c-ts-common--prev-standalone-sibling (node) + "Return the previous sibling of NODE that starts on a new line. +Return nil if no sibling satisfies the condition." + (save-excursion + (setq node (treesit-node-prev-sibling node 'named)) + (goto-char (treesit-node-start node)) + (while (and node + (goto-char (treesit-node-start node)) + (not (looking-back (rx bol (* whitespace)) + (pos-bol)))) + (setq node (treesit-node-prev-sibling node 'named))) + node)) + +(defun c-ts-common-parent-ignore-preproc (node) + "Return the parent of NODE, skipping preproc nodes." + (let ((parent (treesit-node-parent node)) + (pred (if (treesit-thing-defined-p + 'preproc (or (and node (treesit-node-language node)) + (treesit-parser-language + treesit-primary-parser))) + 'preproc + "preproc"))) + (while (and parent (treesit-node-match-p parent pred)) + (setq parent (treesit-node-parent parent))) + parent)) + +(defun c-ts-common-baseline-indent-rule (node parent bol &rest _) + "Baseline indent rule for C-like languages. + +NODE PARENT, BOL are like in other simple indent rules. + +This rule works as follows: + +Let PREV-NODE be the largest node that starts on previous line, +basically the NODE we get if we were indenting previous line. + +0. Closing brace aligns with first parent that starts on a new line. + +1. If PREV-NODE and NODE are siblings, align this line to previous +line (PREV-NODE as the anchor, and offset is 0). + +2. If PARENT is a list, ie, (...) [...], align with NODE's first +sibling. For the first sibling and the closing paren or bracket, indent +according to `c-ts-common-list-indent-style'. This rule also handles +initializer lists like {...}, but initializer lists doesn't respect +`c-ts-common-list-indent-style'--they always indent in the `simple' +style. + +3. Otherwise, go up the parse tree from NODE and look for a parent that +starts on a new line. Use that parent as the anchor and indent one +level. But if the node is a top-level construct (ignoring preprocessor +nodes), don't indent it. + +This rule works for a wide range of scenarios including complex +situations. Major modes should use this as the fallback rule, and add +exception rules before it to cover the cases it doesn't apply. + +This rule tries to be smart and ignore proprocessor node in some +situations. By default, any node that has \"proproc\" in its type are +considered a preprocessor node. If that heuristic is inaccurate, define +a `preproc' thing in `treesit-thing-settings', and this rule will use +the thing definition instead." + (let ((prev-line-node (treesit--indent-prev-line-node bol)) + (offset (symbol-value c-ts-common-indent-offset))) + (cond + ;; Condition 0. + ((and (treesit-node-match-p node "}") + (treesit-node-match-p (treesit-node-child parent 0) "{")) + (cons (c-ts-common--standalone-parent parent) + 0)) + ;; Condition 1. + ((and (treesit-node-eq (treesit-node-parent prev-line-node) + parent) + (not (treesit-node-match-p node (rx (or ")" "]"))))) + (cons (treesit-node-start prev-line-node) + 0)) + ;; Condition 2. + ((treesit-node-match-p (treesit-node-child parent 0) + (rx (or "(" "["))) + (let ((first-sibling (treesit-node-child parent 0 'named))) + (cond + ;; Closing delimeters. + ((treesit-node-match-p node (rx (or ")" "]"))) + (if (eq c-ts-common-list-indent-style 'align) + (cons (treesit-node-start (treesit-node-child parent 0)) + 0) + (cons (c-ts-common--standalone-parent parent) + 0))) + ;; First sibling. + ((treesit-node-eq node first-sibling) + (if (eq c-ts-common-list-indent-style 'align) + (cons (treesit-node-start (treesit-node-child parent 0)) + 1) + (cons (c-ts-common--standalone-parent parent) + offset))) + ;; Not first sibling + (t (cons (treesit-node-start + (or (c-ts-common--prev-standalone-sibling node) + first-sibling)) + 0))))) + ;; Condition 2 for initializer list, only apply to + ;; second line. Eg, + ;; + ;; return { 1, 2, 3, + ;; 4, 5, 6, --> Handled by this condition. + ;; 7, 8, 9 }; --> Handled by condition 1. + ((and (treesit-node-match-p (treesit-node-child parent 0) "{") + (treesit-node-prev-sibling node 'named)) + ;; If first sibling is a comment, indent like code; otherwise + ;; align to first sibling. + (if (treesit-node-match-p + (treesit-node-child parent 0 'named) + c-ts-common--comment-regexp 'ignore-missing) + (cons (c-ts-common--standalone-parent parent) + offset) + (cons (treesit-node-start + (treesit-node-child parent 0 'named)) + 0))) + ;; Before we fallback to condition 3, make sure we don't indent + ;; top-level stuff. + ((treesit-node-eq (treesit-parser-root-node + (treesit-node-parser parent)) + (c-ts-common-parent-ignore-preproc node)) + (cons (pos-bol) 0)) + ;; Condition 3. + (t (cons (c-ts-common--standalone-parent parent) + offset))))) + + + (provide 'c-ts-common) ;;; c-ts-common.el ends here diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index e08e99cf087..dec9411b87c 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -63,6 +63,9 @@ ;; will set up Emacs to use the C/C++ modes defined here for other ;; files, provided that you have the corresponding parser grammar ;; libraries installed. +;; +;; If the tree-sitter doxygen grammar is available, then the comment +;; blocks can be highlighted according to this grammar. ;;; Code: @@ -83,6 +86,7 @@ (declare-function treesit-node-first-child-for-pos "treesit.c") (declare-function treesit-node-next-sibling "treesit.c") (declare-function treesit-node-eq "treesit.c") +(declare-function treesit-node-match-p "treesit.c") (declare-function treesit-query-compile "treesit.c") ;;; Custom variables @@ -127,18 +131,11 @@ the value of SYM in `c-ts-mode' and `c++-ts-mode' buffers to VAL. SYM should be `c-ts-mode-indent-style', and VAL should be a style symbol." (set-default sym val) - (named-let loop ((res nil) - (buffers (buffer-list))) - (if (null buffers) - (mapc (lambda (b) - (with-current-buffer b - (c-ts-mode-set-style val))) - res) - (let ((buffer (car buffers))) - (with-current-buffer buffer - (if (derived-mode-p '(c-ts-mode c++-ts-mode)) - (loop (append res (list buffer)) (cdr buffers)) - (loop res (cdr buffers)))))))) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p '(c-ts-mode c++-ts-mode)) + (setq-local c-ts-mode-indent-style val) + (c-ts-mode-set-style val))))) (defun c-ts-indent-style-safep (style) "Non-nil if STYLE's value is safe for file-local variables." @@ -162,23 +159,13 @@ the list of RULEs doesn't need to contain the language symbol." :safe 'c-ts-indent-style-safep :group 'c) -(defun c-ts-mode--get-indent-style (mode) - "Helper function to set indentation style. -MODE is either `c' or `cpp'." - (let ((style - (if (functionp c-ts-mode-indent-style) - (funcall c-ts-mode-indent-style) - (alist-get c-ts-mode-indent-style (c-ts-mode--indent-styles mode))))) - `((,mode ,@style)))) - (defun c-ts-mode--prompt-for-style () "Prompt for an indent style and return the symbol for it." - (let ((mode (if (derived-mode-p 'c-ts-mode) 'c 'c++))) - (intern - (completing-read - "Style: " - (mapcar #'car (c-ts-mode--indent-styles mode)) - nil t nil nil "gnu")))) + (intern + (completing-read + "Style: " + '(gnu k&r linux bsd) + nil t nil nil "gnu"))) (defun c-ts-mode-set-global-style (style) "Set the indent style of C/C++ modes globally to STYLE. @@ -199,9 +186,11 @@ To set the default indent style globally, use (user-error "The current buffer is not in `c-ts-mode' nor `c++-ts-mode'") (setq-local c-ts-mode-indent-style style) (setq treesit-simple-indent-rules - (treesit--indent-rules-optimize - (c-ts-mode--get-indent-style - (if (derived-mode-p 'c-ts-mode) 'c 'cpp)))))) + (if (functionp style) + (funcall style) + (c-ts-mode--simple-indent-rules + (if (derived-mode-p 'c-ts-mode) 'c 'c++) + style))))) (defcustom c-ts-mode-emacs-sources-support t "Whether to enable Emacs source-specific C features. @@ -215,6 +204,17 @@ again." :safe 'booleanp :group 'c) +(defcustom c-ts-mode-enable-doxygen nil + "Enable doxygen syntax highlighting. +If Non-nil, enable doxygen based font lock for comment blocks. +This needs to be set before enabling `c-ts-mode'; if you change +the value after enabling `c-ts-mode', toggle the mode off and on +again." + :version "31.1" + :type 'boolean + :safe 'booleanp + :group 'c) + ;;; Syntax table (defvar c-ts-mode--syntax-table @@ -274,7 +274,7 @@ one step according to the great-grand-parent indent level. The reason there is a difference between grand-parent and great-grand-parent here is that the node containing the newline is actually the parent of point at the moment of indentation." - (when-let ((node (treesit-node-on (point) (point)))) + (when-let* ((node (treesit-node-on (point) (point)))) (if (string-equal "translation_unit" (treesit-node-type (treesit-node-parent @@ -282,13 +282,13 @@ is actually the parent of point at the moment of indentation." 0 c-ts-mode-indent-offset))) -(defun c-ts-mode--anchor-prev-sibling (node parent bol &rest _) +(defun c-ts-mode--prev-sibling (node parent bol &rest _) "Return the start of the previous named sibling of NODE. -This anchor handles the special case where the previous sibling -is a labeled_statement; in that case, return the child of the -labeled statement instead. (Actually, recursively go down until -the node isn't a labeled_statement.) E.g., +This anchor handles the special case where the previous sibling is a +labeled_statement or preproc directive; in that case, return the child +of the labeled statement instead. (Actually, recursively go down until +the node isn't a labeled_statement or preproc.) E.g., label: int x = 1; @@ -302,12 +302,12 @@ doesn't have a child. PARENT is NODE's parent, BOL is the beginning of non-whitespace characters of the current line." - (when-let ((prev-sibling - (or (treesit-node-prev-sibling node t) - (treesit-node-prev-sibling - (treesit-node-first-child-for-pos parent bol) t) - (treesit-node-child parent -1 t))) - (continue t)) + (when-let* ((prev-sibling + (or (treesit-node-prev-sibling node t) + (treesit-node-prev-sibling + (treesit-node-first-child-for-pos parent bol) t) + (treesit-node-child parent -1 t))) + (continue t)) (save-excursion (while (and prev-sibling continue) (pcase (treesit-node-type prev-sibling) @@ -341,8 +341,8 @@ characters of the current line." ;; prev-sibling doesn't have a child. (treesit-node-start prev-sibling))) -(defun c-ts-mode--standalone-parent-skip-preproc (_n parent &rest _) - "Like the standalone-parent anchor but skips preproc nodes. +(defun c-ts-mode--standalone-parent (_n parent &rest _) + "Like the standalone-parent anchor but skips preproc nodes and labels. PARENT is the parent of the current node." (save-excursion (treesit-node-start @@ -351,65 +351,133 @@ PARENT is the parent of the current node." ;; nil. parent (lambda (node) (and node - (not (string-search "preproc" (treesit-node-type node))) + (not (treesit-node-match-p + node (rx (or "preproc" "labeled_statement")))) (progn (goto-char (treesit-node-start node)) (looking-back (rx bol (* whitespace)) (line-beginning-position))))) t)))) -(defun c-ts-mode--standalone-grandparent (_node parent bol &rest args) - "Like the standalone-parent anchor but pass it the grandparent. -PARENT is NODE's parent, BOL is the beginning of non-whitespace -characters of the current line." - (apply (alist-get 'standalone-parent treesit-simple-indent-presets) - parent (treesit-node-parent parent) bol args)) - -(defun c-ts-mode--else-heuristic (node parent bol &rest _) - "Heuristic matcher for when \"else\" is followed by a closing bracket. -PARENT is NODE's parent, BOL is the beginning of non-whitespace -characters of the current line." - (and (null node) - (save-excursion - (forward-line -1) - (looking-at (rx (* whitespace) "else" (* whitespace) eol))) - (let ((next-node (treesit-node-first-child-for-pos parent bol))) - (equal (treesit-node-type next-node) "}")))) - -(defun c-ts-mode--first-sibling (node parent &rest _) - "Matches when NODE is the \"first sibling\". -\"First sibling\" is defined as: the first child node of PARENT -such that it's on its own line. NODE is the node to match and -PARENT is its parent." - (let ((prev-sibling (treesit-node-prev-sibling node t))) - (or (null prev-sibling) - (save-excursion - (goto-char (treesit-node-start prev-sibling)) - (<= (line-beginning-position) - (treesit-node-start parent) - (line-end-position)))))) - -(defun c-ts-mode--indent-styles (mode) - "Indent rules supported by `c-ts-mode'. -MODE is either `c' or `cpp'." - (let ((common - `((c-ts-mode--for-each-tail-body-matcher prev-line c-ts-mode-indent-offset) - ;; If the user types "else" and hits RET, they expect point - ;; on the empty line to be indented; this rule does that. - ;; This heuristic is intentionally very specific because - ;; more general heuristic is very error-prone, see - ;; discussion in bug#67417. - (c-ts-mode--else-heuristic prev-line c-ts-mode-indent-offset) - +(defun c-ts-mode--for-loop-indent-rule (node parent &rest _) + "Indentation rule for the for-loop. + +NODE and PARENT as usual." + (when (treesit-node-match-p parent "for_statement") + (pcase (treesit-node-field-name node) + ("initializer" + ;; Anchor is the opening paren. + (cons (treesit-node-start (treesit-node-child parent 1)) 1)) + ((or "condition" "update") + (cons (treesit-node-start (treesit-node-prev-sibling node 'named)) + 0)) + ("body" + (cons (c-ts-common--standalone-parent parent) + c-ts-mode-indent-offset)) + (_ (if (treesit-node-match-p node ")") + ;; Anchor is the opening paren. + (cons (treesit-node-start (treesit-node-child parent 1)) 0) + nil))))) + +(defvar c-ts-mode--preproc-indent-rules + `(((node-is "preproc") column-0 0) + ((node-is "#endif") column-0 0) + ((match "preproc_call" "compound_statement") column-0 0) + ((prev-line-is "#endif") c-ts-mode--prev-sibling 0) + ;; Top-level things under a preproc directive. Note that + ;; "preproc" matches more than one type: it matches + ;; preproc_if, preproc_elif, etc. + ((n-p-gp nil "preproc" "translation_unit") column-0 0) + ;; Indent rule for an empty line after a preproc directive. + ((and no-node (parent-is ,(rx (or "\n" "preproc")))) + c-ts-mode--standalone-parent c-ts-mode--preproc-offset) + ;; Statement under a preproc directive, the first statement + ;; indents against parent, the rest statements indent to + ;; their prev-sibling. + ((match nil ,(rx "preproc_" (or "if" "elif")) nil 3 3) + c-ts-mode--standalone-parent c-ts-mode-indent-offset) + ((match nil "preproc_ifdef" nil 2 2) + c-ts-mode--standalone-parent c-ts-mode-indent-offset) + ((match nil "preproc_else" nil 1 1) + c-ts-mode--standalone-parent c-ts-mode-indent-offset) + ((parent-is "preproc") c-ts-mode--prev-sibling 0)) + "Indent rules for preprocessors.") + +(defun c-ts-mode--macro-heuristic-rules (node parent &rest _) + "Heuristic indent rule for control flow macros. + +Eg, + + #define IOTA(var, n) for (int var = 0; var != (n); ++var) + + int main() + { + IOTA (v, 10) { + printf(\"%d \", v); <-- Here we want to indent + counter++; <-- Use baseline rule to align + } to prev sibling + +Checked by \"Compound Statement after code (Bug#74507)\" test. + +NODE and PARENT are the same as other indent rules." + (when (and (treesit-node-match-p parent "compound_statement") + (treesit-node-match-p (treesit-node-prev-sibling parent) + "expression_statement")) + (let ((parent-bol + (lambda () (save-excursion + (goto-char (treesit-node-start parent)) + (back-to-indentation) + (point))))) + (cond + ;; Closing brace. + ((treesit-node-match-p node "}") + (cons (funcall parent-bol) 0)) + ;; First sibling. + ((treesit-node-eq (treesit-node-child parent 0 'named) node) + (cons (funcall parent-bol) + c-ts-mode-indent-offset)))))) + +(defun c-ts-mode--simple-indent-rules (mode style) + "Return the indent rules for MODE and STYLE. + +The returned value can be set to `treesit-simple-indent-rules'. +MODE can be `c' or `cpp'. STYLE can be `gnu', `k&r', `linux', `bsd'." + (let ((rules + `((c-ts-mode--for-each-tail-body-matcher + prev-line c-ts-mode-indent-offset) + + ;; Misc overrides. ((parent-is "translation_unit") column-0 0) - ((query "(ERROR (ERROR)) @indent") column-0 0) - ((node-is ")") parent 1) - ((node-is "]") parent-bol 0) - ((node-is "else") parent-bol 0) - ((node-is "case") parent-bol 0) - ((node-is "preproc_arg") no-indent) + ((node-is ,(rx (or "else" "case"))) standalone-parent 0) + ;; Align the while keyword to the do keyword. + ((match "while" "do_statement") parent 0) + c-ts-mode--parenthesized-expression-indent-rule + ;; Thanks to tree-sitter-c's weird for-loop grammar, we can't + ;; use the baseline indent rule for it. + c-ts-mode--for-loop-indent-rule + c-ts-mode--label-indent-rules + ,@c-ts-mode--preproc-indent-rules + c-ts-mode--macro-heuristic-rules + + ;; Make sure type and function definition components align and + ;; don't indent. Also takes care of GNU style opening braces. + ((parent-is ,(rx (or "function_definition" + "struct_specifier" + "enum_specifier" + "function_declarator" + "template_declaration"))) + parent 0) + ;; This is for the trailing-star stype: int * + ;; func() + ((match "function_declarator" nil "declarator") parent-bol 0) + ;; ((match nil "function_definition" "declarator") parent 0) + ;; ((match nil "struct_specifier" "name") parent 0) + ;; ((match nil "function_declarator" "parameters") parent 0) + ;; ((parent-is "template_declaration") parent 0) + ;; `c-ts-common-looking-at-star' has to come before ;; `c-ts-common-comment-2nd-line-matcher'. + ;; FIXME: consolidate into a single rule. ((and (parent-is "comment") c-ts-common-looking-at-star) c-ts-common-comment-start-after-first-star -1) (c-ts-common-comment-2nd-line-matcher @@ -417,136 +485,96 @@ MODE is either `c' or `cpp'." 1) ((parent-is "comment") prev-adaptive-prefix 0) - ;; Labels. - ((node-is "labeled_statement") standalone-parent 0) - ((parent-is "labeled_statement") - c-ts-mode--standalone-grandparent c-ts-mode-indent-offset) - ;; Preproc directives + ((node-is "preproc_arg") no-indent) ((node-is "preproc") column-0 0) ((node-is "#endif") column-0 0) - ((match "preproc_call" "compound_statement") column-0 0) - - ;; Top-level things under a preproc directive. Note that - ;; "preproc" matches more than one type: it matches - ;; preproc_if, preproc_elif, etc. - ((n-p-gp nil "preproc" "translation_unit") column-0 0) - ;; Indent rule for an empty line after a preproc directive. - ((and no-node (parent-is ,(rx (or "\n" "preproc")))) - c-ts-mode--standalone-parent-skip-preproc c-ts-mode--preproc-offset) - ;; Statement under a preproc directive, the first statement - ;; indents against parent, the rest statements indent to - ;; their prev-sibling. - ((match nil ,(rx "preproc_" (or "if" "elif")) nil 3 3) - c-ts-mode--standalone-parent-skip-preproc c-ts-mode-indent-offset) - ((match nil "preproc_ifdef" nil 2 2) - c-ts-mode--standalone-parent-skip-preproc c-ts-mode-indent-offset) - ((match nil "preproc_else" nil 1 1) - c-ts-mode--standalone-parent-skip-preproc c-ts-mode-indent-offset) - ((parent-is "preproc") c-ts-mode--anchor-prev-sibling 0) - - ((parent-is "function_definition") parent-bol 0) - ((parent-is "pointer_declarator") parent-bol 0) - ((parent-is ,(rx bos "declaration" eos)) parent-bol 0) - ((parent-is "conditional_expression") first-sibling 0) - ((parent-is "assignment_expression") parent-bol c-ts-mode-indent-offset) - ((parent-is "concatenated_string") first-sibling 0) - ((parent-is "comma_expression") first-sibling 0) - ((parent-is "init_declarator") parent-bol c-ts-mode-indent-offset) - ((parent-is "parenthesized_expression") first-sibling 1) - ((parent-is "argument_list") first-sibling 1) - ((parent-is "parameter_list") first-sibling 1) - ((parent-is "binary_expression") parent 0) - ((query "(for_statement initializer: (_) @indent)") parent-bol 5) - ((query "(for_statement condition: (_) @indent)") parent-bol 5) - ((query "(for_statement update: (_) @indent)") parent-bol 5) - ((query "(call_expression arguments: (_) @indent)") parent c-ts-mode-indent-offset) - ((parent-is "call_expression") parent 0) - ;; Closing bracket. This should be before initializer_list - ;; (and probably others) rule because that rule (and other - ;; similar rules) will match the closing bracket. (Bug#61398) - ((node-is "}") standalone-parent 0) - ,@(when (eq mode 'cpp) - '(((node-is "access_specifier") parent-bol 0) - ;; Indent the body of namespace definitions. - ((parent-is "declaration_list") parent-bol c-ts-mode-indent-offset) - ((parent-is "template_declaration") parent-bol 0))) - - - ;; int[5] a = { 0, 0, 0, 0 }; - ((match nil "initializer_list" nil 1 1) parent-bol c-ts-mode-indent-offset) - ((parent-is "initializer_list") c-ts-mode--anchor-prev-sibling 0) - ;; Statement in enum. - ((match nil "enumerator_list" nil 1 1) standalone-parent c-ts-mode-indent-offset) - ((parent-is "enumerator_list") c-ts-mode--anchor-prev-sibling 0) - ;; Statement in struct and union. - ((match nil "field_declaration_list" nil 1 1) standalone-parent c-ts-mode-indent-offset) - ((parent-is "field_declaration_list") c-ts-mode--anchor-prev-sibling 0) - - ;; Statement in {} blocks. - ((or (and (parent-is "compound_statement") - ;; If the previous sibling(s) are not on their - ;; own line, indent as if this node is the first - ;; sibling (Bug#67357) - c-ts-mode--first-sibling) - (match null "compound_statement")) - standalone-parent c-ts-mode-indent-offset) - ((parent-is "compound_statement") c-ts-mode--anchor-prev-sibling 0) - ;; Opening bracket. - ((node-is "compound_statement") standalone-parent c-ts-mode-indent-offset) - ;; Bug#61291. - ((match "expression_statement" nil "body") standalone-parent c-ts-mode-indent-offset) - ;; These rules are for cases where the body is bracketless. - ;; Tested by the "Bracketless Simple Statement" test. - ((parent-is "if_statement") standalone-parent c-ts-mode-indent-offset) - ((parent-is "else_clause") standalone-parent c-ts-mode-indent-offset) - ((parent-is "for_statement") standalone-parent c-ts-mode-indent-offset) - ((match "while" "do_statement") parent-bol 0) ; (do_statement "while") - ((parent-is "while_statement") standalone-parent c-ts-mode-indent-offset) - ((parent-is "do_statement") standalone-parent c-ts-mode-indent-offset) - - ((parent-is "case_statement") standalone-parent c-ts-mode-indent-offset) - - ,@(when (eq mode 'cpp) - `(((node-is "field_initializer_list") parent-bol ,(* c-ts-mode-indent-offset 2))))))) - `((gnu - ;; Prepend rules to set highest priority - ((match "while" "do_statement") parent 0) - (c-ts-mode--top-level-label-matcher column-0 1) - ,@common) - (k&r ,@common) - (linux - ;; Reference: - ;; https://www.kernel.org/doc/html/latest/process/coding-style.html, - ;; and script/Lindent in Linux kernel repository. - ((node-is "labeled_statement") column-0 0) - ,@common) - (bsd - ((node-is "}") parent-bol 0) - ((node-is "labeled_statement") parent-bol c-ts-mode-indent-offset) - ((parent-is "labeled_statement") parent-bol c-ts-mode-indent-offset) - ((parent-is "compound_statement") parent-bol c-ts-mode-indent-offset) - ((match "compound_statement" "if_statement") standalone-parent 0) - ((match "compound_statement" "else_clause") standalone-parent 0) - ((match "compound_statement" "for_statement") standalone-parent 0) - ((match "compound_statement" "while_statement") standalone-parent 0) - ((match "compound_statement" "switch_statement") standalone-parent 0) - ((match "compound_statement" "case_statement") standalone-parent 0) - ((match "compound_statement" "do_statement") standalone-parent 0) - ,@common)))) - -(defun c-ts-mode--top-level-label-matcher (node parent &rest _) - "A matcher that matches a top-level label. -NODE should be a labeled_statement. PARENT is its parent." - (and (equal (treesit-node-type node) - "labeled_statement") - (equal "function_definition" - (treesit-node-type (treesit-node-parent parent))))) + + ;; C++ + ((node-is "access_specifier") parent-bol 0) + ((prev-line-is "access_specifier") + parent-bol c-ts-mode-indent-offset) + + c-ts-common-baseline-indent-rule))) + (setq rules + (pcase style + ('gnu rules) + ('k&r rules) + ('linux + ;; Reference: + ;; https://www.kernel.org/doc/html/latest/process/coding-style.html, + ;; and script/Lindent in Linux kernel repository. + `(((node-is "labeled_statement") column-0 0) + ,@rules)) + ('bsd + `(((match "compound_statement" "compound_statement") + standalone-parent c-ts-mode-indent-offset) + ((node-is "compound_statement") standalone-parent 0) + ,@rules)))) + (pcase mode + ('c `((c . ,rules))) + ('cpp `((cpp . ,rules)))))) + +(defun c-ts-mode--parenthesized-expression-indent-rule (_node parent &rest _) + "Indent rule that indents aprenthesized expression. + +Aligns the next line to the first sibling + +return (a && b + && c) + +return ( a && b + && c + ) + +Same for if/while statements + +if (a && b + && c) + +NODE, PARENT are the same as other indent rules." + (when (treesit-node-match-p + parent (rx (or "binary" "conditional") "_expression")) + (while (and parent + (not (treesit-node-match-p + parent "parenthesized_expression"))) + (setq parent (treesit-node-parent parent))) + (when parent + (cons (treesit-node-start + (treesit-node-child parent 0 'named)) + 0)))) + +(defun c-ts-mode--label-indent-rules (node parent bol &rest args) + "Handles indentation around labels. +NODE, PARENT, BOL, ARGS are as usual." + (cond + ;; Matches the top-level labels for GNU-style. + ((and (eq c-ts-mode-indent-style 'gnu) + (treesit-node-match-p node "labeled_statement") + (treesit-node-match-p (treesit-node-parent parent) + "function_definition")) + (cons (pos-bol) 1)) + ;; Indent the label itself. + ((treesit-node-match-p node "labeled_statement") + (cons (c-ts-mode--standalone-parent node parent bol args) + 0)) + ;; Indent the statement below the label. + ((treesit-node-match-p parent "labeled_statement") + (cons (c-ts-mode--standalone-parent node parent bol args) + c-ts-mode-indent-offset)) + ;; If previous sibling is a labeled_statement, align to it's + ;; children, which is the previous statement. + ((and (not (treesit-node-match-p node "}")) + (treesit-node-match-p (treesit-node-prev-sibling node) + "labeled_statement")) + (cons (c-ts-mode--prev-sibling node parent bol args) + 0)) + (t nil))) ;;; Font-lock (defvar c-ts-mode--feature-list - '(( comment definition) + '(( comment document definition) ( keyword preprocessor string type) ( assignment constant escape-sequence label literal) ( bracket delimiter error function operator property variable)) @@ -598,6 +626,10 @@ MODE is either `c' or `cpp'." "LIVE_BUFFER" "FRAME")) "A regexp matching all the variants of the FOR_EACH_* macro.") +(defvar c-ts-mode--doxygen-comment-regex + (rx (| "/**" "/*!" "//!" "///")) + "A regexp that matches all doxygen comment styles.") + (defun c-ts-mode--test-virtual-named-p () "Return t if the virtual keyword is a namded node, nil otherwise." (ignore-errors @@ -956,9 +988,14 @@ Return nil if NODE is not a defun node or doesn't have a name." (defun c-ts-mode--outline-predicate (node) "Match outlines on lines with function names." - (or (and (equal (treesit-node-type node) "function_declarator") - (equal (treesit-node-type (treesit-node-parent node)) - "function_definition")) + (or (when-let* ((decl (treesit-node-child-by-field-name + (treesit-node-parent node) "declarator")) + (node-pos (treesit-node-start node)) + (decl-pos (treesit-node-start decl)) + (eol (save-excursion (goto-char node-pos) (line-end-position)))) + (and (equal (treesit-node-type decl) "function_declarator") + (<= node-pos decl-pos) + (< decl-pos eol))) ;; DEFUNs in Emacs sources. (and c-ts-mode-emacs-sources-support (c-ts-mode--emacs-defun-p node)))) @@ -1086,8 +1123,8 @@ is required, not just the declaration part for DEFUN." `treesit-defun-type-regexp' defines what constructs to indent." (interactive "*") - (when-let ((orig-point (point-marker)) - (range (c-ts-mode--emacs-defun-at-point t))) + (when-let* ((orig-point (point-marker)) + (range (c-ts-mode--emacs-defun-at-point t))) (indent-region (car range) (cdr range)) (goto-char orig-point))) @@ -1334,33 +1371,50 @@ in your init files." (setq-local treesit-primary-parser (treesit-parser-create 'c nil nil 'for-each))) - (treesit-parser-create 'c) - ;; Comments. - (setq-local comment-start "/* ") - (setq-local comment-end " */") - ;; Indent. - (setq-local treesit-simple-indent-rules - (c-ts-mode--get-indent-style 'c)) - ;; Font-lock. - (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'c)) - ;; Navigation. - ;; - ;; Nodes like struct/enum/union_specifier can appear in - ;; function_definitions, so we need to find the top-level node. - (setq-local treesit-defun-tactic 'top-level) - (treesit-major-mode-setup) - - ;; Emacs source support: handle DEFUN and FOR_EACH_* gracefully. - (when c-ts-mode-emacs-sources-support - (setq-local add-log-current-defun-function - #'c-ts-mode--emacs-current-defun-name) - - (setq-local treesit-range-settings - (treesit-range-rules 'c-ts-mode--emacs-set-ranges)) - - (setq-local treesit-language-at-point-function - (lambda (_pos) 'c)) - (treesit-font-lock-recompute-features '(emacs-devel))))) + (let ((primary-parser (treesit-parser-create 'c))) + ;; Comments. + (setq-local comment-start "/* ") + (setq-local comment-end " */") + ;; Indent. + (setq-local treesit-simple-indent-rules + (c-ts-mode--simple-indent-rules + 'c c-ts-mode-indent-style)) + ;; (setq-local treesit-simple-indent-rules + ;; `((c . ,(alist-get 'gnu (c-ts-mode--indent-styles 'c))))) + ;; Font-lock. + (setq-local treesit-font-lock-settings + (c-ts-mode--font-lock-settings 'c)) + ;; Navigation. + (setq-local treesit-defun-tactic 'top-level) + (treesit-major-mode-setup) + + ;; Emacs source support: handle DEFUN and FOR_EACH_* gracefully. + (when c-ts-mode-emacs-sources-support + (setq-local add-log-current-defun-function + #'c-ts-mode--emacs-current-defun-name) + + (setq-local treesit-range-settings + (treesit-range-rules 'c-ts-mode--emacs-set-ranges)) + + (setq-local treesit-language-at-point-function + (lambda (_pos) 'c)) + (treesit-font-lock-recompute-features '(emacs-devel))) + + ;; Inject doxygen parser for comment. + (when (and c-ts-mode-enable-doxygen (treesit-ready-p 'doxygen t)) + (setq-local treesit-primary-parser primary-parser) + (setq-local treesit-font-lock-settings + (append + treesit-font-lock-settings + c-ts-mode-doxygen-comment-font-lock-settings)) + (setq-local treesit-range-settings + (treesit-range-rules + :embed 'doxygen + :host 'c + :local t + `(((comment) @cap + (:match + ,c-ts-mode--doxygen-comment-regex @cap))))))))) (derived-mode-add-parents 'c-ts-mode '(c-mode)) @@ -1388,24 +1442,41 @@ recommended to enable `electric-pair-mode' with this mode." :after-hook (c-ts-mode-set-modeline) (when (treesit-ready-p 'cpp) - - (treesit-parser-create 'cpp) - - ;; Syntax. - (setq-local syntax-propertize-function - #'c-ts-mode--syntax-propertize) - - ;; Indent. - (setq-local treesit-simple-indent-rules - (c-ts-mode--get-indent-style 'cpp)) - - ;; Font-lock. - (setq-local treesit-font-lock-settings (c-ts-mode--font-lock-settings 'cpp)) - (treesit-major-mode-setup) - - (when c-ts-mode-emacs-sources-support - (setq-local add-log-current-defun-function - #'c-ts-mode--emacs-current-defun-name)))) + (let ((primary-parser (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--simple-indent-rules + 'cpp c-ts-mode-indent-style)) + + ;; Font-lock. + (setq-local treesit-font-lock-settings + (c-ts-mode--font-lock-settings 'cpp)) + (treesit-major-mode-setup) + + (when c-ts-mode-emacs-sources-support + (setq-local add-log-current-defun-function + #'c-ts-mode--emacs-current-defun-name)) + + ;; Inject doxygen parser for comment. + (when (and c-ts-mode-enable-doxygen (treesit-ready-p 'doxygen t)) + (setq-local treesit-primary-parser primary-parser) + (setq-local treesit-font-lock-settings + (append + treesit-font-lock-settings + c-ts-mode-doxygen-comment-font-lock-settings)) + (setq-local treesit-range-settings + (treesit-range-rules + :embed 'doxygen + :host 'cpp + :local t + `(((comment) @cap + (:match + ,c-ts-mode--doxygen-comment-regex @cap))))))))) (derived-mode-add-parents 'c++-ts-mode '(c++-mode)) @@ -1505,6 +1576,9 @@ the code is C or C++, and based on that chooses whether to enable (assq-delete-all 'c-or-c++-mode major-mode-remap-defaults)) (add-to-list 'major-mode-remap-defaults '(c-or-c++-mode . c-or-c++-ts-mode))) +(when (and c-ts-mode-enable-doxygen (not (treesit-ready-p 'doxygen t))) + (message "Doxygen syntax highlighting can't be enabled, please install the language grammar.")) + (provide 'c-ts-mode) (provide 'c++-ts-mode) diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index fbbb81b6f10..f2edf6f5f06 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -91,7 +91,10 @@ Works with: topmost-intro-cont." (c-backward-syntactic-ws (c-langelem-pos langelem)) (if (and (memq (char-before) '(?} ?,)) (not (and c-overloadable-operators-regexp - (c-after-special-operator-id)))) + (c-after-special-operator-id))) + (or (not (eq (char-before) ?})) + (not (eq (cdr-safe (c-in-requires-or-at-end-of-clause)) + t)))) c-basic-offset)))) (defun c-lineup-gnu-DEFUN-intro-cont (langelem) @@ -301,7 +304,7 @@ Works with: arglist-cont, arglist-cont-nonempty." "Line up a line to just after the open paren of the surrounding paren or brace block. -Works with: defun-block-intro, brace-list-intro, +Works with: defun-block-intro, brace-list-intro, enum-intro statement-block-intro, statement-case-intro, arglist-intro." (save-excursion (beginning-of-line) @@ -324,7 +327,8 @@ as the open parenthesis of the argument list, the indentation is of this \"DWIM\" measure. Works with: Almost all symbols, but are typically most useful on -arglist-close, brace-list-close, arglist-cont and arglist-cont-nonempty." +arglist-close, brace-list-close, enum-close, arglist-cont and +arglist-cont-nonempty." (save-excursion (if (memq (c-langelem-sym langelem) '(arglist-cont-nonempty arglist-close)) @@ -1110,9 +1114,9 @@ In the first case the indentation is kept unchanged, in the second `c-basic-offset' is added. Works with: defun-close, defun-block-intro, inline-close, block-close, -brace-list-close, brace-list-intro, statement-block-intro, -arglist-intro, arglist-cont-nonempty, arglist-close, and all in* -symbols, e.g. inclass and inextern-lang." +brace-list-close, brace-list-intro, enum-close, enum-intro, +statement-block-intro, arglist-intro, arglist-cont-nonempty, +arglist-close, and all in* symbols, e.g. inclass and inextern-lang." (save-excursion (beginning-of-line) (if (and (c-go-up-list-backward) @@ -1146,8 +1150,8 @@ anchor position is at an open paren character. In that case, it instead indents relative to the surrounding block just like `c-lineup-whitesmith-in-block'. -Works with: brace-list-entry, brace-entry-open, statement, -arglist-cont." +Works with: brace-list-entry, brace-entry-open, enum-entry, +statement, arglist-cont." (save-excursion (goto-char (c-langelem-pos langelem)) (when (looking-at "\\s(") diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index 4b8cb0eff47..b71442c4751 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -761,14 +761,14 @@ (c-put-string-fence end)) ((eq (char-after beg) ?/) ; Properly bracketed regexp (c-put-char-property beg 'syntax-table '(7)) ; (7) = "string" - (c-put-char-property end 'syntax-table '(7))) - (t)) ; Properly bracketed string: Nothing to do. + (c-put-syntax-table-trim-caches end '(7))) + (t)) ; Properly bracketed string: Nothing to do. ;; Now change the properties of any escaped "s in the string to punctuation. (save-excursion (goto-char (1+ beg)) (or (eobp) - (while (search-forward "\"" end t) - (c-put-char-property (1- (point)) 'syntax-table '(1)))))) + (while (search-forward "\"" end t) + (c-put-syntax-table-trim-caches (1- (point)) '(1)))))) (defun c-awk-syntax-tablify-string () ;; Point is at the opening " or _" of a string. Set the syntax-table @@ -861,7 +861,7 @@ (let (anchor (anchor-state-/div nil)) ; t means a following / would be a div sign. (c-awk-beginning-of-logical-line) ; ACM 2002/7/21. This is probably redundant. - (c-clear-char-properties (point) lim 'syntax-table) + (c-clear-syntax-table-properties-trim-caches (point) lim) ;; Once round the next loop for each string, regexp, or div sign (while (progn ;; Skip any "harmless" lines before the next tricky one. @@ -1011,9 +1011,11 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\ ;; Do the same (almost) with ;; (regexp-opt '("/inet/tcp/lport/rhost/rport" "/inet/udp/lport/rhost/rport" ;; "/inet/raw/lport/rhost/rport") 'words) + ;; , replacing "inet" with "inet[46]?" + ;; , replacing "lport", "rhost", and "rport" with "[[:alnum:]]+". ;; This cannot be combined with the above pattern, because the match number ;; for the (optional) closing \" would then exceed 9. - '("\\(\"/inet/\\(\\(raw\\|\\(tc\\|ud\\)p\\)/lport/rhost/rport\\)\\)\\>\ + '("\\(\"/inet[46]?/\\(\\(raw\\|\\(tc\\|ud\\)p\\)/[[:alnum:]]+/[[:alnum:]]+/[[:alnum:]]+\\)\\)\\>\ \\(\\(\"\\)\\|\\([^\"/\n\r][^\"\n\r]*\\)?$\\)" (1 font-lock-variable-name-face t) (6 font-lock-variable-name-face t t)) @@ -1035,8 +1037,8 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\ '("adump" "and" "asort" "asorti" "atan2" "bindtextdomain" "close" "compl" "cos" "dcgettext" "dcngettext" "exp" "extension" "fflush" "gensub" "gsub" "index" "int" "isarray" "length" "log" "lshift" - "match" "mktime" "or" "patsplit" "print" "printf" "rand" "rshift" - "sin" "split" "sprintf" "sqrt" "srand" "stopme" + "match" "mkbool" "mktime" "or" "patsplit" "print" "printf" "rand" + "rshift" "sin" "split" "sprintf" "sqrt" "srand" "stopme" "strftime" "strtonum" "sub" "substr" "system" "systime" "tolower" "toupper" "typeof" "xor") t) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index e45ab76ec07..42dd6fffe53 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -1248,6 +1248,14 @@ MODE is either a mode symbol or a list of mode symbols." `((setq c-syntax-table-hwm (min c-syntax-table-hwm -pos-)))) (put-text-property -pos- (1+ -pos-) ',property ,value)))) +(defmacro c-put-syntax-table-trim-caches (pos value) + ;; Put a 'syntax-table property with VALUE at POS. Also invalidate four + ;; caches from the position POS. + (declare (debug t)) + `(let ((-pos- ,pos)) + (c-put-char-property -pos- 'syntax-table ,value) + (c-truncate-lit-pos/state-cache -pos-))) + (defmacro c-put-string-fence (pos) ;; Put the string-fence syntax-table text property at POS. ;; Since the character there cannot then count as syntactic whitespace, @@ -1333,6 +1341,14 @@ MODE is either a mode symbol or a list of mode symbols." ;; Emacs < 21. `(c-clear-char-property-fun ,pos ',property)))) +(defmacro c-clear-syntax-table-trim-caches (pos) + ;; Remove the 'syntax-table property at POS and invalidate the four caches + ;; from that position. + (declare (debug t)) + `(let ((-pos- ,pos)) + (c-clear-char-property -pos- 'syntax-table) + (c-truncate-lit-pos/state-cache -pos-))) + (defmacro c-min-property-position (from to property) ;; Return the first position in the range [FROM to) where the text property ;; PROPERTY is set, or `most-positive-fixnum' if there is no such position. @@ -1387,7 +1403,8 @@ MODE is either a mode symbol or a list of mode symbols." (c-use-extents ;; XEmacs `(map-extents (lambda (ext ignored) - (delete-extent ext)) + (delete-extent ext) + nil) ; To prevent exit from `map-extents'. nil ret -to- nil nil ',property)) ((and (fboundp 'syntax-ppss) (eq property 'syntax-table)) @@ -1402,6 +1419,15 @@ MODE is either a mode symbol or a list of mode symbols." ret) nil))) +(defmacro c-clear-syntax-table-properties-trim-caches (from to) + ;; Remove all occurrences of the 'syntax-table property in (FROM TO) and + ;; invalidate the four caches from the first position from which the + ;; property was removed, if any. + (declare (debug t)) + `(let ((first (c-clear-char-properties ,from ,to 'syntax-table))) + (when first + (c-truncate-lit-pos/state-cache first)))) + (defmacro c-clear-syn-tab-properties (from to) ;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text ;; properties between FROM and TO. @@ -1492,8 +1518,10 @@ point is then left undefined." "Remove all text-properties PROPERTY from the region (FROM, TO) which have the value VALUE, as tested by `equal'. These properties are assumed to be over individual characters, having -been put there by `c-put-char-property'. POINT remains unchanged." - (let ((place from) end-place) +been put there by `c-put-char-property'. POINT remains unchanged. +Return the position of the first removed property, if any, or nil." + (let ((place from) end-place + first) (while ; loop round occurrences of (PROPERTY VALUE) (progn (while ; loop round changes in PROPERTY till we find VALUE @@ -1506,25 +1534,51 @@ been put there by `c-put-char-property'. POINT remains unchanged." (setq c-syntax-table-hwm (min c-syntax-table-hwm place))) (setq end-place (c-next-single-property-change place property nil to)) (remove-text-properties place end-place (list property nil)) + (unless first (setq first place)) ;; Do we have to do anything with stickiness here? - (setq place end-place)))) + (setq place end-place)) + first)) (defmacro c-clear-char-property-with-value (from to property value) "Remove all text-properties PROPERTY from the region [FROM, TO) which have the value VALUE, as tested by `equal'. These properties are assumed to be over individual characters, having -been put there by `c-put-char-property'. POINT remains unchanged." +been put there by `c-put-char-property'. POINT remains unchanged. +Return the position of the first removed property, or nil." (declare (debug t)) (if c-use-extents ;; XEmacs - `(let ((-property- ,property)) + `(let ((-property- ,property) + (first (1+ (point-max)))) (map-extents (lambda (ext val) - (if (equal (extent-property ext -property-) val) - (delete-extent ext))) - nil ,from ,to ,value nil -property-)) - ;; GNU Emacs + ;; In the following, the test on the extent's property + ;; is probably redundant. See documentation of + ;; `map-extents'. NO it's NOT! This automatic check + ;; would require another argument to `map-extents', + ;; but the test would use `eq', not `equal', so it's + ;; no good. :-( + (when (equal (extent-property ext -property-) val) + (setq first (min first + (extent-start-position ext))) + (delete-extent ext)) + nil) + nil ,from ,to ,value nil -property-) + (and (<= first (point-max)) first)) + ;; Gnu Emacs `(c-clear-char-property-with-value-function ,from ,to ,property ,value))) +(defmacro c-clear-syntax-table-with-value-trim-caches (from to value) + "Remove all `syntax-table' text-properties with value VALUE from [FROM, TO) +and invalidate the four caches from the first position, if any, where a +property was removed. Return the position of the first property removed, +if any, else nil. POINT and the match data remain unchanged." + (declare (debug t)) + `(let ((first + (c-clear-char-property-with-value ,from ,to 'syntax-table ,value))) + (when first + (c-truncate-lit-pos/state-cache first)) + first)) + (defmacro c-search-forward-char-property-with-value-on-char (property value char &optional limit) "Search forward for a text-property PROPERTY having value VALUE on a @@ -1620,7 +1674,8 @@ property, or nil." (or first (progn (setq first place) (when (eq property 'syntax-table) - (setq c-syntax-table-hwm (min c-syntax-table-hwm place)))))) + (setq c-syntax-table-hwm + (min c-syntax-table-hwm place)))))) ;; Do we have to do anything with stickiness here? (setq place (1+ place))) first)) @@ -1639,26 +1694,46 @@ property, or nil." (-char- ,char) (first (1+ (point-max)))) (map-extents (lambda (ext val) - (when (and (equal (extent-property ext -property-) val) + ;; In the following, the test on the extent's property + ;; is probably redundant. See documentation of + ;; map-extents. NO! See + ;; `c-clear-char-property-with-value'. + (when (and (equal (extent-property ext -property-) + val) (eq (char-after (extent-start-position ext)) -char-)) (setq first (min first (extent-start-position ext))) - (delete-extent ext))) + (delete-extent ext)) + nil) nil ,from ,to ,value nil -property-) (and (<= first (point-max)) first)) - ;; GNU Emacs + ;; Gnu Emacs `(c-clear-char-property-with-value-on-char-function ,from ,to ,property ,value ,char))) +(defmacro c-clear-syntax-table-with-value-on-char-trim-caches + (from to value char) + "Remove all `syntax-table' properties with VALUE on CHAR in [FROM, TO), +as tested by `equal', and invalidate the four caches from the first position, +if any, where a property was removed. POINT and the match data remain +unchanged." + (declare (debug t)) + `(let ((first (c-clear-char-property-with-value-on-char + ,from ,to 'syntax-table ,value ,char))) + (when first + (c-truncate-lit-pos/state-cache first)))) + (defmacro c-put-char-properties-on-char (from to property value char) ;; This needs to be a macro because `property' passed to ;; `c-put-char-property' must be a constant. "Put the text property PROPERTY with value VALUE on characters -with value CHAR in the region [FROM to)." +with value CHAR in the region [FROM to). Return the position of the +first char changed, if any, else nil." (declare (debug t)) `(let ((skip-string (concat "^" (list ,char))) - (-to- ,to)) + (-to- ,to) + first) (save-excursion (goto-char ,from) (while (progn (skip-chars-forward skip-string -to-) @@ -1667,8 +1742,20 @@ with value CHAR in the region [FROM to)." (eq (eval property) 'syntax-table)) `((setq c-syntax-table-hwm (min c-syntax-table-hwm (point))))) (c-put-char-property (point) ,property ,value) - (forward-char))))) - + (when (not first) (setq first (point))) + (forward-char))) + first)) + +(defmacro c-put-syntax-table-properties-on-char-trim-caches + (from to value char) + "Put a `syntax-table' text property with value VALUE on all characters +with value CHAR in the region [FROM to), and invalidate the four caches +from the first position, if any, where a property was put." + (declare (debug t)) + `(let ((first (c-put-char-properties-on-char + ,from ,to 'syntax-table ,value ,char))) + (when first + (c-truncate-lit-pos/state-cache first)))) ;; Miscellaneous macro(s) (defvar c-string-fences-set-flag nil) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 4c319a78e01..d880cdabaaa 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -164,6 +164,7 @@ (cc-require-when-compile 'cc-langs) (cc-require 'cc-vars) +(defvar c-state-cache-invalid-pos) (defvar c-doc-line-join-re) (defvar c-doc-bright-comment-start-re) (defvar c-doc-line-join-end-ch) @@ -2199,8 +2200,9 @@ comment at the start of cc-engine.el for more info." (c-put-is-sws (1+ rung-pos) (1+ (point))) (c-put-in-sws rung-pos - (setq rung-pos (point) - last-put-in-sws-pos rung-pos))) + (point)) + (setq rung-pos (point) + last-put-in-sws-pos rung-pos)) ;; Now move over any comments (x)or a CPP construct. (setq simple-ws-end (point)) @@ -3210,6 +3212,7 @@ comment at the start of cc-engine.el for more info." (c-full-put-near-cache-entry here s nil)) (list s)))))))) + (defsubst c-truncate-lit-pos-cache (pos) ;; Truncate the upper bound of each of the three caches to POS, if it is ;; higher than that position. @@ -3217,6 +3220,12 @@ comment at the start of cc-engine.el for more info." c-semi-near-cache-limit (min c-semi-near-cache-limit pos) c-full-near-cache-limit (min c-full-near-cache-limit pos))) +(defsubst c-truncate-lit-pos/state-cache (pos) + ;; Truncate the upper bound of each of the four caches to POS, if it is + ;; higher than that position. + (c-truncate-lit-pos-cache pos) + (setq c-state-cache-invalid-pos (min c-state-cache-invalid-pos pos))) + (defun c-foreign-truncate-lit-pos-cache (beg _end) "Truncate CC Mode's literal cache. @@ -3266,7 +3275,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and ;; subparen that is closed before the last recorded position. ;; ;; The exact position is chosen to try to be close to yet earlier than -;; the position where `c-state-cache' will be called next. Right now +;; the position where `c-parse-state' will be called next. Right now ;; the heuristic is to set it to the position after the last found ;; closing paren (of any type) before the line on which ;; `c-parse-state' was called. That is chosen primarily to work well @@ -3282,6 +3291,19 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and ;; the middle of the desert, as long as it is not within a brace pair ;; recorded in `c-state-cache' or a paren/bracket pair. +(defvar c-state-cache-invalid-pos 1) +(make-variable-buffer-local 'c-state-cache-invalid-pos) +;; This variable is always a number, and is typically eq to +;; `c-state-cache-good-pos'. +;; +;; Its purpose is to record the position that `c-invalidate-state-cache' needs +;; to trim `c-state-cache' to. +;; +;; When a `syntax-table' text property has been +;; modified at a position before `c-state-cache-good-pos', it gets set to +;; the lowest such position. When that variable is nil, +;; `c-state-cache-invalid-pos' is set to `c-state-point-min-literal'. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; We maintain a simple cache of positions which aren't in a literal, so as to ;; speed up testing for non-literality. @@ -3747,6 +3769,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (c-state-mark-point-min-literal) (setq c-state-cache nil c-state-cache-good-pos c-state-min-scan-pos + c-state-cache-invalid-pos c-state-cache-good-pos c-state-brace-pair-desert nil)) ;; point-min has MOVED FORWARD. @@ -3770,7 +3793,8 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and ; inside a recorded ; brace pair. (setq c-state-cache nil - c-state-cache-good-pos c-state-min-scan-pos) + c-state-cache-good-pos c-state-min-scan-pos + c-state-cache-invalid-pos c-state-cache-good-pos) ;; Do not alter the original `c-state-cache' structure, since there ;; may be a loop suspended which is looping through that structure. ;; This may have been the cause of bug #37910. @@ -3778,7 +3802,8 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (setcdr ptr nil) (setq c-state-cache (copy-sequence c-state-cache)) (setcdr ptr cdr-ptr)) - (setq c-state-cache-good-pos (1+ (c-state-cache-top-lparen)))) + (setq c-state-cache-good-pos (1+ (c-state-cache-top-lparen)) + c-state-cache-invalid-pos c-state-cache-good-pos)) ))) (setq c-state-point-min (point-min))) @@ -4302,6 +4327,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (defun c-state-cache-init () (setq c-state-cache nil c-state-cache-good-pos 1 + c-state-cache-invalid-pos 1 c-state-nonlit-pos-cache nil c-state-nonlit-pos-cache-limit 1 c-state-brace-pair-desert nil @@ -4338,8 +4364,9 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (defun c-invalidate-state-cache-1 (here) ;; Invalidate all info on `c-state-cache' that applies to the buffer at HERE - ;; or higher and set `c-state-cache-good-pos' accordingly. The cache is - ;; left in a consistent state. + ;; or higher and set `c-state-cache-good-pos' and + ;; `c-state-cache-invalid-pos' accordingly. The cache is left in a + ;; consistent state. ;; ;; This is much like `c-whack-state-after', but it never changes a paren ;; pair element into an open paren element. Doing that would mean that the @@ -4353,7 +4380,6 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and ;; HERE. (if (<= here c-state-nonlit-pos-cache-limit) (setq c-state-nonlit-pos-cache-limit (1- here))) - (c-truncate-lit-pos-cache here) (cond ;; `c-state-cache': @@ -4363,6 +4389,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (< here (c-state-get-min-scan-pos))) (setq c-state-cache nil c-state-cache-good-pos nil + c-state-cache-invalid-pos (c-state-get-min-scan-pos) c-state-min-scan-pos nil)) ;; Case 2: `here' is below `c-state-cache-good-pos', so we need to amend @@ -4377,7 +4404,9 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (setq c-state-cache-good-pos (if scan-forward-p (c-append-to-state-cache good-pos here) - good-pos))))) + good-pos) + c-state-cache-invalid-pos + (or c-state-cache-good-pos (c-state-get-min-scan-pos)))))) ;; The brace-pair desert marker: (when (car c-state-brace-pair-desert) @@ -4474,7 +4503,8 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (if (and bopl-state (< good-pos (- here c-state-cache-too-far))) (c-state-cache-lower-good-pos here here-bopl bopl-state) - good-pos))) + good-pos) + c-state-cache-invalid-pos c-state-cache-good-pos)) ((eq strategy 'backward) (setq res (c-remove-stale-state-cache-backwards here) @@ -4486,7 +4516,8 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (setq c-state-cache-good-pos (if scan-forward-p (c-append-to-state-cache good-pos here) - good-pos))) + good-pos) + c-state-cache-invalid-pos c-state-cache-good-pos)) (t ; (eq strategy 'IN-LIT) (setq c-state-cache nil @@ -4494,7 +4525,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and c-state-cache) -(defun c-invalidate-state-cache (here) +(defun c-invalidate-state-cache () ;; This is a wrapper over `c-invalidate-state-cache-1'. ;; ;; It suppresses the syntactic effect of the < and > (template) brackets and @@ -4504,9 +4535,9 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (if (eval-when-compile (memq 'category-properties c-emacs-features)) ;; Emacs (c-with-<->-as-parens-suppressed - (c-invalidate-state-cache-1 here)) + (c-invalidate-state-cache-1 c-state-cache-invalid-pos)) ;; XEmacs - (c-invalidate-state-cache-1 here))) + (c-invalidate-state-cache-1 c-state-cache-invalid-pos))) (defmacro c-state-maybe-marker (place marker) ;; If PLACE is non-nil, return a marker marking it, otherwise nil. @@ -4539,8 +4570,14 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (if (eval-when-compile (memq 'category-properties c-emacs-features)) ;; Emacs (c-with-<->-as-parens-suppressed + (when (< c-state-cache-invalid-pos + (or c-state-cache-good-pos (c-state-get-min-scan-pos))) + (c-invalidate-state-cache-1 c-state-cache-invalid-pos)) (c-parse-state-1)) ;; XEmacs + (when (< c-state-cache-invalid-pos + (or c-state-cache-good-pos (c-state-get-min-scan-pos))) + (c-invalidate-state-cache-1 c-state-cache-invalid-pos)) (c-parse-state-1)) (setq c-state-old-cpp-beg (c-state-maybe-marker here-cpp-beg c-state-old-cpp-beg-marker) @@ -4572,6 +4609,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (t val))))) '(c-state-cache c-state-cache-good-pos + c-state-cache-invalid-pos c-state-nonlit-pos-cache c-state-nonlit-pos-cache-limit c-state-brace-pair-desert @@ -4609,6 +4647,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (let ((here (point)) (min-point (point-min)) (res1 (c-real-parse-state)) res2) (let ((c-state-cache nil) (c-state-cache-good-pos 1) + (c-state-cache-invalid-pos 1) (c-state-nonlit-pos-cache nil) (c-state-nonlit-pos-cache-limit 1) (c-state-brace-pair-desert nil) @@ -6579,8 +6618,7 @@ comment at the start of cc-engine.el for more info." ;; we're just some syntactic whitespace further down we can ;; still use the cache to limit the skipping. (c-backward-syntactic-ws - (max (or c-find-decl-syntactic-pos (point-min)) - (- (point) 10000) (point-min)))) + (max (or c-find-decl-syntactic-pos (point-min)) (point-min)))) ;; If we hit `c-find-decl-syntactic-pos' and ;; `c-find-decl-match-pos' is set then we install the cached @@ -7000,9 +7038,9 @@ comment at the start of cc-engine.el for more info." (when (equal (c-get-char-property (1- (point)) 'syntax-table) c->-as-paren-syntax) ; should always be true. (c-unmark-<->-as-paren (1- (point))) - (c-truncate-lit-pos-cache (1- (point)))) + (c-truncate-lit-pos/state-cache (1- (point)))) (c-unmark-<->-as-paren pos) - (c-truncate-lit-pos-cache pos)))) + (c-truncate-lit-pos/state-cache pos)))) (defun c-clear->-pair-props (&optional pos) ;; POS (default point) is at a > character. If it is marked with @@ -7019,9 +7057,9 @@ comment at the start of cc-engine.el for more info." (when (equal (c-get-char-property (point) 'syntax-table) c-<-as-paren-syntax) ; should always be true. (c-unmark-<->-as-paren (point)) - (c-truncate-lit-pos-cache (point))) + (c-truncate-lit-pos/state-cache (point))) (c-unmark-<->-as-paren pos) - (c-truncate-lit-pos-cache pos)))) + (c-truncate-lit-pos/state-cache pos)))) (defun c-clear-<>-pair-props (&optional pos) ;; POS (default point) is at a < or > character. If it has an @@ -7055,7 +7093,7 @@ comment at the start of cc-engine.el for more info." c->-as-paren-syntax)) ; should always be true. (c-unmark-<->-as-paren (1- (point))) (c-unmark-<->-as-paren pos) - (c-truncate-lit-pos-cache pos) + (c-truncate-lit-pos/state-cache pos) (point))))) (defun c-clear->-pair-props-if-match-before (lim &optional pos) @@ -7076,7 +7114,7 @@ comment at the start of cc-engine.el for more info." (equal (c-get-char-property (point) 'syntax-table) c-<-as-paren-syntax)) ; should always be true. (c-unmark-<->-as-paren (point)) - (c-truncate-lit-pos-cache (point)) + (c-truncate-lit-pos/state-cache (point)) (c-unmark-<->-as-paren pos) (point))))) @@ -7195,7 +7233,8 @@ comment at the start of cc-engine.el for more info." (not (eq beg-literal-end end-literal-end)) (skip-chars-forward "\\\\") (eq (char-after) ?\n) - (not (zerop (skip-chars-backward "\\\\")))) + (not (zerop (skip-chars-backward "\\\\"))) + (< (point) end)) (setq swap-open-string-ends t) (if (c-get-char-property (1- beg-literal-end) 'syntax-table) @@ -7501,16 +7540,11 @@ multi-line strings (but not C++, for example)." ;; Remove any syntax-table text properties from the multi-line string ;; delimiters specified by STRING-DELIMS, the output of ;; `c-ml-string-delims-around-point'. - (let (found) - (if (setq found (c-clear-char-properties (caar string-delims) - (cadar string-delims) - 'syntax-table)) - (c-truncate-lit-pos-cache found)) + (c-clear-syntax-table-properties-trim-caches (caar string-delims) + (cadar string-delims)) (when (cdr string-delims) - (if (setq found (c-clear-char-properties (cadr string-delims) - (caddr string-delims) - 'syntax-table)) - (c-truncate-lit-pos-cache found))))) + (c-clear-syntax-table-properties-trim-caches (cadr string-delims) + (caddr string-delims)))) (defun c-get-ml-closer (open-delim) ;; Return the closer, a three element dotted list of the closer's start, its @@ -7944,7 +7978,7 @@ multi-line strings (but not C++, for example)." ((eq (nth 3 (car state)) t) (insert ?\") (c-put-string-fence end))) - (c-truncate-lit-pos-cache end) + (c-truncate-lit-pos/state-cache end) ;; ....ensure c-new-END extends right to the end of the about ;; to be un-stringed raw string.... (save-excursion @@ -7964,7 +7998,7 @@ multi-line strings (but not C++, for example)." ;; Remove the temporary string delimiter. (goto-char end) (delete-char 1) - (c-truncate-lit-pos-cache end)))) + (c-truncate-lit-pos/state-cache end)))) ;; Have we just created a new starting id? (goto-char beg) @@ -8014,7 +8048,7 @@ multi-line strings (but not C++, for example)." (> (point) beg))) (goto-char (caar c-old-1-beg-ml)) (setq c-new-BEG (min c-new-BEG (point))) - (c-truncate-lit-pos-cache (point)))) + (c-truncate-lit-pos/state-cache (point)))) (when (looking-at c-ml-string-opener-re) (goto-char (match-end 1)) @@ -8027,11 +8061,8 @@ multi-line strings (but not C++, for example)." (when (c-get-char-property (match-beginning 2) 'c-fl-syn-tab) (c-remove-string-fences (match-beginning 2))) (setq c-new-END (point-max)) - (c-clear-char-properties (caar (or c-old-beg-ml c-old-1-beg-ml)) - c-new-END - 'syntax-table) - (c-truncate-lit-pos-cache - (caar (or c-old-beg-ml c-old-1-beg-ml)))))) + (c-clear-syntax-table-properties-trim-caches + (caar (or c-old-beg-ml c-old-1-beg-ml)) c-new-END)))) ;; Have we disturbed the innards of an ml string, possibly by deleting "s? (when (and @@ -8057,10 +8088,9 @@ multi-line strings (but not C++, for example)." bound 'bound) (< (match-end 1) new-END-end-ml-string)) (setq c-new-END (max new-END-end-ml-string c-new-END)) - (c-clear-char-properties (caar c-old-beg-ml) c-new-END - 'syntax-table) - (setq c-new-BEG (min (caar c-old-beg-ml) c-new-BEG)) - (c-truncate-lit-pos-cache (caar c-old-beg-ml))))) + (c-clear-syntax-table-properties-trim-caches + (caar c-old-beg-ml) c-new-END) + (setq c-new-BEG (min (caar c-old-beg-ml) c-new-BEG))))) ;; Have we terminated an existing raw string by inserting or removing ;; text? @@ -8094,7 +8124,7 @@ multi-line strings (but not C++, for example)." (setq c-new-BEG (min (point) c-new-BEG) c-new-END (point-max)) (c-clear-syn-tab-properties (point) c-new-END) - (c-truncate-lit-pos-cache (point))))) + (c-truncate-lit-pos/state-cache (point))))) ;; Are there any raw strings in a newly created macro? (goto-char (c-point 'bol beg)) @@ -8148,8 +8178,7 @@ multi-line strings (but not C++, for example)." (cadr delim)) (< (point) (cadr delim))) (when (not (eq (point) (cddr delim))) - (c-put-char-property (point) 'syntax-table '(1)) - (c-truncate-lit-pos-cache (point))) + (c-put-syntax-table-trim-caches (point) '(1))) (forward-char)))) (defun c-propertize-ml-string-opener (delim bound) @@ -8182,14 +8211,12 @@ multi-line strings (but not C++, for example)." (while (progn (skip-syntax-forward c-ml-string-non-punc-skip-chars (car end-delim)) (< (point) (car end-delim))) - (c-put-char-property (point) 'syntax-table '(1)) ; punctuation - (c-truncate-lit-pos-cache (point)) + (c-put-syntax-table-trim-caches (point) '(1)) ; punctuation (forward-char)) (goto-char (cadr end-delim)) t) - (c-put-char-property (cddr delim) 'syntax-table '(1)) + (c-put-syntax-table-trim-caches (cddr delim) '(1)) (c-put-string-fence (1- (cadr delim))) - (c-truncate-lit-pos-cache (1- (cddr delim))) (when bound ;; In a CPP construct, we try to apply a generic-string ;; `syntax-table' text property to the last possible character in @@ -8219,10 +8246,9 @@ multi-line strings (but not C++, for example)." (if (match-beginning 10) (progn (c-put-string-fence (match-beginning 10)) - (c-truncate-lit-pos-cache (match-beginning 10))) - (c-put-char-property (match-beginning 5) 'syntax-table '(1)) - (c-put-string-fence (1+ (match-beginning 5))) - (c-truncate-lit-pos-cache (match-beginning 5)))) + (c-truncate-lit-pos/state-cache (match-beginning 10))) + (c-put-syntax-table-trim-caches (match-beginning 5) '(1)) + (c-put-string-fence (1+ (match-beginning 5))))) (goto-char bound)) nil)) @@ -8262,20 +8288,18 @@ multi-line strings (but not C++, for example)." '(15))) (goto-char (cdddr string-delims)) (when (c-safe (c-forward-sexp)) ; To '(15) at EOL. - (c-clear-char-property (1- (point)) 'syntax-table) - (c-truncate-lit-pos-cache (1- (point))))) + (c-clear-syntax-table-trim-caches (1- (point))))) ;; The '(15) in the closing delimiter will be cleared by the following. (c-depropertize-ml-string-delims string-delims) (let ((bound1 (if (cdr string-delims) (caddr string-delims) ; end of closing delimiter. bound)) - first s) - (if (and - bound1 - (setq first (c-clear-char-properties (cadar string-delims) bound1 - 'syntax-table))) - (c-truncate-lit-pos-cache first)) + s) + (if bound1 + (c-clear-syntax-table-properties-trim-caches + (cadar string-delims) bound1)) + (setq s (parse-partial-sexp (or c-neutralize-pos (caar string-delims)) (or bound1 (point-max)))) (cond @@ -8284,15 +8308,13 @@ multi-line strings (but not C++, for example)." (setq c-neutralize-pos (nth 8 s)) (setq c-neutralized-prop (c-get-char-property c-neutralize-pos 'syntax-table)) - (c-put-char-property c-neutralize-pos 'syntax-table '(1)) - (c-truncate-lit-pos-cache c-neutralize-pos)) + (c-put-syntax-table-trim-caches c-neutralize-pos '(1))) ((eq (nth 3 s) (char-after c-neutralize-pos)) ;; New unbalanced quote balances old one. (if c-neutralized-prop - (c-put-char-property c-neutralize-pos 'syntax-table - c-neutralized-prop) - (c-clear-char-property c-neutralize-pos 'syntax-table)) - (c-truncate-lit-pos-cache c-neutralize-pos) + (c-put-syntax-table-trim-caches c-neutralize-pos + c-neutralized-prop) + (c-clear-syntax-table-trim-caches c-neutralize-pos)) (setq c-neutralize-pos nil)) ;; New unbalanced quote doesn't balance old one. Nothing to do. ))) @@ -8351,10 +8373,8 @@ multi-line strings (but not C++, for example)." eom))))))) ; bound. (when c-neutralize-pos (if c-neutralized-prop - (c-put-char-property c-neutralize-pos 'syntax-table - c-neutralized-prop) - (c-clear-char-property c-neutralize-pos 'syntax-table)) - (c-truncate-lit-pos-cache c-neutralize-pos))) + (c-put-syntax-table-trim-caches c-neutralize-pos c-neutralized-prop) + (c-clear-syntax-table-trim-caches c-neutralize-pos)))) (defun c-before-after-change-check-c++-modules (beg end &optional _old_len) @@ -8668,7 +8688,7 @@ multi-line strings (but not C++, for example)." (c-forward-syntactic-ws) (c-forward-id-comma-list ref t t)) - ((and (c-keyword-member kwd-sym 'c-paren-any-kwds) + ((and (c-keyword-member kwd-sym 'c-paren-type-kwds) (eq (char-after) ?\()) ;; There's an open paren after a keyword in `c-paren-any-kwds'. @@ -8689,6 +8709,12 @@ multi-line strings (but not C++, for example)." (setq safe-pos (point))) (c-forward-syntactic-ws)) + ((c-keyword-member kwd-sym 'c-paren-nontype-kwds) + (when (and (eq (char-after) ?\() + (c-go-list-forward)) + (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))) @@ -8788,7 +8814,7 @@ multi-line strings (but not C++, for example)." (when c-parse-and-markup-<>-arglists (c-mark-<-as-paren (point)) (c-mark->-as-paren (match-beginning 1)) - (c-truncate-lit-pos-cache (point))) + (c-truncate-lit-pos/state-cache (point))) (goto-char (match-end 1)) t) nil)) @@ -8922,11 +8948,11 @@ multi-line strings (but not C++, for example)." (save-excursion (and (c-go-list-backward) (eq (char-after) ?<) - (c-truncate-lit-pos-cache (point)) + (c-truncate-lit-pos/state-cache (point)) (c-unmark-<->-as-paren (point))))) (c-mark-<-as-paren start) (c-mark->-as-paren (1- (point))) - (c-truncate-lit-pos-cache start)) + (c-truncate-lit-pos/state-cache start)) (setq res t) nil)) ; Exit the loop. @@ -9893,9 +9919,6 @@ point unchanged and return nil." ;; ;; Note that this function is incomplete, handling only those cases expected ;; to be common in a C++20 requires clause. - ;; - ;; Note also that (...) is not recognized as a primary expression if the - ;; next token is an open brace. (let ((here (point)) (c-restricted-<>-arglists t) (c-parse-and-markup-<>-arglists nil) @@ -9908,12 +9931,10 @@ point unchanged and return nil." ((eq (char-after) ?\() (and (c-go-list-forward (point) limit) (eq (char-before) ?\)) - (let ((after-paren (point))) - (c-forward-syntactic-ws limit) - (prog1 - (not (eq (char-after) ?{)) - (when stop-at-end - (goto-char after-paren)))))) + (progn + (unless stop-at-end + (c-forward-syntactic-ws limit)) + t))) ((c-forward-over-compound-identifier) (let ((after-id (point))) (c-forward-syntactic-ws limit) @@ -9932,9 +9953,7 @@ point unchanged and return nil." (c-forward-over-compound-identifier) (c-forward-syntactic-ws limit)))))) (goto-char after-id))) - ((and - (looking-at c-fun-name-substitute-key) ; "requires" - (not (eq (char-after (match-end 0)) ?_))) + ((looking-at c-fun-name-substitute-key) ; "requires" (goto-char (match-end 1)) (c-forward-syntactic-ws limit) (and @@ -10045,7 +10064,7 @@ point unchanged and return nil." (defun c-forward-declarator (&optional limit accept-anon not-top) ;; Assuming point is at the start of a declarator, move forward over it, ;; leaving point at the next token after it (e.g. a ) or a ; or a ,), or at - ;; end of buffer if there is no such token. + ;; LIMIT (or end of buffer) if that comes first. ;; ;; Return a list (ID-START ID-END BRACKETS-AFTER-ID GOT-INIT DECORATED ;; ARGLIST), where ID-START and ID-END are the bounds of the declarator's @@ -10178,9 +10197,6 @@ point unchanged and return nil." (c-safe (goto-char (scan-lists (point) 1 paren-depth))) (c-forward-syntactic-ws))) - (or (eq (point) (point-max)) ; No token after identifier. - (< (point) limit)) - ;; Skip over any trailing bit, such as "__attribute__". (progn (while (cond @@ -10189,9 +10205,7 @@ point unchanged and return nil." ((looking-at c-type-decl-suffix-key) (cond ((save-match-data - (and - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)))) + (looking-at c-requires-clause-key)) (c-forward-c++-requires-clause)) ((eq (char-after) ?\() (if (c-forward-decl-arglist not-top decorated limit) @@ -10648,10 +10662,8 @@ This function might do hidden buffer changes." (c-forward-keyword-clause 1) (when (and (c-major-mode-is 'c++-mode) (c-keyword-member kwd-sym 'c-<>-sexp-kwds) - (save-match-data - (and - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_))))) + (save-match-data ; Probably unnecessary (2024-09-20) + (looking-at c-requires-clause-key))) (c-forward-c++-requires-clause)) (setq kwd-clause-end (point)))) ((and c-opt-cpp-prefix @@ -11009,9 +11021,7 @@ This function might do hidden buffer changes." ((save-match-data (looking-at "\\s(")) (c-safe (c-forward-sexp 1) t)) ((save-match-data - (and - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)))) ; C++ requires + (looking-at c-requires-clause-key)) (c-forward-c++-requires-clause)) (t (goto-char (match-end 1)) t)) @@ -12687,18 +12697,18 @@ comment at the start of cc-engine.el for more info." (goto-char (setq kwd-start (match-beginning 0))) (and ;; Exclude cases where we matched what would ordinarily - ;; be a block declaration keyword, except where it's not + ;; be an enum declaration keyword, except where it's not ;; legal because it's part of a "compound keyword" like - ;; "enum class". Of course, if c-after-brace-list-key + ;; "enum class". Of course, if c-after-enum-list-key ;; is nil, we can skip the test. - (or (equal c-after-brace-list-key regexp-unmatchable) + (or (equal c-after-enum-list-key regexp-unmatchable) (save-match-data (save-excursion (not (and - (looking-at c-after-brace-list-key) + (looking-at c-after-enum-list-key) (= (c-backward-token-2 1 t) 0) - (looking-at c-brace-list-key)))))) + (looking-at c-enum-list-key)))))) (or ;; Found a keyword that can't be a type? (match-beginning 1) @@ -12877,7 +12887,7 @@ comment at the start of cc-engine.el for more info." (or (c-on-identifier) (progn (c-backward-token-2) - (looking-at c-brace-list-key))))) + (looking-at c-enum-list-key))))) (setq colon-pos (point)) (forward-char) (c-forward-syntactic-ws) @@ -12916,8 +12926,8 @@ comment at the start of cc-engine.el for more info." (looking-at c-postfix-decl-spec-key))) (setq before-identifier nil) t) - ((looking-at c-after-brace-list-key) t) - ((looking-at c-brace-list-key) nil) + ((looking-at c-after-enum-list-key) t) + ((looking-at c-enum-list-key) nil) ((eq (char-after) ?\() (and (eq (c-backward-token-2) 0) (or (looking-at c-decl-hangon-key) @@ -12929,9 +12939,19 @@ comment at the start of cc-engine.el for more info." (looking-at "\\s(")) t) (t nil)))) - (or (looking-at c-brace-list-key) + (or (looking-at c-enum-list-key) (progn (goto-char here) nil)))) +(defun c-at-enum-brace (&optional pos) + ;; Return the position of the enum-like keyword introducing the brace at POS + ;; (default point), or nil if we're not at such a construct. + (save-excursion + (if pos + (goto-char pos) + (setq pos (point))) + (and (c-backward-over-enum-header) + (point)))) + (defun c-laomib-loop (lim) ;; The "expensive" loop from `c-looking-at-or-maybe-in-bracelist'. Move ;; backwards over comma separated sexps as far as possible, but no further @@ -13036,13 +13056,10 @@ comment at the start of cc-engine.el for more info." ;; Return that element or nil if one wasn't found. (let ((ptr c-laomib-cache) elt) - (while - (and ptr - (setq elt (car ptr)) - (or (not (eq (car elt) containing-sexp)) - (< start (car (cddr elt))))) - (setq ptr (cdr ptr))) - (when ptr + (while (and (setq elt (assq containing-sexp ptr)) + (< start (car (cddr elt)))) + (setq ptr (cdr (memq elt ptr)))) + (when elt ;; Move the fetched `elt' to the front of the cache. (setq c-laomib-cache (delq elt c-laomib-cache)) (push elt c-laomib-cache) @@ -13056,46 +13073,24 @@ comment at the start of cc-engine.el for more info." (when lim (let (old-elt (new-elt (list lim start end result)) - big-ptr (cur-ptr c-laomib-cache) - togo (size 0) cur-size) + size) ;; If there is an elt which overlaps with the new element, remove it. - (while - (and cur-ptr - (setq old-elt (car cur-ptr)) - (or (not (eq (car old-elt) lim)) - (not (and (> start (car (cddr old-elt))) - (<= start (cadr old-elt)))))) - (setq cur-ptr (cdr cur-ptr))) + (while (and (setq old-elt (assq lim cur-ptr)) + (not (and (> start (car (cddr old-elt))) + (<= start (cadr old-elt))))) + (setq cur-ptr (cdr (memq old-elt cur-ptr)))) (when (and cur-ptr old-elt) (setq c-laomib-cache (delq old-elt c-laomib-cache))) - (while (>= (length c-laomib-cache) 4) - ;; We delete the least recently used elt which doesn't enclose START, - ;; or ... - (dolist (elt c-laomib-cache) - (if (or (<= start (cadr elt)) - (> start (car (cddr elt)))) - (setq togo elt))) - - ;; ... delete the least recently used elt which isn't the biggest. - (when (not togo) - (setq cur-ptr c-laomib-cache) - (while (cdr cur-ptr) - (setq cur-size (- (cadr (cadr cur-ptr)) - (car (cddr (cadr cur-ptr))))) - (when (> cur-size size) - (setq size cur-size - big-ptr cur-ptr)) - (setq cur-ptr (cdr cur-ptr))) - (setq togo (if (cddr big-ptr) - (car (last big-ptr)) - (car big-ptr)))) - - (setq c-laomib-cache (delq togo c-laomib-cache))) - - (push new-elt c-laomib-cache)))) + ;; Don't let the cache grow indefinitely. + (cond + ((fboundp 'ntake) ; >= Emacs 29.1 + (setq c-laomib-cache (ntake 49 c-laomib-cache))) + ((>= (setq size (length c-laomib-cache)) 50) + (setq c-laomib-cache (butlast c-laomib-cache (- size 49))))) + (push new-elt c-laomib-cache)))) (defun c-laomib-fix-elt (lwm elt paren-state) ;; Correct a c-laomib-cache entry ELT with respect to buffer changes, either @@ -13142,7 +13137,7 @@ comment at the start of cc-engine.el for more info." (setq c-laomib-cache (delq elt c-laomib-cache))))))) (defun c-looking-at-or-maybe-in-bracelist (&optional containing-sexp lim) - ;; Point is at an open brace. If this starts a brace list, return a list + ;; Point is at an open brace. If this starts a brace list, return a cons ;; whose car is the buffer position of the start of the construct which ;; introduces the list, and whose cdr is the symbol `in-paren' if the brace ;; is directly enclosed in a parenthesis form (i.e. an arglist), t if we @@ -13162,238 +13157,230 @@ comment at the start of cc-engine.el for more info." ;; ;; Here, "brace list" does not include the body of an enum. (save-excursion - (let ((start (point)) - (braceassignp 'dontknow) - inexpr-brace-list bufpos macro-start res pos after-type-id-pos - pos2 in-paren parens-before-brace - paren-state paren-pos) + (unless (and (c-major-mode-is 'c++-mode) + (c-backward-over-lambda-expression lim)) + (let ((start (point)) + (braceassignp 'dontknow) + inexpr-brace-list bufpos macro-start res pos after-type-id-pos + pos2 in-paren paren-state paren-pos) - (setq res - (or (progn (c-backward-syntactic-ws) - (c-back-over-compound-identifier)) - (c-backward-token-2 1 t lim))) - ;; Checks to do only on the first sexp before the brace. - ;; Have we a C++ initialization, without an "="? - (if (and (c-major-mode-is 'c++-mode) - (cond - ((and (or (not (memq res '(t 0))) - (eq (char-after) ?,)) - (setq paren-state (c-parse-state)) - (setq paren-pos (c-pull-open-brace paren-state)) - (eq (char-after paren-pos) ?\()) - (goto-char paren-pos) - (setq braceassignp 'c++-noassign - in-paren 'in-paren)) - ((looking-at c-pre-brace-non-bracelist-key) - (setq braceassignp nil)) - ((and - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_))) - (setq braceassignp nil)) - ((looking-at c-return-key)) - ((and (looking-at c-symbol-start) - (not (looking-at c-keywords-regexp))) - (if (save-excursion - (and (zerop (c-backward-token-2 1 t lim)) - (looking-at c-pre-id-bracelist-key))) - (setq braceassignp 'c++-noassign) - (setq after-type-id-pos (point)))) - ((eq (char-after) ?\() - (setq parens-before-brace t) - ;; Have we a requires with a parenthesis list? - (when (save-excursion - (and (zerop (c-backward-token-2 1 nil lim)) - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)))) - (setq braceassignp nil)) - nil) - (t nil)) - (save-excursion + (setq res + (or (progn (c-backward-syntactic-ws) + (c-back-over-compound-identifier)) + (c-backward-token-2 1 t lim))) + ;; Checks to do only on the first sexp before the brace. + ;; Have we a C++ initialization, without an "="? + (if (and (c-major-mode-is 'c++-mode) (cond - ((or (not (memq res '(t 0))) - (eq (char-after) ?,)) - (and (setq paren-state (c-parse-state)) + ((and (or (not (memq res '(t 0))) + (eq (char-after) ?,)) + (setq paren-state (c-parse-state)) (setq paren-pos (c-pull-open-brace paren-state)) - (eq (char-after paren-pos) ?\() - (setq in-paren 'in-paren) - (goto-char paren-pos))) - ((looking-at c-pre-brace-non-bracelist-key)) + (eq (char-after paren-pos) ?\()) + (goto-char paren-pos) + (setq braceassignp 'c++-noassign + in-paren 'in-paren)) + ((looking-at c-pre-brace-non-bracelist-key) + (setq braceassignp nil)) + ((looking-at c-fun-name-substitute-key) + (setq braceassignp nil)) ((looking-at c-return-key)) ((and (looking-at c-symbol-start) - (not (looking-at c-keywords-regexp)) - (save-excursion - (and (zerop (c-backward-token-2 1 t lim)) - (looking-at c-pre-id-bracelist-key))))) - (t (setq after-type-id-pos (point)) - nil)))) - (setq braceassignp 'c++-noassign)) - - (when (and c-opt-inexpr-brace-list-key - (eq (char-after) ?\[)) - ;; In Java, an initialization brace list may follow - ;; directly after "new Foo[]", so check for a "new" - ;; earlier. - (while (eq braceassignp 'dontknow) - (setq braceassignp - (cond ((/= (c-backward-token-2 1 t lim) 0) nil) - ((looking-at c-opt-inexpr-brace-list-key) - (setq inexpr-brace-list t) - t) - ((looking-at "\\sw\\|\\s_\\|[.[]") - ;; Carry on looking if this is an - ;; identifier (may contain "." in Java) - ;; or another "[]" sexp. - 'dontknow) - (t nil))))) + (not (looking-at c-keywords-regexp))) + (if (save-excursion + (and (zerop (c-backward-token-2 1 t lim)) + (looking-at c-pre-id-bracelist-key))) + (setq braceassignp 'c++-noassign) + (setq after-type-id-pos (point)))) + ((eq (char-after) ?\() + ;; Have we a requires with a parenthesis list? + (when (save-excursion + (and (zerop (c-backward-token-2 1 nil lim)) + (looking-at c-fun-name-substitute-key))) + (setq braceassignp nil)) + nil) + (t nil)) + (save-excursion + (cond + ((or (not (memq res '(t 0))) + (eq (char-after) ?,)) + (and (setq paren-state (c-parse-state)) + (setq paren-pos (c-pull-open-brace paren-state)) + (eq (char-after paren-pos) ?\() + (setq in-paren 'in-paren) + (goto-char paren-pos))) + ((looking-at c-pre-brace-non-bracelist-key)) + ((looking-at c-return-key)) + ((and (looking-at c-symbol-start) + (not (looking-at c-keywords-regexp)) + (save-excursion + (and (zerop (c-backward-token-2 1 t lim)) + (looking-at c-pre-id-bracelist-key))))) + (t (setq after-type-id-pos (point)) + nil)))) + (setq braceassignp 'c++-noassign)) + + (when (and c-opt-inexpr-brace-list-key + (eq (char-after) ?\[)) + ;; In Java, an initialization brace list may follow + ;; directly after "new Foo[]", so check for a "new" + ;; earlier. + (while (eq braceassignp 'dontknow) + (setq braceassignp + (cond ((/= (c-backward-token-2 1 t lim) 0) nil) + ((looking-at c-opt-inexpr-brace-list-key) + (setq inexpr-brace-list t) + t) + ((looking-at "\\sw\\|\\s_\\|[.[]") + ;; Carry on looking if this is an + ;; identifier (may contain "." in Java) + ;; or another "[]" sexp. + 'dontknow) + (t nil))))) - (setq pos (point)) - (cond - ((not braceassignp) - nil) - ((and after-type-id-pos - (goto-char after-type-id-pos) - (setq res (c-back-over-member-initializers)) - (goto-char res) - (eq (car (c-beginning-of-decl-1 lim)) 'same)) - (cons (point) nil)) ; Return value. - - ((and after-type-id-pos - (progn - (c-backward-syntactic-ws) - (eq (char-before) ?\())) - ;; Single identifier between '(' and '{'. We have a bracelist. - (cons after-type-id-pos 'in-paren)) + (setq pos (point)) + (cond + ((not braceassignp) + nil) + ((and after-type-id-pos + (goto-char after-type-id-pos) + (setq res (c-back-over-member-initializers)) + (goto-char res) + (eq (car (c-beginning-of-decl-1 lim)) 'same)) + (cons (point) nil)) ; Return value. - ;; Are we at the parens of a C++ lambda expression? - ((and parens-before-brace - (save-excursion - (and - (zerop (c-backward-token-2 1 t lim)) - (c-looking-at-c++-lambda-capture-list)))) - nil) ; a lambda expression isn't a brace list. + ((and after-type-id-pos + (progn + (c-backward-syntactic-ws) + (eq (char-before) ?\())) + ;; Single identifier between '(' and '{'. We have a bracelist. + (cons after-type-id-pos 'in-paren)) - (t - (goto-char pos) - (when (eq braceassignp 'dontknow) - (let* ((cache-entry (and containing-sexp - (c-laomib-get-cache containing-sexp pos))) - (lim2 (or (cadr cache-entry) lim)) - sub-bassign-p) - (if cache-entry - (cond - ((<= (point) (cadr cache-entry)) - ;; We're inside the region we've already scanned over, so - ;; just go to that scan's end position. - (goto-char (nth 2 cache-entry)) - (setq braceassignp (nth 3 cache-entry))) - ((> (point) (cadr cache-entry)) - ;; We're beyond the previous scan region, so just scan as - ;; far as the end of that region. - (setq sub-bassign-p (c-laomib-loop lim2)) - (if (<= (point) (cadr cache-entry)) - (progn - (c-laomib-put-cache containing-sexp - start (nth 2 cache-entry) - (nth 3 cache-entry) ;; sub-bassign-p - ) - (setq braceassignp (nth 3 cache-entry)) - (goto-char (nth 2 cache-entry))) - (c-laomib-put-cache containing-sexp - start (point) sub-bassign-p) - (setq braceassignp sub-bassign-p))) - (t)) - - (setq braceassignp (c-laomib-loop lim)) - (when lim - (c-laomib-put-cache lim start (point) braceassignp))))) + (t + (goto-char pos) + (when (eq braceassignp 'dontknow) + (let* ((cache-entry (and containing-sexp + (c-laomib-get-cache containing-sexp pos))) + (lim2 (or (cadr cache-entry) lim)) + sub-bassign-p) + (if cache-entry + (cond + ((<= (point) (cadr cache-entry)) + ;; We're inside the region we've already scanned over, so + ;; just go to that scan's end position. + (goto-char (nth 2 cache-entry)) + (setq braceassignp (nth 3 cache-entry))) + ((> (point) (cadr cache-entry)) + ;; We're beyond the previous scan region, so just scan as + ;; far as the end of that region. + (setq sub-bassign-p (c-laomib-loop lim2)) + (if (<= (point) (cadr cache-entry)) + (progn + (setcar (cdr cache-entry) start) + (setq braceassignp (nth 3 cache-entry)) + (goto-char (nth 2 cache-entry))) + (c-laomib-put-cache containing-sexp + start (point) sub-bassign-p) + (setq braceassignp sub-bassign-p))) + (t)) + + (setq braceassignp (c-laomib-loop lim)) + (when lim + (c-laomib-put-cache lim start (point) braceassignp))))) - (cond - (braceassignp - ;; We've hit the beginning of the aggregate list. - (setq pos2 (point)) - (cons - (if (eq (c-beginning-of-statement-1 containing-sexp) 'same) - (point) - pos2) - (or in-paren inexpr-brace-list))) - ((and after-type-id-pos - (save-excursion - (when (eq (char-after) ?\;) - (c-forward-over-token-and-ws t)) - (setq bufpos (point)) - (when (looking-at c-opt-<>-sexp-key) - (c-forward-over-token-and-ws) - (when (and (eq (char-after) ?<) - (c-get-char-property (point) 'syntax-table)) - (c-go-list-forward nil after-type-id-pos) - (c-forward-syntactic-ws))) - (if (and (not (eq (point) after-type-id-pos)) - (or (not (looking-at c-class-key)) - (save-excursion - (goto-char (match-end 1)) - (c-forward-syntactic-ws) - (not (eq (point) after-type-id-pos))))) - (progn - (setq res - (c-forward-decl-or-cast-1 (c-point 'bosws) - nil nil)) - (and (consp res) - (cond - ((eq (car res) after-type-id-pos)) - ((> (car res) after-type-id-pos) nil) - (t - (catch 'find-decl + (cond + (braceassignp + ;; We've hit the beginning of the aggregate list. + (setq pos2 (point)) + (cons + (if (eq (c-beginning-of-statement-1 containing-sexp) 'same) + (point) + pos2) + (or in-paren inexpr-brace-list))) + ((and after-type-id-pos + (save-excursion + (when (eq (char-after) ?\;) + (c-forward-over-token-and-ws t)) + (setq bufpos (point)) + (when (looking-at c-opt-<>-sexp-key) + (c-forward-over-token-and-ws) + (when (and (eq (char-after) ?<) + (c-get-char-property (point) 'syntax-table)) + (c-go-list-forward nil after-type-id-pos) + (c-forward-syntactic-ws))) + (if (and (not (eq (point) after-type-id-pos)) + (or (not (looking-at c-class-key)) (save-excursion - (goto-char (car res)) - (c-do-declarators - (point-max) t nil nil - (lambda (id-start _id-end _tok _not-top _func _init) - (cond - ((> id-start after-type-id-pos) - (throw 'find-decl nil)) - ((eq id-start after-type-id-pos) - (throw 'find-decl t))))) - nil)))))) - (save-excursion - (goto-char start) - (not (c-looking-at-statement-block)))))) - (cons bufpos (or in-paren inexpr-brace-list))) - ((or (eq (char-after) ?\;) - ;; Brace lists can't contain a semicolon, so we're done. - (save-excursion - (c-backward-syntactic-ws) - (eq (char-before) ?})) - ;; They also can't contain a bare }, which is probably the end - ;; of a function. - ) - nil) - ((and (setq macro-start (point)) - (c-forward-to-cpp-define-body) - (eq (point) start)) - ;; We've a macro whose expansion starts with the '{'. - ;; Heuristically, if we have a ';' in it we've not got a - ;; brace list, otherwise we have. - (let ((macro-end (progn (c-end-of-macro) (point)))) - (goto-char start) - (forward-char) - (if (and (c-syntactic-re-search-forward "[;,]" macro-end t t) - (eq (char-before) ?\;)) - nil - (cons macro-start nil)))) ; (2016-08-30): Lazy! We have no + (goto-char (match-end 1)) + (c-forward-syntactic-ws) + (not (eq (point) after-type-id-pos))))) + (progn + (setq res + (c-forward-decl-or-cast-1 (c-point 'bosws) + nil nil)) + (and (consp res) + (cond + ((eq (car res) after-type-id-pos)) + ((> (car res) after-type-id-pos) nil) + (t + (catch 'find-decl + (save-excursion + (goto-char (car res)) + (c-do-declarators + (point-max) t nil nil + (lambda (id-start _id-end _tok _not-top _func _init) + (cond + ((> id-start after-type-id-pos) + (throw 'find-decl nil)) + ((eq id-start after-type-id-pos) + (throw 'find-decl t))))) + nil)))))) + (save-excursion + (goto-char start) + (not (c-looking-at-statement-block)))))) + (cons bufpos (or in-paren inexpr-brace-list))) + ((or (eq (char-after) ?\;) + ;; Brace lists can't contain a semicolon, so we're done. + (save-excursion + (c-backward-syntactic-ws) + (eq (char-before) ?})) + ;; They also can't contain a bare }, which is probably the end + ;; of a function. + ) + nil) + ((and (setq macro-start (point)) + (c-forward-to-cpp-define-body) + (eq (point) start)) + ;; We've a macro whose expansion starts with the '{'. + ;; Heuristically, if we have a ';' in it we've not got a + ;; brace list, otherwise we have. + (let ((macro-end (progn (c-end-of-macro) (point)))) + (goto-char start) + (forward-char) + (if (and (c-syntactic-re-search-forward "[;,]" macro-end t t) + (eq (char-before) ?\;)) + nil + (cons macro-start nil)))) ; (2016-08-30): Lazy! We have no ; languages where ; `c-opt-inexpr-brace-list-key' is ; non-nil and we have macros. - (t t)))) ;; The caller can go up one level. - ))) + (t t)))) ;; The caller can go up one level. + )))) + +;; A list of the form returned by `c-parse-state'. Each opening brace in it +;; is not the brace of a brace list. Any cons items in it are ignored, and +;; are also unreliable. +(defvar c-no-bracelist-cache nil) +(make-variable-buffer-local 'c-no-bracelist-cache) (defun c-inside-bracelist-p (containing-sexp paren-state accept-in-paren) - ;; return the buffer position of the beginning of the brace list statement + ;; Return the buffer position of the beginning of the brace list statement ;; if CONTAINING-SEXP is inside a brace list, otherwise return nil. ;; - ;; CONTAINING-SEXP is the buffer pos of the innermost containing paren. NO - ;; IT ISN'T!!! [This function is badly designed, and probably needs - ;; reformulating without its first argument, and the critical position being - ;; at point.] + ;; CONTAINING-SEXP must be at an open brace, and is the buffer pos of the + ;; innermost containing brace. NO IT ISN'T!!! [This function is badly + ;; designed, and probably needs reformulating without its first argument, + ;; and the critical position being at point.] ;; ;; PAREN-STATE is the remainder of the state of enclosing braces. ;; ACCEPT-IN-PAREN is non-nil iff we will accept as a brace list a brace @@ -13407,38 +13394,55 @@ comment at the start of cc-engine.el for more info." ;; speed. ;; ;; This function might do hidden buffer changes. - (or - ;; This will pick up brace list declarations. - (save-excursion - (goto-char containing-sexp) - (and (c-backward-over-enum-header) - (point))) - ;; this will pick up array/aggregate init lists, even if they are nested. - (save-excursion - (let ((bufpos t) - next-containing) - (while (and (eq bufpos t) - containing-sexp) - (when paren-state - (setq next-containing (c-pull-open-brace paren-state))) - - (goto-char containing-sexp) - (if (c-looking-at-inexpr-block next-containing next-containing) - ;; We're in an in-expression block of some kind. Do not - ;; check nesting. We deliberately set the limit to the - ;; containing sexp, so that c-looking-at-inexpr-block - ;; doesn't check for an identifier before it. - (setq bufpos nil) - (if (not (eq (char-after) ?{)) - (setq bufpos nil) - (when (eq (setq bufpos (c-looking-at-or-maybe-in-bracelist - next-containing next-containing)) - t) - (setq containing-sexp next-containing - next-containing nil))))) - (and (consp bufpos) - (or accept-in-paren (not (eq (cdr bufpos) 'in-paren))) - (car bufpos)))))) + ;; It will pick up array/aggregate init lists, even if they are nested. + (save-excursion + (let ((bufpos t) + next-containing non-brace-pos + (whole-paren-state (cons containing-sexp paren-state)) + (current-brace containing-sexp)) + (while (and (eq bufpos t) + current-brace + (not (memq current-brace c-no-bracelist-cache))) + (setq next-containing + (and paren-state (c-pull-open-brace paren-state))) + (goto-char current-brace) + (cond + ((c-looking-at-inexpr-block next-containing next-containing) + ;; We're in an in-expression block of some kind. Do not + ;; check nesting. We deliberately set the limit to the + ;; containing sexp, so that c-looking-at-inexpr-block + ;; doesn't check for an identifier before it. + (setq bufpos nil)) + ((not (eq (char-after) ?{)) + (setq non-brace-pos (point)) + (setq bufpos nil)) + ((eq (setq bufpos (c-looking-at-or-maybe-in-bracelist + next-containing next-containing)) + t) + (setq current-brace next-containing)))) + (cond + ((consp bufpos) + (and (or accept-in-paren (not (eq (cdr bufpos) 'in-paren))) + (car bufpos))) + (non-brace-pos + ;; We've encountered a ( or a [. Remove the "middle part" of + ;; paren-state, the part that isn't non-brace-list braces, to get the + ;; new value of `c-no-bracelist-cache'. + (setq whole-paren-state + ;; `c-whack-state-before' makes a copy of `whole-paren-state'. + (c-whack-state-before (1+ non-brace-pos) whole-paren-state)) + (while (and next-containing + (not (memq next-containing c-no-bracelist-cache))) + (setq next-containing (c-pull-open-brace paren-state))) + (setq c-no-bracelist-cache + (nconc whole-paren-state + (and next-containing (list next-containing)) + paren-state)) + nil) + ((not (memq containing-sexp c-no-bracelist-cache)) + ;; Update `c-no-bracelist-cache' + (setq c-no-bracelist-cache (copy-tree whole-paren-state)) + nil))))) (defun c-looking-at-special-brace-list () ;; If we're looking at the start of a pike-style list, i.e., `({ })', @@ -13636,7 +13640,7 @@ comment at the start of cc-engine.el for more info." nil)) ((progn (goto-char req-pos) - (if (looking-at c-fun-name-substitute-key) + (if (looking-at c-requires-clause-key) (setq found-clause (c-forward-c++-requires-clause nil t)) (and (c-forward-concept-fragment) (setq found-clause (point)))) @@ -13847,18 +13851,84 @@ comment at the start of cc-engine.el for more info." (looking-at c-pre-lambda-tokens-re))) (not (c-in-literal)))) +(defun c-looking-at-c++-lambda-expression (&optional lim) + ;; If point is at the [ opening a C++ lambda expressions's capture list, + ;; and the lambda expression is complete, return the position of the { which + ;; opens the body form, otherwise return nil. LIM is the limit for forward + ;; searching for the {. + (let ((here (point)) + (lim-or-max (or lim (point-max))) + got-params) + (when (and (c-looking-at-c++-lambda-capture-list) + (c-go-list-forward nil lim)) + (c-forward-syntactic-ws lim) + (when (c-forward-<>-arglist t) + (c-forward-syntactic-ws lim) + (when (looking-at c-requires-clause-key) + (c-forward-c++-requires-clause lim nil))) + (when (looking-at "\\(alignas\\)\\([^a-zA-Z0-9_$]\\|$\\)") + (c-forward-keyword-clause 1)) + (when (and (eq (char-after) ?\() + (c-go-list-forward nil lim)) + (setq got-params t) + (c-forward-syntactic-ws lim)) + (while (and c-lambda-spec-key (looking-at c-lambda-spec-key)) + (goto-char (match-end 1)) + (c-forward-syntactic-ws lim)) + (let (after-except-pos) + (while + (and (<= (point) lim-or-max) + (cond + ((save-excursion + (and (looking-at "throw\\([^a-zA-Z0-9_]\\|$\\)") + (progn (goto-char (match-beginning 1)) + (c-forward-syntactic-ws lim) + (eq (char-after) ?\()) + (c-go-list-forward nil lim) + (progn (c-forward-syntactic-ws lim) + (setq after-except-pos (point))))) + (goto-char after-except-pos) + (c-forward-syntactic-ws lim) + t) + ((looking-at c-paren-nontype-key) ; "noexcept" or "alignas" + (c-forward-keyword-clause 1)))))) + (and (<= (point) lim-or-max) + (looking-at c-haskell-op-re) + (goto-char (match-end 0)) + (progn (c-forward-syntactic-ws lim) + (c-forward-type t))) ; t is BRACE-BLOCK-TOO. + (and got-params + (<= (point) lim-or-max) + (looking-at c-requires-clause-key) + (c-forward-c++-requires-clause lim nil)) + (prog1 (and (<= (point) lim-or-max) + (eq (char-after) ?{) + (point)) + (goto-char here))))) + +(defun c-backward-over-lambda-expression (&optional lim) + ;; Point is at a {. Move back over the lambda expression this is a part of, + ;; stopping at the [ of the capture list, if this is the case, returning + ;; the position of that opening bracket. If we're not at such a list, leave + ;; point unchanged and return nil. + (let ((here (point))) + (c-syntactic-skip-backward "^;}]" lim t) + (if (and (eq (char-before) ?\]) + (c-go-list-backward nil lim) + (eq (c-looking-at-c++-lambda-expression (1+ here)) + here)) + (point) + (goto-char here) + nil))) + (defun c-c++-vsemi-p (&optional pos) ;; C++ Only - Is there a "virtual semicolon" at POS or point? ;; (See cc-defs.el for full details of "virtual semicolons".) ;; ;; This is true when point is at the last non syntactic WS position on the - ;; line, and either there is a "macro with semicolon" just before it (see - ;; `c-at-macro-vsemi-p') or there is a "requires" clause which ends there. - (let (res) - (cond - ((setq res (c-in-requires-or-at-end-of-clause pos)) - (and res (eq (cdr res) t))) - ((c-at-macro-vsemi-p))))) + ;; line, and there is a "macro with semicolon" just before it (see + ;; `c-at-macro-vsemi-p'). + (c-at-macro-vsemi-p pos)) (defun c-at-macro-vsemi-p (&optional pos) ;; Is there a "virtual semicolon" at POS or point? @@ -14152,6 +14222,8 @@ comment at the start of cc-engine.el for more info." (cdr (assoc (match-string 1) c-other-decl-block-key-in-symbols-alist)) (max (c-point 'boi paren-pos) (point)))) + ((c-at-enum-brace paren-pos) + (c-add-syntax 'enum-intro nil)) ((c-inside-bracelist-p paren-pos paren-state nil) (if (save-excursion (goto-char paren-pos) @@ -14235,7 +14307,7 @@ comment at the start of cc-engine.el for more info." (cond ;; (CASE A removed.) - ;; CASE B: open braces for class or brace-lists + ;; CASE B: open braces for class, enum or brace-lists ((setq special-brace-list (or (and c-special-brace-lists (c-looking-at-special-brace-list)) @@ -14250,6 +14322,10 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'class-open beg-of-same-or-containing-stmt (c-point 'boi placeholder))) + ;; CASE B.6: enum-open. + ((setq placeholder (c-at-enum-brace)) + (c-add-syntax 'enum-open placeholder)) + ;; CASE B.2: brace-list-open ((or (consp special-brace-list) (c-inside-bracelist-p (point) @@ -14413,7 +14489,7 @@ comment at the start of cc-engine.el for more info." literal char-before-ip before-ws-ip char-after-ip macro-start in-macro-expr c-syntactic-context placeholder step-type tmpsymbol keyword injava-inher special-brace-list tmp-pos - tmp-pos2 containing-< tmp constraint-detail + tmp-pos2 containing-< tmp constraint-detail enum-pos ;; The following record some positions for the containing ;; declaration block if we're directly within one: ;; `containing-decl-open' is the position of the open @@ -14794,13 +14870,13 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'class-open placeholder (c-point 'boi tmp-pos))) - ;; CASE 5A.3: brace list open + ;; CASE 5A.3: brace-list/enum open ((save-excursion (goto-char indent-point) (skip-chars-forward " \t") (cond - ((c-backward-over-enum-header) - (setq placeholder (c-point 'boi))) + ((setq enum-pos (c-at-enum-brace)) + (setq placeholder (c-point 'boi enum-pos))) ((consp (setq placeholder (c-looking-at-or-maybe-in-bracelist containing-sexp lim))) @@ -14820,7 +14896,8 @@ comment at the start of cc-engine.el for more info." (progn (c-beginning-of-statement-1 lim) (c-add-syntax 'topmost-intro-cont (c-point 'boi))) - (c-add-syntax 'brace-list-open placeholder))) + (c-add-syntax (if enum-pos 'enum-open 'brace-list-open) + placeholder))) ;; CASE 5A.4: inline defun open ((and containing-decl-open @@ -14841,7 +14918,6 @@ comment at the start of cc-engine.el for more info." (progn (c-backward-syntactic-ws lim) (zerop (c-backward-token-2 nil nil lim))) (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)) (setq placeholder (point)))) (goto-char placeholder) (back-to-indentation) @@ -15267,6 +15343,15 @@ comment at the start of cc-engine.el for more info." ;; NOTE: The point is at the end of the previous token here. + ;; CASE 5U: We are just after a requires clause. + ((and (setq placeholder (c-in-requires-or-at-end-of-clause)) + (eq (cdr-safe placeholder) t)) + (goto-char (car placeholder)) + (c-beginning-of-statement-1 + (or (c-safe-position (point) paren-state) + (c-determine-limit 1000))) + (c-add-syntax 'topmost-intro-cont (point))) + ;; CASE 5J: we are at the topmost level, make ;; sure we skip back past any access specifiers ((and @@ -15490,11 +15575,16 @@ comment at the start of cc-engine.el for more info." (eq (c-beginning-of-statement-1 lim t nil t) 'same) (looking-at c-opt-inexpr-brace-list-key)))) (progn - (setq placeholder (c-inside-bracelist-p (point) - paren-state - nil)) + (setq placeholder + (or (setq enum-pos (c-at-enum-brace)) + (c-inside-bracelist-p (point) + paren-state + nil))) (if placeholder - (setq tmpsymbol '(brace-list-open . inexpr-class)) + (setq tmpsymbol + `(,(if enum-pos 'enum-open 'brace-list-open) + . inexpr-class) + ) (setq tmpsymbol '(block-open . inexpr-statement) placeholder (cdr-safe (c-looking-at-inexpr-block @@ -15609,16 +15699,16 @@ comment at the start of cc-engine.el for more info." (c-add-syntax 'inher-cont (point)) ))) - ;; CASE 9: we are inside a brace-list + ;; CASE 9: we are inside a brace-list or enum. ((and (not (c-major-mode-is 'awk-mode)) ; Maybe this isn't needed (ACM, 2002/3/29) (setq special-brace-list (or (and c-special-brace-lists ;;;; ALWAYS NIL FOR AWK!! (save-excursion (goto-char containing-sexp) (c-looking-at-special-brace-list))) + (setq enum-pos (c-at-enum-brace containing-sexp)) (c-inside-bracelist-p containing-sexp paren-state t)))) (cond - ;; CASE 9A: In the middle of a special brace list opener. ((and (consp special-brace-list) (save-excursion @@ -15644,7 +15734,7 @@ comment at the start of cc-engine.el for more info." (c-forward-noise-clause)))) (c-add-syntax 'brace-list-open (c-point 'boi)))) - ;; CASE 9B: brace-list-close brace + ;; CASE 9B: brace-list-close/enum-close brace ((if (consp special-brace-list) ;; Check special brace list closer. (progn @@ -15665,7 +15755,8 @@ comment at the start of cc-engine.el for more info." (c-safe (goto-char (c-up-list-backward (point))) t) (= (point) containing-sexp))) (if (eq (point) (c-point 'boi)) - (c-add-syntax 'brace-list-close (point)) + (c-add-syntax (if enum-pos 'enum-close 'brace-list-close) + (point)) (setq lim (or (save-excursion (and (c-back-over-member-initializers @@ -15673,7 +15764,8 @@ comment at the start of cc-engine.el for more info." (point))) (c-most-enclosing-brace state-cache (point)))) (c-beginning-of-statement-1 lim nil nil t) - (c-add-stmt-syntax 'brace-list-close nil t lim paren-state))) + (c-add-stmt-syntax (if enum-pos 'enum-close 'brace-list-close) + nil t lim paren-state))) (t ;; Prepare for the rest of the cases below by going back to the @@ -15693,13 +15785,14 @@ comment at the start of cc-engine.el for more info." (c-skip-ws-forward indent-point))) (cond - ;; CASE 9C: we're looking at the first line in a brace-list + ;; CASE 9C: we're looking at the first line in a brace-list/enum ((= (point) indent-point) (if (consp special-brace-list) (goto-char (car (car special-brace-list))) (goto-char containing-sexp)) (if (eq (point) (c-point 'boi)) - (c-add-syntax 'brace-list-intro (point)) + (c-add-syntax (if enum-pos 'enum-intro 'brace-list-intro) + (point)) (setq lim (or (save-excursion (and (c-back-over-member-initializers @@ -15707,9 +15800,10 @@ comment at the start of cc-engine.el for more info." (point))) (c-most-enclosing-brace state-cache (point)))) (c-beginning-of-statement-1 lim nil nil t) - (c-add-stmt-syntax 'brace-list-intro nil t lim paren-state))) + (c-add-stmt-syntax (if enum-pos 'enum-intro 'brace-list-intro) + nil t lim paren-state))) - ;; CASE 9D: this is just a later brace-list-entry or + ;; CASE 9D: this is just a later brace-list-entry/enum-entry or ;; brace-entry-open (t (if (or (eq char-after-ip ?{) (and c-special-brace-lists @@ -15718,10 +15812,9 @@ comment at the start of cc-engine.el for more info." (c-forward-syntactic-ws (c-point 'eol)) (c-looking-at-special-brace-list)))) (c-add-syntax 'brace-entry-open (point)) - (c-add-stmt-syntax 'brace-list-entry nil t containing-sexp - paren-state (point)) - )) - )))) + (c-add-stmt-syntax (if enum-pos 'enum-entry 'brace-list-entry) + nil t containing-sexp + paren-state (point)))))))) ;; CASE 10: A continued statement or top level construct. ((and (not (memq char-before-ip '(?\; ?:))) @@ -15802,8 +15895,7 @@ comment at the start of cc-engine.el for more info." (c-go-list-backward nil lim)) (progn (c-backward-syntactic-ws lim) (zerop (c-backward-token-2 nil nil lim))) - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)))) + (looking-at c-fun-name-substitute-key))) (goto-char containing-sexp) (back-to-indentation) (c-add-stmt-syntax 'defun-close nil t lim paren-state)) @@ -15967,8 +16059,7 @@ comment at the start of cc-engine.el for more info." (c-go-list-backward nil lim)) (progn (c-backward-syntactic-ws lim) (zerop (c-backward-token-2 nil nil lim))) - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)))) + (looking-at c-fun-name-substitute-key))) (goto-char containing-sexp) (back-to-indentation) (c-add-syntax 'defun-block-intro (point))) @@ -16095,12 +16186,24 @@ comment at the start of cc-engine.el for more info." ;; Indentation calculation. +(defvar c-used-syntactic-symbols nil) +;; The syntactic symbols so far used in a chain of them. +;; It is used to prevent infinite loops when the OFFSET in `c-evaluate-offset' +;; is itself a syntactic symbol. + (defun c-evaluate-offset (offset langelem symbol) - ;; offset can be a number, a function, a variable, a list, or one of - ;; the symbols + or - + ;; Evaluate the offset for OFFSET, returning it either as a number, + ;; a vector, a symbol (whose value gets used), or nil. + ;; OFFSET is a number, a function, a syntactic symbol, a variable, a list, + ;; or a symbol such as +, -, etc. + ;; LANGELEM is the original language element for which this function is + ;; being called. + ;; SYMBOL is the syntactic symbol, used mainly for error messages. ;; ;; This function might do hidden buffer changes. - (let ((res + (let* + (offset1 + (res (cond ((numberp offset) offset) ((vectorp offset) offset) @@ -16120,6 +16223,15 @@ comment at the start of cc-engine.el for more info." (c-langelem-pos langelem))) langelem symbol)) + ((setq offset1 (assq offset c-offsets-alist)) + (when (memq offset c-used-syntactic-symbols) + (error "Error evaluating offset %S for %s: \ +Infinite loop of syntactic symbols: %S." + offset symbol c-used-syntactic-symbols)) + (let ((c-used-syntactic-symbols + (cons symbol c-used-syntactic-symbols))) + (c-evaluate-offset (cdr-safe offset1) langelem offset))) + ((listp offset) (cond ((eq (car offset) 'quote) diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 6419d6cf05a..83afe081b85 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -556,34 +556,23 @@ stuff. Used on level 1 and higher." ;; Fontify filenames in #include <...> as strings. ,@(when (c-lang-const c-cpp-include-directives) - (let* ((re (c-make-keywords-re nil - (c-lang-const c-cpp-include-directives))) - (re-depth (regexp-opt-depth re))) - ;; We used to use a font-lock "anchored matcher" here for - ;; the paren syntax. This failed when the ">" was at EOL, - ;; since `font-lock-fontify-anchored-keywords' terminated - ;; its loop at EOL without executing our lambda form at - ;; all. - `((,(c-make-font-lock-search-function - (concat noncontinued-line-end - (c-lang-const c-opt-cpp-prefix) - re - (c-lang-const c-syntactic-ws) - "\\(<\\([^>\n\r]*\\)>?\\)") - `(,(+ ncle-depth re-depth sws-depth - (if (featurep 'xemacs) 2 1) - ) - font-lock-string-face t) - `((let ((beg (match-beginning - ,(+ ncle-depth re-depth sws-depth 1))) - (end (1- (match-end ,(+ ncle-depth re-depth - sws-depth 1))))) - (if (eq (char-after end) ?>) - (progn - (c-mark-<-as-paren beg) - (c-mark->-as-paren end)) - (c-unmark-<->-as-paren beg))) - nil)))))) + ;; We used to use a font-lock "anchored matcher" here for + ;; the paren syntax. This failed when the ">" was at EOL, + ;; since `font-lock-fontify-anchored-keywords' terminated + ;; its loop at EOL without executing our lambda form at all. + ;; (2024-10): The paren syntax is now handled in + ;; before/after-change functions. + `((,(concat noncontinued-line-end + "\\(" ; To make the next ^ special. + (c-lang-const c-cpp-include-key) + "\\)" + (c-lang-const c-syntactic-ws) + "\\(<\\([^>\n\r]*\\)>?\\)") + ,(+ ncle-depth 1 + (regexp-opt-depth (c-lang-const c-cpp-include-key)) + sws-depth + (if (featurep 'xemacs) 2 1)) + font-lock-string-face t))) ;; #define. ,@(when (c-lang-const c-opt-cpp-macro-define) @@ -1283,11 +1272,12 @@ casts and declarations are fontified. Used on level 2 and higher." (c-put-char-property (1- match-pos) 'c-type 'c-decl-arg-start) (cons 'decl nil)) - ;; We're inside a brace list. + ;; We're inside a brace list/enum list. ((and (eq (char-before match-pos) ?{) - (c-inside-bracelist-p (1- match-pos) - (cdr (c-parse-state)) - nil)) + (or (c-at-enum-brace (1- match-pos)) + (c-inside-bracelist-p (1- match-pos) + (cdr (c-parse-state)) + nil))) (c-put-char-property (1- match-pos) 'c-type 'c-not-decl) (cons 'not-decl nil)) @@ -1388,8 +1378,7 @@ casts and declarations are fontified. Used on level 2 and higher." (memq type '(c-decl-arg-start c-decl-type-start)))))))) ((and (zerop (c-backward-token-2)) - (looking-at c-fun-name-substitute-key) - (not (eq (char-after (match-end 0)) ?_)))))))))) + (looking-at c-fun-name-substitute-key))))))))) ;; Cache the result of this test for next time around. (c-put-char-property (1- match-pos) 'c-type 'c-decl-arg-start) (cons 'decl nil)) @@ -1759,9 +1748,7 @@ casts and declarations are fontified. Used on level 2 and higher." ;; Fontification". (while (and (< (point) limit) (search-forward-regexp c-enum-clause-introduction-re limit t)) - (when (save-excursion - (backward-char) - (c-backward-over-enum-header)) + (when (c-at-enum-brace (1- (point))) (c-forward-syntactic-ws) (c-font-lock-declarators limit t nil t))) nil) @@ -1785,9 +1772,7 @@ casts and declarations are fontified. Used on level 2 and higher." (when (and encl-pos (eq (char-after encl-pos) ?\{) - (save-excursion - (goto-char encl-pos) - (c-backward-over-enum-header))) + (c-at-enum-brace encl-pos)) (c-syntactic-skip-backward "^{," nil t) (c-put-char-property (1- (point)) 'c-type 'c-decl-id-start) @@ -2470,7 +2455,7 @@ on level 2 only and so aren't combined with `c-complex-decl-matchers'." generic casts and declarations are fontified. Used on level 2 and higher." - t `(,@(when (c-lang-const c-brace-list-decl-kwds) + t `(,@(when (c-lang-const c-enum-list-kwds) ;; Fontify the remaining identifiers inside an enum list when we start ;; inside it. '(c-font-lock-enum-tail diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index 72cfdfa8653..a256371f850 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -451,7 +451,8 @@ so that all identifiers are recognized as words.") (c-lang-defconst c-get-state-before-change-functions ;; For documentation see the following c-lang-defvar of the same name. ;; The value here may be a list of functions or a single function. - t 'c-before-change-check-unbalanced-strings + t '(c-before-change-include-<> + c-before-change-check-unbalanced-strings) c++ '(c-extend-region-for-CPP c-depropertize-CPP c-before-change-check-ml-strings @@ -463,6 +464,7 @@ so that all identifiers are recognized as words.") c-parse-quotes-before-change c-before-change-fix-comment-escapes) c '(c-extend-region-for-CPP + c-before-change-include-<> c-depropertize-CPP c-truncate-bs-cache c-before-change-check-unbalanced-strings @@ -480,7 +482,8 @@ so that all identifiers are recognized as words.") c-unmark-<>-around-region c-before-change-check-unbalanced-strings c-before-change-check-<>-operators) - pike '(c-before-change-check-ml-strings + pike '(c-before-change-include-<> + c-before-change-check-ml-strings c-before-change-check-unbalanced-strings) awk 'c-awk-record-region-clear-NL) (c-lang-defvar c-get-state-before-change-functions @@ -511,6 +514,7 @@ parameters \(point-min) and \(point-max).") t '(c-depropertize-new-text c-after-change-escape-NL-in-string c-after-change-mark-abnormal-strings + c-after-change-include-<> c-change-expand-fl-region) c '(c-depropertize-new-text c-after-change-fix-comment-escapes @@ -518,6 +522,7 @@ parameters \(point-min) and \(point-max).") c-parse-quotes-after-change c-after-change-mark-abnormal-strings c-extend-font-lock-region-for-macros + c-after-change-include-<> c-neutralize-syntax-in-CPP c-change-expand-fl-region) objc '(c-depropertize-new-text @@ -553,6 +558,7 @@ parameters \(point-min) and \(point-max).") c-after-change-escape-NL-in-string c-after-change-unmark-ml-strings c-after-change-mark-abnormal-strings + c-after-change-include-<> c-change-expand-fl-region) awk '(c-depropertize-new-text c-awk-extend-and-syntax-tablify-region)) @@ -2479,9 +2485,9 @@ following identifier as a type; the keyword must also be present on t (c-make-keywords-re t (c-lang-const c-class-decl-kwds))) (c-lang-defvar c-class-key (c-lang-const c-class-key)) -(c-lang-defconst c-brace-list-decl-kwds +(c-lang-defconst c-enum-list-kwds "Keywords introducing declarations where the following block (if -any) is a brace list. +any) is an enum list. If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', `c-colon-type-list-kwds', `c-paren-nontype-kwds', `c-paren-type-kwds', @@ -2490,23 +2496,43 @@ will be handled." t '("enum") (awk) nil) -(c-lang-defconst c-brace-list-key +(c-lang-defconst c-enum-list-key ;; Regexp matching the start of declarations where the following ;; block is a brace list. - t (c-make-keywords-re t (c-lang-const c-brace-list-decl-kwds))) -(c-lang-defvar c-brace-list-key (c-lang-const c-brace-list-key)) - -(c-lang-defconst c-after-brace-list-decl-kwds - "Keywords that might follow keywords in `c-brace-list-decl-kwds' + t (let ((liszt + (condition-case nil + ;; (prog1 + (c-lang-const c-brace-list-decl-kwds) + ;; (message "`c-brace-list-decl-kwds' has been renamed \ + ;; to `c-enum-list-kwds'. Please amend your derived mode")) + ;; After a few CC Mode versions, output a message here, + ;; prompting the derived mode's maintainer to update the source. + ;; 2024-09. + (error (c-lang-const c-enum-list-kwds))))) + (c-make-keywords-re t liszt))) +(c-lang-defvar c-enum-list-key (c-lang-const c-enum-list-key)) + +(c-lang-defconst c-after-enum-list-kwds + "Keywords that might follow keywords in `c-enum-list-kwds' and precede the opening brace." t nil c++ '("class" "struct")) -(c-lang-defconst c-after-brace-list-key - ;; Regexp matching keywords that can fall between a brace-list +(c-lang-defconst c-after-enum-list-key + ;; Regexp matching keywords that can fall between an enum-list ;; keyword and the associated brace list. - t (c-make-keywords-re t (c-lang-const c-after-brace-list-decl-kwds))) -(c-lang-defvar c-after-brace-list-key (c-lang-const c-after-brace-list-key)) + t (let ((liszt + (condition-case nil + ;; (prog1 + (c-lang-const c-after-brace-list-decl-kwds) + ;; (message "`c-after-brace-list-decl-kwds' has been renamed \ + ;; to `c-after-enum-list-kwds'. Please amend your derived mode")) + ;; After a few CC Mode versions, output a message here, + ;; prompting the derived mode's maintainer to update the source. + ;; 2024-09. + (error (c-lang-const c-after-enum-list-kwds))))) + (c-make-keywords-re t liszt))) +(c-lang-defvar c-after-enum-list-key (c-lang-const c-after-enum-list-key)) (c-lang-defconst c-recognize-post-brace-list-type-p "Set to t when we recognize a colon and then a type after an enum, @@ -2564,7 +2590,7 @@ their matching \"in\" syntactic symbols.") "Keywords introducing a named block, where the name is a \"defun\" name." t (append (c-lang-const c-class-decl-kwds) - (c-lang-const c-brace-list-decl-kwds))) + (c-lang-const c-enum-list-kwds))) (c-lang-defconst c-defun-type-name-decl-key ;; Regexp matching a keyword in `c-defun-type-name-decl-kwds'. @@ -2580,11 +2606,11 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', `c-colon-type-list-kwds', `c-paren-nontype-kwds', `c-paren-type-kwds', `c-<>-type-kwds', or `c-<>-arglist-kwds' then the associated clauses will be handled." - ;; Default to `c-class-decl-kwds' and `c-brace-list-decl-kwds' + ;; Default to `c-class-decl-kwds' and `c-enum-list-kwds' ;; (since e.g. "Foo" is a type that's being defined in "class Foo ;; {...}"). t (append (c-lang-const c-class-decl-kwds) - (c-lang-const c-brace-list-decl-kwds)) + (c-lang-const c-enum-list-kwds)) ;; Languages that have a "typedef" construct. (c c++ objc idl pike) (append (c-lang-const c-typedef-decl-kwds) '("typedef")) @@ -2624,11 +2650,11 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', `c-colon-type-list-kwds', `c-paren-nontype-kwds', `c-paren-type-kwds', `c-<>-type-kwds', or `c-<>-arglist-kwds' then the associated clauses will be handled." - ;; Default to `c-class-decl-kwds' and `c-brace-list-decl-kwds' + ;; Default to `c-class-decl-kwds' and `c-enum-list-kwds' ;; (since e.g. "Foo" is the identifier being defined in "class Foo ;; {...}"). t (append (c-lang-const c-class-decl-kwds) - (c-lang-const c-brace-list-decl-kwds)) + (c-lang-const c-enum-list-kwds)) c nil ;; Note: "manages" for CORBA CIDL clashes with its presence on ;; `c-type-list-kwds' for IDL. @@ -2653,6 +2679,19 @@ will be handled." t (c-make-keywords-re t (c-lang-const c-equals-type-clause-kwds))) (c-lang-defvar c-equals-type-clause-key (c-lang-const c-equals-type-clause-key)) +(c-lang-defconst c-lambda-spec-kwds + "Keywords which are specifiers of certain elements of a C++ lambda function. +This is only used in C++ Mode." + t nil + c++ '("mutable" "constexpr" "consteval" "static")) + +(c-lang-defconst c-lambda-spec-key + ;; A regular expression which matches a member of `c-lambda-spec-kwds', + ;; or nil. + t (if (c-lang-const c-lambda-spec-kwds) + (c-make-keywords-re t (c-lang-const c-lambda-spec-kwds)))) +(c-lang-defvar c-lambda-spec-key (c-lang-const c-lambda-spec-key)) + (c-lang-defconst c-equals-nontype-decl-kwds "Keywords which are followed by an identifier then an \"=\" sign, which declares the identifier to be something other than a @@ -2671,20 +2710,33 @@ type." (c-lang-defconst c-fun-name-substitute-kwds "Keywords which take the place of type+declarator at the beginning of a function-like structure, such as a C++20 \"requires\" -clause. An arglist may or may not follow such a keyword." +expression. An arglist may or may not follow such a keyword. +Not to be confused with `c-requires-clause-kwds'." t nil c++ '("requires")) (c-lang-defconst c-fun-name-substitute-key ;; An unadorned regular expression which matches any member of ;; `c-fun-name-substitute-kwds'. - t (c-make-keywords-re 'appendable (c-lang-const c-fun-name-substitute-kwds))) + t (c-make-keywords-re t (c-lang-const c-fun-name-substitute-kwds))) ;; We use 'appendable, so that we get "\\>" on the regexp, but without a further ;; character, which would mess up backward regexp search from just after the ;; keyword. If only XEmacs had \\_>. ;-( (c-lang-defvar c-fun-name-substitute-key (c-lang-const c-fun-name-substitute-key)) +(c-lang-defconst c-requires-clause-kwds + "Keywords which introduce a C++ requires clause, or something analogous. +This should not be confused with `c-fun-name-substitute-kwds'." + t nil + c++ '("requires")) + +(c-lang-defconst c-requires-clause-key + ;; A regexp matching any member of `c-requires-clause-kwds'. + t (c-make-keywords-re t (c-lang-const c-requires-clause-kwds))) +;; See `c-fun-name-substitute-key' for the justification of appendable. +(c-lang-defvar c-requires-clause-key (c-lang-const c-requires-clause-key)) + (c-lang-defconst c-modifier-kwds "Keywords that can prefix normal declarations of identifiers \(and typically act as flags). Things like argument declarations @@ -2719,7 +2771,7 @@ will be handled." (c-lang-defconst c-other-decl-kwds "Keywords that can start or prefix any declaration level construct, -besides those on `c-class-decl-kwds', `c-brace-list-decl-kwds', +besides those on `c-class-decl-kwds', `c-enum-list-kwds', `c-other-block-decl-kwds', `c-typedef-decl-kwds', `c-typeless-decl-kwds' and `c-modifier-kwds'. @@ -2790,7 +2842,7 @@ one of `c-type-list-kwds', `c-ref-list-kwds', ;; declaration. They might be ambiguous with types or type ;; prefixes. t (c--delete-duplicates (append (c-lang-const c-class-decl-kwds) - (c-lang-const c-brace-list-decl-kwds) + (c-lang-const c-enum-list-kwds) (c-lang-const c-other-block-decl-kwds) (c-lang-const c-typedef-decl-kwds) (c-lang-const c-typeless-decl-kwds) @@ -3086,7 +3138,7 @@ assumed to be set if this isn't nil." "Keywords that may be followed by a brace block containing a comma separated list of identifier definitions, i.e. like the list of identifiers that follows the type in a normal declaration." - t (c-lang-const c-brace-list-decl-kwds)) + t (c-lang-const c-enum-list-kwds)) (c-lang-defconst c-block-stmt-1-kwds "Statement keywords followed directly by a substatement." @@ -4226,10 +4278,10 @@ the invalidity of the putative template construct." ;; keyword itself, and extending up to the "{". It may match text which ;; isn't such a construct; more accurate tests will rule these out when ;; needed. - t (if (c-lang-const c-brace-list-decl-kwds) + t (if (c-lang-const c-enum-list-kwds) (concat "\\<\\(" - (c-make-keywords-re nil (c-lang-const c-brace-list-decl-kwds)) + (c-make-keywords-re nil (c-lang-const c-enum-list-kwds)) "\\)\\>" ;; Disallow various common punctuation chars that can't come ;; before the '{' of the enum list, to avoid searching too far. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 8ce4da56ef7..6676219e702 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -186,8 +186,7 @@ (with-current-buffer b c-buffer-is-cc-mode)) (throw 'found nil))) - (remove-hook 'post-command-hook 'c-post-command) - (remove-hook 'post-gc-hook 'c-post-gc-hook))) + (remove-hook 'post-command-hook 'c-post-command t))) (c-save-buffer-state () (c-clear-char-properties (point-min) (point-max) 'category) (c-clear-char-properties (point-min) (point-max) 'syntax-table) @@ -657,8 +656,10 @@ that requires a literal mode spec at compile time." ;; Initialize the cache for `c-looking-at-or-maybe-in-bracelist'. (setq c-laomib-cache nil) + ;; Initialize the cache for non brace-list braces. + (setq c-no-bracelist-cache nil) ;; Initialize the three literal sub-caches. - (c-truncate-lit-pos-cache 1) + (c-truncate-lit-pos/state-cache 1) ;; Initialize the cache of brace pairs, and opening braces/brackets/parens. (c-state-cache-init) ;; Initialize the "brace stack" cache. @@ -761,7 +762,7 @@ that requires a literal mode spec at compile time." ;; would do since font-lock uses a(n implicit) depth of 0) so we don't need ;; c-after-font-lock-init. (add-hook 'after-change-functions 'c-after-change nil t) - (add-hook 'post-command-hook 'c-post-command) + (add-hook 'post-command-hook 'c-post-command nil t) (when (boundp 'font-lock-extend-after-change-region-function) (set (make-local-variable 'font-lock-extend-after-change-region-function) @@ -1023,8 +1024,8 @@ Note that the style variables are always made local to the buffer." (setq m-beg (point)) (c-end-of-macro) (when c-ml-string-opener-re - (save-excursion (c-depropertize-ml-strings-in-region m-beg (point)))) - (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) + (save-excursion (c-depropertize-ml-strings-in-region m-beg (point))) + (c-clear-syntax-table-with-value-trim-caches m-beg (point) '(1)))) (while (and (< (point) end) (setq ss-found @@ -1035,17 +1036,17 @@ Note that the style variables are always made local to the buffer." (when (and ss-found (> (point) end)) (when c-ml-string-opener-re (save-excursion (c-depropertize-ml-strings-in-region m-beg (point)))) - (c-clear-char-property-with-value m-beg (point) 'syntax-table '(1))) + (c-clear-syntax-table-with-value-trim-caches m-beg (point) '(1))) (while (and (< (point) c-new-END) - (search-forward-regexp c-anchored-cpp-prefix c-new-END 'bound)) + (search-forward-regexp c-anchored-cpp-prefix + c-new-END 'bound)) (goto-char (match-beginning 1)) (setq m-beg (point)) (c-end-of-macro) (when c-ml-string-opener-re (save-excursion (c-depropertize-ml-strings-in-region m-beg (point)))) - (c-clear-char-property-with-value - m-beg (point) 'syntax-table '(1))))) + (c-clear-syntax-table-with-value-trim-caches m-beg (point) '(1))))) (defun c-extend-region-for-CPP (_beg _end) ;; Adjust `c-new-BEG', `c-new-END' respectively to the beginning and end of @@ -1126,7 +1127,7 @@ Note that the style variables are always made local to the buffer." (setq s (parse-partial-sexp beg end -1)) (cond ((< (nth 0 s) 0) ; found an unmated ),},] - (c-put-char-property (1- (point)) 'syntax-table '(1)) + (c-put-syntax-table-trim-caches (1- (point)) '(1)) t) ;; Unbalanced strings are now handled by ;; `c-before-change-check-unbalanced-strings', etc. @@ -1134,7 +1135,7 @@ Note that the style variables are always made local to the buffer." ;; (c-put-char-property (nth 8 s) 'syntax-table '(1)) ;; t) ((> (nth 0 s) 0) ; In a (,{,[ - (c-put-char-property (nth 1 s) 'syntax-table '(1)) + (c-put-syntax-table-trim-caches (nth 1 s) '(1)) t) (t nil))))))) @@ -1284,7 +1285,7 @@ Note that the style variables are always made local to the buffer." ;; (-value- ,value)) (if (equal value '(15)) (c-put-string-fence pos) - (c-put-char-property pos 'syntax-table value)) + (c-put-syntax-table-trim-caches pos value)) (c-put-char-property pos 'c-fl-syn-tab value) (cond ((null c-min-syn-tab-mkr) @@ -1295,12 +1296,11 @@ Note that the style variables are always made local to the buffer." ((null c-max-syn-tab-mkr) (setq c-max-syn-tab-mkr (copy-marker (1+ pos) nil))) ((>= pos c-max-syn-tab-mkr) - (move-marker c-max-syn-tab-mkr (1+ pos)))) - (c-truncate-lit-pos-cache pos)) + (move-marker c-max-syn-tab-mkr (1+ pos))))) (defun c-clear-syn-tab (pos) ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS. - (c-clear-char-property pos 'syntax-table) + (c-clear-syntax-table-trim-caches pos) (c-clear-char-property pos 'c-fl-syn-tab) (when c-min-syn-tab-mkr (if (and (eq pos (marker-position c-min-syn-tab-mkr)) @@ -1321,12 +1321,15 @@ Note that the style variables are always made local to the buffer." pos (c-previous-single-property-change pos 'c-fl-syn-tab nil (1+ c-min-syn-tab-mkr))))))) - (c-truncate-lit-pos-cache pos)) + (c-truncate-lit-pos/state-cache pos)) (defun c-clear-string-fences () ;; Clear syntax-table text properties which are "mirrored" by c-fl-syn-tab ;; text properties. However, any such " character which ends up not being ;; balanced by another " is left with a '(1) syntax-table property. + ;; Note we don't truncate the caches in this function, since it is only + ;; called before leaving CC Mode, and the text properties will be restored + ;; by `c-restore-string-fences' before we continue in CC Mode. (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) (c-save-buffer-state (s pos) ; Prevent text property stuff causing change @@ -1391,6 +1394,7 @@ Note that the style variables are always made local to the buffer." (defun c-restore-string-fences () ;; Restore any syntax-table text properties which are "mirrored" by ;; c-fl-syn-tab text properties. + ;; We don't truncate the caches here. See `c-clear-string-fences'. (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) (c-save-buffer-state ; Prevent text property stuff causing change function ; invocation. @@ -1774,14 +1778,14 @@ position of `after-change-functions'.") (defconst c-maybe-quoted-number-head (concat "\\(0\\(" - "\\([Xx]\\([[:xdigit:]]\\('[[:xdigit:]]\\|[[:xdigit:]]\\)*'?\\)?\\)" + "[Xx]\\([[:xdigit:]]\\('?[[:xdigit:]]\\)*\\)?" "\\|" - "\\([Bb]\\([01]\\('[01]\\|[01]\\)*'?\\)?\\)" + "[Bb]\\([01]\\('?[01]\\)*\\)?" "\\|" - "\\('[0-7]\\|[0-7]\\)*'?" + "\\('?[0-7]\\)*" "\\)" "\\|" - "[1-9]\\('[0-9]\\|[0-9]\\)*'?" + "[1-9]\\('?[0-9]\\)*" "\\)") "Regexp matching the head of a numeric literal, including with digit separators.") @@ -1808,11 +1812,11 @@ position of `after-change-functions'.") (defconst c-maybe-quoted-number-tail (concat "\\(" - "\\([xX']?[[:xdigit:]]\\('[[:xdigit:]]\\|[[:xdigit:]]\\)*\\)" + "\\([xX']?[[:xdigit:]]\\('?[[:xdigit:]]\\)*\\)" "\\|" - "\\([bB']?[01]\\('[01]\\|[01]\\)*\\)" + "\\([bB']?[01]\\('?[01]\\)*\\)" "\\|" - "\\('?[0-9]\\('[0-9]\\|[0-9]\\)*\\)" + "\\('?[0-9]\\)+" "\\)") "Regexp matching the tail of a numeric literal, including with digit separators. Note that this is a strict tail, so won't match, e.g. \"0x....\".") @@ -1828,14 +1832,14 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (defconst c-maybe-quoted-number (concat "\\(0\\(" - "\\([Xx][[:xdigit:]]\\('[[:xdigit:]]\\|[[:xdigit:]]\\)*\\)" + "\\([Xx][[:xdigit:]]\\('?[[:xdigit:]]\\)*\\)" "\\|" - "\\([Bb][01]\\('[01]\\|[01]\\)*\\)" + "\\([Bb][01]\\('?[01]\\)*\\)" "\\|" - "\\('[0-7]\\|[0-7]\\)*" + "\\('?[0-7]\\)*" "\\)" "\\|" - "[1-9]\\('[0-9]\\|[0-9]\\)*" + "[1-9]\\('?[0-9]\\)*" "\\)") "Regexp matching a numeric literal, including with digit separators.") @@ -1947,12 +1951,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (goto-char c-new-BEG) (when (c-search-forward-char-property-with-value-on-char 'syntax-table '(1) ?\' c-new-END) - (c-invalidate-state-cache (1- (point))) - (c-truncate-lit-pos-cache (1- (point))) - (c-clear-char-property-with-value-on-char - (1- (point)) c-new-END - 'syntax-table '(1) - ?') + (c-clear-syntax-table-with-value-on-char-trim-caches + (1- (point)) c-new-END '(1) ?') ;; Remove the c-digit-separator text property from the same "'"s. (when c-has-quoted-numbers (c-clear-char-property-with-value-on-char @@ -1979,10 +1979,8 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ((c-quoted-number-straddling-point) (setq num-beg (match-beginning 0) num-end (match-end 0)) - (c-invalidate-state-cache num-beg) - (c-truncate-lit-pos-cache num-beg) - (c-put-char-properties-on-char num-beg num-end - 'syntax-table '(1) ?') + (c-put-syntax-table-properties-on-char-trim-caches + num-beg num-end '(1) ?') (c-put-char-properties-on-char num-beg num-end 'c-digit-separator t ?') (goto-char num-end)) @@ -1991,15 +1989,11 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") \\)'") ; balanced quoted expression. (goto-char (match-end 0))) ((looking-at "\\\\'") ; Anomalous construct. - (c-invalidate-state-cache (1- (point))) - (c-truncate-lit-pos-cache (1- (point))) - (c-put-char-properties-on-char (1- (point)) (+ (point) 2) - 'syntax-table '(1) ?') - (goto-char (match-end 0))) + (c-truncate-lit-pos/state-cache (1- (point))) + (c-put-syntax-table-properties-on-char-trim-caches + (1- (point)) (+ (point) 2) '(1) ?')) (t - (c-invalidate-state-cache (1- (point))) - (c-truncate-lit-pos-cache (1- (point))) - (c-put-char-property (1- (point)) 'syntax-table '(1)))) + (c-put-syntax-table-trim-caches (1- (point)) '(1)))) ;; Prevent the next `c-quoted-number-straddling-point' getting ;; confused by already processed single quotes. (narrow-to-region (point) (point-max)))))) @@ -2016,6 +2010,70 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (defvar c-new-id-is-type nil) (make-variable-buffer-local 'c-new-id-is-type) +(defun c-before-change-include-<> (beg end) + "Remove category/syntax-table properties from each #include <..>. +In particular, from the < and > characters which have been marked as parens +using these properties. This is done on every such #include <..> with a +portion between BEG and END. + +This function is used solely as a member of +`c-get-state-before-change-functions' where it should appear early, before +`c-depropertize-CPP'. It should be used only together with +`c-after-change-include-<>'." + (c-save-buffer-state ((search-end (progn (goto-char end) + (c-end-of-macro) + (point))) + hash-pos) + (goto-char beg) + (c-beginning-of-macro) + (while (and (< (point) search-end) + (search-forward-regexp c-cpp-include-key search-end 'bound) + (setq hash-pos (match-beginning 0))) + (save-restriction + (narrow-to-region (point-min) (c-point 'eoll)) + (c-forward-comments)) + (when (and (< (point) search-end) + (looking-at "\\s(") + (looking-at "\\(<\\)[^>\n\r]*\\(>\\)?") + (not (cdr (c-semi-pp-to-literal hash-pos)))) + (c-unmark-<->-as-paren (match-beginning 1)) + (when (< hash-pos c-new-BEG) + (setq c-new-BEG hash-pos)) + (when (match-beginning 2) + (c-unmark-<->-as-paren (match-beginning 2)) + (when (> (match-end 2) c-new-END) + (setq c-new-END (match-end 2)))))))) + +(defun c-after-change-include-<> (beg end _old-len) + "Apply category/syntax-table properties to each #include <..>. +In particular, to the < and > characters to mark them as matching parens +using these properties. This is done on every such #include <..> with a +portion between BEG and END. + +This function is used solely as a member of +`c-before-font-lock-functions' where is should appear late, but before +`c-neutralize-syntax-in-CPP'. It should be used only together with +`c-before-change-include-<>'." + (c-save-buffer-state ((search-end (progn (goto-char end) + (c-end-of-macro) + (point))) + hash-pos) + (goto-char beg) + (c-beginning-of-macro) + (while (and (< (point) search-end) + (search-forward-regexp c-cpp-include-key search-end 'bound) + (setq hash-pos (match-beginning 0))) + (save-restriction + (narrow-to-region (point-min) (c-point 'eoll)) + (c-forward-comments)) + (when (and (< (point) search-end) + (looking-at "\\(<\\)[^>\n\r]*\\(>\\)") + (not (cdr (c-semi-pp-to-literal (match-beginning 0))))) + (c-mark-<-as-paren (match-beginning 1)) + (when (< hash-pos c-new-BEG) (setq c-new-BEG hash-pos)) + (c-mark->-as-paren (match-beginning 2)) + (when (> (match-end 2) c-new-END) (setq c-new-END (match-end 2))))))) + (defun c-before-change-fix-comment-escapes (beg end) "Remove punctuation syntax-table text properties from C/C++ comment markers. This is to handle the rare case of two or more backslashes at an @@ -2036,12 +2094,10 @@ with // and /*, not more generic line and block comments." (if (eq (cadr end-state) 'c) (when (search-forward "\\*/" (or (cdr (caddr end-state)) (point-max)) t) - (c-clear-char-property (match-beginning 0) 'syntax-table) - (c-truncate-lit-pos-cache (match-beginning 0))) + (c-clear-syntax-table-trim-caches (match-beginning 0))) (while (search-forward "\\\\\n" (or (cdr (caddr end-state)) (point-max)) t) - (c-clear-char-property (match-beginning 0) 'syntax-table) - (c-truncate-lit-pos-cache (match-beginning 0))))))) + (c-clear-syntax-table-trim-caches (match-beginning 0))))))) (defun c-after-change-fix-comment-escapes (beg end _old-len) "Apply punctuation syntax-table text properties to C/C++ comment markers. @@ -2073,8 +2129,7 @@ with // and /*, not more generic line and block comments." (match-beginning 3)) ((eq (cadr state) 'c++) (match-beginning 2))) - (c-put-char-property (match-beginning 0) 'syntax-table '(1)) - (c-truncate-lit-pos-cache (match-beginning 0)))) + (c-put-syntax-table-trim-caches (match-beginning 0) '(1)))) (goto-char end) (setq state (c-semi-pp-to-literal (point))) @@ -2082,8 +2137,7 @@ with // and /*, not more generic line and block comments." ((eq (cadr state) 'c) (when (search-forward "*/" nil t) (when (eq (char-before (match-beginning 0)) ?\\) - (c-put-char-property (1- (match-beginning 0)) 'syntax-table '(1)) - (c-truncate-lit-pos-cache (1- (match-beginning 0)))))) + (c-put-syntax-table-trim-caches (1- (match-beginning 0)) '(1))))) ((eq (cadr state) 'c++) (while (progn @@ -2091,8 +2145,7 @@ with // and /*, not more generic line and block comments." (and (eq (char-before) ?\\) (progn (when (eq (char-before (1- (point))) ?\\) - (c-put-char-property (- (point) 2) 'syntax-table '(1)) - (c-truncate-lit-pos-cache (1- (point)))) + (c-put-syntax-table-trim-caches (- (point) 2) '(1))) t) (not (eobp)))) (forward-char)))))) @@ -2278,15 +2331,17 @@ with // and /*, not more generic line and block comments." c-get-state-before-change-functions)) (c-laomib-invalidate-cache beg end)))) - (c-truncate-lit-pos-cache beg) + (c-truncate-lit-pos/state-cache beg) ;; The following must be done here rather than in `c-after-change' ;; because newly inserted parens would foul up the invalidation ;; algorithm. - (c-invalidate-state-cache beg) + (c-invalidate-state-cache) ;; The following must happen after the previous, which likely alters ;; the macro cache. (when c-opt-cpp-symbol - (c-invalidate-macro-cache beg end))))) + (c-invalidate-macro-cache beg end)) + (setq c-no-bracelist-cache + (c-whack-state-after beg c-no-bracelist-cache))))) (defvar c-in-after-change-fontification nil) (make-variable-buffer-local 'c-in-after-change-fontification) @@ -2463,7 +2518,7 @@ with // and /*, not more generic line and block comments." (backward-char) (setq pseudo (c-cheap-inside-bracelist-p (c-parse-state))))))) (goto-char pseudo)) - (or pseudo (> (point) bod-lim))) + (or pseudo (bobp) (> (point) bod-lim))) ;; Move forward to the start of the next declaration. (progn (c-forward-syntactic-ws) ;; Have we got stuck in a comment at EOB? diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index ff6371d9368..4937d5d2dcb 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -441,7 +441,7 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil." (symname (symbol-name langelem)) (defstr (format "(default %s): " oldoff)) (errmsg (concat "Offset must be int, func, var, vector, list, " - "or [+,-,++,--,*,/] " + "a syntactic symbol, or [+,-,++,--,*,/] " defstr)) (prompt (concat symname " offset " defstr)) (keymap (make-sparse-keymap)) diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 3845c2d55f0..f0e4c957ea5 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -207,6 +207,192 @@ the value set here overrides the style system (there is a variable ,expanded-doc ,@(plist-put args :type aggregate))))) +(defcustom c-offsets-alist nil + "Alist of syntactic element symbols and indentation offsets. +As described below, each cons cell in this list has the form: + + (SYNTACTIC-SYMBOL . OFFSET) + +When a line is indented, CC Mode first determines the syntactic +context of it by generating a list of symbols called syntactic +elements. The global variable `c-syntactic-context' is bound to that +list. Each element in the list is in turn a list where the first +element is a syntactic symbol which tells what kind of construct the +indentation point is located within. More elements in the syntactic +element lists are optional. If there is one more and it isn't nil, +then it's the anchor position for that construct. + +After generating the syntactic context for the line, CC Mode +calculates the absolute indentation: First the base indentation is +found by using the anchor position for the first syntactic element +that provides one. If none does, zero is used as base indentation. +Then CC Mode looks at each syntactic element in the context in turn. +It compares the car of the syntactic element against the +SYNTACTIC-SYMBOL's in `c-offsets-alist'. When it finds a match, it +adds OFFSET to the base indentation. The sum of this calculation is +the absolute offset for line being indented. + +If the syntactic element does not match any in the `c-offsets-alist', +the element is ignored. + +OFFSET can specify an offset in several different ways: + + If OFFSET is nil then it's ignored. + + If OFFSET is an integer then it's used as relative offset, i.e. it's + added to the base indentation. + + If OFFSET is one of the symbols `+', `-', `++', `--', `*', or `/' + then a positive or negative multiple of `c-basic-offset' is added to + the base indentation; 1, -1, 2, -2, 0.5, and -0.5, respectively. + + If OFFSET is a symbol with a value binding then that value, which + must be an integer, is used as relative offset. + + If OFFSET is a vector then its first element, which must be an + integer, is used as an absolute indentation column. This overrides + the previous base indentation and the relative offsets applied to + it, and it becomes the new base indentation. + + If OFFSET is a function or a lambda expression then it's called with + a single argument containing the cons of the syntactic symbol and + the anchor position (or nil if there is none). The return value + from the function is then reinterpreted as an offset specification. + + If OFFSET is a list then its elements are evaluated recursively as + offset specifications. If the first element is any of the symbols + below then it isn't evaluated but instead specifies how the + remaining offsets in the list should be combined. If it's something + else then the list is combined according the method `first'. The + valid combination methods are: + + `first' -- Use the first offset (that doesn't evaluate to nil). + `min' -- Use the minimum of all the offsets. All must be either + relative or absolute - they can't be mixed. + `max' -- Use the maximum of all the offsets. All must be either + relative or absolute - they can't be mixed. + `add' -- Add all the evaluated offsets together. Exactly one of + them may be absolute, in which case the result is + absolute. Any relative offsets that preceded the + absolute one in the list will be ignored in that case. + +`c-offsets-alist' is a style variable. This means that the offsets on +this variable are normally taken from the style system in CC Mode +\(see `c-default-style' and `c-style-alist'). However, any offsets +put explicitly on this list will override the style system when a CC +Mode buffer is initialized (there is a variable +`c-old-style-variable-behavior' that changes this, though). + +Here is the current list of valid syntactic element symbols: + + string -- Inside multi-line string. + c -- Inside a multi-line C style block comment. + defun-open -- Brace that opens a function definition. + defun-close -- Brace that closes a function definition. + defun-block-intro -- The first line in a top-level defun. + class-open -- Brace that opens a class definition. + class-close -- Brace that closes a class definition. + inline-open -- Brace that opens an in-class inline method. + inline-close -- Brace that closes an in-class inline method. + func-decl-cont -- The region between a function definition's + argument list and the function opening brace + (excluding K&R argument declarations). In C, you + cannot put anything but whitespace and comments + between them; in C++ and Java, throws declarations + and other things can appear in this context. + knr-argdecl-intro -- First line of a K&R C argument declaration. + knr-argdecl -- Subsequent lines in a K&R C argument declaration. + topmost-intro -- The first line in a topmost construct definition. + topmost-intro-cont -- Topmost definition continuation lines. + constraint-cont -- Continuation line of a C++ requires clause (not + to be confused with a \"requires expression\") or + concept. + annotation-top-cont -- Topmost definition continuation line where only + annotations are on previous lines. + annotation-var-cont -- A continuation of a C (or like) statement where + only annotations are on previous lines. + member-init-intro -- First line in a member initialization list. + member-init-cont -- Subsequent member initialization list lines. + inher-intro -- First line of a multiple inheritance list. + inher-cont -- Subsequent multiple inheritance lines. + block-open -- Statement block open brace. + block-close -- Statement block close brace. + brace-list-open -- Open brace of an enum or static array list. + brace-list-close -- Close brace of an enum or static array list. + brace-list-intro -- First line in an enum or static array list. + brace-list-entry -- Subsequent lines in an enum or static array list. + brace-entry-open -- Subsequent lines in an enum or static array + list that start with an open brace. + statement -- A C (or like) statement. + statement-cont -- A continuation of a C (or like) statement. + statement-block-intro -- The first line in a new statement block. + statement-case-intro -- The first line in a case \"block\". + statement-case-open -- The first line in a case block starting with brace. + substatement -- The first line after an if/while/for/do/else. + substatement-open -- The brace that opens a substatement block. + substatement-label -- Labeled line after an if/while/for/do/else. + case-label -- A \"case\" or \"default\" label. + access-label -- C++ private/protected/public access label. + label -- Any ordinary label. + do-while-closure -- The \"while\" that ends a do/while construct. + else-clause -- The \"else\" of an if/else construct. + catch-clause -- The \"catch\" or \"finally\" of a try/catch construct. + comment-intro -- A line containing only a comment introduction. + arglist-intro -- The first line in an argument list. + arglist-cont -- Subsequent argument list lines when no + arguments follow on the same line as the + arglist opening paren. + arglist-cont-nonempty -- Subsequent argument list lines when at + least one argument follows on the same + line as the arglist opening paren. + arglist-close -- The solo close paren of an argument list. + stream-op -- Lines continuing a stream operator construct. + inclass -- The construct is nested inside a class definition. + Used together with e.g. `topmost-intro'. + cpp-macro -- The start of a C preprocessor macro definition. + cpp-macro-cont -- Inside a multi-line C preprocessor macro definition. + friend -- A C++ friend declaration. + objc-method-intro -- The first line of an Objective-C method definition. + objc-method-args-cont -- Lines continuing an Objective-C method definition. + objc-method-call-cont -- Lines continuing an Objective-C method call. + extern-lang-open -- Brace that opens an \"extern\" block. + extern-lang-close -- Brace that closes an \"extern\" block. + inextern-lang -- Analogous to the `inclass' syntactic symbol, + but used inside \"extern\" blocks. + namespace-open, namespace-close, innamespace + -- Similar to the three `extern-lang' symbols, but for + C++ \"namespace\" blocks. + module-open, module-close, inmodule + -- Similar to the three `extern-lang' symbols, but for + CORBA IDL \"module\" blocks. + composition-open, composition-close, incomposition + -- Similar to the three `extern-lang' symbols, but for + CORBA CIDL \"composition\" blocks. + template-args-cont -- C++ template argument list continuations. + inlambda -- In the header or body of a lambda function. + lambda-intro-cont -- Continuation of the header of a lambda function. + inexpr-statement -- The statement is inside an expression. + inexpr-class -- The class is inside an expression. Used e.g. for + Java anonymous classes." + :type + `(set :format "%{%t%}: + Override style setting + | Syntax Offset +%v" + ,@(mapcar + (lambda (elt) + `(cons :format "%v" + :value ,elt + ,(c-constant-symbol (car elt) 25) + (sexp :format "%v" + :validate + (lambda (widget) + (unless (c-valid-offset (widget-value widget)) + (widget-put widget :error "Invalid offset") + widget))))) + (get 'c-offsets-alist 'c-stylevar-fallback))) + :group 'c) + (defun c-valid-offset (offset) "Return non-nil if OFFSET is a valid offset for a syntactic symbol. See `c-offsets-alist'." @@ -218,7 +404,9 @@ See `c-offsets-alist'." (eq offset '/) (integerp offset) (functionp offset) - (and (symbolp offset) (boundp offset)) + (and (symbolp offset) + (or (boundp offset) + (assq offset c-offsets-alist))) (and (vectorp offset) (= (length offset) 1) (integerp (elt offset 0))) @@ -1141,6 +1329,18 @@ can always override the use of `c-default-style' by making calls to ;; token. (brace-entry-open . 0) ;; Anchor pos: Same as brace-list-entry. + (enum-open . class-open) + ;; Anchor pos: At the statement(*) at boi of the start of the + ;; enum construct. + (enum-close . 0) + ;; Anchor pos: At the enum block open. + (enum-intro . +) + ;; Anchor pos: The opening brace position when at boi, or boi + ;; at the enum decl start(*). + (enum-entry . 0) + ;; Anchor pos: Normally, boi of the line containing the + ;; previous token, but if that line also contains the opening + ;; brace, then the first token after that brace. (statement . 0) ;; Anchor pos: After a `;' in the condition clause of a for ;; statement: At the first token after the starting paren. @@ -1240,191 +1440,6 @@ can always override the use of `c-default-style' by making calls to (inexpr-class . +) ;; Anchor pos: None. )) -(defcustom c-offsets-alist nil - "Alist of syntactic element symbols and indentation offsets. -As described below, each cons cell in this list has the form: - - (SYNTACTIC-SYMBOL . OFFSET) - -When a line is indented, CC Mode first determines the syntactic -context of it by generating a list of symbols called syntactic -elements. The global variable `c-syntactic-context' is bound to that -list. Each element in the list is in turn a list where the first -element is a syntactic symbol which tells what kind of construct the -indentation point is located within. More elements in the syntactic -element lists are optional. If there is one more and it isn't nil, -then it's the anchor position for that construct. - -After generating the syntactic context for the line, CC Mode -calculates the absolute indentation: First the base indentation is -found by using the anchor position for the first syntactic element -that provides one. If none does, zero is used as base indentation. -Then CC Mode looks at each syntactic element in the context in turn. -It compares the car of the syntactic element against the -SYNTACTIC-SYMBOL's in `c-offsets-alist'. When it finds a match, it -adds OFFSET to the base indentation. The sum of this calculation is -the absolute offset for line being indented. - -If the syntactic element does not match any in the `c-offsets-alist', -the element is ignored. - -OFFSET can specify an offset in several different ways: - - If OFFSET is nil then it's ignored. - - If OFFSET is an integer then it's used as relative offset, i.e. it's - added to the base indentation. - - If OFFSET is one of the symbols `+', `-', `++', `--', `*', or `/' - then a positive or negative multiple of `c-basic-offset' is added to - the base indentation; 1, -1, 2, -2, 0.5, and -0.5, respectively. - - If OFFSET is a symbol with a value binding then that value, which - must be an integer, is used as relative offset. - - If OFFSET is a vector then its first element, which must be an - integer, is used as an absolute indentation column. This overrides - the previous base indentation and the relative offsets applied to - it, and it becomes the new base indentation. - - If OFFSET is a function or a lambda expression then it's called with - a single argument containing the cons of the syntactic symbol and - the anchor position (or nil if there is none). The return value - from the function is then reinterpreted as an offset specification. - - If OFFSET is a list then its elements are evaluated recursively as - offset specifications. If the first element is any of the symbols - below then it isn't evaluated but instead specifies how the - remaining offsets in the list should be combined. If it's something - else then the list is combined according the method `first'. The - valid combination methods are: - - `first' -- Use the first offset (that doesn't evaluate to nil). - `min' -- Use the minimum of all the offsets. All must be either - relative or absolute - they can't be mixed. - `max' -- Use the maximum of all the offsets. All must be either - relative or absolute - they can't be mixed. - `add' -- Add all the evaluated offsets together. Exactly one of - them may be absolute, in which case the result is - absolute. Any relative offsets that preceded the - absolute one in the list will be ignored in that case. - -`c-offsets-alist' is a style variable. This means that the offsets on -this variable are normally taken from the style system in CC Mode -\(see `c-default-style' and `c-style-alist'). However, any offsets -put explicitly on this list will override the style system when a CC -Mode buffer is initialized (there is a variable -`c-old-style-variable-behavior' that changes this, though). - -Here is the current list of valid syntactic element symbols: - - string -- Inside multi-line string. - c -- Inside a multi-line C style block comment. - defun-open -- Brace that opens a function definition. - defun-close -- Brace that closes a function definition. - defun-block-intro -- The first line in a top-level defun. - class-open -- Brace that opens a class definition. - class-close -- Brace that closes a class definition. - inline-open -- Brace that opens an in-class inline method. - inline-close -- Brace that closes an in-class inline method. - func-decl-cont -- The region between a function definition's - argument list and the function opening brace - (excluding K&R argument declarations). In C, you - cannot put anything but whitespace and comments - between them; in C++ and Java, throws declarations - and other things can appear in this context. - knr-argdecl-intro -- First line of a K&R C argument declaration. - knr-argdecl -- Subsequent lines in a K&R C argument declaration. - topmost-intro -- The first line in a topmost construct definition. - topmost-intro-cont -- Topmost definition continuation lines. - constraint-cont -- Continuation line of a C++ requires clause (not - to be confused with a \"requires expression\") or - concept. - annotation-top-cont -- Topmost definition continuation line where only - annotations are on previous lines. - annotation-var-cont -- A continuation of a C (or like) statement where - only annotations are on previous lines. - member-init-intro -- First line in a member initialization list. - member-init-cont -- Subsequent member initialization list lines. - inher-intro -- First line of a multiple inheritance list. - inher-cont -- Subsequent multiple inheritance lines. - block-open -- Statement block open brace. - block-close -- Statement block close brace. - brace-list-open -- Open brace of an enum or static array list. - brace-list-close -- Close brace of an enum or static array list. - brace-list-intro -- First line in an enum or static array list. - brace-list-entry -- Subsequent lines in an enum or static array list. - brace-entry-open -- Subsequent lines in an enum or static array - list that start with an open brace. - statement -- A C (or like) statement. - statement-cont -- A continuation of a C (or like) statement. - statement-block-intro -- The first line in a new statement block. - statement-case-intro -- The first line in a case \"block\". - statement-case-open -- The first line in a case block starting with brace. - substatement -- The first line after an if/while/for/do/else. - substatement-open -- The brace that opens a substatement block. - substatement-label -- Labeled line after an if/while/for/do/else. - case-label -- A \"case\" or \"default\" label. - access-label -- C++ private/protected/public access label. - label -- Any ordinary label. - do-while-closure -- The \"while\" that ends a do/while construct. - else-clause -- The \"else\" of an if/else construct. - catch-clause -- The \"catch\" or \"finally\" of a try/catch construct. - comment-intro -- A line containing only a comment introduction. - arglist-intro -- The first line in an argument list. - arglist-cont -- Subsequent argument list lines when no - arguments follow on the same line as the - arglist opening paren. - arglist-cont-nonempty -- Subsequent argument list lines when at - least one argument follows on the same - line as the arglist opening paren. - arglist-close -- The solo close paren of an argument list. - stream-op -- Lines continuing a stream operator construct. - inclass -- The construct is nested inside a class definition. - Used together with e.g. `topmost-intro'. - cpp-macro -- The start of a C preprocessor macro definition. - cpp-macro-cont -- Inside a multi-line C preprocessor macro definition. - friend -- A C++ friend declaration. - objc-method-intro -- The first line of an Objective-C method definition. - objc-method-args-cont -- Lines continuing an Objective-C method definition. - objc-method-call-cont -- Lines continuing an Objective-C method call. - extern-lang-open -- Brace that opens an \"extern\" block. - extern-lang-close -- Brace that closes an \"extern\" block. - inextern-lang -- Analogous to the `inclass' syntactic symbol, - but used inside \"extern\" blocks. - namespace-open, namespace-close, innamespace - -- Similar to the three `extern-lang' symbols, but for - C++ \"namespace\" blocks. - module-open, module-close, inmodule - -- Similar to the three `extern-lang' symbols, but for - CORBA IDL \"module\" blocks. - composition-open, composition-close, incomposition - -- Similar to the three `extern-lang' symbols, but for - CORBA CIDL \"composition\" blocks. - template-args-cont -- C++ template argument list continuations. - inlambda -- In the header or body of a lambda function. - lambda-intro-cont -- Continuation of the header of a lambda function. - inexpr-statement -- The statement is inside an expression. - inexpr-class -- The class is inside an expression. Used e.g. for - Java anonymous classes." - :type - `(set :format "%{%t%}: - Override style setting - | Syntax Offset -%v" - ,@(mapcar - (lambda (elt) - `(cons :format "%v" - :value ,elt - ,(c-constant-symbol (car elt) 25) - (sexp :format "%v" - :validate - (lambda (widget) - (unless (c-valid-offset (widget-value widget)) - (widget-put widget :error "Invalid offset") - widget))))) - (get 'c-offsets-alist 'c-stylevar-fallback))) - :group 'c) ;; The syntactic symbols that can occur inside code blocks. Used by ;; `c-gnu-impose-minimum'. diff --git a/lisp/progmodes/cmake-ts-mode.el b/lisp/progmodes/cmake-ts-mode.el index 854adf4ade7..597ef69d9b8 100644 --- a/lisp/progmodes/cmake-ts-mode.el +++ b/lisp/progmodes/cmake-ts-mode.el @@ -208,7 +208,7 @@ Return nil if there is no name or if NODE is not a defun node." :syntax-table cmake-ts-mode--syntax-table (when (treesit-ready-p 'cmake) - (treesit-parser-create 'cmake) + (setq treesit-primary-parser (treesit-parser-create 'cmake)) ;; Comments. (setq-local comment-start "# ") diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index d2e74aa44a6..2b9d355795e 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1405,12 +1405,12 @@ POS and RES.") 2))) ;; Remove matches like /bin/sh and do other file name transforms. (save-match-data - (when-let ((file-name - (and (consp file) - (not (bufferp (car file))) - (if (cdr file) - (expand-file-name (car file) (cdr file)) - (car file))))) + (when-let* ((file-name + (and (consp file) + (not (bufferp (car file))) + (if (cdr file) + (expand-file-name (car file) (cdr file)) + (car file))))) (cl-loop for (regexp replacement) in compilation-transform-file-match-alist when (string-match regexp file-name) @@ -1832,6 +1832,7 @@ to a function that generates a unique name." (compilation-start command comint)) ;; run compile with the default command line +;;;###autoload (defun recompile (&optional edit-command) "Re-compile the program including the current buffer. If this is run in a Compilation mode buffer, reuse the arguments from the @@ -2855,6 +2856,53 @@ as a last resort." (current-buffer) (next-error-find-buffer avoid-current 'compilation-buffer-internal-p))) +(defun compilation--update-markers (loc marker screen-columns first-column) + "Update markers in LOC, and set MARKER to location pointed by LOC. +SCREEN-COLUMNS and FIRST-COLUMN are the value of +`compilation-error-screen-columns' and `compilation-first-column' to use +if they are not set buffer-locally in the target buffer." + (with-current-buffer + (if (bufferp (caar (compilation--loc->file-struct loc))) + (caar (compilation--loc->file-struct loc)) + (apply #'compilation-find-file + marker + (caar (compilation--loc->file-struct loc)) + (cadr (car (compilation--loc->file-struct loc))) + (compilation--file-struct->formats + (compilation--loc->file-struct loc)))) + (let ((screen-columns + ;; Obey the compilation-error-screen-columns of the target + ;; buffer if its major mode set it buffer-locally. + (if (local-variable-p 'compilation-error-screen-columns) + compilation-error-screen-columns screen-columns)) + (compilation-first-column + (if (local-variable-p 'compilation-first-column) + compilation-first-column first-column)) + (last 1)) + (save-restriction + (widen) + (goto-char (point-min)) + ;; Treat file's found lines in forward order, 1 by 1. + (dolist (line (reverse (cddr (compilation--loc->file-struct loc)))) + (when (car line) ; else this is a filename without a line# + (compilation-beginning-of-line (- (car line) last -1)) + (setq last (car line))) + ;; Treat line's found columns and store/update a marker for each. + (dolist (col (cdr line)) + (if (compilation--loc->col col) + (if (eq (compilation--loc->col col) -1) + ;; Special case for range end. + (end-of-line) + (compilation-move-to-column (compilation--loc->col col) + screen-columns)) + (beginning-of-line) + (skip-chars-forward " \t")) + (if (compilation--loc->marker col) + (set-marker (compilation--loc->marker col) (point)) + (setf (compilation--loc->marker col) (point-marker))) + ;; (setf (compilation--loc->timestamp col) timestamp) + )))))) + ;;;###autoload (defun compilation-next-error-function (n &optional reset) "Advance to the next error message and visit the file where the error was. @@ -2864,7 +2912,6 @@ This is the value of `next-error-function' in Compilation buffers." (setq compilation-current-error nil)) (let* ((screen-columns compilation-error-screen-columns) (first-column compilation-first-column) - (last 1) (msg (compilation-next-error (or n 1) nil (or compilation-current-error compilation-messages-start @@ -2876,9 +2923,9 @@ This is the value of `next-error-function' in Compilation buffers." (user-error "No next error")) (setq compilation-current-error (point-marker) overlay-arrow-position - (if (bolp) - compilation-current-error - (copy-marker (line-beginning-position)))) + (if (bolp) + compilation-current-error + (copy-marker (line-beginning-position)))) ;; If loc contains no marker, no error in that file has been visited. ;; If the marker is invalid the buffer has been killed. ;; So, recalculate all markers for that file. @@ -2895,46 +2942,7 @@ This is the value of `next-error-function' in Compilation buffers." ;; (equal (compilation--loc->timestamp loc) ;; (setq timestamp compilation-buffer-modtime))) ) - (with-current-buffer - (if (bufferp (caar (compilation--loc->file-struct loc))) - (caar (compilation--loc->file-struct loc)) - (apply #'compilation-find-file - marker - (caar (compilation--loc->file-struct loc)) - (cadr (car (compilation--loc->file-struct loc))) - (compilation--file-struct->formats - (compilation--loc->file-struct loc)))) - (let ((screen-columns - ;; Obey the compilation-error-screen-columns of the target - ;; buffer if its major mode set it buffer-locally. - (if (local-variable-p 'compilation-error-screen-columns) - compilation-error-screen-columns screen-columns)) - (compilation-first-column - (if (local-variable-p 'compilation-first-column) - compilation-first-column first-column))) - (save-restriction - (widen) - (goto-char (point-min)) - ;; Treat file's found lines in forward order, 1 by 1. - (dolist (line (reverse (cddr (compilation--loc->file-struct loc)))) - (when (car line) ; else this is a filename without a line# - (compilation-beginning-of-line (- (car line) last -1)) - (setq last (car line))) - ;; Treat line's found columns and store/update a marker for each. - (dolist (col (cdr line)) - (if (compilation--loc->col col) - (if (eq (compilation--loc->col col) -1) - ;; Special case for range end. - (end-of-line) - (compilation-move-to-column (compilation--loc->col col) - screen-columns)) - (beginning-of-line) - (skip-chars-forward " \t")) - (if (compilation--loc->marker col) - (set-marker (compilation--loc->marker col) (point)) - (setf (compilation--loc->marker col) (point-marker))) - ;; (setf (compilation--loc->timestamp col) timestamp) - )))))) + (compilation--update-markers loc marker screen-columns first-column)) (compilation-goto-locus marker (compilation--loc->marker loc) (compilation--loc->marker end-loc)) (setf (compilation--loc->visited loc) t))) @@ -3223,7 +3231,7 @@ we try to avoid if possible." (with-current-buffer (marker-buffer marker) (save-excursion (goto-char (marker-position marker)) - (when-let ((prev (compilation--previous-directory (point)))) + (when-let* ((prev (compilation--previous-directory (point)))) (goto-char prev)) (setq dirs (cdr (or (get-text-property (1- (point)) 'compilation-directory) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index e129e2df552..87ff3e86a41 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -88,6 +88,9 @@ (defvar vc-sccs-header) (defun cperl-choose-color (&rest list) + "Old-fashioned way to set colors for syntax highlighting. +Affects faces specific to `cperl-mode` only. +Optional argument LIST defines the attribute list for the face." (let (answer) (while list (or answer @@ -139,8 +142,9 @@ indentation styles." (defcustom cperl-extra-newline-before-brace nil - "Non-nil means that if, elsif, while, until, else, for, foreach -and do constructs look like: + "Non-nil means that code blocks start on a new line. +This affects if, elsif, while, until, else, for, foreach and do +constructs look like: if () { @@ -155,8 +159,9 @@ instead of: (defcustom cperl-extra-newline-before-brace-multiline cperl-extra-newline-before-brace - "Non-nil means the same as `cperl-extra-newline-before-brace', but -for constructs with multiline if/unless/while/until/for/foreach condition." + "Non-nil means the same as `cperl-extra-newline-before-brace'. +It is effective for constructs with multiline +if/unless/while/until/for/foreach condition." :type 'boolean :group 'cperl-autoinsert-details) @@ -254,11 +259,11 @@ This applies to, for example, hash values." :group 'cperl-indentation-details) (defcustom cperl-auto-newline nil - "Non-nil means automatically newline before and after braces, -and after colons and semicolons, inserted in CPerl code. The following -\\[cperl-electric-backspace] will remove the inserted whitespace. -Insertion after colons requires both this variable and -`cperl-auto-newline-after-colon' set." + "Non-nil means automatically insert a newline between phrases. +This happens before and after braces and after colons and semicolons, +inserted in CPerl code. The following \\[cperl-electric-backspace] will +remove the inserted whitespace. Insertion after colons requires both +this variable and `cperl-auto-newline-after-colon' set." :type 'boolean :group 'cperl-autoinsert-details) @@ -275,8 +280,9 @@ Subject to `cperl-auto-newline' setting." :group 'cperl-autoinsert-details) (defcustom cperl-tab-always-indent t - "Non-nil means TAB in CPerl mode should always reindent the current line, -regardless of where in the line point is when the TAB command is used." + "Non-nil means TAB in CPerl mode should always reindent the current line. +This does not depend on where in the line point is when the TAB command +is used." :type 'boolean :group 'cperl-indentation-details) @@ -311,7 +317,8 @@ Default is yes if there is visual feedback on mark." :group 'cperl-autoinsert-details) (defcustom cperl-electric-linefeed nil - "If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. + "If true, LFD should be hairy in CPerl. +Otherwise, \\<cperl-mode-map>\\[newline-and-indent] is hairy. In any case these two mean plain and hairy linefeeds together. Can be overwritten by `cperl-hairy' if nil." :type '(choice (const null) boolean) @@ -366,7 +373,7 @@ Affects: `cperl-font-lock', `cperl-electric-lbrace-space', (defcustom cperl-info-on-command-no-prompt nil "Not-nil (and non-null) means not to prompt on \\[cperl-info-on-command]. -The opposite behavior is always available if prefixed with C-c. +The opposite behavior is always available if prefixed with Control-c. Can be overwritten by `cperl-hairy' if nil." :type '(choice (const null) boolean) :group 'cperl-affected-by-hairy) @@ -519,27 +526,29 @@ Values other than 1 and nil will probably not work." :group 'cperl-indentation-details) (defcustom cperl-break-one-line-blocks-when-indent t - "Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs -need to be reformatted into multiline ones when indenting a region." + "Non-nil means that one-line blocks are reformatted when indenting. +Code blocks after if/unless/while/until/for/foreach need to be +reformatted into multiline ones when indenting a region." :type 'boolean :group 'cperl-indentation-details) (defcustom cperl-fix-hanging-brace-when-indent t - "Non-nil means that BLOCK-end `}' may be put on a separate line -when indenting a region. -Braces followed by else/elsif/while/until are excepted." + "Non-nil means that BLOCK-end `}' may be put on a separate line. +This happens when indenting a region. Braces followed by +else/elsif/while/until are excepted." :type 'boolean :group 'cperl-indentation-details) (defcustom cperl-merge-trailing-else t - "Non-nil means that BLOCK-end `}' followed by else/elsif/continue -may be merged to be on the same line when indenting a region." + "Controls indentation of block-end `}' followed by else/elsif/continue. +If non-nil, then these block-end braces may be merged to be on the same +line when indenting a region." :type 'boolean :group 'cperl-indentation-details) (defcustom cperl-indent-parens-as-block nil - "Non-nil means that non-block ()-, {}- and []-groups are indented as blocks, -but for trailing \",\" inside the group, which won't increase indentation. + "Non-nil means that non-block ()-, {}- and []-groups are indented as blocks. +However, trailing \",\" inside the group, won't increase indentation. One should tune up `cperl-close-paren-offset' as well." :type 'boolean :group 'cperl-indentation-details) @@ -551,7 +560,8 @@ One should tune up `cperl-close-paren-offset' as well." (defcustom cperl-syntaxify-unwind t - "Non-nil means that CPerl unwinds to a start of a long construction + "Controls the accuracy of syntaxification. +Non-nil means that CPerl unwinds to a start of a long construction when syntaxifying a chunk of buffer." :type 'boolean :group 'cperl-speed) @@ -644,7 +654,9 @@ imenu entries." ;;; Short extra-docs. (defvar cperl-tips 'please-ignore-this-line - "If your Emacs does not default to `cperl-mode' on Perl files, and you + "Some tips for using `cperl-mode'. + +If your Emacs does not default to `cperl-mode' on Perl files, and you want it to: put the following into your .emacs file: (add-to-list \\='major-mode-remap-alist \\='(perl-mode . cperl-mode)) @@ -669,7 +681,7 @@ editing, sometimes it may be lost. Fix this by In cases of more severe confusion sometimes it is helpful to do - \\[load-library] cperl-mode RET + \\[load-library] `cperl-mode' RET \\[normal-mode] Before reporting (non-)problems look in the problem section of online @@ -682,7 +694,8 @@ paragraph. It also triggers a bug in some versions of Emacs (CPerl tries to detect it and bulk out).") (defvar cperl-problems-old-emaxen 'please-ignore-this-line - "This used to contain a description of problems in CPerl mode + "Obsolete hints for outdated Emacs versions. +This used to contain a description of problems in CPerl mode specific for very old Emacs versions. This is no longer relevant and has been removed.") (make-obsolete-variable 'cperl-problems-old-emaxen nil "28.1") @@ -775,8 +788,12 @@ line-breaks/spacing between elements of the construct. 11) Syntax-highlight, indentation, sexp-recognition inside regular expressions.") (defvar cperl-speed 'please-ignore-this-line - "This is an incomplete compendium of what is available in other parts -of CPerl documentation. (Please inform me if I skipped anything.) + "Considerations about performance of `cperl-mode'. + +This is an incomplete compendium of what is available in other parts +of CPerl documentation. Nowadays the performance of `cperl-mode' +is not as relevant as it used to be when this was written. +\(Please inform me if I skipped anything.) There is a perception that CPerl is slower than alternatives. This part of documentation is designed to overcome this misconception. @@ -858,7 +875,8 @@ In regular expressions (including character classes): we couldn't match, misplaced quantifiers, unrecognized escape sequences `cperl-nonoverridable-face' Modifiers, as gism in m/REx/gism - `font-lock-type-face' escape sequences with arguments (\\x \\23 \\p \\N) + `font-lock-type-face' escape sequences with arguments + (\\x \\23 \\p \\N) and others match-a-char escape sequences `font-lock-keyword-face' Capturing parens, and | `font-lock-function-name-face' Special symbols: $ ^ . [ ] [^ ] (?{ }) (??{ }) @@ -883,11 +901,13 @@ In regular expressions (including character classes): (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) (defun cperl-putback-char (c) + "Obsolete. Put C back to the event loop." (declare (obsolete nil "29.1")) (push c unread-command-events)) (defsubst cperl-put-do-not-fontify (from to &optional post) - ;; If POST, do not do it with postponed fontification + "Pretend that text between FROM and TO is already fontified. +If POST, do not do it with postponed fontification" (if (and post cperl-syntaxify-by-font-lock) nil (put-text-property (max (point-min) (1- from)) @@ -903,6 +923,9 @@ In regular expressions (including character classes): ;; Make customization possible "in reverse" (defsubst cperl-val (symbol &optional default hairy) + "Internal feature to distinguish SYMBOL between \"uncustomized\" and nil. +Apply DEFAULT if nil, use HAIRY if `cperl-hairy' is non-nil. Use the +symbol's value otherwise." (cond ((eq (symbol-value symbol) 'null) default) (cperl-hairy (or hairy t)) @@ -1574,7 +1597,8 @@ Should contain exactly one group.") "Match the text after `sub' in a subroutine declaration. If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\" of attributes (if present), or end of the name or prototype (whatever is -the last)." +the last). +If ATTR is non-nil, also capture the attributes." (concat ; Assume n groups before this... "\\(" ; n+1=name-group cperl-white-and-comment-rex ; n+2=pre-name @@ -1658,11 +1682,14 @@ the last)." "Syntax table in use in CPerl mode string-like chunks.") (defsubst cperl-1- (p) + "Decreases a position from P, but does not go before `point-min'." (max (point-min) (1- p))) (defsubst cperl-1+ (p) + "Increases a position from P, but does not go beyond `point-max'." (min (point-max) (1+ p))) + (defvar cperl-faces-init nil) ;; Fix for msb.el @@ -1825,7 +1852,7 @@ Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith CPerl knows several indentation styles, and may bulk set the corresponding variables. Use \\[cperl-set-style] to do this or -set the `cperl-file-style' user option. Use +set the variable `cperl-file-style' user option. Use \\[cperl-set-style-back] to restore the memorized preexisting values \(both available from menu). See examples in `cperl-style-examples'. @@ -1972,12 +1999,16 @@ or as help on variables `cperl-tips', `cperl-problems', (derived-mode-add-parents 'cperl-mode '(perl-mode))) (defun cperl--set-file-style () + "Set the file style according to the variable `cperl-file-style'. +Do nothing if the variable is nil." (when cperl-file-style (cperl-file-style cperl-file-style))) ;; Fix for perldb - make default reasonable (defun cperl-db () + "Obsolete workaround for an outdated issue with `perldb'." + (declare (obsolete 'perldb "31.1")) (interactive) (require 'gud) ;; FIXME: Use `read-string' or `read-shell-command'? @@ -1990,7 +2021,7 @@ or as help on variables `cperl-tips', `cperl-problems', '(gud-perldb-history . 1)))) (defun cperl-msb-fix () - ;; Adds perl files to msb menu, supposes that msb is already loaded + "Add perl files to msb menu, supposes that msb is already loaded." (setq cperl-msb-fixed t) (let* ((l (length msb-menu-cond)) (last (nth (1- l) msb-menu-cond)) @@ -2016,7 +2047,8 @@ or as help on variables `cperl-tips', `cperl-problems', (defvar cperl-st-ket '(5 . ?\<)) -(defun cperl-comment-indent () ; called at point at supposed comment +(defun cperl-comment-indent () + "Called at point at supposed comment." (let ((p (point)) (c (current-column)) was phony) (if (and (not cperl-indent-comment-at-column-0) (looking-at "^#")) @@ -2058,15 +2090,15 @@ or as help on variables `cperl-tips', `cperl-problems', (forward-char (length comment-start)))))) (defun cperl-comment-region (b e arg) - "Comment or uncomment each line in the region in CPerl mode. -See `comment-region'." + "Comment or uncomment each line in the region between B and E. +ARG is passed to `comment-region', which see." (interactive "r\np") (let ((comment-start "#")) (comment-region b e arg))) (defun cperl-uncomment-region (b e arg) - "Uncomment or comment each line in the region in CPerl mode. -See `comment-region'." + "Uncomment or comment each line in the region between B and E. +ARG is passed to `comment-region', which see." (interactive "r\np") (let ((comment-start "#")) (comment-region b e (- arg)))) @@ -2074,7 +2106,7 @@ See `comment-region'." (defvar cperl-brace-recursing nil) (defun cperl-electric-brace (arg &optional only-before) - "Insert character and correct line's indentation. + "Insert character ARG and correct line's indentation. If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the place (even in empty line), but not after. If after \")\" and the inserted char is \"{\", insert extra newline before only if @@ -2148,7 +2180,8 @@ char is \"{\", insert extra newline before only if (self-insert-command (prefix-numeric-value arg))))))) (defun cperl-electric-lbrace (arg &optional end) - "Insert character, correct line's indentation, correct quoting by space." + "Insert character ARG, correct line's indentation, correct quoting by space. +Do not look beyond END." (interactive "P") (let ((cperl-brace-recursing t) (cperl-auto-newline cperl-auto-newline) @@ -2188,7 +2221,8 @@ char is \"{\", insert extra newline before only if (defun cperl-electric-paren (arg) "Insert an opening parenthesis or a matching pair of parentheses. -See `cperl-electric-parens'." +See `cperl-electric-parens'. +Argument ARG is the opening parenthesis." (interactive "P") (let ((other-end (if (and cperl-electric-parens-mark (region-active-p) @@ -2223,7 +2257,8 @@ See `cperl-electric-parens'." (defun cperl-electric-rparen (arg) "Insert a matching pair of parentheses if marking is active. If not, or if we are not at the end of marking range, would self-insert. -Affected by `cperl-electric-parens'." +Affected by `cperl-electric-parens'. +Argument ARG is the closing parenthesis." (interactive "P") (let ((other-end (if (and cperl-electric-parens-mark (cperl-val 'cperl-electric-parens) @@ -2324,7 +2359,8 @@ to nil." (message "Precede char by C-q to avoid expansion")))))) (defun cperl-ensure-newlines (n &optional pos) - "Make sure there are N newlines after the point." + "Make sure there are N newlines after the point. +Go to POS which defaults to the current point after processing." (or pos (setq pos (point))) (if (looking-at "\n") (forward-char 1) @@ -2538,7 +2574,8 @@ If in POD, insert appropriate lines." (newline-and-indent)))))) (defun cperl-electric-semi (arg) - "Insert character and correct line's indentation." + "Insert character and correct line's indentation. +ARG is the character to insert." (interactive "P") (if cperl-auto-newline (cperl-electric-terminator arg) @@ -2547,7 +2584,8 @@ If in POD, insert appropriate lines." (cperl-indent-line)))) (defun cperl-electric-terminator (arg) - "Insert character and correct line's indentation." + "Insert character and correct line's indentation. +ARG is the character to insert." (interactive "P") (let ((end (point)) (auto (and cperl-auto-newline @@ -2598,7 +2636,8 @@ If in POD, insert appropriate lines." (defun cperl-electric-backspace (arg) "Backspace, or remove whitespace around the point inserted by an electric key. -Will untabify if `cperl-electric-backspace-untabify' is non-nil." +Will untabify if `cperl-electric-backspace-untabify' is non-nil. +ARG is the key which caused the action." (interactive "p") (if (and cperl-auto-newline (memq last-command '(cperl-electric-semi @@ -2629,6 +2668,7 @@ Will untabify if `cperl-electric-backspace-untabify' is non-nil." (put 'cperl-electric-backspace 'delete-selection 'supersede) (defun cperl-inside-parens-p () + "Obsolete function, unused." (declare (obsolete nil "28.1")) ; not used (condition-case () (save-excursion @@ -2648,7 +2688,8 @@ or in the line's indentation; otherwise insert a tab. A numeric argument, regardless of its value, means indent rigidly all the lines of the expression starting after point so that this line becomes properly indented. -The relative indentation among the lines of the expression are preserved." +The relative indentation among the lines of the expression are preserved. +If WHOLE-EXP is non-nil, indent the whole expression." (interactive "P") (cperl-update-syntaxification (point)) (if whole-exp @@ -2676,7 +2717,8 @@ The relative indentation among the lines of the expression are preserved." (defun cperl-indent-line (&optional parse-data) "Indent current line as Perl code. -Return the amount the indentation changed by." +Return the amount the indentation changed by. +PARSE-DATA is used to save status between calls in a loop." (let ((case-fold-search nil) (pos (- (point-max) (point))) indent i shift-amt) @@ -2720,7 +2762,7 @@ Return the amount the indentation changed by." shift-amt)) (defun cperl-after-label () - ;; Returns true if the point is after label. Does not do save-excursion. + "Return non-nil if the point is after label. Does not do `save-excursion'." (and (eq (preceding-char) ?:) (memq (char-syntax (char-after (- (point) 2))) '(?w ?_)) @@ -2736,7 +2778,8 @@ PARSE-START if preset. STATE is what is returned by `parse-partial-sexp'. DEPTH is true is we are immediately after end of block which contains START. -PRESTART is the position basing on which START was found." +PRESTART is the position basing on which START was found. +START-STATE should be a good guess for the start of a function." (save-excursion (let ((start-point (point)) depth state start prestart) (if (and parse-start @@ -2766,7 +2809,7 @@ PRESTART is the position basing on which START was found." (defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) (defun cperl-beginning-of-property (p prop &optional lim) - "Given that P has a property PROP, find where the property starts. + "Given that P has a property PROP, find where the property start. Will not look before LIM." ;; XXXX What to do at point-max??? (or (previous-single-property-change (cperl-1+ p) prop lim) @@ -2782,7 +2825,7 @@ Will not look before LIM." ) (defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start - ;; the sniffer logic to understand what the current line MEANS. + "Find out what the current line means, based on the given PARSE-DATA." (cperl-update-syntaxification (point)) (let ((res (get-text-property (point) 'syntax-type))) (save-excursion @@ -3089,6 +3132,7 @@ The values mean: (defun cperl-calculate-indent (&optional parse-data) ; was parse-start "Return appropriate indentation for current line as Perl code. +PARSE-DATA is the result of a previous call to speed up things. In usual case returns an integer: the column to indent to. Returns nil if line starts inside a string, t if in a comment. @@ -3344,13 +3388,15 @@ Returns true if comment is found. In POD will not move the point." (nth 4 state)))) (defsubst cperl-modify-syntax-type (at how) + "Modify the syntax-table text properties at AT as given by HOW." (if (< at (point-max)) (progn (put-text-property at (1+ at) 'syntax-table how) (put-text-property at (1+ at) 'rear-nonsticky '(syntax-table))))) (defun cperl-protect-defun-start (s e) - ;; C code looks for "^\\s(" to skip comment backward in "hard" situations + "Mark parentheses as punctuation between S and E. +C code looks for \"^\\s(\" to skip comment backward in \"hard\" situations." (save-excursion (goto-char s) (while (re-search-forward "^\\s(" e 'to-end) @@ -3688,7 +3734,8 @@ newer. To activate the extra delimiters, switch on the minor mode `cperl-extra-paired-delimiters-mode'. This is also available from the \"Perl\" menu in section \"Toggle...\". The character pairs available are: -(), <>, [], {}, «», »«, ༺༻, ༼༽, ᚛᚜, \\=‘\\=’, \\=’\\=‘, \\=“\\=”, \\=”\\=“, \\=‵\\=′, \\=‶\\=″, \\=‷\\=‴, ‹›, ›‹, ⁅⁆, +\(), <>, [], {}, «», »«, ༺༻, ༼༽, ᚛᚜, \\=‘\\=’, \\=’\\=‘, \\=“\\=”, \\=”\\=“, +\\=‵\\=′, \\=‶\\=″, \\=‷\\=‴, ‹›, ›‹, ⁅⁆, ⁍⁌, ⁽⁾, ₍₎, →←, ↛↚, ↝↜, ↠↞, ↣↢, ↦↤, ↪↩, ↬↫, ↱↰, ↳↲, ⇀↼, ⇁↽, ⇉⇇, ⇏⇍, ⇒⇐, ⇛⇚, ⇝⇜, ⇢⇠, ⇥⇤, ⇨⇦, ⇴⬰, ⇶⬱, ⇸⇷, ⇻⇺, ⇾⇽, ∈∋, ∉∌, ∊∍, ≤≥, ≦≧, ≨≩, ≪≫, ≮≯, ≰≱, ≲≳, ≴≵, ≺≻, ≼≽, ≾≿, ⊀⊁, ⊂⊃, ⊄⊅, ⊆⊇, ⊈⊉, ⊊⊋, ⊣⊢, ⊦⫞, ⊨⫤, ⊩⫣, ⊰⊱, ⋐⋑, ⋖⋗, ⋘⋙, ⋜⋝, @@ -3832,7 +3879,8 @@ modify syntax-type text property if the situation is too hard." (defun cperl-forward-group-in-re (&optional st-l) "Find the end of a group in a REx. Return the error message (if any). Does not work if delimiter is `)'. -Works before syntax recognition is done." +Works before syntax recognition is done. +ST-L is a cached syntax table to use." ;; Works *before* syntax recognition is done (or st-l (setq st-l (list nil))) ; Avoid overwriting '() (let (st result reset-st) @@ -3856,7 +3904,14 @@ Works before syntax recognition is done." (defsubst cperl-postpone-fontification (b e type val &optional now) - ;; Do after syntactic fontification? + "Prepare text between B and E for postponed fontification. +TYPE is now always the symbol `face', VAL is the value (the actual face) +to be applied. This works by adding a text property `cperl-postpone' to +the range, which later is evaluated in the function +`cperl-fontify-update' which is inserted into the `font-lock-defaults'. +If `cperl-syntaxify-by-font-lock' is nil (which is not recommended), +then the text property TYPE is immediately set to VAL. +NOW is no longer useful." (if cperl-syntaxify-by-font-lock (or now (put-text-property b e 'cperl-postpone (cons type val))) (put-text-property b e type val))) @@ -3954,7 +4009,11 @@ position of the end of the unsafe construct." (defun cperl-find-sub-attrs (&optional st-l _b-fname _e-fname pos) "Syntactically mark (and fontify) attributes of a subroutine. -Should be called with the point before leading colon of an attribute." +Within attributes, parentheses and text between them have weird +syntactical properties which are likely to mess up search-based +fontification. Therefore they are fontified explicitly here. +Should be called with the point before leading colon of +an attribute. ST-L and POS are a cached from a previous call." ;; Works *before* syntax recognition is done (or st-l (setq st-l (list nil))) ; Avoid overwriting '() (let (st p reset-st after-first (start (point)) start1 end1) @@ -4033,6 +4092,9 @@ Should be called with the point before leading colon of an attribute." (set-syntax-table reset-st)))) (defsubst cperl-look-at-leading-count (is-x-REx e) + "Mark suspicious regexp content up to E. +If IS-X-REX is non-nil, then process a regular expression which has an +/x modifier." (if (and (< (point) e) (re-search-forward (concat "\\=" (if is-x-REx "[ \t\n]*" "") "[{?+*]") @@ -4045,6 +4107,10 @@ Should be called with the point before leading colon of an attribute." ;; Do some smarter-highlighting ;; XXXX Currently ignores alphanum/dash delims, (defsubst cperl-highlight-charclass (endbracket dashface bsface onec-space) + "Process the special syntax of character classes for fontification. +ENDBRACKET is the position of the closing bracket, DASHFACE, BSFACE and +ONEC-SPACE are the faces to be applied to a range indicator, characters +and character escapes, respectively." (let ((l '(1 5 7)) ll lle lll ;; 2 groups, the first takes the whole match (include \[trnfabe]) (singleChar (concat "\\(" "[^\\]" "\\|" "\\\\[^cdg-mo-qsu-zA-Z0-9_]" "\\|" "\\\\c." "\\|" "\\\\x" "\\([[:xdigit:]][[:xdigit:]]?\\|\\={[[:xdigit:]]+}\\)" "\\|" "\\\\0?[0-7][0-7]?[0-7]?" "\\|" "\\\\N{[^{}]*}" "\\)"))) @@ -5319,12 +5385,13 @@ recursive calls in starting lines of here-documents." (list (car err-l) overshoot))) (defun cperl-find-pods-heres-region (min max) + "Call `cperl-find-pods-heres' in the region between MIN and MAX." (interactive "r") (cperl-find-pods-heres min max)) (defun cperl-backward-to-noncomment (lim) - ;; Stops at lim or after non-whitespace that is not in comment - ;; XXXX Wrongly understands end-of-multiline strings with # as comment + "Go backward. Stop at LIM or after non-whitespace not in a comment." + ;;XXXX Wrongly understands end-of-multiline strings with # as comment" (let (stop p pr) (while (and (not stop) (> (point) (or lim (point-min)))) (skip-chars-backward " \t\n\f" lim) @@ -5345,7 +5412,7 @@ recursive calls in starting lines of here-documents." ;; Used only in `cperl-sniff-for-indent'... (defun cperl-block-p () - "Point is before ?\\{. Return true if it starts a block." + "Return non-nil if this is the start of a block. Point is before ?\\{." ;; No save-excursion! This is more a distinguisher of a block/hash ref... (cperl-backward-to-noncomment (point-min)) (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp @@ -5420,8 +5487,9 @@ statement would start; thus the block in ${func()} does not count." (defun cperl-after-expr-p (&optional lim chars test) "Return non-nil if the position is good for start of expression. TEST is the expression to evaluate at the found position. If absent, -CHARS is a string that contains good characters to have before us (however, -`}' is treated \"smartly\" if it is not in the list)." +CHARS is a string that contains good characters to have before +us (however, `}' is treated \"smartly\" if it is not in the list). LIM +is the minimal position to use." (let ((lim (or lim (point-min))) stop p) (cperl-update-syntaxification (point)) @@ -5469,6 +5537,7 @@ CHARS is a string that contains good characters to have before us (however, 'format))))))))) (defun cperl-backward-to-start-of-expr (&optional lim) + "Go backward to the start of the expression, but not before LIM." (condition-case nil (progn (while (and (or (not lim) @@ -5480,6 +5549,7 @@ CHARS is a string that contains good characters to have before us (however, (error nil))) (defun cperl-at-end-of-expr (&optional lim) + "Find the end of the previous expression. Do not go back beyond LIM." ;; Since the SEXP approach below is very fragile, do some overengineering (or (looking-at (concat cperl-maybe-white-and-comment-rex "[;}]")) (condition-case nil @@ -5498,6 +5568,7 @@ CHARS is a string that contains good characters to have before us (however, (error t)))) (defun cperl-forward-to-end-of-expr (&optional lim) + "Go forward to the end of the expression, but not beyond LIM." (condition-case nil (progn (while (and (< (point) (or lim (point-max))) @@ -5506,6 +5577,7 @@ CHARS is a string that contains good characters to have before us (however, (error nil))) (defun cperl-backward-to-start-of-continued-exp (lim) + "Go backward to the start of a continuation line, but not beyond LIM." (if (memq (preceding-char) (append ")]}\"'`" nil)) (forward-sexp -1)) (beginning-of-line) @@ -5514,7 +5586,8 @@ CHARS is a string that contains good characters to have before us (however, (skip-chars-forward " \t")) (defun cperl-after-block-and-statement-beg (lim) - "Return non-nil if the preceding ?} ends the statement." + "Return non-nil if the preceding ?} ends the statement. +Do not look before LIM." ;; We assume that we are after ?\} (and (cperl-after-block-p lim) @@ -5600,7 +5673,8 @@ conditional/loop constructs." (defun cperl-fix-line-spacing (&optional end parse-data) "Improve whitespace in a conditional/loop construct. -Returns some position at the last line." +Returns some position at the last line. +Process until END, use PARSE-DATA from a previous call." (interactive) (or end (setq end (point-max))) @@ -5825,6 +5899,7 @@ Returns some position at the last line." (defvar cperl-update-start) ; Do not need to make them local (defvar cperl-update-end) (defun cperl-delay-update-hook (beg end _old-len) + "Process reformatting between BEG and END in `after-change-functions'." (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) (setq cperl-update-end (max end (or cperl-update-end (point-min))))) @@ -5910,7 +5985,9 @@ conditional/loop constructs." "Like `fill-paragraph', but handle CPerl comments. If any of the current line is a comment, fill the comment or the block of it that point is in, preserving the comment's initial -indentation and initial hashes. Behaves usually outside of comment." +indentation and initial hashes. Behaves usually outside of comment. +JUSTIFY is passed to `fill-paragraph'. ITERATION is for internal +use, it indicates a recursive call." ;; (interactive "P") ; Only works when called from fill-paragraph. -stef (let (;; Non-nil if the current line contains a comment. has-comment @@ -5997,7 +6074,7 @@ indentation and initial hashes. Behaves usually outside of comment." t) (defun cperl-do-auto-fill () - ;; Break out if the line is short enough + "Break out if the line is short enough." (if (> (save-excursion (end-of-line) (current-column)) @@ -6167,6 +6244,8 @@ comment, or POD." ;; Suggested by Mark A. Hershberger (defun cperl-outline-level () + "Guess the outline level. 0 for a package, 1 for a sub. +In POD, returns the level of the current heading." (looking-at outline-regexp) (cond ((not (match-beginning 1)) 0) ; beginning-of-file ;; 2=package-group, 5=package-name 8=sub-name 16=head-level @@ -6201,19 +6280,22 @@ comment, or POD." "Additional expressions to highlight in Perl mode. Maximal set.") (defun cperl-load-font-lock-keywords () + "Initialize the default set of cperl faces." (or cperl-faces-init (cperl-init-faces)) cperl-font-lock-keywords) (defun cperl-load-font-lock-keywords-1 () + "Initialize the minimal set of cperl faces." (or cperl-faces-init (cperl-init-faces)) cperl-font-lock-keywords-1) (defun cperl-load-font-lock-keywords-2 () + "Initialize the maximal set of cperl faces." (or cperl-faces-init (cperl-init-faces)) cperl-font-lock-keywords-2) (defun cperl-font-lock-syntactic-face-function (state) - "Apply faces according to their syntax type. + "Apply faces according to their syntax type, given as STATE. In CPerl mode, this is used for here-documents which have been marked as c-style comments. For everything else, delegate to the default function." @@ -6233,6 +6315,7 @@ builtin functions to be fontified like, well, builtin functions (which they are not). Inherits from `default'.") (defun cperl-init-faces () + "Initialize the faces for CPerl mode." (condition-case errs (progn (let (t-font-lock-keywords t-font-lock-keywords-1) @@ -6910,12 +6993,13 @@ else ) ("Current")) "List of variables to set to get a particular indentation style. -Should be used via `cperl-set-style', `cperl-file-style' or via Perl menu. +Should be used via `cperl-set-style', command `cperl-file-style' or via +Perl menu. See examples in `cperl-style-examples'.") (defun cperl-set-style (style) - "Set CPerl mode variables to use one of several different indentation styles. + "Set CPerl indentation variables to STYLE, one of the predefined styles. This command sets the default values for the variables. It does not affect buffers visiting files where the style has been set as a file or directory variable. To change the indentation style of @@ -6971,9 +7055,9 @@ and \"Whitesmith\"." noerror)) (defun cperl-info-buffer (type) - ;; Return buffer with documentation. Creates if missing. - ;; If TYPE, this vars buffer. - ;; Special care is taken to not stomp over an existing info buffer + "Return buffer with documentation. Create if missing. +If TYPE, this vars buffer. +Special care is taken to not stomp over an existing info buffer" (let* ((bname (if type "*info-perl-var*" "*info-perl*")) (info (get-buffer bname)) (oldbuf (get-buffer "*info*"))) @@ -7009,6 +7093,8 @@ and \"Whitesmith\"." 'find-tag-default)))))) (defun cperl-info-on-command (command) + "Show an info buffer for COMMAND. +This is obsolete because Perl info pages are no longer distributed." (declare (obsolete cperl-perldoc "30.1")) (interactive (let* ((default (cperl-word-at-point)) @@ -7080,11 +7166,15 @@ and \"Whitesmith\"." (select-window iniwin))) (defun cperl-info-on-current-command () + "Show an info buffer for the current command. +This is obsolete because Perl info pages are no longer distributed." (declare (obsolete cperl-perldoc "30.1")) (interactive) (cperl-perldoc (cperl-word-at-point))) (defun cperl-imenu-info-imenu-search () + "Search a Perl info buffer. +This is obsolete because Perl info pages are no longer distributed." (declare (obsolete nil "30.1")) (if (looking-at "^-X[ \t\n]") nil (re-search-backward @@ -7092,6 +7182,8 @@ and \"Whitesmith\"." (forward-line 1))) (defun cperl-imenu-info-imenu-name () + "Return the name of a Perl info buffer. +This is obsolete because Perl info pages are no longer distributed." (declare (obsolete nil "30.1")) (buffer-substring (match-beginning 1) (match-end 1))) @@ -7099,6 +7191,8 @@ and \"Whitesmith\"." (declare-function imenu-choose-buffer-index "imenu" (&optional prompt alist)) (defun cperl-imenu-on-info () + "Create an imenu index for a Perl info page. +This is obsolete because Perl info pages are no longer distributed." (declare (obsolete nil "30.1")) (interactive) (message @@ -7106,7 +7200,7 @@ and \"Whitesmith\"." "Consider installing the perl-doc package from GNU ELPA."))) (defun cperl-lineup (beg end &optional step minshift) - "Lineup construction in a region. + "Lineup construction in a region from BEG to END. Beginning of region should be at the start of a construction. All first occurrences of this construction in the lines that are partially contained in the region are lined up at the same column. @@ -7164,7 +7258,8 @@ Will not move the position at the start to the left." (goto-char (match-beginning 0)))))))) ; No body (defun cperl-etags (&optional add all files) ;; NOT USED??? - "Run etags with appropriate options for Perl files. + "Run etags with appropriate options for Perl FILES. +Add to the current tags file if ADD is non-nil. If optional argument ALL is `recursive', will process Perl files in subdirectories too." ;; Apparently etags doesn't support UTF-8 encoded sources, and usage @@ -7252,8 +7347,9 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." (defun cperl-toggle-set-debug-unwind (arg &optional backtrace) "Toggle (or, with numeric argument, set) debugging state of syntaxification. -Nonpositive numeric argument disables debugging messages. The message -summarizes which regions it was decided to rescan for syntactic constructs. +Nonpositive numeric argument ARG disables debugging messages. The +message summarizes which regions it was decided to rescan for syntactic +constructs. BACKTRACE is added to ARG if provided. The message looks like this: @@ -7279,6 +7375,7 @@ by CPerl." (defvar cperl-tmp-buffer " *cperl-tmp*") (defun cperl-setup-tmp-buf () + "Prepare a temporary buffer for internal use during tags file creation." (set-buffer (get-buffer-create cperl-tmp-buffer)) (set-syntax-table cperl-mode-syntax-table) (buffer-disable-undo) @@ -7302,6 +7399,7 @@ Does not move point." beg)))) (defun cperl-xsub-scan () + "Scan for XS subroutines." (require 'imenu) (let ((index-alist '()) index index1 name package prefix) @@ -7346,6 +7444,8 @@ Does not move point." (defvar cperl-unreadable-ok nil) (defun cperl-find-tags (ifile xs topdir) + "Find tags in IFILE. Treat as an XS file if non-nil. +Entries are made relative to TOPDIR." (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel (cperl-pod-here-fontify nil) file) (save-excursion @@ -7452,16 +7552,19 @@ is relocated, the file TAGS inside it breaks). Use as (defun cperl-add-tags-recurse () "Add to TAGS file data for Perl files in the current directory and kids. Use as - emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ - -f cperl-add-tags-recurse" + Emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\ + -f `cperl-add-tags-recurse'" (cperl-write-tags nil nil t t)) (defvar cperl-tags-file-name "TAGS" "TAGS file name to use in `cperl-write-tags'.") +(declare-function initialize-new-tags-table "etags" ()) + (defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir) - ;; If INBUFFER, do not select buffer, and do not save - ;; If ERASE is `ignore', do not erase, and do not try to delete old info. + "Write tags for FILE. If this is a directory, RECURSE if non-nil. +If ERASE is `ignore', do not erase, and do not try to delete old info. +If INBUFFER, do not select buffer, and do not save." (require 'etags) (if file nil (setq file (if dir default-directory (buffer-file-name))) @@ -7534,8 +7637,7 @@ Use as (insert (cperl-find-tags file xs topdir)))))) (if inbuffer nil ; Delegate to the caller (save-buffer 0) ; No backup - (if (fboundp 'initialize-new-tags-table) - (initialize-new-tags-table)))))) + (initialize-new-tags-table))))) (defvar cperl-tags-hier-regexp-list (concat @@ -7557,7 +7659,7 @@ Use as (declare-function etags-snarf-tag "etags" (&optional use-explicit)) (defun cperl-tags-hier-fill () - ;; Suppose we are in a tag table cooked by cperl. + "Fill a tags hierarchy if in a tag table cooked by cperl." (goto-char 1) (let (pack name line ord cons1 file info fileind) (while (re-search-forward cperl-tags-hier-regexp-list nil t) @@ -7604,7 +7706,8 @@ Use as "Show hierarchical menu of classes and methods. Finds info about classes by a scan of loaded TAGS files. Supposes that the TAGS files contain fully qualified function names. -One may build such TAGS files from CPerl mode menu." +One may build such TAGS files from CPerl mode menu. +If UPDATE is non-nil, update the tags table." (interactive) (require 'etags) (require 'imenu) @@ -7651,6 +7754,8 @@ One may build such TAGS files from CPerl mode menu." (if (eq update -999) (cperl-tags-hier-init t))) (defun cperl-tags-treeify (to level) + "Build a tree for the tags hierarchy into TO. +LEVEL us the current level during the recursive calls." ;; cadr of `to' is read-write. On start it is a cons (let* ((regexp (concat "^\\(" (mapconcat #'identity @@ -7719,6 +7824,7 @@ One may build such TAGS files from CPerl mode menu." root-packages)))) (defun cperl-list-fold (list name limit) + "Fold LIST with name NAME into sublists with LIMIT members or less." (let (list1 list2 elt1 (num 0)) (if (<= (length list) limit) list (setq list1 nil list2 nil) @@ -7738,6 +7844,7 @@ One may build such TAGS files from CPerl mode menu." list1))))) (defun cperl-menu-to-keymap (menu) + "Prepare MENU for display with `imenu'." (let (list) (cons 'keymap (mapcar @@ -7787,7 +7894,8 @@ One may build such TAGS files from CPerl mode menu." ;;"[*/+-|&<.]+=" ) "\\|") - "If matches at the start of match found by `my-bad-c-style-regexp', + "Lisp Regular expression for things regularly occurring in a Perl regex. +If matches at the start of match found by `my-bad-c-style-regexp', insertion of a whitespace will not help.") (defvar found-bad) @@ -7824,6 +7932,7 @@ Currently it is tuned to C and Perl syntax." (message "No appropriate place found")))) (defun cperl-next-bad-style () + "Proceed to the next occurrence of bad regexp style." (let (p (not-found t) found) (while (and not-found (re-search-forward cperl-bad-style-regexp nil 'to-end)) @@ -7874,6 +7983,7 @@ Currently it is tuned to C and Perl syntax." (defvar cperl-help-from-timer nil) (defun cperl-word-at-point-hard () + "Try hard to find a useful token for Perl at point." ;; Does not save-excursion ;; Get to the something meaningful (or (eobp) (eolp) (forward-char 1)) @@ -7951,7 +8061,7 @@ than a line. Your contribution to update/shorten it is appreciated." "Where the documentation can be found.") (defun cperl-describe-perl-symbol (val) - "Display the documentation of symbol at point, a Perl operator." + "Display the documentation of symbol VAL at point, a Perl operator." (let ((enable-recursive-minibuffers t) regexp) (cond @@ -7994,7 +8104,8 @@ than a line. Your contribution to update/shorten it is appreciated." (defvar cperl-short-docs 'please-ignore-this-line ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) - "# based on \\='@(#)@ perl-descr.el 1.9 - describe-perl-symbol\\=' [Perl 5] + "Short documentation of Perl functions and variables. +# based on \\='@(#)@ perl-descr.el 1.9 - describe-perl-symbol\\=' [Perl 5] ... Range (list context); flip/flop [no flop when flip] (scalar context). ! ... Logical negation. ... != ... Numeric inequality. @@ -8437,7 +8548,8 @@ while (EXPR) { ... } EXPR while EXPR =encoding encodingname Encoding of the document.") (defun cperl-switch-to-doc-buffer (&optional interactive) - "Go to the Perl documentation buffer and insert the documentation." + "Go to the Perl documentation buffer and insert the documentation. +If INTERACTIVE, open a new window for this buffer." (interactive "p") (let ((buf (get-buffer-create cperl-doc-buffer))) (if interactive @@ -8450,11 +8562,12 @@ while (EXPR) { ... } EXPR while EXPR (setq buffer-read-only t))))) (defun cperl-beautify-regexp-piece (b e embed level) + "Beautify part of a regexp from B to E. +If EMBED is nil, process the whole regular expression. Recurse to depth +LEVEL." ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". - ;; EMBED is nil if we process the whole REx. ;; The REx is guaranteed to have //x - ;; LEVEL shows how many levels deep to go ;; position at enter and at leave is not defined (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline pos) (if embed @@ -8638,6 +8751,7 @@ while (EXPR) { ... } EXPR while EXPR (cperl-make-indent c))))) (defun cperl-make-regexp-x () + "Ensure that a regular expression has a \"/x\" modifier." ;; Returns position of the start ;; XXX this is called too often! Need to cache the result! (save-excursion @@ -8673,7 +8787,8 @@ while (EXPR) { ... } EXPR while EXPR b))) (defun cperl-beautify-regexp (&optional deep) - "Do it. (Experimental, may change semantics, recheck the result.) + "Beautify a regular expression to level DEEP. +\(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive "P") (setq deep (if deep (prefix-numeric-value deep) -1)) @@ -8743,6 +8858,7 @@ We suppose that the regexp is scanned already." (defun cperl-beautify-level (&optional deep) "Find an enclosing group in regexp and beautify it. +Recurse to DEEP levels. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive "P") @@ -9074,7 +9190,7 @@ If a region is highlighted, restricts to the region." (cperl-pod-spell t)) (defun cperl-pod-spell (&optional do-heres) - "Spell-check POD documentation. + "Spell-check POD documentation. Do here-docs if DO-HERES. If invoked with prefix argument, will do HERE-DOCs instead. If a region is highlighted, restricts to the region." (interactive "P") @@ -9097,9 +9213,9 @@ If a region is highlighted, restricts to the region." beg end)))) (defun cperl-map-pods-heres (func &optional prop s end) - "Execute a function over regions of pods or here-documents. -PROP is the text-property to search for; default to `in-pod'. Stop when -function returns nil." + "Execute FUNC over regions of pods or here-documents. +Start at S. PROP is the text-property to search for; default to +`in-pod'. Stop at END or when FUNC returns nil." (let (pos posend has-prop (cont t)) (or prop (setq prop 'in-pod)) (or s (setq s (point-min))) @@ -9116,9 +9232,9 @@ function returns nil." ;; Based on code by Masatake YAMATO: (defun cperl-get-here-doc-region (&optional pos pod) - "Return HERE document region around the point. -Return nil if the point is not in a HERE document region. If POD is non-nil, -will return a POD section if point is in a POD section." + "Return HERE document region around POS. +Return nil if the point is not in a HERE document region. If POD is +non-nil, will return a POD section if point is in a POD section." (or pos (setq pos (point))) (cperl-update-syntaxification pos) (if (or (eq 'here-doc (get-text-property pos 'syntax-type)) @@ -9152,10 +9268,9 @@ POS defaults to the point." (defun cperl-facemenu-add-face-function (face _end) "A callback to process user-initiated font-change requests. -Translates `bold', `italic', and `bold-italic' requests to insertion of -corresponding POD directives, and `underline' to C<> POD directive. - -Such requests are usually bound to M-o LETTER." +Translates FACE which is one of `bold', `italic', and `bold-italic' to +insertion of corresponding POD directives, and `underline' to C<> POD +directive." (or (get-text-property (point) 'in-pod) (error "Faces can only be set within POD")) (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">")) @@ -9253,9 +9368,11 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." (setq cperl-lazy-installed nil)) (defun cperl-lazy-hook () + "Set display of cperl short-docs to be shown when idle." (setq cperl-help-shown nil)) (defun cperl-get-help-defer () + "Hook to display short-docs when idle." (if (not (memq major-mode '(perl-mode cperl-mode))) nil (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) (cperl-get-help) @@ -9266,12 +9383,14 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." ;;; Plug for wrong font-lock: (defun cperl-font-lock-unfontify-region-function (beg end) + "Remove fontification between BEG and END." (declare (obsolete nil "30.1")) (with-silent-modifications (remove-text-properties beg end '(face nil)))) (defun cperl-font-lock-fontify-region-function (beg end loudly) "Extend the region to safe positions, then call the default function. +Process from BEG to END. LOUDLY is passed to the default function. Newer `font-lock's can do it themselves. We unwind only as far as needed for fontification. Syntaxification may do extra unwind via `cperl-unwind-to-safe'." @@ -9300,6 +9419,7 @@ do extra unwind via `cperl-unwind-to-safe'." (font-lock-default-fontify-region beg end loudly)) (defun cperl-fontify-syntactically (end) + "Find and apply text properties for \"hard\" syntax to END." ;; Some vars for debugging only ;; (message "Syntaxifying...") (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) @@ -9329,6 +9449,8 @@ do extra unwind via `cperl-unwind-to-safe'." nil)) ; Do not iterate (defun cperl-fontify-update (end) + "Function to convert postponed fontification up to END to actual faces. +This function is part of our `font-lock-defaults'." (let ((pos (point-min)) prop posend) (setq end (point-max)) (while (< pos end) @@ -9339,6 +9461,8 @@ do extra unwind via `cperl-unwind-to-safe'." nil) ; Do not iterate (defun cperl-fontify-update-bad (end) + "Process postponed fontification to end of buffer, ignoring END. +This function is no longer needed." ;; Since fontification happens with different region than syntaxification, ;; do to the end of buffer, not to END ;; likewise, start earlier if needed @@ -9356,12 +9480,15 @@ do extra unwind via `cperl-unwind-to-safe'." ;; Called when any modification is made to buffer text. (defun cperl-after-change-function (beg _end _old-len) + "Process information provided as an `after-change-function'. +Reset CPerl mode's syntax pointer to BEG." ;; We should have been informed about changes by `font-lock'. Since it ;; does not inform as which calls are deferred, do it ourselves (if cperl-syntax-done-to (setq cperl-syntax-done-to (min cperl-syntax-done-to beg)))) (defun cperl-update-syntaxification (to) + "Apply syntax table properties up to TO." (when cperl-use-syntax-table-text-property (syntax-propertize to))) diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 1f86527191a..b86555b1d87 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -1049,7 +1049,7 @@ Key bindings: (error "Tree-sitter for C# isn't available")) ;; Tree-sitter. - (treesit-parser-create 'c-sharp) + (setq treesit-primary-parser (treesit-parser-create 'c-sharp)) ;; Comments. (c-ts-common-comment-setup) diff --git a/lisp/progmodes/dockerfile-ts-mode.el b/lisp/progmodes/dockerfile-ts-mode.el index e31fd86bbdf..42fa7482a87 100644 --- a/lisp/progmodes/dockerfile-ts-mode.el +++ b/lisp/progmodes/dockerfile-ts-mode.el @@ -133,7 +133,7 @@ Return nil if there is no name or if NODE is not a stage node." :syntax-table dockerfile-ts-mode--syntax-table (when (treesit-ready-p 'dockerfile) - (treesit-parser-create 'dockerfile) + (setq treesit-primary-parser (treesit-parser-create 'dockerfile)) ;; Comments. (setq-local comment-start "# ") diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 0a14146a245..e5c27de81fc 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2018-2024 Free Software Foundation, Inc. -;; Version: 1.17.30 +;; Version: 1.17 ;; Author: João Távora <joaotavora@gmail.com> ;; Maintainer: João Távora <joaotavora@gmail.com> ;; URL: https://github.com/joaotavora/eglot @@ -292,7 +292,7 @@ automatically)." (scala-mode . ,(eglot-alternatives '("metals" "metals-emacs"))) (racket-mode . ("racket" "-l" "racket-langserver")) - ((tex-mode context-mode texinfo-mode bibtex-mode) + ((latex-mode plain-tex-mode context-mode texinfo-mode bibtex-mode tex-mode) . ,(eglot-alternatives '("digestif" "texlab"))) (erlang-mode . ("erlang_ls" "--transport" "stdio")) ((yaml-ts-mode yaml-mode) . ("yaml-language-server" "--stdio")) @@ -710,14 +710,14 @@ compile time if an undeclared LSP interface is used.")) (cl-destructuring-bind (&key types required-keys optional-keys &allow-other-keys) (eglot--interface interface-name) - (when-let ((missing (and enforce-required - (cl-set-difference required-keys - (eglot--plist-keys object))))) + (when-let* ((missing (and enforce-required + (cl-set-difference required-keys + (eglot--plist-keys object))))) (eglot--error "A `%s' must have %s" interface-name missing)) - (when-let ((excess (and disallow-non-standard - (cl-set-difference - (eglot--plist-keys object) - (append required-keys optional-keys))))) + (when-let* ((excess (and disallow-non-standard + (cl-set-difference + (eglot--plist-keys object) + (append required-keys optional-keys))))) (eglot--error "A `%s' mustn't have %s" interface-name excess)) (when check-types (cl-loop @@ -1238,38 +1238,31 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see." "Lookup `eglot-server-programs' for MODE. Return (LANGUAGES . CONTACT-PROXY). -MANAGED-MODES is a list with MODE as its first element. -Subsequent elements are other major modes also potentially -managed by the server that is to manage MODE. - -LANGUAGE-IDS is a list of the same length as MANAGED-MODES. Each -elem is derived from the corresponding mode name, if not -specified in `eglot-server-programs' (which see). +LANGUAGES is a list ((MANAGED-MODE . LANGUAGE-ID) ...). MANAGED-MODE is +a major mode also potentially managed by the server that is to manage +MODE. LANGUAGE-ID is string identifying the language to the LSP server. +It's derived from the corresponding mode name, or explicitly specified +in `eglot-server-programs' (which see). CONTACT-PROXY is the value of the corresponding `eglot-server-programs' entry." - (cl-flet ((languages (main-mode-sym specs) - (let* ((res - (mapcar (jsonrpc-lambda (sym &key language-id &allow-other-keys) - (cons sym - (or language-id - (or (get sym 'eglot-language-id) - (replace-regexp-in-string - "\\(?:-ts\\)?-mode$" "" - (symbol-name sym)))))) - specs)) - (head (cl-find main-mode-sym res :key #'car))) - (cons head (delq head res))))) - (cl-loop - for (modes . contact) in eglot-server-programs - for specs = (mapcar #'eglot--ensure-list - (if (or (symbolp modes) (keywordp (cadr modes))) - (list modes) modes)) - thereis (cl-some (lambda (spec) - (cl-destructuring-bind (sym &key &allow-other-keys) spec - (and (provided-mode-derived-p mode sym) - (cons (languages sym specs) contact)))) - specs)))) + (cl-loop + for (modes . contact) in eglot-server-programs + for llists = (mapcar #'eglot--ensure-list + (if (or (symbolp modes) (keywordp (cadr modes))) + (list modes) modes)) + for normalized = (mapcar (jsonrpc-lambda (sym &key language-id &allow-other-keys) + (cons sym + (or language-id + (or (get sym 'eglot-language-id) + (replace-regexp-in-string + "\\(?:-ts\\)?-mode$" "" + (symbol-name sym)))))) + llists) + when (cl-some (lambda (cell) + (provided-mode-derived-p mode (car cell))) + normalized) + return (cons normalized contact))) (defun eglot--guess-contact (&optional interactive) "Helper for `eglot'. @@ -1921,7 +1914,7 @@ and just return it. PROMPT shouldn't end with a question mark." (cond ((null servers) (eglot--error "No servers!")) ((or (cdr servers) (not dont-if-just-the-one)) - (let* ((default (when-let ((current (eglot-current-server))) + (let* ((default (when-let* ((current (eglot-current-server))) (funcall name current))) (read (completing-read (if default @@ -2171,7 +2164,7 @@ If it is activated, also signal textDocument/didOpen." (with-no-warnings (require 'package) (unless package-archive-contents (package-refresh-contents)) - (when-let ((existing (cadr (assoc 'eglot package-alist)))) + (when-let* ((existing (cadr (assoc 'eglot package-alist)))) (package-delete existing t)) (package-install (cadr (assoc 'eglot package-archive-contents))))) @@ -2464,10 +2457,10 @@ expensive cached value of `file-truename'.") (current-buffer) beg end (eglot--diag-type severity) message `((eglot-lsp-diag . ,diag-spec)) - (when-let ((faces - (cl-loop for tag across tags - when (alist-get tag eglot--tag-faces) - collect it))) + (when-let* ((faces + (cl-loop for tag across tags + when (alist-get tag eglot--tag-faces) + collect it))) `((face . ,faces)))))) into diags finally (cond ((and @@ -2626,12 +2619,12 @@ buffer." (append (eglot--TextDocumentPositionParams) `(:context - ,(if-let (trigger (and (characterp eglot--last-inserted-char) - (cl-find eglot--last-inserted-char - (eglot-server-capable :completionProvider - :triggerCharacters) - :key (lambda (str) (aref str 0)) - :test #'char-equal))) + ,(if-let* ((trigger (and (characterp eglot--last-inserted-char) + (cl-find eglot--last-inserted-char + (eglot-server-capable :completionProvider + :triggerCharacters) + :key (lambda (str) (aref str 0)) + :test #'char-equal)))) `(:triggerKind 2 :triggerCharacter ,trigger) `(:triggerKind 1))))) (defvar-local eglot--recent-changes nil @@ -3174,7 +3167,7 @@ for which LSP on-type-formatting should be requested." (defun eglot-completion-at-point () "Eglot's `completion-at-point' function." ;; Commit logs for this function help understand what's going on. - (when-let (completion-capability (eglot-server-capable :completionProvider)) + (when-let* ((completion-capability (eglot-server-capable :completionProvider))) (let* ((server (eglot--current-server-or-lose)) (bounds (or (bounds-of-thing-at-point 'symbol) (cons (point) (point)))) @@ -3303,7 +3296,7 @@ for which LSP on-type-formatting should be requested." (_ (intern (downcase kind)))))) :company-deprecated (lambda (proxy) - (when-let ((lsp-item (get-text-property 0 'eglot--lsp-item proxy))) + (when-let* ((lsp-item (get-text-property 0 'eglot--lsp-item proxy))) (or (seq-contains-p (plist-get lsp-item :tags) 1) (eq t (plist-get lsp-item :deprecated))))) @@ -3397,7 +3390,7 @@ for which LSP on-type-formatting should be requested." (with-temp-buffer (insert siglabel) ;; Add documentation, indented so we can distinguish multiple signatures - (when-let (doc (and (not briefp) sigdoc (eglot--format-markup sigdoc))) + (when-let* ((doc (and (not briefp) sigdoc (eglot--format-markup sigdoc)))) (goto-char (point-max)) (insert "\n" (replace-regexp-in-string "^" " " doc))) ;; Try to highlight function name only @@ -3857,12 +3850,12 @@ at point. With prefix argument, prompt for ACTION-KIND." (handle-event `(,desc 'deleted ,file)) (handle-event `(,desc 'created ,file1)))))) (watch-dir (dir) - (when-let ((probe - (and (file-readable-p dir) - (or (gethash dir (eglot--file-watches server)) - (puthash dir (list (file-notify-add-watch - dir '(change) #'handle-event)) - (eglot--file-watches server)))))) + (when-let* ((probe + (and (file-readable-p dir) + (or (gethash dir (eglot--file-watches server)) + (puthash dir (list (file-notify-add-watch + dir '(change) #'handle-event)) + (eglot--file-watches server)))))) (push id (cdr probe))))) (unwind-protect (progn @@ -3896,7 +3889,7 @@ at point. With prefix argument, prompt for ACTION-KIND." with grammar = '((:** "\\*\\*/?" eglot--glob-emit-**) (:* "\\*" eglot--glob-emit-*) (:? "\\?" eglot--glob-emit-?) - (:{} "{[^][*{}]+}" eglot--glob-emit-{}) + (:{} "{[^{}]+}" eglot--glob-emit-{}) (:range "\\[\\^?[^][/,*{}]+\\]" eglot--glob-emit-range) (:literal "[^][,*?{}]+" eglot--glob-emit-self)) until (eobp) @@ -3906,20 +3899,25 @@ at point. With prefix argument, prompt for ACTION-KIND." (list (cl-gensym "state-") emitter (match-string 0))) finally (error "Glob '%s' invalid at %s" (buffer-string) (point)))))) +(cl-defun eglot--glob-fsm (states &key (exit 'eobp) noerror) + `(cl-labels ,(cl-loop for (this that) on states + for (self emit text) = this + for next = (or (car that) exit) + collect (funcall emit text self next)) + ,(if noerror + `(,(caar states)) + `(or (,(caar states)) + (error "Glob done but more unmatched text: '%s'" + (buffer-substring (point) (point-max))))))) + (defun eglot--glob-compile (glob &optional byte-compile noerror) "Convert GLOB into Elisp function. Maybe BYTE-COMPILE it. If NOERROR, return predicate, else erroring function." - (let* ((states (eglot--glob-parse glob)) + (let* ((states (eglot--glob-parse glob)) (body `(with-current-buffer (get-buffer-create " *eglot-glob-matcher*") (erase-buffer) (save-excursion (insert string)) - (cl-labels ,(cl-loop for (this that) on states - for (self emit text) = this - for next = (or (car that) 'eobp) - collect (funcall emit text self next)) - (or (,(caar states)) - (error "Glob done but more unmatched text: '%s'" - (buffer-substring (point) (point-max))))))) + ,(eglot--glob-fsm states))) (form `(lambda (string) ,(if noerror `(ignore-errors ,body) body)))) (if byte-compile (byte-compile form) form))) @@ -3939,10 +3937,20 @@ If NOERROR, return predicate, else erroring function." (defun eglot--glob-emit-{} (arg self next) (let ((alternatives (split-string (substring arg 1 (1- (length arg))) ","))) - `(,self () - (or (re-search-forward ,(concat "\\=" (regexp-opt alternatives)) nil t) - (error "Failed matching any of %s" ',alternatives)) - (,next)))) + (if (cl-notany (lambda (a) (string-match "\\*" a)) alternatives) + `(,self () + (or (re-search-forward ,(concat "\\=" (regexp-opt alternatives)) nil t) + (error "No alternatives match: %s" ',alternatives)) + (,next)) + (let ((fsms (mapcar (lambda (a) + `(save-excursion + (ignore-errors + ,(eglot--glob-fsm (eglot--glob-parse a) + :exit next :noerror t)))) + alternatives))) + `(,self () + (or ,@fsms + (error "Glob match fail after alternatives %s" ',alternatives))))))) (defun eglot--glob-emit-range (arg self next) (when (eq ?! (aref arg 1)) (aset arg 1 ?^)) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 9bf6f9217c8..2b6d9d2b8bb 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -246,7 +246,7 @@ Use `emacs-lisp-byte-compile-and-load' in combination with `native-comp-jit-compilation' set to t to achieve asynchronous native compilation of the current buffer's file." (interactive nil emacs-lisp-mode) - (when-let ((byte-file (emacs-lisp-native-compile))) + (when-let* ((byte-file (emacs-lisp-native-compile))) (load (file-name-sans-extension byte-file)))) (defun emacs-lisp-macroexpand () @@ -784,13 +784,18 @@ functions are annotated with \"<f>\" via the (list t (elisp--completion-local-symbols) :predicate (lambda (sym) (get sym 'error-conditions)))) - ((and (or ?\( 'let 'let*) + ((and (or ?\( 'let 'let* 'cond 'cond* 'bind*) (guard (save-excursion (goto-char (1- beg)) (when (eq parent ?\() (up-list -1)) - (forward-symbol -1) - (looking-at "\\_<let\\*?\\_>")))) + (skip-syntax-backward " w_") + (or + (looking-at + "\\_<\\(let\\*?\\|bind\\*\\)\\_>") + (and (not (eq parent ?\()) + (looking-at + "\\_<cond\\*?\\_>")))))) (list t (elisp--completion-local-symbols) :predicate #'elisp--shorthand-aware-boundp :company-kind (lambda (_) 'variable) @@ -1044,7 +1049,9 @@ namespace but with lower confidence." (let ((sym (intern-soft identifier))) (when sym (let* ((pos (get-text-property 0 'pos identifier)) - (namespace (if pos + (namespace (if (and pos + ;; Reusing it in Help Mode. + (derived-mode-p 'emacs-lisp-mode)) (elisp--xref-infer-namespace pos) 'any)) (defs (elisp--xref-find-definitions sym))) @@ -1844,7 +1851,7 @@ Also see `elisp-eldoc-var-docstring-with-value'." Intended for `eldoc-documentation-functions' (which see). Compared to `elisp-eldoc-var-docstring', this also includes the current variable value and a bigger chunk of the docstring." - (when-let ((cs (elisp--current-symbol))) + (when-let* ((cs (elisp--current-symbol))) (when (and (boundp cs) ;; nil and t are boundp! (not (null cs)) diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el index 0cb77b30a75..41904e8bd0d 100644 --- a/lisp/progmodes/erts-mode.el +++ b/lisp/progmodes/erts-mode.el @@ -209,8 +209,8 @@ expected results and the actual results in a separate buffer." (re-search-backward "^=-=\n" nil t) (let ((potential-start (match-end 0))) ;; See if we're in a two-clause ("before" and "after") test or not. - (if-let ((start (and (save-excursion (re-search-backward "^=-=\n" nil t)) - (match-end 0)))) + (if-let* ((start (and (save-excursion (re-search-backward "^=-=\n" nil t)) + (match-end 0)))) (let ((end (save-excursion (re-search-backward "^=-=-=\n" nil t)))) (if (or (not end) (> start end)) diff --git a/lisp/progmodes/flymake-cc.el b/lisp/progmodes/flymake-cc.el index 60e7da5d617..0cf6b68012c 100644 --- a/lisp/progmodes/flymake-cc.el +++ b/lisp/progmodes/flymake-cc.el @@ -28,18 +28,19 @@ (require 'cl-lib) -(defcustom flymake-cc-command 'flymake-cc-use-special-make-target +(defcustom flymake-cc-command #'flymake-cc-use-special-make-target "Command used by the `flymake-cc' backend. -A list of strings, or a symbol naming a function that produces one -such list when called with no arguments in the buffer where the -variable `flymake-mode' is active. +The value should be a list of strings, or a function that produces +such a list when called with no arguments in the buffer where `flymake-mode' +is active. The list of strings should be suitable for the `:command' +keyword of `make-process'. The command should invoke a GNU-style compiler that checks the syntax of a (Obj)C(++) program passed to it via its standard input and prints the result on its standard output." :type '(choice - (symbol :tag "Function") - (repeat :tag "Command(s)" string)) + (function :tag "Function to produce compilation command") + (repeat :tag "Compilation command and its options" string)) :version "27.1" :group 'flymake-cc) @@ -128,7 +129,7 @@ REPORT-FN is Flymake's callback." (make-process :name "gcc-flymake" :buffer (generate-new-buffer "*gcc-flymake*") - :command (if (symbolp flymake-cc-command) + :command (if (functionp flymake-cc-command) (funcall flymake-cc-command) flymake-cc-command) :noquery t :connection-type 'pipe diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 9a6b62ca254..3dee1a58e44 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -845,7 +845,7 @@ Return to original margin width if ORIG-WIDTH is non-nil." (widen) (dolist (o (overlays-in (point-min) (point-max))) (when (overlay-get o 'flymake--eol-overlay) - (if-let ((src-ovs (overlay-get o 'flymake-eol-source-overlays))) + (if-let* ((src-ovs (overlay-get o 'flymake-eol-source-overlays))) (overlay-put o 'before-string (flymake--eol-overlay-summary src-ovs)) (delete-overlay o)))))) @@ -1533,7 +1533,7 @@ START and STOP and LEN are as in `after-change-functions'." (defun flymake-eldoc-function (report-doc &rest _) "Document diagnostics at point. Intended for `eldoc-documentation-functions' (which see)." - (when-let ((diags (flymake-diagnostics (point)))) + (when-let* ((diags (flymake-diagnostics (point)))) (funcall report-doc (mapconcat #'flymake-diagnostic-text diags "\n") :echo (mapconcat #'flymake-diagnostic-oneliner diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 8a726dfe66e..00c3d5a5cbd 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -290,6 +290,7 @@ buffer). This corresponds to the g77 compiler option `-ffixed-line-length-N'." :type 'integer :safe 'integerp + :local t :initialize 'custom-initialize-default :set (lambda (_symbol value) ;; Do all fortran buffers, and the default. @@ -297,8 +298,6 @@ buffer). This corresponds to the g77 compiler option :version "23.1" :group 'fortran) -(make-variable-buffer-local 'fortran-line-length) - (defcustom fortran-mode-hook nil "Hook run when entering Fortran mode." :type 'hook @@ -1631,7 +1630,7 @@ Return point or nil." (setq icol (+ icol fortran-if-indent))) ((looking-at "where[ \t]*(.*)[ \t]*\n") (setq icol (+ icol fortran-if-indent))) - ((looking-at "do\\b") + ((looking-at "do *[0-9]* *[a-z0-9_]+ *= *[a-z0-9_]+ *, *[a-z0-9_]+") (setq icol (+ icol fortran-do-indent))) ((looking-at "\\(structure\\|union\\|map\\|interface\\)\ diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 2981965ee0c..b60e21ff0ae 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -2699,7 +2699,8 @@ Sets `gdb-thread-number' to new id." (gdb-force-mode-line-update (propertize gdb-inferior-status 'face font-lock-type-face)) (setq gdb-active-process t) - (setq gud-running t)) + (setq gud-running t) + (gud-hide-current-line-indicator nil)) ;; -break-insert -t didn't give a reason before gdb 6.9 @@ -3241,7 +3242,7 @@ See `def-gdb-auto-update-handler'." ;; Add the breakpoint/header row to the table. (gdb-breakpoints--add-breakpoint-row table breakpoint) ;; If this breakpoint has multiple locations, add them as well. - (when-let ((locations (gdb-mi--field breakpoint 'locations))) + (when-let* ((locations (gdb-mi--field breakpoint 'locations))) (dolist (loc locations) (add-to-list 'gdb-breakpoints-list (cons (gdb-mi--field loc 'number) loc)) @@ -4829,7 +4830,7 @@ overlay arrow in source buffer." (when frame (setq gdb-selected-frame (gdb-mi--field frame 'func)) (setq gdb-selected-file - (when-let ((full (gdb-mi--field frame 'fullname))) + (when-let* ((full (gdb-mi--field frame 'fullname))) (file-local-name full))) (setq gdb-frame-number (gdb-mi--field frame 'level)) (setq gdb-frame-address (gdb-mi--field frame 'addr)) diff --git a/lisp/progmodes/go-ts-mode.el b/lisp/progmodes/go-ts-mode.el index 2d3e6aac090..86e74ad58a8 100644 --- a/lisp/progmodes/go-ts-mode.el +++ b/lisp/progmodes/go-ts-mode.el @@ -46,6 +46,12 @@ :safe 'integerp :group 'go) +(defcustom go-ts-mode-build-tags nil + "List of Go build tags for the test commands." + :version "31.1" + :type '(repeat string) + :group 'go) + (defvar go-ts-mode--syntax-table (let ((table (make-syntax-table))) (modify-syntax-entry ?+ "." table) @@ -242,7 +248,10 @@ (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) + "C-c C-d" #'go-ts-mode-docstring + "C-c C-t t" #'go-ts-mode-test-function-at-point + "C-c C-t f" #'go-ts-mode-test-this-file + "C-c C-t p" #'go-ts-mode-test-this-package) ;;;###autoload (define-derived-mode go-ts-mode prog-mode "Go" @@ -253,7 +262,7 @@ :syntax-table go-ts-mode--syntax-table (when (treesit-ready-p 'go) - (treesit-parser-create 'go) + (setq treesit-primary-parser (treesit-parser-create 'go)) ;; Comments. (setq-local comment-start "// ") @@ -354,7 +363,7 @@ Methods are prefixed with the receiver name, unless SKIP-PREFIX is t." 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))) + (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 @@ -366,15 +375,92 @@ comment already exists, jump to it." (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))) + (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))))) +(defun go-ts-mode--get-build-tags-flag () + "Return the compile flag for build tags. +This function respects the `go-ts-mode-build-tags' variable for +specifying build tags." + (if go-ts-mode-build-tags + (format "-tags %s" (string-join go-ts-mode-build-tags ",")) + "")) + +(defun go-ts-mode--compile-test (regexp) + "Compile the tests matching REGEXP. +This function respects the `go-ts-mode-build-tags' variable for +specifying build tags." + (compile (format "go test -v %s -run '%s'" + (go-ts-mode--get-build-tags-flag) + regexp))) + +(defun go-ts-mode--find-defun-at (start) + "Return the first defun node from START." + (let ((thing (or treesit-defun-type-regexp 'defun))) + (or (treesit-thing-at start thing) + (treesit-thing-next start thing)))) + +(defun go-ts-mode--get-function-regexp (name) + (if name + (format "^%s$" name) + (error "No test function found"))) + +(defun go-ts-mode--get-functions-in-range (start end) + "Return a list with the names of all defuns in the range START to END." + (let* ((node (go-ts-mode--find-defun-at start)) + (name (treesit-defun-name node)) + (node-start (treesit-node-start node)) + (node-end (treesit-node-end node))) + (cond ((or (not node) + (> start node-end) + (< end node-start)) + nil) + ((or (not (equal (treesit-node-type node) "function_declaration")) + (not (string-prefix-p "Test" name))) + (go-ts-mode--get-functions-in-range (treesit-node-end node) end)) + (t + (cons (go-ts-mode--get-function-regexp name) + (go-ts-mode--get-functions-in-range (treesit-node-end node) end)))))) + +(defun go-ts-mode--get-test-regexp-at-point () + "Return a regular expression for the tests at point. +If region is active, the regexp will include all the functions under the +region." + (if-let* ((range (if (region-active-p) + (list (region-beginning) (region-end)) + (list (point) (point)))) + (funcs (apply #'go-ts-mode--get-functions-in-range range))) + (string-join funcs "|") + (error "No test function found"))) + +(defun go-ts-mode-test-function-at-point () + "Run the unit test at point. +If the point is anywhere in the test function, that function will be +run. If the region is selected, all the functions under the region will +be run." + (interactive) + (go-ts-mode--compile-test (go-ts-mode--get-test-regexp-at-point))) + +(defun go-ts-mode-test-this-file () + "Run all the unit tests in the current file." + (interactive) + (if-let* ((defuns (go-ts-mode--get-functions-in-range (point-min) (point-max)))) + (go-ts-mode--compile-test (string-join defuns "|")) + (error "No test functions found in the current file"))) + +(defun go-ts-mode-test-this-package () + "Run all the unit tests under the current package." + (interactive) + (compile (format "go test -v %s -run %s" + (go-ts-mode--get-build-tags-flag) + default-directory))) + ;; go.mod support. (defvar go-mod-ts-mode--syntax-table @@ -453,7 +539,7 @@ what the parent of the node would be if it were a node." :syntax-table go-mod-ts-mode--syntax-table (when (treesit-ready-p 'gomod) - (treesit-parser-create 'gomod) + (setq treesit-primary-parser (treesit-parser-create 'gomod)) ;; Comments. (setq-local comment-start "// ") diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index e8d1e692d0f..ed8d6e9e0d9 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -310,6 +310,8 @@ See `compilation-error-screen-columns'." (define-key map "}" #'compilation-next-file) (define-key map "\t" #'compilation-next-error) (define-key map [backtab] #'compilation-previous-error) + + (define-key map "e" #'grep-change-to-grep-edit-mode) map) "Keymap for grep buffers. `compilation-minor-mode-map' is a cdr of this.") @@ -827,15 +829,23 @@ The value depends on `grep-command', `grep-template', (unless grep-find-use-xargs (setq grep-find-use-xargs (cond - ((grep-probe find-program - `(nil nil nil ,(null-device) "-exec" "echo" - "{}" "+")) - 'exec-plus) + ;; For performance, we want: + ;; A. Run grep on batches of files (instead of one grep per file) + ;; B. If the directory is large and we need multiple batches, + ;; run find in parallel with a running grep. + ;; "find | xargs grep" gives both A and B ((and + (not (eq system-type 'windows-nt)) (grep-probe find-program `(nil nil nil ,(null-device) "-print0")) (grep-probe xargs-program '(nil nil nil "-0" "echo"))) 'gnu) + ;; "find -exec {} +" gives A but not B + ((grep-probe find-program + `(nil nil nil ,(null-device) "-exec" "echo" + "{}" "+")) + 'exec-plus) + ;; "find -exec {} ;" gives neither A nor B. (t 'exec)))) (unless grep-find-command @@ -1044,6 +1054,91 @@ list is empty)." command-args) #'grep-mode)) +(defun grep-edit--prepare-buffer () + "Mark relevant regions read-only, and add relevant occur text-properties." + (save-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t) + (dummy (make-marker)) + match) + (while (setq match (text-property-search-forward 'compilation-annotation)) + (add-text-properties (prop-match-beginning match) (prop-match-end match) + '(read-only t))) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'compilation-message)) + (add-text-properties (prop-match-beginning match) (prop-match-end match) + '(read-only t occur-prefix t)) + (let ((loc (compilation--message->loc (prop-match-value match))) + m) + ;; Update the markers if necessary. + (unless (and (compilation--loc->marker loc) + (marker-buffer (compilation--loc->marker loc))) + (compilation--update-markers loc dummy compilation-error-screen-columns compilation-first-column)) + (setq m (compilation--loc->marker loc)) + (add-text-properties (prop-match-beginning match) + (or (next-single-property-change + (prop-match-end match) + 'compilation-message) + (1+ (pos-eol))) + `(occur-target ((,m . ,m))))))))) + +(defvar grep-edit-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map text-mode-map) + (define-key map (kbd "C-c C-c") #'grep-edit-save-changes) + map) + "Keymap for `grep-edit-mode'.") + +(defvar grep-edit-mode-hook nil + "Hooks run when changing to Grep-Edit mode.") + +(defun grep-edit-mode () + "Major mode for editing *grep* buffers. +In this mode, changes to the *grep* buffer are applied to the +originating files. +\\<grep-edit-mode-map> +Type \\[grep-edit-save-changes] to exit Grep-Edit mode, return to Grep +mode. + +The only editable texts in a Grep-Edit buffer are the match results." + (interactive) + (error "This mode can be enabled only by `grep-change-to-grep-edit-mode'")) +(put 'grep-edit-mode 'mode-class 'special) + +(defun grep-change-to-grep-edit-mode () + "Switch to `grep-edit-mode' to edit *grep* buffer." + (interactive) + (unless (derived-mode-p 'grep-mode) + (error "Not a Grep buffer")) + (when (get-buffer-process (current-buffer)) + (error "Cannot switch when grep is running")) + (use-local-map grep-edit-mode-map) + (grep-edit--prepare-buffer) + (setq buffer-read-only nil) + (setq major-mode 'grep-edit-mode) + (setq mode-name "Grep-Edit") + (buffer-enable-undo) + (set-buffer-modified-p nil) + (setq buffer-undo-list nil) + (add-hook 'after-change-functions #'occur-after-change-function nil t) + (run-mode-hooks 'grep-edit-mode-hook) + (message (substitute-command-keys + "Editing: Type \\[grep-edit-save-changes] to return to Grep mode"))) + +(defun grep-edit-save-changes () + "Switch back to Grep mode." + (interactive) + (unless (derived-mode-p 'grep-edit-mode) + (error "Not a Grep-Edit buffer")) + (remove-hook 'after-change-functions #'occur-after-change-function t) + (use-local-map grep-mode-map) + (setq buffer-read-only t) + (setq major-mode 'grep-mode) + (setq mode-name "Grep") + (force-mode-line-update) + (buffer-disable-undo) + (setq buffer-undo-list t) + (message "Switching to Grep mode")) ;;;###autoload (defun grep-find (command-args) @@ -1262,7 +1357,7 @@ command before it's run." regexp files nil - (when-let ((ignores (grep-find-ignored-files dir))) + (when-let* ((ignores (grep-find-ignored-files dir))) (concat " --exclude=" (mapconcat (lambda (ignore) @@ -1379,7 +1474,7 @@ to indicate whether the grep should be case sensitive or not." "Compute the command for \\[rgrep] to use by default." (require 'find-dired) ; for `find-name-arg' (let ((ignored-files-arg - (when-let ((ignored-files (grep-find-ignored-files dir))) + (when-let* ((ignored-files (grep-find-ignored-files dir))) (concat (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here " -name " @@ -1403,7 +1498,7 @@ to indicate whether the grep should be case sensitive or not." (concat " " (shell-quote-argument "!" grep-quoting-style) " " ignored-files-arg))) dir (concat - (when-let ((ignored-dirs (rgrep-find-ignored-directories dir))) + (when-let* ((ignored-dirs (rgrep-find-ignored-directories dir))) (concat "-type d " (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here @@ -1483,8 +1578,8 @@ command before it's run." (defun grep-file-at-point (point) "Return the name of the file at POINT a `grep-mode' buffer. The returned file name is relative." - (when-let ((msg (get-text-property point 'compilation-message)) - (loc (compilation--message->loc msg))) + (when-let* ((msg (get-text-property point 'compilation-message)) + (loc (compilation--message->loc msg))) (caar (compilation--loc->file-struct loc)))) ;;;###autoload diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 7486804da1b..a4e611277e4 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -2949,11 +2949,19 @@ It is saved for when this flag is not set.") "Overlay created for `gud-highlight-current-line'. It is nil if not yet present.") +(defun gud-hide-current-line-indicator(destroy-overlay) + "Stop displaying arrow and highlighting current line in a source file." + ;; Stop displaying an arrow in a source file. + (setq gud-overlay-arrow-position nil) + ;; And any highlight overlays. + (when gud-highlight-current-line-overlay + (delete-overlay gud-highlight-current-line-overlay) + (if destroy-overlay + (setq gud-highlight-current-line-overlay nil)))) + (defun gud-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) ;; buffer killed - ;; Stop displaying an arrow in a source file. - (setq gud-overlay-arrow-position nil) (set-process-buffer proc nil) (if (and (boundp 'speedbar-initial-expansion-list-name) (string-equal speedbar-initial-expansion-list-name "GUD")) @@ -2963,12 +2971,9 @@ It is nil if not yet present.") (gdb-reset) (gud-reset))) ((memq (process-status proc) '(signal exit)) - ;; Stop displaying an arrow in a source file. - (setq gud-overlay-arrow-position nil) - ;; And any highlight overlays. - (when gud-highlight-current-line-overlay - (delete-overlay gud-highlight-current-line-overlay) - (setq gud-highlight-current-line-overlay nil)) + + (gud-hide-current-line-indicator t) + (if (eq (buffer-local-value 'gud-minor-mode gud-comint-buffer) 'gdbmi) (gdb-reset) @@ -4134,7 +4139,8 @@ This command runs functions from `lldb-mode-hook'." (add-hook 'completion-at-point-functions #'gud-lldb-completion-at-point nil 'local) - (keymap-local-set "<tab>" #'completion-at-point) + ;; Bind TAB not <tab> so that it also works on ttys. + (keymap-local-set "TAB" #'completion-at-point) (gud-set-repeat-map-property 'gud-gdb-repeat-map) (setq comint-prompt-regexp (rx line-start "(lldb)" (0+ blank))) diff --git a/lisp/progmodes/heex-ts-mode.el b/lisp/progmodes/heex-ts-mode.el index b527d96b579..84fd513525c 100644 --- a/lisp/progmodes/heex-ts-mode.el +++ b/lisp/progmodes/heex-ts-mode.el @@ -148,7 +148,7 @@ With ARG, do it many times. Negative ARG means move backward." :group 'heex-ts (when (treesit-ready-p 'heex) - (treesit-parser-create 'heex) + (setq treesit-primary-parser (treesit-parser-create 'heex)) ;; Comments (setq-local treesit-thing-settings diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 9bcac0d8dc5..27a02e9805f 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -400,7 +400,7 @@ If there is a marked region from START to END it only shows the symbols within." (end-of-line 2))) (defun hif-merge-ifdef-region (start end) - "This function merges nearby ifdef regions to form a bigger overlay. + "Merge nearby ifdef regions to form a bigger overlay. The region is defined by START and END. This will decrease the number of overlays created." ;; Generally there is no need to call itself recursively since there should diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index 85fc6b930f5..b092b3b679c 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -308,8 +308,8 @@ quoted using shell quote syntax. "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) (setq inferior-lisp-buffer "*inferior-lisp*") - (with-suppressed-warnings ((obsolete display-comint-buffer-action)) - (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action))) + (pop-to-buffer "*inferior-lisp*" (append display-buffer--same-window-action + '((category . comint))))) ;;;###autoload (defalias 'run-lisp 'inferior-lisp) diff --git a/lisp/progmodes/java-ts-mode.el b/lisp/progmodes/java-ts-mode.el index 4ceb211ade1..177f914160c 100644 --- a/lisp/progmodes/java-ts-mode.el +++ b/lisp/progmodes/java-ts-mode.el @@ -24,6 +24,8 @@ ;;; Commentary: ;; +;; If the tree-sitter doxygen grammar is available, then the comment +;; blocks can be highlighted according to this grammar. ;;; Code: @@ -46,6 +48,17 @@ :safe 'integerp :group 'java) +(defcustom java-ts-mode-enable-doxygen nil + "Enable doxygen syntax highlighting. +If Non-nil, enable doxygen based font lock for comment blocks. +This needs to be set before enabling `java-ts-mode'; if you change +the value after enabling `java-ts-mode', toggle the mode off and on +again." + :version "31.1" + :type 'boolean + :safe 'booleanp + :group 'java) + (defvar java-ts-mode--syntax-table (let ((table (make-syntax-table))) ;; Taken from the cc-langs version @@ -312,7 +325,7 @@ Return nil if there is no name or if NODE is not a defun node." (defvar java-ts-mode--feature-list - '(( comment definition ) + '(( comment document definition ) ( constant keyword string type) ( annotation expression literal) ( bracket delimiter operator))) @@ -326,76 +339,91 @@ Return nil if there is no name or if NODE is not a defun node." (unless (treesit-ready-p 'java) (error "Tree-sitter for Java isn't available")) - (treesit-parser-create 'java) - - ;; Comments. - (c-ts-common-comment-setup) - - ;; Indent. - (setq-local c-ts-common-indent-type-regexp-alist - `((block . ,(rx (or "class_body" - "array_initializer" - "constructor_body" - "annotation_type_body" - "interface_body" - "lambda_expression" - "enum_body" - "switch_block" - "record_declaration_body" - "block"))) - (close-bracket . "}") - (if . "if_statement") - (else . ("if_statement" . "alternative")) - (for . "for_statement") - (while . "while_statement") - (do . "do_statement"))) - (setq-local c-ts-common-indent-offset 'java-ts-mode-indent-offset) - (setq-local treesit-simple-indent-rules java-ts-mode--indent-rules) - - ;; Electric - (setq-local electric-indent-chars - (append "{}():;," electric-indent-chars)) - - ;; Navigation. - (setq-local treesit-defun-type-regexp - (regexp-opt '("method_declaration" - "class_declaration" - "record_declaration" - "interface_declaration" - "enum_declaration" - "import_declaration" - "package_declaration" - "module_declaration" - "constructor_declaration"))) - (setq-local treesit-defun-name-function #'java-ts-mode--defun-name) - - (setq-local treesit-thing-settings - `((java - (sexp ,(rx (or "annotation" - "parenthesized_expression" - "argument_list" - "identifier" - "modifiers" - "block" - "body" - "literal" - "access" - "reference" - "_type" - "true" - "false"))) - (sentence ,(rx (or "statement" - "local_variable_declaration" - "field_declaration" - "module_declaration" - "package_declaration" - "import_declaration"))) - (text ,(regexp-opt '("line_comment" - "block_comment" - "text_block")))))) - - ;; Font-lock. - (setq-local treesit-font-lock-settings java-ts-mode--font-lock-settings) + (let ((primary-parser (treesit-parser-create 'java))) + + ;; Comments. + (c-ts-common-comment-setup) + + ;; Indent. + (setq-local c-ts-common-indent-type-regexp-alist + `((block . ,(rx (or "class_body" + "array_initializer" + "constructor_body" + "annotation_type_body" + "interface_body" + "lambda_expression" + "enum_body" + "switch_block" + "record_declaration_body" + "block"))) + (close-bracket . "}") + (if . "if_statement") + (else . ("if_statement" . "alternative")) + (for . "for_statement") + (while . "while_statement") + (do . "do_statement"))) + (setq-local c-ts-common-indent-offset 'java-ts-mode-indent-offset) + (setq-local treesit-simple-indent-rules java-ts-mode--indent-rules) + + ;; Electric + (setq-local electric-indent-chars + (append "{}():;," electric-indent-chars)) + + ;; Navigation. + (setq-local treesit-defun-type-regexp + (regexp-opt '("method_declaration" + "class_declaration" + "record_declaration" + "interface_declaration" + "enum_declaration" + "import_declaration" + "package_declaration" + "module_declaration" + "constructor_declaration"))) + (setq-local treesit-defun-name-function #'java-ts-mode--defun-name) + + (setq-local treesit-thing-settings + `((java + (sexp ,(rx (or "annotation" + "parenthesized_expression" + "argument_list" + "identifier" + "modifiers" + "block" + "body" + "literal" + "access" + "reference" + "_type" + "true" + "false"))) + (sentence ,(rx (or "statement" + "local_variable_declaration" + "field_declaration" + "module_declaration" + "package_declaration" + "import_declaration"))) + (text ,(regexp-opt '("line_comment" + "block_comment" + "text_block")))))) + + ;; Font-lock. + (setq-local treesit-font-lock-settings + java-ts-mode--font-lock-settings) + + ;; Inject doxygen parser for comment. + (when (and java-ts-mode-enable-doxygen (treesit-ready-p 'doxygen t)) + (setq-local treesit-primary-parser primary-parser) + (setq-local treesit-font-lock-settings + (append treesit-font-lock-settings + c-ts-mode-doxygen-comment-font-lock-settings)) + (setq-local treesit-range-settings + (treesit-range-rules + :embed 'doxygen + :host 'java + :local t + `(((block_comment) @cap (:match "/\\*\\*" @cap))))))) + (setq-local treesit-font-lock-feature-list java-ts-mode--feature-list) ;; Imenu. @@ -411,6 +439,9 @@ Return nil if there is no name or if NODE is not a defun node." (if (treesit-ready-p 'java) (add-to-list 'auto-mode-alist '("\\.java\\'" . java-ts-mode))) +(when (and java-ts-mode-enable-doxygen (not (treesit-ready-p 'doxygen t))) + (message "Doxygen syntax highlighting can't be enabled, please install the language grammar.")) + (provide 'java-ts-mode) ;;; java-ts-mode.el ends here diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 5ac5b88d17f..dbf721e8d0f 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -58,12 +58,8 @@ (eval-when-compile (require 'cl-lib) - (require 'ido) (require 'rx)) -(defvar ido-cur-list) -(defvar electric-layout-rules) -(declare-function ido-mode "ido" (&optional arg)) (declare-function treesit-parser-create "treesit.c") (declare-function treesit-induce-sparse-tree "treesit.c") (declare-function treesit-search-subtree "treesit.c") @@ -3289,11 +3285,7 @@ one from `js--get-all-known-symbols', using prompt PROMPT and initial input INITIAL-INPUT. Return a cons of (SYMBOL-NAME . LOCATION), where SYMBOL-NAME is a string and LOCATION is a marker." - (unless ido-mode - (ido-mode 1) - (ido-mode -1)) - - (let ((choice (ido-completing-read + (let ((choice (completing-read prompt (cl-loop for key being the hash-keys of symbols-table collect key) @@ -3861,11 +3853,14 @@ See `treesit-thing-settings' for more information.") "array" "function" "string" + "template_string" + "template_substitution" "escape" "template" "regex" "number" "identifier" + "property_identifier" "this" "super" "true" @@ -3928,7 +3923,7 @@ See `treesit-thing-settings' for more information.") (sexp ,(js--regexp-opt-symbol js--treesit-sexp-nodes)) (sentence ,(js--regexp-opt-symbol js--treesit-sentence-nodes)) (text ,(js--regexp-opt-symbol '("comment" - "template_string")))))) + "string_fragment")))))) ;; Fontification. (setq-local treesit-font-lock-settings js--treesit-font-lock-settings) diff --git a/lisp/progmodes/json-ts-mode.el b/lisp/progmodes/json-ts-mode.el index 1fb96555010..7409c6be833 100644 --- a/lisp/progmodes/json-ts-mode.el +++ b/lisp/progmodes/json-ts-mode.el @@ -128,7 +128,7 @@ Return nil if there is no name or if NODE is not a defun node." (unless (treesit-ready-p 'json) (error "Tree-sitter for JSON isn't available")) - (treesit-parser-create 'json) + (setq treesit-primary-parser (treesit-parser-create 'json)) ;; Comments. (setq-local comment-start "// ") diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el index d2ac67a9230..828636f359d 100644 --- a/lisp/progmodes/lua-ts-mode.el +++ b/lisp/progmodes/lua-ts-mode.el @@ -733,14 +733,12 @@ Calls REPORT-FN directly." ((buffer-live-p (process-buffer process)))) (with-current-buffer buffer (comint-write-input-ring)))) -(defvar lua-ts-mode-map - (let ((map (make-sparse-keymap "Lua"))) - (define-key map "\C-c\C-n" 'lua-ts-inferior-lua) - (define-key map "\C-c\C-c" 'lua-ts-send-buffer) - (define-key map "\C-c\C-l" 'lua-ts-send-file) - (define-key map "\C-c\C-r" 'lua-ts-send-region) - map) - "Keymap for `lua-ts-mode' buffers.") +(defvar-keymap lua-ts-mode-map + :doc "Keymap for `lua-ts-mode' buffers." + "C-c C-n" #'lua-ts-inferior-lua + "C-c C-c" #'lua-ts-send-buffer + "C-c C-l" #'lua-ts-send-file + "C-c C-r" #'lua-ts-send-region) (easy-menu-define lua-ts-mode-menu lua-ts-mode-map "Menu bar entry for `lua-ts-mode'." @@ -765,7 +763,7 @@ Calls REPORT-FN directly." (use-local-map lua-ts-mode-map) (when (treesit-ready-p 'lua) - (treesit-parser-create 'lua) + (setq treesit-primary-parser (treesit-parser-create 'lua)) ;; Comments. (setq-local comment-start "--") diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 87ebe81ca4c..5441903738d 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -83,7 +83,7 @@ (defface makefile-space '((((class color)) (:background "hotpink")) - (t (:reverse-video t))) + (t (:inverse-video t))) "Face to use for highlighting leading spaces in Font-Lock mode.") (defface makefile-targets @@ -102,7 +102,7 @@ (defface makefile-makepp-perl '((((class color) (background light)) (:background "LightBlue1")) ; Camel Book (((class color) (background dark)) (:background "DarkBlue")) - (t (:reverse-video t))) + (t (:inverse-video t))) "Face to use for additionally highlighting Perl code in Font-Lock mode." :version "22.1") @@ -704,7 +704,7 @@ The function must satisfy this calling convention: ;; Each "ARG" is used as a prompt for a required argument. (defconst makefile-gnumake-functions-alist '( - ;; Text functions + ;; Functions for String Substitution and Analysis ("subst" "From" "To" "In") ("patsubst" "Pattern" "Replacement" "In") ("strip" "Text") @@ -712,22 +712,42 @@ The function must satisfy this calling convention: ("filter" "Pattern" "Text") ("filter-out" "Pattern" "Text") ("sort" "List") - ;; Filename functions + ("word" "Index" "Text") + ("wordlist" "S" "E" "Text") + ("words" "Text") + ("firstword" "Text") + ("lastword" "Names") + ;; Functions for File Names ("dir" "Names") ("notdir" "Names") ("suffix" "Names") ("basename" "Names") - ("addprefix" "Prefix" "Names") ("addsuffix" "Suffix" "Names") + ("addprefix" "Prefix" "Names") ("join" "List 1" "List 2") - ("word" "Index" "Text") - ("words" "Text") - ("firstword" "Text") ("wildcard" "Pattern") + ("realpath" "Names") + ("abspath" "Names") + ;; Functions for Conditionals + ("if" "Condition" "Then-part" "Else-part") + ("or" "Condition 1" "Condition 2" "Condition 3" "Condition 4") + ("and" "Condition 1" "Condition 2" "Condition 3" "Condition 4") ;; Misc functions ("foreach" "Variable" "List" "Text") + ("file" "Op" "Filename" "Text") + ("call" "Variable" "Param 1" "Param 2" "Param 3" "Param 4" "Param 5") + ("value" "Variable") + ("eval" "statement") ("origin" "Variable") - ("shell" "Command"))) + ("flavor" "Variable") + ("shell" "Command") + ("guile" "Program") + ;; Functions that control make + ("error" "Text") + ("warning" "Text") + ("info" "Text") + ) + "Alist of GNU Make functions and their arguments.") ;;; ------------------------------------------------------------ diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index cc47880bcbb..68b1b9bfc9d 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -536,8 +536,6 @@ Non-nil means always go to the next Octave code line after sending." (put-text-property (match-beginning 1) (match-end 1) 'syntax-table (string-to-syntax "\"'"))))) -(defvar electric-layout-rules) - ;; FIXME: cc-mode.el also adds an entry for .m files, mapping them to ;; objc-mode. We here rely on the fact that loaddefs.el is filled in ;; alphabetical order, so cc-mode.el comes before octave-mode.el, which lets diff --git a/lisp/progmodes/peg.el b/lisp/progmodes/peg.el index 0b069e95563..115f692a030 100644 --- a/lisp/progmodes/peg.el +++ b/lisp/progmodes/peg.el @@ -438,10 +438,9 @@ rulesets defined previously with `define-peg-ruleset'." (macroexpand-all `(cl-labels ,(mapcar (lambda (rule) - ;; FIXME: Use `peg--lambda' as well. `(,(peg--rule-id (car rule)) - () - ,(peg--translate-rule-body (car rule) (cdr rule)))) + (peg--lambda ',(cdr rule) () + ,(peg--translate-rule-body (car rule) (cdr rule))))) rules) ,@body) `((:peg-rules ,@(append rules (cdr ctx))) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 68685fb6625..3c32fac3f42 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -963,8 +963,8 @@ changed by, or (parse-state) if line starts in a quoted string." (save-excursion (skip-chars-backward " \t\n") (beginning-of-line) - (when-let ((comm (and (looking-at "^\\.$") - (nth 8 (syntax-ppss))))) + (when-let* ((comm (and (looking-at "^\\.$") + (nth 8 (syntax-ppss))))) (goto-char comm) (beginning-of-line) (looking-at perl--format-regexp)))) @@ -1128,16 +1128,9 @@ Returns (parse-state) if line starts inside a string." ;; Move back over whitespace before the openbrace. ;; If openbrace is not first nonwhite thing on the line, ;; add the perl-brace-imaginary-offset. - (progn (skip-chars-backward " \t") - (if (bolp) 0 perl-brace-imaginary-offset)) - ;; If the openbrace is preceded by a parenthesized exp, - ;; move to the beginning of that; - ;; possibly a different line - (progn - (if (eq (preceding-char) ?\)) - (forward-sexp -1)) - ;; Get initial indentation of the line we are on. - (current-indentation))))))))) + (save-excursion (skip-chars-backward " \t") + (if (bolp) 0 perl-brace-imaginary-offset)) + (perl-indent-new-calculate 'virtual)))))))) (defun perl-backward-to-noncomment () "Move point backward to after the first non-white-space, skipping comments." diff --git a/lisp/progmodes/php-ts-mode.el b/lisp/progmodes/php-ts-mode.el index 6052c79ccf3..10f290d24ea 100644 --- a/lisp/progmodes/php-ts-mode.el +++ b/lisp/progmodes/php-ts-mode.el @@ -595,12 +595,12 @@ doesn't have a child. PARENT is NODE's parent, BOL is the beginning of non-whitespace characters of the current line." - (when-let ((prev-sibling - (or (treesit-node-prev-sibling node t) - (treesit-node-prev-sibling - (treesit-node-first-child-for-pos parent bol) t) - (treesit-node-child parent -1 t))) - (continue t)) + (when-let* ((prev-sibling + (or (treesit-node-prev-sibling node t) + (treesit-node-prev-sibling + (treesit-node-first-child-for-pos parent bol) t) + (treesit-node-child parent -1 t))) + (continue t)) (save-excursion (while (and prev-sibling continue) (goto-char (treesit-node-start prev-sibling)) @@ -1236,8 +1236,8 @@ Return nil if the NODE has no field “name” or if NODE is not a defun node." "Indent the current top-level declaration syntactically. `treesit-defun-type-regexp' defines what constructs to indent." (interactive "*") - (when-let ((orig-point (point-marker)) - (node (treesit-defun-at-point))) + (when-let* ((orig-point (point-marker)) + (node (treesit-defun-at-point))) (indent-region (treesit-node-start node) (treesit-node-end node)) (goto-char orig-point))) @@ -1557,14 +1557,17 @@ Depends on `c-ts-common-comment-setup'." ;; should be the last one (setq-local treesit-primary-parser (treesit-parser-create 'php)) - (treesit-font-lock-recompute-features) (treesit-major-mode-setup) (add-hook 'flymake-diagnostic-functions #'php-ts-mode-flymake-php nil 'local))) ;;;###autoload -(defun php-ts-mode-run-php-webserver (&optional port hostname document-root - router-script num-of-workers) +(defun php-ts-mode-run-php-webserver (&optional port + hostname + document-root + router-script + num-of-workers + config) "Run PHP built-in web server. PORT: Port number of built-in web server, default `php-ts-mode-ws-port'. @@ -1578,10 +1581,12 @@ ROUTER-SCRIPT: Path of the router PHP script, see `https://www.php.net/manual/en/features.commandline.webserver.php' NUM-OF-WORKERS: Before run the web server set the PHP_CLI_SERVER_WORKERS env variable useful for testing code against -multiple simultaneous requests. +multiple simultaneous requests +CONFIG: Alternative php.ini config, default `php-ts-mode-php-config'. -Interactively, when invoked with prefix argument, always prompt -for PORT, HOSTNAME, DOCUMENT-ROOT and ROUTER-SCRIPT." +Interactively, when invoked with prefix argument, always prompt for +PORT, HOSTNAME, DOCUMENT-ROOT, ROUTER-SCRIPT, NUM-OF-WORKERS and +CONFIG." (interactive (when current-prefix-arg (php-ts-mode--webserver-read-args))) (let* ((port (or @@ -1596,6 +1601,9 @@ for PORT, HOSTNAME, DOCUMENT-ROOT and ROUTER-SCRIPT." document-root php-ts-mode-ws-document-root (php-ts-mode--webserver-read-args 'document-root))) + (config (or config + (when php-ts-mode-php-config + (expand-file-name php-ts-mode-php-config)))) (host (format "%s:%d" hostname port)) (name (format "PHP web server on: %s" host)) (buf-name (format "*%s*" name)) @@ -1603,12 +1611,18 @@ for PORT, HOSTNAME, DOCUMENT-ROOT and ROUTER-SCRIPT." nil (list "-S" host "-t" document-root + (when config + (format "-c %s" config)) router-script))) (process-environment - (cons (cond - (num-of-workers (format "PHP_CLI_SERVER_WORKERS=%d" num-of-workers)) - (php-ts-mode-ws-workers (format "PHP_CLI_SERVER_WORKERS=%d" php-ts-mode-ws-workers))) - process-environment))) + (nconc (cond + (num-of-workers + (list + (format "PHP_CLI_SERVER_WORKERS=%d" num-of-workers))) + (php-ts-mode-ws-workers + (list + (format "PHP_CLI_SERVER_WORKERS=%d" php-ts-mode-ws-workers)))) + process-environment))) (if (get-buffer buf-name) (message "Switch to already running web server into buffer %s" buf-name) (message "Run PHP built-in web server with args %s into buffer %s" @@ -1623,12 +1637,17 @@ for PORT, HOSTNAME, DOCUMENT-ROOT and ROUTER-SCRIPT." (defun php-ts-mode--webserver-read-args (&optional type) "Helper for `php-ts-mode-run-php-webserver'. -The optional TYPE can be the symbol \"port\", \"hostname\", \"document-root\" or -\"router-script\", otherwise it requires all of them." +The optional TYPE can be the symbol \"port\", \"hostname\", \"document-root\", +\"router-script\", \"num-workers\" or \"config\", otherwise it requires all of them." (let ((ask-port (lambda () - (read-number "Port: " 3000))) + (read-number "Port: " (or + php-ts-mode-ws-port + 3000)))) (ask-hostname (lambda () - (read-string "Hostname: " "localhost"))) + (read-string "Hostname: " + (or + php-ts-mode-ws-hostname + "localhost")))) (ask-document-root (lambda () (expand-file-name (read-directory-name "Document root: " @@ -1640,17 +1659,40 @@ The optional TYPE can be the symbol \"port\", \"hostname\", \"document-root\" or (read-file-name "Router script: " (file-name-directory (or (buffer-file-name) - default-directory))))))) + default-directory)))))) + (ask-num-workers (lambda () + (let ((num-workers + (read-number + "Number of workers (less then 2 means no workers): " + (or php-ts-mode-ws-workers 0)))) + ;; num-workers must be >= 2 or nil + ;; otherwise PHP's built-in web server will not start. + (if (> num-workers 1) + num-workers + nil)))) + (ask-config (lambda() + (let ((file-name (expand-file-name + (read-file-name "Alternative php.ini: " + (file-name-directory + (or (buffer-file-name) + default-directory)))))) + (if (string= "" (file-name-directory file-name)) + nil + file-name))))) (cl-case type (port (funcall ask-port)) (hostname (funcall ask-hostname)) (document-root (funcall ask-document-root)) (router-script (funcall ask-router-script)) + (num-of-workers (funcall ask-num-workers)) + (config (funcall ask-config)) (t (list (funcall ask-port) (funcall ask-hostname) (funcall ask-document-root) - (funcall ask-router-script)))))) + (funcall ask-router-script) + (funcall ask-num-workers) + (funcall ask-config)))))) (define-derived-mode inferior-php-ts-mode comint-mode "Inferior PHP" "Major mode for PHP inferior process." diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index fdcaa2c7ddc..ed6be453274 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -199,7 +199,9 @@ When it is non-nil, `project-current' will always skip prompting too.") (defcustom project-prompter #'project-prompt-project-dir "Function to call to prompt for a project. -Called with no arguments and should return a project root dir." +The function is either called with no arguments or with one argument, +which is the prompt string to use. It should return a project root +directory." :type '(choice (const :tag "Prompt for a project directory" project-prompt-project-dir) (const :tag "Prompt for a project name" @@ -218,7 +220,8 @@ else prompt the user for the project to use. To prompt for a project, call the function specified by `project-prompter', which returns the directory in which to look for the project. If no project is found in that directory, return a \"transient\" -project instance. +project instance. When MAYBE-PROMPT is a string, it's passed to the +prompter function as an argument. The \"transient\" project instance is a special kind of value which denotes a project rooted in that directory and includes all @@ -235,7 +238,9 @@ of the project instance object." (pr) ((unless project-current-directory-override maybe-prompt) - (setq directory (funcall project-prompter) + (setq directory (if (stringp maybe-prompt) + (funcall project-prompter maybe-prompt) + (funcall project-prompter)) pr (project--find-in-directory directory)))) (when maybe-prompt (if pr @@ -586,10 +591,10 @@ See `project-vc-extra-root-markers' for the marker value format.") last-matches)) vc-handled-backends)) project) - (when (and - (eq backend 'Git) - (project--vc-merge-submodules-p root) - (project--submodule-p root)) + (while (and + (eq backend 'Git) + (project--vc-merge-submodules-p root) + (project--submodule-p root)) (let* ((parent (file-name-directory (directory-file-name root)))) (setq root (vc-call-backend 'Git 'root parent)))) (when root @@ -666,7 +671,7 @@ See `project-vc-extra-root-markers' for the marker value format.") (pcase backend (`Git (let* ((default-directory (expand-file-name (file-name-as-directory dir))) - (args '("-z")) + (args '("-z" "-c" "--exclude-standard")) (vc-git-use-literal-pathspecs nil) (include-untracked (project--value-in-dir 'project-vc-include-untracked @@ -674,7 +679,9 @@ See `project-vc-extra-root-markers' for the marker value format.") (submodules (project--git-submodules)) files) (setq args (append args - '("-c" "--exclude-standard") + (and (<= 31 emacs-major-version) + (version<= "2.35" (vc-git--program-version)) + '("--sparse")) (and include-untracked '("-o")))) (when extra-ignores (setq args (append args @@ -706,7 +713,10 @@ See `project-vc-extra-root-markers' for the marker value format.") (delq nil (mapcar (lambda (file) - (unless (member file submodules) + (unless (or (member file submodules) + ;; Should occur for sparse directories + ;; only, when sparse index is enabled. + (directory-name-p file)) (if project-files-relative-names file (concat default-directory file)))) @@ -919,7 +929,7 @@ DIRS must contain directory names." (generic-cmd (lookup-key project-prefix-map key)) (switch-to-buffer-obey-display-actions t) (display-buffer-overriding-action (unless place-cmd action))) - (if-let ((cmd (or place-cmd generic-cmd))) + (if-let* ((cmd (or place-cmd generic-cmd))) (call-interactively cmd) (user-error "%s is undefined" (key-description key))))) @@ -1068,14 +1078,26 @@ relative to PROJECT instead. This supports using a relative file name from the current buffer when switching projects with `project-switch-project' and then using a command like `project-find-file'." - (if-let (filename-proj (and project-current-directory-override - (project-current nil default-directory))) + (if-let* ((filename-proj (and project-current-directory-override + (project-current nil default-directory)))) ;; file-name-concat requires Emacs 28+ (concat (file-name-as-directory (project-root project)) (file-relative-name filename (project-root filename-proj))) filename)) ;;;###autoload +(defun project-root-find-file (filename) + "Edit file FILENAME. + +Interactively, prompt for FILENAME, defaulting to the root directory of +the current project." + (declare (interactive-only find-file)) + (interactive (list (read-file-name "Find file in root: " + (project-root (project-current t)) nil + (confirm-nonexistent-file-or-buffer)))) + (find-file filename t)) + +;;;###autoload (defun project-find-file (&optional include-all) "Visit a file (with completion) in the current project. @@ -1124,9 +1146,9 @@ for VCS directories listed in `vc-directory-exclusion-list'." (defcustom project-read-file-name-function #'project--read-file-cpd-relative "Function to call to read a file name from a list. For the arguments list, see `project--read-file-cpd-relative'." - :type '(choice (const :tag "Read with completion from relative names" + :type '(choice (const :tag "Read with completion from relative file names" project--read-file-cpd-relative) - (const :tag "Read with completion from absolute names" + (const :tag "Read with completion from file names" project--read-file-absolute) (function :tag "Custom function" nil)) :group 'project @@ -1148,7 +1170,7 @@ This has the effect of sharing more history between projects." :version "30.1") (defun project--transplant-file-name (filename project) - (when-let ((old-root (get-text-property 0 'project filename))) + (when-let* ((old-root (get-text-property 0 'project filename))) (expand-file-name (file-relative-name filename old-root) (project-root project)))) @@ -1176,53 +1198,34 @@ by the user at will." (file-name-absolute-p (car all-files))) prompt (concat prompt (format " in %s" common-parent-directory)))) - (included-cpd (when (member common-parent-directory all-files) - (setq all-files - (delete common-parent-directory all-files)) - t)) - (mb-default (mapcar (lambda (mb-default) - (if (and common-parent-directory - mb-default - (file-name-absolute-p mb-default)) - (file-relative-name - mb-default common-parent-directory) - mb-default)) - (if (listp mb-default) mb-default (list mb-default)))) (substrings (mapcar (lambda (s) (substring s cpd-length)) all-files)) - (_ (when included-cpd - (setq substrings (cons "./" substrings)))) (new-collection (project--file-completion-table substrings)) - (abs-cpd (expand-file-name common-parent-directory)) - (abs-cpd-length (length abs-cpd)) - (relname (cl-letf* ((non-essential t) ;Avoid new Tramp connections. - ((symbol-value hist) - (mapcan - (lambda (s) - (setq s (expand-file-name s)) - (and (string-prefix-p abs-cpd s) - (not (eq abs-cpd-length (length s))) - (list (substring s abs-cpd-length)))) - (symbol-value hist)))) - (project--completing-read-strict prompt - new-collection - predicate - hist mb-default))) + (relname (project--completing-read-strict prompt + new-collection + predicate + hist mb-default + (unless (equal common-parent-directory "") + common-parent-directory))) (absname (expand-file-name relname common-parent-directory))) absname)) (defun project--read-file-absolute (prompt all-files &optional predicate hist mb-default) - (let* ((new-prompt (if (file-name-absolute-p (car all-files)) + (let* ((names-absolute (file-name-absolute-p (car all-files))) + (new-prompt (if names-absolute prompt (concat prompt " in " default-directory))) - ;; FIXME: Map relative names to absolute? + ;; TODO: The names are intentionally not absolute in many cases. + ;; Probably better to rename this function. (ct (project--file-completion-table all-files)) (file (project--completing-read-strict new-prompt ct predicate - hist mb-default))) + hist mb-default + (unless names-absolute + default-directory)))) (unless (file-name-absolute-p file) (setq file (expand-file-name file))) file)) @@ -1281,17 +1284,39 @@ directories listed in `vc-directory-exclusion-list'." (defun project--completing-read-strict (prompt collection &optional predicate - hist mb-default) - (minibuffer-with-setup-hook - (lambda () - (setq-local minibuffer-default-add-function - (lambda () - (let ((minibuffer-default mb-default)) - (minibuffer-default-add-completions))))) - (completing-read (format "%s: " prompt) - collection predicate 'confirm - nil - hist))) + hist mb-default + common-parent-directory) + (cl-letf* ((mb-default (mapcar (lambda (mb-default) + (if (and common-parent-directory + mb-default + (file-name-absolute-p mb-default)) + (file-relative-name + mb-default common-parent-directory) + mb-default)) + (if (listp mb-default) mb-default (list mb-default)))) + (abs-cpd (expand-file-name (or common-parent-directory ""))) + (abs-cpd-length (length abs-cpd)) + (non-essential t) ;Avoid new Tramp connections. + ((symbol-value hist) + (if common-parent-directory + (mapcan + (lambda (s) + (setq s (expand-file-name s)) + (and (string-prefix-p abs-cpd s) + (not (eq abs-cpd-length (length s))) + (list (substring s abs-cpd-length)))) + (symbol-value hist)) + (symbol-value hist)))) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-default-add-function + (lambda () + (let ((minibuffer-default mb-default)) + (minibuffer-default-add-completions))))) + (completing-read (format "%s: " prompt) + collection predicate 'confirm + nil + hist)))) ;;;###autoload (defun project-find-dir () @@ -1301,6 +1326,7 @@ The current buffer's `default-directory' is available as part of \"future history\"." (interactive) (let* ((project (project-current t)) + (project-files-relative-names t) (all-files (project-files project)) (completion-ignore-case read-file-name-completion-ignore-case) ;; FIXME: This misses directories without any files directly @@ -1308,11 +1334,15 @@ The current buffer's `default-directory' is available as part of ;; `project-files-filtered', and see ;; https://stackoverflow.com/a/50685235/615245 for possible ;; implementation. - (all-dirs (mapcar #'file-name-directory all-files)) + (all-dirs (cons "./" + (delq nil + ;; Some completion UIs show duplicates. + (delete-dups + (mapcar #'file-name-directory all-files))))) + (default-directory (project-root project)) (dir (project--read-file-name project "Dired" - ;; Some completion UIs show duplicates. - (delete-dups all-dirs) + all-dirs nil 'file-name-history (and default-directory (project--find-default-from default-directory project))))) @@ -1346,7 +1376,8 @@ if one already exists." (shell-buffer (get-buffer default-project-shell-name))) (if (and shell-buffer (not current-prefix-arg)) (if (comint-check-proc shell-buffer) - (pop-to-buffer shell-buffer (bound-and-true-p display-comint-buffer-action)) + (pop-to-buffer shell-buffer (append display-buffer--same-window-action + '((category . comint)))) (shell shell-buffer)) (shell (generate-new-buffer-name default-project-shell-name))))) @@ -1363,7 +1394,8 @@ if one already exists." (eshell-buffer-name (project-prefixed-buffer-name "eshell")) (eshell-buffer (get-buffer eshell-buffer-name))) (if (and eshell-buffer (not current-prefix-arg)) - (pop-to-buffer eshell-buffer (bound-and-true-p display-comint-buffer-action)) + (pop-to-buffer eshell-buffer (append display-buffer--same-window-action + '((category . comint)))) (eshell t)))) ;;;###autoload @@ -1424,7 +1456,7 @@ If you exit the `query-replace', you can later continue the (defun project-prefixed-buffer-name (mode) (concat "*" - (if-let ((proj (project-current nil))) + (if-let* ((proj (project-current nil))) (project-name proj) (file-name-nondirectory (directory-file-name default-directory))) @@ -1721,7 +1753,7 @@ in `project-kill-buffer-conditions'." bufs)) ;;;###autoload -(defun project-kill-buffers (&optional no-confirm) +(defun project-kill-buffers (&optional no-confirm project) "Kill the buffers belonging to the current project. Two buffers belong to the same project if their project instances, as reported by `project-current' in each buffer, are @@ -1731,9 +1763,11 @@ is non-nil, the command will not ask the user for confirmation. NO-CONFIRM is always nil when the command is invoked interactively. +If PROJECT is non-nil, kill buffers for that project instead. + Also see the `project-kill-buffers-display-buffer-list' variable." (interactive) - (let* ((pr (project-current t)) + (let* ((pr (or project (project-current t))) (bufs (project--buffers-to-kill pr)) (query-user (lambda () (yes-or-no-p @@ -1849,7 +1883,7 @@ result in `project-list-file'. Announce the project's removal from the list using REPORT-MESSAGE, which is a format string passed to `message' as its first argument." (project--ensure-read-project-list) - (when-let ((ent (assoc (abbreviate-file-name project-root) project--list))) + (when-let* ((ent (assoc (abbreviate-file-name project-root) project--list))) (setq project--list (delq ent project--list)) (message report-message project-root) (project--write-project-list))) @@ -1865,11 +1899,12 @@ the project list." (defvar project--dir-history) -(defun project-prompt-project-dir () +(defun project-prompt-project-dir (&optional prompt) "Prompt the user for a directory that is one of the known project roots. The project is chosen among projects known from the project list, see `project-list-file'. -It's also possible to enter an arbitrary directory not in the list." +It's also possible to enter an arbitrary directory not in the list. +When PROMPT is non-nil, use it as the prompt string." (project--ensure-read-project-list) (let* ((dir-choice "... (choose a dir)") (choices @@ -1883,18 +1918,23 @@ It's also possible to enter an arbitrary directory not in the list." ;; If the user simply pressed RET, do this again until they don't. (setq pr-dir (let (history-add-new-input) - (completing-read "Select project: " choices nil t nil 'project--dir-history)))) + (completing-read (if prompt + ;; TODO: Use `format-prompt' (Emacs 28.1+) + (format "%s: " (substitute-command-keys prompt)) + "Select project: ") + choices nil t nil 'project--dir-history)))) (if (equal pr-dir dir-choice) (read-directory-name "Select directory: " default-directory nil t) pr-dir))) (defvar project--name-history) -(defun project-prompt-project-name () +(defun project-prompt-project-name (&optional prompt) "Prompt the user for a project, by name, that is one of the known project roots. The project is chosen among projects known from the project list, see `project-list-file'. -It's also possible to enter an arbitrary directory not in the list." +It's also possible to enter an arbitrary directory not in the list. +When PROMPT is non-nil, use it as the prompt string." (let* ((dir-choice "... (choose a dir)") project--name-history (choices @@ -1904,8 +1944,8 @@ It's also possible to enter an arbitrary directory not in the list." (dolist (dir (reverse (project-known-project-roots))) ;; We filter out directories that no longer map to a project, ;; since they don't have a clean project-name. - (when-let ((proj (project--find-in-directory dir)) - (name (project-name proj))) + (when-let* ((proj (project--find-in-directory dir)) + (name (project-name proj))) (push name project--name-history) (push (cons name proj) ret))) (reverse ret))) @@ -1918,7 +1958,10 @@ It's also possible to enter an arbitrary directory not in the list." ;; If the user simply pressed RET, do this again until they don't. (setq pr-name (let (history-add-new-input) - (completing-read "Select project: " table nil t nil 'project--name-history)))) + (completing-read (if prompt + (format "%s: " prompt) + "Select project: ") + table nil t nil 'project--name-history)))) (if (equal pr-name dir-choice) (read-directory-name "Select directory: " default-directory nil t) (let ((proj (assoc pr-name choices))) @@ -1930,6 +1973,12 @@ It's also possible to enter an arbitrary directory not in the list." (project--ensure-read-project-list) (mapcar #'car project--list)) +(defun project-read-project () + "Read a project with completion from the known list. +Returns an object that the API methods can be used with." + ;; Will prompt again if the entered directory is not a project anymore. + (project-current t (funcall project-prompter))) + ;;;###autoload (defun project-execute-extended-command () "Execute an extended command in project root." @@ -1993,10 +2042,10 @@ projects." (dolist (project (mapcar #'car project--list)) (puthash project t known)) (dolist (subdir dirs) - (when-let (((file-directory-p subdir)) - (project (project--find-in-directory subdir)) - (project-root (project-root project)) - ((not (gethash project-root known)))) + (when-let* (((file-directory-p subdir)) + (project (project--find-in-directory subdir)) + (project-root (project-root project)) + ((not (gethash project-root known)))) (project-remember-project project t) (puthash project-root t known) (message "Found %s..." project-root) @@ -2144,8 +2193,8 @@ Otherwise, use the face `help-key-binding' in the prompt." (let ((temp-map (make-sparse-keymap))) (set-keymap-parent temp-map project-prefix-map) (dolist (row commands-menu temp-map) - (when-let ((cmd (nth 0 row)) - (keychar (nth 2 row))) + (when-let* ((cmd (nth 0 row)) + (keychar (nth 2 row))) (define-key temp-map (vector keychar) cmd))))) command choice) @@ -2202,7 +2251,7 @@ If you set `uniquify-dirname-transform' to this function, slash-separated components from `project-name' will be appended to the buffer's directory name when buffers from two different projects would otherwise have the same name." - (if-let (proj (project-current nil dirname)) + (if-let* ((proj (project-current nil dirname))) (let ((root (project-root proj))) (expand-file-name (file-name-concat @@ -2237,7 +2286,7 @@ is part of the default mode line beginning with Emacs 30." (defun project-mode-line-format () "Compose the project mode-line." - (when-let ((project (project-current))) + (when-let* ((project (project-current))) ;; Preserve the global value of 'last-coding-system-used' ;; that 'write-region' needs to set for 'basic-save-buffer', ;; but updating the mode line might occur at the same time diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 0001bdd21a9..cfa3cc59568 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -277,7 +277,19 @@ (autoload 'help-function-arglist "help-fns") ;;;###autoload -(add-to-list 'auto-mode-alist (cons (purecopy "\\.py[iw]?\\'") 'python-mode)) +(defconst python--auto-mode-alist-regexp + ;; (rx (or + ;; (seq "." (or "py" + ;; "pth" ; Python Path Configuration File + ;; "pyi" ; Python Stub File (PEP 484) + ;; "pyw")) ; MS-Windows specific extension + ;; (seq "/" (or "SConstruct" "SConscript"))) ; SCons Build Files + ;; eos) + "\\(?:\\.\\(?:p\\(?:th\\|y[iw]?\\)\\)\\|/\\(?:SCons\\(?:\\(?:crip\\|truc\\)t\\)\\)\\)\\'" + ) + +;;;###autoload +(add-to-list 'auto-mode-alist (cons python--auto-mode-alist-regexp 'python-mode)) ;;;###autoload (add-to-list 'interpreter-mode-alist (cons (purecopy "python[0-9.]*") 'python-mode)) @@ -287,14 +299,16 @@ :version "24.3" :link '(emacs-commentary-link "python")) -(defcustom python-interpreter "python" +(defcustom python-interpreter + (cond ((executable-find "python") "python") + (t "python3")) "Python interpreter for noninteractive use. Some Python interpreters also require changes to `python-interpreter-args'. To customize the Python interpreter for interactive use, modify `python-shell-interpreter' instead." - :version "29.1" + :version "31.1" :type 'string) (defcustom python-interpreter-args "" @@ -305,107 +319,112 @@ To customize the Python interpreter for interactive use, modify ;;; Bindings -(defvar python-mode-map - (let ((map (make-sparse-keymap))) - ;; Movement - (define-key map [remap backward-sentence] #'python-nav-backward-block) - (define-key map [remap forward-sentence] #'python-nav-forward-block) - (define-key map [remap backward-up-list] #'python-nav-backward-up-list) - (define-key map [remap up-list] #'python-nav-up-list) - (define-key map [remap mark-defun] #'python-mark-defun) - (define-key map "\C-c\C-j" #'imenu) - ;; Indent specific - (define-key map "\177" #'python-indent-dedent-line-backspace) - (define-key map (kbd "<backtab>") #'python-indent-dedent-line) - (define-key map "\C-c<" #'python-indent-shift-left) - (define-key map "\C-c>" #'python-indent-shift-right) - ;; Skeletons - (define-key map "\C-c\C-tc" #'python-skeleton-class) - (define-key map "\C-c\C-td" #'python-skeleton-def) - (define-key map "\C-c\C-tf" #'python-skeleton-for) - (define-key map "\C-c\C-ti" #'python-skeleton-if) - (define-key map "\C-c\C-tm" #'python-skeleton-import) - (define-key map "\C-c\C-tt" #'python-skeleton-try) - (define-key map "\C-c\C-tw" #'python-skeleton-while) - ;; Shell interaction - (define-key map "\C-c\C-p" #'run-python) - (define-key map "\C-c\C-s" #'python-shell-send-string) - (define-key map "\C-c\C-e" #'python-shell-send-statement) - (define-key map "\C-c\C-r" #'python-shell-send-region) - (define-key map "\C-\M-x" #'python-shell-send-defun) - (define-key map "\C-c\C-b" #'python-shell-send-block) - (define-key map "\C-c\C-c" #'python-shell-send-buffer) - (define-key map "\C-c\C-l" #'python-shell-send-file) - (define-key map "\C-c\C-z" #'python-shell-switch-to-shell) - ;; Some util commands - (define-key map "\C-c\C-v" #'python-check) - (define-key map "\C-c\C-f" #'python-eldoc-at-point) - (define-key map "\C-c\C-d" #'python-describe-at-point) - ;; Import management - (define-key map "\C-c\C-ia" #'python-add-import) - (define-key map "\C-c\C-if" #'python-fix-imports) - (define-key map "\C-c\C-ir" #'python-remove-import) - (define-key map "\C-c\C-is" #'python-sort-imports) - ;; Utilities - (substitute-key-definition #'complete-symbol #'completion-at-point - map global-map) - (easy-menu-define python-menu map "Python Mode menu" - '("Python" - :help "Python-specific Features" - ["Shift region left" python-indent-shift-left :active mark-active - :help "Shift region left by a single indentation step"] - ["Shift region right" python-indent-shift-right :active mark-active - :help "Shift region right by a single indentation step"] - "-" - ["Start of def/class" beginning-of-defun - :help "Go to start of outermost definition around point"] - ["End of def/class" end-of-defun - :help "Go to end of definition around point"] - ["Mark def/class" mark-defun - :help "Mark outermost definition around point"] - ["Jump to def/class" imenu - :help "Jump to a class or function definition"] - "--" - ("Skeletons") - "---" - ["Start interpreter" run-python - :help "Run inferior Python process in a separate buffer"] - ["Switch to shell" python-shell-switch-to-shell - :help "Switch to running inferior Python process"] - ["Eval string" python-shell-send-string - :help "Eval string in inferior Python session"] - ["Eval block" python-shell-send-block - :help "Eval block in inferior Python session"] - ["Eval buffer" python-shell-send-buffer - :help "Eval buffer in inferior Python session"] - ["Eval statement" python-shell-send-statement - :help "Eval statement in inferior Python session"] - ["Eval region" python-shell-send-region - :help "Eval region in inferior Python session"] - ["Eval defun" python-shell-send-defun - :help "Eval defun in inferior Python session"] - ["Eval file" python-shell-send-file - :help "Eval file in inferior Python session"] - ["Debugger" pdb :help "Run pdb under GUD"] - "----" - ["Check file" python-check - :help "Check file for errors"] - ["Help on symbol" python-eldoc-at-point - :help "Get help on symbol at point"] - ["Complete symbol" completion-at-point - :help "Complete symbol before point"] - "-----" - ["Add import" python-add-import - :help "Add an import statement to the top of this buffer"] - ["Remove import" python-remove-import - :help "Remove an import statement from the top of this buffer"] - ["Sort imports" python-sort-imports - :help "Sort the import statements at the top of this buffer"] - ["Fix imports" python-fix-imports - :help "Add missing imports and remove unused ones from the current buffer"] - )) - map) - "Keymap for `python-mode'.") +(defvar-keymap python-mode-map + :doc "Keymap for `python-mode'." + ;; Movement + "<remap> <backward-sentence>" #'python-nav-backward-block + "<remap> <forward-sentence>" #'python-nav-forward-block + "<remap> <backward-up-list>" #'python-nav-backward-up-list + "<remap> <up-list>" #'python-nav-up-list + "<remap> <mark-defun>" #'python-mark-defun + "C-c C-j" #'imenu + ;; Indent specific + "DEL" #'python-indent-dedent-line-backspace + "<backtab>" #'python-indent-dedent-line + "C-c <" #'python-indent-shift-left + "C-c >" #'python-indent-shift-right + ;; Skeletons + "C-c C-t c" #'python-skeleton-class + "C-c C-t d" #'python-skeleton-def + "C-c C-t f" #'python-skeleton-for + "C-c C-t i" #'python-skeleton-if + "C-c C-t m" #'python-skeleton-import + "C-c C-t t" #'python-skeleton-try + "C-c C-t w" #'python-skeleton-while + ;; Shell interaction + "C-c C-p" #'run-python + "C-c C-s" #'python-shell-send-string + "C-c C-e" #'python-shell-send-statement + "C-c C-r" #'python-shell-send-region + "C-M-x" #'python-shell-send-defun + "C-c C-b" #'python-shell-send-block + "C-c C-c" #'python-shell-send-buffer + "C-c C-l" #'python-shell-send-file + "C-c C-z" #'python-shell-switch-to-shell + ;; Some util commands + "C-c C-v" #'python-check + "C-c C-f" #'python-eldoc-at-point + "C-c C-d" #'python-describe-at-point + ;; Import management + "C-c C-i a" #'python-add-import + "C-c C-i f" #'python-fix-imports + "C-c C-i r" #'python-remove-import + "C-c C-i s" #'python-sort-imports + ;; Utilities + "<remap> <complete-symbol>" #'completion-at-point) + +(defvar subword-mode nil) + +(easy-menu-define python-menu python-mode-map + "Menu used for ´python-mode'." + '("Python" + :help "Python-specific Features" + ["Shift region left" python-indent-shift-left :active mark-active + :help "Shift region left by a single indentation step"] + ["Shift region right" python-indent-shift-right :active mark-active + :help "Shift region right by a single indentation step"] + "-----" + ["Start of def/class" beginning-of-defun + :help "Go to start of outermost definition around point"] + ["End of def/class" end-of-defun + :help "Go to end of definition around point"] + ["Mark def/class" mark-defun + :help "Mark outermost definition around point"] + ["Jump to def/class" imenu + :help "Jump to a class or function definition"] + "-----" + ("Skeletons") + "-----" + ["Start interpreter" run-python + :help "Run inferior Python process in a separate buffer"] + ["Switch to shell" python-shell-switch-to-shell + :help "Switch to running inferior Python process"] + ["Eval string" python-shell-send-string + :help "Eval string in inferior Python session"] + ["Eval block" python-shell-send-block + :help "Eval block in inferior Python session"] + ["Eval buffer" python-shell-send-buffer + :help "Eval buffer in inferior Python session"] + ["Eval statement" python-shell-send-statement + :help "Eval statement in inferior Python session"] + ["Eval region" python-shell-send-region + :help "Eval region in inferior Python session"] + ["Eval defun" python-shell-send-defun + :help "Eval defun in inferior Python session"] + ["Eval file" python-shell-send-file + :help "Eval file in inferior Python session"] + ["Debugger" pdb :help "Run pdb under GUD"] + "-----" + ["Check file" python-check + :help "Check file for errors"] + ["Help on symbol" python-eldoc-at-point + :help "Get help on symbol at point"] + ["Complete symbol" completion-at-point + :help "Complete symbol before point"] + "-----" + ["Add import" python-add-import + :help "Add an import statement to the top of this buffer"] + ["Remove import" python-remove-import + :help "Remove an import statement from the top of this buffer"] + ["Sort imports" python-sort-imports + :help "Sort the import statements at the top of this buffer"] + ["Fix imports" python-fix-imports + :help "Add missing imports and remove unused ones from the current buffer"] + "-----" + ("Toggle..." + ["Subword Mode" subword-mode + :style toggle :selected subword-mode + :help "Toggle subword movement and editing mode"]))) (defvar python-ts-mode-map (copy-keymap python-mode-map) "Keymap for `python-ts-mode'.") @@ -698,13 +717,14 @@ class declarations.") "reload" "unichr" "unicode" "xrange" "apply" "buffer" "coerce" "intern" ;; Python 3: - "ascii" "breakpoint" "bytearray" "bytes" "exec" + "aiter" "anext" "ascii" "breakpoint" "bytearray" "bytes" "exec" ;; Special attributes: ;; https://docs.python.org/3/reference/datamodel.html - "__annotations__" "__closure__" "__code__" - "__defaults__" "__dict__" "__doc__" "__globals__" - "__kwdefaults__" "__name__" "__module__" "__package__" - "__qualname__" + "__annotations__" "__bases__" "__closure__" "__code__" + "__defaults__" "__dict__" "__doc__" "__firstlineno__" + "__globals__" "__kwdefaults__" "__name__" "__module__" + "__mro__" "__package__" "__qualname__" + "__static_attributes__" "__type_params__" ;; Extras: "__all__") symbol-end) . font-lock-builtin-face)) @@ -767,11 +787,12 @@ sign in chained assignment." ;; Python 3: "BlockingIOError" "BrokenPipeError" "ChildProcessError" "ConnectionAbortedError" "ConnectionError" "ConnectionRefusedError" - "ConnectionResetError" "FileExistsError" "FileNotFoundError" - "InterruptedError" "IsADirectoryError" "NotADirectoryError" - "PermissionError" "ProcessLookupError" "RecursionError" + "ConnectionResetError" "EncodingWarning" "FileExistsError" + "FileNotFoundError" "InterruptedError" "IsADirectoryError" + "NotADirectoryError" "ModuleNotFoundError" "PermissionError" + "ProcessLookupError" "PythonFinalizationError" "RecursionError" "ResourceWarning" "StopAsyncIteration" "TimeoutError" - "ExceptionGroup" + "BaseExceptionGroup" "ExceptionGroup" ;; OS specific "VMSError" "WindowsError" ) @@ -790,7 +811,7 @@ sign in chained assignment." (3 'font-lock-operator-face) (,(python-rx symbol-name) (progn - (when-let ((type-start (match-beginning 2))) + (when-let* ((type-start (match-beginning 2))) (goto-char type-start)) (match-end 0)) nil @@ -995,7 +1016,7 @@ It makes underscores and dots word constituent chars.") (defvar python--treesit-builtins (append python--treesit-builtin-types - '("abs" "all" "any" "ascii" "bin" "breakpoint" + '("abs" "aiter" "all" "anext" "any" "ascii" "bin" "breakpoint" "callable" "chr" "classmethod" "compile" "delattr" "dir" "divmod" "enumerate" "eval" "exec" "filter" "format" "getattr" "globals" @@ -1016,10 +1037,12 @@ It makes underscores and dots word constituent chars.") ">>" ">>=" "|" "|=" "~" "@" "@=")) (defvar python--treesit-special-attributes - '("__annotations__" "__closure__" "__code__" - "__defaults__" "__dict__" "__doc__" "__globals__" - "__kwdefaults__" "__name__" "__module__" "__package__" - "__qualname__" "__all__")) + '("__annotations__" "__bases__" "__closure__" "__code__" + "__defaults__" "__dict__" "__doc__" "__firstlineno__" + "__globals__" "__kwdefaults__" "__name__" "__module__" + "__mro__" "__package__" "__qualname__" + "__static_attributes__" "__type_params__" + "__all__")) (defvar python--treesit-exceptions '(;; Python 2 and 3: @@ -1041,11 +1064,12 @@ It makes underscores and dots word constituent chars.") ;; Python 3: "BlockingIOError" "BrokenPipeError" "ChildProcessError" "ConnectionAbortedError" "ConnectionError" "ConnectionRefusedError" - "ConnectionResetError" "FileExistsError" "FileNotFoundError" - "InterruptedError" "IsADirectoryError" "NotADirectoryError" - "PermissionError" "ProcessLookupError" "RecursionError" + "ConnectionResetError" "EncodingWarning" "FileExistsError" + "FileNotFoundError" "InterruptedError" "IsADirectoryError" + "NotADirectoryError" "ModuleNotFoundError" "PermissionError" + "ProcessLookupError" "PythonFinalizationError" "RecursionError" "ResourceWarning" "StopAsyncIteration" "TimeoutError" - "ExceptionGroup" + "BaseExceptionGroup" "ExceptionGroup" ;; OS specific "VMSError" "WindowsError" )) @@ -1134,7 +1158,7 @@ fontified." ((or "identifier" "none") (setq font-node child)) ("attribute" - (when-let ((type-node (treesit-node-child-by-field-name child "attribute"))) + (when-let* ((type-node (treesit-node-child-by-field-name child "attribute"))) (setq font-node type-node))) ((or "binary_operator" "subscript") (python--treesit-fontify-union-types child override start end type-regex))) @@ -2704,8 +2728,7 @@ position, else returns nil." :safe 'stringp) (defcustom python-shell-interpreter - (cond ((executable-find "python3") "python3") - ((executable-find "python") "python") + (cond ((executable-find "python") "python") (t "python3")) "Python interpreter for interactive use. @@ -2713,7 +2736,7 @@ Some Python interpreters also require changes to `python-shell-interpreter-args'. In particular, setting `python-shell-interpreter' to \"ipython3\" requires setting `python-shell-interpreter-args' to \"--simple-prompt\"." - :version "28.1" + :version "31.1" :type 'string) (defcustom python-shell-internal-buffer-name "Python Internal" @@ -3246,8 +3269,8 @@ name respectively the current project name." (pcase dedicated ('nil python-shell-buffer-name) ('project - (if-let ((proj (and (featurep 'project) - (project-current)))) + (if-let* ((proj (and (featurep 'project) + (project-current)))) (format "%s[%s]" python-shell-buffer-name (file-name-nondirectory (directory-file-name (project-root proj)))) @@ -3770,7 +3793,7 @@ non-nil, means also display the Python shell buffer." dedicated)))) '(buffer project nil)) (user-error "No Python shell")) - (when-let ((proc (get-buffer-process (current-buffer)))) + (when-let* ((proc (get-buffer-process (current-buffer)))) (kill-process proc) (while (accept-process-output proc))) (python-shell-make-comint (python-shell-calculate-command) @@ -4379,12 +4402,12 @@ When a match is found, native completion is disabled." (defcustom python-shell-completion-native-output-timeout 5.0 "Time in seconds to wait for completion output before giving up." :version "25.1" - :type 'float) + :type 'number) (defcustom python-shell-completion-native-try-output-timeout 1.0 "Time in seconds to wait for *trying* native completion output." :version "25.1" - :type 'float) + :type 'number) (defvar python-shell-readline-completer-delims nil "Word delimiters used by the readline completer. @@ -4827,9 +4850,9 @@ using that one instead of current buffer's process." ((stringp (car cands)) (if no-delims ;; Reduce completion candidates due to long prefix. - (if-let ((Lp (length prefix)) - ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix)) - (L (match-beginning 0))) + (if-let* ((Lp (length prefix)) + ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix)) + (L (match-beginning 0))) ;; If extra-offset is not zero: ;; start end ;; o------------------o---------o-------o @@ -5503,14 +5526,14 @@ def __FFAP_get_module_path(objstr): (defun python-ffap-module-path (module) "Function for `ffap-alist' to return path for MODULE." - (when-let ((process (python-shell-get-process)) - (ready (python-shell-with-shell-buffer + (when-let* ((process (python-shell-get-process)) + (ready (python-shell-with-shell-buffer (python-util-comint-end-of-output-p))) - (module-file - (python-shell-send-string-no-output - (format "%s\nprint(__FFAP_get_module_path(%s))" - python-ffap-setup-code - (python-shell--encode-string module))))) + (module-file + (python-shell-send-string-no-output + (format "%s\nprint(__FFAP_get_module_path(%s))" + python-ffap-setup-code + (python-shell--encode-string module))))) (unless (string-empty-p module-file) (python-util-strip-string module-file)))) @@ -5539,10 +5562,8 @@ def __FFAP_get_module_path(objstr): "Buffer name used for check commands." :type 'string) -(defvar python-check-custom-command nil +(defvar-local python-check-custom-command nil "Internal use.") -;; XXX: Avoid `defvar-local' for compat with Emacs<24.3 -(make-variable-buffer-local 'python-check-custom-command) (defun python-check (command) "Check a Python file (default current buffer's file). @@ -6521,7 +6542,7 @@ This is for compatibility with Emacs < 24.4." (defun python-util-comint-end-of-output-p () "Return non-nil if the last prompt matches input prompt." - (when-let ((prompt (python-util-comint-last-prompt))) + (when-let* ((prompt (python-util-comint-last-prompt))) (python-shell-comint-end-of-output-p (buffer-substring-no-properties (car prompt) (cdr prompt))))) @@ -6801,8 +6822,8 @@ for key in sorted(result): (defun python--import-sources () "List files containing Python imports that may be useful in the current buffer." - (if-let (((featurep 'project)) ;For compatibility with Emacs < 26 - (proj (project-current))) + (if-let* (((featurep 'project)) ;For compatibility with Emacs < 26 + (proj (project-current))) (seq-filter (lambda (s) (string-match-p "\\.py[iwx]?\\'" s)) (project-files proj)) (list default-directory))) @@ -6914,9 +6935,9 @@ asking. When calling from Lisp, use a non-nil NAME to restrict the suggestions to imports defining NAME." (interactive (list (when current-prefix-arg (thing-at-point 'symbol)))) - (when-let ((statement (python--query-import name - (python--import-sources) - "Add import: "))) + (when-let* ((statement (python--query-import name + (python--import-sources) + "Add import: "))) (if (python--do-isort "--add" statement) (message "Added `%s'" statement) (message "(No changes in Python imports needed)")))) @@ -6939,8 +6960,8 @@ argument, restrict the suggestions to imports defining the symbol at point. If there is only one such suggestion, act without asking." (interactive (list (when current-prefix-arg (thing-at-point 'symbol)))) - (when-let ((statement (python--query-import name (current-buffer) - "Remove import: "))) + (when-let* ((statement (python--query-import name (current-buffer) + "Remove import: "))) (if (python--do-isort "--rm" statement) (message "Removed `%s'" statement) (message "(No changes in Python imports needed)")))) @@ -6982,11 +7003,11 @@ asking." (forward-line 1)))) ;; Compute imports to be added (dolist (name (seq-uniq undefined)) - (when-let ((statement (python--query-import name - (python--import-sources) - (format "\ + (when-let* ((statement (python--query-import name + (python--import-sources) + (format "\ Add import for undefined name `%s' (empty to skip): " - name)))) + name)))) (push statement add))) ;; Compute imports to be removed (dolist (name (seq-uniq unused)) @@ -7026,8 +7047,8 @@ Add import for undefined name `%s' (empty to skip): " (eq (char-after) last-command-event)) (save-excursion (insert (make-string 2 last-command-event))))) -(defvar electric-indent-inhibit) (defvar prettify-symbols-alist) +(defvar python--installed-grep-hook nil) ;;;###autoload (define-derived-mode python-base-mode prog-mode "Python" @@ -7053,6 +7074,16 @@ implementations: `python-mode' and `python-ts-mode'." (setq-local electric-indent-inhibit t) (setq-local electric-indent-chars (cons ?: electric-indent-chars)) + (setq-local electric-layout-rules + `((?: . ,(lambda () + (and (zerop (car (syntax-ppss))) + (python-info-statement-starts-block-p) + ;; Heuristic: assume walrus operator := + ;; when colon is preceded by space. + (save-excursion + (goto-char (- (point) 2)) + (looking-at (rx (not space) ":"))) + 'after))))) ;; Add """ ... """ pairing to electric-pair-mode. (add-hook 'post-self-insert-hook @@ -7112,6 +7143,15 @@ implementations: `python-mode' and `python-ts-mode'." "`outline-level' function for Python mode." (1+ (/ (current-indentation) python-indent-offset)))) + (unless python--installed-grep-hook + (setq python--installed-grep-hook t) + (with-eval-after-load 'grep + (defvar grep-files-aliases) + (defvar grep-find-ignored-directories) + (cl-pushnew '("py" . "*.py") grep-files-aliases :test #'equal) + (dolist (dir '(".tox" ".venv" ".mypy_cache" ".ruff_cache")) + (cl-pushnew dir grep-find-ignored-directories)))) + (setq-local prettify-symbols-alist python-prettify-symbols-alist) (make-local-variable 'python-shell-internal-buffer) @@ -7147,7 +7187,7 @@ implementations: `python-mode' and `python-ts-mode'." \\{python-ts-mode-map}" :syntax-table python-mode-syntax-table (when (treesit-ready-p 'python) - (treesit-parser-create 'python) + (setq treesit-primary-parser (treesit-parser-create 'python)) (setq-local treesit-font-lock-feature-list '(( comment definition) ( keyword string type) @@ -7161,6 +7201,20 @@ implementations: `python-mode' and `python-ts-mode'." "_definition")) (setq-local treesit-defun-name-function #'python--treesit-defun-name) + + (setq-local treesit-sentence-type-regexp + (regexp-opt '("statement" + "clause"))) + + (setq-local treesit-sexp-type-regexp + (regexp-opt '("expression" + "string" + "call" + "operator" + "identifier" + "integer" + "float"))) + (treesit-major-mode-setup) (setq-local syntax-propertize-function #'python--treesit-syntax-propertize) @@ -7170,7 +7224,7 @@ implementations: `python-mode' and `python-ts-mode'." (when python-indent-guess-indent-offset (python-indent-guess-indent-offset)) - (add-to-list 'auto-mode-alist '("\\.py[iw]?\\'" . python-ts-mode)) + (add-to-list 'auto-mode-alist (cons python--auto-mode-alist-regexp 'python-ts-mode)) (add-to-list 'interpreter-mode-alist '("python[0-9.]*" . python-ts-mode)))) (derived-mode-add-parents 'python-ts-mode '(python-mode)) diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el index c86ef7e0a3e..2b36c68bb6c 100644 --- a/lisp/progmodes/ruby-ts-mode.el +++ b/lisp/progmodes/ruby-ts-mode.el @@ -1156,7 +1156,7 @@ leading double colon is not added." (unless (treesit-ready-p 'ruby) (error "Tree-sitter for Ruby isn't available")) - (treesit-parser-create 'ruby) + (setq treesit-primary-parser (treesit-parser-create 'ruby)) (setq-local add-log-current-defun-function #'ruby-ts-add-log-current-function) diff --git a/lisp/progmodes/rust-ts-mode.el b/lisp/progmodes/rust-ts-mode.el index 571ffa9b220..7a421eb506b 100644 --- a/lisp/progmodes/rust-ts-mode.el +++ b/lisp/progmodes/rust-ts-mode.el @@ -62,6 +62,15 @@ to be checked as its standard input." (repeat :tag "Custom command" string)) :group 'rust) +(defcustom rust-ts-mode-fontify-number-suffix-as-type nil + "If non-nil, suffixes of number literals are fontified as types. +In Rust, number literals can possess an optional type suffix. When this +variable is non-nil, these suffixes are fontified using +`font-lock-type-face' instead of `font-lock-number-face'." + :version "31.1" + :type 'boolean + :group 'rust) + (defvar rust-ts-mode-prettify-symbols-alist '(("&&" . ?∧) ("||" . ?∨) ("<=" . ?≤) (">=" . ?≥) ("!=" . ?≠) @@ -116,6 +125,12 @@ to be checked as its standard input." ((parent-is "use_list") parent-bol rust-ts-mode-indent-offset))) "Tree-sitter indent rules for `rust-ts-mode'.") +(defconst rust-ts-mode--number-types + (regexp-opt '("u8" "i8" "u16" "i16" "u32" "i32" "u64" + "i64" "u128" "i128" "usize" "isize" "f32" "f64")) + "Regexp matching type suffixes of number literals. +See https://doc.rust-lang.org/reference/tokens.html#suffixes.") + (defvar rust-ts-mode--builtin-macros '("concat_bytes" "concat_idents" "const_format_args" "format_args_nl" "log_syntax" "trace_macros" "assert" "assert_eq" @@ -221,7 +236,8 @@ to be checked as its standard input." :language 'rust :feature 'number - '([(float_literal) (integer_literal)] @font-lock-number-face) + '([(float_literal) (integer_literal)] + @rust-ts-mode--fontify-number-literal) :language 'rust :feature 'operator @@ -267,7 +283,11 @@ to be checked as its standard input." eos) @font-lock-type-face)) ((scoped_identifier path: (identifier) @rust-ts-mode--fontify-scope)) - ((scoped_type_identifier path: (identifier) @rust-ts-mode--fontify-scope))) + ((scoped_type_identifier path: (identifier) @rust-ts-mode--fontify-scope)) + ;; Sometimes the parser can't determine if an identifier is a type, + ;; so we use this heuristic. See bug#69625 for the full discussion. + ((identifier) @font-lock-type-face + (:match ,(rx bos upper) @font-lock-type-face))) :language 'rust :feature 'property @@ -365,6 +385,25 @@ to be checked as its standard input." (treesit-node-start id) (treesit-node-end id) 'font-lock-variable-name-face override start end))))))) +(defun rust-ts-mode--fontify-number-literal (node override start stop &rest _) + "Fontify number literals, highlighting the optional type suffix. +If `rust-ts-mode-fontify-number-suffix-as-type' is non-nil, use +`font-lock-type-face' to highlight the suffix." + (let* ((beg (treesit-node-start node)) + (end (treesit-node-end node))) + (save-excursion + (goto-char end) + (if (and rust-ts-mode-fontify-number-suffix-as-type + (looking-back rust-ts-mode--number-types beg)) + (let* ((ty (match-beginning 0)) + (nb (if (eq (char-before ty) ?_) (1- ty) ty))) + (treesit-fontify-with-override + ty end 'font-lock-type-face override start stop) + (treesit-fontify-with-override + beg nb 'font-lock-number-face override start stop)) + (treesit-fontify-with-override + beg end 'font-lock-number-face override start stop))))) + (defun rust-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." @@ -507,7 +546,7 @@ See `prettify-symbols-compose-predicate'." :syntax-table rust-ts-mode--syntax-table (when (treesit-ready-p 'rust) - (treesit-parser-create 'rust) + (setq treesit-primary-parser (treesit-parser-create 'rust)) ;; Syntax. (setq-local syntax-propertize-function diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index a348e9ba6fd..15ba6e6f2a0 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -300,6 +300,18 @@ naming the shell." (nil "^\\s-*\\([[:alpha:]_][[:alnum:]_]*\\)\\s-*()" 1))) + ;; The difference between the Bash regular expression and the sh regular + ;; expression is that Bash also allows hyphens (-) in function names. + (bash + . ((nil + ;; function FOO + ;; function FOO() + "^\\s-*function\\s-+\\([[:alpha:]_][[:alnum:]_-]*\\)\\s-*\\(?:()\\)?" + 1) + ;; FOO() + (nil + "^\\s-*\\([[:alpha:]_][[:alnum:]_-]*\\)\\s-*()" + 1))) (mksh . ((nil ;; function FOO @@ -1435,8 +1447,9 @@ If FORCE is non-nil and no process found, create one." (defun sh-show-shell () "Pop the shell interaction buffer." (interactive) - (with-suppressed-warnings ((obsolete display-comint-buffer-action)) - (pop-to-buffer (process-buffer (sh-shell-process t)) display-comint-buffer-action))) + (pop-to-buffer (process-buffer (sh-shell-process t)) + (append display-buffer--same-window-action + '((category . comint))))) (defun sh-send-text (text) "Send TEXT to `sh-shell-process'." @@ -1623,7 +1636,7 @@ not written in Bash or sh." (add-hook 'flymake-diagnostic-functions #'sh-shellcheck-flymake nil t) (add-hook 'hack-local-variables-hook #'sh-after-hack-local-variables nil t) - (treesit-parser-create 'bash) + (setq treesit-primary-parser (treesit-parser-create 'bash)) (setq-local treesit-font-lock-feature-list '(( comment function) ( command declaration-command keyword string) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index a0b350ce54f..13bf5e874b0 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -869,7 +869,13 @@ current input in the SQLi buffer to the process." :type '(choice (const :tag "Nothing" nil) (const :tag "The semicolon `;'" semicolon) (const :tag "The string `go' by itself" go)) - :version "20.8") + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (custom-set-default symbol value) + (if (eq value 'go) + (add-hook 'post-self-insert-hook 'sql-magic-go) + (remove-hook 'post-self-insert-hook 'sql-magic-go))) + :version "31.1") (defcustom sql-send-terminator nil "When non-nil, add a terminator to text sent to the SQL interpreter. @@ -1359,8 +1365,6 @@ Based on `comint-mode-map'." :parent comint-mode-map "C-j" #'sql-accumulate-and-indent "C-c C-w" #'sql-copy-column - "O" #'sql-magic-go - "o" #'sql-magic-go ";" #'sql-magic-semicolon "C-c C-l a" #'sql-list-all "C-c C-l t" #'sql-list-table) @@ -3067,16 +3071,16 @@ displayed." ;;; Small functions -(defun sql-magic-go (arg) +(defun sql-magic-go () "Insert \"o\" and call `comint-send-input'. `sql-electric-stuff' must be the symbol `go'." - (interactive "P") - (self-insert-command (prefix-numeric-value arg)) - (if (and (equal sql-electric-stuff 'go) - (save-excursion - (comint-bol nil) - (looking-at "go\\b"))) - (comint-send-input))) + (and (eq major-mode 'sql-interactive-mode) + (equal sql-electric-stuff 'go) + (or (eq last-command-event ?o) (eq last-command-event ?O)) + (save-excursion + (comint-bol nil) + (looking-at "go\\b")) + (comint-send-input))) (put 'sql-magic-go 'delete-selection t) (defun sql-magic-semicolon (arg) diff --git a/lisp/progmodes/typescript-ts-mode.el b/lisp/progmodes/typescript-ts-mode.el index dcf1f721f2f..3dfb623c667 100644 --- a/lisp/progmodes/typescript-ts-mode.el +++ b/lisp/progmodes/typescript-ts-mode.el @@ -80,10 +80,19 @@ table) "Syntax table for `typescript-ts-mode'.") +(define-error 'typescript-ts-mode-wrong-dialect-error + "Wrong typescript dialect" + 'error) + +(defun typescript-ts-mode--check-dialect (dialect) + (unless (or (eq dialect 'typescript) (eq dialect 'tsx)) + (signal 'typescript-ts-mode-wrong-dialect-error + (list "Unsupported dialect for typescript-ts-mode supplied" dialect)))) + (defun tsx-ts-mode--indent-compatibility-b893426 () "Indent rules helper, to handle different releases of tree-sitter-tsx. Check if a node type is available, then return the right indent rules." - ;; handle commit b893426 + ;; handle https://github.com/tree-sitter/tree-sitter-typescript/commit/b893426b82492e59388a326b824a346d829487e8 (condition-case nil (progn (treesit-query-capture 'tsx '((jsx_fragment) @capture)) `(((match "<" "jsx_fragment") parent 0) @@ -106,6 +115,7 @@ declarations, accounting for the length of keyword (var, let, or const)." (defun typescript-ts-mode--indent-rules (language) "Rules used for indentation. Argument LANGUAGE is either `typescript' or `tsx'." + (typescript-ts-mode--check-dialect language) `((,language ((parent-is "program") column-0 0) ((node-is "}") parent-bol 0) @@ -188,6 +198,7 @@ Argument LANGUAGE is either `typescript' or `tsx'." ;; Warning: treesitter-query-capture says both node types are valid, ;; but then raises an error if the wrong node type is used. So it is ;; important to check with the new node type (member_expression) + (typescript-ts-mode--check-dialect language) (condition-case nil (progn (treesit-query-capture language '((jsx_opening_element (member_expression) @capture))) '((jsx_opening_element @@ -219,6 +230,7 @@ Argument LANGUAGE is either `typescript' or `tsx'." LANGUAGE can be `typescript' or `tsx'. Starting from version 0.20.4 of the typescript/tsx grammar, `function' becomes `function_expression'." + (typescript-ts-mode--check-dialect language) (condition-case nil (progn (treesit-query-capture language '((function_expression) @cap)) ;; New version of the grammar @@ -230,6 +242,7 @@ typescript/tsx grammar, `function' becomes `function_expression'." (defun typescript-ts-mode--font-lock-settings (language) "Tree-sitter font-lock settings. Argument LANGUAGE is either `typescript' or `tsx'." + (typescript-ts-mode--check-dialect language) (let ((func-exp (tsx-ts-mode--font-lock-compatibility-function-expression language))) (treesit-font-lock-rules :language language @@ -380,7 +393,7 @@ Argument LANGUAGE is either `typescript' or `tsx'." :language language :feature 'jsx (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language) - `((jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face))) + `((jsx_attribute (property_identifier) @typescript-ts-jsx-attribute-face))) :language language :feature 'number @@ -501,7 +514,7 @@ This mode is intended to be inherited by concrete major modes." :syntax-table typescript-ts-mode--syntax-table (when (treesit-ready-p 'typescript) - (treesit-parser-create 'typescript) + (setq treesit-primary-parser (treesit-parser-create 'typescript)) ;; Indent. (setq-local treesit-simple-indent-rules @@ -539,7 +552,7 @@ at least 3 (which is the default value)." :syntax-table typescript-ts-mode--syntax-table (when (treesit-ready-p 'tsx) - (treesit-parser-create 'tsx) + (setq treesit-primary-parser (treesit-parser-create 'tsx)) ;; Comments. (setq-local comment-start "// ") diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 65545d523a8..58dc234adfe 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: 2024.03.01.121933719 +;; Version: 2024.10.09.140346409 ;; 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 "2024-03-01-7448f97-vpo-GNU" +(defconst verilog-mode-version "2024-10-09-85d8429-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.") @@ -11441,6 +11441,7 @@ This repairs those mis-inserted by an AUTOARG." ;; Prefix regexp needs beginning of match, or some symbol of ;; lesser or equal precedence. We assume the [:]'s exist in expr. ;; Ditto the end. + ;;(message "sre: out=%s" out) (while (string-match (concat "\\([[({:*/<>+-]\\)" ; - must be last "(\\<\\([0-9A-Za-z_]+\\))" @@ -11486,19 +11487,23 @@ This repairs those mis-inserted by an AUTOARG." out) (let ((pre (match-string 1 out)) (lhs (string-to-number (match-string 2 out))) + (op (match-string 3 out)) (rhs (string-to-number (match-string 4 out))) (post (match-string 5 out)) val) (when (equal pre "-") (setq lhs (- lhs))) - (setq val (if (equal (match-string 3 out) "-") + (setq val (if (equal op "-") (- lhs rhs) (+ lhs rhs)) out (replace-match - (concat (if (and (equal pre "-") - (< val 0)) - "" ; Not "--20" but just "-20" - pre) + (concat (cond ((and (equal pre "-") + (< val 0)) + "") ; Not "--20" but just "-20" + ((and (equal pre "-") + (> val 0)) + "+") ; Not "-+20" but just "+20" + (t pre)) (int-to-string val) post) nil nil out)) )) @@ -11526,19 +11531,20 @@ This repairs those mis-inserted by an AUTOARG." nil nil out))))) out))) -;;(verilog-simplify-range-expression "[1:3]") ; 1 -;;(verilog-simplify-range-expression "[(1):3]") ; 1 -;;(verilog-simplify-range-expression "[(((16)+1)+1+(1+1))]") ; 20 -;;(verilog-simplify-range-expression "[(2*3+6*7)]") ; 48 -;;(verilog-simplify-range-expression "[(FOO*4-1*2)]") ; FOO*4-2 -;;(verilog-simplify-range-expression "[(FOO*4+1-1)]") ; FOO*4+0 -;;(verilog-simplify-range-expression "[(func(BAR))]") ; func(BAR) -;;(verilog-simplify-range-expression "[FOO-1+1-1+1]") ; FOO-0 -;;(verilog-simplify-range-expression "[$clog2(2)]") ; 1 -;;(verilog-simplify-range-expression "[$clog2(7)]") ; 3 -;;(verilog-simplify-range-expression "[(TEST[1])-1:0]") -;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; [4:2] -;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]") +;;(verilog-simplify-range-expression "[1:3]") ; "[1:3]" +;;(verilog-simplify-range-expression "[(1):3]") ; "[1:3]" +;;(verilog-simplify-range-expression "[(((16)+1)+1+(1+1))]") ; "[20]" +;;(verilog-simplify-range-expression "[(2*3+6*7)]") ; "[48]" +;;(verilog-simplify-range-expression "[(FOO*4-1*2)]") ; "[FOO*4-2]" +;;(verilog-simplify-range-expression "[(FOO*4+1-1)]") ; "[FOO*4+0]" +;;(verilog-simplify-range-expression "[(func(BAR))]") ; "[func(BAR)]" +;;(verilog-simplify-range-expression "[FOO-1+1-1+1]") ; "[FOO-0]" +;;(verilog-simplify-range-expression "[FOO-1+2:LSB-3+1]") ; "[FOO+1:LSB-1]" +;;(verilog-simplify-range-expression "[$clog2(2)]") ; "[1]" +;;(verilog-simplify-range-expression "[$clog2(7)]") ; "[3]" +;;(verilog-simplify-range-expression "[(TEST[1])-1:0]") ; "[(TEST[1])-1:0]" +;;(verilog-simplify-range-expression "[1<<2:8>>2]") ; "[4:2]" +;;(verilog-simplify-range-expression "[2*4/(4-2) +2+4 <<4 >>2]") ; "[8/(2) +2+4 <<4 >>2]" ;;(verilog-simplify-range-expression "[WIDTH*2/8-1:0]") ; "[WIDTH*2/8-1:0]" ;;(verilog-simplify-range-expression "[(FOO).size:0]") ; "[FOO.size:0]" diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 144bfa944d3..bf309500a38 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -2338,10 +2338,13 @@ Ignore byte-compiler warnings you might see." (defun vhdl-run-when-idle (secs repeat function) "Wait until idle, then run FUNCTION." - (if (fboundp 'start-itimer) + (if (fboundp 'start-itimer) ;;XEmacs (start-itimer "vhdl-mode" function secs repeat t) ;; explicitly activate timer (necessary when Emacs is already idle) - (aset (run-with-idle-timer secs repeat function) 0 nil))) + (let ((timer (run-with-idle-timer secs repeat function))) + ;; `run-with-idle-timer' already sets the `triggered' flag to nil, + ;; at least since Emacs-24. + (if (< emacs-major-version 24) (aset timer 0 nil))))) (defun vhdl-warning-when-idle (&rest args) "Wait until idle, then print out warning STRING and beep." diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 125616398f0..e6f029f3fa8 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -150,18 +150,17 @@ Line numbers start from 1 and columns from 0." (cl-defmethod xref-location-marker ((l xref-file-location)) (pcase-let (((cl-struct xref-file-location file line column) l)) (with-current-buffer - (or (get-file-buffer file) - (let ((find-file-suppress-same-file-warnings t)) - (find-file-noselect file))) + (let ((find-file-suppress-same-file-warnings t)) + (find-file-noselect file)) (save-restriction (widen) (save-excursion (goto-char (point-min)) (ignore-errors - ;; xref location may be out of date; it may be past the - ;; end of the current file, or the file may have been - ;; deleted. Return a reasonable location; the user will - ;; figure it out. + ;; The location shouldn't be be out of date, but we make + ;; provision for that anyway; in case it's past the end of + ;; the file, or it had been deleted. Then return an + ;; approximation, the user will figure it out. (beginning-of-line line) (forward-char column)) (point-marker)))))) @@ -514,6 +513,9 @@ Erase the stack slots following this one." ;;;###autoload (define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") +(defun xref--switch-to-buffer (buf) + (pop-to-buffer buf '((display-buffer-same-window) (category . xref-jump)))) + ;;;###autoload (defun xref-go-back () "Go back to the previous position in xref history. @@ -524,8 +526,8 @@ To undo, use \\[xref-go-forward]." (user-error "At start of xref history") (let ((marker (pop (car history)))) (xref--push-forward (point-marker)) - (switch-to-buffer (or (marker-buffer marker) - (user-error "The marked buffer has been deleted"))) + (xref--switch-to-buffer (or (marker-buffer marker) + (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) (set-marker marker nil nil) (run-hooks 'xref-after-return-hook))))) @@ -539,8 +541,8 @@ To undo, use \\[xref-go-forward]." (user-error "At end of xref history") (let ((marker (pop (cdr history)))) (xref--push-backward (point-marker)) - (switch-to-buffer (or (marker-buffer marker) - (user-error "The marked buffer has been deleted"))) + (xref--switch-to-buffer (or (marker-buffer marker) + (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) (set-marker marker nil nil) (run-hooks 'xref-after-return-hook))))) @@ -613,7 +615,7 @@ If SELECT is non-nil, select the target window." (xref-location-marker (xref-item-location item)))) (buf (marker-buffer marker))) (cl-ecase action - ((nil) (switch-to-buffer buf)) + ((nil) (xref--switch-to-buffer buf)) (window (pop-to-buffer buf t)) (frame (let ((pop-up-frames t)) (pop-to-buffer buf t)))) (xref--goto-char marker)) @@ -689,7 +691,10 @@ and finally return the window." (or (not (window-dedicated-p xref--original-window)) (eq (window-buffer xref--original-window) buf))) `((xref--display-buffer-in-window) - (window . ,xref--original-window)))))) + (category . xref-jump) + (window . ,xref--original-window))) + (t + '(nil (category . xref-jump)))))) (with-selected-window (display-buffer buf action) (xref--goto-char pos) (run-hooks 'xref-after-jump-hook) @@ -1051,7 +1056,7 @@ beginning of the line." "Return the string used to group a set of locations. This function is used as a value for `add-log-current-defun-function'." (xref--group-name-for-display - (if-let (item (xref--item-at-point)) + (if-let* ((item (xref--item-at-point))) (xref-location-group (xref-match-item-location item)) (xref--imenu-extract-index-name)) (xref--project-root (project-current)))) @@ -2078,7 +2083,8 @@ directory, used as the root of the ignore globs." (replace-regexp-in-string ;; FIXME: Add tests. Move to subr.el, make a public function. ;; Maybe error on Emacs-only constructs. - "\\(?:\\\\\\\\\\)*\\(?:\\\\[][]\\)?\\(?:\\[.+?\\]\\|\\(\\\\?[(){}|]\\)\\)" + (rx (zero-or-more "\\\\") (opt "\\" (any "[]")) + (or (seq "[" (+? nonl) "]") (group (opt "\\") (any "(){|}")))) (lambda (str) (cond ((not (match-beginning 1)) diff --git a/lisp/rect.el b/lisp/rect.el index 0212dedcb48..4325134f8f0 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -766,7 +766,17 @@ Ignores `line-move-visual'." ((not rectangle-mark-mode) (funcall orig)) (t - (apply #'min (mapcar #'car (region-bounds)))))) + (save-excursion + (let* ((pt (point)) + (mk (mark)) + (start (min pt mk)) + (end (max pt mk)) + (cols (rectangle--pos-cols start end)) + (startcol (car cols)) + (endcol (cdr cols))) + (goto-char start) + (move-to-column (min startcol endcol)) + (point)))))) (defun rectangle--region-end (orig) "Like `region-end' but supports rectangular regions." @@ -774,7 +784,17 @@ Ignores `line-move-visual'." ((not rectangle-mark-mode) (funcall orig)) (t - (apply #'max (mapcar #'cdr (region-bounds)))))) + (save-excursion + (let* ((pt (point)) + (mk (mark)) + (start (min pt mk)) + (end (max pt mk)) + (cols (rectangle--pos-cols start end)) + (startcol (car cols)) + (endcol (cdr cols))) + (goto-char end) + (move-to-column (max startcol endcol)) + (point)))))) (defun rectangle--extract-region (orig &optional delete) (cond @@ -837,102 +857,130 @@ Ignores `line-move-visual'." (eq (nth 1 rol) (buffer-chars-modified-tick)) (eq start (nth 2 rol)) (eq end (nth 3 rol)) - (equal (rectangle--crutches) (nth 4 rol))) + (equal (rectangle--crutches) (nth 4 rol)) + ;; Check point explicitly so that `exchange-point-and-mark' + ;; triggers overlay recomputation. + (eq (nth 5 rol) (point))) rol) (t (save-excursion - (let* ((nrol nil) + (let* ((pt (point)) + (nrol nil) (old (if (eq 'rectangle (car-safe rol)) - (nthcdr 5 rol) + (nthcdr 6 rol) (funcall redisplay-unhighlight-region-function rol) nil))) (cl-assert (eq (window-buffer window) (current-buffer))) ;; `rectangle--pos-cols' looks up the `selected-window's parameter! (with-selected-window window - (apply-on-rectangle - (lambda (leftcol rightcol) - (let* ((mleft (move-to-column leftcol)) - (left (point)) - ;; BEWARE: In the presence of other overlays with - ;; before/after/display-strings, this happens to move to - ;; the column "as if the overlays were not applied", which - ;; is sometimes what we want, tho it can be - ;; considered a bug in move-to-column (it should arguably - ;; pay attention to the before/after-string/display - ;; properties when computing the column). - (mright (move-to-column rightcol)) - (right (point)) - (ol - (if (not old) - (let ((ol (make-overlay left right))) - (overlay-put ol 'window window) - (overlay-put ol 'face 'region) - ol) - (let ((ol (pop old))) - (move-overlay ol left right (current-buffer)) - ol)))) - ;; `move-to-column' may stop before the column (if bumping into - ;; EOL) or overshoot it a little, when column is in the middle - ;; of a char. - (cond - ((< mleft leftcol) ;`leftcol' is past EOL. - (overlay-put ol 'before-string (rectangle--space-to leftcol)) - (setq mright (max mright leftcol))) - ((and (> mleft leftcol) ;`leftcol' is in the middle of a char. - (eq (char-before left) ?\t)) - (setq left (1- left)) - (move-overlay ol left right) - (goto-char left) - (overlay-put ol 'before-string (rectangle--space-to leftcol))) - ((overlay-get ol 'before-string) - (overlay-put ol 'before-string nil))) - (cond - ;; While doing rectangle--string-preview, the two sets of - ;; overlays steps on the other's toes. I fixed some of the - ;; problems, but others remain. The main one is the two - ;; (rectangle--space-to rightcol) below which try to virtually - ;; insert missing text, but during "preview", the text is not - ;; missing (it's provided by preview's own overlay). - (rectangle--string-preview-state - (if (overlay-get ol 'after-string) - (overlay-put ol 'after-string nil))) - ((< mright rightcol) ;`rightcol' is past EOL. - (let ((str (rectangle--space-to rightcol))) - (put-text-property 0 (length str) 'face 'region str) - ;; If cursor happens to be here, draw it at the right place. - (rectangle--place-cursor leftcol left str) - (overlay-put ol 'after-string str))) - ((and (> mright rightcol) ;`rightcol's in the middle of a char. - (eq (char-before right) ?\t)) - (setq right (1- right)) - (move-overlay ol left right) - (if (= rightcol leftcol) - (overlay-put ol 'after-string nil) - (goto-char right) - (let ((str (rectangle--space-to rightcol))) - (put-text-property 0 (length str) 'face 'region str) - (when (= left right) - (rectangle--place-cursor leftcol left str)) - (overlay-put ol 'after-string str)))) - ((overlay-get ol 'after-string) - (overlay-put ol 'after-string nil))) - (when (and (= leftcol rightcol) (display-graphic-p)) - ;; Make zero-width rectangles visible! - (overlay-put ol 'after-string - (concat (propertize " " - 'face '(region (:height 0.2))) - (overlay-get ol 'after-string)))) - (push ol nrol))) - start end)) + (let* ((cols (rectangle--pos-cols start end)) + (startcol (car cols)) + (endcol (cdr cols)) + (leftcol (min startcol endcol)) + (rightcol (max startcol endcol)) + ;; We don't know what lines will actually be displayed, + ;; so add highlight overlays on lines within the window + ;; height from point. + (height (window-height)) + (start-pt (max start (progn (forward-line (- height)) + (point)))) + (end-pt (min end (progn (goto-char pt) + (forward-line height) + (point))))) + (goto-char start-pt) + (beginning-of-line) + (while + (let* ((mleft (move-to-column leftcol)) + (left (point)) + ;; BEWARE: In the presence of other overlays with + ;; before/after/display-strings, this happens to move to + ;; the column "as if the overlays were not applied", + ;; which is sometimes what we want, tho it can be + ;; considered a bug in move-to-column (it should + ;; arguably pay attention to the + ;; before/after-string/display properties when computing + ;; the column). + (mright (move-to-column rightcol)) + (right (point)) + (ol + (if (not old) + (let ((ol (make-overlay left right))) + (overlay-put ol 'window window) + (overlay-put ol 'face 'region) + ol) + (let ((ol (pop old))) + (move-overlay ol left right (current-buffer)) + ol)))) + ;; `move-to-column' may stop before the column (if bumping + ;; into EOL) or overshoot it a little, when column is in the + ;; middle of a char. + (cond + ((< mleft leftcol) ;`leftcol' is past EOL. + (overlay-put ol 'before-string + (rectangle--space-to leftcol)) + (setq mright (max mright leftcol))) + ((and (> mleft leftcol) ;`leftcol' is in the middle of a char + (eq (char-before left) ?\t)) + (setq left (1- left)) + (move-overlay ol left right) + (goto-char left) + (overlay-put ol 'before-string + (rectangle--space-to leftcol))) + ((overlay-get ol 'before-string) + (overlay-put ol 'before-string nil))) + (cond + ;; While doing rectangle--string-preview, the two sets of + ;; overlays steps on the other's toes. I fixed some of the + ;; problems, but others remain. The main one is the two + ;; (rectangle--space-to rightcol) below which try to + ;; virtually insert missing text, but during "preview", the + ;; text is not missing (it's provided by preview's own + ;; overlay). + (rectangle--string-preview-state + (if (overlay-get ol 'after-string) + (overlay-put ol 'after-string nil))) + ((< mright rightcol) ;`rightcol' is past EOL. + (let ((str (rectangle--space-to rightcol))) + (put-text-property 0 (length str) 'face 'region str) + ;; If cursor happens to be here, draw it at the right + ;; place. + (rectangle--place-cursor leftcol left str) + (overlay-put ol 'after-string str))) + ((and (> mright rightcol) ;`rightcol' in the middle of a char + (eq (char-before right) ?\t)) + (setq right (1- right)) + (move-overlay ol left right) + (if (= rightcol leftcol) + (overlay-put ol 'after-string nil) + (goto-char right) + (let ((str (rectangle--space-to rightcol))) + (put-text-property 0 (length str) 'face 'region str) + (when (= left right) + (rectangle--place-cursor leftcol left str)) + (overlay-put ol 'after-string str)))) + ((overlay-get ol 'after-string) + (overlay-put ol 'after-string nil))) + (when (and (= leftcol rightcol) (display-graphic-p)) + ;; Make zero-width rectangles visible! + (overlay-put ol 'after-string + (concat (propertize + " " 'face '(region (:height 0.2))) + (overlay-get ol 'after-string)))) + (push ol nrol) + (and (zerop (forward-line 1)) + (bolp) + (<= (point) end-pt)))) + ) + ) (mapc #'delete-overlay old) `(rectangle ,(buffer-chars-modified-tick) - ,start ,end ,(rectangle--crutches) + ,start ,end ,(rectangle--crutches) ,pt ,@nrol)))))) (defun rectangle--unhighlight-for-redisplay (orig rol) (if (not (eq 'rectangle (car-safe rol))) (funcall orig rol) - (mapc #'delete-overlay (nthcdr 5 rol)) + (mapc #'delete-overlay (nthcdr 6 rol)) (setcar (cdr rol) nil))) (defun rectangle--duplicate-right (n displacement) diff --git a/lisp/register.el b/lisp/register.el index 497848ded1e..407fd8a8779 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -36,6 +36,7 @@ ;; FIXME: Clean up namespace usage! (declare-function frameset-register-p "frameset") +(declare-function dired-current-directory "dired") (cl-defstruct (registerv (:constructor nil) @@ -300,6 +301,18 @@ If NOCONFIRM is non-nil, request confirmation of register name by RET." :act 'set :noconfirm (memq register-use-preview '(nil never)) :smatch t)) +(cl-defmethod register-command-info ((_command (eql file-to-register))) + (make-register-preview-info + :types '(all) + :msg "File to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) +(cl-defmethod register-command-info ((_command (eql buffer-to-register))) + (make-register-preview-info + :types '(all) + :msg "Buffer to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) (defun register-preview-forward-line (arg) "Move to next or previous line in register preview buffer. @@ -672,7 +685,6 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." Push the mark if going to the location moves point, unless called in succession. If the register contains a file name, find that file. If the register contains a buffer name, switch to that buffer. -\(To put a file or buffer name in a register, you must use `set-register'.) If the register contains a window configuration (one frame) or a frameset \(all frames), restore the configuration of that frame or of all frames accordingly. @@ -688,6 +700,44 @@ Interactively, prompt for REGISTER using `register-read-with-preview'." (let ((val (get-register register))) (register-val-jump-to val delete))) +(defun file-to-register (file-name register) + "Insert FILE-NAME into REGISTER. +To visit the file, use \\[jump-to-register]. + +Interactively, prompt for REGISTER using `register-read-with-preview'. +With a prefix-argument, prompt for FILE-NAME using `read-file-name', +With no prefix-argument, use the currently visited file or directory +for FILE-NAME." + (interactive (list (if (eq current-prefix-arg nil) + (if (eq major-mode 'dired-mode) + (dired-current-directory) + (buffer-file-name)) + (read-file-name "File: ")) + (register-read-with-preview "File to register: "))) + (unless (eq file-name nil) + (set-register register (cons 'file file-name)))) + +(defun buffer-to-register (buffer register) + "Store reference to BUFFER in REGISTER. +To visit the buffer, use \\[jump-to-register]. + +Interactively, use current buffer as BUFFER, and prompt for REGISTER. +With a prefix argument, prompt for BUFFER as well." + (interactive + (let ((buffer + (if current-prefix-arg + (get-buffer (read-buffer "Store reference to buffer" + (current-buffer) t)) + (current-buffer)))) + (list buffer + (register-read-with-preview + (substitute-quotes + (format "Store reference to buffer `%s' in register: " + (buffer-name buffer))))))) + (with-current-buffer buffer + (add-hook 'kill-buffer-hook #'register-buffer-to-file-query nil t)) + (set-register register (cons 'buffer buffer))) + (cl-defgeneric register-val-jump-to (_val _arg) "Execute the \"jump\" operation of VAL. VAL is the contents of a register as returned by `get-register'. @@ -739,6 +789,18 @@ ARG is the value of the prefix argument or nil." buffer-file-name (marker-position (cdr elem)))))))) +(defun register-buffer-to-file-query () + "Turn buffer registers into file-query references when a buffer is killed." + (and buffer-file-name + (dolist (elem register-alist) + (and (consp (cdr elem)) + (eq (current-buffer) (cddr elem)) + (setcdr elem + (list 'file-query + buffer-file-name + (point))))))) + + (defun number-to-register (number register) "Store NUMBER in REGISTER. REGISTER is a character, the name of the register. diff --git a/lisp/repeat.el b/lisp/repeat.el index 1de26826ea1..45888d9db08 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -504,7 +504,13 @@ See `describe-repeat-maps' for a list of all repeatable commands." (let ((was-in-progress repeat-in-progress)) (setq repeat-in-progress nil) (let ((map (repeat-get-map))) - (when (repeat-check-map map) + (when (and (repeat-check-map map) + (let ((continue-only (repeat--command-property 'repeat-continue-only))) + (or (null continue-only) + (and (or (not (consp continue-only)) + (memq (repeat--command-property 'repeat-map) + continue-only)) + was-in-progress)))) ;; Messaging (funcall repeat-echo-function map) @@ -560,8 +566,8 @@ This function can be used to force exit of repetition while it's active." (mapconcat (lambda (key-cmd) (let ((key (car key-cmd)) (cmd (cdr key-cmd))) - (if-let ((hint (and (symbolp cmd) - (get cmd 'repeat-hint)))) + (if-let* ((hint (and (symbolp cmd) + (get cmd 'repeat-hint)))) ;; Reuse `read-multiple-choice' formatting. (cdr (rmc--add-key-description (list key hint))) (propertize (key-description (vector key)) diff --git a/lisp/replace.el b/lisp/replace.el index 01a892bbba7..2285b19b519 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -352,7 +352,7 @@ should a regexp." to)) regexp-flag)) -(defun query-replace-read-args (prompt regexp-flag &optional noerror) +(defun query-replace-read-args (prompt regexp-flag &optional noerror no-highlight) (unless noerror (barf-if-buffer-read-only)) (save-mark-and-excursion @@ -364,7 +364,7 @@ should a regexp." :filter (when (use-region-p) (replace--region-filter (funcall region-extract-function 'bounds))) - :highlight query-replace-lazy-highlight + :highlight (and query-replace-lazy-highlight (not no-highlight)) :regexp regexp-flag :regexp-function (or replace-regexp-function delimited-flag diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 012e305f7f4..e2b7b4c9f06 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -416,22 +416,22 @@ It runs the hook `save-place-after-find-file-hook'." "Position point in a Dired buffer according to its saved place. This is run via `dired-initial-position-hook', which see." (or save-place-loaded (save-place-load-alist-from-file)) - (when-let ((directory (and (derived-mode-p 'dired-mode) - (boundp 'dired-subdir-alist) - dired-subdir-alist - (dired-current-directory))) - (item (expand-file-name (if (consp directory) - (car directory) - directory))) - (cell (assoc (if save-place-abbreviate-file-names - (abbreviate-file-name item) item) - save-place-alist))) + (when-let* ((directory (and (derived-mode-p 'dired-mode) + (boundp 'dired-subdir-alist) + dired-subdir-alist + (dired-current-directory))) + (item (expand-file-name (if (consp directory) + (car directory) + directory))) + (cell (assoc (if save-place-abbreviate-file-names + (abbreviate-file-name item) item) + save-place-alist))) (or revert-buffer-in-progress-p (cond ((integerp (cdr cell)) (goto-char (cdr cell))) ((listp (cdr cell)) - (when-let ((elt (assq 'dired-filename (cdr cell)))) + (when-let* ((elt (assq 'dired-filename (cdr cell)))) (dired-goto-file (expand-file-name (cdr elt))))))) ;; and make sure it will be saved again for later (setq save-place-mode t))) diff --git a/lisp/server.el b/lisp/server.el index abfd3d4d753..d45fb2b25ab 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -1904,7 +1904,7 @@ if there are no other active clients." (length> server-clients 1) (seq-some (lambda (frame) - (when-let ((p (frame-parameter frame 'client))) + (when-let* ((p (frame-parameter frame 'client))) (not (eq proc p)))) (frame-list))) ;; If `server-stop-automatically' is not enabled, there diff --git a/lisp/ses.el b/lisp/ses.el index c9bd0ab18da..8b270842734 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -1443,9 +1443,10 @@ undoable. Return nil when there was no change, and non-nil otherwise." (ses-widen) (goto-char ses--params-marker) (forward-line (plist-get ses-paramlines-plist 'ses--numlocprn )) - (insert (format (plist-get ses-paramfmt-plist 'ses--numlocprn) - ses--numlocprn) - ?\n) + (let (print-level print-length) + (insert (format (plist-get ses-paramfmt-plist 'ses--numlocprn) + ses--numlocprn) + ?\n)) t) ))) (defun ses-set-parameter (def value &optional elem) @@ -1467,7 +1468,7 @@ If ELEM is specified, it is the array subscript within DEF to be set to VALUE." (setq oldval (symbol-value def)) (set def value)) ;; Special undo since it's outside the narrowed buffer. - (let (buffer-undo-list) + (let (buffer-undo-list print-level print-length) (delete-region (point) (line-end-position)) (insert (format fmt (symbol-value def)))) (push `(apply ses-set-parameter ,def ,oldval ,elem) buffer-undo-list)))) @@ -1478,6 +1479,7 @@ If ELEM is specified, it is the array subscript within DEF to be set to VALUE." Newlines in the data are escaped." (let* ((inhibit-read-only t) (print-escape-newlines t) + print-level print-length rowcol row col cell sym formula printer text) (setq ses-start-time (float-time)) (with-temp-message " " @@ -2532,7 +2534,7 @@ Return nil if cell formula was unsafe and user declined confirmation." (row (car rowcol)) (col (cdr rowcol)) (formula (ses-cell-formula row col)) - initial) + initial print-level print-length) (if (eq (car-safe formula) 'ses-safe-formula) (setq formula (cadr formula))) (if (eq (car-safe formula) 'quote) diff --git a/lisp/shadowfile.el b/lisp/shadowfile.el index 877b2c8b5ee..5eaa94b4633 100644 --- a/lisp/shadowfile.el +++ b/lisp/shadowfile.el @@ -294,7 +294,7 @@ Argument can be a simple name, remote file name, or already a (defsubst shadow-make-fullname (hup &optional host name) "Make a Tramp style fullname out of HUP, a `tramp-file-name' structure. Replace HOST, and NAME when non-nil. HOST can also be a remote file name." - (when-let ((hup (copy-tramp-file-name hup))) + (when-let* ((hup (copy-tramp-file-name hup))) (when host (if (file-remote-p host) (setq name (or name (and hup (tramp-file-name-localname hup))) @@ -364,7 +364,7 @@ Will return the name bare if it is a local file." Do so by replacing (when possible) home directory with ~/, and hostname with cluster name that includes it. Filename should be absolute and true." - (when-let ((hup (shadow-parse-name file))) + (when-let* ((hup (shadow-parse-name file))) (let* ((homedir (if (shadow-local-file hup) shadow-homedir (file-name-as-directory @@ -464,8 +464,8 @@ It may have different filenames on each site. When this file is edited, the new version will be copied to each of the other locations. Sites can be specific hostnames, or names of clusters (see `shadow-define-cluster')." (interactive) - (when-let ((hup (shadow-parse-name - (shadow-contract-file-name (buffer-file-name))))) + (when-let* ((hup (shadow-parse-name + (shadow-contract-file-name (buffer-file-name))))) (let* ((name (tramp-file-name-localname hup)) site group) (while (setq site (shadow-read-site)) diff --git a/lisp/shell.el b/lisp/shell.el index 4d92fe71df4..33d80061ada 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -432,8 +432,8 @@ interpreted as local file name on the remote host. If `shell-mode' is invoked in a local buffer, and no history file name can be determined, a default according to the shell type is used." :type '(choice (const :tag "Default" nil) (const :tag "Suppress" t) file) + :local 'permanent-only :version "30.1") -(put 'shell-history-file-name 'permanent-local t) ;;; Basic Procedures @@ -953,8 +953,8 @@ Make the shell buffer the current buffer, and return it. (current-buffer))) ;; The buffer's window must be correctly set when we call comint ;; (so that comint sets the COLUMNS env var properly). - (with-suppressed-warnings ((obsolete display-comint-buffer-action)) - (pop-to-buffer buffer display-comint-buffer-action)) + (pop-to-buffer buffer (append display-buffer--same-window-action + '((category . comint)))) (with-connection-local-variables (when file-name @@ -1659,19 +1659,19 @@ Returns t if successful." :version "29.1") (defface shell-highlight-undef-defined-face - '((t :inherit 'font-lock-function-name-face)) + '((t :inherit font-lock-function-name-face)) "Face used for existing shell commands." :group 'shell :version "29.1") (defface shell-highlight-undef-undefined-face - '((t :inherit 'font-lock-warning-face)) + '((t :inherit font-lock-warning-face)) "Face used for non-existent shell commands." :group 'shell :version "29.1") (defface shell-highlight-undef-alias-face - '((t :inherit 'font-lock-variable-name-face)) + '((t :inherit font-lock-variable-name-face)) "Face used for shell command aliases." :group 'shell :version "29.1") @@ -1802,7 +1802,7 @@ works better if `comint-fontify-input-mode' is enabled." (progn (remove-hook 'comint-indirect-setup-hook shell--highlight-undef-indirect t) (setq shell--highlight-undef-indirect nil) - (when-let ((buf (comint-indirect-buffer t))) + (when-let* ((buf (comint-indirect-buffer t))) (with-current-buffer buf (font-lock-remove-keywords nil shell-highlight-undef-keywords)))) (font-lock-remove-keywords nil shell-highlight-undef-keywords)) @@ -1842,7 +1842,7 @@ works better if `comint-fontify-input-mode' is enabled." (font-lock-add-keywords nil shell-highlight-undef-keywords t)))) (cond (comint-fontify-input-mode (setq shell--highlight-undef-indirect setup) - (if-let ((buf (comint-indirect-buffer t))) + (if-let* ((buf (comint-indirect-buffer t))) (with-current-buffer buf (funcall setup)) (add-hook 'comint-indirect-setup-hook setup nil t))) diff --git a/lisp/simple.el b/lisp/simple.el index 3054c8ab6a7..f2ee4a5df67 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2399,7 +2399,7 @@ mode when reading the command name." (defun command-completion-using-modes-p (symbol buffer) "Say whether SYMBOL has been marked as a mode-specific command in BUFFER." ;; Check the modes. - (when-let ((modes (command-modes symbol))) + (when-let* ((modes (command-modes symbol))) ;; Common fast case: Just a single mode. (if (null (cdr modes)) (or (provided-mode-derived-p @@ -2801,10 +2801,10 @@ don't clear it." (t ;; Pass `cmd' rather than `final', for the backtrace's sake. (prog1 (call-interactively cmd record-flag keys) - (when-let ((info - (and (symbolp cmd) - (not (get cmd 'command-execute-obsolete-warned)) - (get cmd 'byte-obsolete-info)))) + (when-let* ((info + (and (symbolp cmd) + (not (get cmd 'command-execute-obsolete-warned)) + (get cmd 'byte-obsolete-info)))) (put cmd 'command-execute-obsolete-warned t) (message "%s" (macroexp--obsolete-warning cmd info "command" @@ -3993,6 +3993,9 @@ with < or <= based on USE-<." ((integerp (car undo-elt)) ;; (BEGIN . END) (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt)))) + ;; (apply DELTA BEG END FUNC . ARGS) + ((and (eq (car undo-elt) 'apply) (integerp (nth 1 undo-elt))) + (cons (nth 2 undo-elt) (nth 1 undo-elt))) (t '(0 . 0))) '(0 . 0))) @@ -4779,7 +4782,7 @@ 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))) + (if-let* ((handler (find-file-name-handler default-directory 'file-user-uid))) (funcall handler 'file-user-uid) (user-uid))) @@ -4791,7 +4794,7 @@ Names'. If a file name handler is unable to retrieve the effective gid, this function will instead return -1." - (if-let ((handler (find-file-name-handler default-directory 'file-group-gid))) + (if-let* ((handler (find-file-name-handler default-directory 'file-group-gid))) (funcall handler 'file-group-gid) (group-gid))) @@ -5817,6 +5820,20 @@ move the yanking point; just return the Nth kill forward." :type 'boolean :group 'killing) +(defcustom kill-region-dwim nil + "Behavior when `kill-region' is invoked without an active region. +If set to nil (default), kill the region even if it is inactive, +signaling an error if there is no region. +If set to `emacs-word', kill the last word as defined by the +current major mode. +If set to `unix-word', kill the last word in the style of a shell like +Bash. This ignores the major mode like `unix-word-rubout' (which see)." + :type '(choice (const :tag "Kill region even when inactive" nil) + (const :tag "Kill a word like `backward-kill-word'" emacs-word) + (const :tag "Kill a word like Bash would" unix-word)) + :group 'killing + :version "31.1") + (defun kill-region (beg end &optional region) "Kill (\"cut\") text between point and mark. This deletes the text from the buffer and saves it in the kill ring. @@ -5843,27 +5860,43 @@ Lisp programs should use this function for killing text. (To delete text, use `delete-region'.) Supply two arguments, character positions BEG and END indicating the stretch of text to be killed. If the optional argument REGION is - non-nil, the function ignores BEG and END, and kills the current + `region', the function ignores BEG and END, and kills the current region instead. Interactively, REGION is always non-nil, and so - this command always kills the current region." + this command always kills the current region. It is possible to + override this behavior by customizing the user option + `kill-region-dwim'." ;; Pass mark first, then point, because the order matters when ;; calling `kill-append'. (interactive (progn - (let ((beg (mark)) + (let ((beg (mark kill-region-dwim)) (end (point))) - (unless (and beg end) + (cond + ((and kill-region-dwim (not (use-region-p))) + (list beg end kill-region-dwim)) + ((not (and beg end)) (user-error "The mark is not set now, so there is no region")) - (list beg end 'region)))) + ((list beg end 'region)))))) + (condition-case nil - (let ((string (if region - (funcall region-extract-function 'delete) - (filter-buffer-substring beg end 'delete)))) + (let ((string (cond + ((memq region '(unix-word emacs-word)) + (let ((end (point))) + (save-excursion + (if (eq region 'emacs-word) + (forward-word -1) + (forward-unix-word -1)) + (filter-buffer-substring (point) end 'delete)))) + (region + (funcall region-extract-function 'delete)) + ((filter-buffer-substring beg end 'delete))))) (when string ;STRING is nil if BEG = END ;; Add that string to the kill ring, one way or another. - (if (eq last-command 'kill-region) + (if (and (not (memq region '(unix-word emacs-word))) + (eq last-command 'kill-region)) (kill-append string (< end beg)) (kill-new string))) - (when (or string (eq last-command 'kill-region)) + (when (and (not (memq region '(unix-word emacs-word))) + (or string (eq last-command 'kill-region))) (setq this-command 'kill-region)) (setq deactivate-mark t) nil) @@ -7674,8 +7707,8 @@ This has no effect when the variable `line-move-visual' is non-nil." A non-nil setting overrides the variable `line-move-visual', which see." :type '(choice integer (const :tag "None" nil)) + :local t :group 'editing-basics) -(make-variable-buffer-local 'goal-column) (defvar temporary-goal-column 0 "Current goal column for vertical motion. @@ -8204,7 +8237,8 @@ If NOERROR, don't signal an error if we can't move that many lines." ;; Move to the desired column. (if (and line-move-visual - (not (or truncate-lines truncate-partial-width-windows))) + (not noninteractive) + (not (or truncate-lines (truncated-partial-width-window-p)))) ;; Under line-move-visual, goal-column should be ;; interpreted in units of the frame's canonical character ;; width, which is exactly what vertical-motion does. @@ -8895,14 +8929,71 @@ constitute a word." ;; If we found something nonempty, return it as a string. (unless (= start end) (buffer-substring-no-properties start end))))) + +(defun forward-unix-word (n &optional delim) + "Move forward N Unix-words. +A Unix-word is whitespace-delimited. +A negative N means go backwards to the beginning of Unix-words. + +Unix-words differ from Emacs words in that they are always delimited by +whitespace, regardless of the buffer's syntax table. This function +emulates how C-w at the Unix terminal or shell identifies words. + +Optional argument DELIM specifies what characters are considered +whitespace. It is a string as might be passed to `skip-chars-forward'. +The default is \"\\s\\f\\n\\r\\t\\v\". Do not prefix a `^' character." + (when (string-prefix-p "^" delim) + (error "DELIM argument must not begin with `^'")) + (unless (zerop n) + ;; We do skip over newlines by default because `backward-word' does. + (let* ((delim (or delim "\s\f\n\r\t\v")) + (ndelim (format "^%s" delim)) + (start (point)) + (fun (if (> n 0) + #'skip-chars-forward + #'skip-chars-backward))) + (dotimes (_ (abs n)) + (funcall fun delim) + (funcall fun ndelim)) + (constrain-to-field nil start)))) + +(defun unix-word-rubout (arg) + "Kill ARG Unix-words backwards. +A Unix-word is whitespace-delimited. +Interactively, ARG is the numeric prefix argument, defaulting to 1. +A negative ARG means to kill forwards. + +Unix-words differ from Emacs words in that they are always delimited by +whitespace, regardless of the buffer's syntax table. +Thus, this command emulates C-w at the Unix terminal or shell. +See also this command's nakesake in Info node +`(readline)Commands For Killing'." + (interactive "^p") + (let ((start (point))) + (forward-unix-word (- arg)) + (kill-region start (point)))) + +(defun unix-filename-rubout (arg) + "Kill ARG Unix-words backwards, also treating slashes as word delimiters. +A Unix-word is whitespace-delimited. +Interactively, ARG is the numeric prefix argument, defaulting to 1. +A negative ARG means to kill forwards. + +This is like `unix-word-rubout' (which see), but `/' and `\\' are also +treated as delimiting words. See this command's namesake in Info node +`(readline)Commands For Killing'." + (interactive "^p") + (let ((start (point))) + (forward-unix-word (- arg) "\\\\/\s\f\n\r\t\v") + (kill-region start (point)))) (defcustom fill-prefix nil "String for filling to insert at front of new line, or nil for none." :type '(choice (const :tag "None" nil) string) :safe #'string-or-null-p + :local t :group 'fill) -(make-variable-buffer-local 'fill-prefix) (defcustom auto-fill-inhibit-regexp nil "Regexp to match lines that should not be auto-filled." @@ -9966,7 +10057,7 @@ the completions is popped up and down." (let ((inhibit-read-only t)) (add-text-properties (point) (min (1+ (point)) (point-max)) '(first-completion t)))) - (when-let ((pos (next-single-property-change (point) 'mouse-face))) + (when-let* ((pos (next-single-property-change (point) 'mouse-face))) (goto-char pos)))) (defun last-completion () @@ -9976,7 +10067,7 @@ the completions is popped up and down." (point-max) 'mouse-face nil (point-min))) ;; Move to the start of last one. (unless (get-text-property (point) 'mouse-face) - (when-let ((pos (previous-single-property-change (point) 'mouse-face))) + (when-let* ((pos (previous-single-property-change (point) 'mouse-face))) (goto-char pos)))) (defun previous-completion (n) @@ -10158,6 +10249,22 @@ Also see the `completion-auto-wrap' variable." This makes `completions--deselect' effective.") +(defun completion-list-candidate-at-point (&optional pt) + "Candidate string and bounds at PT in completions buffer. +The return value has the format (STR BEG END). +The optional argument PT defaults to (point)." + (setq pt (or pt (point))) + (when (cond + ((and (/= pt (point-max)) + (get-text-property pt 'completion--string)) + (cl-incf pt)) + ((and (/= pt (point-min)) + (get-text-property (1- pt) 'completion--string)))) + (setq pt (or (previous-single-property-change pt 'completion--string) pt)) + (list (get-text-property pt 'completion--string) pt + (or (next-single-property-change pt 'completion--string) + (point-max))))) + (defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. If EVENT, use EVENT's position to determine the starting position. @@ -10181,21 +10288,9 @@ minibuffer, but don't quit the completions window." (or (get-text-property (posn-point (event-start event)) 'completion--string) (error "No completion here")) - (save-excursion - (goto-char (posn-point (event-start event))) - (let (beg) - (cond - ((and (not (eobp)) - (get-text-property (point) 'completion--string)) - (setq beg (1+ (point)))) - ((and (not (bobp)) - (get-text-property (1- (point)) 'completion--string)) - (setq beg (point))) - (t (error "No completion here"))) - (setq beg (or (previous-single-property-change - beg 'completion--string) - beg)) - (get-text-property beg 'completion--string)))))) + (or (car (completion-list-candidate-at-point + (posn-point (event-start event)))) + (error "No completion here"))))) (unless (buffer-live-p buffer) (error "Destination buffer is dead")) @@ -10363,6 +10458,8 @@ Called from `temp-buffer-show-hook'." (let ((base-position completion-base-position) (insert-fun completion-list-insert-choice-function)) (completion-list-mode) + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) (setq-local completion-base-position base-position) (setq-local completion-list-insert-choice-function insert-fun)) (setq-local completion-reference-buffer mainbuf) @@ -10403,10 +10500,10 @@ to move point between completions.\n\n"))))))) (defun switch-to-completions () "Select the completion list window." (interactive) - (when-let ((window (or (get-buffer-window "*Completions*" 0) - ;; Make sure we have a completions window. - (progn (minibuffer-completion-help) - (get-buffer-window "*Completions*" 0))))) + (when-let* ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) (select-window window) (when (bobp) (cond @@ -11358,8 +11455,7 @@ seconds." (if timer ;; The timer is already running. See if it's due to expire ;; within the next five seconds. - (let ((time (list (aref timer 1) (aref timer 2) - (aref timer 3)))) + (let ((time (timer--time timer))) (unless (<= (time-convert (time-subtract time nil) 'integer) 5) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index c13c977938b..38fb641acf7 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -3168,25 +3168,32 @@ With universal argument ARG, flush cached data." (speedbar-do-function-pointer)) (error (speedbar-position-cursor-on-line)))) +(defun speedbar--get-line-indent-level () + "Return the indentation level of the current line." + (save-excursion + (beginning-of-line) + (if (looking-at "[0-9]+:") + (string-to-number (match-string 0)) + 0))) + (defun speedbar-expand-line-descendants (&optional arg) "Expand the line under the cursor and all descendants. Optional argument ARG indicates that any cache should be flushed." (interactive "P") - (save-restriction - (narrow-to-region (line-beginning-position) - (line-beginning-position 2)) - (speedbar-expand-line arg) - ;; Now, inside the area expanded here, expand all subnodes of - ;; the same descendant type. - (save-excursion - (speedbar-next 1) ;; Move into the list. - (let ((err nil)) - (while (not err) - (condition-case nil - (progn - (speedbar-expand-line-descendants arg) - (speedbar-restricted-next 1)) - (error (setq err t)))))))) + (dframe-message "Expanding all descendants...") + (save-excursion + (let ((top-depth (speedbar--get-line-indent-level))) + ;; Attempt to expand the top-level item. + (speedbar-expand-line arg) + ;; Move forwards, either into the newly expanded list, onto an + ;; already expanded list, onto a sibling item, or to the end of + ;; the buffer. + (while (and (zerop (forward-line 1)) + (not (eobp)) + (> (speedbar--get-line-indent-level) top-depth) + (speedbar-expand-line arg))))) + (dframe-message "Expanding all descendants...done") + (speedbar-position-cursor-on-line)) (defun speedbar-contract-line-descendants () "Expand the line under the cursor and all descendants." diff --git a/lisp/startup.el b/lisp/startup.el index f18795ae6ac..3436409a35e 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -854,6 +854,12 @@ It is the default value of the variable `top-level'." ;; We are careful to do it late (after term-setup-hook), although the ;; new multi-tty code does not use $TERM any more there anyway. (setenv "TERM" "dumb") + ;; Similarly, a subprocess should not try to invoke a pager, as most + ;; pagers will fail in a dumb terminal. Many programs default to + ;; using "less" when PAGER is unset, so set PAGER to "cat"; using cat + ;; as a pager is equivalent to not using a pager at all. + (when (executable-find "cat") + (setenv "PAGER" "cat")) ;; Remove DISPLAY from the process-environment as well. This allows ;; `callproc.c' to give it a useful adaptive default which is either ;; the value of the `display' frame-parameter or the DISPLAY value @@ -1100,9 +1106,9 @@ init-file, or to a default value if loading is not possible." ;; The next test is for builds without native ;; compilation support or builds with unexec. (boundp 'comp-eln-to-el-h)) - (if-let (source (gethash (file-name-nondirectory - user-init-file) - comp-eln-to-el-h)) + (if-let* ((source (gethash (file-name-nondirectory + user-init-file) + comp-eln-to-el-h))) ;; source exists or the .eln file would not load (setq user-init-file source) (message "Warning: unknown source file for init file %S" diff --git a/lisp/subr.el b/lisp/subr.el index e9d12644d0e..02cc84c04b7 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -463,8 +463,7 @@ Also see `ignore'." (declare (pure t) (side-effect-free error-free)) t) -;; Signal a compile-error if the first arg is missing. -(defun error (&rest args) +(defun error (string &rest args) "Signal an error, making a message by passing ARGS to `format-message'. Errors cause entry to the debugger when `debug-on-error' is non-nil. This can be overridden by `debug-ignored-errors'. @@ -481,9 +480,8 @@ for the sake of consistency. To alter the look of the displayed error messages, you can use the `command-error-function' variable." - (declare (ftype (function (&rest t) nil)) - (advertised-calling-convention (string &rest args) "23.1")) - (signal 'error (list (apply #'format-message args)))) + (declare (ftype (function (string &rest t) nil))) + (signal 'error (list (apply #'format-message string args)))) (defun user-error (format &rest args) "Signal a user error, making a message by passing ARGS to `format-message'. @@ -2681,14 +2679,12 @@ for forms evaluated for side-effect with returned values ignored." This is like `if-let*' except, as a special case, interpret a SPEC of the form \(SYMBOL SOMETHING) like \((SYMBOL SOMETHING)). This exists for backward compatibility with an old syntax that accepted only one -binding. - -This macro will be marked obsolete in Emacs 31.1; prefer `if-let*' in -new code." +binding." (declare (indent 2) (debug ([&or (symbolp form) ; must be first, Bug#48489 (&rest [&or symbolp (symbolp form) (form)])] - body))) + body)) + (obsolete if-let* "31.1")) (when (and (<= (length spec) 2) (not (listp (car spec)))) ;; Adjust the single binding case @@ -2700,12 +2696,17 @@ new code." Evaluate each binding in turn, stopping if a binding value is nil. If all are non-nil, return the value of the last form in BODY. -The variable list SPEC is the same as in `if-let'. - -This macro will be marked obsolete in Emacs 31.1; prefer `when-let*' and -`and-let*' in new code." - (declare (indent 1) (debug if-let)) - (list 'if-let spec (macroexp-progn body))) +The variable list SPEC is the same as in `if-let'." + (declare (indent 1) (debug if-let) + (obsolete "use `when-let*' or `and-let*' instead." "31.1")) + ;; Previously we expanded to `if-let', and then required a + ;; `with-suppressed-warnings' to avoid doubling up the obsoletion + ;; warnings. But that triggers a bytecompiler bug; see bug#74530. + ;; So for now we reimplement `if-let' here. + (when (and (<= (length spec) 2) + (not (listp (car spec)))) + (setq spec (list spec))) + (list 'if-let* spec (macroexp-progn body))) (defmacro while-let (spec &rest body) "Bind variables according to SPEC and conditionally evaluate BODY. @@ -3084,7 +3085,8 @@ instead." (if (and (or (null type) (eq type 'defun)) (symbolp symbol) (autoloadp (symbol-function symbol))) - (nth 1 (symbol-function symbol)) + (locate-library + (nth 1 (symbol-function symbol))) (if (and native-p (or (null type) (eq type 'defun)) (symbolp symbol) (native-comp-available-p) @@ -3356,7 +3358,15 @@ only unbound fallback disabled is downcasing of the last event." ;; though read-key-sequence thinks we should wait ;; for more input to decide how to interpret the ;; current input. - (throw 'read-key keys))))))) + ;; + ;; As this treatment will completely defeat the + ;; purpose of touch screen event conversion, + ;; dispense with this timeout when the first + ;; event in this vector is a touch-screen event. + (unless (memq (car-safe (aref keys 0)) '(touchscreen-begin + touchscreen-update + touchscreen-end)) + (throw 'read-key keys)))))))) (unwind-protect (progn (use-global-map diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index e8c6b7f3bcc..faf5df541e0 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -298,7 +298,7 @@ For any other value of KEY, the value is t." (defvar tab-bar--dragging-in-progress) (defun tab-bar--event-to-item (posn) - "This function extracts extra info from the mouse event at position POSN. + "Extract extra info from the mouse event at position POSN. It returns a list of the form (KEY KEY-BINDING CLOSE-P), where: KEY is a symbol representing a tab, such as \\='tab-1 or \\='current-tab; KEY-BINDING is the binding of KEY; @@ -1027,7 +1027,10 @@ It should return the formatted tab group name to display in the tab bar." (defun tab-bar-tab-group-format-default (tab i &optional current-p) (propertize - (concat (if (and tab-bar-tab-hints (not current-p)) (format "%d " i) "") + (concat (if (and tab-bar-tab-hints + (not current-p) + (not tab-bar-show-inactive-group-tabs)) + (format "%d " i) "") (funcall tab-bar-tab-group-function tab)) 'face (if current-p 'tab-bar-tab-group-current 'tab-bar-tab-group-inactive))) @@ -1054,7 +1057,7 @@ The argument I is the tab index, and CURRENT-P is non-nil when the tab is current. Return the result as a keymap." (append `((,(intern (format "sep-%i" i)) menu-item ,(tab-bar-separator) ignore)) - `((,(intern (format "group-%i" i)) + `((,(intern (if current-p "current-group" (format "group-%i" i))) menu-item ,(if current-p (condition-case nil @@ -1074,6 +1077,16 @@ when the tab is current. Return the result as a keymap." (tab-bar-select-tab ,i)))) :help "Click to visit group")))) +(defcustom tab-bar-show-inactive-group-tabs nil + "Show tabs even if they are in inactive groups." + :type 'boolean + :initialize #'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + (force-mode-line-update)) + :group 'tab-bar + :version "31.1") + (defun tab-bar-format-tabs-groups () "Produce tabs for the tab bar grouped according to their groups." (let* ((tabs (funcall tab-bar-tabs-function)) @@ -1090,7 +1103,8 @@ when the tab is current. Return the result as a keymap." ((or (equal tab-group current-group) (not tab-group)) (append ;; Prepend current group name before first tab - (when (and (not (equal previous-group tab-group)) tab-group) + (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 @@ -1098,9 +1112,17 @@ when the tab is current. Return the result as a keymap." (tab-bar--format-tab tab i)))) ;; Show first tab of other groups with a group name ((not (equal previous-group tab-group)) - (tab-bar--format-tab-group tab i)) + (append + (tab-bar--format-tab-group tab i) + (when tab-bar-show-inactive-group-tabs + (let ((tab-bar-tab-face-function + tab-bar-tab-group-face-function)) + (tab-bar--format-tab tab i))))) ;; Hide other group tabs - (t nil)) + (t (when tab-bar-show-inactive-group-tabs + (let ((tab-bar-tab-face-function + tab-bar-tab-group-face-function)) + (tab-bar--format-tab tab i))))) (setq previous-group tab-group)))) tabs))) @@ -1226,12 +1248,30 @@ which see. It's not recommended to change this value since with larger values, the tab bar might wrap to the second line when it shouldn't.") -(defvar tab-bar-auto-width-faces +(defconst tab-bar--auto-width-faces-default '( tab-bar-tab tab-bar-tab-inactive tab-bar-tab-ungrouped - tab-bar-tab-group-inactive) + tab-bar-tab-group-inactive)) + +(defvar tab-bar-auto-width-faces + tab-bar--auto-width-faces-default "Resize tabs only with these faces.") +(defun tab-bar-auto-width-predicate-default (item) + "Accepts tab ITEM and returns non-nil for tabs and tab groups." + (if (eq tab-bar-auto-width-faces tab-bar--auto-width-faces-default) + (string-match-p + ;; (rx bos (or "current-tab" "tab-" "group-")) + "\\`\\(?:current-tab\\|\\(?:group\\|tab\\)-\\)" + (symbol-name (nth 0 item))) + (memq (get-text-property 0 'face (nth 2 item)) + tab-bar-auto-width-faces))) + +(defvar tab-bar-auto-width-functions '(tab-bar-auto-width-predicate-default) + "List of functions for `tab-bar-auto-width' to call with a tab ITEM. +If any of these functions returns non-nil for a given tab ITEM, that +tab's width will be auto-sized.") + (defvar tab-bar--auto-width-hash nil "Memoization table for `tab-bar-auto-width'.") @@ -1260,8 +1300,7 @@ be scaled for display on the current frame." (width 0)) ;; resize tab names to this width (dolist (item items) (when (and (eq (nth 1 item) 'menu-item) (stringp (nth 2 item))) - (if (memq (get-text-property 0 'face (nth 2 item)) - tab-bar-auto-width-faces) + (if (run-hook-with-args-until-success 'tab-bar-auto-width-functions item) (push item tabs) (unless (eq (nth 0 item) 'align-right) (setq non-tabs (concat non-tabs (nth 2 item))))))) diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 92b52b6936c..3bf42431ac0 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -461,7 +461,7 @@ named the same as the mode.") (defun tab-line-tabs-buffer-group-by-project (&optional buffer) "Group tab buffers by project name." (with-current-buffer buffer - (if-let ((project (project-current))) + (if-let* ((project (project-current))) (project-name project) "No project"))) @@ -555,12 +555,15 @@ This means that switching to a buffer previously shown in the same window will keep the same order of tabs that was before switching. And newly displayed buffers are added to the end of the tab line." (let* ((old-buffers (window-parameter nil 'tab-line-buffers)) - (buffer-positions (let ((index-table (make-hash-table :test 'eq))) + (buffer-positions (let ((index-table (make-hash-table + :size (length old-buffers) + :test #'eq))) (seq-do-indexed (lambda (buf idx) (puthash buf idx index-table)) old-buffers) index-table)) (new-buffers (sort (tab-line-tabs-window-buffers) + :in-place t :key (lambda (buffer) (gethash buffer buffer-positions most-positive-fixnum))))) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 7278bee48d4..a0366374d34 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -1049,7 +1049,7 @@ return nil. Otherwise point is returned." (while (and (not found) (not (eobp))) (forward-line 1) - (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (when-let* ((descriptor (ignore-errors (tar-get-descriptor)))) (when (equal (tar-header-name descriptor) file) (setq found t)))) (if (not found) @@ -1074,7 +1074,7 @@ return nil. Otherwise point is returned." (beginning-of-line) (bobp))))) (tar-next-line n) - (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (when-let* ((descriptor (ignore-errors (tar-get-descriptor)))) (let ((candidate (tar-header-name descriptor)) (buffer (current-buffer))) (when (and candidate diff --git a/lisp/term.el b/lisp/term.el index 9a8dc25e1a2..c966afd5e80 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -732,9 +732,9 @@ Buffer local variable.") (defvar term-ansi-current-underline nil) (defvar term-ansi-current-slow-blink nil) (defvar term-ansi-current-fast-blink nil) -(defvar term-ansi-current-color 0) +(defvar term-ansi-current-color nil) (defvar term-ansi-face-already-done nil) -(defvar term-ansi-current-bg-color 0) +(defvar term-ansi-current-bg-color nil) (defvar term-ansi-current-reverse nil) (defvar term-ansi-current-invisible nil) @@ -1084,9 +1084,9 @@ For custom keybindings purposes please note there is also (setq term-ansi-current-slow-blink nil) (setq term-ansi-current-fast-blink nil) (setq term-ansi-current-reverse nil) - (setq term-ansi-current-color 0) + (setq term-ansi-current-color nil) (setq term-ansi-current-invisible nil) - (setq term-ansi-current-bg-color 0)) + (setq term-ansi-current-bg-color nil)) (defvar touch-screen-display-keyboard) @@ -3430,19 +3430,21 @@ option is enabled. See `term-set-goto-process-mark'." (defun term--color-as-hex (for-foreground) "Return the current ANSI color as a hexadecimal color string. Use the current background color if FOR-FOREGROUND is nil, -otherwise use the current foreground color." +otherwise use the current foreground color. Return nil if the +color is unset in the terminal state." (let ((color (if for-foreground term-ansi-current-color term-ansi-current-bg-color))) - (or (ansi-color--code-as-hex (1- color)) - (progn - (and ansi-color-bold-is-bright term-ansi-current-bold - (<= 1 color 8) - (setq color (+ color 8))) - (if for-foreground - (face-foreground (elt ansi-term-color-vector color) - nil 'default) - (face-background (elt ansi-term-color-vector color) - nil 'default)))))) + (when color + (or (ansi-color--code-as-hex (1- color)) + (progn + (and ansi-color-bold-is-bright term-ansi-current-bold + (<= 1 color 8) + (setq color (+ color 8))) + (if for-foreground + (face-foreground (elt ansi-term-color-vector color) + nil 'default) + (face-background (elt ansi-term-color-vector color) + nil 'default))))))) ;; New function to deal with ansi colorized output, as you can see you can ;; have any bold/underline/fg/bg/reverse combination. -mm @@ -3499,7 +3501,7 @@ otherwise use the current foreground color." (_ (term-ansi-reset)))) ;; Reset foreground (terminfo: op) - (39 (setq term-ansi-current-color 0)) + (39 (setq term-ansi-current-color nil)) ;; Background (terminfo: setab) ((and param (guard (<= 40 param 47))) @@ -3529,7 +3531,7 @@ otherwise use the current foreground color." (_ (term-ansi-reset)))) ;; Reset background (terminfo: op) - (49 (setq term-ansi-current-bg-color 0)) + (49 (setq term-ansi-current-bg-color nil)) ;; 0 (Reset) (terminfo: sgr0) or unknown (reset anyway) (_ (term-ansi-reset)))) @@ -3541,10 +3543,11 @@ otherwise use the current foreground color." (setq fg (term--color-as-hex t) bg (term--color-as-hex nil))) (setq term-current-face - `( :foreground ,fg - :background ,bg - ,@(unless term-ansi-current-invisible - (list :inverse-video term-ansi-current-reverse))))) + `(,@(when fg `(:foreground ,fg)) + ,@(when bg `(:background ,bg)) + ,@(when (and term-ansi-current-reverse + (not term-ansi-current-invisible)) + (list :inverse-video term-ansi-current-reverse))))) (setq term-current-face `(,term-current-face diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el index df1cdc5143e..5ecf789e364 100644 --- a/lisp/term/android-win.el +++ b/lisp/term/android-win.el @@ -159,7 +159,7 @@ two markers or an overlay. Otherwise, it is nil." VALUE should be something suitable for passing to `gui-set-selection'." (unless (stringp value) - (when-let ((bounds (android-selection-bounds value))) + (when-let* ((bounds (android-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) @@ -204,7 +204,7 @@ VALUE should be something suitable for passing to &context (window-system android)) ;; First, try to turn value into a string. ;; Don't set anything if that did not work. - (when-let ((string (android-encode-select-string value))) + (when-let* ((string (android-encode-select-string value))) (cond ((eq type 'CLIPBOARD) (android-set-clipboard string)) ((eq type 'PRIMARY) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index efc0a129062..c6091669adc 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -142,7 +142,7 @@ two markers or an overlay. Otherwise, it is nil." Return a list of the appropriate MIME type, and UTF-8 data of VALUE as a unibyte string, or nil if VALUE was not a string." (unless (stringp value) - (when-let ((bounds (haiku-selection-bounds value))) + (when-let* ((bounds (haiku-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) @@ -260,7 +260,7 @@ CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or VALUE will be encoded as Latin-1 (like on X Windows) and stored under the type `text/plain;charset=iso-8859-1'." (unless (stringp value) - (when-let ((bounds (haiku-selection-bounds value))) + (when-let* ((bounds (haiku-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) @@ -274,7 +274,7 @@ under the type `text/plain;charset=iso-8859-1'." VALUE will be encoded as UTF-8 and stored under the type `text/plain'." (unless (stringp value) - (when-let ((bounds (haiku-selection-bounds value))) + (when-let* ((bounds (haiku-selection-bounds value))) (setq value (ignore-errors (with-current-buffer (nth 2 bounds) (buffer-substring (nth 0 bounds) diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 5b8f9ad0109..0913fc777df 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -101,6 +101,13 @@ ;; (princ event)) (defun w32-handle-dropped-file (window file-name) + (dnd-handle-multiple-urls + window + (list + (w32-dropped-file-to-url file-name)) + 'private)) + +(defun w32-dropped-file-to-url (file-name) (let ((f (if (eq system-type 'cygwin) (cygwin-convert-file-name-from-windows file-name t) (subst-char-in-string ?\\ ?/ file-name))) @@ -117,37 +124,53 @@ (split-string (encode-coding-string f coding) "/") "/"))) - ;; FIXME: is the W32 build capable only of receiving a single file - ;; from each drop? - (dnd-handle-multiple-urls window (list (concat - (if (eq system-type 'cygwin) - "file://" - "file:") - file-name)) - 'private)) + (concat + (if (eq system-type 'cygwin) + "file://" + "file:") + file-name)) (defun w32-drag-n-drop (event &optional new-frame) - "Edit the files listed in the drag-n-drop EVENT. -Switch to a buffer editing the last file dropped." + "Perform drag-n-drop action according to data in EVENT. +If EVENT is for one or more files, visit those files in corresponding +buffers, and switch to the buffer that visits the last dropped file. +If EVENT is for text, insert that text at point into the buffer +shown in the window that is the target of the drop; if that buffer is +read-only, add the dropped text to kill-ring. +If EVENT payload is nil, then this is a drag event. +If the optional argument NEW-FRAME is non-nil, perform the +drag-n-drop action in a newly-created frame using its selected-window +and that window's buffer." (interactive "e") - (save-excursion - ;; Make sure the drop target has positive co-ords - ;; before setting the selected frame - otherwise it - ;; won't work. <skx@tardis.ed.ac.uk> - (let* ((window (posn-window (event-start event))) - (coords (posn-x-y (event-start event))) - (x (car coords)) - (y (cdr coords))) - (if (and (> x 0) (> y 0)) - (set-frame-selected-window nil window)) - - (when new-frame - (select-frame (make-frame))) - (raise-frame) - (setq window (selected-window)) - - (mapc (apply-partially #'w32-handle-dropped-file window) - (car (cdr (cdr event))))))) + ;; Make sure the drop target has positive co-ords + ;; before setting the selected frame - otherwise it + ;; won't work. <skx@tardis.ed.ac.uk> + (let* ((window (posn-window (event-start event))) + (coords (posn-x-y (event-start event))) + (arg (car (cdr (cdr event)))) + (x (car coords)) + (y (cdr coords))) + + (if (and (> x 0) (> y 0) (window-live-p window)) + (set-frame-selected-window nil window)) + ;; Don't create new frame if we are just dragging + (and arg new-frame + (select-frame (make-frame))) + (raise-frame) + (setq window (selected-window)) + + ;; arg (the payload of the event) is a string when the drop is + ;; text, and a list of strings when the drop is one or more files. + ;; It is nil if the event is a drag event. + (if arg + (save-excursion + (if (stringp arg) + (dnd-insert-text window 'copy arg) + (dnd-handle-multiple-urls + window + (mapcar #'w32-dropped-file-to-url arg) + 'private))) + (dnd-handle-movement (event-start event))))) (defun w32-drag-n-drop-other-frame (event) "Edit the files listed in the drag-n-drop EVENT, in other frames. @@ -431,15 +454,84 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (w32-set-clipboard-data (string-replace "\0" "\\0" value)) (put 'x-selections (or type 'PRIMARY) value))) -(defun w32--get-selection (&optional type data-type) +(defvar w32--selection-target-translations + '((PNG . image/png) + (DIBV5 . image/png) + (HTML\ Format . text/html))) + +(defun w32--translate-selection-target (target) + (let ((xlat (assoc target w32--selection-target-translations))) + (if xlat + (cdr xlat) + target))) + +(defun w32--translate-reverse-selection-target (target) + (append + (mapcar #'car + (seq-filter + (lambda (x) + (eq target + (w32--translate-selection-target (car x)))) + w32--selection-target-translations)) + (list target))) + +(defvar w32--textual-mime-types + '("application/xml" + "application/json" + "application/yaml" + "application/json-seq" + "\\`text/" + "\\+xml\\'" + "\\+json\\'" + "\\+yaml\\'" + "\\+json-seq\\'")) + +(defun w32--mime-type-textual-p (mime-type) + "Returns t if MIME-TYPE, a symbol, names a textual MIME type. + +This function is intended to classify clipboard data. All MIME subtypes +of text/ are considered textual. Also those with suffixes +xml, +json, ++yaml, +json-seq. And application/xml, application/json, +application/yaml, application/json-seq. + +This classification is not exhaustive. Some MIME types not listed may +also be textual." + (string-match-p + (mapconcat #'identity w32--textual-mime-types "\\|") + (symbol-name mime-type))) + +(declare-function w32--get-clipboard-data-media "w32select.c") + +(defun w32--get-selection (&optional type data-type) (cond ((and (eq type 'CLIPBOARD) (eq data-type 'STRING)) (with-demoted-errors "w32-get-clipboard-data:%S" (w32-get-clipboard-data))) ((eq data-type 'TARGETS) (if (eq type 'CLIPBOARD) - (w32-selection-targets type) + (vconcat + (delete-dups + (seq-map #'w32--translate-selection-target + (w32-selection-targets type)))) (if (get 'x-selections (or type 'PRIMARY)) '[STRING]))) + ((eq type 'CLIPBOARD) + (let ((tmp-file (make-temp-file "emacs-clipboard")) + (is-textual (w32--mime-type-textual-p data-type))) + (unwind-protect + (let* ((data-types (w32--translate-reverse-selection-target data-type)) + (data (w32--get-clipboard-data-media data-types tmp-file is-textual))) + (cond + ;; data is in the file + ((eq data t) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally tmp-file) + (buffer-string))) + ;; data is in data var + ((stringp data) data) + ;; No data + (t nil))) + (delete-file tmp-file)))) (t (get 'x-selections (or type 'PRIMARY))))) (defun w32--selection-owner-p (selection) diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index c736f694083..eadf0988805 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -1997,7 +1997,7 @@ With optional argument SEE-THRU set to non-nil, text in the buffer (aset artist-rb-save-data 6 0))) (defun artist-no-rb-unset-point2 () - "This function unsets point 2 when not rubber-banding." + "Unset point 2 when not rubber-banding." (if (= (aref artist-rb-save-data 6) 1) (let ((x-now (artist-current-column)) (y-now (artist-current-line)) @@ -2020,7 +2020,7 @@ With optional argument SEE-THRU set to non-nil, text in the buffer (aset artist-rb-save-data 6 1))) (defun artist-no-rb-unset-points () - "This function unsets point 1 and 2 when not rubber-banding." + "Unset point 1 and 2 when not rubber-banding." (artist-no-rb-unset-point1) (artist-no-rb-unset-point2)) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index cbcea8af012..99a97c9bb8d 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1377,6 +1377,12 @@ and must return a string (the key to use)." :version "28.1" :type 'function) +(defcustom bibtex-entry-ask-for-key t + "If non-nil, `bibtex-entry' asks for a key." + :group 'bibtex + :version "31.1" + :type 'boolean) + (defcustom bibtex-entry-offset 0 "Offset for BibTeX entries. Added to the value of all other variables which determine columns." @@ -3852,7 +3858,8 @@ is non-nil." (let ((completion-ignore-case t)) (list (completing-read "Entry Type: " bibtex-entry-alist nil t nil 'bibtex-entry-type-history)))) - (let ((key (if bibtex-maintain-sorted-entries + (let ((key (if (and bibtex-maintain-sorted-entries + bibtex-entry-ask-for-key) (bibtex-read-key (format "%s key: " entry-type)))) (field-list (bibtex-field-list entry-type))) (unless (bibtex-prepare-new-entry (list key nil entry-type)) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index f5a20e0ca0e..c8da28187ee 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -1814,7 +1814,7 @@ can also be used to fill comments. (setq-local font-lock-fontify-region-function #'css--fontify-region) ;; Tree-sitter specific setup. - (treesit-parser-create 'css) + (setq treesit-primary-parser (treesit-parser-create 'css)) (setq-local treesit-simple-indent-rules css--treesit-indent-rules) (setq-local treesit-defun-type-regexp "rule_set") (setq-local treesit-defun-name-function #'css--treesit-defun-name) diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el index edeb1540feb..bb514f462ea 100644 --- a/lisp/textmodes/emacs-news-mode.el +++ b/lisp/textmodes/emacs-news-mode.el @@ -106,13 +106,15 @@ outline-minor-mode-use-buttons 'in-margins) (outline-minor-mode) (setq-local imenu-generic-expression outline-imenu-generic-expression) + ;; This is so 'C-h o' picks up correctly symbols quoted 'like this'. + (modify-syntax-entry ?' "\"") (emacs-etc--hide-local-variables)) ;;;###autoload (define-derived-mode emacs-news-mode text-mode "NEWS" "Major mode for editing the Emacs NEWS file." ;; Disable buttons. - (button-mode nil) + (button-mode -1) ;; And make the buffer writable. This is used when toggling ;; emacs-news-mode. (setq buffer-read-only nil) @@ -245,7 +247,7 @@ untagged NEWS entry." (while (re-search-forward "'\\([^-][^ \t\n]+\\)'" nil t) ;; Filter out references to key sequences. (let ((string (match-string 1))) - (when-let ((symbol (intern-soft string))) + (when-let* ((symbol (intern-soft string))) (when (or (boundp symbol) (fboundp symbol)) (buttonize-region (match-beginning 1) (match-end 1) diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index 29c56f8feaf..11c67d2dc51 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -1115,9 +1115,9 @@ The `justification' text-property can locally override this variable." (const right) (const full) (const center) - (const none)) + (const none)) + :local t :safe 'symbolp) -(make-variable-buffer-local 'default-justification) (defun current-justification () "How should we justify this line? diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 09d4e8a8d1a..9d51ed27371 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -810,6 +810,18 @@ Mostly we check word delimiters." (let ((pos (point))) (or (>= pos start) (<= pos stop) (= pos (1+ stop)))))))) +(defcustom flyspell-delay-use-timer nil + "Whether Flyspell should use a timer for waiting after a delayed command. + +If this is non-nil, Flyspell sets up a timer for checking the word at +point `flyspell-delay' seconds after you invoke a delayed command. +Otherwise, if this option is nil, Flyspell uses `sit-for' to wait for +that duration instead." + :type 'boolean + :version "31.1") + +(defvar flyspell--timer nil) + ;;*---------------------------------------------------------------------*/ ;;* flyspell-check-word-p ... */ ;;*---------------------------------------------------------------------*/ @@ -844,7 +856,15 @@ Mostly we check word delimiters." ;; The current command is not delayed, that ;; is that we must check the word now. (and (not unread-command-events) - (sit-for flyspell-delay))) + (if (not flyspell-delay-use-timer) + (sit-for flyspell-delay) + (setq flyspell--timer + (run-with-idle-timer + flyspell-delay nil + (lambda (buffer) + (when (eq (current-buffer) buffer) (flyspell-word))) + (current-buffer))) + nil))) (t t))) (t t)))) @@ -955,6 +975,7 @@ Mostly we check word delimiters." (defun flyspell-post-command-hook () "The `post-command-hook' used by flyspell to check a word on-the-fly." (interactive) + (when (timerp flyspell--timer) (cl-callf cancel-timer flyspell--timer)) (when flyspell-mode (with-local-quit (let ((command this-command) @@ -1179,7 +1200,7 @@ spell-check." (set-process-query-on-exit-flag ispell-process nil) ;; Wait until ispell has processed word. (while (progn - (accept-process-output ispell-process) + (accept-process-output ispell-process 1) (not (string= "" (car ispell-filter))))) ;; (ispell-send-string "!\n") ;; back to terse mode. diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el index 235e1055fa9..f78fbdde1da 100644 --- a/lisp/textmodes/html-ts-mode.el +++ b/lisp/textmodes/html-ts-mode.el @@ -92,7 +92,7 @@ Return nil if there is no name or if NODE is not a defun node." (unless (treesit-ready-p 'html) (error "Tree-sitter for HTML isn't available")) - (treesit-parser-create 'html) + (setq treesit-primary-parser (treesit-parser-create 'html)) ;; Indent. (setq-local treesit-simple-indent-rules html-ts-mode--indent-rules) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 667da10d7a3..404f682d379 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -346,12 +346,11 @@ calling \\[ispell-change-dictionary] with that value. This variable is automatically set when defined in the file with either `ispell-dictionary-keyword' or the Local Variable syntax." :type '(choice string - (const :tag "default" nil))) + (const :tag "default" nil)) + :local t) ;;;###autoload (put 'ispell-local-dictionary 'safe-local-variable 'string-or-null-p) -(make-variable-buffer-local 'ispell-local-dictionary) - (defcustom ispell-dictionary nil "Default dictionary to use if `ispell-local-dictionary' is nil." :type '(choice string @@ -377,10 +376,8 @@ such as \"&\". See `ispell-html-skip-alists' for more details. This variable affects spell-checking of HTML, XML, and SGML files." :type '(choice (const :tag "always" t) (const :tag "never" nil) - (const :tag "use-mode-name" use-mode-name))) - -(make-variable-buffer-local 'ispell-skip-html) - + (const :tag "use-mode-name" use-mode-name)) + :local t) (defcustom ispell-local-dictionary-alist nil "List of local or customized dictionary definitions. @@ -3320,9 +3317,7 @@ Generated from `ispell-tex-skip-alists'." "\\|" ;; keys wrapped in begin{} (mapconcat (lambda (lst) - (concat "\\\\begin[ \t\n]*{[ \t\n]*" - (car lst) - "[ \t\n]*}")) + (concat "\\\\begin[ \t\n]*{" (car lst) "}")) (car (cdr ispell-tex-skip-alists)) "\\|"))) @@ -3728,7 +3723,7 @@ If APPEND is non-nil, don't erase previous debugging output." (while cur (unless (string-prefix-p word (car cur)) (setcar cur (concat word (substring (car cur) len)))) - (while (when-let ((next (cadr cur))) + (while (when-let* ((next (cadr cur))) (not (string-prefix-p word next t))) (setcdr cur (cddr cur))) (setq cur (cdr cur))) diff --git a/lisp/textmodes/less-css-mode.el b/lisp/textmodes/less-css-mode.el index 51e62a712b4..27c94f625fc 100644 --- a/lisp/textmodes/less-css-mode.el +++ b/lisp/textmodes/less-css-mode.el @@ -115,8 +115,8 @@ This can be also be set to a full path, or a relative path. If the path is relative, it will be relative to the value of `less-css-output-dir', if set, or the current directory by default." - :type '(choice (const :tag "Default" nil) file)) -(make-variable-buffer-local 'less-css-output-file-name) + :type '(choice (const :tag "Default" nil) file) + :local t) (defcustom less-css-input-file-name nil "File name which will be compiled to CSS. @@ -131,10 +131,10 @@ variables. This can be also be set to a full path, or a relative path. If the path is relative, it will be relative to the current directory by default." - :type '(choice (const nil) file)) + :type '(choice (const nil) file) + :local t) ;;;###autoload (put 'less-css-input-file-name 'safe-local-variable #'stringp) -(make-variable-buffer-local 'less-css-input-file-name) (defconst less-css-default-error-regex "^\\(?:\e\\[31m\\)?\\([^\e\n]*\\|FileError:.*\n\\)\\(?:\e\\[39m\e\\[31m\\)? in \\(?:\e\\[39m\\)?\\([^ \r\n\t\e]+\\)\\(?:\e\\[90m\\)?\\(?::\\| on line \\)\\([0-9]+\\)\\(?::\\|, column \\)\\([0-9]+\\):?\\(?:\e\\[39m\\)?") diff --git a/lisp/textmodes/refer.el b/lisp/textmodes/refer.el index f5f4be75c03..b6707d53071 100644 --- a/lisp/textmodes/refer.el +++ b/lisp/textmodes/refer.el @@ -91,7 +91,8 @@ the default search path. Since Refer does not know that default path, it cannot search it. Include that path explicitly in your BIBINPUTS environment if you really want it searched (which is not likely to happen anyway)." - :type '(choice (repeat directory) (const bibinputs) (const texinputs))) + :type '(choice (repeat directory) (const bibinputs) (const texinputs)) + :local t) (defcustom refer-bib-files 'dir "List of \\.bib files to search for references, @@ -109,14 +110,16 @@ If `refer-bib-files' is nil, auto or dir, it is setq'd to the appropriate list of files when it is first used if `refer-cache-bib-files' is t. If `refer-cache-bib-files' is nil, the list of \\.bib files to use is re-read each time it is needed." - :type '(choice (repeat file) (const nil) (const auto) (const dir))) + :type '(choice (repeat file) (const nil) (const auto) (const dir)) + :local t) (defcustom refer-cache-bib-files t "Variable determining whether the value of `refer-bib-files' should be cached. If t, initialize the value of refer-bib-files the first time it is used. If nil, re-read the list of \\.bib files depending on the value of `refer-bib-files' each time it is needed." - :type 'boolean) + :type 'boolean + :local t) (defcustom refer-bib-files-regexp "\\\\bibliography" "Regexp matching a bibliography file declaration. @@ -130,10 +133,6 @@ If a specified file doesn't exist and has no extension, a \\.bib extension is automatically tried." :type 'regexp) -(make-variable-buffer-local 'refer-bib-files) -(make-variable-buffer-local 'refer-cache-bib-files) -(make-variable-buffer-local 'refer-bib-directory) - ;;; Internal variables (defvar refer-saved-state nil) (defvar refer-previous-keywords nil) diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index 0eaffec3b54..7b4407ec336 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -152,7 +152,7 @@ No active TAGS table is required." (setq dlist (reftex-uniquify-by-car dlist)) (if (null dlist) (error "No duplicate labels in document")) (switch-to-buffer-other-window "*Duplicate Labels*") - (set (make-local-variable 'TeX-master) master) + (setq-local TeX-master master) (erase-buffer) (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") (insert @@ -492,17 +492,16 @@ With no argument, this command toggles (with-current-buffer crt-buf (when reftex-mode (if (boundp 'multi-isearch-next-buffer-function) - (set (make-local-variable - 'multi-isearch-next-buffer-function) - #'reftex-isearch-switch-to-next-file) - (set (make-local-variable 'isearch-wrap-function) - #'reftex-isearch-wrap-function) - (set (make-local-variable 'isearch-search-fun-function) - (lambda () #'reftex-isearch-isearch-search)) - (set (make-local-variable 'isearch-push-state-function) - #'reftex-isearch-push-state-function) - (set (make-local-variable 'isearch-next-buffer-function) - #'reftex-isearch-switch-to-next-file)) + (setq-local multi-isearch-next-buffer-function + #'reftex-isearch-switch-to-next-file) + (setq-local isearch-wrap-function + #'reftex-isearch-wrap-function) + (setq-local isearch-search-fun-function + (lambda () #'reftex-isearch-isearch-search)) + (setq-local isearch-push-state-function + #'reftex-isearch-push-state-function) + (setq-local isearch-next-buffer-function + #'reftex-isearch-switch-to-next-file)) (setq reftex-isearch-minor-mode t)))) (add-hook 'reftex-mode-hook #'reftex-isearch-minor-mode)) (dolist (crt-buf (buffer-list)) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 68efa4fe8a3..cb491367c8d 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -387,9 +387,9 @@ Press `?' for a summary of important key bindings, or check the menu. Here are all local bindings. \\{reftex-index-mode-map}" - (set (make-local-variable 'revert-buffer-function) #'reftex-index-revert) - (set (make-local-variable 'reftex-index-restriction-data) nil) - (set (make-local-variable 'reftex-index-restriction-indicator) nil) + (setq-local revert-buffer-function #'reftex-index-revert) + (setq-local reftex-index-restriction-data nil) + (setq-local reftex-index-restriction-indicator nil) (setq mode-line-format (list "---- " 'mode-line-buffer-identification " " 'global-mode-string @@ -511,9 +511,9 @@ With prefix 3, restrict index to region." ;; If the buffer is currently restricted, empty it to force update. (when reftex-index-restriction-data (reftex-erase-buffer)) - (set (make-local-variable 'reftex-last-index-file) calling-file) - (set (make-local-variable 'reftex-index-tag) index-tag) - (set (make-local-variable 'reftex-docstruct-symbol) docstruct-symbol) + (setq-local reftex-last-index-file calling-file) + (setq-local reftex-index-tag index-tag) + (setq-local reftex-docstruct-symbol docstruct-symbol) (if restriction (setq reftex-index-restriction-indicator (car restriction) reftex-index-restriction-data (cdr restriction)) @@ -1303,8 +1303,7 @@ If the buffer is non-empty, delete the old header first." (lambda (a _b) (equal (car a) default-macro)))) macro entry key repeat) - (if master (set (make-local-variable 'TeX-master) - (file-name-nondirectory master))) + (when master (setq-local TeX-master (file-name-nondirectory master))) (when (> (buffer-size) 0) (goto-char 1) @@ -1387,9 +1386,9 @@ Here are all local bindings. \\{reftex-index-phrases-mode-map}" :syntax-table reftex-index-phrases-syntax-table - (set (make-local-variable 'font-lock-defaults) - reftex-index-phrases-font-lock-defaults) - (set (make-local-variable 'reftex-index-phrases-marker) (make-marker))) + (setq-local font-lock-defaults + reftex-index-phrases-font-lock-defaults) + (setq-local reftex-index-phrases-marker (make-marker))) ;; (add-hook 'reftex-index-phrases-mode-hook #'turn-on-font-lock) (defun reftex-index-next-phrase (&optional arg) diff --git a/lisp/textmodes/reftex-sel.el b/lisp/textmodes/reftex-sel.el index fa36543daf4..aec89448481 100644 --- a/lisp/textmodes/reftex-sel.el +++ b/lisp/textmodes/reftex-sel.el @@ -97,7 +97,7 @@ Press `?' for a summary of important key bindings. During a selection process, these are the local bindings. \\{reftex-select-label-mode-map}" - (set (make-local-variable 'reftex-select-marked) nil) + (setq-local reftex-select-marked nil) (when (syntax-table-p reftex-latex-syntax-table) (set-syntax-table reftex-latex-syntax-table)) ;; We do not set a local map - reftex-select-item does this. @@ -136,7 +136,7 @@ Press `?' for a summary of important key bindings. During a selection process, these are the local bindings. \\{reftex-select-label-mode-map}" - (set (make-local-variable 'reftex-select-marked) nil) + (setq-local reftex-select-marked nil) ;; We do not set a local map - reftex-select-item does this. ) @@ -236,9 +236,9 @@ During a selection process, these are the local bindings. (concat "\\`" (regexp-quote (file-name-directory (reftex-TeX-master-file)))))) - (set (make-local-variable 'reftex-docstruct-symbol) docstruct-symbol) - (set (make-local-variable 'reftex-prefix) - (cdr (assoc labels reftex-typekey-to-prefix-alist))) + (setq-local reftex-docstruct-symbol docstruct-symbol) + (setq-local reftex-prefix + (cdr (assoc labels reftex-typekey-to-prefix-alist))) (if (equal reftex-prefix " ") (setq reftex-prefix nil)) ;; Walk the docstruct and insert the appropriate stuff @@ -459,7 +459,7 @@ During a selection process, these are the local bindings. (reftex-find-start-point (point-min) offset reftex-last-data reftex-last-line) (beginning-of-line 1) - (set (make-local-variable 'reftex-last-follow-point) (point)) + (setq-local reftex-last-follow-point (point)) (unwind-protect (progn @@ -480,9 +480,9 @@ During a selection process, these are the local bindings. (mapc (lambda (c) (delete-overlay (nth 1 c))) reftex-select-marked))))) - (set (make-local-variable 'reftex-last-line) - (+ (count-lines (point-min) (point)) (if (bolp) 1 0))) - (set (make-local-variable 'reftex-last-data) reftex--last-data) + (setq-local reftex-last-line + (+ (count-lines (point-min) (point)) (if (bolp) 1 0))) + (setq-local reftex-last-data reftex--last-data) (reftex-kill-buffer "*RefTeX Help*") (setq reftex-callback-fwd (not reftex-callback-fwd)) ;; ;-))) (message "") diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el index 1cc6e27e780..fe5a32f15f0 100644 --- a/lisp/textmodes/reftex-toc.el +++ b/lisp/textmodes/reftex-toc.el @@ -1,6 +1,6 @@ ;;; reftex-toc.el --- RefTeX's table of contents mode -*- lexical-binding: t; -*- -;; Copyright (C) 1997-2000, 2003-2024 Free Software Foundation, Inc. +;; Copyright (C) 1997-2024 Free Software Foundation, Inc. ;; Author: Carsten Dominik <dominik@science.uva.nl> ;; Maintainer: auctex-devel@gnu.org @@ -125,13 +125,13 @@ Press `?' for a summary of important key bindings. Here are all local bindings. \\{reftex-toc-mode-map}" - (set (make-local-variable 'transient-mark-mode) t) - (set (make-local-variable 'revert-buffer-function) #'reftex-toc-revert) - (set (make-local-variable 'reftex-toc-include-labels-indicator) "") - (set (make-local-variable 'reftex-toc-max-level-indicator) - (if (= reftex-toc-max-level 100) - "ALL" - (int-to-string reftex-toc-max-level))) + (setq-local transient-mark-mode t) + (setq-local revert-buffer-function #'reftex-toc-revert) + (setq-local reftex-toc-include-labels-indicator "") + (setq-local reftex-toc-max-level-indicator + (if (= reftex-toc-max-level 100) + "ALL" + (int-to-string reftex-toc-max-level))) (setq mode-line-format (list "---- " 'mode-line-buffer-identification " " 'global-mode-string " (" mode-name ")" @@ -241,7 +241,7 @@ When called with a raw \\[universal-argument] prefix, rescan the document first. (switch-to-buffer "*toc*")) (or (eq major-mode 'reftex-toc-mode) (reftex-toc-mode)) - (set (make-local-variable 'reftex-docstruct-symbol) docstruct-symbol) + (setq-local reftex-docstruct-symbol docstruct-symbol) (setq reftex-toc-include-labels-indicator (if (eq reftex-toc-include-labels t) "ALL" diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index 791b10412c9..aac735dc771 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -382,9 +382,6 @@ See also `reftex-toc-split-windows-horizontally'." :group 'reftex-table-of-contents-browser :type 'number) -(defvar reftex-toc-split-windows-horizontally-fraction 0.5 - "This variable is obsolete, use `reftex-toc-split-windows-fraction' instead.") - (defcustom reftex-toc-keep-other-windows t "Non-nil means, split the selected window to display the *toc* buffer. This helps to keep the window configuration, but makes the *toc* small. @@ -2112,6 +2109,9 @@ the following construct: \\bbb [xxx] {aaa}." :group 'reftex-miscellaneous-configurations :type 'hook) +(defvar reftex-toc-split-windows-horizontally-fraction 0.5) +(make-obsolete-variable 'reftex-toc-split-windows-horizontally-fraction + 'reftex-toc-split-windows-fraction "31.1") (provide 'reftex-vars) diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 6974a4be4a7..165afd5a746 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -1,6 +1,6 @@ ;;; reftex.el --- minor mode for doing \label, \ref, \cite, \index in LaTeX -*- lexical-binding: t; -*- -;; Copyright (C) 1997-2000, 2003-2024 Free Software Foundation, Inc. +;; Copyright (C) 1997-2024 Free Software Foundation, Inc. ;; Author: Carsten Dominik <dominik@science.uva.nl> ;; Maintainer: auctex-devel@gnu.org @@ -273,8 +273,7 @@ on the menu bar. (defvar reftex-multifile-index 0) ;; Variable holding the symbol with the label list of the document. -(defvar reftex-docstruct-symbol nil) -(make-variable-buffer-local 'reftex-docstruct-symbol) +(defvar-local reftex-docstruct-symbol nil) (defun reftex-next-multifile-index () ;; Return the next free index for multifile symbols. @@ -2036,8 +2035,8 @@ IGNORE-WORDS List of words which should be removed from the string." ;; of font-lock) (rename-buffer newname t) ;; Good: we have the indirection functions - (set (make-local-variable 'font-lock-fontify-region-function) - #'reftex-select-font-lock-fontify-region) + (setq-local font-lock-fontify-region-function + #'reftex-select-font-lock-fontify-region) (let ((major-mode 'latex-mode)) (font-lock-mode 1))) (rename-buffer oldname)))) @@ -2116,8 +2115,7 @@ IGNORE-WORDS List of words which should be removed from the string." ;; Define a menu for the menu bar if Emacs is running under X -(defvar reftex-isearch-minor-mode nil) -(make-variable-buffer-local 'reftex-isearch-minor-mode) +(defvar-local reftex-isearch-minor-mode nil) (easy-menu-define reftex-mode-menu reftex-mode-map "Menu used in RefTeX mode." diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 5f99ee016a2..25b04e55253 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -102,7 +102,6 @@ ;; FIXME: Embed complicated `defconst's in `eval-when-compile'. -;; Common Lisp stuff (require 'cl-lib) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1324,8 +1323,6 @@ The hook for `text-mode' is run before this one." ;; Pull in variable definitions silencing byte-compiler. (require 'newcomment) -(defvar electric-indent-inhibit) - ;; Use rst-mode for *.rst and *.rest files. Many ReStructured-Text files ;; use *.txt, but this is too generic to be set as a default. ;;;###autoload (add-to-list 'auto-mode-alist (purecopy '("\\.re?st\\'" . rst-mode))) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index f126df8955a..fad7008adc0 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -533,6 +533,7 @@ an optional alist of possible values." "Add \"face\" tags with `facemenu-keymap' commands." (let ((tag-face (ensure-list (cdr (assq face sgml-face-tag-alist))))) (cond (tag-face + (require 'skeleton) (setq tag-face (funcall skeleton-transformation-function tag-face)) (setq facemenu-end-add-face (mapconcat (lambda (f) (concat "</" f ">")) (reverse tag-face))) @@ -851,6 +852,7 @@ If QUIET, do not print a message when there are no attributes for TAG." (setq alist (cons '("class") alist))) (unless (assoc-string "id" alist) (setq alist (cons '("id") alist)))) + (require 'skeleton) (if (stringp (car alist)) (progn (insert (if (eq (preceding-char) ?\s) "" ?\s) @@ -1203,7 +1205,7 @@ and move to the line in the SGML document that caused it." (or sgml-saved-validate-command (concat sgml-validate-command " " - (when-let ((name (buffer-file-name))) + (when-let* ((name (buffer-file-name))) (shell-quote-argument (file-name-nondirectory name)))))))) (setq sgml-saved-validate-command command) @@ -2434,14 +2436,14 @@ To work around that, do: (defun html-mode--complete-at-point () ;; Complete a tag like <colg etc. (or - (when-let ((tag (save-excursion - (and (looking-back "<\\([^ \t\n]*\\)" - (line-beginning-position)) - (match-string 1))))) + (when-let* ((tag (save-excursion + (and (looking-back "<\\([^ \t\n]*\\)" + (line-beginning-position)) + (match-string 1))))) (list (match-beginning 1) (point) (mapcar #'car html-tag-alist))) ;; Complete params like <colgroup ali etc. - (when-let ((tag (save-excursion (sgml-beginning-of-tag))) + (when-let* ((tag (save-excursion (sgml-beginning-of-tag))) (params (seq-filter #'consp (cdr (assoc tag html-tag-alist)))) (param (save-excursion (and (looking-back "[ \t\n]\\([^= \t\n]*\\)" @@ -2450,14 +2452,14 @@ To work around that, do: (list (match-beginning 1) (point) (mapcar #'car params))) ;; Complete param values like <colgroup align=mi etc. - (when-let ((tag (save-excursion (sgml-beginning-of-tag))) - (params (seq-filter #'consp (cdr (assoc tag html-tag-alist)))) - (param (save-excursion - (and (looking-back - "[ \t\n]\\([^= \t\n]+\\)=\\([^= \t\n]*\\)" - (line-beginning-position)) - (match-string 1)))) - (values (cdr (assoc param params)))) + (when-let* ((tag (save-excursion (sgml-beginning-of-tag))) + (params (seq-filter #'consp (cdr (assoc tag html-tag-alist)))) + (param (save-excursion + (and (looking-back + "[ \t\n]\\([^= \t\n]+\\)=\\([^= \t\n]*\\)" + (line-beginning-position)) + (match-string 1)))) + (values (cdr (assoc param params)))) (list (match-beginning 2) (point) (mapcar #'car values))))) @@ -2474,10 +2476,9 @@ To work around that, do: (when (and (file-exists-p file) (not (yes-or-no-p (format "%s exists; overwrite?" file)))) (user-error "%s exists" file)) - (with-temp-buffer - (set-buffer-multibyte nil) - (insert image) - (write-region (point-min) (point-max) file)) + (let ((coding-system-for-write 'emacs-internal)) + (with-temp-file file + (insert image))) (insert (format "<img src=%S>\n" (file-relative-name file))) (insert-image (create-image file (mailcap-mime-type-to-extension type) nil diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 97c950267c6..06a45112719 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -210,6 +210,7 @@ otherwise, the file name, preceded by a space, is added at the end. If the value is a form, it is evaluated to get the command to use." :type '(choice (const nil) string sexp) + :risky t :group 'tex-view) ;;;###autoload @@ -309,7 +310,7 @@ Should be a simple file name with no extension or directory specification.") (defvar tex-print-file nil "File name that \\[tex-print] prints. -Set by \\[tex-region], \\[tex-buffer], and \\[tex-file].") +Set by \\[tex-region], \\[tex-buffer], \\[tex-file] and \\[tex-compile].") (defvar tex-mode-syntax-table (let ((st (make-syntax-table))) @@ -636,6 +637,14 @@ An alternative value is \" . \", if you use a font with a narrow period." 3 '(tex-font-lock-append-prop 'bold) 'append))))) "Gaudy expressions to highlight in TeX modes.") +(defvar-local tex-expl-region-list nil + "List of region boundaries where expl3 syntax is active. +It will be nil in buffers visiting files which use expl3 syntax +throughout, for example, expl3 classes or packages.") + +(defvar-local tex-expl-buffer-p nil + "Non-nil in buffers using expl3 syntax throughout.") + (defun tex-font-lock-suscript (pos) (unless (or (memq (get-text-property pos 'face) '(font-lock-constant-face font-lock-builtin-face @@ -645,7 +654,17 @@ An alternative value is \" . \", if you use a font with a narrow period." (pos pos)) (while (eq (char-before pos) ?\\) (setq pos (1- pos) odd (not odd))) - odd)) + odd) + ;; Check if POS is in an expl3 syntax region or an expl3 buffer + (when (eq (char-after pos) ?_) + (or tex-expl-buffer-p + (and + tex-expl-region-list + (catch 'result + (dolist (range tex-expl-region-list) + (and (> pos (car range)) + (< pos (cdr range)) + (throw 'result t)))))))) (if (eq (char-after pos) ?_) `(face subscript display (raise ,(car tex-font-script-display))) `(face superscript display (raise ,(cadr tex-font-script-display)))))) @@ -1289,8 +1308,16 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook #'tex--prettify-symbols-compose-p) (setq-local syntax-propertize-function (syntax-propertize-rules latex-syntax-propertize-rules)) + ;; Don't add extra processing to `syntax-propertize' in files where + ;; expl3 syntax is always active. + :after-hook (progn (tex-expl-buffer-parse) + (unless tex-expl-buffer-p + (add-hook 'syntax-propertize-extend-region-functions + #'tex-expl-region-set nil t))) ;; TABs in verbatim environments don't do what you think. (setq-local indent-tabs-mode nil) + ;; Set up xref backend in TeX buffers. + (add-hook 'xref-backend-functions #'tex--xref-backend nil t) ;; Other vars that should be buffer-local. (make-local-variable 'tex-command) (make-local-variable 'tex-start-of-header) @@ -1936,6 +1963,36 @@ Mark is left at original location." (forward-sexp 1)))))) (message "%s words" count)))) +(defun tex-expl-buffer-parse () + "Identify buffers using expl3 syntax throughout." + (save-excursion + (goto-char (point-min)) + (when (tex-search-noncomment + (re-search-forward + "\\\\\\(?:ExplFile\\|ProvidesExpl\\|__xparse_file\\)" + nil t)) + (setq tex-expl-buffer-p t)))) + +(defun tex-expl-region-set (_beg _end) + "Create a list of regions where expl3 syntax is active. +This function updates the list whenever `syntax-propertize' runs, and +stores it in the buffer-local variable `tex-expl-region-list'. The list +will always be nil when the buffer visits an expl3 file, for example, an +expl3 class or package, where the entire file uses expl3 syntax." + (unless syntax-ppss--updated-cache;; Stop forward search running twice. + (setq tex-expl-region-list nil) + ;; Leaving this test here allows users to set `tex-expl-buffer-p' + ;; independently of the mode's automatic detection of an expl3 file. + (unless tex-expl-buffer-p + (goto-char (point-min)) + (let ((case-fold-search nil)) + (while (tex-search-noncomment + (search-forward "\\ExplSyntaxOn" nil t)) + (let ((new-beg (point)) + (new-end (or (tex-search-noncomment + (search-forward "\\ExplSyntaxOff" nil t)) + (point-max)))) + (push (cons new-beg new-end) tex-expl-region-list))))))) ;;; Invoking TeX in an inferior shell. @@ -2035,8 +2092,9 @@ In the tex shell buffer this command behaves like `comint-send-input'." (defun tex-display-shell () "Make the TeX shell buffer visible in a window." - (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) - (display-buffer (tex-shell-buf) display-tex-shell-buffer-action)) + (display-buffer (tex-shell-buf) '(display-buffer-in-previous-window + (inhibit-same-window . t) + (category . tex-shell))) (tex-recenter-output-buffer nil)) (defun tex-shell-sentinel (proc _msg) @@ -2155,6 +2213,8 @@ If NOT-ALL is non-nil, save the `.dvi' file." t "%r.dvi") ("xdvi %r &" "%r.dvi") ("\\doc-view \"%r.pdf\"" "%r.pdf") + ("evince %r.pdf &" "%r.pdf") + ("mupdf %r.pdf &" "%r.pdf") ("xpdf %r.pdf &" "%r.pdf") ("gv %r.ps &" "%r.ps") ("yap %r &" "%r.dvi") @@ -2473,6 +2533,7 @@ Only applies the FSPEC to the args part of FORMAT." (if (tex-shell-running) (tex-kill-job) (tex-start-shell)) + (setq tex-print-file (expand-file-name (tex-main-file))) (tex-send-tex-command cmd dir)))) (defun tex-start-tex (command file &optional dir) @@ -2692,9 +2753,10 @@ line LINE of the window, or centered if LINE is nil." (let ((tex-shell (get-buffer "*tex-shell*"))) (if (null tex-shell) (message "No TeX output buffer") - (when-let ((window - (with-suppressed-warnings ((obsolete display-tex-shell-buffer-action)) - (display-buffer tex-shell display-tex-shell-buffer-action)))) + (when-let* ((window + (display-buffer tex-shell '(display-buffer-in-previous-window + (inhibit-same-window . t) + (category . tex-shell))))) (with-selected-window window (bury-buffer tex-shell) (goto-char (point-max)) @@ -3742,6 +3804,267 @@ There might be text before point." (process-send-region tex-chktex--process (point-min) (point-max)) (process-send-eof tex-chktex--process)))) + +;;; Xref backend + +;; Here we lightly adapt the default etags backend for xref so that +;; the main xref user commands (including `xref-find-definitions', +;; `xref-find-apropos', and `xref-find-references' [on M-., C-M-., and +;; M-?, respectively]) work in TeX buffers. The only methods we +;; actually modify are `xref-backend-identifier-at-point' and +;; `xref-backend-references'. Many of the complications here, and in +;; `etags' itself, are due to the necessity of parsing both the old +;; TeX syntax and the new expl3 syntax, which will continue to appear +;; together in documents for the foreseeable future. Synchronizing +;; Emacs and `etags' this way aims to improve the user experience "out +;; of the box." + +;; Populate `semantic-symref-filepattern-alist' for the in-tree modes; +;; AUCTeX is doing the same for its modes. +(with-eval-after-load 'semantic/symref/grep + (defvar semantic-symref-filepattern-alist) + (push '(latex-mode "*.[tT]e[xX]" "*.ltx" "*.sty" "*.cl[so]" + "*.bbl" "*.drv" "*.hva") + semantic-symref-filepattern-alist) + (push '(plain-tex-mode "*.[tT]e[xX]" "*.ins") + semantic-symref-filepattern-alist) + (push '(doctex-mode "*.dtx") semantic-symref-filepattern-alist)) + +(defun tex--xref-backend () 'tex-etags) + +(cl-defmethod xref-backend-identifier-at-point ((_backend (eql 'tex-etags))) + (require 'etags) + (tex--thing-at-point)) + +;; The detection of `_' and `:' is a primitive method for determining +;; whether point is on an expl3 construct. It may fail in some +;; instances. +(defun tex--thing-at-point () + "Demarcate `thing-at-point' for the TeX `xref' backend." + (let ((bounds (tex--bounds-of-symbol-at-point))) + (when bounds + (let ((texsym (buffer-substring-no-properties (car bounds) (cdr bounds)))) + (if (and (not (string-match-p "reference" (symbol-name this-command))) + (seq-contains-p texsym ?_) + (seq-contains-p texsym ?:)) + (seq-take texsym (seq-position texsym ?:)) + texsym))))) + +(defun tex-thingatpt--beginning-of-symbol () + (and + (re-search-backward "[][\\{}\"*`'#=&()%,|$[:cntrl:][:blank:]]" nil t) + (forward-char))) + +(defun tex-thingatpt--end-of-symbol () + (and + (re-search-forward "[][\\{}\"*`'#=&()%,|$[:cntrl:][:blank:]]" nil t) + (backward-char))) + +(defun tex--bounds-of-symbol-at-point () + "Simplify `bounds-of-thing-at-point' for TeX `xref' backend." + (let ((orig (point))) + (ignore-errors + (save-excursion + (tex-thingatpt--end-of-symbol) + (tex-thingatpt--beginning-of-symbol) + (let ((beg (point))) + (if (<= beg orig) + (let ((real-end + (progn + (tex-thingatpt--end-of-symbol) + (point)))) + (cond ((and (<= orig real-end) (< beg real-end)) + (cons beg real-end)) + ((and (= orig real-end) (= beg real-end)) + (cons beg (1+ beg)))))))))));; For 1-char TeX commands. + +(cl-defmethod xref-backend-identifier-completion-table ((_backend + (eql 'tex-etags))) + (xref-backend-identifier-completion-table 'etags)) + +(cl-defmethod xref-backend-identifier-completion-ignore-case ((_backend + (eql + 'tex-etags))) + (xref-backend-identifier-completion-ignore-case 'etags)) + +(cl-defmethod xref-backend-definitions ((_backend (eql 'tex-etags)) symbol) + (xref-backend-definitions 'etags symbol)) + +(cl-defmethod xref-backend-apropos ((_backend (eql 'tex-etags)) pattern) + (xref-backend-apropos 'etags pattern)) + +;; The `xref-backend-references' method requires more code than the +;; others for at least two main reasons: TeX authors have typically been +;; free in their invention of new file types with new suffixes, and they +;; have also tended sometimes to include non-symbol characters in +;; command names. When combined with the default Semantic Symbol +;; Reference API, these two characteristics of TeX code mean that a +;; command like `xref-find-references' would often fail to find any hits +;; for a symbol at point, including the one under point in the current +;; buffer, or it would find only some instances and skip others. + +(defun tex-find-references-syntax-table () + (let ((st (if (boundp 'TeX-mode-syntax-table) + (make-syntax-table TeX-mode-syntax-table) + (make-syntax-table tex-mode-syntax-table)))) + st)) + +(defvar tex--xref-syntax-fun nil) + +(defun tex-xref-syntax-function (str beg end) + "Provide a bespoke `syntax-propertize-function' for \\[xref-find-references]." + (let* (grpb tempstr + (shrtstr (if end + (progn + (setq tempstr (seq-take str (1- (length str)))) + (if beg + (setq tempstr (seq-drop tempstr 1)) + tempstr)) + (seq-drop str 1))) + (grpa (if (and beg end) + (prog1 + (list 1 "_") + (setq grpb (list 2 "_"))) + (list 1 "_"))) + (re (concat beg (regexp-quote shrtstr) end)) + (temp-rule (if grpb + (list re grpa grpb) + (list re grpa)))) + ;; Simple benchmarks suggested that the speed-up from compiling this + ;; function was nearly nil, so `eval' and its non-byte-compiled + ;; function remain. + (setq tex--xref-syntax-fun (eval + `(syntax-propertize-rules ,temp-rule))))) + +(defun tex--collect-file-extensions () + "Gather TeX file extensions from `auto-mode-alist'." + (let* ((mlist (when (rassq major-mode auto-mode-alist) + (seq-filter + (lambda (elt) + (eq (cdr elt) major-mode)) + auto-mode-alist))) + (lcsym (intern-soft (downcase (symbol-name major-mode)))) + (lclist (and lcsym + (not (eq lcsym major-mode)) + (rassq lcsym auto-mode-alist) + (seq-filter + (lambda (elt) + (eq (cdr elt) lcsym)) + auto-mode-alist))) + (shortsym (when (stringp mode-name) + (intern-soft (concat (string-trim-right mode-name "/.*") + "-mode")))) + (lcshortsym (when (stringp mode-name) + (intern-soft (downcase + (concat + (string-trim-right mode-name "/.*") + "-mode"))))) + (shlist (and shortsym + (not (eq shortsym major-mode)) + (not (eq shortsym lcsym)) + (rassq shortsym auto-mode-alist) + (seq-filter + (lambda (elt) + (eq (cdr elt) shortsym)) + auto-mode-alist))) + (lcshlist (and lcshortsym + (not (eq lcshortsym major-mode)) + (not (eq lcshortsym lcsym)) + (rassq lcshortsym auto-mode-alist) + (seq-filter + (lambda (elt) + (eq (cdr elt) lcshortsym)) + auto-mode-alist))) + (exts (when (or mlist lclist shlist lcshlist) + (seq-union (seq-map #'car lclist) + (seq-union (seq-map #'car mlist) + (seq-union (seq-map #'car lcshlist) + (seq-map #'car shlist)))))) + (ed-exts (when exts + (seq-map + (lambda (elt) + (concat "*" (string-trim elt "\\\\" "\\\\'"))) + exts)))) + ed-exts)) + +(defvar tex--buffers-list nil) +(defvar-local tex--old-syntax-function nil) + +(cl-defmethod xref-backend-references ((_backend (eql 'tex-etags)) identifier) + "Find references of IDENTIFIER in TeX buffers and files." + (require 'semantic/symref/grep) + (defvar semantic-symref-filepattern-alist) + (let (bufs texbufs + (mode major-mode)) + (dolist (buf (buffer-list)) + (if (eq (buffer-local-value 'major-mode buf) mode) + (push buf bufs) + (when (string-match-p ".*\\.[tT]e[xX]" (buffer-name buf)) + (push buf texbufs)))) + (unless (seq-set-equal-p tex--buffers-list bufs) + (let* ((amalist (tex--collect-file-extensions)) + (extlist (alist-get mode semantic-symref-filepattern-alist)) + (extlist-new (seq-uniq + (seq-union amalist extlist #'string-match-p)))) + (setq tex--buffers-list bufs) + (dolist (buf bufs) + (when-let* ((fbuf (buffer-file-name buf)) + (ext (file-name-extension fbuf)) + (finext (concat "*." ext)) + ((not (seq-find (lambda (elt) (string-match-p elt finext)) + extlist-new))) + ((push finext extlist-new))))) + (unless (seq-set-equal-p extlist-new extlist) + (setf (alist-get mode semantic-symref-filepattern-alist) + extlist-new)))) + (let* (setsyntax + (punct (with-syntax-table (tex-find-references-syntax-table) + (seq-positions identifier (list ?w ?_) + (lambda (elt sycode) + (not (memq (char-syntax elt) sycode)))))) + (end (and punct + (memq (1- (length identifier)) punct) + (> (length identifier) 1) + (concat "\\(" + (regexp-quote + (string (elt identifier + (1- (length identifier))))) + "\\)"))) + (beg (and punct + (memq 0 punct) + (concat "\\(" + (regexp-quote (string (elt identifier 0))) + "\\)"))) + (text-mode-hook + (if (or end beg) + (progn + (tex-xref-syntax-function identifier beg end) + (setq setsyntax (lambda () + (setq-local syntax-propertize-function + tex--xref-syntax-fun) + (setq-local TeX-style-hook-applied-p t))) + (cons setsyntax text-mode-hook)) + text-mode-hook))) + (unless (memq 'doctex-mode (derived-mode-all-parents mode)) + (setq bufs (append texbufs bufs))) + (when (or end beg) + (dolist (buf bufs) + (with-current-buffer buf + (unless (local-variable-p 'tex--old-syntax-function) + (setq tex--old-syntax-function syntax-propertize-function)) + (setq-local syntax-propertize-function + tex--xref-syntax-fun) + (syntax-ppss-flush-cache (point-min))))) + (unwind-protect + (xref-backend-references nil identifier) + (when (or end beg) + (dolist (buf bufs) + (with-current-buffer buf + (when buffer-file-truename + (setq-local syntax-propertize-function + tex--old-syntax-function) + (syntax-ppss-flush-cache (point-min)))))))))) + (make-obsolete-variable 'tex-mode-load-hook "use `with-eval-after-load' instead." "28.1") (run-hooks 'tex-mode-load-hook) diff --git a/lisp/textmodes/toml-ts-mode.el b/lisp/textmodes/toml-ts-mode.el index 3c4533a7fea..806f045c23b 100644 --- a/lisp/textmodes/toml-ts-mode.el +++ b/lisp/textmodes/toml-ts-mode.el @@ -124,7 +124,7 @@ Return nil if there is no name or if NODE is not a defun node." :syntax-table toml-ts-mode--syntax-table (when (treesit-ready-p 'toml) - (treesit-parser-create 'toml) + (setq treesit-primary-parser (treesit-parser-create 'toml)) ;; Comments (setq-local comment-start "# ") diff --git a/lisp/textmodes/two-column.el b/lisp/textmodes/two-column.el index 806d6c5e709..41cd82ce728 100644 --- a/lisp/textmodes/two-column.el +++ b/lisp/textmodes/two-column.el @@ -142,15 +142,14 @@ (defcustom 2C-separator "" "A string inserted between the two columns when merging. This gets set locally by \\[2C-split]." - :type 'string) -(put '2C-separator 'permanent-local t) + :type 'string + :local 'permanent-only) (defcustom 2C-window-width 40 "The width of the first column. (Must be at least `window-min-width'.) This value is local for every buffer that sets it." - :type 'integer) -(make-variable-buffer-local '2C-window-width) -(put '2C-window-width 'permanent-local t) + :type 'integer + :local 'permanent) (defcustom 2C-beyond-fill-column 4 "Base for calculating `fill-column' for a buffer in two-column minor mode. diff --git a/lisp/textmodes/yaml-ts-mode.el b/lisp/textmodes/yaml-ts-mode.el index 210835585fe..42d7c2e1798 100644 --- a/lisp/textmodes/yaml-ts-mode.el +++ b/lisp/textmodes/yaml-ts-mode.el @@ -148,7 +148,7 @@ boundaries. JUSTIFY is passed to `fill-paragraph'." :syntax-table yaml-ts-mode--syntax-table (when (treesit-ready-p 'yaml) - (treesit-parser-create 'yaml) + (setq treesit-primary-parser (treesit-parser-create 'yaml)) ;; Comments. (setq-local comment-start "# ") diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 3cfd3905701..51b59ca50f4 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -408,7 +408,7 @@ E.g.: (defun thing-at-point-file-at-point (&optional _lax _bounds) "Return the name of the existing file at point." - (when-let ((filename (thing-at-point 'filename))) + (when-let* ((filename (thing-at-point 'filename))) (setq filename (expand-file-name filename)) (and (file-exists-p filename) filename))) @@ -423,7 +423,7 @@ E.g.: (defun thing-at-point-face-at-point (&optional _lax _bounds) "Return the name of the face at point as a symbol." - (when-let ((face (thing-at-point 'symbol))) + (when-let* ((face (thing-at-point 'symbol))) (and (facep face) (intern face)))) (put 'face 'thing-at-point 'thing-at-point-face-at-point) diff --git a/lisp/thread.el b/lisp/thread.el index 4c428f30f71..b1edf3e4678 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -126,7 +126,7 @@ other describing THREAD's blocker, if any." (cond ((not (thread-live-p thread)) '("Finished" "")) ((eq thread (current-thread)) '("Running" "")) - (t (if-let ((blocker (thread--blocker thread))) + (t (if-let* ((blocker (thread--blocker thread))) `("Blocked" ,(prin1-to-string blocker)) '("Yielded" ""))))) diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el index 8c28920d219..a02c1d4532d 100644 --- a/lisp/time-stamp.el +++ b/lisp/time-stamp.el @@ -5,8 +5,8 @@ ;; This file is part of GNU Emacs. -;; Maintainer: Stephen Gildea <stepheng+emacs@gildea.com> -;; Keywords: tools +;; Author: Stephen Gildea <stepheng+emacs@gildea.com> +;; Keywords: files, tools ;; 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 @@ -25,20 +25,19 @@ ;; A template in a file can be updated with a new time stamp when ;; you save the file. For example: -;; static char *ts = "sdmain.c Time-stamp: <2020-04-18 14:10:21 gildea>"; +;; static char *ts = "sdmain.c Time-stamp: <2024-04-18 14:10:21 gildea>"; ;; To use time-stamping, add this line to your init file: ;; (add-hook 'before-save-hook 'time-stamp) ;; Now any time-stamp templates in your files will be updated automatically. -;; See the documentation for the functions `time-stamp' -;; and `time-stamp-toggle-active' for details. +;; See the documentation for the function `time-stamp' for details. ;;; Code: (defgroup time-stamp nil "Maintain last change time stamps in files edited by Emacs." - :group 'data + :group 'files :group 'extensions) @@ -47,34 +46,34 @@ This is a string, used verbatim except for character sequences beginning with %, as follows. -%:A weekday name: `Monday' %#A gives uppercase: `MONDAY' -%3a abbreviated weekday: `Mon' %#a gives uppercase: `MON' -%:B month name: `January' %#B gives uppercase: `JANUARY' -%3b abbreviated month: `Jan' %#b gives uppercase: `JAN' -%02d day of month -%02H 24-hour clock hour -%02I 12-hour clock hour -%02m month number -%02M minute -%#p `am' or `pm' %P gives uppercase: `AM' or `PM' -%02S seconds -%w day number of week, Sunday is 0 -%02y 2-digit year %Y 4-digit year -%Z time zone name: `EST' %#Z gives lowercase: `est' -%5z time zone offset: `-0500' (since Emacs 27; see note below) +%:A weekday name: `Monday' %#A gives uppercase: `MONDAY' +%3a abbreviated weekday: `Mon' %#a gives uppercase: `MON' +%:B month name: `January' %#B gives uppercase: `JANUARY' +%3b abbreviated month: `Jan' %#b gives uppercase: `JAN' +%02d day of month +%02H 24-hour clock hour +%02I 12-hour clock hour +%02m month number +%02M minute +%#p `am' or `pm' %P gives uppercase: `AM' or `PM' +%02S seconds +%w day number of week, Sunday is 0 +%02y 2-digit year %Y 4-digit year +%Z time zone name: `EST' %#Z gives lowercase: `est' +%5z time zone offset: `-0500' (since Emacs 27; see note below) Non-date items: -%% a literal percent character: `%' -%f file name without directory %F absolute file name -%l login name %L full name of logged-in user -%q unqualified host name %Q fully-qualified host name -%h mail host name +%% a literal percent character: `%' +%f file name without directory %F absolute file name +%l login name %L full name of logged-in user +%q unqualified host name %Q fully-qualified host name +%h mail host name Decimal digits between the % and the type character specify the field width. Strings are truncated on the right. A leading zero in the field width zero-fills a number. -For example, to get the format used by the `date' command, +For example, to get a common format used by the `date' command, use \"%3a %3b %2d %02H:%02M:%02S %Z %Y\". The values of non-numeric formatted items depend on the locale @@ -224,7 +223,7 @@ for generating repeated time stamps. These variables are best changed with file-local variables. If you were to change `time-stamp-end' or `time-stamp-inserts-lines' in your init file, you would be incompatible with other people's files.") -;;;###autoload(put 'time-stamp-inserts-lines 'safe-local-variable 'symbolp) +;;;###autoload(put 'time-stamp-inserts-lines 'safe-local-variable 'booleanp) (defvar time-stamp-count 1 ;Do not change! @@ -266,20 +265,22 @@ If you were to change `time-stamp-pattern', `time-stamp-line-limit', `time-stamp-start', or `time-stamp-end' in your init file, you would be incompatible with other people's files. -See also `time-stamp-count' and `time-stamp-inserts-lines'. - Examples: -\"-10/\" (sets only `time-stamp-line-limit') +;; time-stamp-pattern: \"-10/\" + (sets only `time-stamp-line-limit') + +// time-stamp-pattern: \"-9/^Last modified: %%$\" + (sets `time-stamp-line-limit', `time-stamp-start' and `time-stamp-end') -\"-9/^Last modified: %%$\" (sets `time-stamp-line-limit', -`time-stamp-start' and `time-stamp-end') +@c time-stamp-pattern: \"@set Time-stamp: %:B %1d, %Y$\" + (sets `time-stamp-start', `time-stamp-format' and `time-stamp-end') -\"@set Time-stamp: %:B %1d, %Y$\" (sets `time-stamp-start', -`time-stamp-format' and `time-stamp-end') +%% time-stamp-pattern: \"newcommand{\\\\\\\\timestamp}{%%}\" + (sets `time-stamp-start'and `time-stamp-end') -\"newcommand{\\\\\\\\timestamp}{%%}\" (sets `time-stamp-start' -and `time-stamp-end')") + +See also `time-stamp-count' and `time-stamp-inserts-lines'.") ;;;###autoload(put 'time-stamp-pattern 'safe-local-variable 'stringp) @@ -287,8 +288,8 @@ and `time-stamp-end')") ;;;###autoload (defun time-stamp () "Update any time stamp string(s) in the buffer. -This function looks for a time stamp template and updates it with -the current date, time, and/or other info. +Look for a time stamp template and update it with the current date, +time, and/or other info. The template, which you manually create on one of the first 8 lines of the file before running this function, by default can look like @@ -297,7 +298,7 @@ one of the following (your choice): Time-stamp: \" \" This function writes the current time between the brackets or quotes, by default formatted like this: - Time-stamp: <2020-08-07 17:10:21 gildea> + Time-stamp: <2024-08-07 17:10:21 gildea> Although you can run this function manually to update a time stamp once, usually you want automatic time stamp updating. @@ -311,7 +312,7 @@ To enable automatic time-stamping for only a specific file, add this line to a local variables list near the end of the file: eval: (add-hook \\='before-save-hook \\='time-stamp nil t) -If the file has no time-stamp template, this function does nothing. +If the file has no time stamp template, this function does nothing. You can set `time-stamp-pattern' in a file's local variables list to customize the information in the time stamp and where it is written. @@ -419,7 +420,7 @@ Returns the end point, which is where `time-stamp' begins the next search." (cond ((not time-stamp-active) (if time-stamp-warn-inactive - ;; don't signal an error in a write-file-hook + ;; don't signal an error in a hook (progn (message "Warning: time-stamp-active is off; did not time-stamp buffer.") (sit-for 1)))) @@ -518,7 +519,8 @@ and all `time-stamp-format' compatibility." (setq cur-char (if (< ind fmt-len) (aref format ind) ?\0)) - (or (eq ?. cur-char) + (or (eq ?. cur-char) (eq ?* cur-char) + (eq ?E cur-char) (eq ?O cur-char) (eq ?, cur-char) (eq ?: cur-char) (eq ?@ cur-char) (eq ?- cur-char) (eq ?+ cur-char) (eq ?_ cur-char) (eq ?\s cur-char) (eq ?# cur-char) (eq ?^ cur-char) @@ -601,12 +603,18 @@ and all `time-stamp-format' compatibility." (time-stamp-do-number cur-char alt-form field-width time)) ((eq cur-char ?M) ;minute, 0-59 (time-stamp-do-number cur-char alt-form field-width time)) - ((eq cur-char ?p) ;am or pm + ((eq cur-char ?p) ;AM or PM (if change-case - (time-stamp--format "%#p" time) - (time-stamp--format "%p" time))) + (time-stamp--format "%#p" time) + (if upcase + (time-stamp--format "%^p" time) + (time-stamp--format "%p" time)))) ((eq cur-char ?P) ;AM or PM - (time-stamp--format "%p" time)) + (if change-case + (time-stamp--format "%#p" time) + (if upcase + "" ;discourage inconsistent "%^P" + (time-stamp--format "%p" time)))) ((eq cur-char ?S) ;seconds, 00-60 (time-stamp-do-number cur-char alt-form field-width time)) ((eq cur-char ?w) ;weekday number, Sunday is 0 @@ -801,6 +809,8 @@ Suggests replacing OLD-FORM with NEW-FORM." ;; - The %_z format always outputs seconds, allowing all added padding ;; to be spaces. Without this rule, there would be no way to ;; request seconds that worked for both 2- and 3-digit hours. +;; (We consider 3-digit hours not because such offsets are in use but +;; instead to guide our design toward consistency and extensibility.) ;; - Conflicting options are rejected, lest users depend ;; on incidental behavior. ;; @@ -843,7 +853,7 @@ Suggests replacing OLD-FORM with NEW-FORM." colon-count field-width offset-secs) - "Formats a time offset according to a %z variation. + "Format a time offset according to a %z variation. With no flags, the output includes hours and minutes: +-HHMM unless there is a non-zero seconds part, in which case the seconds diff --git a/lisp/time.el b/lisp/time.el index b6f8de8fc4a..3bb34657e07 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -239,8 +239,8 @@ would give mode line times like `94/12/30 21:07:48 (UTC)'." (timer display-time-timer) ;; Compute the time when this timer will run again, next. (next-time (timer-relative-time - (list (aref timer 1) (aref timer 2) (aref timer 3)) - (* 5 (aref timer 4)) 0))) + (timer--time timer) + (* 5 (timer--repeat-delay timer)) 0))) ;; If the activation time is not in the future, ;; skip executions until we reach a time in the future. ;; This avoids a long pause if Emacs has been suspended for hours. @@ -452,7 +452,7 @@ runs the normal hook `display-time-hook' after each update." ("America/New_York" "New York") ("Europe/London" "London") ("Europe/Paris" "Paris") - ("Asia/Calcutta" "Bangalore") + ("Asia/Kolkata" "Bangalore") ("Asia/Tokyo" "Tokyo")) "Alist of zoneinfo-style time zones and places for `world-clock'. Each element has the form (TIMEZONE LABEL). @@ -548,7 +548,7 @@ If the value is t instead of an alist, use the value of (defun world-clock-copy-time-as-kill () "Copy current line into the kill ring." (interactive nil world-clock-mode) - (when-let ((str (buffer-substring-no-properties (pos-bol) (pos-eol)))) + (when-let* ((str (buffer-substring-no-properties (pos-bol) (pos-eol)))) (kill-new str) (message str))) @@ -598,7 +598,7 @@ See `world-clock'." The variable `world-clock-list' specifies which time zones to use. To turn off the world time display, go to the window and type \\[quit-window]." (interactive) - (if-let ((buffer (get-buffer world-clock-buffer-name))) + (if-let* ((buffer (get-buffer world-clock-buffer-name))) (pop-to-buffer buffer) (pop-to-buffer world-clock-buffer-name) (when world-clock-timer-enable diff --git a/lisp/tmm.el b/lisp/tmm.el index f52afb7e162..632e55e47a8 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -82,14 +82,12 @@ or else the correct item might not be found in the `*Completions*' buffer." :type '(choice (const :tag "No shortcuts" nil) string)) -(defvar tmm-mb-map nil - "A place to store minibuffer map.") - (defcustom tmm-completion-prompt - "Press PageUp key to reach this buffer from the minibuffer. -Alternatively, you can use Up/Down keys (or your History keys) to change -the item in the minibuffer, and press RET when you are done, or press the -marked letters to pick up your choice. Type C-g or ESC ESC ESC to cancel. + "Press M-v/PageUp key to reach this buffer from the minibuffer. +Alternatively, You can use Up/Down keys (or your History keys) to change +the item in the minibuffer, and press RET when you are done, or press +the %s to pick up your choice. +Type ^ to go to the parent menu. Type C-g or ESC ESC ESC to cancel. " "Help text to insert on the top of the completion buffer. To save space, you can set this to nil, @@ -110,6 +108,13 @@ If you use only one of `downcase' or `upcase' for `tmm-shortcut-style', specify nil for this variable." :type '(choice integer (const nil))) +(defcustom tmm-shortcut-inside-entry nil + "Highlight the shortcut character in the menu entry's string. +When non-nil, the first menu-entry's character that acts as a shortcut +is displayed with the `highlight' face to help identify it. The +`tmm-mid-prompt' string is not used then." + :type 'boolean) + (defface tmm-inactive '((t :inherit shadow)) "Face used for inactive menu items.") @@ -123,7 +128,7 @@ specify nil for this variable." (defvar tmm--history nil) ;;;###autoload -(defun tmm-prompt (menu &optional in-popup default-item no-execute) +(defun tmm-prompt (menu &optional in-popup default-item no-execute path) "Text-mode emulation of calling the bindings in keymap. Creates a text-mode menu of possible choices. You can access the elements in the menu in two ways: @@ -136,7 +141,9 @@ keymap or an alist of alists. DEFAULT-ITEM, if non-nil, specifies an initial default choice. Its value should be an event that has a binding in MENU. NO-EXECUTE, if non-nil, means to return the command the user selects -instead of executing it." +instead of executing it. +PATH is a stack that keeps track of your path through sub-menus. It +is used to go back through those sub-menus." ;; If the optional argument IN-POPUP is t, ;; then MENU is an alist of elements of the form (STRING . VALUE). ;; That is used for recursive calls only. @@ -198,7 +205,8 @@ instead of executing it." (setq tail (cdr tail))))) (let ((prompt (concat "^" - (if (stringp tmm-mid-prompt) + (if (and (stringp tmm-mid-prompt) + (not tmm-shortcut-inside-entry)) (concat "." (regexp-quote tmm-mid-prompt)))))) (setq tmm--history @@ -227,22 +235,28 @@ instead of executing it." " (up/down to change, PgUp to menu): ") (tmm--completion-table tmm-km-list) nil t nil 'tmm--history (reverse tmm--history))))))) - (setq choice (cdr (assoc out tmm-km-list))) - (and (null choice) - (string-prefix-p tmm-c-prompt out) - (setq out (substring out (length tmm-c-prompt)) - choice (cdr (assoc out tmm-km-list)))) - (and (null choice) out - (setq out (try-completion out tmm-km-list) - choice (cdr (assoc out tmm-km-list))))) + (if (and (stringp out) (string= "^" out)) + ;; A fake choice to please the destructuring later. + (setq choice (cons out out)) + (setq choice (cdr (assoc out tmm-km-list))) + (and (null choice) + (string-prefix-p tmm-c-prompt out) + (setq out (substring out (length tmm-c-prompt)) + choice (cdr (assoc out tmm-km-list)))) + (and (null choice) out + (setq out (try-completion out tmm-km-list) + choice (cdr (assoc out tmm-km-list)))))) ;; CHOICE is now (STRING . MEANING). Separate the two parts. (setq chosen-string (car choice)) (setq choice (cdr choice)) - (cond (in-popup + (cond ((and (stringp choice) (string= "^" choice)) + ;; User wants to go up: do it first. + (if path (tmm-prompt (pop path) in-popup nil nil path))) + (in-popup ;; We just did the inner level of a -popup menu. choice) ;; We just did the outer level. Do the inner level now. - (not-menu (tmm-prompt choice t nil no-execute)) + (not-menu (tmm-prompt choice t nil no-execute (cons menu path))) ;; We just handled a menu keymap and found another keymap. ((keymapp choice) (if (symbolp choice) @@ -250,7 +264,7 @@ instead of executing it." (condition-case nil (require 'mouse) (error nil)) - (tmm-prompt choice nil nil no-execute)) + (tmm-prompt choice nil nil no-execute (cons menu path))) ;; We just handled a menu keymap and found a command. (choice (if chosen-string @@ -277,7 +291,7 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (t (let* ((str (car elt)) (paren (string-search "(" str)) - (pos 0) (word 0) char) + (word 0) pos char) (catch 'done ; ??? is this slow? (while (and (or (not tmm-shortcut-words) ; no limit on words (< word tmm-shortcut-words)) ; try n words @@ -293,17 +307,40 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (if (not (memq char tmm-short-cuts)) (throw 'done char)))) (setq word (1+ word)) (setq pos (match-end 0))) + ;; A nil value for pos means that the shortcut is not inside the + ;; string of the menu entry. + (setq pos nil) (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit (setq char tmm-next-shortcut-digit) (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit)) (if (not (memq char tmm-short-cuts)) (throw 'done char))) (setq char nil)) (if char (setq tmm-short-cuts (cons char tmm-short-cuts))) - (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt) - ;; keep them lined up in columns - (make-string (1+ (length tmm-mid-prompt)) ?\s)) - str) - (cdr elt)))))) + (cons + (if tmm-shortcut-inside-entry + (if char + (if pos + ;; A character inside the menu entry. + (let ((res (copy-sequence str))) + (aset res pos char) + (add-text-properties pos (1+ pos) '(face highlight) res) + res) + ;; A fallback digit character: place it in front of the + ;; menu entry. + (concat (propertize (char-to-string char) 'face 'highlight) + " " str)) + (make-string 2 ?\s)) + (concat (if char (concat (char-to-string char) tmm-mid-prompt) + ;; Keep them lined up in columns. + (make-string (1+ (length tmm-mid-prompt)) ?\s)) + str)) + (cdr elt)))))) + +(defun tmm-clear-self-insert-and-exit () + "Clear the minibuffer contents then self insert and exit." + (interactive) + (delete-minibuffer-contents) + (self-insert-and-exit)) ;; This returns the old map. (defun tmm-define-keys (minibuffer) @@ -316,13 +353,14 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." ;; downcase input to the same (define-key map (char-to-string (downcase c)) 'tmm-shortcut) (define-key map (char-to-string (upcase c)) 'tmm-shortcut))) - (if minibuffer - (progn - (define-key map [pageup] 'tmm-goto-completions) - (define-key map [prior] 'tmm-goto-completions) - (define-key map "\ev" 'tmm-goto-completions) - (define-key map "\C-n" 'next-history-element) - (define-key map "\C-p" 'previous-history-element))) + (when minibuffer + (define-key map [pageup] 'tmm-goto-completions) + (define-key map [prior] 'tmm-goto-completions) + (define-key map "\ev" 'tmm-goto-completions) + (define-key map "\C-n" 'next-history-element) + (define-key map "\C-p" 'previous-history-element) + ;; Previous menu shortcut (see `tmm-prompt'). + (define-key map "^" 'tmm-clear-self-insert-and-exit)) (prog1 (current-local-map) (use-local-map (append map (current-local-map)))))) @@ -377,7 +415,12 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (let ((inhibit-read-only t) (window (get-buffer-window "*Completions*"))) (goto-char (point-min)) - (insert tmm-completion-prompt) + (insert + (if tmm-shortcut-inside-entry + (format tmm-completion-prompt + (concat (propertize "highlighted" 'face 'highlight) " character")) + (format tmm-completion-prompt + (concat "character right before '" tmm-mid-prompt "' ")))) (when window ;; Try to show everything just inserted and preserve height of ;; *Completions* window. This should fix a behavior described @@ -399,23 +442,26 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." (choose-completion)) ;; In minibuffer (delete-region (minibuffer-prompt-end) (point-max)) - (dolist (elt tmm-km-list) - (if (string= - (substring (car elt) 0 - (min (1+ (length tmm-mid-prompt)) - (length (car elt)))) - (concat (char-to-string c) tmm-mid-prompt)) - (setq s (car elt)))) + (dolist (elt tmm-km-list) + (let ((str (car elt)) + (index 0)) + (when tmm-shortcut-inside-entry + (if (get-char-property 0 'face str) + (setq index 0) + (let ((next (next-single-char-property-change 0 'face str))) + (setq index (if (= (length str) next) 0 next))))) + (if (= (aref str index) c) + (setq s str)))) (insert s) (exit-minibuffer))))) (defun tmm-goto-completions () "Jump to the completions buffer." (interactive) - (let ((prompt-end (minibuffer-prompt-end))) - (setq tmm-c-prompt (buffer-substring prompt-end (point-max))) - ;; FIXME: Why? - (delete-region prompt-end (point-max))) + (setq tmm-c-prompt (buffer-substring (minibuffer-prompt-end) (point-max))) + ;; Clear minibuffer old contents before using *Completions* buffer for + ;; selection. + (delete-minibuffer-contents) (switch-to-buffer-other-window "*Completions*") (search-forward tmm-c-prompt) (search-backward tmm-c-prompt)) @@ -477,13 +523,20 @@ It uses the free variable `tmm-table-undef' to keep undefined keys." (when binding (setq binding (key-description binding)) ;; Try to align the keybindings. - (let ((colwidth (min 30 (- (/ (window-width) 2) 10)))) + (let* ((window (get-buffer-window "*Completions*")) + (colwidth (min 30 (- (/ (if window + (window-width window) + (frame-width)) + 2) + 10))) + (nspaces (max 2 (- colwidth + (string-width str) + (string-width binding))))) (setq str (concat str - (make-string (max 2 (- colwidth - (string-width str) - (string-width binding))) - ?\s) + (propertize (make-string nspaces ?\s) + 'display + (cons 'space (list :width nspaces))) binding))))))) (and km (stringp km) (setq str km)) ;; Verify that the command is enabled; diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el index a52d0367258..677360b2ed4 100644 --- a/lisp/touch-screen.el +++ b/lisp/touch-screen.el @@ -33,13 +33,35 @@ (defvar touch-screen-current-tool nil "The touch point currently being tracked, or nil. -If non-nil, this is a list of ten elements: the ID of the touch -point being tracked, the window where the touch began, a cons -holding the last registered position of the touch point, relative -to that window, a field used to store data while tracking the -touch point, the initial position of the touchpoint, another four -fields to used store data while tracking the touch point, and the -last known position of the touch point. +If non-nil, this is a list of ten elements, which might be +accessed as follows: + + (nth 0 touch-screen-current-tool) + The ID of the touch point being tracked. + + (nth 1 touch-screen-current-tool) + The window where the touch sequence being monitored commenced. + + (nth 2 touch-screen-current-tool) + A cons holding the last registered position of the touch + point, relative to that window. + + (nth 3 touch-screen-current-tool) + A field holding a symbol identifying the gesture being + observed while tracking the said touch point. + + (nth 4 touch-screen-current-tool) + The initial position of the touchpoint. + + (nth 5 touch-screen-current-tool) + (nth 6 touch-screen-current-tool) + (nth 7 touch-screen-current-tool) + (nth 8 touch-screen-current-tool) + A further four fields to used store data while tracking the + touch point. + + (nth 9 touch-screen-current-tool) + The last known position of the touch point. See `touch-screen-handle-point-update' and `touch-screen-handle-point-up' for the meanings of the fourth @@ -157,13 +179,22 @@ dragging.") ;; Should this variable be documented? (defvar-local touch-screen-keyboard-function nil "Function that decides whether to display the on screen keyboard. -If set, this function is called with point set to the position of the -tap involved when a command listed in `touch-screen-set-point-commands' -is about to be invoked in response to a tap, the current buffer, or the -text beneath point (in the case of an `inhibit-read-only' text -property), is not read only, and `touch-screen-display-keyboard' is nil, -and should return non-nil if it is appropriate to display the on-screen -keyboard afterwards.") +If set, this function is called with point set to the position +of the tap involved when a command listed in +`touch-screen-set-point-commands' is about to be invoked in +response to a tap, the current buffer, or the text beneath +point (in the case of an `inhibit-read-only' text property), is +not read only, and `touch-screen-display-keyboard' is nil, and +should return non-nil if it is appropriate to display the +on-screen keyboard afterwards.") + +(defvar touch-screen-simple-mouse-conversion nil + "Whether to unconditionally enable simple mouse event translation. +If non-nil, touch screen event conversion will always proceed as +though a command was bound to `down-mouse-1' at the position of +the initial tap. That is to say, taps, mouse motion, and +touchpoint removals will be unconditionally converted into +mouse-down, mouse motion, mouse drag, and mouse button events.") @@ -1018,6 +1049,8 @@ When ARG is t, set the fourth element of (let ((posn (nth 4 touch-screen-current-tool))) (throw 'input-event (list 'touchscreen-hold posn)))))) +(declare-function remember-mouse-glyph "xdisp.c") + (defun touch-screen-handle-point-update (point) "Notice that the touch point POINT has changed position. Perform the editing operations or throw to the input translation @@ -1068,8 +1101,7 @@ then move point to the position of POINT." (what (nth 3 touch-screen-current-tool)) (posn (cdr point)) ;; Now get the position of X and Y relative to WINDOW. - (relative-xy - (touch-screen-relative-xy posn window))) + (relative-xy (touch-screen-relative-xy posn window))) ;; Update the 10th field of the tool list with RELATIVE-XY. (setcar (nthcdr 9 touch-screen-current-tool) relative-xy) (cond ((or (null what) @@ -1119,8 +1151,43 @@ then move point to the position of POINT." ;; point of the event. Generate a mouse-motion event if ;; mouse movement is being tracked. (when track-mouse - (throw 'input-event (list 'mouse-movement - (cdr point))))) + (let ((mouse-rect (nth 5 touch-screen-current-tool)) + (edges (window-inside-pixel-edges window))) + ;; If fine-grained tracking is enabled, disregard the + ;; mouse rect. Apply the same criteria as + ;; `remember_mouse_glyph', which see. + (if (or mouse-fine-grained-tracking + window-resize-pixelwise) + (throw 'input-event (list 'mouse-movement posn)) + ;; Otherwise, generate an event only if POINT falls + ;; outside the extents of the mouse rect, and record + ;; the extents of the glyph beneath point as the next + ;; mouse rect. + (let ((point relative-xy) + (frame-offsets (if (framep window) + '(0 . 0) + (cons (car edges) (cadr edges))))) + (when (or (not mouse-rect) + (< (car point) (- (car mouse-rect) + (car frame-offsets))) + (> (car point) (+ (- (car mouse-rect) 1 + (car frame-offsets)) + (caddr mouse-rect))) + (< (cdr point) (- (cadr mouse-rect) + (cdr frame-offsets))) + (> (cdr point) (+ (- (cadr mouse-rect) 1 + (cdr frame-offsets)) + (cadddr mouse-rect)))) + ;; Record the extents of this glyph. + (setcar (nthcdr 5 touch-screen-current-tool) + (remember-mouse-glyph (or (and (framep window) window) + (window-frame window)) + (+ (car point) + (car frame-offsets)) + (+ (cdr point) + (cdr frame-offsets)))) + ;; Generate the movement. + (throw 'input-event (list 'mouse-movement posn)))))))) ((eq what 'held) (let* ((posn (cdr point))) ;; Now start dragging. @@ -1418,36 +1485,27 @@ is not read-only." (new-point (posn-point posn)) (old-posn (nth 4 touch-screen-current-tool)) (old-window (posn-window posn)) - (old-point (posn-point posn))) + (old-point (posn-point posn)) + (new-relative-xy (touch-screen-relative-xy + posn new-window)) + (old-relative-xy (touch-screen-relative-xy + old-posn new-window))) (throw 'input-event - ;; If the position of the touch point hasn't - ;; changed, or it doesn't start or end on a - ;; window... - (if (and (not old-point) (not new-point)) - ;; Should old-point and new-point both equal - ;; nil, compare the posn areas and nominal - ;; column position. If either are - ;; different, generate a drag event. - (let ((new-col-row (posn-col-row posn)) - (new-area (posn-area posn)) - (old-col-row (posn-col-row old-posn)) - (old-area (posn-area old-posn))) - (if (and (equal new-col-row old-col-row) - (eq new-area old-area)) - ;; ... generate a mouse-1 event... - (list 'mouse-1 posn) - ;; ... otherwise, generate a - ;; drag-mouse-1 event. - (list 'drag-mouse-1 old-posn posn))) - (if (and (eq new-window old-window) - (eq new-point old-point) - (windowp new-window) - (windowp old-window)) - ;; ... generate a mouse-1 event... - (list 'mouse-1 posn) - ;; ... otherwise, generate a drag-mouse-1 - ;; event. - (list 'drag-mouse-1 old-posn posn))))))) + ;; If the position of the touch point has + ;; changed, or it has moved significantly, as + ;; measured by reference to double-click-fuzz... + (if (or (let ((xdiff (- (car new-relative-xy) + (car old-relative-xy))) + (ydiff (- (cdr new-relative-xy) + (cdr old-relative-xy)))) + (and (>= (abs xdiff) double-click-fuzz) + (>= (abs ydiff) double-click-fuzz))) + (not (eq old-window new-window)) + (not (eq old-point new-point))) + ;; ... generate a drag-mouse-1 event... + (list 'drag-mouse-1 old-posn posn) + ;; ... otherwise, generate a mouse-1 event. + (list 'mouse-1 posn)))))) ((eq what 'mouse-1-menu) ;; Generate a `down-mouse-1' event at the position the tap ;; took place, unless the touch sequence was canceled. @@ -1633,29 +1691,35 @@ functions undertaking event management themselves to call ;; Generate the `restart-drag' event. (throw 'input-event (list 'touchscreen-restart-drag position)))) - ;; Determine if there is a command bound to `down-mouse-1' - ;; at the position of the tap and that command is not a - ;; command whose functionality is replaced by the - ;; long-press mechanism. If so, set the fourth element of - ;; `touch-screen-current-tool' to `mouse-drag' and - ;; generate an emulated `mouse-1' event. + ;; Determine whether there is a command bound to + ;; `down-mouse-1' at the position of the tap and that + ;; command is not a command whose functionality is replaced + ;; by the long-press mechanism. If so, set the fourth + ;; element of `touch-screen-current-tool' to `mouse-drag' + ;; and generate an emulated `mouse-1' event. Likewise if + ;; touch event translation is being invoked by a caller of + ;; `read-key' that expects unprocessed mouse input, ;; - ;; If the command in question is a keymap, set that - ;; element to `mouse-1-menu' instead of `mouse-drag', and - ;; don't generate a `down-mouse-1' event immediately. - ;; Instead, wait for the touch point to be released. + ;; If the command in question is a keymap, set that element + ;; to `mouse-1-menu' instead of `mouse-drag', and don't + ;; generate a `down-mouse-1' event immediately, but wait for + ;; the touch point to be released, so that the menu bar may + ;; not be displayed before the user has released the touch + ;; point and the window system is ready to display a menu. (if (and tool-list - (and (setq binding - (key-binding (if prefix - (vector prefix - 'down-mouse-1) - [down-mouse-1]) - t nil position)) - (not (and (symbolp binding) - (get binding 'ignored-mouse-command))))) - (if (or (keymapp binding) - (and (symbolp binding) - (get binding 'mouse-1-menu-command))) + (or (and (setq binding + (key-binding (if prefix + (vector prefix + 'down-mouse-1) + [down-mouse-1]) + t nil position)) + (not (and (symbolp binding) + (get binding 'ignored-mouse-command)))) + touch-screen-simple-mouse-conversion)) + (if (and (not touch-screen-simple-mouse-conversion) + (or (keymapp binding) + (and (symbolp binding) + (get binding 'mouse-1-menu-command)))) ;; binding is a keymap, or a command that does ;; almost the same thing. If a `mouse-1' event is ;; generated after the keyboard command loop @@ -1664,8 +1728,26 @@ functions undertaking event management themselves to call ;; `mouse-1-menu' instead and wait for the up ;; event to display the menu. (setcar (nthcdr 3 tool-list) 'mouse-1-menu) - (progn (setcar (nthcdr 3 tool-list) 'mouse-drag) - (throw 'input-event (list 'down-mouse-1 position)))) + (progn + (setcar (nthcdr 3 tool-list) 'mouse-drag) + ;; Record the extents of the glyph beneath this + ;; touch point to avoid generating extraneous events + ;; when it next moves. + (setcar + (nthcdr 5 touch-screen-current-tool) + (let* ((edges (window-inside-pixel-edges window)) + (point (posn-x-y position)) + (frame-offsets (if (framep window) + '(0 . 0) + (cons (car edges) + (cadr edges))))) + (remember-mouse-glyph (or (and (framep window) window) + (window-frame window)) + (+ (car point) + (car frame-offsets)) + (+ (cdr point) + (cdr frame-offsets))))) + (throw 'input-event (list 'down-mouse-1 position)))) (and point ;; Start the long-press timer. (touch-screen-handle-timeout nil))))))) @@ -1677,8 +1759,8 @@ functions undertaking event management themselves to call ;; The positions of tools currently pressed against the screen ;; have changed. If there is a tool being tracked as part of a ;; gesture, look it up in the list of tools. - (if-let ((new-point (assq (car touch-screen-current-tool) - (cadr event)))) + (if-let* ((new-point (assq (car touch-screen-current-tool) + (cadr event)))) (if touch-screen-aux-tool (touch-screen-handle-aux-point-update (cdr new-point) (car new-point)) diff --git a/lisp/transient.el b/lisp/transient.el index a64a4bc6ef4..0f53fee3c0e 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -5,7 +5,7 @@ ;; Author: Jonas Bernoulli <jonas@bernoul.li> ;; URL: https://github.com/magit/transient ;; Keywords: extensions -;; Version: 0.7.2.2 +;; Version: 0.7.4 ;; SPDX-License-Identifier: GPL-3.0-or-later @@ -38,41 +38,8 @@ (require 'eieio) (require 'edmacro) (require 'format-spec) - -(eval-and-compile - (when (and (featurep 'seq) - (not (fboundp 'seq-keep))) - (unload-feature 'seq 'force))) (require 'seq) -(unless (fboundp 'seq-keep) - (display-warning 'transient (substitute-command-keys "\ -Transient requires `seq' >= 2.24, -but due to bad defaults, Emacs's package manager, refuses to -upgrade this and other built-in packages to higher releases -from GNU Elpa, when a package specifies that this is needed. - -To fix this, you have to add this to your init file: - - (setq package-install-upgrade-built-in t) - -Then evaluate that expression by placing the cursor after it -and typing \\[eval-last-sexp]. - -Once you have done that, you have to explicitly upgrade `seq': - - \\[package-upgrade] seq \\`RET' - -Then you also must make sure the updated version is loaded, -by evaluating this form: - - (progn (unload-feature 'seq t) (require 'seq)) - -Until you do this, you will get random errors about `seq-keep' -being undefined while using Transient. - -If you don't use the `package' package manager but still get -this warning, then your chosen package manager likely has a -similar defect.") :emergency)) +(require 'pp) (eval-when-compile (require 'subr-x)) @@ -82,7 +49,6 @@ similar defect.") :emergency)) (declare-function Man-getpage-in-background "man" (topic)) (defvar Man-notify-method) -(defvar pp-default-function) ; since Emacs 29.1 (defmacro transient--with-emergency-exit (id &rest body) (declare (indent defun)) @@ -1094,7 +1060,7 @@ commands are aliases for." (when (eq (car-safe (car args)) 'declare) (setq declare (car args)) (setq args (cdr args)) - (when-let ((int (assq 'interactive-only declare))) + (when-let* ((int (assq 'interactive-only declare))) (setq interactive-only (cadr int)) (delq int declare)) (unless (cdr declare) @@ -1218,7 +1184,7 @@ commands are aliases for." (setq args (plist-put args :argument (cadr arg))) (setq arg (cadr arg))) (string - (when-let ((shortarg (transient--derive-shortarg arg))) + (when-let* ((shortarg (transient--derive-shortarg arg))) (setq args (plist-put args :shortarg shortarg))) (setq args (plist-put args :argument arg)))) (setq sym (intern (format "transient:%s:%s" prefix arg))) @@ -1255,7 +1221,7 @@ commands are aliases for." (setq args (plist-put args key (macroexp-quote val)))) ((setq args (plist-put args key val))))))) (unless (plist-get args :key) - (when-let ((shortarg (plist-get args :shortarg))) + (when-let* ((shortarg (plist-get args :shortarg))) (setq args (plist-put args :key shortarg)))) (list 'list (or level transient--default-child-level) @@ -1405,7 +1371,7 @@ LOC is a command, a key vector, a key description (a string as returned by `key-description'), or a coordination list (whose last element may also be a command or key). See info node `(transient)Modifying Existing Transients'." - (if-let ((mem (transient--layout-member loc prefix))) + (if-let* ((mem (transient--layout-member loc prefix))) (car mem) (error "%s not found in %s" loc prefix))) @@ -1590,6 +1556,31 @@ This is bound while the suffixes are drawn in the transient buffer.") ;;; Identities +(defun transient-active-prefix (&optional prefixes) + "Return the active transient object. + +Return nil if there is no active transient, if the transient buffer +isn't shown, and while the active transient is suspended (e.g., while +the minibuffer is in use). + +Unlike `transient-current-prefix', which is only ever non-nil in code +that is run directly by a command that is invoked while a transient +is current, this function is also suitable for use in asynchronous +code, such as timers and callbacks (this function's main use-case). + +If optional PREFIXES is non-nil, it must be a list of prefix command +symbols, in which case the active transient object is only returned +if it matches one of the PREFIXES." + (and transient--showp + transient--prefix + (or (not prefixes) + (memq (oref transient--prefix command) prefixes)) + (or (memq 'transient--pre-command pre-command-hook) + (and (memq t pre-command-hook) + (memq 'transient--pre-command + (default-value 'pre-command-hook)))) + transient--prefix)) + (defun transient-prefix-object () "Return the current prefix as an object. @@ -1916,9 +1907,9 @@ of the corresponding object." (error "Cannot bind %S to %s and also %s" (string-trim key) cmd alt)) ((define-key map kbd cmd)))))) - (when-let ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b)) - (when-let ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b)) - (when-let ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b)) + (when-let* ((b (keymap-lookup map "-"))) (keymap-set map "<kp-subtract>" b)) + (when-let* ((b (keymap-lookup map "="))) (keymap-set map "<kp-equal>" b)) + (when-let* ((b (keymap-lookup map "+"))) (keymap-set map "<kp-add>" b)) (when transient-enable-popup-navigation ;; `transient--make-redisplay-map' maps only over bindings that are ;; directly in the base keymap, so that cannot be a composed keymap. @@ -2144,7 +2135,7 @@ value. Otherwise return CHILDREN as is." (apply class :level level args) (unless (and cmd (symbolp cmd)) (error "BUG: Non-symbolic suffix command: %s" cmd)) - (if-let ((proto (and cmd (transient--suffix-prototype cmd)))) + (if-let* ((proto (and cmd (transient--suffix-prototype cmd)))) (apply #'clone proto :level level args) (apply class :command cmd :level level args))))) (cond ((not cmd)) @@ -2175,7 +2166,7 @@ value. Otherwise return CHILDREN as is." (if (transient-switches--eieio-childp obj) (cl-call-next-method obj) (unless (slot-boundp obj 'shortarg) - (when-let ((shortarg (transient--derive-shortarg (oref obj argument)))) + (when-let* ((shortarg (transient--derive-shortarg (oref obj argument)))) (oset obj shortarg shortarg))) (unless (slot-boundp obj 'key) (if (slot-boundp obj 'shortarg) @@ -2376,7 +2367,7 @@ value. Otherwise return CHILDREN as is." ((and transient--prefix transient--redisplay-key) (setq transient--redisplay-key nil) (when transient--showp - (if-let ((win (minibuffer-selected-window))) + (if-let* ((win (minibuffer-selected-window))) (with-selected-window win (transient--show)) (transient--show))))) @@ -2434,72 +2425,35 @@ value. Otherwise return CHILDREN as is." (remove-hook 'minibuffer-exit-hook ,exit))) ,@body))) -(static-if (>= emacs-major-version 30) ;transient--wrap-command - (defun transient--wrap-command () - (cl-assert - (>= emacs-major-version 30) nil - "Emacs was downgraded, making it necessary to recompile Transient") - (letrec - ((prefix transient--prefix) - (suffix this-command) - (advice - (lambda (fn &rest args) - (interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (let ((debugger #'transient--exit-and-debug)) - (advice-eval-interactive-spec spec)) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (unwind-protect - (let ((debugger #'transient--exit-and-debug)) - (apply fn args)) - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (when (symbolp this-command) - (advice-add suffix :around advice '((depth . -99)))))) - - (defun transient--wrap-command () - (let* ((prefix transient--prefix) - (suffix this-command) - (advice nil) - (advice-interactive - (lambda (spec) - (let ((abort t)) - (unwind-protect - (prog1 (let ((debugger #'transient--exit-and-debug)) - (advice-eval-interactive-spec spec)) - (setq abort nil)) - (when abort - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-interactive) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil)))))) - (advice-body - (lambda (fn &rest args) - (unwind-protect - (let ((debugger #'transient--exit-and-debug)) - (apply fn args)) - (when-let ((unwind (oref prefix unwind-suffix))) - (transient--debug 'unwind-command) - (funcall unwind suffix)) - (advice-remove suffix advice) - (oset prefix unwind-suffix nil))))) - (setq advice `(lambda (fn &rest args) - (interactive ,advice-interactive) - (apply ',advice-body fn args))) - (when (symbolp this-command) - (advice-add suffix :around advice '((depth . -99))))))) +(defun transient--wrap-command () + (letrec + ((prefix transient--prefix) + (suffix this-command) + (advice + (lambda (fn &rest args) + (interactive + (lambda (spec) + (let ((abort t)) + (unwind-protect + (prog1 (let ((debugger #'transient--exit-and-debug)) + (advice-eval-interactive-spec spec)) + (setq abort nil)) + (when abort + (when-let* ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-interactive) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil)))))) + (unwind-protect + (let ((debugger #'transient--exit-and-debug)) + (apply fn args)) + (when-let* ((unwind (oref prefix unwind-suffix))) + (transient--debug 'unwind-command) + (funcall unwind suffix)) + (advice-remove suffix advice) + (oset prefix unwind-suffix nil))))) + (when (symbolp this-command) + (advice-add suffix :around advice '((depth . -99)))))) (defun transient--premature-post-command () (and (equal (this-command-keys-vector) []) @@ -2668,7 +2622,7 @@ exit." ;;; Pre-Commands (defun transient--call-pre-command () - (if-let ((fn (transient--get-pre-command this-command))) + (if-let* ((fn (transient--get-pre-command this-command))) (let ((action (funcall fn))) (when (eq action transient--exit) (setq transient--exitp (or transient--exitp t))) @@ -2764,7 +2718,7 @@ If there is no parent prefix, then just call the command." (defun transient--setup-recursion (prefix-obj) (when transient--stack (let ((command (oref prefix-obj command))) - (when-let ((suffix-obj (transient-suffix-object command))) + (when-let* ((suffix-obj (transient-suffix-object command))) (when (memq (if (slot-boundp suffix-obj 'transient) (oref suffix-obj transient) (oref transient-current-prefix transient-suffix)) @@ -2873,8 +2827,8 @@ prefix argument and pivot to `transient-update'." ;; `this-command' is `transient-undefined' or `transient-inapt'. ;; Show the command (`this-original-command') the user actually ;; tried to invoke. - (if-let ((cmd (or (ignore-errors (symbol-name this-original-command)) - (ignore-errors (symbol-name this-command))))) + (if-let* ((cmd (or (ignore-errors (symbol-name this-original-command)) + (ignore-errors (symbol-name this-command))))) (format " [%s]" (propertize cmd 'face 'font-lock-warning-face)) "")) (unless (and transient--transient-map @@ -3171,7 +3125,7 @@ Otherwise call the primary method according to object's class." (if (slot-boundp obj 'value) (oref obj value) (oset obj value - (if-let ((saved (assq (oref obj command) transient-values))) + (if-let* ((saved (assq (oref obj command) transient-values))) (cdr saved) (transient-default-value obj))))) @@ -3207,8 +3161,8 @@ Otherwise call the primary method according to object's class." nil) (cl-defmethod transient-default-value ((obj transient-prefix)) - (if-let ((default (and (slot-boundp obj 'default-value) - (oref obj default-value)))) + (if-let* ((default (and (slot-boundp obj 'default-value) + (oref obj default-value)))) (if (functionp default) (funcall default) default) @@ -3313,7 +3267,7 @@ it\", in which case it is pointless to preserve history.)" The last value is \"don't use any of these switches\"." (let ((choices (mapcar (apply-partially #'format (oref obj argument-format)) (oref obj choices)))) - (if-let ((value (oref obj value))) + (if-let* ((value (oref obj value))) (cadr (member value choices)) (car choices)))) @@ -3321,7 +3275,7 @@ The last value is \"don't use any of these switches\"." "Elsewhere use the reader of the infix command COMMAND. Use this if you want to share an infix's history with a regular stand-alone command." - (if-let ((obj (transient--suffix-prototype command))) + (if-let* ((obj (transient--suffix-prototype command))) (cl-letf (((symbol-function #'transient--show) #'ignore)) (transient-infix-read obj)) (error "Not a suffix command: `%s'" command))) @@ -3397,7 +3351,7 @@ command-line option) or \": \". Finally fall through to using \"(BUG: no prompt): \" as the prompt." - (if-let ((prompt (oref obj prompt))) + (if-let* ((prompt (oref obj prompt))) (let ((prompt (if (functionp prompt) (funcall prompt obj) prompt))) @@ -3690,7 +3644,7 @@ have a history of their own.") (transient--insert-groups) (when (or transient--helpp transient--editp) (transient--insert-help)) - (when-let ((line (transient--separator-line))) + (when-let* ((line (transient--separator-line))) (insert line))) (unless (window-live-p transient--window) (setq transient--window @@ -3751,8 +3705,8 @@ have a history of their own.") (cl-defmethod transient--insert-group :around ((group transient-group)) "Insert GROUP's description, if any." - (when-let ((desc (transient-with-shadowed-buffer - (transient-format-description group)))) + (when-let* ((desc (transient-with-shadowed-buffer + (transient-format-description group)))) (insert desc ?\n)) (let ((transient--max-group-level (max (oref group level) transient--max-group-level)) @@ -3766,68 +3720,39 @@ have a history of their own.") (insert " ")) (insert ?\n)) -(cl-defmethod transient--insert-group ((group transient-column)) +(cl-defmethod transient--insert-group ((group transient-column) + &optional skip-empty) (transient--maybe-pad-keys group) (dolist (suffix (oref group suffixes)) (let ((str (transient-with-shadowed-buffer (transient-format suffix)))) - (insert str) - (unless (string-match-p ".\n\\'" str) - (insert ?\n))))) + (unless (and (not skip-empty) (equal str "")) + (insert str) + (unless (string-match-p ".\n\\'" str) + (insert ?\n)))))) (cl-defmethod transient--insert-group ((group transient-columns)) - (let* ((columns - (mapcar - (lambda (column) - (transient--maybe-pad-keys column group) - (transient-with-shadowed-buffer - (let* ((transient--pending-group column) - (rows (mapcar #'transient-format (oref column suffixes)))) - (if-let ((desc (transient-format-description column))) - (cons desc rows) - rows)))) - (oref group suffixes))) - (vp (or (oref transient--prefix variable-pitch) - transient-align-variable-pitch)) - (rs (apply #'max (mapcar #'length columns))) - (cs (length columns)) - (cw (mapcar (let ((widths (oref transient--prefix column-widths))) - (lambda (col) - (apply - #'max - (if-let ((min (pop widths))) - (if vp (* min (transient--pixel-width " ")) min) - 0) - (mapcar (if vp #'transient--pixel-width #'length) - col)))) - columns)) - (cc (transient--seq-reductions-from - (apply-partially #'+ (* 2 (if vp (transient--pixel-width " ") 1))) - cw 0))) - (if transient-force-single-column - (dotimes (c cs) - (dotimes (r rs) - (when-let ((cell (nth r (nth c columns)))) - (unless (equal cell "") - (insert cell ?\n)))) - (unless (= c (1- cs)) - (insert ?\n))) - (dotimes (r rs) - (dotimes (c cs) - (if vp - (progn - (when-let ((cell (nth r (nth c columns)))) - (insert cell)) - (if (= c (1- cs)) - (insert ?\n) - (insert (propertize " " 'display - `(space :align-to (,(nth (1+ c) cc))))))) - (when (> c 0) - (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)) - (insert ?\n)))))))) + (if transient-force-single-column + (dolist (group (oref group suffixes)) + (transient--insert-group group t)) + (let* ((columns + (mapcar + (lambda (column) + (transient--maybe-pad-keys column group) + (transient-with-shadowed-buffer + `(,@(and-let* ((desc (transient-format-description column))) + (list desc)) + ,@(let ((transient--pending-group column)) + (mapcar #'transient-format (oref column suffixes)))))) + (oref group suffixes))) + (stops (transient--column-stops columns))) + (dolist (row (apply #'transient--mapn #'list columns)) + (let ((stops stops)) + (dolist (cell row) + (let ((stop (pop stops))) + (when cell + (transient--align-to stop) + (insert cell))))) + (insert ?\n))))) (cl-defmethod transient--insert-group ((group transient-subgroups)) (let ((subgroups (oref group suffixes))) @@ -3914,7 +3839,7 @@ as a button." "Format OBJ's `key' for display and return the result." (let ((key (if (slot-boundp obj 'key) (oref obj key) "")) (cmd (and (slot-boundp obj 'command) (oref obj command)))) - (when-let ((width (oref transient--pending-group pad-keys))) + (when-let* ((width (oref transient--pending-group pad-keys))) (setq key (truncate-string-to-width key width nil ?\s))) (if transient--redisplay-key (let ((len (length transient--redisplay-key)) @@ -4005,15 +3930,14 @@ face `transient-heading' to the complete string." (cl-defmethod transient-format-description :around ((obj transient-suffix)) "Format the description by calling the next method. If the result is nil, then use \"(BUG: no description)\" as the -description. -If the OBJ's `key' is currently unreachable, then apply the face -`transient-unreachable' to the complete string." +description. If the OBJ's `key' is currently unreachable, then +apply the face `transient-unreachable' to the complete string." (let ((desc (or (cl-call-next-method obj) (and (slot-boundp transient--prefix 'suffix-description) (funcall (oref transient--prefix suffix-description) obj))))) (if desc - (when-let ((face (transient--get-face obj 'face))) + (when-let* ((face (transient--get-face obj 'face))) (setq desc (transient--add-face desc face t))) (setq desc (propertize "(BUG: no description)" 'face 'error))) (when (if transient--all-levels-p @@ -4022,8 +3946,8 @@ If the OBJ's `key' is currently unreachable, then apply the face (> (max (oref obj level) transient--max-group-level) transient--default-prefix-level))) (setq desc (transient--add-face desc 'transient-higher-level))) - (when-let ((inapt-face (and (oref obj inapt) - (transient--get-face obj 'inapt-face)))) + (when-let* ((inapt-face (and (oref obj inapt) + (transient--get-face obj 'inapt-face)))) (setq desc (transient--add-face desc inapt-face))) (when (and (slot-boundp obj 'key) (transient--key-unreachable-p obj)) @@ -4041,7 +3965,7 @@ If the OBJ's `key' is currently unreachable, then apply the face (cl-defmethod transient-format-value ((obj transient-option)) (let ((argument (oref obj argument))) - (if-let ((value (oref obj value))) + (if-let* ((value (oref obj value))) (pcase-exhaustive (oref obj multi-value) ('nil (concat (propertize argument 'face 'transient-argument) @@ -4123,8 +4047,8 @@ If the OBJ's `key' is currently unreachable, then apply the face (and val (not (integerp val)) val))) (defun transient--maybe-pad-keys (group &optional parent) - (when-let ((pad (or (oref group pad-keys) - (and parent (oref parent pad-keys))))) + (when-let* ((pad (or (oref group pad-keys) + (and parent (oref parent pad-keys))))) (oset group pad-keys (apply #'max (if (integerp pad) pad 0) @@ -4143,6 +4067,28 @@ If the OBJ's `key' is currently unreachable, then apply the face (car (window-text-pixel-size nil (line-beginning-position) (point)))))) +(defun transient--column-stops (columns) + (let* ((var-pitch (or transient-align-variable-pitch + (oref transient--prefix variable-pitch))) + (char-width (and var-pitch (transient--pixel-width " ")))) + (transient--seq-reductions-from + (apply-partially #'+ (* 2 (if var-pitch char-width 1))) + (transient--mapn + (lambda (cells min) + (apply #'max + (if min (if var-pitch (* min char-width) min) 0) + (mapcar (if var-pitch #'transient--pixel-width #'length) cells))) + columns + (oref transient--prefix column-widths)) + 0))) + +(defun transient--align-to (stop) + (unless (zerop stop) + (insert (if (or transient-align-variable-pitch + (oref transient--prefix variable-pitch)) + (propertize " " 'display `(space :align-to (,stop))) + (make-string (max 0 (- stop (current-column))) ?\s))))) + (defun transient-command-summary-or-name (obj) "Return the summary or name of the command represented by OBJ. @@ -4152,7 +4098,7 @@ that, else its name. Intended to be temporarily used as the `:suffix-description' of a prefix command, while porting a regular keymap to a transient." (let ((command (oref obj command))) - (if-let ((doc (documentation command))) + (if-let* ((doc (documentation command))) (propertize (car (split-string doc "\n")) 'face 'font-lock-doc-face) (propertize (symbol-name command) 'face 'font-lock-function-name-face)))) @@ -4183,7 +4129,7 @@ prefix method." 'transient--prefix))) (and prefix (not (eq (oref transient--prefix command) this-command)) (prog1 t (transient-show-help prefix))))) - ((if-let ((show-help (oref obj show-help))) + ((if-let* ((show-help (oref obj show-help))) (funcall show-help obj) (transient--describe-function this-command))))) @@ -4191,11 +4137,11 @@ prefix method." "Call `show-help' if non-nil, else show the `man-page' if non-nil, else use `describe-function'. When showing the manpage, then try to jump to the correct location." - (if-let ((show-help (oref obj show-help))) + (if-let* ((show-help (oref obj show-help))) (funcall show-help obj) - (if-let ((man-page (oref transient--prefix man-page)) - (argument (and (slot-boundp obj 'argument) - (oref obj argument)))) + (if-let* ((man-page (oref transient--prefix man-page)) + (argument (and (slot-boundp obj 'argument) + (oref obj argument)))) (transient--show-manpage man-page argument) (transient--describe-function this-command)))) @@ -4497,6 +4443,17 @@ we stop there." (push (funcall function (car acc) elt) acc)) (nreverse acc))) +(defun transient--mapn (function &rest lists) + "Apply FUNCTION to elements of LISTS. +Like `cl-mapcar' but while that stops when the shortest list +is exhausted, continue until the longest list is, using nil +as stand-in for elements of exhausted lists." + (let (result) + (while (catch 'more (mapc (lambda (l) (and l (throw 'more t))) lists) nil) + (push (apply function (mapcar #'car-safe lists)) result) + (setq lists (mapcar #'cdr lists))) + (nreverse result))) + ;;; Font-Lock (defconst transient-font-lock-keywords diff --git a/lisp/treesit.el b/lisp/treesit.el index 2518204ce93..db3a706f016 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -123,17 +123,6 @@ of max unsigned 32-bit value for byte offsets into buffer text." ;;; Parser API supplement -(defun treesit-parse-string (string language) - "Parse STRING using a parser for LANGUAGE. -Return the root node of the syntax tree." - ;; We can't use `with-temp-buffer' because it kills the buffer when - ;; returning from the form. - (let ((buf (generate-new-buffer " *treesit-parse-string*"))) - (with-current-buffer buf - (insert string) - (treesit-parser-root-node - (treesit-parser-create language))))) - (defvar-local treesit-language-at-point-function nil "A function that returns the language at point. This is used by `treesit-language-at', which is used by various @@ -161,7 +150,7 @@ In a multi-language buffer, make sure `treesit-language-at' wouldn't return the correct result." (if treesit-language-at-point-function (funcall treesit-language-at-point-function position) - (when-let ((parser (car (treesit-parser-list)))) + (when-let* ((parser (car (treesit-parser-list)))) (treesit-parser-language parser)))) ;;; Node API supplement @@ -209,9 +198,9 @@ unless PARSER-OR-LANG is a parser, or PARSER-OR-LANG is a language and doesn't match the language of the local parser." (let* ((root (if (treesit-parser-p parser-or-lang) (treesit-parser-root-node parser-or-lang) - (or (when-let ((parser - (car (treesit-local-parsers-at - pos parser-or-lang)))) + (or (when-let* ((parser + (car (treesit-local-parsers-at + pos parser-or-lang)))) (treesit-parser-root-node parser)) (treesit-buffer-root-node (or parser-or-lang @@ -267,10 +256,10 @@ parser first." (let* ((lang-at-point (treesit-language-at beg)) (root (if (treesit-parser-p parser-or-lang) (treesit-parser-root-node parser-or-lang) - (or (when-let ((parser - (car (treesit-local-parsers-on - beg end (or parser-or-lang - lang-at-point))))) + (or (when-let* ((parser + (car (treesit-local-parsers-on + beg end (or parser-or-lang + lang-at-point))))) (treesit-parser-root-node parser)) (treesit-buffer-root-node (or parser-or-lang lang-at-point)))))) @@ -305,11 +294,11 @@ Use the first parser in the parser list if LANGUAGE is omitted. If LANGUAGE is non-nil, use the first parser for LANGUAGE with TAG in the parser list, or create one if none exists. TAG defaults to nil." - (if-let ((parser - (if language - (treesit-parser-create language nil nil tag) - (or (car (treesit-parser-list)) - (signal 'treesit-no-parser (list (current-buffer))))))) + (if-let* ((parser + (if language + (treesit-parser-create language nil nil tag) + (or (car (treesit-parser-list)) + (signal 'treesit-no-parser (list (current-buffer))))))) (treesit-parser-root-node parser))) (defun treesit-filter-child (node pred &optional named) @@ -393,8 +382,8 @@ If NAMED is non-nil, count named child only." (defun treesit-node-field-name (node) "Return the field name of NODE as a child of its parent." - (when-let ((parent (treesit-node-parent node)) - (idx (treesit-node-index node))) + (when-let* ((parent (treesit-node-parent node)) + (idx (treesit-node-index node))) (treesit-node-field-name-for-child parent idx))) (defun treesit-node-get (node instructions) @@ -689,8 +678,8 @@ instead. HOST-PARSER is the host parser which created the local PARSER." (let ((res nil)) (dolist (ov (overlays-at (or pos (point)))) - (when-let ((parser (overlay-get ov 'treesit-parser)) - (host-parser (overlay-get ov 'treesit-host-parser))) + (when-let* ((parser (overlay-get ov 'treesit-parser)) + (host-parser (overlay-get ov 'treesit-host-parser))) (when (or (null language) (eq (treesit-parser-language parser) language)) @@ -711,8 +700,8 @@ instead. HOST-PARSER is the host parser which created the local PARSER." (let ((res nil)) (dolist (ov (overlays-in (or beg (point-min)) (or end (point-max)))) - (when-let ((parser (overlay-get ov 'treesit-parser)) - (host-parser (overlay-get ov 'treesit-host-parser))) + (when-let* ((parser (overlay-get ov 'treesit-parser)) + (host-parser (overlay-get ov 'treesit-host-parser))) (when (or (null language) (eq (treesit-parser-language parser) language)) @@ -726,10 +715,10 @@ For every local parser overlay between BEG and END, if its `treesit-parser-ov-timestamp' is smaller than MODIFIED-TICK, delete it." (dolist (ov (overlays-in beg end)) - (when-let ((ov-timestamp - (overlay-get ov 'treesit-parser-ov-timestamp))) + (when-let* ((ov-timestamp + (overlay-get ov 'treesit-parser-ov-timestamp))) (when (< ov-timestamp modified-tick) - (when-let ((local-parser (overlay-get ov 'treesit-parser))) + (when-let* ((local-parser (overlay-get ov 'treesit-parser))) (treesit-parser-delete local-parser)) (delete-overlay ov))))) @@ -859,10 +848,15 @@ opposed to embedded parsers which parses only part of the buffer.") (defvar-local treesit-font-lock-settings nil "A list of SETTINGs for treesit-based fontification. -The exact format of each SETTING is considered internal. Use -`treesit-font-lock-rules' to set this variable. +Use `treesit-font-lock-rules' to set this variable. The exact format of +each individual SETTING is considered internal and will change in the +future. Use `treesit-font-lock-setting-query', +`treesit-font-lock-setting-enable', etc, to access each field. + +Below information is considered internal and only provided to help +debugging: -Each SETTING has the form: +Currently each SETTING has the form: (QUERY ENABLE FEATURE OVERRIDE) @@ -880,12 +874,25 @@ OVERRIDE is the override flag for this query. Its value can be t, nil, append, prepend, keep. See more in `treesit-font-lock-rules'.") -(defsubst treesit--font-lock-setting-feature (setting) - "Return the feature of SETTING. -SETTING should be a setting in `treesit-font-lock-settings'." +;; Follow cl-defstruct naming conventions, in case we use cl-defstruct +;; in the future. +(defsubst treesit-font-lock-setting-query (setting) + "Return the QUERY of SETTING in `treesit-font-lock-settings'." + (nth 0 setting)) + +(defsubst treesit-font-lock-setting-enable (setting) + "Return the ENABLE flag of SETTING in `treesit-font-lock-settings'." + (nth 1 setting)) + +(defsubst treesit-font-lock-setting-feature (setting) + "Return the FEATURE symbol of SETTING in `treesit-font-lock-settings'." (nth 2 setting)) -(defsubst treesit--font-lock-setting-enable (setting) +(defsubst treesit-font-lock-setting-override (setting) + "Return the OVERRIDE flag of SETTING in `treesit-font-lock-settings'." + (nth 3 setting)) + +(defsubst treesit--font-lock-setting-clone-enable (setting) "Return enabled SETTING." (let ((new-setting (copy-tree setting))) (setf (nth 1 new-setting) t) @@ -1136,7 +1143,7 @@ signals the `treesit-font-lock-error' error if that happens. If LANGUAGE is non-nil, only compute features for that language, and leave settings for other languages unchanged." - (when-let ((intersection (cl-intersection add-list remove-list))) + (when-let* ((intersection (cl-intersection add-list remove-list))) (signal 'treesit-font-lock-error (list "ADD-LIST and REMOVE-LIST contain the same feature" intersection))) @@ -1183,12 +1190,12 @@ all existing rules. If FEATURE is non-nil, add RULES before/after rules for FEATURE. See docstring of `treesit-font-lock-rules' for what is a feature." - (let ((rules (seq-map #'treesit--font-lock-setting-enable rules)) + (let ((rules (seq-map #'treesit--font-lock-setting-clone-enable rules)) (feature-idx (when feature (cl-position-if (lambda (setting) - (eq (treesit--font-lock-setting-feature setting) feature)) + (eq (treesit-font-lock-setting-feature setting) feature)) treesit-font-lock-settings)))) (pcase (cons how feature) ((or '(:after . nil) '(nil . nil)) @@ -1207,6 +1214,48 @@ docstring of `treesit-font-lock-rules' for what is a feature." (append rules (nthcdr feature-idx treesit-font-lock-settings))))))) +(defun treesit-validate-font-lock-rules (settings) + "Validate font-lock rules in SETTINGS before major mode starts. + +If the tree-sitter grammar currently installed on the system is +incompatible with the major mode's font-lock rules, this procedure will +detect the problematic rule, disable it temporarily, and notify the +user." + (let ((faulty-features ())) + (dolist (setting settings) + (let* ((query (treesit-font-lock-setting-query setting)) + (lang (treesit-query-language query)) + (enabled (treesit-font-lock-setting-enable setting))) + (when (and enabled + (condition-case nil + (progn + (treesit-query-compile lang query 'eager) + nil) + (treesit-query-error t))) + (push (cons (treesit-font-lock-setting-feature setting) + lang) + faulty-features)))) + (when faulty-features + (treesit-font-lock-recompute-features + nil (mapcar #'car faulty-features)) + (let* ((languages + (string-join + (delete-dups (mapcar (lambda (feat) + (format "tree-sitter-%s" (cdr feat))) + faulty-features)) + ", ")) + (features (string-join + (mapcar + (lambda (feat) + (format "- `%s' for %s" + (car feat) (cdr feat))) + faulty-features) + ",\n"))) + (display-warning + 'treesit-font-lock-rules-mismatch + (format "Emacs cannot compile every font-lock rules because a mismatch between the grammar and the rules. This is most likely due to a mismatch between the font-lock rules defined by the major mode and the tree-sitter grammar.\n\nThis error can be fixed by either downgrading the grammar (%s) on your system, or upgrading the major mode package. The following are the temporarily disabled features:\n\n%s." + languages features)))))) + (defun treesit-fontify-with-override (start end face override &optional bound-start bound-end) "Apply FACE to the region between START and END. @@ -1360,6 +1409,10 @@ If LOUDLY is non-nil, display some debugging information." (root-nodes (mapcar #'treesit-parser-root-node (append local-parsers global-parsers)))) + ;; Can't we combine all the queries in each setting into one big + ;; query? That should make font-lock faster? I tried, it shaved off + ;; 1ms in xdisp.c, and 0.3ms in a small C file (for typing a single + ;; character), not worth it. --yuan (dolist (setting treesit-font-lock-settings) (let* ((query (nth 0 setting)) (enable (nth 1 setting)) @@ -1381,7 +1434,7 @@ If LOUDLY is non-nil, display some debugging information." (setq treesit--font-lock-fast-mode nil)))) ;; Only activate if ENABLE flag is t. - (when-let + (when-let* ((activate (eq t enable)) (nodes (if (eq t treesit--font-lock-fast-mode) (mapcan @@ -1548,13 +1601,13 @@ START and END mark the current to-be-propertized region." (defvar-local treesit-simple-indent-rules nil "A list of indent rule settings. -Each indent rule setting should be (LANGUAGE . RULES), -where LANGUAGE is a language symbol, and RULES is a list of +Each indent rule setting should be (LANGUAGE RULE...), where LANGUAGE is +a language symbol, and each RULE is of the form - (MATCHER ANCHOR OFFSET). + (MATCHER ANCHOR OFFSET) -MATCHER determines whether this rule applies, ANCHOR and OFFSET -together determines which column to indent to. +MATCHER determines whether this rule applies, ANCHOR and +OFFSET together determines which column to indent to. A MATCHER is a function that takes three arguments (NODE PARENT BOL). BOL is the point where we are indenting: the beginning of @@ -1571,7 +1624,20 @@ ANCHOR and adds OFFSET to it, and indents to that column. OFFSET can be an integer or a variable whose value is an integer. For MATCHER and ANCHOR, Emacs provides some convenient presets. -See `treesit-simple-indent-presets'.") +See `treesit-simple-indent-presets'. + +For complex cases, a RULE can also be a single function. This function +should take the same argument as MATCHER or ANCHOR. If it matches, +return a cons (ANCHOR-POS . OFFSET), where ANCHOR-POS is a position and +OFFSET is the indent offset; if it doesn't match, return nil.") + +(defun treesit--indent-prev-line-node (pos) + "Return the largest node on the previous line of POS." + (save-excursion + (goto-char pos) + (when (eq (forward-line -1) 0) + (back-to-indentation) + (treesit--indent-largest-node-at (point))))) (defvar treesit-simple-indent-presets (list (cons 'match @@ -1623,6 +1689,12 @@ See `treesit-simple-indent-presets'.") (lambda (node &rest _) (string-match-p type (or (treesit-node-type node) ""))))) + ;; FIXME: Add to manual. + (cons 'prev-line-is (lambda (type) + (lambda (_n _p bol &rest _) + (treesit-node-match-p + (treesit--indent-prev-line-node bol) + type)))) (cons 'field-is (lambda (name) (lambda (node &rest _) (string-match-p @@ -1728,10 +1800,7 @@ See `treesit-simple-indent-presets'.") (forward-line -1) (skip-chars-forward " \t") (point)))) - (cons 'column-0 (lambda (_n _p bol &rest _) - (save-excursion - (goto-char bol) - (line-beginning-position)))) + (cons 'column-0 (lambda (&rest _) (pos-bol))) ;; TODO: Document. (cons 'and (lambda (&rest fns) (lambda (node parent bol &rest _) @@ -1932,41 +2001,44 @@ PARENT is its parent; ANCHOR is a point (not a node), and OFFSET is a number. Emacs finds the column of ANCHOR and adds OFFSET to it as the final indentation of the current line.") -(defun treesit--indent-1 () - "Indent the current line. -Return (ANCHOR . OFFSET). This function is used by -`treesit-indent' and `treesit-indent-region'." - ;; Basically holds the common part between the two indent function. - (let* ((bol (save-excursion - (forward-line 0) - (skip-chars-forward " \t") - (point))) - (local-parsers (treesit-local-parsers-at bol nil t)) +(defun treesit--indent-largest-node-at (pos) + "Get largest node that still starts at POS." + (let* ((local-parsers (treesit-local-parsers-at pos nil t)) (smallest-node (cond ((car local-parsers) (let ((local-parser (caar local-parsers)) (host-parser (cdar local-parsers))) (if (eq (treesit-node-start (treesit-parser-root-node local-parser)) - bol) - (treesit-node-at bol host-parser) - (treesit-node-at bol local-parser)))) + pos) + (treesit-node-at pos host-parser) + (treesit-node-at pos local-parser)))) ((null (treesit-parser-list)) nil) ((eq 1 (length (treesit-parser-list nil nil t))) - (treesit-node-at bol)) - ((treesit-language-at bol) - (treesit-node-at bol (treesit-language-at bol))) - (t (treesit-node-at bol)))) + (treesit-node-at pos)) + ((treesit-language-at pos) + (treesit-node-at pos (treesit-language-at pos))) + (t (treesit-node-at pos)))) (root (treesit-parser-root-node - (treesit-node-parser smallest-node))) - (node (treesit-parent-while - smallest-node - (lambda (node) - (and (eq bol (treesit-node-start node)) - (not (treesit-node-eq node root))))))) - (let* - ((parser (if smallest-node - (treesit-node-parser smallest-node) + (treesit-node-parser smallest-node)))) + (treesit-parent-while + smallest-node + (lambda (node) + (and (eq pos (treesit-node-start node)) + (not (treesit-node-eq node root))))))) + +(defun treesit--indent-1 () + "Indent the current line. +Return (ANCHOR . OFFSET). This function is used by +`treesit-indent' and `treesit-indent-region'." + ;; Basically holds the common part between the two indent function. + (let* ((bol (save-excursion + (forward-line 0) + (skip-chars-forward " \t") + (point))) + (node (treesit--indent-largest-node-at bol)) + (parser (if node + (treesit-node-parser node) nil)) ;; NODE would be nil if BOL is on a whitespace. In that case ;; we set PARENT to the "node at point", which would @@ -1974,7 +2046,7 @@ Return (ANCHOR . OFFSET). This function is used by (parent (cond ((and node parser) (treesit-node-parent node)) (t (treesit-node-on bol bol))))) - (funcall treesit-indent-function node parent bol)))) + (funcall treesit-indent-function node parent bol))) (defun treesit-indent () "Indent according to the result of `treesit-indent-function'." @@ -2107,31 +2179,37 @@ OFFSET." (let* ((language (treesit-node-language parent)) (rules (alist-get language treesit-simple-indent-rules))) - (cl-loop for rule in rules - for pred = (nth 0 rule) - for anchor = (nth 1 rule) - for offset = (nth 2 rule) - if (treesit--simple-indent-eval - (list pred node parent bol)) - do (when treesit--indent-verbose + (catch 'match + (dolist (rule rules) + (if (functionp rule) + (let ((result (funcall rule node parent bol))) + (when result + (when treesit--indent-verbose (message "Matched rule: %S" rule)) - and - return - (let ((anchor-pos - (treesit--simple-indent-eval - (list anchor node parent bol))) - (offset-val - (cond ((numberp offset) offset) - ((and (symbolp offset) - (boundp offset)) - (symbol-value offset)) - (t (treesit--simple-indent-eval - (list offset node parent bol)))))) - (cons anchor-pos offset-val)) - finally return - (progn (when treesit--indent-verbose - (message "No matched rule")) - (cons nil nil)))))) + (throw 'match result))) + (let ((pred (nth 0 rule)) + (anchor (nth 1 rule)) + (offset (nth 2 rule))) + ;; Found a match. + (when (treesit--simple-indent-eval + (list pred node parent bol)) + (when treesit--indent-verbose + (message "Matched rule: %S" rule)) + (let ((anchor-pos + (treesit--simple-indent-eval + (list anchor node parent bol))) + (offset-val + (cond ((numberp offset) offset) + ((and (symbolp offset) + (boundp offset)) + (symbol-value offset)) + (t (treesit--simple-indent-eval + (list offset node parent bol)))))) + (throw 'match (cons anchor-pos offset-val))))))) + ;; Didn't find any match. + (when treesit--indent-verbose + (message "No matched rule")) + (cons nil nil))))) (defun treesit--read-major-mode () "Read a major mode using completion. @@ -2187,12 +2265,14 @@ RULES." (_ func))) ;; Optimize a rule (MATCHER ANCHOR OFFSET). (optimize-rule (rule) - (let ((matcher (nth 0 rule)) - (anchor (nth 1 rule)) - (offset (nth 2 rule))) - (list (optimize-func matcher) - (optimize-func anchor) - offset)))) + (if (functionp rule) + rule + (let ((matcher (nth 0 rule)) + (anchor (nth 1 rule)) + (offset (nth 2 rule))) + (list (optimize-func matcher) + (optimize-func anchor) + offset))))) (cons lang (mapcar #'optimize-rule indent-rules))))) ;;; Search @@ -2324,8 +2404,8 @@ friends." (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))) + (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) @@ -2849,7 +2929,7 @@ The delimiter between nested defun names is controlled by (let ((node (treesit-defun-at-point)) (name nil)) (while node - (when-let ((new-name (treesit-defun-name node))) + (when-let* ((new-name (treesit-defun-name node))) (if name (setq name (concat new-name treesit-add-log-defun-delimiter @@ -3104,7 +3184,8 @@ before calling this function." (add-hook 'pre-redisplay-functions #'treesit--pre-redisplay 0 t) (when treesit-primary-parser (treesit-parser-add-notifier - treesit-primary-parser #'treesit--font-lock-mark-ranges-to-fontify))) + treesit-primary-parser #'treesit--font-lock-mark-ranges-to-fontify)) + (treesit-validate-font-lock-rules treesit-font-lock-settings)) ;; Syntax (add-hook 'syntax-propertize-extend-region-functions #'treesit--pre-syntax-ppss 0 t) @@ -3166,7 +3247,7 @@ before calling this function." ;; Remove existing local parsers. (dolist (ov (overlays-in (point-min) (point-max))) - (when-let ((parser (overlay-get ov 'treesit-parser))) + (when-let* ((parser (overlay-get ov 'treesit-parser))) (treesit-parser-delete parser) (delete-overlay ov)))) @@ -3309,7 +3390,7 @@ to the offending pattern and highlight the pattern." (defvar-local treesit--explorer-source-buffer nil "Source buffer corresponding to the playground buffer.") -(defvar-local treesit--explorer-language nil +(defvar-local treesit--explorer-parser nil "The language used in the playground.") (defvar-local treesit--explorer-refresh-timer nil @@ -3323,8 +3404,8 @@ to the offending pattern and highlight the pattern." (defvar treesit-explore-mode) -(defun treesit--explorer--nodes-to-highlight (language) - "Return nodes for LANGUAGE covered in region. +(defun treesit--explorer--nodes-to-highlight (parser) + "Return nodes for PARSER covered in region. This function tries to return the largest node possible. If the region covers exactly one node, that node is returned (in a list). If the region covers more than one node, two nodes are @@ -3332,7 +3413,7 @@ returned: the very first one in the region and the very last one in the region." (let* ((beg (region-beginning)) (end (region-end)) - (node (treesit-node-on beg end language)) + (node (treesit-node-on beg end parser)) (node (or (treesit-parent-while node (lambda (n) @@ -3356,7 +3437,7 @@ in the region." (when (and treesit-explore-mode (buffer-live-p treesit--explorer-buffer)) (let* ((root (treesit-node-on - (window-start) (window-end) treesit--explorer-language)) + (window-start) (window-end) treesit--explorer-parser)) ;; Only highlight the current top-level construct. ;; Highlighting the whole buffer is slow and unnecessary. ;; But if the buffer is small (ie, used in playground @@ -3373,7 +3454,7 @@ in the region." (nodes-hl (when (region-active-p) (treesit--explorer--nodes-to-highlight - treesit--explorer-language))) + treesit--explorer-parser))) ;; If we didn't edit the buffer nor change the top-level ;; node, don't redraw the whole syntax tree. (highlight-only (treesit-node-eq @@ -3388,9 +3469,9 @@ in the region." (when (and top-level (not highlight-only)) (erase-buffer) (treesit--explorer-draw-node top-level)) - (when-let ((pos (treesit--explorer-highlight-node nodes-hl)) - (window (get-buffer-window - treesit--explorer-buffer))) + (when-let* ((pos (treesit--explorer-highlight-node nodes-hl)) + (window (get-buffer-window + treesit--explorer-buffer))) (if highlight-only (goto-char pos) ;; If HIGHLIGHT-ONLY is nil, we erased the buffer and @@ -3551,11 +3632,56 @@ leaves point at the end of the last line of NODE." (when (buffer-live-p treesit--explorer-buffer) (kill-buffer treesit--explorer-buffer))) +(defun treesit--explorer-generate-parser-alist () + "Return an alist of (PARSER-NAME . PARSER) for relevant parsers. +Relevant parsers include all global parsers and local parsers that +covers point. PARSER-NAME are unique." + (let* ((local-parsers (treesit-parser-list nil nil 'embedded)) + (local-parsers-at-point + (treesit-local-parsers-at (point))) + res) + (dolist (parser (treesit-parser-list nil nil t)) + ;; Exclude local parsers that doesn't cover point. + (when (or (memq parser local-parsers-at-point) + (not (memq parser local-parsers))) + (push (cons (concat (format "%s" parser) + (if (treesit-parser-tag parser) + (format " tag=%s" + (treesit-parser-tag + parser)) + "") + (if (memq parser + local-parsers-at-point) + " (local)" + "") + (propertize (format " %s" (gensym)) + 'invisible t)) + parser) + res))) + (nreverse res))) + (define-derived-mode treesit--explorer-tree-mode special-mode "TS Explorer" "Mode for displaying syntax trees for `treesit-explore-mode'." nil) +(defun treesit-explorer-switch-parser (parser) + "Switch explorer to use PARSER." + (interactive + (list (let* ((parser-alist + (treesit--explorer-generate-parser-alist)) + (parser-name (completing-read + "Parser: " (mapcar #'car parser-alist)))) + (alist-get parser-name parser-alist + nil nil #'equal)))) + (unless treesit-explore-mode + (user-error "Not in `treesit-explore-mode'")) + (setq-local treesit--explorer-parser parser) + (display-buffer treesit--explorer-buffer + (cons nil '((inhibit-same-window . t)))) + (setq-local treesit--explorer-last-node nil) + (treesit--explorer-refresh)) + (define-minor-mode treesit-explore-mode "Enable exploring the current buffer's syntax tree. Pops up a window showing the syntax tree of the source in the @@ -3564,40 +3690,28 @@ the text in the active region is highlighted in the explorer window." :lighter " TSexplore" (if treesit-explore-mode - (let ((language - (intern (completing-read - "Language: " - (cl-remove-duplicates - (mapcar #'treesit-parser-language - (treesit-parser-list nil nil t))))))) - (if (not (treesit-language-available-p language)) - (user-error "Cannot find tree-sitter grammar for %s: %s" - language (cdr (treesit-language-available-p - language t))) - ;; Create explorer buffer. - (unless (buffer-live-p treesit--explorer-buffer) - (setq-local treesit--explorer-buffer - (get-buffer-create - (format "*tree-sitter explorer for %s*" - (buffer-name)))) - (setq-local treesit--explorer-language language) - (with-current-buffer treesit--explorer-buffer - (treesit--explorer-tree-mode))) - (display-buffer treesit--explorer-buffer - (cons nil '((inhibit-same-window . t)))) - (setq-local treesit--explorer-last-node nil) - (treesit--explorer-refresh) - ;; Set up variables and hooks. - (add-hook 'post-command-hook - #'treesit--explorer-post-command 0 t) - (add-hook 'kill-buffer-hook - #'treesit--explorer-kill-explorer-buffer 0 t) - ;; Tell `desktop-save' to not save explorer buffers. - (when (boundp 'desktop-modes-not-to-save) - (unless (memq 'treesit--explorer-tree-mode - desktop-modes-not-to-save) - (push 'treesit--explorer-tree-mode - desktop-modes-not-to-save))))) + (progn + ;; Create explorer buffer. + (unless (buffer-live-p treesit--explorer-buffer) + (setq-local treesit--explorer-buffer + (get-buffer-create + (format "*tree-sitter explorer for %s*" + (buffer-name)))) + (with-current-buffer treesit--explorer-buffer + (treesit--explorer-tree-mode))) + ;; Select parser. + (call-interactively #'treesit-explorer-switch-parser) + ;; Set up variables and hooks. + (add-hook 'post-command-hook + #'treesit--explorer-post-command 0 t) + (add-hook 'kill-buffer-hook + #'treesit--explorer-kill-explorer-buffer 0 t) + ;; Tell `desktop-save' to not save explorer buffers. + (when (boundp 'desktop-modes-not-to-save) + (unless (memq 'treesit--explorer-tree-mode + desktop-modes-not-to-save) + (push 'treesit--explorer-tree-mode + desktop-modes-not-to-save)))) ;; Turn off explore mode. (remove-hook 'post-command-hook #'treesit--explorer-post-command t) @@ -3605,6 +3719,14 @@ window." #'treesit--explorer-kill-explorer-buffer t) (treesit--explorer-kill-explorer-buffer))) +(defun treesit-explore () + "Show the explorer." + (interactive) + (if (and treesit-explore-mode + (buffer-live-p treesit--explorer-buffer)) + (display-buffer treesit--explorer-buffer '(nil (inhibit-same-window . t))) + (treesit-explore-mode))) + ;;; Install & build language grammar (defvar treesit-language-source-alist nil @@ -3691,26 +3813,26 @@ nil, the grammar is installed to the standard location, the "Language: " (mapcar #'car treesit-language-source-alist))) 'interactive)) - (when-let ((recipe - (or (assoc lang treesit-language-source-alist) - (if (eq out-dir 'interactive) - (treesit--install-language-grammar-build-recipe - lang) - (signal 'treesit-error `("Cannot find recipe for this language" ,lang))))) - (default-out-dir - (or (car treesit--install-language-grammar-out-dir-history) - (locate-user-emacs-file "tree-sitter"))) - (out-dir - (if (eq out-dir 'interactive) - (read-string - (format "Install to (default: %s): " - default-out-dir) - nil - 'treesit--install-language-grammar-out-dir-history - default-out-dir) - ;; When called non-interactively, OUT-DIR should - ;; default to DEFAULT-OUT-DIR. - (or out-dir default-out-dir)))) + (when-let* ((recipe + (or (assoc lang treesit-language-source-alist) + (if (eq out-dir 'interactive) + (treesit--install-language-grammar-build-recipe + lang) + (signal 'treesit-error `("Cannot find recipe for this language" ,lang))))) + (default-out-dir + (or (car treesit--install-language-grammar-out-dir-history) + (locate-user-emacs-file "tree-sitter"))) + (out-dir + (if (eq out-dir 'interactive) + (read-string + (format "Install to (default: %s): " + default-out-dir) + nil + 'treesit--install-language-grammar-out-dir-history + default-out-dir) + ;; When called non-interactively, OUT-DIR should + ;; default to DEFAULT-OUT-DIR. + (or out-dir default-out-dir)))) (condition-case err (progn (apply #'treesit--install-language-grammar-1 diff --git a/lisp/tutorial.el b/lisp/tutorial.el index d754db238de..f98aff167d2 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -650,7 +650,13 @@ with some explanatory links." (delete-region prop-start prop-end)))))) (defvar tutorial--starting-point) + +;; For when the user saves the TUTORIAL to a file. (put 'tutorial--starting-point 'permanent-local t) +(put 'tutorial--lang 'permanent-local t) +(put 'tutorial--point-before-chkeys 'permanent-local t) +(put 'tutorial--point-after-chkeys 'permanent-local t) + (defun tutorial--save-on-kill () "Query the user about saving the tutorial when killing Emacs." (when (buffer-live-p tutorial--buffer) diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index 8f4df780a54..d7d7701b364 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -72,8 +72,7 @@ instead of the filename inheritance method." (pass (url-password href)) (enable-recursive-minibuffers t) ; for url-handler-mode (bug#10298) byserv retval data) - (setq server (format "%s:%d" server port) - file (cond + (setq file (cond (realm realm) ((string= "" file) "/") ((string-match "/$" file) file) @@ -91,9 +90,10 @@ instead of the filename inheritance method." (read-string (url-auth-user-prompt href realm) (or user (user-real-login-name))))) pass (or - (url-do-auth-source-search server type :secret) + (url-do-auth-source-search server type :secret user) (and (url-interactive-p) (read-passwd "Password: " nil (or pass ""))))) + (setq server (format "%s:%d" server port)) (set url-basic-auth-storage (cons (list server (cons file @@ -126,9 +126,10 @@ instead of the filename inheritance method." (read-string (url-auth-user-prompt href realm) (user-real-login-name)))) pass (or - (url-do-auth-source-search server type :secret) + (url-do-auth-source-search server type :secret user) (and (url-interactive-p) (read-passwd "Password: "))) + server (format "%s:%d" server port) retval (base64-encode-string (format "%s:%s" user pass) t) byserv (assoc server (symbol-value url-basic-auth-storage))) (setcdr byserv @@ -460,8 +461,8 @@ challenge such as nonce and opaque." "A list of the registered authorization schemes and various and sundry information associated with them.") -(defun url-do-auth-source-search (server type parameter) - (let* ((auth-info (auth-source-search :max 1 :host server :port type)) +(defun url-do-auth-source-search (server type parameter &optional user) + (let* ((auth-info (auth-source-search :max 1 :host server :port type :user user)) (auth-info (nth 0 auth-info)) (token (plist-get auth-info parameter)) (token (if (functionp token) (funcall token) token))) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 184c1278072..37f589a0b09 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -74,7 +74,9 @@ (defvar url-http-open-connections (make-hash-table :test 'equal :size 17) - "A hash table of all open network connections.") + "A hash table of all open network connections. +If Emacs is compiled with thread support, the key is a list `(host port +thread)'. Otherwise, it is a cons cell `(host . port)'.") (defvar url-http-version "1.1" "What version of HTTP we advertise, as a string. @@ -153,27 +155,46 @@ request.") (defsubst url-http-debug (&rest args) (apply #'url-debug 'http args)) +(declare-function current-thread "thread.c" ()) +(declare-function thread-live-p "thread.c" (thread)) + (defun url-http-mark-connection-as-busy (host port proc) - (url-http-debug "Marking connection as busy: %s:%d %S" host port proc) - (set-process-query-on-exit-flag proc t) - (puthash (cons host port) - (delq proc (gethash (cons host port) url-http-open-connections)) - url-http-open-connections) - proc) + (let ((key (if main-thread + (list host port (current-thread)) + (cons host port)))) + (url-http-debug "Marking connection as busy: %s:%d %S" host port proc) + (set-process-query-on-exit-flag proc t) + (puthash key + (delq proc (gethash key url-http-open-connections)) + url-http-open-connections) + proc)) (defun url-http-mark-connection-as-free (host port proc) - (url-http-debug "Marking connection as free: %s:%d %S" host port proc) - (when (memq (process-status proc) '(open run connect)) - (set-process-buffer proc nil) - (set-process-sentinel proc 'url-http-idle-sentinel) - (set-process-query-on-exit-flag proc nil) - (puthash (cons host port) - (cons proc (gethash (cons host port) url-http-open-connections)) - url-http-open-connections)) - nil) + (let ((key (if main-thread + (list host port (current-thread)) + (cons host port)))) + (url-http-debug "Marking connection as free: %s:%d %S" host port proc) + (when (memq (process-status proc) '(open run connect)) + (set-process-buffer proc nil) + (set-process-sentinel proc 'url-http-idle-sentinel) + (set-process-query-on-exit-flag proc nil) + (puthash key + (cons proc (gethash key url-http-open-connections)) + url-http-open-connections)) + nil)) (defun url-http-find-free-connection (host port &optional gateway-method) - (let ((conns (gethash (cons host port) url-http-open-connections)) + (when main-thread + (maphash + (lambda (key _val) + (unless (thread-live-p (caddr key)) + (remhash key url-http-open-connections))) + url-http-open-connections)) + (let ((conns (gethash + (if main-thread + (list host port (current-thread)) + (cons host port)) + url-http-open-connections)) (connection nil)) (while (and conns (not connection)) (if (not (memq (process-status (car conns)) '(run open connect))) @@ -182,7 +203,8 @@ request.") host port (car conns)) (url-http-idle-sentinel (car conns) nil)) (setq connection (car conns)) - (url-http-debug "Found existing connection: %s:%d %S" host port connection)) + (url-http-debug + "Found existing connection: %s:%d %S" host port connection)) (pop conns)) (if connection (url-http-debug "Reusing existing connection: %s:%d" host port) @@ -232,7 +254,9 @@ request.") " "))) (defun url-http--get-referer (url) - (url-http-debug "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" (current-buffer) url url-current-lastloc) + (url-http-debug + "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" + (current-buffer) url url-current-lastloc) (when url-current-lastloc (if (not (url-p url-current-lastloc)) (setq url-current-lastloc (url-generic-parse-url url-current-lastloc))) @@ -273,7 +297,8 @@ The string is based on `url-privacy-level' and `url-user-agent'." (cond ((functionp url-user-agent) (funcall url-user-agent)) ((stringp url-user-agent) url-user-agent) - ((eq url-user-agent 'default) (url-http--user-agent-default-string)))))) + ((eq url-user-agent 'default) + (url-http--user-agent-default-string)))))) (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) ""))) (defun url-http-create-request () @@ -297,7 +322,8 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." (url-get-authentication (or (and (boundp 'proxy-info) proxy-info) - url-http-target-url) nil 'any nil))) + url-http-target-url) + nil 'any nil))) (ref-url (url-http--encode-string url-http-referer))) (if (equal "" real-fname) (setq real-fname "/")) @@ -343,8 +369,9 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." ;; (maybe) Try to keep the connection open "Connection: " (if (or using-proxy (not url-http-attempt-keepalives)) - "close" "keep-alive") "\r\n" - ;; HTTP extensions we support + "close" "keep-alive") + "\r\n" + ;; HTTP extensions we support (if url-extensions-header (format "Extension: %s\r\n" url-extensions-header)) @@ -511,7 +538,8 @@ Return the number of characters removed." (defun url-http-parse-response () "Parse just the response code." (if (not url-http-end-of-headers) - (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) + (error + "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) (goto-char (point-min)) (skip-chars-forward " \t\n") ; Skip any blank crap @@ -1273,7 +1301,8 @@ the end of the document." (url-http-activate-callback))) ((> nd url-http-end-of-headers) ;; Have some leftover data - (url-http-debug "Calling initial content-length for extra data at end of headers") + (url-http-debug + "Calling initial content-length for extra data at end of headers") (url-http-content-length-after-change-function (marker-position url-http-end-of-headers) nd @@ -1437,15 +1466,17 @@ The return value of this function is the retrieval buffer." ((= url-http-response-status 200) (if (gnutls-available-p) (condition-case e - (let ((tls-connection (gnutls-negotiate - :process proc - :hostname (puny-encode-domain (url-host url-current-object)) - :verify-error nil))) + (let ((tls-connection + (gnutls-negotiate + :process proc + :hostname (puny-encode-domain (url-host url-current-object)) + :verify-error nil))) ;; check certificate validity (setq tls-connection - (nsm-verify-connection tls-connection - (puny-encode-domain (url-host url-current-object)) - (url-port url-current-object))) + (nsm-verify-connection + tls-connection + (puny-encode-domain (url-host url-current-object)) + (url-port url-current-object))) (with-current-buffer process-buffer (erase-buffer)) (set-process-buffer tls-connection process-buffer) (setq url-http-after-change-function @@ -1484,9 +1515,11 @@ The return value of this function is the retrieval buffer." (message "HTTP error: %s" error))))) (t (setf (car url-callback-arguments) - (nconc (list :error (list 'error 'connection-failed why - :host (url-host (or url-http-proxy url-current-object)) - :service (url-port (or url-http-proxy url-current-object)))) + (nconc (list + :error + (list 'error 'connection-failed why + :host (url-host (or url-http-proxy url-current-object)) + :service (url-port (or url-http-proxy url-current-object)))) (car url-callback-arguments))) (url-http-activate-callback)))))) diff --git a/lisp/url/url.el b/lisp/url/url.el index 2bf62d7cfbb..253d2ecfe72 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -259,9 +259,9 @@ how long to wait for a response before giving up." (url-debug 'retrieval "Spinning in url-retrieve-synchronously: nil (%S)" proc-buffer) - (when-let ((redirect-buffer - (buffer-local-value 'url-redirect-buffer - proc-buffer))) + (when-let* ((redirect-buffer + (buffer-local-value 'url-redirect-buffer + proc-buffer))) (unless (eq redirect-buffer proc-buffer) (url-debug 'retrieval "Redirect in url-retrieve-synchronously: %S -> %S" @@ -270,7 +270,7 @@ how long to wait for a response before giving up." (kill-buffer proc-buffer)) ;; Accommodate hack in commit 55d1d8b. (setq proc-buffer redirect-buffer))) - (when-let ((proc (get-buffer-process proc-buffer))) + (when-let* ((proc (get-buffer-process proc-buffer))) (when (memq (process-status proc) '(closed exit signal failed)) ;; Process sentinel vagaries occasionally cause diff --git a/lisp/use-package/use-package-core.el b/lisp/use-package/use-package-core.el index 6c3d350c610..1b9a4332f25 100644 --- a/lisp/use-package/use-package-core.el +++ b/lisp/use-package/use-package-core.el @@ -69,7 +69,9 @@ "This version of `use-package'.") (defcustom use-package-keywords - '(:disabled + '(:pin + :ensure + :disabled :load-path :requires :defines @@ -101,7 +103,9 @@ :load ;; This must occur almost last; the only forms which should appear after ;; are those that must happen directly after the config forms. - :config) + :config + :diminish + :delight) "The set of valid keywords, in the order they are processed in. The order of this list is *very important*, so it is only advisable to insert new keywords, never to delete or reorder @@ -115,7 +119,7 @@ nothing at all to happen, even if the rest of the `use-package' declaration is incorrect." :type '(repeat symbol) :group 'use-package - :version "29.1") + :version "31.1") (defcustom use-package-deferring-keywords '(:bind-keymap @@ -197,7 +201,12 @@ See also `use-package-defaults', which uses this value." (lambda (name args) (and use-package-always-demand (not (plist-member args :defer)) - (not (plist-member args :demand)))))) + (not (plist-member args :demand))))) + (:ensure (list use-package-always-ensure) + (lambda (name args) + (and use-package-always-ensure + (not (plist-member args :load-path))))) + (:pin use-package-always-pin use-package-always-pin)) "Default values for specified `use-package' keywords. Each entry in the alist is a list of three elements: The first element is the `use-package' keyword. @@ -223,7 +232,7 @@ attempted." (choice :tag "Default value" sexp function) (choice :tag "Enable if non-nil" sexp function))) :group 'use-package - :version "29.1") + :version "31.1") (defcustom use-package-merge-key-alist '((:if . (lambda (new old) `(and ,new ,old))) @@ -377,6 +386,36 @@ stability issues." :version "30.1" :group 'use-package) +(defcustom use-package-always-ensure nil + "Treat every package as though it had specified using `:ensure SEXP'. +See also `use-package-defaults', which uses this value." + :type 'sexp + :version "29.1") + +(defcustom use-package-always-pin nil + "Treat every package as though it had specified using `:pin SYM'. +See also `use-package-defaults', which uses this value." + :type 'symbol + :version "29.1") + +(defcustom use-package-ensure-function 'use-package-ensure-elpa + "Function that ensures a package is installed. +This function is called with three arguments: the name of the +package declared in the `use-package' form; the arguments passed +to all `:ensure' keywords (always a list, even if only one); and +the current `state' plist created by previous handlers. + +Note that this function is called whenever `:ensure' is provided, +even if it is nil. It is up to the function to decide on the +semantics of the various values for `:ensure'. + +This function should return non-nil if the package is installed. + +The default value uses package.el to install the package." + :type '(choice (const :tag "package.el" use-package-ensure-elpa) + (function :tag "Custom")) + :version "29.1") + (defvar use-package-statistics (make-hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lisp/use-package/use-package-delight.el b/lisp/use-package/use-package-delight.el index c458d263cf0..c67e2aa6320 100644 --- a/lisp/use-package/use-package-delight.el +++ b/lisp/use-package/use-package-delight.el @@ -81,8 +81,6 @@ `((if (fboundp 'delight) (delight '(,@args))))))) -(add-to-list 'use-package-keywords :delight t) - (provide 'use-package-delight) ;;; use-package-delight.el ends here diff --git a/lisp/use-package/use-package-diminish.el b/lisp/use-package/use-package-diminish.el index 79421a0e273..0be2ba688a0 100644 --- a/lisp/use-package/use-package-diminish.el +++ b/lisp/use-package/use-package-diminish.el @@ -70,8 +70,6 @@ arg) body))) -(add-to-list 'use-package-keywords :diminish t) - (provide 'use-package-diminish) ;;; use-package-diminish.el ends here diff --git a/lisp/use-package/use-package-ensure.el b/lisp/use-package/use-package-ensure.el index 817c62276ad..82ab3256ef0 100644 --- a/lisp/use-package/use-package-ensure.el +++ b/lisp/use-package/use-package-ensure.el @@ -32,49 +32,10 @@ (require 'cl-lib) (require 'use-package-core) -(defgroup use-package-ensure nil - "Support for :ensure and :pin keywords in `use-package' declarations." - :group 'use-package - :link '(custom-manual "(use-package) Installing packages") - :version "29.1") - (eval-when-compile (declare-function package-installed-p "package") (declare-function package-read-all-archive-contents "package" ())) -(defcustom use-package-always-ensure nil - "Treat every package as though it had specified using `:ensure SEXP'. -See also `use-package-defaults', which uses this value." - :type 'sexp - :group 'use-package-ensure - :version "29.1") - -(defcustom use-package-always-pin nil - "Treat every package as though it had specified using `:pin SYM'. -See also `use-package-defaults', which uses this value." - :type 'symbol - :group 'use-package-ensure - :version "29.1") - -(defcustom use-package-ensure-function 'use-package-ensure-elpa - "Function that ensures a package is installed. -This function is called with three arguments: the name of the -package declared in the `use-package' form; the arguments passed -to all `:ensure' keywords (always a list, even if only one); and -the current `state' plist created by previous handlers. - -Note that this function is called whenever `:ensure' is provided, -even if it is nil. It is up to the function to decide on the -semantics of the various values for `:ensure'. - -This function should return non-nil if the package is installed. - -The default value uses package.el to install the package." - :type '(choice (const :tag "package.el" use-package-ensure-elpa) - (function :tag "Custom")) - :group 'use-package-ensure - :version "29.1") - ;;;; :pin (defun use-package-normalize/:pin (_name keyword args) @@ -199,18 +160,6 @@ manually updated package." body)) body)) -(add-to-list 'use-package-defaults - '(:ensure (list use-package-always-ensure) - (lambda (name args) - (and use-package-always-ensure - (not (plist-member args :load-path))))) t) - -(add-to-list 'use-package-defaults - '(:pin use-package-always-pin use-package-always-pin) t) - -(add-to-list 'use-package-keywords :ensure) -(add-to-list 'use-package-keywords :pin) - (provide 'use-package-ensure) ;;; use-package-ensure.el ends here diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 81e8b23ee33..2ed9a4553c8 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -196,6 +196,7 @@ The default \"-b\" means to ignore whitespace-only changes, "RET" #'diff-goto-source "<mouse-2>" #'diff-goto-source "W" #'widen + "w" #'diff-kill-ring-save "o" #'diff-goto-source ; other-window "A" #'diff-ediff-patch "r" #'diff-restrict-view @@ -208,7 +209,7 @@ The default \"-b\" means to ignore whitespace-only changes, ;; We want to inherit most bindings from ;; `diff-mode-shared-map', but not all since they may hide ;; useful `M-<foo>' global bindings when editing. - (dolist (key '("A" "r" "R" "g" "q" "W" "z")) + (dolist (key '("A" "r" "R" "g" "q" "W" "w" "z")) (keymap-set map key nil)) map) ;; From compilation-minor-mode. @@ -217,7 +218,9 @@ The default \"-b\" means to ignore whitespace-only changes, "C-x 4 A" #'diff-add-change-log-entries-other-window ;; Misc operations. "C-c C-a" #'diff-apply-hunk + "C-c M-r" #'diff-revert-and-kill-hunk "C-c C-m a" #'diff-apply-buffer + "C-c C-m n" #'diff-delete-other-hunks "C-c C-e" #'diff-ediff-patch "C-c C-n" #'diff-restrict-view "C-c C-s" #'diff-split-hunk @@ -241,6 +244,8 @@ The default \"-b\" means to ignore whitespace-only changes, :help "Apply the current hunk to the source file and go to the next"] ["Test applying hunk" diff-test-hunk :help "See whether it's possible to apply the current hunk"] + ["Revert and kill hunk" diff-revert-and-kill-hunk + :help "Reverse-apply and then kill the current hunk."] ["Apply all hunks" diff-apply-buffer :help "Apply all hunks in the current diff buffer"] ["Apply diff with Ediff" diff-ediff-patch @@ -274,6 +279,8 @@ The default \"-b\" means to ignore whitespace-only changes, :help "Kill current hunk"] ["Kill current file's hunks" diff-file-kill :help "Kill all current file's hunks"] + ["Delete other hunks" diff-delete-other-hunks + :help "Delete hunks other than the current hunk"] "-----" ["Previous Hunk" diff-hunk-prev :help "Go to the previous count'th hunk"] @@ -810,6 +817,39 @@ If the prefix ARG is given, restrict the view to the current file instead." (goto-char (car bounds)) (ignore-errors (diff-beginning-of-hunk t))))) +;; This is not `diff-kill-other-hunks' because we might need to make +;; copies of file headers in order to ensure the new kill ring entry +;; would be a patch with the same meaning. That is not implemented +;; because it does not seem like it would be useful. +(defun diff-delete-other-hunks (&optional beg end) + "Delete hunks other than the current one. +Interactively, if the region is active, delete all hunks that the region +overlaps; otherwise delete all hunks except the current one. +When calling from Lisp, pass BEG and END as the bounds of the region in +which to delete hunks; BEG and END omitted or nil means to delete all +the hunks but the one which contains point." + (interactive (list (use-region-beginning) (use-region-end))) + (when (buffer-narrowed-p) + (user-error "Command is not safe in a narrowed buffer")) + (let ((inhibit-read-only t)) + (save-excursion + (cond ((xor beg end) + (error "Require exactly zero or two arguments")) + (beg + (goto-char beg) + (setq beg (car (diff-bounds-of-hunk))) + (goto-char end) + (setq end (cadr (diff-bounds-of-hunk)))) + (t + (pcase-setq `(,beg ,end) (diff-bounds-of-hunk)))) + (delete-region end (point-max)) + (goto-char beg) + (diff-beginning-of-file) + (diff-hunk-next) + (delete-region (point) beg) + (diff-beginning-of-file-and-junk) + (delete-region (point-min) (point))))) + (defun diff-beginning-of-file-and-junk () "Go to the beginning of file-related diff-info. This is like `diff-beginning-of-file' except it tries to skip back over leading @@ -1051,13 +1091,24 @@ PREFIX is only used internally: don't use it." (diff-find-file-name old noprompt (match-string 1))) ;; if all else fails, ask the user (unless noprompt - (let ((file (expand-file-name (or (car fs) "")))) + (let ((file (or (car fs) "")) + (creation (equal null-device + (car (diff-hunk-file-names (not old)))))) + (when (and (memq diff-buffer-type '(git hg)) + (string-match "/" file)) + ;; Strip the dst prefix (like b/) if diff is from Git/Hg. + (setq file (substring file (match-end 0)))) + (setq file (expand-file-name file)) (setq file (read-file-name (format "Use file %s: " file) - (file-name-directory file) file t + (file-name-directory file) file + ;; Allow non-matching for creation. + (not creation) (file-name-nondirectory file))) - (setq-local diff-remembered-files-alist - (cons (cons fs file) diff-remembered-files-alist)) + (when (or (not creation) (file-exists-p file)) + ;; Only remember files that exist. User might have mistyped. + (setq-local diff-remembered-files-alist + (cons (cons fs file) diff-remembered-files-alist))) file))))))) @@ -1607,7 +1658,9 @@ modified lines of the diff." (setq-local diff-buffer-type (if (re-search-forward "^diff --git" nil t) 'git - nil))) + (if (re-search-forward "^diff -r.*-r" nil t) + 'hg + nil)))) (when (eq diff-buffer-type 'git) (setq diff-outline-regexp (concat "\\(^diff --git.*\\|" diff-hunk-header-re "\\)"))) @@ -1980,7 +2033,11 @@ the value of this variable when given an appropriate prefix argument). With a prefix argument, REVERSE the hunk." (interactive "P") (diff-beginning-of-hunk t) - (pcase-let ((`(,buf ,line-offset ,pos ,old ,new ,switched) + (pcase-let* (;; Do not accept BUFFER.REV buffers as source location. + (diff-vc-backend nil) + ;; When we detect deletion, we will use the old file name. + (deletion (equal null-device (car (diff-hunk-file-names reverse)))) + (`(,buf ,line-offset ,pos ,old ,new ,switched) ;; Sometimes we'd like to have the following behavior: if ;; REVERSE go to the new file, otherwise go to the old. ;; But that means that by default we use the old file, which is @@ -1990,7 +2047,7 @@ With a prefix argument, REVERSE the hunk." ;; TODO: make it possible to ask explicitly for this behavior. ;; ;; This is duplicated in diff-test-hunk. - (diff-find-source-location nil reverse))) + (diff-find-source-location (xor deletion reverse) reverse))) (cond ((null line-offset) (user-error "Can't find the text to patch")) @@ -2016,6 +2073,10 @@ With a prefix argument, REVERSE the hunk." "Hunk hasn't been applied yet; apply it now? " "Hunk has already been applied; undo it? "))))) (message "(Nothing done)")) + ((and deletion (not switched)) + (when (y-or-n-p (format-message "Delete file `%s'?" (buffer-file-name buf))) + (delete-file (buffer-file-name buf) delete-by-moving-to-trash) + (kill-buffer buf))) (t ;; Apply the hunk (with-current-buffer buf @@ -2049,24 +2110,53 @@ With a prefix argument, try to REVERSE the hunk." (diff-hunk-kill) (diff-hunk-next))))) -(defun diff-apply-buffer () +(defcustom diff-ask-before-revert-and-kill-hunk t + "If non-nil, `diff-revert-and-kill-hunk' will ask for confirmation." + :type 'boolean + :version "31.1") + +(defun diff-revert-and-kill-hunk () + "Reverse-apply and then kill the hunk at point. Save changed buffer. + +This command is useful in buffers generated by \\[vc-diff] and \\[vc-root-diff], +especially when preparing to commit the patch with \\[vc-next-action]. +You can use \\<diff-mode-map>\\[diff-hunk-kill] to temporarily remove changes that you intend to +include in a separate commit or commits, and you can use this command +to permanently drop changes you didn't intend, or no longer want. + +This is a destructive operation, so by default, this command asks you to +confirm you really want to reverse-apply and kill the hunk. You can +customize `diff-ask-before-revert-and-kill-hunk' to control that." + (interactive) + (when (or (not diff-ask-before-revert-and-kill-hunk) + (yes-or-no-p "Really reverse-apply and kill this hunk?")) + (cl-destructuring-bind (beg end) (diff-bounds-of-hunk) + (when (null (diff-apply-buffer beg end t)) + (diff-hunk-kill))))) + +(defun diff-apply-buffer (&optional beg end reverse) "Apply the diff in the entire diff buffer. -When applying all hunks was successful, then save the changed buffers." +If applying all hunks succeeds, save the changed buffers. +When called from Lisp with optional arguments, restrict the application +to hunks lying between BEG and END, and reverse-apply them when REVERSE is +non-nil. Returns nil if buffers were successfully modified and saved, or +the number of failed hunk applications otherwise." (interactive) (let ((buffer-edits nil) (failures 0) (diff-refine nil)) (save-excursion - (goto-char (point-min)) + (goto-char (or beg (point-min))) (diff-beginning-of-hunk t) (while (pcase-let ((`(,buf ,line-offset ,pos ,_src ,dst ,switched) - (diff-find-source-location nil nil))) + (diff-find-source-location nil reverse))) (cond ((and line-offset (not switched)) (push (cons pos dst) (alist-get buf buffer-edits))) (t (setq failures (1+ failures)))) (and (not (eq (prog1 (point) (ignore-errors (diff-hunk-next))) (point))) + (or (not end) (< (point) end)) (looking-at-p diff-hunk-header-re))))) (cond ((zerop failures) (dolist (buf-edits (reverse buffer-edits)) @@ -2079,9 +2169,14 @@ When applying all hunks was successful, then save the changed buffers." (delete-region (car pos) (cdr pos)) (insert (car dst)))) (save-buffer))) - (message "Saved %d buffers" (length buffer-edits))) + (message "Saved %d buffers" (length buffer-edits)) + nil) (t - (message "%d hunks failed; no buffers changed" failures))))) + (message (ngettext "%d hunk failed; no buffers changed" + "%d hunks failed; no buffers changed" + failures) + failures) + failures)))) (defalias 'diff-mouse-goto-source #'diff-goto-source) @@ -2108,6 +2203,55 @@ revision of the file otherwise." (goto-char (+ (car pos) (cdr src))) (when buffer (next-error-found buffer (current-buffer)))))) +(defun diff-kill-ring-save (beg end &optional reverse) + "Save to `kill-ring' the result of applying diffs in region between BEG and END. +By default the command will copy the text that applying the diff would +produce, along with the text between hunks. If REVERSE is non-nil, or +the command was invoked with a prefix argument, copy the lines that the +diff would remove (beginning with \"+\" or \"<\")." + (interactive + (append (if (use-region-p) + (list (region-beginning) (region-end)) + (save-excursion + (list (diff-beginning-of-hunk) + (diff-end-of-hunk)))) + (list current-prefix-arg))) + (unless (derived-mode-p 'diff-mode) + (user-error "Command can only be invoked in a diff-buffer")) + (let ((parts '())) + (save-excursion + (goto-char beg) + (catch 'break + (while t + (let ((hunk (diff-hunk-text + (buffer-substring + (save-excursion (diff-beginning-of-hunk)) + (save-excursion (min (diff-end-of-hunk) end))) + (not reverse) + (save-excursion + (- (point) (diff-beginning-of-hunk)))))) + (push (substring (car hunk) (cdr hunk)) + parts)) + ;; check if we have copied everything + (diff-end-of-hunk) + (when (<= end (point)) (throw 'break t)) + ;; copy the text between hunks + (let ((inhibit-message t) start) + (save-window-excursion + (save-excursion + (forward-line -1) + ;; FIXME: Detect if the line we jump to doesn't match + ;; the line in the diff. + (diff-goto-source t) + (forward-line +1) + (setq start (point)))) + (save-window-excursion + (diff-goto-source t) + (push (buffer-substring start (point)) + parts)))))) + (kill-new (string-join (nreverse parts))) + (setq deactivate-mark t) + (message (if reverse "Copied original text" "Copied modified text")))) (defun diff-current-defun () "Find the name of function at point. @@ -3082,6 +3226,17 @@ hunk text is not found in the source file." ;;;###autoload (defun diff-vc-deduce-fileset () + (when (buffer-narrowed-p) + ;; If user used `diff-restrict-view' then we may not have the + ;; file header, and the commit will not succeed (bug#73387). + (user-error "Cannot commit patch when narrowed; consider %s" + (mapconcat (lambda (c) + (key-description + (where-is-internal c nil t))) + '(widen + diff-delete-other-hunks + vc-next-action) + " "))) (let ((backend (vc-responsible-backend default-directory)) files) (save-excursion diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index 72dae9b678f..085ee9140f5 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -567,9 +567,8 @@ If nil, differences are highlighted using ASCII flags, ediff-before-flag and ediff-after-flag. On a non-window system, differences are always highlighted using ASCII flags." :type 'boolean + :local 'permanent :group 'ediff-highlighting) -(make-variable-buffer-local 'ediff-use-faces) -(put 'ediff-use-faces 'permanent-local t) ;; this indicates that diff regions are word-size, so fine diffs are ;; permanently nixed; used in ediff-windows-wordwise and ediff-regions-wordwise @@ -611,9 +610,8 @@ reverses the meaning of this variable." Otherwise, all difference regions are highlighted, but the selected region is shown in brighter colors." :type 'boolean + :local 'permanent :group 'ediff-highlighting) -(make-variable-buffer-local 'ediff-highlight-all-diffs) -(put 'ediff-highlight-all-diffs 'permanent-local t) (ediff-defvar-local ediff-control-buffer-suffix nil @@ -1200,8 +1198,8 @@ save. Anything else means save automatically only if the merge job is part of a group of jobs, such as `ediff-merge-directory' or `ediff-merge-directory-revisions'." :type '(choice (const nil) (const t) (const group-jobs-only)) + :local t :group 'ediff-merge) -(make-variable-buffer-local 'ediff-autostore-merges) (ediff-defvar-local ediff-merge-store-file nil "File where the result of the merge is to be saved. Internal.") diff --git a/lisp/vc/ediff-merg.el b/lisp/vc/ediff-merg.el index 606c23cb8aa..294880a4c49 100644 --- a/lisp/vc/ediff-merg.el +++ b/lisp/vc/ediff-merg.el @@ -73,9 +73,8 @@ STRING4" This means that regions that have status prefer-A or prefer-B will be skipped over. A value of nil means show all regions." :type 'boolean - :group 'ediff-merge - ) -(make-variable-buffer-local 'ediff-show-clashes-only) + :local t + :group 'ediff-merge) (defcustom ediff-skip-merge-regions-that-differ-from-default nil "If t, show only the regions that have not been changed by the user. @@ -87,9 +86,8 @@ A region is considered to have been changed also when it is marked as Buffer A or if it is marked as `prefer-B' and is different from the region in Buffer B." :type 'boolean - :group 'ediff-merge - ) -(make-variable-buffer-local 'ediff-skip-merge-regions-that-differ-from-default) + :local t + :group 'ediff-merge) (defvar state-of-merge) ; dynamic var diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index 597d8a5e643..6038f3eae30 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -1890,8 +1890,8 @@ current point position in the specified buffer." (defun ediff-diff-to-diff (arg &optional keys) "Copy buffer-X'th difference region to buffer Y (X,Y are A, B, or C). -With numerical prefix argument ARG, copy the difference specified -in the arg. +With numerical prefix argument ARG, copy the difference specified in the +arg. With prefix `\\[universal-argument]', copy all differences. Otherwise, copy the difference given by `ediff-current-difference'. This command assumes it is bound to a 2-character key sequence, `ab', `ba', `ac', etc., which is used to determine the types of buffers to be used for @@ -1904,17 +1904,23 @@ command keys." (interactive "P") (ediff-barf-if-not-control-buffer) (or keys (setq keys (this-command-keys))) - (if (eq arg '-) (setq arg -1)) ; translate neg arg to -1 - (if (numberp arg) (ediff-jump-to-difference arg)) - - (let* ((char1 (aref keys 0)) - (char2 (aref keys 1)) - ediff-verbose-p) - (ediff-copy-diff ediff-current-difference - (ediff-char-to-buftype char1) - (ediff-char-to-buftype char2)) - ;; recenter with rehighlighting, but no messages - (ediff-recenter))) + (if (equal arg '(4)) + ;; copy all differences with `C-u' prefix + (let ((n 0)) + (while (ediff-valid-difference-p n) + (ediff-diff-to-diff (1+ n) keys) + (setq n (1+ n)))) + (if (eq arg '-) (setq arg -1)) ; translate neg arg to -1 + (if (numberp arg) (ediff-jump-to-difference arg)) + + (let* ((char1 (aref keys 0)) + (char2 (aref keys 1)) + ediff-verbose-p) + (ediff-copy-diff ediff-current-difference + (ediff-char-to-buftype char1) + (ediff-char-to-buftype char2)) + ;; recenter with rehighlighting, but no messages + (ediff-recenter)))) (defun ediff-copy-A-to-B (arg) "Copy ARGth difference region from buffer A to B. diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 3c4eadb59a1..9dcc8c89526 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -246,7 +246,11 @@ when this variable is set to nil.") (defvar log-edit-initial-files nil) (defvar log-edit-callback nil) (defvar log-edit-diff-function - (lambda () (error "Diff functionality has not been set up"))) + (lambda () (error "Diff functionality has not been set up")) + "Function to display an appropriate `diff-mode' buffer for the change. +Called by the `log-edit-show-diff' command. +Should not leave the `diff-mode' buffer's window selected; that is, the +Log Edit buffer's window should be selected when the function returns.") (defvar log-edit-listfun nil) (defvar log-edit-parent-buffer nil) @@ -890,6 +894,14 @@ different header separator appropriate for `log-edit-mode'." (zerop (forward-line 1)))) (eobp)))) +(defun log-edit--make-header-line (header &optional value) + ;; Make \\`C-a' work like it does in other buffers with header names. + (concat (propertize (concat header ": ") + 'field 'header + 'rear-nonsticky t) + value + "\n")) + (defun log-edit-insert-message-template () "Insert the default VC commit log template with Summary and Author." (interactive) @@ -897,11 +909,8 @@ different header separator appropriate for `log-edit-mode'." (log-edit-empty-buffer-p)) (dolist (header (append '("Summary") (and log-edit-setup-add-author '("Author")))) - ;; Make `C-a' work like in other buffers with header names. - (insert (propertize (concat header ": ") - 'field 'header - 'rear-nonsticky t) - "\n")) + + (insert (log-edit--make-header-line header))) (insert "\n") (message-position-point))) @@ -1315,7 +1324,7 @@ If TOGGLE is non-nil, and the value of HEADER already is VALUE, clear it. Make sure there is an empty line after the headers. Return t if toggled on (or TOGGLE is nil), otherwise nil." (let ((val t) - (line (concat header ": " value "\n"))) + (line (log-edit--make-header-line header value))) (save-excursion (save-restriction (rfc822-goto-eoh) diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index e9e6602e414..a54854a7016 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -111,6 +111,7 @@ (require 'pcvs-util) (require 'easy-mmode) +(require 'log-edit) (autoload 'vc-find-revision "vc") (autoload 'vc-diff-internal "vc") @@ -543,11 +544,43 @@ If called interactively, visit the version at point." (defun log-view-modify-change-comment () "Edit the change comment displayed at point." (interactive) - (vc-modify-change-comment (list (if log-view-per-file-logs - (log-view-current-file) - (car log-view-vc-fileset))) - (log-view-current-tag) - (log-view-extract-comment))) + (let* ((files (list (if log-view-per-file-logs + (log-view-current-file) + (car log-view-vc-fileset)))) + (rev (log-view-current-tag)) + ;; `log-view-extract-comment' is the legacy code for this; the + ;; `get-change-comment' backend action is the new way to do it. + ;; + ;; FIXME: Eventually the older backends should have + ;; implementations of `get-change-comment' because that ought + ;; to be more robust than the approach taken by + ;; `log-view-extract-comment'. Then we can delete the latter. + ;; See discussion in bug#64055. --spwhitton + ;; + ;; FIXME: We should implement backend actions + ;; `get-change-comment' and `modify-change-comment' for bzr and + ;; Hg, so that this command works for those backends. + ;; As discussed in bug#64055, `get-change-comment' is required, + ;; and parsing the old comment out of the Log View buffer will + ;; not do. This is because for these backends there are + ;; `vc-*-log-switches' variables which can change what gets put + ;; in the Log View buffers and break any Lisp parsing attempt. + (comment (condition-case _ + (vc-call-backend log-view-vc-backend + 'get-change-comment files rev) + (vc-not-supported (log-view-extract-comment))))) + (when (memq 'log-edit-insert-message-template log-edit-hook) + (let* ((first-newline (string-match "\n" comment)) + (summary (substring comment 0 first-newline)) + (rest (and first-newline + (substring comment (1+ first-newline))))) + (setq comment + ;; As we are part of the VC subsystem I think we are + ;; entitled to call a \\`log-edit--' function. + ;; --spwhitton + (concat (log-edit--make-header-line "Summary" summary) + (if (length> rest 0) rest "\n"))))) + (vc-modify-change-comment files rev comment))) (defun log-view-annotate-version (pos) "Annotate the version at POS. diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index a16c7871ff9..09d9ebda21b 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -81,7 +81,7 @@ Used in `smerge-diff-base-upper' and related functions." (((class color) (min-colors 88) (background dark)) :background "#553333" :extend t) (((class color)) - :foreground "red" :extend)) + :foreground "red" :extend t)) "Face for the `upper' version of a conflict.") (define-obsolete-face-alias 'smerge-mine 'smerge-upper "26.1") (defvar smerge-upper-face 'smerge-upper) @@ -92,7 +92,7 @@ Used in `smerge-diff-base-upper' and related functions." (((class color) (min-colors 88) (background dark)) :background "#335533" :extend t) (((class color)) - :foreground "green" :extend)) + :foreground "green" :extend t)) "Face for the `lower' version of a conflict.") (define-obsolete-face-alias 'smerge-other 'smerge-lower "26.1") (defvar smerge-lower-face 'smerge-lower) @@ -168,6 +168,10 @@ Used in `smerge-diff-base-upper' and related functions." (const :tag "none" "") string)) +;; Make it so `C-c ^ n' doesn't insert `n' but just signals an error +;; when SMerge mode is not enabled (bug#73544). +;;;###autoload (global-set-key "\C-c^" (make-sparse-keymap)) + (defvar-keymap smerge-mode-map (key-description smerge-command-prefix) smerge-basic-map) @@ -1240,7 +1244,7 @@ spacing of the \"Lower\" chunk." (write-region beg2 end2 file2 nil 'nomessage) (unwind-protect (save-current-buffer - (if-let (buffer (get-buffer smerge-diff-buffer-name)) + (if-let* ((buffer (get-buffer smerge-diff-buffer-name))) (set-buffer buffer) (set-buffer (get-buffer-create smerge-diff-buffer-name)) (setq buffer-read-only t)) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index d733b36f8ff..4e1b1831389 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1456,9 +1456,9 @@ These are the commands available for use in the file status buffer: (let ((use-vc-backend backend)) (vc-dir-mode) ;; Activate the backend-specific minor mode, if any. - (when-let ((minor-mode - (intern-soft (format "vc-dir-%s-mode" - (downcase (symbol-name backend)))))) + (when-let* ((minor-mode + (intern-soft (format "vc-dir-%s-mode" + (downcase (symbol-name backend)))))) (funcall minor-mode 1))))) (defun vc-default-dir-extra-headers (_backend _dir) diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 998cef649ff..c4a2b252cb0 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -460,7 +460,7 @@ Display the buffer in some window, but don't select it." args)))) (setq proc (apply #'vc-do-command t 'async command nil args)))) (unless vc--inhibit-async-window - (when-let ((window (display-buffer buffer))) + (when-let* ((window (display-buffer buffer))) (set-window-start window new-window-start))) proc)) @@ -685,10 +685,12 @@ NOT-URGENT means it is ok to continue if the user says not to save." ;; Set up key bindings for use while editing log messages (declare-function log-edit-empty-buffer-p "log-edit" ()) +(declare-function log-edit-diff-fileset "log-edit" ()) +(declare-function log-edit-diff-patch "log-edit" ()) (defvar vc-patch-string) -(defun vc-log-edit (fileset mode backend) +(defun vc-log-edit (fileset mode backend &optional diff-function) "Set up `log-edit' for use on FILE." (setq default-directory (buffer-local-value 'default-directory vc-parent-buffer)) @@ -718,7 +720,9 @@ NOT-URGENT means it is ok to continue if the user says not to save." (lambda (file) (file-relative-name file root)) fileset)))) (log-edit-diff-function - . ,(if vc-patch-string 'log-edit-diff-patch 'log-edit-diff-fileset)) + . ,(cond (diff-function) + (vc-patch-string #'log-edit-diff-patch) + (t #'log-edit-diff-fileset))) (log-edit-vc-backend . ,backend) (vc-log-fileset . ,fileset) (vc-patch-string . ,vc-patch-string)) @@ -727,7 +731,7 @@ NOT-URGENT means it is ok to continue if the user says not to save." (set-buffer-modified-p nil) (setq buffer-file-name nil)) -(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook backend patch-string) +(defun vc-start-logentry (files comment initial-contents msg logbuf mode action &optional after-hook backend patch-string diff-function) "Accept a comment for an operation on FILES. If COMMENT is nil, pop up a LOGBUF buffer, emit MSG, and set the action on close to ACTION. If COMMENT is a string and @@ -740,15 +744,14 @@ empty comment. Remember the file's buffer in `vc-parent-buffer' MODE, defaulting to `log-edit-mode' if MODE is nil. AFTER-HOOK specifies the local value for `vc-log-after-operation-hook'. BACKEND, if non-nil, specifies a VC backend for the Log Edit buffer. -PATCH-STRING is a patch to check in." - (let ((parent - (if (vc-dispatcher-browsing) - ;; If we are called from a directory browser, the parent buffer is - ;; the current buffer. - (current-buffer) - (if (and files (equal (length files) 1)) - (get-file-buffer (car files)) - (current-buffer))))) +PATCH-STRING is a patch to check in. +DIFF-FUNCTION is `log-edit-diff-function' for the Log Edit buffer." + (let ((parent (if (and (length= files 1) + (not (vc-dispatcher-browsing))) + (get-file-buffer (car files)) + (current-buffer)))) + (unless parent + (error "Unable to determine VC parent buffer")) (if (and comment (not initial-contents)) (set-buffer (get-buffer-create logbuf)) (pop-to-buffer (get-buffer-create logbuf))) @@ -757,7 +760,7 @@ PATCH-STRING is a patch to check in." (concat " from " (buffer-name vc-parent-buffer))) (when patch-string (setq-local vc-patch-string patch-string)) - (vc-log-edit files mode backend) + (vc-log-edit files mode backend diff-function) (make-local-variable 'vc-log-after-operation-hook) (when after-hook (setq vc-log-after-operation-hook after-hook)) @@ -827,7 +830,8 @@ the buffer contents as a comment." "Are we in a directory browser buffer?" (or (derived-mode-p 'vc-dir-mode) (derived-mode-p 'dired-mode) - (derived-mode-p 'diff-mode))) + (derived-mode-p 'diff-mode) + (derived-mode-p 'log-view-mode))) ;; These are unused. ;; (defun vc-dispatcher-in-fileset-p (fileset) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 61f1db527ad..da3be93fc9c 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -67,6 +67,7 @@ ;; - merge-news (file) see `merge-file' ;; - mark-resolved (files) OK ;; - steal-lock (file &optional revision) NOT NEEDED +;; - get-change-comment (files rev) OK ;; HISTORY FUNCTIONS ;; * print-log (files buffer &optional shortlog start-revision limit) OK ;; * log-outgoing (buffer remote-location) OK @@ -167,10 +168,10 @@ uses a full scan)." (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 -removed. If the value is `unstage-maybe', and no merge is in -progress, then after the last conflict is resolved, also clear -the staging area." +That is performed after all conflict markers in it have been removed. +If the value is `unstage-maybe', and no merge, rebase or similar +operation is in progress, then after the last conflict is resolved, also +clear the staging area." :type '(choice (const :tag "Don't resolve" nil) (const :tag "Resolve" t) (const :tag "Resolve and maybe unstage all files" @@ -315,11 +316,21 @@ Good example of file name that needs this: \"test[56].xx\".") (defvar vc-git--program-version nil) +(connection-local-set-profile-variables + 'vc-git-connection-default-profile + '((vc-git--program-version . nil))) + +(connection-local-set-profiles + '(:application vc-git) + 'vc-git-connection-default-profile) + (defun vc-git--program-version () - (or vc-git--program-version - (let ((version-string - (vc-git--run-command-string nil "version"))) - (setq vc-git--program-version + (with-connection-local-application-variables 'vc-git + (or vc-git--program-version + (let ((version-string + (vc-git--run-command-string nil "version"))) + (setq-connection-local + vc-git--program-version (if (and version-string ;; Some Git versions append additional strings ;; to the numerical version string. E.g., Git @@ -329,7 +340,7 @@ Good example of file name that needs this: \"test[56].xx\".") (string-match "git version \\([0-9][0-9.]+\\)" version-string)) (string-trim-right (match-string 1 version-string) "\\.") - "0"))))) + "0")))))) (defun vc-git--git-path (&optional path) "Resolve .git/PATH for the current working tree. @@ -717,6 +728,74 @@ or an empty string if none." :files files :update-function update-function))) +(defun vc-git--current-branch () + (vc-git--out-match '("symbolic-ref" "HEAD") + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + +(defun vc-git-dir--branch-headers () + "Return headers for branch-related information." + (let ((branch (vc-git--current-branch)) + tracking remote-url) + (if branch + (when-let* ((branch-merge + (vc-git--out-match + `("config" ,(concat "branch." branch ".merge")) + "^\\(refs/heads/\\)?\\(.+\\)$" 2)) + (branch-remote + (vc-git--out-match + `("config" ,(concat "branch." branch ".remote")) + "\\([^\n]+\\)" 1))) + (if (string= branch-remote ".") + (setq tracking branch-merge + remote-url "none (tracking local branch)") + (setq tracking (concat branch-remote "/" branch-merge) + remote-url (vc-git-repository-url + default-directory branch-remote)))) + (setq branch "none (detached HEAD)")) + (cl-flet ((fmt (key value) + (concat + (propertize (format "% -11s: " key) 'face 'vc-dir-header) + (propertize value 'face 'vc-dir-header-value)))) + (remove nil (list + (fmt "Branch" branch) + (and tracking (fmt "Tracking" tracking)) + (and remote-url (fmt "Remote" remote-url))))))) + +(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 (file-exists-p (expand-file-name "REVERT_HEAD" gitdir)) + (push 'revert cmds)) + (when (file-exists-p (expand-file-name "CHERRY_PICK_HEAD" gitdir)) + (push 'cherry-pick cmds)) + (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--in-progress-headers () + "Return headers for Git commands in progress in this worktree." + (let ((cmds (vc-git--cmds-in-progress))) + (cl-flet ((fmt (cmd name) + (when (memq cmd cmds) + ;; For now just a heading, key bindings can be added + ;; later for various bisect actions. + (propertize (format "% -11s: in progress" name) + 'face 'vc-dir-status-warning)))) + (remove nil (list (fmt 'bisect "Bisect") + (fmt 'rebase "Rebase")))))) + (defvar-keymap vc-git-stash-shared-map "S" #'vc-git-stash-snapshot "C" #'vc-git-stash) @@ -797,130 +876,75 @@ 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--stash-headers () + "Return headers describing the current stashes." + (list + (concat + (propertize "Stash : " 'face 'vc-dir-header) + (if-let* ((stash-list (vc-git-stash-list))) + (let* ((len (length stash-list)) + (limit + (if (integerp vc-git-show-stash) + (min vc-git-show-stash len) + len)) + (shown-stashes (cl-subseq stash-list 0 limit)) + (hidden-stashes (cl-subseq stash-list limit)) + (all-hideable (or (eq vc-git-show-stash t) + (<= len vc-git-show-stash)))) + (concat + ;; Button to toggle visibility. + (if all-hideable + (vc-git-make-stash-button nil limit limit) + (vc-git-make-stash-button t vc-git-show-stash len)) + ;; Stash list. + (when shown-stashes + (concat + (propertize "\n" + 'vc-git-hideable all-hideable) + (mapconcat + (lambda (x) + (propertize x + 'face 'vc-dir-header-value + 'mouse-face 'highlight + 'vc-git-hideable all-hideable + 'help-echo vc-git-stash-list-help + 'keymap vc-git-stash-map)) + shown-stashes + (propertize "\n" + 'vc-git-hideable all-hideable)))) + (when hidden-stashes + (concat + (propertize "\n" + 'invisible t + 'vc-git-hideable t) + (mapconcat + (lambda (x) + (propertize x + 'face 'vc-dir-header-value + 'mouse-face 'highlight + 'invisible t + 'vc-git-hideable t + 'help-echo vc-git-stash-list-help + 'keymap vc-git-stash-map)) + hidden-stashes + (propertize "\n" + 'invisible t + 'vc-git-hideable t)))))) + (propertize "Nothing stashed" + 'help-echo vc-git-stash-shared-help + 'keymap vc-git-stash-shared-map + 'face 'vc-dir-header-value))))) (defun vc-git-dir-extra-headers (dir) - (let ((str (vc-git--out-str "symbolic-ref" "HEAD")) - (stash-list (vc-git-stash-list)) - (default-directory dir) - (in-progress (vc-git--cmds-in-progress)) - - branch remote-url stash-button stash-string tracking-branch) - (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) - (progn - (setq branch (match-string 2 str)) - (let ((remote (vc-git--out-str - "config" (concat "branch." branch ".remote"))) - (merge (vc-git--out-str - "config" (concat "branch." branch ".merge")))) - (when (string-match "\\([^\n]+\\)" remote) - (setq remote (match-string 1 remote))) - (when (string-match "^\\(refs/heads/\\)?\\(.+\\)$" merge) - (setq tracking-branch (match-string 2 merge))) - (pcase remote - ("." - (setq remote-url "none (tracking local branch)")) - ((pred (not string-empty-p)) - (setq - remote-url (vc-git-repository-url dir remote) - tracking-branch (concat remote "/" tracking-branch)))))) - (setq branch "none (detached HEAD)")) - (when stash-list - (let* ((len (length stash-list)) - (limit - (if (integerp vc-git-show-stash) - (min vc-git-show-stash len) - len)) - (shown-stashes (cl-subseq stash-list 0 limit)) - (hidden-stashes (cl-subseq stash-list limit)) - (all-hideable (or (eq vc-git-show-stash t) - (<= len vc-git-show-stash)))) - (setq stash-button (if all-hideable - (vc-git-make-stash-button nil limit limit) - (vc-git-make-stash-button t vc-git-show-stash len)) - stash-string - (concat - (when shown-stashes - (concat - (propertize "\n" - 'vc-git-hideable all-hideable) - (mapconcat - (lambda (x) - (propertize x - 'face 'vc-dir-header-value - 'mouse-face 'highlight - 'vc-git-hideable all-hideable - 'help-echo vc-git-stash-list-help - 'keymap vc-git-stash-map)) - shown-stashes - (propertize "\n" - 'vc-git-hideable all-hideable)))) - (when hidden-stashes - (concat - (propertize "\n" - 'invisible t - 'vc-git-hideable t) - (mapconcat - (lambda (x) - (propertize x - 'face 'vc-dir-header-value - 'mouse-face 'highlight - 'invisible t - 'vc-git-hideable t - 'help-echo vc-git-stash-list-help - 'keymap vc-git-stash-map)) - hidden-stashes - (propertize "\n" - 'invisible t - 'vc-git-hideable t)))))))) - (concat - (propertize "Branch : " 'face 'vc-dir-header) - (propertize branch - 'face 'vc-dir-header-value) - (when tracking-branch - (concat - "\n" - (propertize "Tracking : " 'face 'vc-dir-header) - (propertize tracking-branch 'face 'vc-dir-header-value))) - (when remote-url - (concat - "\n" - (propertize "Remote : " 'face 'vc-dir-header) - (propertize remote-url - 'face 'vc-dir-header-value))) - ;; For now just a heading, key bindings can be added later for various bisect actions - (when (memq 'bisect in-progress) - (propertize "\nBisect : in progress" 'face 'vc-dir-status-warning)) - (when (memq 'rebase in-progress) - (propertize "\nRebase : in progress" 'face 'vc-dir-status-warning)) - (if stash-list - (concat - (propertize "\nStash : " 'face 'vc-dir-header) - stash-button - stash-string) - (concat - (propertize "\nStash : " 'face 'vc-dir-header) - (propertize "Nothing stashed" - 'help-echo vc-git-stash-shared-help - 'keymap vc-git-stash-shared-map - 'face 'vc-dir-header-value)))))) + (let ((default-directory dir)) + (string-join + (append + ;; Each helper returns a list of headers. Each header must be a + ;; propertized string with no final newline. + (vc-git-dir--branch-headers) + (vc-git-dir--in-progress-headers) + (vc-git-dir--stash-headers)) + "\n"))) (defun vc-git-branches () "Return the existing branches, as a list of strings. @@ -1020,12 +1044,9 @@ See `vc-git-log-edit-summary-max-len'.") "Toggle whether this will amend the previous commit. If toggling on, also insert its message into the buffer." (interactive) - (log-edit--toggle-amend - (lambda () - (with-output-to-string - (vc-git-command - standard-output 1 nil - "log" "--max-count=1" "--pretty=format:%B" "HEAD"))))) + (vc-git--assert-allowed-rewrite (vc-git--rev-parse "HEAD")) + (log-edit--toggle-amend (lambda () + (vc-git-get-change-comment nil "HEAD")))) (defvar-keymap vc-git-log-edit-mode-map :name "Git-Log-Edit" @@ -1035,19 +1056,19 @@ If toggling on, also insert its message into the buffer." (defun vc-git--log-edit-summary-check (limit) (and (re-search-forward "^Summary: " limit t) - (when-let ((regex - (cond ((and (natnump vc-git-log-edit-summary-max-len) - (natnump vc-git-log-edit-summary-target-len)) - (format ".\\{,%d\\}\\(.\\{,%d\\}\\)\\(.*\\)" - vc-git-log-edit-summary-target-len - (- vc-git-log-edit-summary-max-len - vc-git-log-edit-summary-target-len))) - ((natnump vc-git-log-edit-summary-max-len) - (format ".\\{,%d\\}\\(?2:.*\\)" - vc-git-log-edit-summary-max-len)) - ((natnump vc-git-log-edit-summary-target-len) - (format ".\\{,%d\\}\\(.*\\)" - vc-git-log-edit-summary-target-len))))) + (when-let* ((regex + (cond ((and (natnump vc-git-log-edit-summary-max-len) + (natnump vc-git-log-edit-summary-target-len)) + (format ".\\{,%d\\}\\(.\\{,%d\\}\\)\\(.*\\)" + vc-git-log-edit-summary-target-len + (- vc-git-log-edit-summary-max-len + vc-git-log-edit-summary-target-len))) + ((natnump vc-git-log-edit-summary-max-len) + (format ".\\{,%d\\}\\(?2:.*\\)" + vc-git-log-edit-summary-max-len)) + ((natnump vc-git-log-edit-summary-target-len) + (format ".\\{,%d\\}\\(.*\\)" + vc-git-log-edit-summary-target-len))))) (re-search-forward regex limit t)))) (define-derived-mode vc-git-log-edit-mode log-edit-mode "Log-Edit/git" @@ -1068,6 +1089,17 @@ It is based on `log-edit-mode', and has Git-specific extensions." (autoload 'vc-switches "vc") +(defun vc-git--log-edit-extract-headers (comment) + (cl-flet ((boolean-arg-fn (argument) + (lambda (v) (and (equal v "yes") (list argument))))) + (log-edit-extract-headers + `(("Author" . "--author") + ("Date" . "--date") + ("Amend" . ,(boolean-arg-fn "--amend")) + ("No-Verify" . ,(boolean-arg-fn "--no-verify")) + ("Sign-Off" . ,(boolean-arg-fn "--signoff"))) + comment))) + (defun vc-git-checkin (files comment &optional _rev) (let* ((file1 (or (car files) default-directory)) (root (vc-git-root file1)) @@ -1166,31 +1198,23 @@ It is based on `log-edit-mode', and has Git-specific extensions." (vc-git-command nil 0 patch-file "apply" "--cached") (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))))) - ;; When operating on the whole tree, better pass "-a" than ".", since "." - ;; fails when we're committing a merge. - (apply #'vc-git-command nil 0 (if (and only (not vc-git-patch-string)) files) - (nconc (if msg-file (list "commit" "-F" - (file-local-name msg-file)) - (list "commit" "-m")) - (let ((args - (log-edit-extract-headers - `(("Author" . "--author") - ("Date" . "--date") - ("Amend" . ,(boolean-arg-fn "--amend")) - ("No-Verify" . ,(boolean-arg-fn "--no-verify")) - ("Sign-Off" . ,(boolean-arg-fn "--signoff"))) - comment))) - (when msg-file - (let ((coding-system-for-write - (or pcsw vc-git-commits-coding-system))) - (write-region (car args) nil msg-file)) - (setq args (cdr args))) - args) - (unless vc-git-patch-string - (if only (list "--only" "--") '("-a")))))) + ;; When operating on the whole tree, better pass "-a" than ".", + ;; since "." fails when we're committing a merge. + (apply #'vc-git-command nil 0 + (if (and only (not vc-git-patch-string)) files) + (nconc (if msg-file (list "commit" "-F" + (file-local-name msg-file)) + (list "commit" "-m")) + (let ((args + (vc-git--log-edit-extract-headers comment))) + (when msg-file + (let ((coding-system-for-write + (or pcsw vc-git-commits-coding-system))) + (write-region (car args) nil msg-file)) + (setq args (cdr args))) + args) + (unless vc-git-patch-string + (if only (list "--only" "--") '("-a"))))) (if (and msg-file (file-exists-p msg-file)) (delete-file msg-file)) (when to-stash (let ((cached (make-nearby-temp-file "git-cached"))) @@ -1399,8 +1423,14 @@ This prompts for a branch to merge from." (vc-git-command nil 0 buffer-file-name "add") (unless (or (not (eq vc-git-resolve-conflicts 'unstage-maybe)) - ;; Doing a merge, so bug#20292 doesn't apply. - (file-exists-p (vc-git--git-path "MERGE_HEAD")) + ;; Doing a merge or rebase-like operation, so bug#20292 + ;; doesn't apply. + ;; + ;; If we were to 'git reset' in the middle of a + ;; cherry-pick, for example, it would effectively abort + ;; the cherry-pick, losing the user's progress. + (cl-intersection '(merge rebase am revert cherry-pick) + (vc-git--cmds-in-progress)) (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) @@ -1941,6 +1971,95 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defun vc-git-mark-resolved (files) (vc-git-command nil 0 files "add")) +(defun vc-git-get-change-comment (_files rev) + (with-output-to-string + (vc-git-command standard-output 1 nil + "log" "--max-count=1" "--pretty=format:%B" rev))) + +(defun vc-git--assert-allowed-rewrite (rev) + (when (and (not (and vc-allow-rewriting-published-history + (not (eq vc-allow-rewriting-published-history 'ask)))) + ;; Check there is an upstream. + (with-temp-buffer + (vc-git--out-ok "config" "--get" + (format "branch.%s.merge" + (vc-git--current-branch))))) + (let ((outgoing (split-string + (with-output-to-string + (vc-git-command standard-output 0 nil "log" + "--pretty=format:%H" + "@{upstream}..HEAD"))))) + (unless (or (cl-member rev outgoing :test #'string-prefix-p) + (and (eq vc-allow-rewriting-published-history 'ask) + (yes-or-no-p + (format "\ +Commit %s appears published; allow rewriting history?" + rev)))) + (user-error "\ +Will not rewrite likely-public history; see option `vc-allow-rewriting-published-history'"))))) + +(defun vc-git-modify-change-comment (files rev comment) + (vc-git--assert-allowed-rewrite rev) + (let* ((args (delete "--amend" + (vc-git--log-edit-extract-headers comment))) + (message (format "amend! %s\n\n%s" rev (pop args))) + (msg-file + ;; On MS-Windows, pass the message through a file, to work + ;; around how command line arguments must be in the system + ;; codepage, and therefore might not support non-ASCII. + ;; + ;; As our other arguments are static, we need not be concerned + ;; about the encoding of command line arguments in general. + ;; See `vc-git-checkin' for the more complex case. + (and (eq system-type 'windows-nt) + (let ((default-directory + (or (file-name-directory (or (car files) + default-directory)) + default-directory))) + (make-nearby-temp-file "git-msg"))))) + (unwind-protect + (progn + (when (cl-intersection '("--author" "--date") args + :test #'string=) + ;; 'git rebase --autosquash' cannot alter authorship. + ;; See the description of --fixup in git-commit(1). + (error +"Author: and Date: not supported when modifying existing commits")) + + ;; Check that a rebase with --autosquash won't make changes + ;; other than to REV's change comment. With the prompt here + ;; it's okay to assume the user knows what --autosquash is + ;; because they've made some squash!/fixup!/amend! commits. + (when + (and (split-string + (with-output-to-string + (vc-git-command standard-output 0 nil + "log" "--oneline" "-E" + "--grep" "^(squash|fixup|amend)! " + (format "%s~1.." rev)))) + (not (yes-or-no-p "\ +Rebase may --autosquash your other squash!/fixup!/amend!; proceed?"))) + (user-error "Aborted")) + + (when msg-file + (let ((coding-system-for-write + (or coding-system-for-write + vc-git-commits-coding-system))) + (write-region message nil msg-file))) + ;; Regardless of the state of the index and working tree, this + ;; will always create an empty commit, thanks to --only. + (apply #'vc-git-command nil 0 nil + "commit" "--only" "--allow-empty" + (nconc (if msg-file + (list "-F" (file-local-name msg-file)) + (list "-m" message)) + args))) + (when (and msg-file (file-exists-p msg-file)) + (delete-file msg-file)))) + (with-environment-variables (("GIT_SEQUENCE_EDITOR" "true")) + (vc-git-command nil 0 nil "rebase" "--autostash" "--autosquash" "-i" + (format "%s~1" rev)))) + (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] @@ -2058,36 +2177,60 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) +(declare-function vc-deduce-fileset "vc" + (&optional observer allow-unregistered + state-model-only-files)) + (autoload 'vc-dir-marked-files "vc-dir") +(defun vc-git--deduce-files-for-stash () + ;; In *vc-dir*, if nothing is marked, act on the whole working tree + ;; regardless of the position of point. This preserves historical + ;; behavior and is also probably more useful. + (if (derived-mode-p 'vc-dir-mode) + (vc-dir-marked-files) + (cadr (vc-deduce-fileset)))) + (defun vc-git-stash (name) - "Create a stash given the name NAME." + "Create a stash named NAME. +In `vc-dir-mode', if there are files marked, stash the changes to those. +If no files are marked, stash all uncommitted changes to tracked files. +In other modes, call `vc-deduce-fileset' to determine files to stash." (interactive "sStash name: ") (let ((root (vc-git-root default-directory))) (when root (apply #'vc-git--call nil "stash" "push" "-m" name - (when (derived-mode-p 'vc-dir-mode) - (vc-dir-marked-files))) + (vc-git--deduce-files-for-stash)) (vc-resynch-buffer root t t)))) (defvar vc-git-stash-read-history nil "History for `vc-git-stash-read'.") -(defun vc-git-stash-read (prompt) - "Read a Git stash. PROMPT is a string to prompt with." - (let ((stash (completing-read - prompt - (split-string - (or (vc-git--run-command-string nil "stash" "list") "") "\n" t) - nil :require-match nil 'vc-git-stash-read-history))) - (if (string-equal stash "") - (user-error "Not a stash") - (string-match "^stash@{[[:digit:]]+}" stash) - (match-string 0 stash)))) +(cl-defun vc-git-stash-read (prompt &key default-most-recent) + "Prompt the user, with PROMPT, to select a git stash. +PROMPT is passed to `format-prompt'. If DEFAULT-MOST-RECENT is non-nil, +then the most recently pushed stash is the default selection." + (if-let* ((stashes + (split-string (vc-git--run-command-string nil + "stash" "list") + "\n" t))) + (let* ((default (and default-most-recent (car stashes))) + (prompt (format-prompt prompt + (and default-most-recent + "most recent, stash@{0}"))) + (stash (completing-read prompt stashes + nil :require-match nil + 'vc-git-stash-read-history + default))) + (if (string-empty-p stash) + (user-error "Not a stash") + (string-match "^stash@{[[:digit:]]+}" stash) + (match-string 0 stash))) + (user-error "No stashes"))) (defun vc-git-stash-show (name) "Show the contents of stash NAME." - (interactive (list (vc-git-stash-read "Show stash: "))) + (interactive (list (vc-git-stash-read "Show stash"))) (vc-setup-buffer "*vc-git-stash*") (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "--color=never" "-p" name) @@ -2098,32 +2241,39 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-stash-apply (name) "Apply stash NAME." - (interactive (list (vc-git-stash-read "Apply stash: "))) + (interactive (list (vc-git-stash-read "Apply stash"))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-pop (name) "Pop stash NAME." - (interactive (list (vc-git-stash-read "Pop stash: "))) + ;; Stashes are commonly popped off in reverse order, so pass non-nil + ;; DEFAULT-MOST-RECENT to `vc-git-stash-read'. + (interactive (list (vc-git-stash-read "Pop stash" + :default-most-recent t))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-delete (name) "Delete stash NAME." - (interactive (list (vc-git-stash-read "Delete stash: "))) + (interactive (list (vc-git-stash-read "Delete stash"))) (vc-git-command "*vc-git-stash*" 0 nil "stash" "drop" "-q" name) (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-snapshot () - "Create a stash with the current tree state." + "Create a stash with the current uncommitted changes. +In `vc-dir-mode', if there are files marked, stash the changes to those. +If no files are marked, stash all uncommitted changes to tracked files. +In other modes, call `vc-deduce-fileset' to determine files to stash." (interactive) - (vc-git--call nil "stash" "save" - (format-time-string "Snapshot on %Y-%m-%d at %H:%M")) + (apply #'vc-git--call nil "stash" "push" "-m" + (format-time-string "Snapshot on %Y-%m-%d at %H:%M") + (vc-git--deduce-files-for-stash)) (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}") (vc-resynch-buffer (vc-git-root default-directory) t t)) (defun vc-git-stash-list () - (when-let ((out (vc-git--run-command-string nil "stash" "list"))) + (when-let* ((out (vc-git--run-command-string nil "stash" "list"))) (split-string (replace-regexp-in-string "^stash@" " " out) @@ -2135,7 +2285,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (goto-char point) (beginning-of-line) (if (looking-at "^ +\\({[0-9]+}\\):") - (match-string 1) + (match-string-no-properties 1) (error "Cannot find stash at point")))) ;; vc-git-stash-delete-at-point must be called from a vc-dir buffer. @@ -2204,7 +2354,7 @@ The difference to `vc-do-command' is that this function always invokes (let ((file (or (car-safe file-or-list) file-or-list))) (and file - (eq ?/ (aref file (1- (length file)))) + (directory-name-p file) (equal file (vc-git-root file)))))) (defun vc-git--empty-db-p () @@ -2246,6 +2396,13 @@ The exit status is ignored." (with-current-buffer standard-output (apply #'vc-git--out-ok command args)))) +(defun vc-git--out-match (args regexp group) + "Run `git ARGS...' and return match for group number GROUP of REGEXP. +Return nil if the output does not match. The exit status is ignored." + (let ((out (apply #'vc-git--out-str args))) + (when (string-match regexp out) + (match-string group out)))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string. FILE can be nil." diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 876d86dc24f..856bea66a6f 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -397,8 +397,11 @@ specific file to query." (defun vc-hg-print-log (files buffer &optional shortlog start-revision limit) "Print commit log associated with FILES into specified BUFFER. If SHORTLOG is non-nil, use a short format based on `vc-hg-root-log-format'. -If START-REVISION is non-nil, it is the newest revision to show. -If LIMIT is non-nil, show no more than this many entries." +If LIMIT is a positive integer, show no more than that many entries. + +If START-REVISION is nil, print the commit log starting from the working +directory parent (revset \".\"). If START-REVISION is a string, print +the log starting from that revision." ;; `vc-do-command' creates the buffer, but we need it before running ;; the command. (vc-setup-buffer buffer) @@ -408,8 +411,8 @@ If LIMIT is non-nil, show no more than this many entries." (with-current-buffer buffer (apply #'vc-hg-command buffer 'async files "log" + (format "-r%s:0" (or start-revision ".")) (nconc - (when start-revision (list (format "-r%s:0" start-revision))) (when limit (list "-l" (format "%s" limit))) (when (eq vc-log-view-type 'with-diff) (list "-p")) diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el index 27f58cb3369..ff19b0f7696 100644 --- a/lisp/vc/vc-src.el +++ b/lisp/vc/vc-src.el @@ -222,8 +222,9 @@ This function differs from `vc-do-command' in that it invokes `vc-src-program'." (defun vc-src-working-revision (file) "SRC-specific version of `vc-working-revision'." (let ((result (ignore-errors - (with-output-to-string - (vc-src-command standard-output file "list" "-f{1}" "@"))))) + (string-trim-right + (with-output-to-string + (vc-src-command standard-output file "list" "-f{1}" "@")))))) (if (zerop (length result)) "0" result))) ;;; diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 597a1622f5a..dd6079d22ab 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -309,6 +309,12 @@ ;; used for files under this backend, and if files can indeed be ;; locked by other users. ;; +;; - get-change-comment (files rev) +;; +;; Return the change comments associated with the files at the given +;; revision. The FILES argument it for forward-compatibility; +;; existing implementations care only about REV. +;; ;; - modify-change-comment (files rev comment) ;; ;; Modify the change comments associated with the files at the @@ -698,27 +704,6 @@ ;; ;; - Add the ability to list tags and branches. ;; -;;;; Unify two different versions of the amend capability -;; -;; - Some back ends (SCCS/RCS/SVN/SRC), have an amend capability that can -;; be invoked from log-view. -;; -;; - The git backend supports amending, but in a different -;; way (press `C-c C-e' in log-edit buffer, when making a new commit). -;; -;; - Second, `log-view-modify-change-comment' doesn't seem to support -;; modern backends at all because `log-view-extract-comment' -;; unconditionally calls `log-view-current-file'. This should be easy to -;; fix. -;; -;; - Third, doing message editing in log-view might be a natural way to go -;; about it, but editing any but the last commit (and even it, if it's -;; been pushed) is a dangerous operation in Git, which we shouldn't make -;; too easy for users to perform. -;; -;; There should be a check that the given comment is not reachable -;; from any of the "remote" refs? -;; ;;;; Other ;; ;; - asynchronous checkin and commit, so you can keep working in other @@ -929,6 +914,91 @@ is sensitive to blank lines." :type 'boolean :version "27.1") +;; The default is nil because only a VC user who also possesses a lot of +;; knowledge specific to the VCS in use can know when it is okay to +;; rewrite history, and we can't convey to a user who is relatively +;; naïve regarding the VCS in use the potential risks in only the space +;; of a minibuffer yes/no prompt. +;; +;; See `vc-git--assert-allowed-rewrite' for an example of how to use +;; this variable in VCS backend code. +(defcustom vc-allow-rewriting-published-history nil + "When non-nil, permit VCS operations that may rewrite published history. + +Many VCS commands can change your copy of published change history +without warning. If this occurs, you won't be able to pull and push in +the ordinary way until you take special action. For example, for Git, +see \"Recovering from Upstream Rebase\" in the Man page git-rebase(1). + +Normally, Emacs refuses to run VCS commands that it thinks will rewrite +published history. If you customize this variable to `ask', Emacs will +instead prompt you to confirm that you really want to perform the +rewrite. Any other non-nil value means to proceed with no prompting. + +We recommend customizing this variable to `ask' or leaving it nil, +because if published history is rewritten unexpectedly it can be fairly +time-consuming to recover. Only customize this variable to a non-nil +value other than `ask' if you have a strong grasp of the VCS in use." + :type '(choice (const :tag "Don't allow" nil) + (const :tag "Prompt to allow" ask) + (const :tag "Allow without prompting" t)) + :version "31.1") + +(defconst vc-cloneable-backends-custom-type + `(choice :convert-widget + ,(lambda (widget) + (let (opts) + (dolist (be vc-handled-backends) + (when (or (vc-find-backend-function be 'clone) + (alist-get 'clone (get be 'vc-functions))) + (push (widget-convert (list 'const be)) opts))) + (widget-put widget :args opts)) + widget)) + "The type of VC backends that support cloning VCS repositories.") + +(defcustom vc-clone-heuristic-alist + `((,(rx bos "http" (? "s") "://" + (or (: (? "www.") "github.com" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "codeberg.org" + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: (? "www.") "gitlab" (+ "." (+ alnum)) + "/" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/" + (or "r" "git") "/" + (+ (or alnum "-" "." "_")) (? "/"))) + (or (? "/") ".git") eos) + . Git) + (,(rx bos "http" (? "s") "://" + (or (: "hg.sr.ht" + "/~" (+ (or alnum "-" "." "_")) + "/" (+ (or alnum "-" "." "_"))) + (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Hg) + (,(rx bos "http" (? "s") "://" + (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/" + (+ (or alnum "-" "." "_")) (? "/"))) + eos) + . Bzr)) + "Alist mapping repository URLs to VC backends. +`vc-clone' consults this alist to determine the VC +backend from the repository URL when you call it without +specifying a backend. Each element of the alist has the form +\(URL-REGEXP . BACKEND). `vc-clone' will use BACKEND of +the first association for which the URL of the repository matches +the URL-REGEXP of the association." + :type `(alist :key-type (regexp :tag "Regular expression matching URLs") + :value-type ,vc-cloneable-backends-custom-type) + :version "31.1") + ;; File property caching @@ -1018,6 +1088,13 @@ use." (vc-call-backend bk 'create-repo)) (throw 'found bk)))) +(defun vc-guess-url-backend (url) + "Guess the VC backend for URL. +This function will internally query `vc-clone-heuristic-alist' +and return nil if it cannot reasonably guess." + (and url (alist-get url vc-clone-heuristic-alist + nil nil #'string-match-p))) + ;;;###autoload (defun vc-responsible-backend (file &optional no-error) "Return the name of a backend system that is responsible for FILE. @@ -1043,8 +1120,8 @@ responsible for the given file." (dirs (delq nil (mapcar (lambda (backend) - (when-let ((dir (vc-call-backend - backend 'responsible-p file))) + (when-let* ((dir (vc-call-backend + backend 'responsible-p file))) ;; We run DIR through `expand-file-name' ;; so that abbreviated directories, such ;; as "~/", wouldn't look "less specific" @@ -1661,6 +1738,8 @@ Type \\[vc-next-action] to check in changes.") (format "%d files" (length files)) "this file")))) +(declare-function mail-text "sendmail" ()) +(declare-function message-goto-body "message" (&optional interactive)) (defun vc-steal-lock (file rev owner) "Steal the lock on FILE." (let (file-description) @@ -1681,7 +1760,10 @@ Type \\[vc-next-action] to check in changes.") ;; goes wrong, we don't want to send any mail. (compose-mail owner (format "Stolen lock on %s" file-description)) (setq default-directory (expand-file-name "~/")) - (goto-char (point-max)) + (cond + ((eq mail-user-agent 'sendmail-user-agent) + (mail-text)) + ((message-goto-body))) (insert (format "I stole the lock on %s, " file-description) (current-time-string) @@ -1919,7 +2001,7 @@ in the output buffer." (setq-local revert-buffer-function (lambda (_ _) (vc-diff-patch-string patch-string))) (setq-local vc-patch-string patch-string) - (pop-to-buffer (current-buffer)) + (display-buffer (current-buffer)) (vc-run-delayed (vc-diff-finish (current-buffer) nil)))) (defun vc-diff-internal (async vc-fileset rev1 rev2 &optional verbose buffer) @@ -2074,20 +2156,15 @@ INITIAL-INPUT are passed on to `vc-read-revision' directly." ;; filesets, but not yet. ((/= (length files) 1) nil) - ;; if it's a directory, don't supply any revision default - ((file-directory-p first) - nil) - ;; if the file is not up-to-date, use working revision as older revision - ((not (vc-up-to-date-p first)) - (setq rev1-default (vc-working-revision first))) - ;; if the file is not locked, use last revision and current source as defaults + ;; if the file is not locked, use previous revision and current source as defaults (t - (setq rev1-default (ignore-errors ;If `previous-revision' doesn't work. - (vc-call-backend backend 'previous-revision first - (vc-working-revision first)))) - (when (string= rev1-default "") (setq rev1-default nil)))) + (push (ignore-errors ;If `previous-revision' doesn't work. + (vc-call-backend backend 'previous-revision first + (vc-working-revision first backend))) + rev1-default) + (when (member (car rev1-default) '("" nil)) (setq rev1-default nil)))) ;; construct argument list - (let* ((rev1-prompt (format-prompt "Older revision" rev1-default)) + (let* ((rev1-prompt (format-prompt "Older revision" (car rev1-default))) (rev2-prompt (format-prompt "Newer revision" ;; (or rev2-default "current source")) @@ -2101,8 +2178,8 @@ INITIAL-INPUT are passed on to `vc-read-revision' directly." (defun vc-version-diff (_files rev1 rev2) "Report diffs between revisions REV1 and REV2 in the repository history. This compares two revisions of the current fileset. -If REV1 is nil, it defaults to the current revision, i.e. revision -of the last commit. +If REV1 is nil, it defaults to the previous revision, i.e. revision +before the last commit. If REV2 is nil, it defaults to the work tree, i.e. the current state of each file in the fileset." (interactive (vc-diff-build-argument-list-internal)) @@ -2119,9 +2196,8 @@ state of each file in the fileset." "Report diffs between REV1 and REV2 revisions of the whole tree." (interactive (vc-diff-build-argument-list-internal - (or (ignore-errors (vc-deduce-fileset t)) - (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory)))) - (list backend (list (vc-call-backend backend 'root default-directory))))))) + (let ((backend (or (vc-deduce-backend) (vc-responsible-backend default-directory)))) + (list backend (list (vc-call-backend backend 'root default-directory)))))) ;; This is a mix of `vc-root-diff' and `vc-version-diff' (when (and (not rev1) rev2) (error "Not a valid revision range")) @@ -2165,7 +2241,7 @@ deduced fileset." (defun vc-buffer-sync-fileset (fileset not-urgent) (dolist (filename (cadr fileset)) - (when-let ((buffer (find-buffer-visiting filename))) + (when-let* ((buffer (find-buffer-visiting filename))) (with-current-buffer buffer (vc-buffer-sync not-urgent))))) @@ -2446,7 +2522,30 @@ the variable `vc-BACKEND-header'." (lambda () (vc-call-backend backend 'log-edit-mode)) (lambda (files comment) (vc-call-backend backend - 'modify-change-comment files rev comment))))) + 'modify-change-comment files rev comment) + ;; We are now back in `vc-parent-buffer'. + ;; If this is Log View, then revision IDs might now be + ;; out-of-date, which could be hazardous if the user immediately + ;; tries to use `log-view-modify-change-comment' a second time. + ;; E.g. with Git, `vc-git-modify-change-comment' could create an + ;; "amend!" commit referring to a commit which no longer exists + ;; on the branch, such that it wouldn't be autosquashed. + ;; So refresh the view. + (when (derived-mode-p 'log-view-mode) + (revert-buffer))) + nil backend nil + (lambda () + ;; Here we want the root diff for REV, even if we were called + ;; from a buffer generated by C-x v l, because the change comment + ;; we will edit applies to the whole revision. + (let* ((rootdir + (vc-call-backend backend 'root default-directory)) + (prevrev + (vc-call-backend backend + 'previous-revision rootdir rev))) + (save-selected-window + (vc-diff-internal nil (list backend (list rootdir)) + prevrev rev))))))) ;;;###autoload (defun vc-merge () @@ -3804,30 +3903,54 @@ to provide the `find-revision' operation instead." (interactive) (vc-call-backend (vc-backend buffer-file-name) 'check-headers)) -(defun vc-clone (remote &optional backend directory rev) +(defvar vc--remotes-history) + +(defun vc-clone (remote &optional backend directory rev open-dir) "Clone repository REMOTE using version-control BACKEND, into DIRECTORY. If successful, return the string with the directory of the checkout; otherwise return nil. REMOTE should be a string, the URL of the remote repository or the name of a directory (if the repository is local). + +When called interactively, prompt for REMOTE, BACKEND and DIRECTORY, +except attempt to determine BACKEND automatically based on REMOTE. + If DIRECTORY is nil or omitted, it defaults to `default-directory'. If BACKEND is nil or omitted, the function iterates through every known backend in `vc-handled-backends' until one succeeds to clone REMOTE. If REV is non-nil, it indicates a specific revision to check out after -cloning; the syntax of REV depends on what BACKEND accepts." - (setq directory (expand-file-name (or directory default-directory))) - (if backend - (progn - (unless (memq backend vc-handled-backends) - (error "Unknown VC backend %s" backend)) - (vc-call-backend backend 'clone remote directory rev)) - (catch 'ok - (dolist (backend vc-handled-backends) - (ignore-error vc-not-supported - (when-let ((res (vc-call-backend - backend 'clone - remote directory rev))) - (throw 'ok res))))))) +cloning; the syntax of REV depends on what BACKEND accepts. +If OPEN-DIR is non-nil, as it is interactively, also switches to a +buffer visiting DIRECTORY." + (interactive + (let* ((url (read-string "Remote: " nil 'vc--remotes-history)) + (backend (or (vc-guess-url-backend url) + (intern (completing-read + "Backend: " vc-handled-backends nil t))))) + (list url backend + (read-directory-name + "Clone into new or empty directory: " nil nil + (lambda (dir) (or (not (file-exists-p dir)) + (directory-empty-p dir)))) + nil t))) + (let* ((directory (expand-file-name (or directory default-directory))) + (backend (or backend (vc-guess-url-backend remote))) + (directory (if backend + (progn + (unless (memq backend vc-handled-backends) + (error "Unknown VC backend %s" backend)) + (vc-call-backend backend 'clone remote directory rev)) + (catch 'ok + (dolist (backend vc-handled-backends) + (ignore-error vc-not-supported + (when-let* ((res (vc-call-backend + backend 'clone + remote directory rev))) + (throw 'ok res)))))))) + (when (file-directory-p directory) + (when open-dir + (find-file directory)) + directory))) (declare-function log-view-current-tag "log-view" (&optional pos)) (defun vc-default-last-change (_backend file line) diff --git a/lisp/version.el b/lisp/version.el index a84f7f161f0..db2afd55694 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -28,26 +28,31 @@ +;; If either of the files examined by the following two functions does +;; not exist, Emacs was configured `--disable-build-details'. + (defun android-read-build-system () "Obtain the host name of the system on which Emacs was built. Use the data stored in the special file `/assets/build_info'. Value is the string ``Unknown'' upon failure, else the hostname of the build system." - (with-temp-buffer - (insert-file-contents "/assets/build_info") - (let ((string (buffer-substring 1 (line-end-position)))) - (and (not (equal string "Unknown")) string)))) + (when (file-exists-p "/assets/build_info") + (with-temp-buffer + (insert-file-contents "/assets/build_info") + (let ((string (buffer-substring 1 (line-end-position)))) + (and (not (equal string "Unknown")) string))))) (defun android-read-build-time () "Obtain the time at which Emacs was built. Use the data stored in the special file `/assets/build_info'. Value is nil upon failure, else the time in the same format as returned by `current-time'." - (with-temp-buffer - (insert-file-contents "/assets/build_info") - (end-of-line) - (let ((number (read (current-buffer)))) - (time-convert number 'list)))) + (when (file-exists-p "/assets/build_info") + (with-temp-buffer + (insert-file-contents "/assets/build_info") + (end-of-line) + (let ((number (read (current-buffer)))) + (time-convert number 'list))))) diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el index d95cf4bb569..b6117960bf7 100644 --- a/lisp/visual-wrap.el +++ b/lisp/visual-wrap.el @@ -97,24 +97,86 @@ extra indent = 2 (if (visual-wrap--face-extend-p f) f)) eol-face))))))) -(defun visual-wrap--prefix (fcp) - (let ((fcp-len (string-width fcp))) - (cond - ((= 0 visual-wrap-extra-indent) - fcp) - ((< 0 visual-wrap-extra-indent) - (concat fcp (make-string visual-wrap-extra-indent ?\s))) - ((< 0 (+ visual-wrap-extra-indent fcp-len)) - (substring fcp - 0 - (+ visual-wrap-extra-indent fcp-len))) - (t - "")))) +(defun visual-wrap--adjust-prefix (prefix) + "Adjust PREFIX with `visual-wrap-extra-indent'." + (if (numberp prefix) + (+ visual-wrap-extra-indent prefix) + (let ((prefix-len (string-width prefix))) + (cond + ((= 0 visual-wrap-extra-indent) + prefix) + ((< 0 visual-wrap-extra-indent) + (concat prefix (make-string visual-wrap-extra-indent ?\s))) + ((< 0 (+ visual-wrap-extra-indent prefix-len)) + (substring prefix + 0 (+ visual-wrap-extra-indent prefix-len))) + (t + ""))))) + +(defun visual-wrap--apply-to-line (position) + "Apply visual-wrapping properties to the logical line starting at POSITION." + (save-excursion + (goto-char position) + (when-let* ((first-line-prefix (fill-match-adaptive-prefix)) + (next-line-prefix (visual-wrap--content-prefix + first-line-prefix position))) + (when (numberp next-line-prefix) + ;; Set a minimum width for the prefix so it lines up correctly + ;; with subsequent lines. Make sure not to do this past the end + ;; of the line though! (`fill-match-adaptive-prefix' could + ;; potentially return a prefix longer than the current line in + ;; the buffer.) + (add-display-text-property + position (min (+ position (length first-line-prefix)) + (line-end-position)) + 'min-width `((,next-line-prefix . width)))) + (setq next-line-prefix (visual-wrap--adjust-prefix next-line-prefix)) + (put-text-property + position (line-end-position) 'wrap-prefix + (if (numberp next-line-prefix) + `(space :align-to (,next-line-prefix . width)) + next-line-prefix))))) + +(defun visual-wrap--content-prefix (prefix position) + "Get the next-line prefix for the specified first-line PREFIX. +POSITION is the position in the buffer where PREFIX is located. + +This returns a string prefix to use for subsequent lines; an integer, +indicating the number of canonical-width spaces to use; or nil, if +PREFIX was empty." + (cond + ((string= prefix "") + nil) + ((or (and adaptive-fill-first-line-regexp + (string-match adaptive-fill-first-line-regexp prefix)) + (and comment-start-skip + (string-match comment-start-skip prefix))) + ;; If we want to repeat the first-line prefix on subsequent lines, + ;; return its string value. However, we remove any `wrap-prefix' + ;; property that might have been added earlier. Otherwise, we end + ;; up with a string containing a `wrap-prefix' string containing a + ;; `wrap-prefix' string... + (remove-text-properties 0 (length prefix) '(wrap-prefix) prefix) + prefix) + (t + ;; Otherwise, we want the prefix to be whitespace of the same width + ;; as the first-line prefix. We want to return an integer width (in + ;; units of the font's average-width) large enough to fit the + ;; first-line prefix. + (let ((avg-space (propertize (buffer-substring position (1+ position)) + 'display '(space :width 1)))) + ;; Remove any `min-width' display specs since we'll replace with + ;; our own later in `visual-wrap--apply-to-line' (bug#73882). + (add-display-text-property 0 (length prefix) 'min-width nil prefix) + (max (string-width prefix) + (ceiling (string-pixel-width prefix (current-buffer)) + (string-pixel-width avg-space (current-buffer)))))))) (defun visual-wrap-fill-context-prefix (beg end) "Compute visual wrap prefix from text between BEG and END. This is like `fill-context-prefix', but with prefix length adjusted by `visual-wrap-extra-indent'." + (declare (obsolete nil "31.1")) (let* ((fcp ;; `fill-context-prefix' ignores prefixes that look like ;; paragraph starts, in order to avoid inadvertently @@ -124,11 +186,11 @@ by `visual-wrap-extra-indent'." ;; make much sense (and is positively harmful in ;; taskpaper-mode where paragraph-start matches everything). (or (let ((paragraph-start regexp-unmatchable)) - (fill-context-prefix beg end)) + (fill-context-prefix beg end)) ;; Note: fill-context-prefix may return nil; See: ;; http://article.gmane.org/gmane.emacs.devel/156285 "")) - (prefix (visual-wrap--prefix fcp)) + (prefix (visual-wrap--adjust-prefix fcp)) (face (visual-wrap--prefix-face fcp beg end))) (if face (propertize prefix 'face face) @@ -147,28 +209,8 @@ by `visual-wrap-extra-indent'." (forward-line 0) (setq beg (point)) (while (< (point) end) - (let ((lbp (point))) - (put-text-property - (point) (progn (search-forward "\n" end 'move) (point)) - 'wrap-prefix - (let ((pfx (visual-wrap-fill-context-prefix - lbp (point)))) - ;; Remove any `wrap-prefix' property that might have been - ;; added earlier. Otherwise, we end up with a string - ;; containing a `wrap-prefix' string containing a - ;; `wrap-prefix' string ... - (remove-text-properties - 0 (length pfx) '(wrap-prefix) pfx) - (let ((dp (get-text-property 0 'display pfx))) - (when (and dp (eq dp (get-text-property (1- lbp) 'display))) - ;; There's a `display' property which covers not just the - ;; prefix but also the previous newline. So it's not - ;; just making the prefix more pretty and could interfere - ;; or even defeat our efforts (e.g. it comes from - ;; `adaptive-fill-mode'). - (remove-text-properties - 0 (length pfx) '(display) pfx))) - pfx)))) + (visual-wrap--apply-to-line (point)) + (forward-line)) `(jit-lock-bounds ,beg . ,end)) ;;;###autoload diff --git a/lisp/which-key.el b/lisp/which-key.el index 0118c0f74ef..6d3d5efdd03 100644 --- a/lisp/which-key.el +++ b/lisp/which-key.el @@ -4,7 +4,7 @@ ;; Author: Justin Burkett <justin@burkett.cc> ;; Maintainer: Justin Burkett <justin@burkett.cc> -;; Version: 3.6.0 +;; Version: 3.6.1 ;; Package-Requires: ((emacs "25.1")) ;; This file is part of GNU Emacs. @@ -61,7 +61,7 @@ This variable should be set before activating `which-key-mode'. A value of zero might lead to issues, so a non-zero value is recommended (see https://github.com/justbur/emacs-which-key/issues/134)." - :type 'float + :type 'number :package-version "1.0" :version "30.1") (defcustom which-key-idle-secondary-delay nil @@ -82,7 +82,7 @@ This only applies if `which-key-popup-type' is minibuffer or `which-key-show-prefix' is echo. It needs to be less than `which-key-idle-delay' or else the keystroke echo will erase the which-key popup." - :type 'float + :type 'number :package-version '(which-key . "1.0") :version "30.1") (defcustom which-key-max-description-length 27 @@ -332,14 +332,14 @@ the right of) the middle slot. The default is zero." "Maximum width of which-key popup when type is side-window. This variable can also be a number between 0 and 1. In that case, it denotes a percentage out of the frame's width." - :type 'float + :type 'number :package-version '(which-key . "1.0") :version "30.1") (defcustom which-key-side-window-max-height 0.25 "Maximum height of which-key popup when type is side-window. This variable can also be a number between 0 and 1. In that case, it denotes a percentage out of the frame's height." - :type 'float + :type 'number :package-version '(which-key . "1.0") :version "30.1") (defcustom which-key-frame-max-width 60 @@ -1220,7 +1220,7 @@ total height." ;;; Show/hide which-key buffer (defun which-key--hide-popup () - "This function is called to hide the which-key buffer." + "Hide the `which-key' buffer." (unless (or which-key-persistent-popup (member real-this-command which-key--paging-functions)) (setq which-key--last-try-2-loc nil) @@ -2347,10 +2347,7 @@ enough space based on your settings and frame size." prefix-keys) (when (cdr page-echo) (funcall (cdr page-echo))) (which-key--show-popup (cons height width))))) ;; used for paging at top-level - (if (fboundp 'set-transient-map) - (set-transient-map (which-key--get-popup-map)) - (with-no-warnings - (set-temporary-overlay-map (which-key--get-popup-map)))))) + (set-transient-map (which-key--get-popup-map)))) ;;; Paging functions diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 8be139d4584..cd8cd0450f2 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -1465,6 +1465,11 @@ The problems cleaned up are: If `whitespace-style' includes the value `space-after-tab::space', replace TABs by SPACEs. +5. missing newline at end of file. + If `whitespace-style' includes the value `missing-newline-at-eof', + and the cleanup region includes the end of file, add a final newline + if it is not there already. + See `whitespace-style', `indent-tabs-mode' and `tab-width' for documentation." (interactive "@r") @@ -1545,7 +1550,16 @@ documentation." ((memq 'space-before-tab::space whitespace-style) (whitespace-replace-action 'untabify rstart rend - whitespace-space-before-tab-regexp 2)))) + whitespace-space-before-tab-regexp 2))) + ;; PROBLEM 5: missing newline at end of file + (and (memq 'missing-newline-at-eof whitespace-style) + (> (point-max) (point-min)) + (= (point-max) (without-restriction (point-max))) + (/= (char-before (point-max)) ?\n) + (not (and (eq selective-display t) + (= (char-before (point-max)) ?\r))) + (goto-char (point-max)) + (ignore-errors (insert "\n")))) (set-marker rend nil)))) ; point marker to nowhere diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 77e506960a2..ba99847f488 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -56,7 +56,6 @@ ;;; Code: (require 'cl-lib) -(eval-when-compile (require 'subr-x)) ; when-let ;; The `string' widget completion uses this. (declare-function ispell-get-word "ispell" @@ -1042,8 +1041,8 @@ button end points." (defun widget-text (widget) "Get the text representation of the widget." - (when-let ((from (widget-get widget :from)) - (to (widget-get widget :to))) + (when-let* ((from (widget-get widget :from)) + (to (widget-get widget :to))) (when (eq (marker-buffer from) (marker-buffer to)) ; is this check necessary? (buffer-substring-no-properties from to)))) @@ -2942,7 +2941,7 @@ Otherwise, the new widget is the default child of WIDGET. The new widget gets inserted at the position of the BEFORE child." (save-excursion (let ((children (widget-get widget :children)) - (last-deleted (when-let ((lst (widget-get widget :last-deleted))) + (last-deleted (when-let* ((lst (widget-get widget :last-deleted))) (prog1 (pop lst) (widget-put widget :last-deleted lst))))) @@ -3894,6 +3893,30 @@ or a list with the default value of each component of the list WIDGET." (and (consp value) (widget-group-match widget (widget-apply widget :value-to-internal value)))) + +(defun widget-single-or-list-to-internal (widget val) + (if (listp val) val + (cons val (make-list (1- (length (widget-get widget :args))) nil)))) + +(define-widget 'single-or-list 'group + "Either a single value (`nlistp') or a list of values (`listp'). + +If the initial value is `nlistp', the first child widget gets +that value and the other children get nil. + +If the first child's value is `nlistp' and the other children are +nil, then `widget-value' just returns the first child's value." + ;; The internal value is always a list; only :value-to-internal and + ;; :match ever get called with the external value, which might be + ;; `nlistp'. + :value-to-external (lambda (_ val) + (if (and (nlistp (car val)) + (cl-every #'null (cdr val))) + (car val) val)) + :value-to-internal #'widget-single-or-list-to-internal + :match (lambda (widget val) + (widget-group-match widget (widget-single-or-list-to-internal widget val)))) + ;;; The `lazy' Widget. ;; diff --git a/lisp/window-tool-bar.el b/lisp/window-tool-bar.el index 63484da3255..2f16addfb33 100644 --- a/lisp/window-tool-bar.el +++ b/lisp/window-tool-bar.el @@ -305,8 +305,8 @@ MENU-ITEM is a menu item to convert. See info node `(elisp)Tool Bar'." 'face 'window-tool-bar-button-disabled str)) - (when-let ((spec (and (window-tool-bar--use-images) - (plist-get menu-item :image)))) + (when-let* ((spec (and (window-tool-bar--use-images) + (plist-get menu-item :image)))) (put-text-property 0 len 'display (append spec diff --git a/lisp/window.el b/lisp/window.el index 01010072190..e9d57652ec6 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -428,6 +428,16 @@ The functions currently affected by this are `split-window', An application may bind this to a non-nil value around calls to these functions to inhibit processing of window parameters.") +(defun window-no-other-p (&optional window) + "Return non-nil if WINDOW should not be used as \"other\" window. +WINDOW must be a live window and defaults to the selected one. + +Return non-nil if the `no-other-window' parameter of WINDOW is non-nil +and `ignore-window-parameters' is nil. Return nil in any other case." + (setq window (window-normalize-window window t)) + (and (not ignore-window-parameters) + (window-parameter window 'no-other-window))) + ;; This must go to C, finally (or get removed). (defconst window-safe-min-height 1 "The absolute minimum number of lines of any window. @@ -2307,11 +2317,11 @@ as seen from the position of `window-point' in window WINDOW. DIRECTION should be one of `above', `below', `left' or `right'. WINDOW must be a live window and defaults to the selected one. -Do not return a window whose `no-other-window' parameter is -non-nil. If the nearest window's `no-other-window' parameter is -non-nil, try to find another window in the indicated direction. -If, however, the optional argument IGNORE is non-nil, return that -window even if its `no-other-window' parameter is non-nil. +Do not return a window for which `window-no-other-p' returns non-nil. +If `window-no-other-p' returns non-nil for the nearest window, try to +find another window in the indicated direction. If, however, the +optional argument IGNORE is non-nil, return the nearest window even if +`window-no-other-p' returns for it a non-nil value. Optional argument SIGN a negative number means to use the right or bottom edge of WINDOW as reference position instead of @@ -2375,7 +2385,7 @@ Return nil if no suitable window can be found." (cond ((or (eq window w) ;; Ignore ourselves. - (and (window-parameter w 'no-other-window) + (and (window-no-other-p w) ;; Ignore W unless IGNORE is non-nil. (not ignore)))) (hor @@ -2491,14 +2501,13 @@ and no others." (defun get-lru-window (&optional all-frames dedicated not-selected no-other) "Return the least recently used window on frames specified by ALL-FRAMES. -Return a full-width window if possible. A minibuffer window is -never a candidate. A dedicated window is never a candidate -unless DEDICATED is non-nil, so if all windows are dedicated, the -value is nil. Avoid returning the selected window if possible. -Optional argument NOT-SELECTED non-nil means never return the -selected window. Optional argument NO-OTHER non-nil means to -never return a window whose `no-other-window' parameter is -non-nil. +Return a full-width window if possible. A minibuffer window is never a +candidate. A dedicated window is never a candidate unless DEDICATED is +non-nil, so if all windows are dedicated, the value is nil. Avoid +returning the selected window if possible. Optional argument +NOT-SELECTED non-nil means never return the selected window. Optional +argument NO-OTHER non-nil means to never return a window for which +`window-no-other-p' returns non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2522,8 +2531,7 @@ selected frame and no others." (dolist (window windows) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) - (or (not no-other) - (not (window-parameter window 'no-other-window)))) + (or (not no-other) (not (window-no-other-p window)))) (setq time (window-use-time window)) (if (or (eq window (selected-window)) (not (window-full-width-p window))) @@ -2537,12 +2545,11 @@ selected frame and no others." (defun get-mru-window (&optional all-frames dedicated not-selected no-other) "Return the most recently used window on frames specified by ALL-FRAMES. -A minibuffer window is never a candidate. A dedicated window is -never a candidate unless DEDICATED is non-nil, so if all windows -are dedicated, the value is nil. Optional argument NOT-SELECTED -non-nil means never return the selected window. Optional -argument NO-OTHER non-nil means to never return a window whose -`no-other-window' parameter is non-nil. +A minibuffer window is never a candidate. A dedicated window is never a +candidate unless DEDICATED is non-nil, so if all windows are dedicated, +the value is nil. Optional argument NOT-SELECTED non-nil means never +return the selected window. Optional argument NO-OTHER non-nil means to +never return a window for which `window-no-other-p' returns non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2564,8 +2571,7 @@ selected frame and no others." (setq time (window-use-time window)) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) - (or (not no-other) - (not (window-parameter window 'no-other-window))) + (or (not no-other) (not (window-no-other-p window))) (or (not best-time) (> time best-time))) (setq best-time time) (setq best-window window))) @@ -2573,12 +2579,11 @@ selected frame and no others." (defun get-largest-window (&optional all-frames dedicated not-selected no-other) "Return the largest window on frames specified by ALL-FRAMES. -A minibuffer window is never a candidate. A dedicated window is -never a candidate unless DEDICATED is non-nil, so if all windows -are dedicated, the value is nil. Optional argument NOT-SELECTED -non-nil means never return the selected window. Optional -argument NO-OTHER non-nil means to never return a window whose -`no-other-window' parameter is non-nil. +A minibuffer window is never a candidate. A dedicated window is never a +candidate unless DEDICATED is non-nil, so if all windows are dedicated, +the value is nil. Optional argument NOT-SELECTED non-nil means never +return the selected window. Optional argument NO-OTHER non-nil means to +never return a window for which `window-no-other-p' returns non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2602,8 +2607,7 @@ selected frame and no others." (dolist (window (window-list-1 nil 'nomini all-frames)) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) - (or (not no-other) - (not (window-parameter window 'no-other-window)))) + (or (not no-other) (window-no-other-p window))) (setq size (* (window-pixel-height window) (window-pixel-width window))) (when (> size best-size) @@ -3963,12 +3967,10 @@ skip -COUNT windows backwards. COUNT zero means do not skip any window, so select the selected window. In an interactive call, COUNT is the numeric prefix argument. Return nil. -If the `other-window' parameter of the selected window is a -function and `ignore-window-parameters' is nil, call that -function with the arguments COUNT and ALL-FRAMES. - -This function does not select a window whose `no-other-window' -window parameter is non-nil. +If the `other-window' parameter of the selected window is a function and +`ignore-window-parameters' is nil, call that function with the arguments +COUNT and ALL-FRAMES. Otherwise, do not return a window for which +`window-no-other-p' returns non-nil. This function uses `next-window' for finding the window to select. The argument ALL-FRAMES has the same meaning as in @@ -3994,7 +3996,7 @@ always effectively nil." ;; Keep out of infinite loops. When COUNT has not changed ;; since we last looked at `window' we're probably in one. (throw 'exit nil))) - ((window-parameter window 'no-other-window) + ((window-no-other-p window) (unless old-window ;; The first non-selectable window `next-window' got us: ;; Remember it and the current value of COUNT. @@ -4010,7 +4012,7 @@ always effectively nil." ;; Keep out of infinite loops. When COUNT has not changed ;; since we last looked at `window' we're probably in one. (throw 'exit nil))) - ((window-parameter window 'no-other-window) + ((window-no-other-p window) (unless old-window ;; The first non-selectable window `previous-window' got ;; us: Remember it and the current value of COUNT. @@ -4104,12 +4106,35 @@ and no others." (next-window base-window (if nomini 'arg) all-frames)))) ;;; Deleting windows. -(defun window-deletable-p (&optional window) +(defcustom window-deletable-functions nil + "Abnormal hook to decide whether a window may be implicitly deleted. +The value should be a list of functions that take two arguments. The +first argument is the window about to be deleted. The second argument +if non-nil, means that the window is the only window on its frame and +should be deleted together with its frame. If the window is live, its +buffer is current when running this hook. + +If any of these functions returns nil, the window will not be deleted +and another buffer will be shown in it. This hook is run implicitly by +the functions `quit-restore-window', `kill-buffer' and `bury-buffer'. +It is not run by `delete-window' and `delete-windows-on'. The purpose +of this hook is to give its clients a chance to save a window or its +frame from deletion because they might still want to use that window or +frame for their own purposes." + :type 'hook + :version "31.1" + :group 'windows) + +(defun window-deletable-p (&optional window no-run) "Return t if WINDOW can be safely deleted from its frame. WINDOW must be a valid window and defaults to the selected one. Return `frame' if WINDOW is the root window of its frame and that -frame can be safely deleted." +frame can be safely deleted. + +Unless the optional argument NO-RUN is non-nil, run the abnormal hook +`window-deletable-functions' and return nil if any function on that hook +returns nil." (setq window (window-normalize-window window)) (unless (or ignore-window-parameters @@ -4124,27 +4149,28 @@ frame can be safely deleted." ;; WINDOW's frame can be deleted only if there are other frames ;; on the same terminal, and it does not contain the active ;; minibuffer. - (unless (or (eq frame (next-frame frame 0)) - ;; We can delete our frame only if no other frame - ;; currently uses our minibuffer window. - (catch 'other - (dolist (other (frame-list)) - (when (and (not (eq other frame)) - (eq (window-frame (minibuffer-window other)) - frame)) - (throw 'other t)))) - (let ((minibuf (active-minibuffer-window))) - (and minibuf (eq frame (window-frame minibuf)) - (not (eq (default-toplevel-value - 'minibuffer-follows-selected-frame) - t))))) + (unless (or (not (frame-deletable-p (window-frame window))) + (or no-run + (if (window-live-p window) + (not (with-current-buffer (window-buffer window) + (run-hook-with-args-until-failure + 'window-deletable-functions window t))) + (not (run-hook-with-args-until-failure + 'window-deletable-functions window t))))) 'frame)) ((window-minibuffer-p window) ;; If WINDOW is the minibuffer window of a non-minibuffer-only ;; frame, it cannot be deleted separately. nil) - ((or ignore-window-parameters - (not (eq window (window-main-window frame)))) + ((and (or ignore-window-parameters + (not (eq window (window-main-window frame)))) + (or no-run + (if (window-live-p window) + (with-current-buffer (window-buffer window) + (run-hook-with-args-until-failure + 'window-deletable-functions window nil)) + (run-hook-with-args-until-failure + 'window-deletable-functions window nil)))) ;; Otherwise, WINDOW can be deleted unless it is the main window ;; of its frame. t)))) @@ -4159,10 +4185,10 @@ Tool-bar and tab-bar pseudo-windows are ignored by this function: if the specified coordinates are in any of these two windows, this function returns nil. -Optional argument FRAME must specify a live frame and defaults to -the selected one. Optional argument NO-OTHER non-nil means to -return nil if the window located at the specified coordinates has -a non-nil `no-other-window' parameter." +Optional argument FRAME must specify a live frame and defaults to the +selected one. Optional argument NO-OTHER non-nil means to return nil if +`window-no-other-p' returns non-nil for the window located at the +specified coordinates." (setq frame (window-normalize-frame frame)) (let* ((root-edges (window-edges (frame-root-window frame) nil nil t)) (root-left (nth 2 root-edges)) @@ -4175,7 +4201,7 @@ a non-nil `no-other-window' parameter." (or (< x (nth 2 edges)) (= x root-left)) (>= y (nth 1 edges)) (or (< y (nth 3 edges)) (= y root-bottom))) - (if (and no-other (window-parameter window 'no-other-window)) + (if (and no-other (window-no-other-p window)) (throw 'window nil) (throw 'window window))))) frame)))) @@ -4187,13 +4213,13 @@ another live window on that frame to serve as its selected window. This option controls the window that is selected in such a situation. -The possible choices are `mru' (the default) to select the most -recently used window on that frame, and `pos' to choose the -window at the frame coordinates of point of the previously -selected window. If this is nil, choose the frame's first window -instead. A window with a non-nil `no-other-window' parameter is -chosen only if all windows on that frame have that parameter set -to a non-nil value." +The possible choices are `mru' (the default) to select the most recently +used window on that frame, and `pos' to choose the window at the frame +coordinates of point of the previously selected window. If this is nil, +choose the frame's first window instead. A window for which +`window-no-other-p' returns non-nil is chosen only if all windows on +that frame have their `no-other-window' parameter set to a non-nil +value." :type '(choice (const :tag "Most recently used" mru) (const :tag "At position of deleted" pos) (const :tag "Frame's first " nil)) @@ -4316,15 +4342,14 @@ the option `delete-window-choose-selected'." (let ((mru-window (get-mru-window frame nil nil t))) (and mru-window (set-frame-selected-window frame mru-window))))) - ((and (window-parameter - (frame-selected-window frame) 'no-other-window) + ((and (window-no-other-p (frame-selected-window frame)) ;; If `delete-window-internal' selected a window with a ;; non-nil 'no-other-window' parameter as its frame's ;; selected window, try to choose another one. (catch 'found (walk-window-tree (lambda (other) - (unless (window-parameter other 'no-other-window) + (unless (window-no-other-p other) (set-frame-selected-window frame other) (throw 'found t))) frame)))) @@ -4445,87 +4470,107 @@ This may be a useful alternative binding for \\[delete-other-windows] ;;; Windows and buffers. -;; `prev-buffers' and `next-buffers' are two reserved window slots used +;; 'prev-buffers' and 'next-buffers' are two reserved window slots used ;; for (1) determining which buffer to show in the window when its ;; buffer shall be buried or killed and (2) which buffer to show for -;; `switch-to-prev-buffer' and `switch-to-next-buffer'. +;; 'switch-to-prev-buffer' and 'switch-to-next-buffer'. -;; `prev-buffers' consists of <buffer, window-start, window-point> +;; 'prev-buffers' consists of <buffer, window-start, window-point> ;; triples. The entries on this list are ordered by the time their ;; buffer has been removed from the window, the most recently removed ;; buffer's entry being first. The window-start and window-point -;; components are `window-start' and `window-point' at the time the +;; components are 'window-start' and 'window-point' at the time the ;; buffer was removed from the window which implies that the entry must -;; be added when `set-window-buffer' removes the buffer from the window. +;; be added when 'set-window-buffer' removes the buffer from the window. -;; `next-buffers' is the list of buffers that have been replaced -;; recently by `switch-to-prev-buffer'. These buffers are the least -;; preferred candidates of `switch-to-prev-buffer' and the preferred -;; candidates of `switch-to-next-buffer' to switch to. This list is +;; 'next-buffers' is the list of buffers that have been replaced +;; recently by 'switch-to-prev-buffer'. These buffers are the least +;; preferred candidates of 'switch-to-prev-buffer' and the preferred +;; candidates of 'switch-to-next-buffer' to switch to. This list is ;; reset to nil by any action changing the window's buffer with the -;; exception of `switch-to-prev-buffer' and `switch-to-next-buffer'. -;; `switch-to-prev-buffer' pushes the buffer it just replaced on it, -;; `switch-to-next-buffer' pops the last pushed buffer from it. - -;; Both `prev-buffers' and `next-buffers' may reference killed buffers -;; if such a buffer was killed while the window was hidden within a -;; window configuration. Such killed buffers get removed whenever -;; `switch-to-prev-buffer' or `switch-to-next-buffer' encounter them. - -;; The following function is called by `set-window-buffer' _before_ it -;; replaces the buffer of the argument window with the new buffer. -(defun push-window-buffer-onto-prev (&optional window) - "Push entry for WINDOW's buffer onto WINDOW's prev-buffers list. -WINDOW must be a live window and defaults to the selected one. - -Any duplicate entries for the buffer in the list are removed." +;; exception of 'switch-to-prev-buffer' and 'switch-to-next-buffer'. +;; 'switch-to-prev-buffer' pushes the buffer it just replaced on it, +;; 'switch-to-next-buffer' pops the last pushed buffer from it. + +;; The following function is called by 'set-window-buffer' _before_ it +;; replaces the buffer of the argument window with the new buffer. It +;; does not record a non-minibuffer buffer (like the one created by +;; 'calculator' in Electric mode) in a minibuffer window since the code +;; in minibuf.c cannot handle that. The minibuf.c code calls this +;; function exclusively to arrange minibuffers shown in minibuffer +;; windows. +(defun record-window-buffer (&optional window) + "Record WINDOW's buffer. +Add the buffer currently shown in WINDOW to the list of WINDOW's +previous buffers. WINDOW must be a live window and defaults to the +selected one. + +If WINDOW is not a minibuffer window, do not record insignificant +buffers (buffers whose name starts with a space). If WINDOW is a +minibuffer window, record its buffer if and only if that buffer is a +live minibuffer (`minibufferp' with LIVE argument non-nil must return +non-nil for it). + +Run `buffer-list-update-hook' if and only if WINDOW is not a minibuffer +window." (let* ((window (window-normalize-window window t)) + (mini (window-minibuffer-p window)) (buffer (window-buffer window)) - (w-list (window-prev-buffers window)) - (entry (assq buffer w-list))) + (prev-buffers (window-prev-buffers window)) + (entry (assq buffer prev-buffers))) (when entry - (setq w-list (assq-delete-all buffer w-list))) - (let ((start (window-start window)) - (point (window-point window))) - (setq entry - (cons buffer - (with-current-buffer buffer - (if entry - ;; We have an entry, update marker positions. - (list (set-marker (nth 1 entry) start) - (set-marker (nth 2 entry) point)) - (list (copy-marker start) - (copy-marker - ;; Preserve window-point-insertion-type - ;; (Bug#12855) - point window-point-insertion-type)))))) - (set-window-prev-buffers window (cons entry w-list))))) + (setq prev-buffers (assq-delete-all buffer prev-buffers))) -(defun record-window-buffer (&optional window) - "Record WINDOW's buffer. -WINDOW must be a live window and defaults to the selected one." - (let* ((window (window-normalize-window window t)) - (buffer (window-buffer window))) ;; Reset WINDOW's next buffers. If needed, they are resurrected by ;; `switch-to-prev-buffer' and `switch-to-next-buffer'. (set-window-next-buffers window nil) - ;; Don't record insignificant buffers. - (when (not (eq (aref (buffer-name buffer) 0) ?\s)) - (push-window-buffer-onto-prev window) - (run-hooks 'buffer-list-update-hook)))) - -(defun unrecord-window-buffer (&optional window buffer) + ;; For minibuffer windows record live minibuffers only. For normal + ;; windows do not record insignificant buffers. + (when (if mini + (minibufferp buffer t) + (not (eq (aref (buffer-name buffer) 0) ?\s))) + (let ((start (window-start window)) + (point (window-point window))) + (setq entry + (cons buffer + (with-current-buffer buffer + (if entry + ;; We have an entry, update marker positions. + (list (set-marker (nth 1 entry) start) + (set-marker (nth 2 entry) point)) + (list (copy-marker start) + (copy-marker + ;; Preserve window-point-insertion-type + ;; (Bug#12855) + point window-point-insertion-type)))))) + (set-window-prev-buffers window (cons entry prev-buffers)) + + (unless mini + (run-hooks 'buffer-list-update-hook)))))) + +(defalias 'push-window-buffer-onto-prev 'record-window-buffer) + +(defun unrecord-window-buffer (&optional window buffer all) "Unrecord BUFFER in WINDOW. -WINDOW must be a live window and defaults to the selected one. -BUFFER must be a live buffer and defaults to the buffer of -WINDOW." +WINDOW must be a live window and defaults to the selected one. BUFFER +must be a live buffer and defaults to the buffer of WINDOW (although +that default hardly makes any sense). + +Make BUFFER disappear from most components specified by the object of +WINDOW. This includes the buffers previously shown in WINDOW as well as +any buffers mentioned by WINDOW's `quit-restore' and `quit-restore-prev' +parameters. + +This function is called by `replace-buffer-in-windows' which is mainly +concerned with finding another buffer for all windows showing a buffer +about to be killed. It's also called by `delete-windows-on' and +`quit-windows-on' and should be called wherever the traces of a buffer +should be erased from the window handling subsystem." (let* ((window (window-normalize-window window t)) (buffer (or buffer (window-buffer window)))) - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window))))) + (when (buffer-live-p buffer) + (window-discard-buffer-from-window buffer window all)))) (defun set-window-buffer-start-and-point (window buffer &optional start point) "Set WINDOW's buffer to BUFFER. @@ -4684,7 +4729,7 @@ This function is called by `previous-buffer'." ((or switch-to-prev-buffer-skip (not switch-to-visible-buffer)) frame))) - entry new-buffer killed-buffers skipped) + entry new-buffer skipped) (when (window-minibuffer-p window) ;; Don't switch in minibuffer window. (unless (setq window (minibuffer-selected-window)) @@ -4700,14 +4745,14 @@ This function is called by `previous-buffer'." (dolist (entry (window-prev-buffers window)) (when (and (not (eq (car entry) old-buffer)) (setq new-buffer (car entry)) - (or (buffer-live-p new-buffer) - (not (setq killed-buffers - (cons new-buffer killed-buffers)))) - (or (null pred) (funcall pred new-buffer)) + ;; Beware: new-buffer might have been killed by + ;; a function on 'buffer-predicate'. + (buffer-live-p new-buffer) + (or (null pred) (funcall pred new-buffer)) ;; When BURY-OR-KILL is nil, avoid switching to a ;; buffer in WINDOW's next buffers list. (or bury-or-kill (not (memq new-buffer next-buffers)))) - (if (switch-to-prev-buffer-skip-p skip window new-buffer bury-or-kill) + (if (switch-to-prev-buffer-skip-p skip window new-buffer bury-or-kill) (setq skipped new-buffer) (set-window-buffer-start-and-point window new-buffer (nth 1 entry) (nth 2 entry)) @@ -4741,11 +4786,7 @@ This function is called by `previous-buffer'." ;; Scan reverted next buffers last (must not use nreverse ;; here!). (dolist (buffer (reverse next-buffers)) - ;; Actually, buffer _must_ be live here since otherwise it - ;; would have been caught in the scan of previous buffers. - (when (and (or (buffer-live-p buffer) - (not (setq killed-buffers - (cons buffer killed-buffers)))) + (when (and (buffer-live-p buffer) (not (eq buffer old-buffer)) (or (null pred) (funcall pred buffer)) (setq entry (assq buffer (window-prev-buffers window)))) @@ -4764,11 +4805,10 @@ This function is called by `previous-buffer'." (if bury-or-kill (let ((entry (and (eq bury-or-kill 'append) (assq old-buffer (window-prev-buffers window))))) - ;; Remove `old-buffer' from WINDOW's previous and (restored list - ;; of) next buffers. - (set-window-prev-buffers - window (assq-delete-all old-buffer (window-prev-buffers window))) - (set-window-next-buffers window (delq old-buffer next-buffers)) + ;; Remove `old-buffer' from WINDOW's previous and (restored + ;; list of) next buffers and also from its 'quit-restore' and + ;; 'quit-restore-prev' parameters. + (unrecord-window-buffer window old-buffer t) (when entry ;; Append old-buffer's entry to list of WINDOW's previous ;; buffers so it's less likely to get switched to soon but @@ -4781,14 +4821,6 @@ This function is called by `previous-buffer'." (set-window-next-buffers window (cons old-buffer (delq old-buffer next-buffers)))) - ;; Remove killed buffers from WINDOW's previous and next buffers. - (when killed-buffers - (dolist (buffer killed-buffers) - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window))))) - ;; Return new-buffer. new-buffer)) @@ -4820,7 +4852,7 @@ This function is called by `next-buffer'." ((or switch-to-prev-buffer-skip (not switch-to-visible-buffer)) frame))) - new-buffer entry killed-buffers skipped) + new-buffer entry skipped) (when (window-minibuffer-p window) ;; Don't switch in minibuffer window. (unless (setq window (minibuffer-selected-window)) @@ -4833,9 +4865,7 @@ This function is called by `next-buffer'." (catch 'found ;; Scan WINDOW's next buffers first. (dolist (buffer next-buffers) - (when (and (or (buffer-live-p buffer) - (not (setq killed-buffers - (cons buffer killed-buffers)))) + (when (and (buffer-live-p buffer) (not (eq buffer old-buffer)) (or (null pred) (funcall pred buffer)) (setq entry (assq buffer (window-prev-buffers window)))) @@ -4868,9 +4898,7 @@ This function is called by `next-buffer'." (when (and (not (eq new-buffer (car entry))) (not (eq old-buffer (car entry))) (setq new-buffer (car entry)) - (or (buffer-live-p new-buffer) - (not (setq killed-buffers - (cons new-buffer killed-buffers)))) + (buffer-live-p new-buffer) (or (null pred) (funcall pred new-buffer))) (if (switch-to-prev-buffer-skip-p skip window new-buffer) (setq skipped (or skipped new-buffer)) @@ -4886,14 +4914,6 @@ This function is called by `next-buffer'." ;; Remove `new-buffer' from and restore WINDOW's next buffers. (set-window-next-buffers window (delq new-buffer next-buffers)) - ;; Remove killed buffers from WINDOW's previous and next buffers. - (when killed-buffers - (dolist (buffer killed-buffers) - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window))))) - ;; Return new-buffer. new-buffer)) @@ -5045,6 +5065,18 @@ minibuffer window or is dedicated to its buffer." (not (or executing-kbd-macro noninteractive))) (user-error "No previous buffer")))))) +(defcustom kill-buffer-quit-windows nil + "Non-nil means killing buffers shall quit windows. +If this is nil, killing a buffer may only delete windows dedicated to +that buffer. Otherwise, `kill-buffer' has `quit-restore-window' deal +with any window showing the buffer to be killed. That function may +delete such a window even if it's not dedicated to its buffer. Also, +`delete-windows-on' will use `quit-restore-window' as fallback when a +window cannot be deleted otherwise." + :type 'boolean + :version "31.1" + :group 'windows) + (defun delete-windows-on (&optional buffer-or-name frame) "Delete all windows showing BUFFER-OR-NAME. BUFFER-OR-NAME may be a buffer or the name of an existing buffer @@ -5076,21 +5108,22 @@ Interactively, FRAME is the prefix argument, so you can use \\[universal-argument] 0 to specify all windows only on the current terminal's frames. -If a frame's root window shows the buffer specified by -BUFFER-OR-NAME and is dedicated to that buffer and that frame -does not host the active minibuffer window and there is at least -one other frame on that frame's terminal, delete that frame. -Otherwise, do not delete a frame's root window if it shows the -buffer specified by BUFFER-OR-NAME and do not delete any frame's -main window showing that buffer either. Rather, in any such -case, call `switch-to-prev-buffer' to show another buffer in that -window and make sure the window is no more dedicated to its -buffer. - -If the buffer specified by BUFFER-OR-NAME is shown in a -minibuffer window, do nothing for that window. For any window -that does not show that buffer, remove the buffer from that -window's lists of previous and next buffers." +If a frame's root window shows the buffer specified by BUFFER-OR-NAME, +is dedicated to that buffer, that frame does not host the active +minibuffer window and there is at least one other frame on that frame's +terminal, delete that frame. Otherwise, do not delete a frame's root +window if it shows the buffer specified by BUFFER-OR-NAME and do not +delete any frame's main window showing that buffer either. Rather, in +any such case, call either `quit-restore-window' (provided +`kill-buffer-quit-windows' is non-nil) or `switch-to-prev-buffer' to +show another buffer in that window and make sure the window is no more +dedicated to its buffer. + +If the buffer specified by BUFFER-OR-NAME is shown in a minibuffer +window, do nothing for that window. For any window that does not show +that buffer, remove the buffer from that window's lists of previous and +next buffers and remove any `quit-restore' and `quit-restore-prev' +parameters naming it." (interactive (let ((frame (cond ((and (numberp current-prefix-arg) @@ -5108,11 +5141,12 @@ window's lists of previous and next buffers." frame))) (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other - ;; `window-list-1' based function. - (all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) - (dolist (window (window-list-1 nil nil all-frames)) + ;; `window-list-1' based functions. + (frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) + (dolist (window (window-list-1 nil 'nomini frames)) (if (eq (window-buffer window) buffer) - (let ((deletable (window-deletable-p window)) + ;; Don't run 'window-deletable-functions'. + (let ((deletable (window-deletable-p window t)) (dedicated (window-dedicated-p window))) (cond ((and (eq deletable 'frame) dedicated) @@ -5121,43 +5155,94 @@ window's lists of previous and next buffers." ((eq deletable t) ;; Delete window. (delete-window window)) + (kill-buffer-quit-windows + (quit-restore-window window 'bury) + (when (window-live-p window) + ;; Unrecord BUFFER in this window. + (unrecord-window-buffer window buffer t))) (t ;; In window switch to previous buffer. (set-window-dedicated-p window nil) (switch-to-prev-buffer window 'bury) - ;; Restore the dedicated 'side' flag. - (when (eq dedicated 'side) - (set-window-dedicated-p window 'side))))) + ;; Restore the dedicated 'side' flag. + (when (eq dedicated 'side) + (set-window-dedicated-p window 'side)) + (when (window-live-p window) + ;; Unrecord BUFFER in this window. + (unrecord-window-buffer window buffer t))))) ;; If a window doesn't show BUFFER, unrecord BUFFER in it. - (unrecord-window-buffer window buffer))))) - + (unrecord-window-buffer window buffer t))))) + +;; Conceptually, 'replace-buffer-in-windows' would not have to touch the +;; list of previous buffers of a minibuffer window: As a rule, +;; minibuffers are never deleted and any other buffers shown in a +;; minibuffer window are not recorded by 'record-window'. To be on the +;; safe side, 'replace-buffer-in-windows' now scans minibuffer windows +;; too to make sure that any killed buffer gets removed from all lists +;; of previous and next buffers. 'replace-buffer-in-windows' still does +;; _not_ replace the buffer itself in any minibuffer window showing it. +;; That case is still handled only in 'kill-buffer' itself. (defun replace-buffer-in-windows (&optional buffer-or-name) "Replace BUFFER-OR-NAME with some other buffer in all windows showing it. -BUFFER-OR-NAME may be a buffer or the name of an existing buffer -and defaults to the current buffer. - -With the exception of side windows, when a window showing BUFFER-OR-NAME -is dedicated, that window is deleted. If that window is the only window -on its frame, the frame is deleted too when there are other frames left. -If there are no other frames left, some other buffer is displayed in that +BUFFER-OR-NAME may be a buffer or the name of an existing buffer and +defaults to the current buffer. + +If the option `kill-buffer-quit-windows' is nil, behave as follows: With +the exception of side windows, when a window showing BUFFER-OR-NAME is +dedicated, delete that window. If that window is the only window on its +frame, delete its frame when there are other frames left. In any other +case, call `switch-to-prev-buffer' to display some other buffer in that window. -This function removes the buffer denoted by BUFFER-OR-NAME from -all window-local buffer lists." +If `kill-buffer-quit-windows' is non-nil, call `quit-restore-window' for +any window showing BUFFER-OR-NAME with the argument BURY-OR-KILL set to +`killing' to avoid that the latter kills the buffer prematurely. + +In either case, remove the buffer denoted by BUFFER-OR-NAME from the +lists of previous and next buffers of all windows and remove any +`quit-restore' or `quit-restore-prev' parameters mentioning it. + +This function does not replace the buffer specified by BUFFER-OR-NAME in +any minibuffer window showing it, nor does it delete minibuffer windows +or minibuffer frames. It removes, however, that buffer from the lists +of previous and next buffers of all minibuffer windows. + +If, for any window showing BUFFER-OR-NAME running the abnormal hook +`window-deletable-functions' returns nil, do not delete that window but +show some other buffer in that window. + +This function is called by `kill-buffer' which effectively kills the +buffer specified by `buffer-or-name' afterwards. It never kills a +buffer by itself." (interactive "bBuffer to replace: ") (let ((buffer (window-normalize-buffer buffer-or-name))) - (dolist (window (window-list-1 nil nil t)) - (if (eq (window-buffer window) buffer) - ;; Delete a dedicated window unless it is a side window. - (let ((dedicated-side (eq (window-dedicated-p window) 'side))) - (when (or dedicated-side (not (window--delete window t t))) - ;; Switch to another buffer in that window. - (set-window-dedicated-p window nil) - (if (switch-to-prev-buffer window 'kill) + ;; Scan all windows including minibuffer windows. We have to + ;; unrecord BUFFER-OR-NAME even in those not showing it. + (dolist (window (window-list-1 nil t t)) + (when (eq (window-buffer window) buffer) + (cond + ((window-minibuffer-p window)) + (kill-buffer-quit-windows + (quit-restore-window window 'killing)) + (t + (let ((dedicated-side (eq (window-dedicated-p window) 'side))) + (when (or dedicated-side (not (window--delete window t 'kill))) + ;; Switch to another buffer in that window. + (set-window-dedicated-p window nil) + (if (switch-to-prev-buffer window 'kill) (and dedicated-side (set-window-dedicated-p window 'side)) - (window--delete window nil 'kill)))) - ;; Unrecord BUFFER in WINDOW. - (unrecord-window-buffer window buffer))))) + (window--delete window nil 'kill)))))) + + (when (window-live-p window) + ;; If the fourth elements of the 'quit-restore' or + ;; 'quit-restore-prev' parameters equal BUFFER, these + ;; parameters become useless - in 'quit-restore-window' the + ;; fourth element must equal the buffer of WINDOW in order to + ;; use that parameter. If BUFFER is mentioned in the second + ;; element of the parameter, 'quit-restore-window' cannot + ;; possibly show BUFFER instead; so this parameter becomes + ;; useless too. + (unrecord-window-buffer window buffer t)))))) (defcustom quit-window-hook nil "Hook run before performing any other actions in the `quit-window' command." @@ -5165,6 +5250,23 @@ all window-local buffer lists." :version "27.1" :group 'windows) +(defcustom quit-restore-window-no-switch nil + "Non-nil means `quit-restore-window' preferably won't switch buffers. +If this is nil, `quit-restore-window' unconditionally calls +`switch-to-prev-buffer' unless the window is dedicated or has been made +by `display-buffer'. If this is t, `quit-restore-window' will try to +delete the window unless a live buffer exists that was previously shown +in that window. If this is the symbol `skip-first', it will switch to a +previous buffer only if there are at least two of them. + +The net effect of making this non-nil is that if `quit-restore-window' +doesn't find a suitable buffer previously shown in the window, it will +rather try to delete the window (and maybe its frame) than show a buffer +the window has never shown before." + :type 'boolean + :version "31.1" + :group 'windows) + (defun window--quit-restore-select-window (window) "Select WINDOW after having quit another one. Do not select an inactive minibuffer window." @@ -5177,17 +5279,21 @@ Do not select an inactive minibuffer window." "Quit WINDOW and deal with its buffer. WINDOW must be a live window and defaults to the selected one. -According to information stored in WINDOW's `quit-restore' window -parameter either (1) delete WINDOW and its frame, (2) delete -WINDOW but leave its frame alone, (3) restore the buffer -previously shown in WINDOW, or (4) make WINDOW display some other -buffer. If WINDOW is not deleted, reset its `quit-restore' -parameter to nil. See Info node `(elisp) Quitting Windows' for -more details. +According to information stored in WINDOW's `quit-restore' and +`quit-restore-prev' parameters either (1) delete WINDOW and its +frame, (2) delete WINDOW but leave its frame alone, (3) restore the +buffer previously shown in WINDOW, or (4) make WINDOW display some other +buffer. In case (3) set any of these parameters to nil if it has been +used to restore the previously shown buffer. See Info node `(elisp) +Quitting Windows' for more details. -If WINDOW's dedicated flag is t, try to delete WINDOW. If it -equals the value `side', restore that value when WINDOW is not -deleted. +If WINDOW's dedicated flag is t, try to delete WINDOW. If it equals the +value `side', restore that value when WINDOW is not deleted. Whether +WINDOW or its frame get deleted can be further controlled via the option +`quit-restore-window-no-switch'. + +If running the abnormal hook `window-deletable-functions' returns nil, +do not delete WINDOW but show some other buffer in it. Optional second argument BURY-OR-KILL tells how to proceed with the buffer of WINDOW. The following values are handled: @@ -5207,21 +5313,31 @@ nil means to not handle the buffer in a particular way. This most reliable remedy to not have `switch-to-prev-buffer' switch to this buffer again without killing the buffer. -`kill' means to kill WINDOW's buffer." +`kill' means to kill WINDOW's buffer. + +`killing' is like `kill' but means that WINDOW's buffer will get killed +elsewhere. This value is used by `replace-buffer-in-windows' and +`quit-windows-on'. + +`burying' is like `bury' but means that WINDOW's buffer will get buried +elsewhere. This value is used by `quit-windows-on'." (setq window (window-normalize-window window t)) (let* ((buffer (window-buffer window)) (quit-restore (window-parameter window 'quit-restore)) + (quit-restore-prev (window-parameter window 'quit-restore-prev)) (quit-restore-2 (nth 2 quit-restore)) + (quit-restore-prev-2 (nth 2 quit-restore-prev)) (prev-buffer (catch 'prev-buffer (dolist (buf (window-prev-buffers window)) (unless (eq (car buf) buffer) (throw 'prev-buffer (car buf)))))) (dedicated (window-dedicated-p window)) - quad entry) + quad entry reset-prev) (cond ;; First try to delete dedicated windows that are not side windows. ((and dedicated (not (eq dedicated 'side)) - (window--delete window 'dedicated (eq bury-or-kill 'kill))) + (window--delete + window 'dedicated (memq bury-or-kill '(kill killing)))) ;; If the previously selected window is still alive, select it. (window--quit-restore-select-window quit-restore-2)) ((and (not prev-buffer) @@ -5242,10 +5358,27 @@ nil means to not handle the buffer in a particular way. This (window--delete window nil (eq bury-or-kill 'kill))) ;; If the previously selected window is still alive, select it. (window--quit-restore-select-window quit-restore-2)) - ((and (listp (setq quad (nth 1 quit-restore))) - (buffer-live-p (car quad)) - (eq (nth 3 quit-restore) buffer)) - ;; Show another buffer stored in quit-restore parameter. + ((and (or (and quit-restore-window-no-switch (not prev-buffer)) + ;; Ignore first of the previous buffers if + ;; 'quit-restore-window-no-switch' says so. + (and (eq quit-restore-window-no-switch 'skip-first) + (not (cdr (window-prev-buffers window))))) + ;; Delete WINDOW if possible. + (window--delete + window nil (memq bury-or-kill '(kill killing)))) + ;; If the previously selected window is still alive, select it. + (window--quit-restore-select-window quit-restore-2)) + ((or (and (listp (setq quad (nth 1 quit-restore-prev))) + (buffer-live-p (car quad)) + (eq (nth 3 quit-restore-prev) buffer) + ;; Use selected window from quit-restore-prev. + (setq quit-restore-2 quit-restore-prev-2) + ;; We want to reset quit-restore-prev only. + (setq reset-prev t)) + (and (listp (setq quad (nth 1 quit-restore))) + (buffer-live-p (car quad)) + (eq (nth 3 quit-restore) buffer))) + ;; Show another buffer stored in quit-restore(-prev) parameter. (when (and (integerp (nth 3 quad)) (if (window-combined-p window) (/= (nth 3 quad) (window-total-height window)) @@ -5270,27 +5403,26 @@ nil means to not handle the buffer in a particular way. This ;; Deal with the buffer we just removed from WINDOW. (setq entry (and (eq bury-or-kill 'append) (assq buffer (window-prev-buffers window)))) - (when bury-or-kill + (when (memq bury-or-kill '(bury burying kill killing)) ;; Remove buffer from WINDOW's previous and next buffers. - (set-window-prev-buffers - window (assq-delete-all buffer (window-prev-buffers window))) - (set-window-next-buffers - window (delq buffer (window-next-buffers window)))) + (unrecord-window-buffer window buffer)) (when entry ;; Append old buffer's entry to list of WINDOW's previous ;; buffers so it's less likely to get switched to soon but ;; `display-buffer-in-previous-window' can nevertheless find it. (set-window-prev-buffers window (append (window-prev-buffers window) (list entry)))) - ;; Reset the quit-restore parameter. - (set-window-parameter window 'quit-restore nil) - ;; Select old window. + ;; Reset the quit-restore(-prev) parameter. + (set-window-parameter window 'quit-restore-prev nil) + (unless reset-prev + ;; If quit-restore-prev was not used, reset the quit-restore + ;; parameter + (set-window-parameter window 'quit-restore nil)) ;; If the previously selected window is still alive, select it. (window--quit-restore-select-window quit-restore-2)) (t - ;; Show some other buffer in WINDOW and reset the quit-restore - ;; parameter. - (set-window-parameter window 'quit-restore nil) + ;; Show some other buffer in WINDOW and leave the + ;; quit-restore(-prev) parameters alone (Juri's idea). ;; Make sure that WINDOW is no more dedicated. (set-window-dedicated-p window nil) ;; Try to switch to a previous buffer. Delete the window only if @@ -5298,16 +5430,14 @@ nil means to not handle the buffer in a particular way. This (if (switch-to-prev-buffer window bury-or-kill) (when (eq dedicated 'side) (set-window-dedicated-p window 'side)) - (window--delete window nil (eq bury-or-kill 'kill)) - ;; If the previously selected window is still alive, select it. - (window--quit-restore-select-window quit-restore-2)))) - + (window--delete + window nil (memq bury-or-kill '(kill killing)))))) ;; Deal with the buffer. (cond ((not (buffer-live-p buffer))) ((eq bury-or-kill 'kill) (kill-buffer buffer)) - (bury-or-kill + ((eq bury-or-kill 'bury) (bury-buffer-internal buffer))))) (defun quit-window (&optional kill window) @@ -5337,18 +5467,31 @@ non-nil means to kill BUFFER-OR-NAME. KILL nil means to bury BUFFER-OR-NAME. Optional argument FRAME is handled as by `delete-windows-on'. -This function calls `quit-window' on all candidate windows -showing BUFFER-OR-NAME." +This function calls `quit-restore-window' on all candidate windows +showing BUFFER-OR-NAME. In addition, it removes the buffer denoted by +BUFFER-OR-NAME from all window-local buffer lists and removes any +`quit-restore' or `quit-restore-prev' parameters mentioning it." (interactive "bQuit windows on (buffer):\nP") (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other - ;; `window-list-1' based function. - (all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) - (dolist (window (window-list-1 nil nil all-frames)) - (if (eq (window-buffer window) buffer) - (quit-window kill window) - ;; If a window doesn't show BUFFER, unrecord BUFFER in it. - (unrecord-window-buffer window buffer))))) + ;; `window-list' based function. + (frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) + (dolist (window (window-list-1 nil nil frames)) + (when (eq (window-buffer window) buffer) + (with-current-buffer buffer + (run-hooks 'quit-window-hook)) + (quit-restore-window + window (if kill 'killing 'burying))) + + (when (window-live-p window) + ;; Unrecord BUFFER in this window. + (unrecord-window-buffer window buffer t))) + + ;; Deal with BUFFER-OR-NAME. + (cond + ((not (buffer-live-p buffer))) + (kill (kill-buffer buffer)) + (t (bury-buffer-internal buffer))))) (defun window--combination-resizable (parent &optional horizontal) "Return number of pixels recoverable from height of window PARENT. @@ -5456,6 +5599,13 @@ frame. The selected window is not changed by this function." (setq atom-root (window-atom-root window)) (not (eq atom-root window))) (throw 'done (split-window atom-root size side pixelwise))) + ;; If WINDOW's frame has a side window and WINDOW specifies the + ;; frame's root window, split the frame's main window instead + ;; (Bug#73627). + ((and (eq window (frame-root-window frame)) + (window-with-parameter 'window-side nil frame)) + (throw 'done (split-window (window-main-window frame) + size side pixelwise))) ;; If WINDOW is a side window or its first or last child is a ;; side window, throw an error unless `window-combination-resize' ;; equals 'side. @@ -6658,34 +6808,42 @@ or `other'. The second element is either one of the symbols previously shown in the window, that buffer's window start and window point, and the window's height. The third element is the window selected at the time the parameter was created. The -fourth element is BUFFER." +fourth element is BUFFER. + +If TYPE is `reuse', BUFFER is different from the one currently displayed +in WINDOW, and WINDOW already has a `quit-restore' parameter, install or +update a `quit-restore-prev' parameter for this window. This allows for +quitting WINDOW in a similar fashion but also keeps the very first +`quit-restore' parameter stored for this window around. Consequently, +WINDOW (or its frame) can be eventually deleted by `quit-restore-widow' +if that parameter's fourth element equals WINDOW's buffer." (cond ((eq type 'reuse) - (if (eq (window-buffer window) buffer) - ;; WINDOW shows BUFFER already. Update WINDOW's quit-restore - ;; parameter, if any. - (let ((quit-restore (window-parameter window 'quit-restore))) + (let ((quit-restore (window-parameter window 'quit-restore))) + (if (eq (window-buffer window) buffer) + ;; WINDOW shows BUFFER already. Update WINDOW's quit-restore + ;; parameter, if any. (when (consp quit-restore) (setcar quit-restore 'same) ;; The selected-window might have changed in ;; between (Bug#20353). (unless (or (eq window (selected-window)) - (eq window (nth 2 quit-restore))) - (setcar (cddr quit-restore) (selected-window))))) - ;; WINDOW shows another buffer. - (with-current-buffer (window-buffer window) - (set-window-parameter - window 'quit-restore - (list 'other - ;; A quadruple of WINDOW's buffer, start, point and height. - (list (current-buffer) (window-start window) - ;; Preserve window-point-insertion-type (Bug#12855). - (copy-marker - (window-point window) window-point-insertion-type) - (if (window-combined-p window) - (window-total-height window) - (window-total-width window))) - (selected-window) buffer))))) + (eq window (nth 2 quit-restore))) + (setcar (cddr quit-restore) (selected-window)))) + ;; WINDOW shows another buffer. + (with-current-buffer (window-buffer window) + (set-window-parameter + window (if quit-restore 'quit-restore-prev 'quit-restore) + (list 'other + ;; A quadruple of WINDOW's buffer, start, point and height. + (list (current-buffer) (window-start window) + ;; Preserve window-point-insertion-type (Bug#12855). + (copy-marker + (window-point window) window-point-insertion-type) + (if (window-combined-p window) + (window-total-height window) + (window-total-width window))) + (selected-window) buffer)))))) ((eq type 'window) ;; WINDOW has been created on an existing frame. (set-window-parameter @@ -7936,7 +8094,7 @@ specified by the ACTION argument." (while (and functions (not window)) (setq window (funcall (car functions) buffer alist) functions (cdr functions))) - (when-let ((select (assq 'post-command-select-window alist))) + (when-let* ((select (assq 'post-command-select-window alist))) (letrec ((old-selected-window (selected-window)) (postfun (lambda () @@ -8029,10 +8187,10 @@ This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (when-let ((window (or (display-buffer-reuse-window buffer alist) - (display-buffer-same-window buffer alist) - (display-buffer-pop-up-window buffer alist) - (display-buffer-use-some-window buffer alist)))) + (when-let* ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) (delete-other-windows window) window)) @@ -8957,35 +9115,6 @@ currently selected window; otherwise it will be displayed in another window." (pop-to-buffer buffer display-buffer--same-window-action norecord)) -(defcustom display-comint-buffer-action - (append display-buffer--same-window-action '((category . comint))) - "`display-buffer' action for displaying comint buffers." - :type display-buffer--action-custom-type - :risky t - :version "29.1" - :group 'windows - :group 'comint) - -(make-obsolete-variable - 'display-comint-buffer-action - "use a `(category . comint)' condition in `display-buffer-alist'." - "30.1") - -(defcustom display-tex-shell-buffer-action '(display-buffer-in-previous-window - (inhibit-same-window . t) - (category . tex-shell)) - "`display-buffer' action for displaying TeX shell buffers." - :type display-buffer--action-custom-type - :risky t - :version "29.1" - :group 'windows - :group 'tex-run) - -(make-obsolete-variable - 'display-tex-shell-buffer-action - "use a `(category . tex-shell)' condition in `display-buffer-alist'." - "30.1") - (defun read-buffer-to-switch (prompt) "Read the name of a buffer to switch to, prompting with PROMPT. Return the name of the buffer as a string. @@ -9130,6 +9259,9 @@ the buffer in the selected window, window start and point are adjusted as prescribed by the option `switch-to-buffer-preserve-window-point'. Otherwise, these are left alone. +In either case, call `display-buffer-record-window' to avoid disrupting +a sequence of `display-buffer' operations using this window. + Return the buffer switched to." (interactive (let ((force-same-window @@ -9190,6 +9322,11 @@ Return the buffer switched to." buffer)) (displayed (and (eq preserve-win-point 'already-displayed) (get-buffer-window buffer 0)))) + + ;; Make sure quitting the window works. + (unless switch-to-buffer-obey-display-actions + (display-buffer-record-window 'reuse (selected-window) buffer)) + (set-window-buffer nil buffer) (when (and entry (or (eq preserve-win-point t) displayed)) ;; Try to restore start and point of buffer in the selected @@ -10905,10 +11042,10 @@ that can be later used as argument for `window-point-context-use-function'. Remember the returned context in the window parameter `context'." (walk-windows (lambda (w) - (when-let ((fn (buffer-local-value 'window-point-context-set-function - (window-buffer w))) - ((functionp fn)) - (context (funcall fn w))) + (when-let* ((fn (buffer-local-value 'window-point-context-set-function + (window-buffer w))) + ((functionp fn)) + (context (funcall fn w))) (set-window-parameter w 'context (cons (buffer-name (window-buffer w)) context)))) 'nomini)) @@ -10924,11 +11061,11 @@ The function called is supposed to set the window point to the location found by the provided context." (walk-windows (lambda (w) - (when-let ((fn (buffer-local-value 'window-point-context-use-function - (window-buffer w))) - ((functionp fn)) - (context (window-parameter w 'context)) - ((equal (buffer-name (window-buffer w)) (car context)))) + (when-let* ((fn (buffer-local-value 'window-point-context-use-function + (window-buffer w))) + ((functionp fn)) + (context (window-parameter w 'context)) + ((equal (buffer-name (window-buffer w)) (car context)))) (funcall fn w (cdr context)) (set-window-parameter w 'context nil))) 'nomini)) @@ -10953,11 +11090,11 @@ found by the provided context." (let ((point (window-point w))) (save-excursion (goto-char point) - (when-let ((f (alist-get 'front-context-string context)) - ((search-forward f (point-max) t))) + (when-let* ((f (alist-get 'front-context-string context)) + ((search-forward f (point-max) t))) (goto-char (match-beginning 0)) - (when-let ((r (alist-get 'rear-context-string context)) - ((search-backward r (point-min) t))) + (when-let* ((r (alist-get 'rear-context-string context)) + ((search-backward r (point-min) t))) (goto-char (match-end 0)) (setq point (point))))) (set-window-point w point)))) diff --git a/lisp/xdg.el b/lisp/xdg.el index 4c675489400..dc04fa88b03 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -291,7 +291,7 @@ According to the XDG Desktop Entry Specification version 0.5: colon-separated list of strings ... $XDG_CURRENT_DESKTOP should have been set by the login manager, according to the value of the DesktopNames found in the session file." - (when-let ((ret (getenv "XDG_CURRENT_DESKTOP"))) + (when-let* ((ret (getenv "XDG_CURRENT_DESKTOP"))) (string-split ret ":"))) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index c5a84db6d4a..04581a75bc0 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -439,7 +439,7 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (cond ((eq xwidget-event-type 'load-changed) (let ((title (xwidget-webkit-title xwidget)) (uri (xwidget-webkit-uri xwidget))) - (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) + (when-let* ((buffer (get-buffer "*Xwidget WebKit History*"))) (with-current-buffer buffer (revert-buffer))) (with-current-buffer (xwidget-buffer xwidget) diff --git a/lisp/yank-media.el b/lisp/yank-media.el index 563aae85419..17981c37c0e 100644 --- a/lisp/yank-media.el +++ b/lisp/yank-media.el @@ -67,7 +67,12 @@ all the different selection types." (lambda (type) (pcase-let ((`(,major ,minor) (split-string (symbol-name type) "/"))) (if (and (equal major "image") - (not (image-type-available-p (intern minor)))) + (not (image-type-available-p + ;; Usually, MIME subtype is the same as Emacs' + ;; identifier for an image type. But for SVG, the + ;; identifier is 'svg, while the MIME type is + ;; image/svg+xml. So we make the exception here. + (intern (if (string= minor "svg+xml") "svg" minor))))) ;; Just filter out all the image types that Emacs doesn't ;; support, because the clipboard is full of things like ;; `image/x-win-bitmap'. @@ -81,7 +86,7 @@ all the different selection types." (gui-get-selection 'CLIPBOARD 'TARGETS))) (defun yank-media--get-selection (data-type) - (when-let ((data (gui-get-selection 'CLIPBOARD data-type))) + (when-let* ((data (gui-get-selection 'CLIPBOARD data-type))) (if (string-match-p "\\`text/" (symbol-name data-type)) (yank-media-types--format data-type data) data))) @@ -116,7 +121,7 @@ non-supported selection data types." (let ((elements nil)) ;; First gather all the data. (dolist (type '(PRIMARY CLIPBOARD)) - (when-let ((data-types (gui-get-selection type 'TARGETS))) + (when-let* ((data-types (gui-get-selection type 'TARGETS))) (when (vectorp data-types) (seq-do (lambda (data-type) (unless (memq data-type '( TARGETS MULTIPLE |