diff options
Diffstat (limited to 'lisp')
73 files changed, 1200 insertions, 499 deletions
diff --git a/lisp/apropos.el b/lisp/apropos.el index f2460643ab3..376c1b2cbc5 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -724,22 +724,27 @@ the output includes key-bindings of commands." ;; (autoload (push (cdr x) autoloads)) ('require (push (cdr x) requires)) ('provide (push (cdr x) provides)) - ('t nil) ; Skip "was an autoload" entries. + ('t nil) ; Skip "was an autoload" entries. ;; FIXME: Print information about each individual method: both ;; its docstring and specializers (bug#21422). ('cl-defmethod (push (cadr x) provides)) (_ (push (or (cdr-safe x) x) symbols)))) - (let ((apropos-pattern "")) ;Dummy binding for apropos-symbols-internal. - (apropos-symbols-internal - symbols apropos-do-all - (concat - (format-message - "Library `%s' provides: %s\nand requires: %s" - file - (mapconcat #'apropos-library-button - (or provides '(nil)) " and ") - (mapconcat #'apropos-library-button - (or requires '(nil)) " and "))))))) + (let ((apropos-pattern "") ;Dummy binding for apropos-symbols-internal. + (text + (concat + (format-message + "Library `%s' provides: %s\nand requires: %s" + file + (mapconcat #'apropos-library-button + (or provides '(nil)) " and ") + (mapconcat #'apropos-library-button + (or requires '(nil)) " and "))))) + (if (null symbols) + (with-output-to-temp-buffer "*Apropos*" + (with-current-buffer standard-output + (apropos-mode) + (apropos--preamble text))) + (apropos-symbols-internal symbols apropos-do-all text))))) (defun apropos-symbols-internal (symbols keys &optional text) ;; Filter out entries that are marked as apropos-inhibit. @@ -1154,10 +1159,7 @@ as a heading." symbol item) (set-buffer standard-output) (apropos-mode) - (insert (substitute-command-keys "Type \\[apropos-follow] on ") - (if apropos-multi-type "a type label" "an entry") - " to view its full documentation.\n\n") - (if text (insert text "\n\n")) + (apropos--preamble text) (dolist (apropos-item p) (when (and spacing (not (bobp))) (princ spacing)) @@ -1287,6 +1289,14 @@ as a heading." (fill-region opoint (point) nil t))) (or (bolp) (terpri))))) +(defun apropos--preamble (text) + (let ((inhibit-read-only t)) + (insert (substitute-command-keys "Type \\[apropos-follow] on ") + (if apropos-multi-type "a type label" "an entry") + " to view its full documentation.\n\n") + (when text + (insert text "\n\n")))) + (defun apropos-follow () "Invokes any button at point, otherwise invokes the nearest label button." (interactive) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 31e41a9273c..52b96fd2038 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -467,18 +467,18 @@ See user option `bookmark-fontify'." "Remove a bookmark's colorized overlay. BM is a bookmark as returned from function `bookmark-get-bookmark'. See user option `bookmark-fontify'." - (let ((filename (assq 'filename bm)) - (pos (assq 'position bm)) + (let ((filename (cdr (assq 'filename bm))) + (pos (cdr (assq 'position bm))) overlays found temp) - (when filename (setq filename (expand-file-name (cdr filename)))) - (when pos (setq pos (cdr pos))) - (dolist (buf (buffer-list)) - (with-current-buffer buf - (when (equal filename buffer-file-name) - (setq overlays (overlays-at pos)) - (while (and (not found) (setq temp (pop overlays))) - (when (eq 'bookmark (overlay-get temp 'category)) - (delete-overlay (setq found temp))))))))) + (when (and pos filename) + (setq filename (expand-file-name filename)) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (equal filename buffer-file-name) + (setq overlays (overlays-at pos)) + (while (and (not found) (setq temp (pop overlays))) + (when (eq 'bookmark (overlay-get temp 'category)) + (delete-overlay (setq found temp)))))))))) (defun bookmark-completing-read (prompt &optional default) "Prompting with PROMPT, read a bookmark name in completion. diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 0103d5c2ce9..5ec6af470ae 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1665,8 +1665,11 @@ Otherwise use brackets." 'custom-button-pressed 'custom-button-pressed-unraised)))) +(defvar custom--invocation-options nil) + (defun custom-buffer-create-internal (options &optional _description) (Custom-mode) + (setq custom--invocation-options options) (let ((init-file (or custom-file user-init-file))) ;; Insert verbose help at the top of the custom buffer. (when custom-buffer-verbose-help @@ -2821,7 +2824,7 @@ the present value is saved to its :shown-value property instead." (list (widget-value (car-safe (widget-get widget :children))))) - (error "There are unsaved changes"))) + (message "Note: There are unsaved changes"))) (widget-put widget :documentation-shown nil) (widget-put widget :custom-state 'hidden)) (custom-redraw widget) @@ -5152,11 +5155,19 @@ if that value is non-nil." :label (nth 5 arg))) custom-commands) (setq custom-tool-bar-map map)))) + (setq-local custom--invocation-options nil) + (setq-local revert-buffer-function #'custom--revert-buffer) (make-local-variable 'custom-options) (make-local-variable 'custom-local-buffer) (custom--initialize-widget-variables) (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)) +(defun custom--revert-buffer (_ignore-auto _noconfirm) + (unless custom--invocation-options + (error "Insufficient data to revert")) + (custom-buffer-create custom--invocation-options + (buffer-name))) + (put 'Custom-mode 'mode-class 'special) (provide 'cus-edit) diff --git a/lisp/desktop.el b/lisp/desktop.el index ae8d026acc4..b9467c87527 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -759,7 +759,10 @@ is nil, ask the user where to save the desktop." (unless (yes-or-no-p "Error while saving the desktop. Ignore? ") (signal (car err) (cdr err)))))) ;; If we own it, we don't anymore. - (when (eq (emacs-pid) (desktop-owner)) (desktop-release-lock)) + (when (eq (emacs-pid) (desktop-owner)) + ;; Allow exiting Emacs even if we can't delete the desktop file. + (ignore-error 'file-error + (desktop-release-lock))) t) ;; ---------------------------------------------------------------------------- diff --git a/lisp/dired.el b/lisp/dired.el index 9ddd2c542dc..28448be06ce 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -163,7 +163,7 @@ always set this variable to t." :type 'boolean :group 'dired-mark) -(defcustom dired-trivial-filenames (purecopy "\\`\\.\\.?\\'\\|\\`#") +(defcustom dired-trivial-filenames (purecopy "\\`\\.\\.?\\'\\|\\`\\.?#") "Regexp of files to skip when finding first file of a directory. A value of nil means move to the subdir line. A value of t means move to first file." @@ -356,6 +356,11 @@ is anywhere on its Dired line, except the beginning of the line." :group 'dired :version "28.1") +(defcustom dired-kill-when-opening-new-dired-buffer nil + "If non-nil, kill the current buffer when selecting a new directory." + :type 'boolean + :version "28.1") + ;;; Internal variables @@ -615,6 +620,31 @@ Subexpression 2 must end right before the \\n.") (list dired-re-dir '(".+" (dired-move-to-filename) nil (0 dired-directory-face))) ;; + ;; Files suffixed with `completion-ignored-extensions'. + '(eval . + ;; It is quicker to first find just an extension, then go back to the + ;; start of that file name. So we do this complex MATCH-ANCHORED form. + (list (concat + "\\(" (regexp-opt completion-ignored-extensions) + "\\|#\\|\\.#.+\\)$") + '(".+" (dired-move-to-filename) nil (0 dired-ignored-face)))) + ;; + ;; Files suffixed with `completion-ignored-extensions' + ;; plus a character put in by -F. + '(eval . + (list (concat "\\(" (regexp-opt completion-ignored-extensions) + "\\|#\\|\\.#.+\\)[*=|]$") + '(".+" (progn + (end-of-line) + ;; If the last character is not part of the filename, + ;; move back to the start of the filename + ;; so it can be fontified. + ;; Otherwise, leave point at the end of the line; + ;; that way, nothing is fontified. + (unless (get-text-property (1- (point)) 'mouse-face) + (dired-move-to-filename))) + nil (0 dired-ignored-face)))) + ;; ;; Broken Symbolic link. (list dired-re-sym (list (lambda (end) @@ -659,29 +689,6 @@ Subexpression 2 must end right before the \\n.") (list dired-re-special '(".+" (dired-move-to-filename) nil (0 'dired-special))) ;; - ;; Files suffixed with `completion-ignored-extensions'. - '(eval . - ;; It is quicker to first find just an extension, then go back to the - ;; start of that file name. So we do this complex MATCH-ANCHORED form. - (list (concat "\\(" (regexp-opt completion-ignored-extensions) "\\|#\\)$") - '(".+" (dired-move-to-filename) nil (0 dired-ignored-face)))) - ;; - ;; Files suffixed with `completion-ignored-extensions' - ;; plus a character put in by -F. - '(eval . - (list (concat "\\(" (regexp-opt completion-ignored-extensions) - "\\|#\\)[*=|]$") - '(".+" (progn - (end-of-line) - ;; If the last character is not part of the filename, - ;; move back to the start of the filename - ;; so it can be fontified. - ;; Otherwise, leave point at the end of the line; - ;; that way, nothing is fontified. - (unless (get-text-property (1- (point)) 'mouse-face) - (dired-move-to-filename))) - nil (0 dired-ignored-face)))) - ;; ;; Explicitly put the default face on file names ending in a colon to ;; avoid fontifying them as directory header. (list (concat dired-re-maybe-mark dired-re-inode-size dired-re-perms ".*:$") @@ -2377,7 +2384,7 @@ directory in another window." (progn (if other-window (dired-other-window up) - (dired up)) + (dired--find-possibly-alternative-file up)) (dired-goto-file dir))))) (defun dired-get-file-for-visit () @@ -2401,7 +2408,16 @@ directory in another window." (defun dired-find-file () "In Dired, visit the file or directory named on this line." (interactive) - (dired--find-file #'find-file (dired-get-file-for-visit))) + (dired--find-possibly-alternative-file (dired-get-file-for-visit))) + +(defun dired--find-possibly-alternative-file (file) + "Find FILE, but respect `dired-kill-when-opening-new-dired-buffer'." + (if (and dired-kill-when-opening-new-dired-buffer + (file-directory-p file)) + (progn + (set-buffer-modified-p nil) + (dired--find-file #'find-alternate-file file)) + (dired--find-file #'find-file file))) (defun dired--find-file (find-file-function file) "Call FIND-FILE-FUNCTION on FILE, but bind some relevant variables." @@ -3834,13 +3850,13 @@ object files--just `.o' will mark more than you might think." when (stringp file) sum (file-attribute-size (file-attributes file))))) (if (zerop nmarked) - (message "No marked files")) - (message "%d marked file%s (%s total size)" - nmarked - (if (= nmarked 1) - "" - "s") - (funcall byte-count-to-string-function size)))) + (message "No marked files") + (message "%d marked file%s (%s total size)" + nmarked + (if (= nmarked 1) + "" + "s") + (funcall byte-count-to-string-function size))))) (defun dired-mark-files-containing-regexp (regexp &optional marker-char) "Mark all files with contents containing REGEXP for use in later commands. diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index b45984be1d5..9d1ae705976 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -250,7 +250,10 @@ expression, in which case we want to handle forms differently." (custom-autoload ',varname ,file ,(condition-case nil (null (plist-get props :set)) - (error nil)))))) + (error nil))) + ;; Propagate the :safe property to the loaddefs file. + ,@(when-let ((safe (plist-get props :safe))) + `((put ',varname 'safe-local-variable ,safe)))))) ((eq car 'defgroup) ;; In Emacs this is normally handled separately by cus-dep.el, but for diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3e65db42421..6970c8a5055 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1627,7 +1627,7 @@ the `\\\\=[command]' ones that are assumed to be of length `byte-compile--wide-docstring-substitution-len'. Also ignore URLs." (string-match - (format "^.\\{%s,\\}$" (int-to-string (1+ col))) + (format "^.\\{%d,\\}$" (min (1+ col) #xffff)) ; Heed RE_DUP_MAX. (replace-regexp-in-string (rx (or ;; Ignore some URLs. @@ -1857,8 +1857,7 @@ also be compiled." (file-readable-p source) (not (string-match "\\`\\.#" file)) (not (auto-save-file-name-p source)) - (not (string-equal dir-locals-file - (file-name-nondirectory source)))) + (not (member source (dir-locals--all-files directory)))) (progn (cl-incf (pcase (byte-recompile-file source force arg) ('no-byte-compile skip-count) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index f6637109028..f1579cda8bd 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -259,7 +259,8 @@ Returns a form where all lambdas don't have any free variables." (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0)) ;; As a special exception, ignore "ignore". - (eq var 'ignored)) + (eq var 'ignored) + (not (byte-compile-warning-enabled-p 'unbound var))) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) (format "Unused lexical %s `%S'%s" varkind var diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 1c8c372aaef..b31ea42a99b 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -53,6 +53,7 @@ (message eieio-version)) (require 'eieio-core) +(eval-when-compile (require 'subr-x)) ;;; Defining a new class @@ -740,31 +741,37 @@ Called from the constructor routine." "Construct the new object THIS based on SLOTS.") (cl-defmethod initialize-instance ((this eieio-default-superclass) - &optional slots) + &optional args) "Construct the new object THIS based on SLOTS. -SLOTS is a tagged list where odd numbered elements are tags, and +ARGS is a property list where odd numbered elements are tags, and even numbered elements are the values to store in the tagged slot. If you overload the `initialize-instance', there you will need to call `shared-initialize' yourself, or you can call `call-next-method' to have this constructor called automatically. If these steps are not taken, then new objects of your class will not have their values -dynamically set from SLOTS." - ;; First, see if any of our defaults are `lambda', and - ;; re-evaluate them and apply the value to our slots. +dynamically set from ARGS." (let* ((this-class (eieio--object-class this)) + (initargs args) (slots (eieio--class-slots this-class))) (dotimes (i (length slots)) - ;; For each slot, see if we need to evaluate it. + ;; For each slot, see if we need to evaluate its initform. (let* ((slot (aref slots i)) + (slot-name (eieio-slot-descriptor-name slot)) (initform (cl--slot-descriptor-initform slot))) - ;; Those slots whose initform is constant already have the right - ;; value set in the default-object. - (unless (macroexp-const-p initform) - ;; FIXME: We should be able to just do (aset this (+ i <cst>) dflt)! - (eieio-oset this (cl--slot-descriptor-name slot) - (eval initform t)))))) - ;; Shared initialize will parse our slots for us. - (shared-initialize this slots)) + (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. + (macroexp-const-p initform)) + ;; FIXME: Use `aset' instead of `eieio-oset', relying on that + ;; vector returned by `eieio--class-slots' + ;; should be congruent with the object itself. + (eieio-oset this slot-name (eval initform t)))))) + ;; Shared initialize will parse our args for us. + (shared-initialize this args)) (cl-defgeneric slot-missing (object slot-name _operation &optional _new-value) "Method invoked when an attempt to access a slot in OBJECT fails. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index df864464b77..f4bab9c3456 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -318,16 +318,20 @@ Assumes the caller has bound `macroexpand-all-environment'." (`(,(or 'function 'quote) . ,_) form) (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) pcase--dontcare)) - (macroexp--cons fun - (macroexp--cons (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil t)) - (macroexp--all-forms body)) - (cdr form)) - form)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (and (or (not (fboundp 'byte-compile-warning-enabled-p)) + (byte-compile-warning-enabled-p t)) + (format "Empty %s body" fun)) + nil t)) + (macroexp--all-forms body)) + (cdr form)) + form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. ;; If the byte-optimizer is loaded, try to unfold this, diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index f4f03133b0f..1125dde4055 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -44,6 +44,8 @@ by counted more than once." (pop-to-buffer "*Memory Report*") (special-mode) (button-mode 1) + (setq-local revert-buffer-function (lambda (_ignore-auto _noconfirm) + (memory-report))) (setq truncate-lines t) (message "Gathering data...") (let ((reports (append (memory-report--garbage-collect) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index a0f1ab0ed67..6bbd4c99763 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -3954,9 +3954,14 @@ packages." (package--ensure-package-menu-mode) (if (or (not status) (string-empty-p status)) (package-menu--generate t t) - (package-menu--filter-by (lambda (pkg-desc) - (string-match-p status (package-desc-status pkg-desc))) - (format "status:%s" status)))) + (let ((status-list + (if (listp status) + status + (split-string status ",")))) + (package-menu--filter-by + (lambda (pkg-desc) + (member (package-desc-status pkg-desc) status-list)) + (format "status:%s" (string-join status-list ",")))))) (defun package-menu-filter-by-version (version predicate) "Filter the \"*Packages*\" buffer by VERSION and PREDICATE. diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index 7d042a9102e..396949d59a2 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -355,11 +355,16 @@ provided in the Commentary section of this library." (reb-delete-overlays)) (setq reb-target-buffer (current-buffer) reb-target-window (selected-window)) - (select-window (or (get-buffer-window reb-buffer) - (progn - (setq reb-window-config (current-window-configuration)) - (split-window (selected-window) (- (window-height) 4))))) - (switch-to-buffer (get-buffer-create reb-buffer)) + (select-window + (or (get-buffer-window reb-buffer) + (let ((dir (if (window-parameter nil 'window-side) + 'bottom 'down))) + (setq reb-window-config (current-window-configuration)) + (display-buffer + (get-buffer-create reb-buffer) + `((display-buffer-in-direction) + (direction . ,dir) + (dedicated . t)))))) (font-lock-mode 1) (reb-initialize-buffer))) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index c1d05941239..02f2ad3d816 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -115,9 +115,12 @@ See the documentation for `list-load-path-shadows' for further information." ;; FILE now contains the current file name, with no suffix. (unless (or (member file files-seen-this-dir) ;; Ignore these files. - (member file (list "subdirs" "leim-list" - (file-name-sans-extension - dir-locals-file)))) + (member file + (list "subdirs" "leim-list" + (file-name-sans-extension dir-locals-file) + (concat + (file-name-sans-extension dir-locals-file) + "-2")))) ;; File has not been seen yet in this directory. ;; This test prevents us declaring that XXX.el shadows ;; XXX.elc (or vice-versa) when they are in the same directory. diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 4df404015a0..4beba1dbed1 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -162,6 +162,10 @@ There can be any number of :example/:result elements." :eval (split-string "foo bar") :eval (split-string "|foo|bar|" "|") :eval (split-string "|foo|bar|" "|" t)) + (split-string-and-unquote + :eval (split-string-and-unquote "foo \"bar zot\"")) + (split-string-shell-command + :eval (split-string-shell-command "ls /tmp/'foo bar'")) (string-lines :eval (string-lines "foo\n\nbar") :eval (string-lines "foo\n\nbar" t)) @@ -499,9 +503,13 @@ There can be any number of :example/:result elements." (flatten-tree :eval (flatten-tree '(1 (2 3) 4))) (car - :eval (car '(one two three))) + :eval (car '(one two three)) + :eval (car '(one . two)) + :eval (car nil)) (cdr - :eval (cdr '(one two three))) + :eval (cdr '(one two three)) + :eval (cdr '(one . two)) + :eval (cdr nil)) (last :eval (last '(one two three))) (butlast @@ -1137,8 +1145,9 @@ There can be any number of :example/:result elements." :eval (sqrt -1))) ;;;###autoload -(defun shortdoc-display-group (group) - "Pop to a buffer with short documentation summary for functions in GROUP." +(defun shortdoc-display-group (group &optional function) + "Pop to a buffer with short documentation summary for functions in GROUP. +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) @@ -1169,15 +1178,17 @@ There can be any number of :example/:result elements." (setq prev t) (shortdoc--display-function data)))) (cdr (assq group shortdoc--groups)))) - (goto-char (point-min))) + (goto-char (point-min)) + (when function + (text-property-search-forward 'shortdoc-function function t) + (beginning-of-line))) (defun shortdoc--display-function (data) (let ((function (pop data)) (start-section (point)) arglist-start) ;; Function calling convention. - (insert (propertize "(" - 'shortdoc-function t)) + (insert (propertize "(" 'shortdoc-function function)) (if (plist-get data :no-manual) (insert-text-button (symbol-name function) @@ -1308,16 +1319,15 @@ Example: (define-derived-mode shortdoc-mode special-mode "shortdoc" "Mode for shortdoc.") -(defmacro shortdoc--goto-section (arg sym &optional reverse) - `(progn - (unless (natnump ,arg) - (setq ,arg 1)) - (while (< 0 ,arg) - (,(if reverse - 'text-property-search-backward - 'text-property-search-forward) - ,sym t) - (setq ,arg (1- ,arg))))) +(defun shortdoc--goto-section (arg sym &optional reverse) + (unless (natnump arg) + (setq arg 1)) + (while (> arg 0) + (funcall + (if reverse 'text-property-search-backward + 'text-property-search-forward) + sym nil t t) + (setq arg (1- arg)))) (defun shortdoc-next (&optional arg) "Move cursor to the next function. diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 0b10dfdc0af..04f3b70aaa8 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -36,6 +36,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup tabulated-list nil "Tabulated-list customization group." :group 'convenience @@ -645,18 +647,41 @@ this is the vector stored within it." (defun tabulated-list-sort (&optional n) "Sort Tabulated List entries by the column at point. -With a numeric prefix argument N, sort the Nth column." +With a numeric prefix argument N, sort the Nth column. + +If the numeric prefix is -1, restore order the list was +originally displayed in." (interactive "P") - (let ((name (if n - (car (aref tabulated-list-format n)) - (get-text-property (point) - 'tabulated-list-column-name)))) - (if (nth 2 (assoc name (append tabulated-list-format nil))) - (tabulated-list--sort-by-column-name name) - (user-error "Cannot sort by %s" name)))) + (if (equal n -1) + ;; Restore original order. + (progn + (unless tabulated-list--original-order + (error "Order is already in original order")) + (setq tabulated-list-entries + (sort tabulated-list-entries + (lambda (e1 e2) + (< (gethash e1 tabulated-list--original-order) + (gethash e2 tabulated-list--original-order))))) + (setq tabulated-list-sort-key nil) + (tabulated-list-init-header) + (tabulated-list-print t)) + ;; Sort based on a column name. + (let ((name (if n + (car (aref tabulated-list-format n)) + (get-text-property (point) + 'tabulated-list-column-name)))) + (if (nth 2 (assoc name (append tabulated-list-format nil))) + (tabulated-list--sort-by-column-name name) + (user-error "Cannot sort by %s" name))))) (defun tabulated-list--sort-by-column-name (name) (when (and name (derived-mode-p 'tabulated-list-mode)) + (unless tabulated-list--original-order + ;; Store the original order so that we can restore it later. + (setq tabulated-list--original-order (make-hash-table)) + (cl-loop for elem in tabulated-list-entries + for i from 0 + do (setf (gethash elem tabulated-list--original-order) i))) ;; Flip the sort order on a second click. (if (equal name (car tabulated-list-sort-key)) (setcdr tabulated-list-sort-key @@ -717,6 +742,8 @@ Interactively, N is the prefix numeric argument, and defaults to ;;; The mode definition: +(defvar tabulated-list--original-order nil) + (define-derived-mode tabulated-list-mode special-mode "Tabulated" "Generic major mode for browsing a list of items. This mode is usually not used directly; instead, other major @@ -757,6 +784,7 @@ as the ewoc pretty-printer." (setq-local glyphless-char-display (tabulated-list-make-glyphless-char-display-table)) (setq-local text-scale-remap-header-line t) + (setq-local tabulated-list--original-order nil) ;; Avoid messing up the entries' display just because the first ;; column of the first entry happens to begin with a R2L letter. (setq bidi-paragraph-direction 'left-to-right) diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 855ce0be69e..7229d6163df 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -244,6 +244,10 @@ return a string which is inserted. It may set `facemenu-end-add-face'." (define-key map [fc] (cons "Face" 'facemenu-face-menu))) (defalias 'facemenu-menu facemenu-menu) +;;;###autoload (autoload 'facemenu-menu "facemenu" nil nil 'keymap) +;;;###autoload +(define-key global-map [C-down-mouse-2] 'facemenu-menu) + (easy-menu-add-item menu-bar-edit-menu nil ["Text Properties" facemenu-menu]) @@ -714,7 +718,13 @@ they are used to set the face information. As a special case, if FACE is `default', then the region is left with NO face text property. Otherwise, selecting the default face would not have any effect. See `facemenu-remove-face-function'." - (interactive "*xFace: \nr") + (interactive (list (progn + (barf-if-buffer-read-only) + (read-face-name "Use face" (face-at-point t))) + (if (and mark-active (not current-prefix-arg)) + (region-beginning)) + (if (and mark-active (not current-prefix-arg)) + (region-end)))) (cond ((and (eq face 'default) (not (eq facemenu-remove-face-function t))) diff --git a/lisp/faces.el b/lisp/faces.el index bc0c3f9d9b8..301b2493b0a 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2914,23 +2914,30 @@ It is used for characters of no fonts too." ;; Faces for TTY menus. (defface tty-menu-enabled-face - '((t - :foreground "yellow" :background "blue" :weight bold)) + '((((class color)) + :foreground "yellow" :background "blue" :weight bold) + (t :weight bold)) "Face for displaying enabled items in TTY menus." - :group 'basic-faces) + :group 'basic-faces + :version "28.1") (defface tty-menu-disabled-face '((((class color) (min-colors 16)) :foreground "lightgray" :background "blue") - (t - :foreground "white" :background "blue")) + (((class color)) + :foreground "white" :background "blue") + (t :inherit shadow)) "Face for displaying disabled items in TTY menus." - :group 'basic-faces) + :group 'basic-faces + :version "28.1") (defface tty-menu-selected-face - '((t :background "red")) + '((((class color)) + :background "red") + (t :inverse-video t)) "Face for displaying the currently selected item in TTY menus." - :group 'basic-faces) + :group 'basic-faces + :version "28.1") (defgroup paren-showing-faces nil "Faces used to highlight paren matches." diff --git a/lisp/ffap.el b/lisp/ffap.el index 6faf8d50b26..c31926eb299 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -260,6 +260,7 @@ ffap most of the time." :type 'boolean :group 'ffap) +;;;###autoload (defcustom ffap-file-finder 'find-file "The command called by `find-file-at-point' to find a file." :type 'function diff --git a/lisp/files.el b/lisp/files.el index 859c193db99..d97c93e5c76 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -465,6 +465,31 @@ If `silently', don't ask the user before saving." :type '(choice (const t) (const nil) (const silently)) :group 'abbrev) +(defcustom lock-file-name-transforms nil + "Transforms to apply to buffer file name before making a lock file name. +This has the same syntax as +`auto-save-file-name-transforms' (which see), but instead of +applying to auto-save file names, it's applied to lock file names. + +By default, a lock file is put into the same directory as the +file it's locking, and it has the same name, but with \".#\" prepended." + :group 'files + :type '(repeat (list (regexp :tag "Regexp") + (string :tag "Replacement") + (boolean :tag "Uniquify"))) + :version "28.1") + +(defcustom remote-file-name-inhibit-locks nil + "Whether to use file locks for remote files." + :group 'files + :version "28.1" + :type 'boolean) + +(define-minor-mode lock-file-mode + "Toggle file locking in the current buffer (Lock File mode)." + :version "28.1" + (setq-local create-lockfiles (and lock-file-mode t))) + (defcustom find-file-run-dired t "Non-nil means allow `find-file' to visit directories. To visit the directory, `find-file' runs `find-directory-functions'." @@ -2133,6 +2158,19 @@ think it does, because \"free\" is pretty hard to define in practice." :version "25.1" :type '(choice integer (const :tag "Never issue warning" nil))) +(defcustom query-about-changed-file t + "If non-nil, query the user when re-visiting a file that has changed. +This happens if the file is already visited in a buffer, the +file was changed externally, and the user re-visits the file. + +If nil, don't prompt the user, but instead provide instructions for +reverting, after switching to the buffer with its contents before +the external changes." + :group 'files + :group 'find-file + :version "28.1" + :type 'boolean) + (declare-function x-popup-dialog "menu.c" (position contents &optional header)) (defun files--ask-user-about-large-file-help-text (op-type size) @@ -2315,6 +2353,14 @@ the various files." (message "Reverting file %s..." filename) (revert-buffer t t) (message "Reverting file %s...done" filename))) + ((not query-about-changed-file) + (message + (substitute-command-keys + "File %s changed on disk. \\[revert-buffer] to load new contents%s") + (file-name-nondirectory filename) + (if (buffer-modified-p buf) + " and discard your edits" + ""))) ((yes-or-no-p (if (string= (file-name-nondirectory filename) (buffer-name buf)) @@ -6664,67 +6710,15 @@ Does not consider `auto-save-visited-file-name' as that variable is checked before calling this function. See also `auto-save-file-name-p'." (if buffer-file-name - (let ((handler (find-file-name-handler buffer-file-name - 'make-auto-save-file-name))) + (let ((handler (find-file-name-handler + buffer-file-name 'make-auto-save-file-name))) (if handler (funcall handler 'make-auto-save-file-name) - (let ((list auto-save-file-name-transforms) - (filename buffer-file-name) - result uniq) - ;; Apply user-specified translations - ;; to the file name. - (while (and list (not result)) - (if (string-match (car (car list)) filename) - (setq result (replace-match (cadr (car list)) t nil - filename) - uniq (car (cddr (car list))))) - (setq list (cdr list))) - (if result - (setq filename - (cond - ((memq uniq (secure-hash-algorithms)) - (concat - (file-name-directory result) - (secure-hash uniq filename))) - (uniq - (concat - (file-name-directory result) - (subst-char-in-string - ?/ ?! - (replace-regexp-in-string - "!" "!!" filename)))) - (t result)))) - (setq result - (if (and (eq system-type 'ms-dos) - (not (msdos-long-file-names))) - ;; We truncate the file name to DOS 8+3 limits - ;; before doing anything else, because the regexp - ;; passed to string-match below cannot handle - ;; extensions longer than 3 characters, multiple - ;; dots, and other atrocities. - (let ((fn (dos-8+3-filename - (file-name-nondirectory buffer-file-name)))) - (string-match - "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'" - fn) - (concat (file-name-directory buffer-file-name) - "#" (match-string 1 fn) - "." (match-string 3 fn) "#")) - (concat (file-name-directory filename) - "#" - (file-name-nondirectory filename) - "#"))) - ;; Make sure auto-save file names don't contain characters - ;; invalid for the underlying filesystem. - (if (and (memq system-type '(ms-dos windows-nt cygwin)) - ;; Don't modify remote filenames - (not (file-remote-p result))) - (convert-standard-filename result) - result)))) - + (files--transform-file-name + buffer-file-name auto-save-file-name-transforms + "#" "#"))) ;; Deal with buffers that don't have any associated files. (Mail ;; mode tends to create a good number of these.) - (let ((buffer-name (buffer-name)) (limit 0) file-name) @@ -6772,6 +6766,74 @@ See also `auto-save-file-name-p'." (file-error nil)) file-name))) +(defun files--transform-file-name (filename transforms prefix suffix) + "Transform FILENAME according to TRANSFORMS. +See `auto-save-file-name-transforms' for the format of +TRANSFORMS. PREFIX is prepended to the non-directory portion of +the resulting file name, and SUFFIX is appended." + (save-match-data + (let (result uniq) + ;; Apply user-specified translations to the file name. + (while (and transforms (not result)) + (if (string-match (car (car transforms)) filename) + (setq result (replace-match (cadr (car transforms)) t nil + filename) + uniq (car (cddr (car transforms))))) + (setq transforms (cdr transforms))) + (when result + (setq filename + (cond + ((memq uniq (secure-hash-algorithms)) + (concat + (file-name-directory result) + (secure-hash uniq filename))) + (uniq + (concat + (file-name-directory result) + (subst-char-in-string + ?/ ?! + (replace-regexp-in-string + "!" "!!" filename)))) + (t result)))) + (setq result + (if (and (eq system-type 'ms-dos) + (not (msdos-long-file-names))) + ;; We truncate the file name to DOS 8+3 limits before + ;; doing anything else, because the regexp passed to + ;; string-match below cannot handle extensions longer + ;; than 3 characters, multiple dots, and other + ;; atrocities. + (let ((fn (dos-8+3-filename + (file-name-nondirectory buffer-file-name)))) + (string-match + "\\`\\([^.]+\\)\\(\\.\\(..?\\)?.?\\|\\)\\'" + fn) + (concat (file-name-directory buffer-file-name) + prefix (match-string 1 fn) + "." (match-string 3 fn) suffix)) + (concat (file-name-directory filename) + prefix + (file-name-nondirectory filename) + suffix))) + ;; Make sure auto-save file names don't contain characters + ;; invalid for the underlying filesystem. + (expand-file-name + (if (and (memq system-type '(ms-dos windows-nt cygwin)) + ;; Don't modify remote filenames + (not (file-remote-p result))) + (convert-standard-filename result) + result))))) + +(defun make-lock-file-name (filename) + "Make a lock file name for FILENAME. +By default, this just prepends \".#\" to the non-directory part +of FILENAME, but the transforms in `lock-file-name-transforms' +are done first." + (let ((handler (find-file-name-handler filename 'make-lock-file-name))) + (if handler + (funcall handler 'make-lock-file-name filename) + (files--transform-file-name filename lock-file-name-transforms ".#" "")))) + (defun auto-save-file-name-p (filename) "Return non-nil if FILENAME can be yielded by `make-auto-save-file-name'. FILENAME should lack slashes. diff --git a/lisp/frame.el b/lisp/frame.el index bb5da0da04c..302993e7a89 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1397,7 +1397,7 @@ FRAME defaults to the selected frame." (declare-function x-list-fonts "xfaces.c" (pattern &optional face frame maximum width)) -(defun set-frame-font (font &optional keep-size frames) +(defun set-frame-font (font &optional keep-size frames inhibit-customize) "Set the default font to FONT. When called interactively, prompt for the name of a font, and use that font on the selected frame. When called from Lisp, FONT @@ -1414,7 +1414,10 @@ If FRAMES is non-nil, it should be a list of frames to act upon, or t meaning all existing graphical frames. Also, if FRAMES is non-nil, alter the user's Customization settings as though the font-related attributes of the `default' face had been -\"set in this session\", so that the font is applied to future frames." +\"set in this session\", so that the font is applied to future frames. + +If INHIBIT-CUSTOMIZE is non-nil, don't update the user's +Customization settings." (interactive (let* ((completion-ignore-case t) (default (frame-parameter nil 'font)) @@ -1451,7 +1454,8 @@ as though the font-related attributes of the `default' face had been f (list (cons 'height (round height (frame-char-height f))) (cons 'width (round width (frame-char-width f)))))))) - (when frames + (when (and frames + (not inhibit-customize)) ;; Alter the user's Custom setting of the `default' face, but ;; only for font-related attributes. (let ((specs (cadr (assq 'user (get 'default 'theme-face)))) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index f2ec9462c5e..b989446792b 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6039,7 +6039,28 @@ If nil, don't show those extra buttons." (ignored gnus-ignored-mime-types) (mm-inline-font-lock (gnus-visual-p 'article-highlight 'highlight)) (not-attachment t) - display text) + ;; Arrange a callback from `mm-inline-message' if we're + ;; displaying a message/rfc822 part. + (mm-inline-message-prepare-function + (lambda (charset) + (let ((handles + (let (gnus-article-mime-handles + ;; disable prepare hook + gnus-article-prepare-hook + (gnus-newsgroup-charset + ;; mm-uu might set it. + (unless (eq charset 'gnus-decoded) + (or charset gnus-newsgroup-charset)))) + (let ((gnus-original-article-buffer + (mm-handle-buffer handle))) + (run-hooks 'gnus-article-decode-hook)) + (gnus-article-prepare-display) + gnus-article-mime-handles))) + (when handles + (setq gnus-article-mime-handles + (mm-merge-handles gnus-article-mime-handles handles)))))) + display text + gnus-displaying-mime) (catch 'ignored (progn (while ignored diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index bac987e2f00..db54237a767 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1597,6 +1597,10 @@ this is a reply." (if (stringp gnus-gcc-externalize-attachments) (string-match gnus-gcc-externalize-attachments group) gnus-gcc-externalize-attachments)) + ;; If we want to externalize stuff when GCC-ing, then we + ;; can't use the cache, because that has all the contents. + (when mml-externalize-attachments + (setq encoded-cache nil)) (save-excursion (nnheader-set-temp-buffer " *acc*") (setq message-options (with-current-buffer cur message-options)) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 70bde264c11..39bde837b30 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -448,10 +448,10 @@ auto-completion of contact names and addresses for keys like Date values (any key in `gnus-search-date-keys') can be provided in any format that `parse-time-string' can parse (note that this can produce weird results). Dates with missing bits will be -interpreted as the most recent occurence thereof (ie \"march 03\" -is the most recent March 3rd). Lastly, relative specifications -such as 1d (one day ago) are understood. This also accepts w, m, -and y. m is assumed to be 30 days. +interpreted as the most recent occurrence thereof (i.e. \"march +03\" is the most recent March 3rd). Lastly, relative +specifications such as 1d (one day ago) are understood. This +also accepts w, m, and y. m is assumed to be 30 days. This function will accept pretty much anything as input. Its only job is to parse the query into a sexp, and pass that on -- @@ -629,25 +629,30 @@ gnus-*-mark marks, and return an appropriate string." mark)) (defun gnus-search-query-expand-key (key) - (cond ((test-completion key gnus-search-expandable-keys) - ;; We're done! - key) - ;; There is more than one possible completion. - ((consp (cdr (completion-all-completions - key gnus-search-expandable-keys #'stringp 0))) - (signal 'gnus-search-parse-error - (list (format "Ambiguous keyword: %s" key)))) - ;; Return KEY, either completed or untouched. - ((car-safe (completion-try-completion - key gnus-search-expandable-keys - #'stringp 0))))) + "Attempt to expand KEY to a full keyword. +Use `gnus-search-expandable-keys' as a completion table; return +KEY directly if it can't be completed. Raise an error if KEY is +ambiguous, meaning that it is a prefix of multiple known +keywords. This means that it's not possible to enter a custom +keyword that happens to be a prefix of a known keyword." + (let ((comp (try-completion key gnus-search-expandable-keys))) + (if (or (eql comp 't) ; Already a key. + (null comp)) ; An unknown key. + key + (if (null (member comp gnus-search-expandable-keys)) + ;; KEY is a prefix of multiple known keywords, and could not + ;; be completed to something unique. + (signal 'gnus-search-parse-error + (list (format "Ambiguous keyword: %s" key))) + ;; We completed to a unique known key. + comp)))) (defun gnus-search-query-return-string (&optional delimited trim) "Return a string from the current buffer. If DELIMITED is non-nil, assume the next character is a delimiter character, and return everything between point and the next -occurence of the delimiter, including the delimiters themselves. -If TRIM is non-nil, do not return the delimiters. Otherwise, +occurrence of the delimiter, including the delimiters themselves. +If TRIM is non-nil, do not return the delimiters. Otherwise, return one word." ;; This function cannot handle nested delimiters, as it's not a ;; proper parser. Ie, you cannot parse "to:bob or (from:bob or @@ -1351,68 +1356,59 @@ Returns a list of [group article score] vectors." (cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) server query &optional groups) - (let ((prefix (slot-value engine 'remove-prefix)) - (group-regexp (when groups - (mapconcat - (lambda (group-name) - (mapconcat #'regexp-quote - (split-string - (gnus-group-real-name group-name) - "[.\\/]") - "[.\\\\/]")) - groups - "\\|"))) - artlist vectors article group) + (let ((prefix (or (slot-value engine 'remove-prefix) + "")) + artlist article group) (goto-char (point-min)) + ;; Prep prefix, we want to at least be removing the root + ;; filesystem separator. + (when (stringp prefix) + (setq prefix (file-name-as-directory + (expand-file-name prefix "/")))) (while (not (or (eobp) (looking-at-p "\\(?:[[:space:]\n]+\\)?Process .+ finished"))) (pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine))) (when (and f-name (file-readable-p f-name) - (null (file-directory-p f-name)) - (or (null groups) - (and (gnus-search-single-p query) - (alist-get 'thread query)) - (string-match-p group-regexp f-name))) - (push (list f-name score) artlist)))) + (null (file-directory-p f-name))) + (setq group + (replace-regexp-in-string + "[/\\]" "." + (replace-regexp-in-string + "/?\\(cur\\|new\\|tmp\\)?/\\'" "" + (replace-regexp-in-string + "\\`\\." "" + (string-remove-prefix + prefix (file-name-directory f-name)) + nil t) + nil t) + nil t)) + (setq group (gnus-group-full-name group server)) + (setq article (file-name-nondirectory f-name) + article + ;; TODO: Provide a cleaner way of producing final + ;; article numbers for the various backends. + (if (string-match-p "\\`[[:digit:]]+\\'" article) + (string-to-number article) + (nnmaildir-base-name-to-article-number + (substring article 0 (string-match ":" article)) + group (string-remove-prefix "nnmaildir:" server)))) + (when (and (numberp article) + (or (null groups) + (member group groups))) + (push (list f-name article group score) + artlist))))) ;; Are we running an additional grep query? (when-let ((grep-reg (alist-get 'grep query))) (setq artlist (gnus-search-grep-search engine artlist grep-reg))) - ;; Prep prefix. - (when (and prefix (null (string-empty-p prefix))) - (setq prefix (file-name-as-directory (expand-file-name prefix)))) - ;; Turn (file-name score) into [group article score]. - (pcase-dolist (`(,f-name ,score) artlist) - (setq article (file-name-nondirectory f-name) - group (file-name-directory f-name)) - ;; Remove prefix. - (when prefix - (setq group (string-remove-prefix prefix group))) - ;; Break the directory name down until it's something that - ;; (probably) can be used as a group name. - (setq group - (replace-regexp-in-string - "[/\\]" "." - (replace-regexp-in-string - "/?\\(cur\\|new\\|tmp\\)?/\\'" "" - (replace-regexp-in-string - "^[./\\]" "" - group nil t) - nil t) - nil t)) - - (push (vector (gnus-group-full-name group server) - (if (string-match-p "\\`[[:digit:]]+\\'" article) - (string-to-number article) - (nnmaildir-base-name-to-article-number - (substring article 0 (string-match ":" article)) - group (string-remove-prefix "nnmaildir:" server))) - (if (numberp score) - score - (string-to-number score))) - vectors)) - vectors)) + ;; Munge into the list of vectors expected by nnselect. + (mapcar (pcase-lambda (`(,_ ,article ,group ,score)) + (vector group article + (if (numberp score) + score + (string-to-number score)))) + artlist))) (cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed)) "Base implementation treats the whole line as a filename, and diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index a9be2d6b347..cdabdef2ec8 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -1658,6 +1658,11 @@ starting with `not' and followed by regexps." "Face used for displaying MML." :group 'message-faces) +(defface message-signature-separator '((t :bold t)) + "Face used for displaying the signature separator." + :group 'message-faces + :version "28.1") + (defun message-match-to-eoh (_limit) (let ((start (point))) (rfc822-goto-eoh) @@ -1751,9 +1756,22 @@ number of levels specified in the faces `message-cited-text-*'." (0 ',cited-text-face)) keywords)) (setq level (1+ level))) - keywords)) + keywords) + ;; Match signature. This `field' stuff ensures that hitting `RET' + ;; after the signature separator doesn't remove the trailing space. + (list + '(message--match-signature (0 '( face message-signature-separator + rear-nonsticky t + field signature))))) "Additional expressions to highlight in Message mode.") +(defun message--match-signature (limit) + (save-excursion + (and (re-search-forward message-signature-separator limit t) + ;; It's the last one in the buffer. + (not (save-excursion + (re-search-forward message-signature-separator nil t)))))) + (defvar message-face-alist '((bold . message-bold-region) (underline . underline-region) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 3e36d6724ea..2ec75a0bc59 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -418,16 +418,18 @@ This is only used if `mm-inline-large-images' is set to (fundamental-mode) (goto-char (point-min))) -(defvar gnus-original-article-buffer) -(defvar gnus-article-prepare-hook) -(defvar gnus-displaying-mime) +(defvar mm-inline-message-prepare-function nil + "Function called by `mm-inline-message' to do client specific setup. +It is called with one parameter -- the charset.") (defun mm-inline-message (handle) + "Insert HANDLE (a message/rfc822 part) into the current buffer. +This function will call `mm-inline-message-prepare-function' +after inserting the part." (let ((b (point)) (bolp (bolp)) (charset (mail-content-type-get - (mm-handle-type handle) 'charset)) - gnus-displaying-mime handles) + (mm-handle-type handle) 'charset))) (when (and charset (stringp charset)) (setq charset (intern (downcase charset))) @@ -437,16 +439,8 @@ This is only used if `mm-inline-large-images' is set to (save-restriction (narrow-to-region b b) (mm-insert-part handle) - (let (gnus-article-mime-handles - ;; disable prepare hook - gnus-article-prepare-hook - (gnus-newsgroup-charset - (unless (eq charset 'gnus-decoded) ;; mm-uu might set it. - (or charset gnus-newsgroup-charset)))) - (let ((gnus-original-article-buffer (mm-handle-buffer handle))) - (run-hooks 'gnus-article-decode-hook)) - (gnus-article-prepare-display) - (setq handles gnus-article-mime-handles)) + (when mm-inline-message-prepare-function + (funcall mm-inline-message-prepare-function charset)) (goto-char (point-min)) (unless bolp (insert "\n")) @@ -454,9 +448,6 @@ This is only used if `mm-inline-large-images' is set to (unless (bolp) (insert "\n")) (insert "----------\n\n") - (when handles - (setq gnus-article-mime-handles - (mm-merge-handles gnus-article-mime-handles handles))) (mm-handle-set-undisplayer handle (let ((beg (point-min-marker)) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index afdb0d17b26..cb248b1d009 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -752,7 +752,7 @@ FILE is the file where FUNCTION was probably defined." (insert-text-button (symbol-name group) 'action (lambda (_) - (shortdoc-display-group group)) + (shortdoc-display-group group object)) 'follow-link t 'help-echo (purecopy "mouse-1, RET: show documentation group"))) groups) @@ -1901,7 +1901,7 @@ documentation for the major and minor modes of that buffer." ;; Ignore aliases. (not (symbolp (symbol-function sym))) ;; Ignore everything bound. - (not (where-is-internal sym)) + (not (where-is-internal sym nil t)) (apply #'derived-mode-p (command-modes sym))) (push sym functions)))) (with-temp-buffer diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 68f8cc50549..37b88b318de 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -111,7 +111,7 @@ highlighting will be applied throughout the buffer." :group 'hi-lock) (defcustom hi-lock-exclude-modes - '(rmail-mode mime/viewer-mode gnus-article-mode) + '(rmail-mode mime/viewer-mode gnus-article-mode term-mode) "List of major modes in which hi-lock will not run. For security reasons since font lock patterns can specify function calls." diff --git a/lisp/hilit-chg.el b/lisp/hilit-chg.el index 3c3c4073986..8919e982383 100644 --- a/lisp/hilit-chg.el +++ b/lisp/hilit-chg.el @@ -492,9 +492,9 @@ This allows you to manually remove highlighting from uninteresting changes." ;; otherwise an undone change shows up as changed. While the properties ;; are automatically restored by undo, we must fix up the overlay. (save-match-data - (let (;;(beg-decr 1) - (end-incr 1) - (type 'hilit-chg)) + (let ((end-incr 1) + (type 'hilit-chg) + (property 'hilit-chg)) (if undo-in-progress (if (and highlight-changes-mode highlight-changes-visible-mode) @@ -515,7 +515,8 @@ This allows you to manually remove highlighting from uninteresting changes." ;; (setq beg-decr 0)))) ;; (setq beg (max (- beg beg-decr) (point-min))) (setq end (min (+ end end-incr) (point-max))) - (setq type 'hilit-chg-delete)) + (setq type 'hilit-chg-delete + property 'hilit-chg-delete)) ;; Not a deletion. ;; Most of the time the following is not necessary, but ;; if the current text was marked as a deletion then @@ -523,14 +524,15 @@ This allows you to manually remove highlighting from uninteresting changes." ;; text where she earlier deleted text, we have to remove the ;; deletion marking, and replace it explicitly with a `changed' ;; marking, otherwise its highlighting would disappear. - (if (eq (get-text-property end 'hilit-chg) 'hilit-chg-delete) - (save-restriction - (widen) - (put-text-property end (+ end 1) 'hilit-chg 'hilit-chg) - (if highlight-changes-visible-mode - (hilit-chg-fixup end (+ end 1)))))) + (when (eq (get-text-property end 'hilit-chg-delete) + 'hilit-chg-delete) + (save-restriction + (widen) + (put-text-property end (+ end 1) 'hilit-chg-delete nil) + (if highlight-changes-visible-mode + (hilit-chg-fixup end (+ end 1)))))) (unless no-property-change - (put-text-property beg end 'hilit-chg type)) + (put-text-property beg end property type)) (if (or highlight-changes-visible-mode no-property-change) (hilit-chg-make-ov type beg end))))))) diff --git a/lisp/ido.el b/lisp/ido.el index 93629046801..ea5ff32b8d7 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -1521,6 +1521,10 @@ Removes badly formatted data and ignored directories." :global t (remove-function read-file-name-function #'ido-read-file-name) (remove-function read-buffer-function #'ido-read-buffer) + (when (boundp 'ffap-file-finder) + (remove-function ffap-file-finder #'ido-find-file) + (when ido-mode + (add-function :override ffap-file-finder #'ido-find-file))) (when ido-everywhere (if (not ido-mode) (ido-mode 'both) diff --git a/lisp/image.el b/lisp/image.el index ee152940311..494c26a8a33 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -1191,7 +1191,9 @@ rotations by only multiples of 90 degrees." 360))))) (defun image-save () - "Save the image under point." + "Save the image under point. +This writes the original image data to a file. Rotating or +changing the displayed image size does not affect the saved image." (interactive) (let ((image (image--get-image))) (with-temp-buffer diff --git a/lisp/info.el b/lisp/info.el index cdf339ff6fb..b65728ba41b 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -391,6 +391,14 @@ where SUPPORTS-INDEX-COOKIES can be either t or nil.") (defvar-local Info-index-alternatives nil "List of possible matches for last `Info-index' command.") +(defvar-local Info--current-index-alternative 0 + "Current displayed index alternative.") + +(defcustom Info-warn-on-index-alternatives-wrap t + "Warn when wrapping to the beginning/end when displaying index alternatives." + :type 'boolean + :version "28.1") + (defvar Info-point-loc nil "Point location within a selected node. If string, the point is moved to the proper occurrence of the @@ -3375,39 +3383,56 @@ Give an empty topic name to go to the Index node itself." (setq exact (cons found exact) matches (delq found matches))) (setq Info-history-list ohist-list) - (setq Info-index-alternatives (nconc exact (nreverse matches))) + (setq Info-index-alternatives (nconc exact (nreverse matches)) + Info--current-index-alternative 0) (Info-index-next 0))))) (defun Info-index-next (num) - "Go to the next matching index item from the last \\<Info-mode-map>\\[Info-index] command." + "Go to the next matching index item from the last \\<Info-mode-map>\\[Info-index] command. +If given a numeric prefix, skip that many index items forward (or +backward). + +Also see the `Info-warn-on-index-alternatives-wrap' user option." (interactive "p" Info-mode) - (or Info-index-alternatives - (user-error "No previous `i' command")) - (while (< num 0) - (setq num (+ num (length Info-index-alternatives)))) - (while (> num 0) - (setq Info-index-alternatives - (nconc (cdr Info-index-alternatives) - (list (car Info-index-alternatives))) - num (1- num))) - (Info-goto-node (nth 1 (car Info-index-alternatives))) - (if (> (nth 3 (car Info-index-alternatives)) 0) - ;; Forward 2 lines less because `Info-find-node-2' initially - ;; puts point to the 2nd line. - (forward-line (- (nth 3 (car Info-index-alternatives)) 2)) - (forward-line 3) ; don't search in headers - (let ((name (car (car Info-index-alternatives)))) - (Info-find-index-name name))) - (message "Found `%s' in %s. %s" - (car (car Info-index-alternatives)) - (nth 2 (car Info-index-alternatives)) - (if (cdr Info-index-alternatives) - (format-message - "(%s total; use `%s' for next)" - (length Info-index-alternatives) - (key-description (where-is-internal - 'Info-index-next overriding-local-map t))) - "(Only match)"))) + (unless Info-index-alternatives + (user-error "No previous `i' command")) + (let ((index (+ Info--current-index-alternative num)) + (total (length Info-index-alternatives)) + (next-key (key-description (where-is-internal + 'Info-index-next overriding-local-map t)))) + (if (and Info-warn-on-index-alternatives-wrap + (> total 1) + (cond + ((< index 0) + (setq Info--current-index-alternative (- total 2)) + (message + "No previous matches, use `%s' to continue from end of list" + next-key) + t) + ((>= index total) + (setq Info--current-index-alternative -1) + (message + "No previous matches, use `%s' to continue from start of list" + next-key) + t))) + () ; Do nothing + (setq index (mod index total) + Info--current-index-alternative index) + (let ((entry (nth index Info-index-alternatives))) + (Info-goto-node (nth 1 entry)) + (if (> (nth 3 entry) 0) + ;; Forward 2 lines less because `Info-find-node-2' initially + ;; puts point to the 2nd line. + (forward-line (- (nth 3 entry) 2)) + (forward-line 3) ; don't search in headers + (Info-find-index-name (car entry))) + (message "Found `%s' in %s. %s" + (car entry) + (nth 2 entry) + (if (> total 1) + (format-message + "(%s total; use `%s' for next)" total next-key) + "(Only match)")))))) (defun Info-find-index-name (name) "Move point to the place within the current node where NAME is defined." diff --git a/lisp/isearch.el b/lisp/isearch.el index c8bd62875f4..922ab0f6ad4 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -233,6 +233,7 @@ called with the positions of the start and the end of the text matched by Isearch and replace commands. If this function returns nil, Isearch and replace commands will continue searching without stopping at resp. replacing this match. +This function is expected to be careful not to clobber the match data. If you use `add-function' to modify this variable, you can use the `isearch-message-prefix' advice property to specify the prefix string @@ -3529,11 +3530,14 @@ Optional third argument, if t, means if fail just return nil (no error). ;; Clear RETRY unless the search predicate says ;; to skip this search hit. (if (or (not isearch-success) - (bobp) (eobp) - (= (match-beginning 0) (match-end 0)) (funcall isearch-filter-predicate (match-beginning 0) (match-end 0))) - (setq retry nil))) + (setq retry nil) + ;; Advance point on empty matches before retrying + (when (= (match-beginning 0) (match-end 0)) + (if (if isearch-forward (eobp) (bobp)) + (setq retry nil isearch-success nil) + (forward-char (if isearch-forward 1 -1)))))) (setq isearch-just-started nil) (when isearch-success (setq isearch-other-end @@ -4044,7 +4048,6 @@ Attempt to do the search exactly the way the pending Isearch would." ;; Clear RETRY unless the search predicate says ;; to skip this search hit. (if (or (not success) - (= (point) bound) ; like (bobp) (eobp) in `isearch-search'. (= (match-beginning 0) (match-end 0)) (funcall isearch-filter-predicate (match-beginning 0) (match-end 0))) diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el index 11d93a6df9a..6933a7c1d06 100644 --- a/lisp/jka-cmpr-hook.el +++ b/lisp/jka-cmpr-hook.el @@ -104,6 +104,9 @@ Otherwise, it is nil.") (defun jka-compr-info-can-append (info) (aref info 7)) (defun jka-compr-info-strip-extension (info) (aref info 8)) (defun jka-compr-info-file-magic-bytes (info) (aref info 9)) +(defun jka-compr-info-uncompress-function (info) + (and (> (length info) 10) + (aref info 10))) (defun jka-compr-get-compression-info (filename) @@ -197,13 +200,15 @@ options through Custom does this automatically." ;;[regexp ;; compr-message compr-prog compr-args ;; uncomp-message uncomp-prog uncomp-args - ;; can-append strip-extension-flag file-magic-bytes] + ;; can-append strip-extension-flag file-magic-bytes + ;; uncompress-function] (mapcar 'purecopy '(["\\.Z\\'" "compressing" "compress" ("-c") ;; gzip is more common than uncompress. It can only read, not write. "uncompressing" "gzip" ("-c" "-q" "-d") - nil t "\037\235"] + nil t "\037\235" + zlib-decompress-region] ;; Formerly, these had an additional arg "-c", but that fails with ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and ;; "Version 0.9.0b, 9-Sept-98". @@ -218,11 +223,13 @@ options through Custom does this automatically." ["\\.\\(?:tgz\\|svgz\\|sifz\\)\\'" "compressing" "gzip" ("-c" "-q") "uncompressing" "gzip" ("-c" "-q" "-d") - t nil "\037\213"] + t nil "\037\213" + zlib-decompress-region] ["\\.g?z\\'" "compressing" "gzip" ("-c" "-q") "uncompressing" "gzip" ("-c" "-q" "-d") - t t "\037\213"] + t t "\037\213" + zlib-decompress-region] ["\\.lz\\'" "Lzip compressing" "lzip" ("-c" "-q") "Lzip uncompressing" "lzip" ("-c" "-q" "-d") @@ -259,7 +266,7 @@ options through Custom does this automatically." Each element, which describes a compression technique, is a vector of the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS -APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where: +APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS UNCOMPRESS-FUNCTION], where: regexp is a regexp that matches filenames that are compressed with this format @@ -275,7 +282,7 @@ APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where: uncompress-msg is the message to issue to the user when doing this type of uncompression (nil means no message) - uncompress-program is a program that performs this compression + uncompress-program is a program that performs this uncompression uncompress-args is a list of args to pass to the uncompress program @@ -288,6 +295,9 @@ APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where: file-magic-chars is a string of characters that you would find at the beginning of a file compressed in this way. + uncompress-function is a function that performs uncompression, if + uncompress-program is not found. + If you set this outside Custom while Auto Compression mode is already enabled \(as it is by default), you have to call `jka-compr-update' after setting it to properly update other @@ -309,9 +319,12 @@ variables. Setting this through Custom does that automatically." (repeat :tag "Uncompress Arguments" string) (boolean :tag "Append") (boolean :tag "Strip Extension") - (string :tag "Magic Bytes"))) + (string :tag "Magic Bytes") + (choice :tag "Uncompress Function" + (symbol) + (const :tag "None" nil)))) :set 'jka-compr-set - :version "24.1" ; removed version extension piece + :version "28.1" ; add uncompress-function :group 'jka-compr) (defcustom jka-compr-mode-alist-additions diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el index 2f98c8d9ff4..658ea44a348 100644 --- a/lisp/jka-compr.el +++ b/lisp/jka-compr.el @@ -386,6 +386,7 @@ There should be no more than seven characters after the final `/'." (let ((uncompress-message (jka-compr-info-uncompress-message info)) (uncompress-program (jka-compr-info-uncompress-program info)) + (uncompress-function (jka-compr-info-uncompress-function info)) (uncompress-args (jka-compr-info-uncompress-args info)) (base-name (file-name-nondirectory filename)) (notfound nil) @@ -409,58 +410,76 @@ There should be no more than seven characters after the final `/'." jka-compr-verbose (message "%s %s..." uncompress-message base-name)) - (condition-case error-code - - (let ((coding-system-for-read 'no-conversion)) - (if replace - (goto-char (point-min))) - (setq start (point)) - (if (or beg end) - (jka-compr-partial-uncompress uncompress-program - (concat uncompress-message - " " base-name) - uncompress-args - local-file - (or beg 0) - (if (and beg end) - (- end beg) - end)) - ;; If visiting, bind off buffer-file-name so that - ;; file-locking will not ask whether we should - ;; really edit the buffer. - (let ((buffer-file-name - (if visit nil buffer-file-name))) - (jka-compr-call-process uncompress-program - (concat uncompress-message - " " base-name) - local-file - t - nil - uncompress-args))) - (setq size (- (point) start)) - (if replace - (delete-region (point) (point-max))) - (goto-char start)) - (error - ;; If the file we wanted to uncompress does not exist, - ;; handle that according to VISIT as `insert-file-contents' - ;; would, maybe signaling the same error it normally would. - (if (and (eq (car error-code) 'file-missing) - (eq (nth 3 error-code) local-file)) - (if visit - (setq notfound error-code) - (signal 'file-missing - (cons "Opening input file" - (nthcdr 2 error-code)))) - ;; If the uncompression program can't be found, - ;; signal that as a non-file error - ;; so that find-file-noselect-1 won't handle it. - (if (and (memq 'file-error (get (car error-code) - 'error-conditions)) - (equal (cadr error-code) "Searching for program")) - (error "Uncompression program `%s' not found" - (nth 3 error-code))) - (signal (car error-code) (cdr error-code)))))) + (if (and (not (executable-find uncompress-program)) + uncompress-function + (fboundp uncompress-function)) + ;; If we don't have the uncompression program, then use the + ;; internal uncompression function (if we have one). + (let ((buf (current-buffer))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-file-contents-literally file) + (funcall uncompress-function (point-min) (point-max)) + (when end + (delete-region end (point-max))) + (when beg + (delete-region (point-min) beg)) + (setq size (buffer-size)) + (insert-into-buffer buf)) + (goto-char (point-min))) + ;; Use the external uncompression program. + (condition-case error-code + + (let ((coding-system-for-read 'no-conversion)) + (if replace + (goto-char (point-min))) + (setq start (point)) + (if (or beg end) + (jka-compr-partial-uncompress + uncompress-program + (concat uncompress-message " " base-name) + uncompress-args + local-file + (or beg 0) + (if (and beg end) + (- end beg) + end)) + ;; If visiting, bind off buffer-file-name so that + ;; file-locking will not ask whether we should + ;; really edit the buffer. + (let ((buffer-file-name + (if visit nil buffer-file-name))) + (jka-compr-call-process uncompress-program + (concat uncompress-message + " " base-name) + local-file + t + nil + uncompress-args))) + (setq size (- (point) start)) + (if replace + (delete-region (point) (point-max))) + (goto-char start)) + (error + ;; If the file we wanted to uncompress does not exist, + ;; handle that according to VISIT as `insert-file-contents' + ;; would, maybe signaling the same error it normally would. + (if (and (eq (car error-code) 'file-missing) + (eq (nth 3 error-code) local-file)) + (if visit + (setq notfound error-code) + (signal 'file-missing + (cons "Opening input file" + (nthcdr 2 error-code)))) + ;; If the uncompression program can't be found, + ;; signal that as a non-file error + ;; so that find-file-noselect-1 won't handle it. + (if (and (memq 'file-error (get (car error-code) + 'error-conditions)) + (equal (cadr error-code) "Searching for program")) + (error "Uncompression program `%s' not found" + (nth 3 error-code))) + (signal (car error-code) (cdr error-code))))))) (and local-copy diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 9cd2c62b7b8..ab355b6e8c4 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -570,7 +570,9 @@ (defun clipboard-yank () "Insert the clipboard contents, or the last stretch of killed text." (interactive "*") - (let ((select-enable-clipboard t)) + (let ((select-enable-clipboard t) + ;; Ensure that we defeat the DWIM login in `gui-selection-value'. + (gui--last-selected-text-clipboard nil)) (yank))) (defun clipboard-kill-ring-save (beg end &optional region) diff --git a/lisp/mouse.el b/lisp/mouse.el index ab260d4ed49..89e5d7c48a3 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -1208,7 +1208,7 @@ overlay property, the value of that property determines what to do. for the `follow-link' event, the binding of that event determines what to do. -The resulting value determine whether POS is inside a link: +The resulting value determines whether POS is inside a link: - If the value is `mouse-face', POS is inside a link if there is a non-nil `mouse-face' property at POS. Return t in this case. @@ -2881,8 +2881,8 @@ is copied instead of being cut." (set-marker (nth 2 state) nil)) (with-current-buffer (window-buffer window) (setq cursor-type (nth 3 state))))))) - + ;;; Bindings for mouse commands. (global-set-key [down-mouse-1] 'mouse-drag-region) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 873f0457e3a..85d81b6bbcc 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -183,6 +183,33 @@ temporarily blinks with this face." "Face for <abbr> elements." :version "27.1") +(defface shr-h1 + '((t :height 1.3 :weight bold)) + "Face for <h1> elements." + :version "28.1") + +(defface shr-h2 + '((t :weight bold)) + "Face for <h2> elements." + :version "28.1") + +(defface shr-h3 + '((t :slant italic)) + "Face for <h3> elements." + :version "28.1") + +(defface shr-h4 nil + "Face for <h4> elements." + :version "28.1") + +(defface shr-h5 nil + "Face for <h5> elements." + :version "28.1") + +(defface shr-h6 nil + "Face for <h6> elements." + :version "28.1") + (defcustom shr-inhibit-images nil "If non-nil, inhibit loading images." :version "28.1" @@ -1939,24 +1966,22 @@ BASE is the URL of the HTML being rendered." (shr-generic dom)) (defun shr-tag-h1 (dom) - (shr-heading dom (if shr-use-fonts - '(variable-pitch (:height 1.3 :weight bold)) - 'bold))) + (shr-heading dom 'shr-h1)) (defun shr-tag-h2 (dom) - (shr-heading dom 'bold)) + (shr-heading dom 'shr-h2)) (defun shr-tag-h3 (dom) - (shr-heading dom 'italic)) + (shr-heading dom 'shr-h3)) (defun shr-tag-h4 (dom) - (shr-heading dom)) + (shr-heading dom 'shr-h4)) (defun shr-tag-h5 (dom) - (shr-heading dom)) + (shr-heading dom 'shr-h5)) (defun shr-tag-h6 (dom) - (shr-heading dom)) + (shr-heading dom 'shr-h6)) (defun shr-tag-hr (_dom) (shr-ensure-newline) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 7fb0ff57808..8138d9a3608 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -133,6 +133,7 @@ It is used for TCP/IP devices." (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-adb-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-adb-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -159,9 +160,11 @@ It is used for TCP/IP devices." (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -180,6 +183,7 @@ It is used for TCP/IP devices." (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-adb-handle-write-region)) @@ -535,7 +539,8 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -544,15 +549,26 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let* ((curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) + (let (file-locked + (curbuf (current-buffer)) + (tmpfile (tramp-compat-make-temp-file filename))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) - (write-region start end tmpfile append 'no-message lockname) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (with-tramp-progress-reporter - v 3 (format-message - "Moving tmp file `%s' to `%s'" tmpfile filename) + v 3 (format-message + "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect (unless (tramp-adb-execute-adb-command v "push" tmpfile (tramp-compat-file-name-unquote localname)) @@ -575,6 +591,11 @@ But handle the case, if the \"test\" command is not available." (file-attributes filename)) (current-time)))) + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + ;; The end. (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) @@ -782,7 +803,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let (command input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat #'tramp-shell-quote-argument diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index d723fd5c6d5..67798e892ab 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -236,6 +236,7 @@ It must be supported by libarchive(3).") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-archive-handle-file-local-copy) + (file-locked-p . ignore) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-archive-handle-file-name-all-completions) ;; `file-name-as-directory' performed by default handler. @@ -262,9 +263,11 @@ It must be supported by libarchive(3).") (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) (load . tramp-archive-handle-load) + (lock-file . ignore) (make-auto-save-file-name . ignore) (make-directory . tramp-archive-handle-not-implemented) (make-directory-internal . tramp-archive-handle-not-implemented) + (make-lock-file-name . ignore) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) @@ -283,6 +286,7 @@ It must be supported by libarchive(3).") (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-archive-handle-not-implemented)) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index a41620ab9f7..579234f9f50 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,6 +49,8 @@ ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. +;; "lock-pid" is the timestamp a (network) process is created, it is +;; used instead of the pid in file locks. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 54cfb6fb4a4..9d5e5f787b6 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -353,6 +353,16 @@ A nil value for either argument stands for the current time." (lambda (fromstring tostring instring) (replace-regexp-in-string (regexp-quote fromstring) tostring instring)))) +;; 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))))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 1d8c0ad2170..fdb2907ec32 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -182,6 +182,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-crypt-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) ;; `file-name-as-directory' performed by default handler. @@ -208,9 +209,11 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (insert-directory . tramp-crypt-handle-insert-directory) ;; `insert-file-contents' performed by default handler. (load . tramp-handle-load) + (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-crypt-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -229,6 +232,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) (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) (write-region . tramp-handle-write-region)) @@ -734,6 +738,11 @@ absolute file names." (let (tramp-crypt-enabled) (file-executable-p (tramp-crypt-encrypt-file-name filename)))) +(defun tramp-crypt-handle-file-locked-p (filename) + "Like `file-locked-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-locked-p (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for Tramp files." (all-completions @@ -797,6 +806,13 @@ WILDCARD is not supported." (delete-region (prop-match-beginning match) (prop-match-end match)) (insert (propertize string 'dired-filename t))))))) +(defun tramp-crypt-handle-lock-file (filename) + "Like `lock-file' for Tramp files." + (let (tramp-crypt-enabled) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall + 'lock-file (tramp-crypt-encrypt-file-name filename)))) + (defun tramp-crypt-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." (with-parsed-tramp-file-name (expand-file-name dir) nil @@ -848,6 +864,13 @@ WILDCARD is not supported." (tramp-set-file-uid-gid (tramp-crypt-encrypt-file-name filename) uid gid)))) +(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)))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-crypt 'force))) diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index ec1db8680f2..93b184a36c2 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -164,10 +164,9 @@ (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) (let* ((default-directory (tramp-compat-temporary-file-directory)) - (fuse (concat "fuse." (tramp-file-name-method vec))) - (mount (shell-command-to-string (format "mount -t %s" fuse)))) - (tramp-message vec 6 "%s %s" "mount -t" fuse) - (tramp-message vec 6 "\n%s" mount) + (command (format "mount -t fuse.%s" (tramp-file-name-method vec))) + (mount (shell-command-to-string command))) + (tramp-message vec 6 "%s\n%s" command mount) (tramp-set-connection-property (tramp-get-connection-process vec) "mounted" (when (string-match @@ -176,6 +175,16 @@ mount) (match-string 1 mount))))))) +(defun tramp-fuse-unmount (vec) + "Unmount fuse volume determined by VEC." + (let ((default-directory (tramp-compat-temporary-file-directory)) + (command (format "fusermount3 -u %s" (tramp-fuse-mount-point vec)))) + (tramp-message vec 6 "%s\n%s" command (shell-command-to-string command)) + (tramp-flush-connection-property + (tramp-get-connection-process vec) "mounted") + ;; Give the caches a chance to expire. + (sleep-for 1))) + (defun tramp-fuse-local-file-name (filename) "Return local mount name of FILENAME." (setq filename (tramp-compat-file-name-unquote (expand-file-name filename))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f1d24dc0c41..022fdeeb885 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -774,6 +774,7 @@ It has been changed in GVFS 1.14.") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-gvfs-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -800,9 +801,11 @@ It has been changed in GVFS 1.14.") (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -821,6 +824,7 @@ It has been changed in GVFS 1.14.") (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -2144,6 +2148,9 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 3b6de3e0b70..49e366c01c6 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -96,6 +96,7 @@ (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -122,9 +123,11 @@ (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -143,6 +146,7 @@ (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-handle-write-region)) @@ -358,6 +362,10 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property + p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 88caa2fb7ba..e6bd42a83ae 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -962,6 +962,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (file-exists-p . tramp-sh-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-sh-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-sh-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -988,9 +989,11 @@ Format specifiers \"%s\" are replaced before the script is used.") (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sh-handle-make-directory) ;; `make-directory-internal' performed by default handler. + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) @@ -1009,6 +1012,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . tramp-sh-handle-vc-registered) (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) (write-region . tramp-sh-handle-write-region)) @@ -3025,7 +3029,7 @@ implementation will be used." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let (command env uenv input tmpinput stderr tmpstderr outbuf ret) ;; Compute command. (setq command (mapconcat #'tramp-shell-quote-argument @@ -3235,7 +3239,8 @@ implementation will be used." (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -3244,23 +3249,31 @@ implementation will be used." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((uid (or (tramp-compat-file-attribute-user-id + (let (file-locked + (uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (if (and (tramp-local-host-p v) ;; `file-writable-p' calls `file-expand-file-name'. We ;; cannot use `tramp-run-real-handler' therefore. - (let (file-name-handler-alist) - (and - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))))) + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) ;; Short track: if we are on the local host, we can run directly. - (write-region start end localname append 'no-message lockname) + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) (let* ((modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) @@ -3294,9 +3307,10 @@ implementation will be used." ;; on. We must ensure that `file-coding-system-alist' ;; matches `tmpfile'. (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile))) + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) (condition-case err - (write-region start end tmpfile append 'no-message lockname) + (write-region start end tmpfile append 'no-message) ((error quit) (setq tramp-temp-buffer-file-name nil) (delete-file tmpfile) @@ -3465,6 +3479,12 @@ implementation will be used." ;; Set the ownership. (when need-chown (tramp-set-file-uid-gid filename uid gid)) + + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 6fbf08801e8..4008c25d3af 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -247,6 +247,7 @@ See `tramp-actions-before-shell' for more info.") (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-smb-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-smb-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -273,9 +274,11 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) @@ -294,6 +297,7 @@ See `tramp-actions-before-shell' for more info.") (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-smb-handle-write-region)) @@ -532,7 +536,7 @@ arguments to pass to the OPERATION." (tramp-process-actions p v nil tramp-smb-actions-with-tar) (while (process-live-p p) - (sit-for 0.1)) + (sleep-for 0.1)) (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. @@ -1255,7 +1259,7 @@ component is used as the target of the symlink." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) @@ -1575,7 +1579,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (defun tramp-smb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -1584,15 +1589,25 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((curbuf (current-buffer)) + (let (file-locked + (curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (tramp-run-real-handler - #'write-region (list start end tmpfile append 'no-message lockname)) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (with-tramp-progress-reporter v 3 (format "Moving tmp file %s to %s" tmpfile filename) @@ -1619,6 +1634,11 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (file-attributes filename)) (current-time)))) + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + ;; The end. (when (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index c4a36fe2a3a..99f4063988f 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -96,6 +96,7 @@ (file-exists-p . tramp-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-fuse-handle-file-name-all-completions) (file-name-as-directory . tramp-handle-file-name-as-directory) @@ -122,9 +123,11 @@ (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-sshfs-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-fuse-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) @@ -143,6 +146,7 @@ (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-sshfs-handle-write-region)) @@ -231,7 +235,7 @@ arguments to pass to the OPERATION." (when (and (numberp destination) (zerop destination)) (error "Implementation does not handle immediate return")) - (with-parsed-tramp-file-name default-directory nil + (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((command (format "cd %s && exec %s" @@ -281,7 +285,8 @@ arguments to pass to the OPERATION." (defun tramp-sshfs-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -290,15 +295,31 @@ arguments to pass to the OPERATION." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (write-region - start end (tramp-fuse-local-file-name filename) append 'nomessage lockname) - (tramp-flush-file-properties v localname) + (let (file-locked) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + + (let (create-lockfiles) + (write-region + start end (tramp-fuse-local-file-name filename) append 'nomessage) + (tramp-flush-file-properties v localname)) - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; File name conversions. @@ -321,6 +342,9 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index d6417094bae..45d9fab986c 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -88,6 +88,7 @@ See `tramp-actions-before-shell' for more info.") (file-exists-p . tramp-sudoedit-handle-file-exists-p) (file-in-directory-p . tramp-handle-file-in-directory-p) (file-local-copy . tramp-handle-file-local-copy) + (file-locked-p . tramp-handle-file-locked-p) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-sudoedit-handle-file-name-all-completions) @@ -115,9 +116,11 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) + (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sudoedit-handle-make-directory) (make-directory-internal . ignore) + (make-lock-file-name . tramp-handle-make-lock-file-name) (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) @@ -136,6 +139,7 @@ See `tramp-actions-before-shell' for more info.") (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) + (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-sudoedit-handle-write-region)) @@ -713,6 +717,7 @@ ID-FORMAT valid values are `string' and `integer'." (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (let* ((uid (or (tramp-compat-file-attribute-user-id (file-attributes filename 'integer)) @@ -776,6 +781,9 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) + ;; Mark process for filelock. + (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) + ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 75e44551ef9..736c7efd242 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2455,6 +2455,8 @@ Must be handled by the callers." file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info + ;; Emacs 28+ only. + file-locked-p lock-file make-lock-file-name unlock-file ;; Tramp internal magic file name function. tramp-set-file-uid-gid)) (if (file-name-absolute-p (nth 0 args)) @@ -3628,7 +3630,7 @@ User is always nil." (file-writable-p (file-name-directory filename))))))) (defcustom tramp-allow-unsafe-temporary-files nil - "Whether root-owned auto-save or backup files can be written to \"/tmp\"." + "Whether root-owned auto-save, backup or lock files can be written to \"/tmp\"." :version "28.1" :type 'boolean) @@ -3816,6 +3818,100 @@ User is always nil." ;; Result. (cons (expand-file-name filename) (cdr result))))) +(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))) + (or (file-symlink-p lockname) + (and (file-readable-p lockname) + (with-temp-buffer + (insert-file-contents-literally lockname) + (buffer-string)))))) + +(defun tramp-get-lock-pid (file) + "Determine pid for lockfile of FILE." + ;; Some Tramp methods do not offer a connection process, but just a + ;; network process as a place holder. Those processes use the + ;; "lock-pid" connection property as fake pid, in fact it is the + ;; time stamp the process is created. + (let ((p (tramp-get-process (tramp-dissect-file-name file)))) + (number-to-string + (or (process-id p) + (tramp-get-connection-property p "lock-pid" (emacs-pid)))))) + +(defconst tramp-lock-file-info-regexp + ;; USER@HOST.PID[:BOOT_TIME] + "\\`\\(.+\\)@\\(.+\\)\\.\\([[:digit:]]+\\)\\(?::\\([[:digit:]]+\\)\\)?\\'" + "The format of a lock file.") + +(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))) + (or (and (string-equal (match-string 1 info) (user-login-name)) + (string-equal (match-string 2 info) (system-name)) + (string-equal (match-string 3 info) (tramp-get-lock-pid file))) + (match-string 1 info)))) + +(defun tramp-handle-lock-file (file) + "Like `lock-file' for Tramp files." + ;; See if this file is visited and has changed on disk since it + ;; was visited. + (catch 'dont-lock + (unless (eq (file-locked-p file) t) ;; Locked by me. + (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) (system-name) + (tramp-get-lock-pid file)))) + + ;; Protect against security hole. + (with-parsed-tramp-file-name file nil + (when (and (not tramp-allow-unsafe-temporary-files) + (file-in-directory-p lockname temporary-file-directory) + (zerop (or (tramp-compat-file-attribute-user-id + (file-attributes file 'integer)) + tramp-unknown-id-integer)) + (not (with-tramp-connection-property + (tramp-get-process v) "unsafe-temporary-file" + (yes-or-no-p + (concat + "Lock file on local temporary directory, " + "do you want to continue? "))))) + (tramp-error v 'file-error "Unsafe lock file name"))) + + ;; Do the lock. + (let (create-lockfiles signal-hook-function) + (condition-case nil + (make-symbolic-link info lockname 'ok-if-already-exists) + (error + (with-file-modes #o0644 + (write-region info nil lockname))))))))) + +(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)) + (tramp-run-real-handler 'make-lock-file-name (list file)))) + +(defun tramp-handle-unlock-file (file) + "Like `unlock-file' for Tramp files." + (when-let ((lockname (tramp-compat-make-lock-file-name file))) + (condition-case err + (delete-file lockname) + ;; `userlock--handle-unlock-error' exists since Emacs 28.1. + (error (tramp-compat-funcall 'userlock--handle-unlock-error err))))) + (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." (with-parsed-tramp-file-name (expand-file-name file) nil @@ -4357,7 +4453,8 @@ of." (defun tramp-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) + (setq filename (expand-file-name filename) + lockname (file-truename (or lockname filename))) (with-parsed-tramp-file-name filename nil (when (and mustbenew (file-exists-p filename) (or (eq mustbenew 'excl) @@ -4366,7 +4463,8 @@ of." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename)) + (let (file-locked + (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) (uid (or (tramp-compat-file-attribute-user-id @@ -4375,6 +4473,15 @@ of." (gid (or (tramp-compat-file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) + (file-remote-p lockname) + (not (eq (file-locked-p lockname) t))) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -4386,7 +4493,8 @@ of." ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. - (write-region start end tmpfile append 'no-message lockname) + (let (create-lockfiles) + (write-region start end tmpfile append 'no-message)) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error @@ -4404,13 +4512,18 @@ of." (current-time)))) ;; Set the ownership. - (tramp-set-file-uid-gid filename uid gid)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))) + (tramp-set-file-uid-gid filename uid gid) + + ;; Unlock file. + (when (and file-locked (eq (file-locked-p lockname) t)) + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; This is used in tramp-sh.el and tramp-sudoedit.el. (defconst tramp-stat-marker "/////" diff --git a/lisp/outline.el b/lisp/outline.el index 68b8f4b6dda..0bb74ffd64a 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -182,7 +182,6 @@ in the file it applies to.") ;; Only takes effect if point is on a heading. :filter ,(lambda (cmd) (when (outline-on-heading-p) cmd))))) - (define-key map [tab] tab-binding) (define-key map (kbd "TAB") tab-binding) (define-key map (kbd "<backtab>") #'outline-cycle-buffer)) map) diff --git a/lisp/pcmpl-unix.el b/lisp/pcmpl-unix.el index c1aaf829dcf..e1d104f74ff 100644 --- a/lisp/pcmpl-unix.el +++ b/lisp/pcmpl-unix.el @@ -82,7 +82,8 @@ being via `pcmpl-ssh-known-hosts-file'." ;;;###autoload (defun pcomplete/xargs () "Completion for `xargs'." - ;; FIXME: Add completion of xargs-specific arguments. + (while (string-prefix-p "-" (pcomplete-arg 0)) + (pcomplete-here (funcall pcomplete-default-completion-function))) (funcall pcomplete-command-completion-function) (funcall (or (pcomplete-find-completion-function (pcomplete-arg 1)) pcomplete-default-completion-function))) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index e502cbb3dc0..755211b922b 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -25,10 +25,13 @@ ;; This file provides minor modes for putting clickable overlays on ;; references to bugs. A bug reference is text like "PR foo/29292"; -;; this is mapped to a URL using a user-supplied format. +;; this is mapped to a URL using a user-supplied format; see +;; `bug-reference-url-format' and `bug-reference-bug-regexp'. More +;; extensive documentation is in (info "(emacs) Bug Reference"). ;; Two minor modes are provided. One works on any text in the buffer; -;; the other operates only on comments and strings. +;; the other operates only on comments and strings. By default, the +;; URL link is followed by invoking C-c RET or mouse-2. ;;; Code: @@ -126,6 +129,9 @@ The second subexpression should match the bug reference (usually a number)." "Open URL corresponding to the bug reference at POS." (interactive (list (if (integerp last-command-event) (point) last-command-event))) + (when (null bug-reference-url-format) + (user-error + "You must customize some bug-reference variables; see Emacs info node Bug Reference")) (if (and (not (integerp pos)) (eventp pos)) ;; POS is a mouse event; switch to the proper window/buffer (let ((posn (event-start pos))) @@ -178,6 +184,22 @@ The second subexpression should match the bug reference (usually a number)." "/issues/" (match-string 2)))))) ;; + ;; Codeberg projects. + ;; + ;; The systematics is exactly as for Github projects. + ("[/@]codeberg.org[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://codeberg.org/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/issues/" + (match-string 2)))))) + ;; ;; GitLab projects. ;; ;; Here #18 is an issue and !17 is a merge request. Explicit @@ -195,6 +217,30 @@ The second subexpression should match the bug reference (usually a number)." (if (string= (match-string 3) "#") "issues/" "merge_requests/") + (match-string 2)))))) + ;; + ;; Sourcehut projects. + ;; + ;; #19 is an issue. Other project's issues can be referenced as + ;; #~user/project#19. + ;; + ;; Caveat: The code assumes that a project on git.sr.ht or + ;; hg.sr.ht has a tracker of the same name on todo.sh.ht. That's + ;; a very common setup but all sr.ht services are loosely coupled, + ;; so you can have a repo without tracker, or a repo with a + ;; tracker using a different name, etc. So we can only try to + ;; make a good guess. + ("[/@]\\(?:git\\|hg\\).sr.ht[/:]\\(~[.A-Za-z0-9_/-]+\\)" + "\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://todo.sr.ht/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/" (match-string 2))))))) "An alist for setting up `bug-reference-mode' based on VC URL. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 462ea51e2ce..91c72a9429f 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1345,6 +1345,13 @@ command before it's run." (grep-highlight-matches 'always)) (rgrep regexp files dir confirm))) +(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))) + (caar (compilation--loc->file-struct loc)))) + ;;;###autoload (defalias 'rzgrep 'zrgrep) diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index 0a72ae96bba..e69a9ff394e 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -62,6 +62,7 @@ (require 'comint) (require 'lisp-mode) +(require 'shell) (defgroup inferior-lisp nil @@ -289,15 +290,20 @@ to continue it." "Run an inferior Lisp process, input and output via buffer `*inferior-lisp*'. If there is a process already running in `*inferior-lisp*', just switch to that buffer. + With argument, allows you to edit the command line (default is value of `inferior-lisp-program'). Runs the hooks from `inferior-lisp-mode-hook' (after the `comint-mode-hook' is run). + +If any parts of the command name contains spaces, they should be +quoted using shell quote syntax. + \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run lisp: " inferior-lisp-program) inferior-lisp-program))) (if (not (comint-check-proc "*inferior-lisp*")) - (let ((cmdlist (split-string cmd))) + (let ((cmdlist (split-string-shell-command cmd))) (set-buffer (apply (function make-comint) "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 3f466e1150b..4d277755aeb 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -272,7 +272,7 @@ not be enclosed in { } or ( )." "Regex used to find macro assignment lines in a makefile.") (defconst makefile-var-use-regex - "[^$]\\$[({]\\([-a-zA-Z0-9_.]+\\|[@%<?^+*][FD]?\\)" + "\\(^\\|[^$]\\)\\$[({]\\([-a-zA-Z0-9_.]+\\|[@%<?^+*][FD]?\\)" "Regex used to find $(macro) uses in a makefile.") (defconst makefile-ignored-files-in-pickup-regex @@ -346,7 +346,7 @@ not be enclosed in { } or ( )." (3 font-lock-builtin-face prepend t)) ;; Variable references even in targets/strings/comments. - (,var 1 font-lock-variable-name-face prepend) + (,var 2 font-lock-variable-name-face prepend) ;; Automatic variable references and single character variable references, ;; but not shell variables references. diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index c3a12c5b2c5..91db4ae21cb 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -2192,6 +2192,8 @@ Point should be before the newline." When used interactively, insert the proper starting #!-line, and make the visited file executable via `executable-set-magic', perhaps querying depending on the value of `executable-query'. +(If given a prefix (i.e., `C-u') don't insert any starting #! +line.) When this function is called noninteractively, INSERT-FLAG (the third argument) controls whether to insert a #!-line and think about making @@ -2215,7 +2217,7 @@ whose value is the shell name (don't quote it)." '("csh" "rc" "sh")) nil nil nil nil sh-shell-file) (eq executable-query 'function) - t)) + (not current-prefix-arg))) (if (string-match "\\.exe\\'" shell) (setq shell (substring shell 0 (match-beginning 0)))) (setq sh-shell (sh-canonicalize-shell shell)) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index b7a926f82e0..e2cd904a6cd 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -959,7 +959,9 @@ GROUP is a string for decoration purposes and XREF is an (prefix (cond ((not line) " ") - ((equal line prev-line) "") + ((and (equal line prev-line) + (equal prev-group group)) + "") (t (propertize (format line-format line) 'face 'xref-line-number))))) ;; Render multiple matches on the same line, together. diff --git a/lisp/repeat.el b/lisp/repeat.el index 503cb340006..cec3cb643a1 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -397,7 +397,7 @@ When Repeat mode is enabled, and the command symbol has the property named (and (commandp s) (get s 'repeat-map) (push (get s 'repeat-map) keymaps)))))) - (message "Repeat mode is enabled for %d commands and %d keymaps; see `describe-repeat'." + (message "Repeat mode is enabled for %d commands and %d keymaps; see `describe-repeat-maps'." (length commands) (length (delete-dups keymaps)))))) @@ -489,10 +489,10 @@ When Repeat mode is enabled, and the command symbol has the property named repeat-echo-mode-line-string))) (force-mode-line-update t))) -(defun describe-repeat () - "Describe repeatable commands and keymaps." +(defun describe-repeat-maps () + "Describe mappings of commands repeatable by symbol property `repeat-map'." (interactive) - (help-setup-xref (list #'describe-repeat) + (help-setup-xref (list #'describe-repeat-maps) (called-interactively-p 'interactive)) (let ((keymaps nil)) (all-completions @@ -502,7 +502,7 @@ When Repeat mode is enabled, and the command symbol has the property named (push s (alist-get (get s 'repeat-map) keymaps))))) (with-help-window (help-buffer) (with-current-buffer standard-output - (princ "This is a list of repeatable keymaps and commands.\n\n") + (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) (princ (format-message "`%s' keymap is repeatable by these commands:\n" diff --git a/lisp/replace.el b/lisp/replace.el index fe2cbc447a6..ed81097e149 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1089,17 +1089,17 @@ a previously found match." rend (point-max))) (goto-char rstart)) (let ((count 0) - opoint (case-fold-search (if (and case-fold-search search-upper-case) (isearch-no-upper-case-p regexp t) case-fold-search))) (while (and (< (point) rend) - (progn (setq opoint (point)) - (re-search-forward regexp rend t))) - (if (= opoint (point)) - (forward-char 1) - (setq count (1+ count)))) + (re-search-forward regexp rend t)) + ;; Ensure forward progress on zero-length matches like "^$". + (when (and (= (match-beginning 0) (match-end 0)) + (not (eobp))) + (forward-char 1)) + (setq count (1+ count))) (when interactive (message (ngettext "%d occurrence" "%d occurrences" count) diff --git a/lisp/saveplace.el b/lisp/saveplace.el index f654702def4..2a95b39da87 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -87,6 +87,11 @@ this happens automatically before saving `save-place-alist' to `save-place-file'." :type 'boolean) +(defcustom save-place-abbreviate-file-names nil + "If non-nil, abbreviate file names before saving them." + :type 'boolean + :version "28.1") + (defcustom save-place-save-skipped t "If non-nil, remember files matching `save-place-skip-check-regexp'. @@ -177,7 +182,10 @@ file: "Add current buffer filename and position to `save-place-alist'. Put filename and point in a cons box and then cons that onto the front of the `save-place-alist', if `save-place-mode' is non-nil. -Otherwise, just delete that file from the alist." +Otherwise, just delete that file from the alist. + +If `save-place-abbreviate-file-names' is non-nil, abbreviate the +file names." ;; First check to make sure alist has been loaded in from the master ;; file. If not, do so, then feel free to modify the alist. It ;; will be saved again when Emacs is killed. @@ -195,6 +203,8 @@ Otherwise, just delete that file from the alist." (or (not save-place-ignore-files-regexp) (not (string-match save-place-ignore-files-regexp item)))) + (when save-place-abbreviate-file-names + (setq item (abbreviate-file-name item))) (let ((cell (assoc item save-place-alist)) (position (cond ((eq major-mode 'hexl-mode) (with-no-warnings diff --git a/lisp/select.el b/lisp/select.el index 72f03e76c48..ab744efcf09 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -187,11 +187,17 @@ decoded. If `gui-get-selection' signals an error, return nil." (let ((clip-text (when select-enable-clipboard (let ((text (gui--selection-value-internal 'CLIPBOARD))) - (if (string= text "") (setq text nil)) - - ;; Check the CLIPBOARD selection for 'newness', is it different - ;; from what we remembered them to be last time we did a - ;; cut/paste operation. + (when (string= text "") + (setq text nil)) + ;; When `select-enable-clipboard' is non-nil, + ;; killing/copying text (with, say, `C-w') will push the + ;; text to the clipboard (and store it in + ;; `gui--last-selected-text-clipboard'). We check + ;; whether the text on the clipboard is identical to this + ;; text, and if so, we report that the clipboard is + ;; empty. See (bug#27442) for further discussion about + ;; this DWIM action, and possible ways to make this check + ;; less fragile, if so desired. (prog1 (unless (equal text gui--last-selected-text-clipboard) text) diff --git a/lisp/shell.el b/lisp/shell.el index 4339e8c0a3b..5aab80d1031 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -459,6 +459,16 @@ Useful for shells like zsh that has this feature." (push (mapconcat #'identity (nreverse arg) "") args))) (cons (nreverse args) (nreverse begins))))) +;;;###autoload +(defun split-string-shell-command (string) + "Split STRING (a shell command) into a list of strings. +General shell syntax, like single and double quoting, as well as +backslash quoting, is respected." + (with-temp-buffer + (insert string) + (let ((comint-file-name-quote-list shell-file-name-quote-list)) + (car (shell--parse-pcomplete-arguments))))) + (defun shell-command-completion-function () "Completion function for shell command names. This is the value of `pcomplete-command-completion-function' for diff --git a/lisp/simple.el b/lisp/simple.el index cceb17180c1..f4d28c9a767 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -5842,7 +5842,13 @@ Can be `untabify' -- turn a tab to many spaces, then delete one space; (defun backward-delete-char-untabify (arg &optional killp) "Delete characters backward, changing tabs into spaces. The exact behavior depends on `backward-delete-char-untabify-method'. + Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. + +If Transient Mark mode is enabled, the mark is active, and ARG is 1, +delete the text in the region and deactivate the mark instead. +To disable this, set option ‘delete-active-region’ to nil. + Interactively, ARG is the prefix arg (default 1) and KILLP is t if a prefix arg was specified." (interactive "*p\nP") diff --git a/lisp/subr.el b/lisp/subr.el index e49c2773357..c7e18646bfb 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3850,6 +3850,14 @@ Before insertion, process text properties according to (insert-buffer-substring buffer start end) (remove-yank-excluded-properties opoint (point)))) +(defun insert-into-buffer (buffer &optional start end) + "Insert the contents of the current buffer into BUFFER. +If START/END, only insert that region from the current buffer. +Point in BUFFER will be placed after the inserted text." + (let ((current (current-buffer))) + (with-current-buffer buffer + (insert-buffer-substring current start end)))) + (defun yank-handle-font-lock-face-property (face start end) "If `font-lock-defaults' is nil, apply FACE as a `face' property. START and END denote the start and end of the text to act on. diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 0d97da8ca71..d5fad353638 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -471,7 +471,10 @@ should return the formatted tab name to display in the tab line." (dolist (fn tab-line-tab-face-functions) (setf face (funcall fn tab tabs face buffer-p selected-p))) (apply 'propertize - (concat (propertize name 'keymap tab-line-tab-map) + (concat (propertize name + 'keymap tab-line-tab-map + ;; Don't turn mouse-1 into mouse-2 (bug#49247) + 'follow-link 'ignore) (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab)) tab-line-close-button-show (not (eq tab-line-close-button-show diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el index ba8fac81f2c..877658a5a55 100644 --- a/lisp/textmodes/enriched.el +++ b/lisp/textmodes/enriched.el @@ -38,7 +38,7 @@ ;;; Code: -(provide 'enriched) +(require 'facemenu) ;;; ;;; Variables controlling the display @@ -538,4 +538,6 @@ the range of text to assign text property SYMBOL with value VALUE." (list start end 'display prop) (list start end 'display (list 'disable-eval prop))))) +(provide 'enriched) + ;;; enriched.el ends here diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 8b8108cb97b..ababd775d5f 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -1427,7 +1427,9 @@ on the line for the invalidity you want to see." (forward-line 1) (setq num-matches (1+ num-matches)) (insert-buffer-substring buffer start end) - (let (text-beg (text-end (point-marker))) + (let ((text-end (point-marker)) + (inhibit-read-only t) + text-beg) (forward-char (- start end)) (setq text-beg (point-marker)) (insert (format "%3d: " linenum)) @@ -1439,7 +1441,8 @@ on the line for the invalidity you want to see." (put-text-property text-beg (- text-end 1) 'occur-target tem)))))))) (with-current-buffer standard-output - (let ((no-matches (zerop num-matches))) + (let ((no-matches (zerop num-matches)) + (inhibit-read-only t)) (if no-matches (insert "None!\n")) (if (called-interactively-p 'interactive) diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 8ca0f429ca1..4c2470fbcb6 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -677,14 +677,14 @@ Signal an error if the entire string was not used." "Return the number at point, or nil if none is found. Decimal numbers like \"14\" or \"-14.5\", as well as hex numbers like \"0xBEEF09\" or \"#xBEEF09\", are recognized." - (when (thing-at-point-looking-at - "\\(-?[0-9]+\\.?[0-9]*\\)\\|\\(0x\\|#x\\)\\([a-zA-Z0-9]+\\)" 500) - (if (match-beginning 1) - (string-to-number - (buffer-substring (match-beginning 1) (match-end 1))) - (string-to-number - (buffer-substring (match-beginning 3) (match-end 3)) - 16)))) + (cond + ((thing-at-point-looking-at "\\(0x\\|#x\\)\\([a-fA-F0-9]+\\)" 500) + (string-to-number + (buffer-substring (match-beginning 2) (match-end 2)) + 16)) + ((thing-at-point-looking-at "-?[0-9]+\\.?[0-9]*" 500) + (string-to-number + (buffer-substring (match-beginning 0) (match-end 0)))))) (put 'number 'thing-at-point 'number-at-point) ;;;###autoload diff --git a/lisp/userlock.el b/lisp/userlock.el index 4a758153189..38aaf6aec23 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -230,7 +230,7 @@ to get the latest version of the file, then make the change again." (display-warning '(unlock-file) ;; There is no need to explain that this is an unlock error because - ;; ERR is a `file-error' condition, which explains this. + ;; ERROR is a `file-error' condition, which explains this. (message "%s, ignored" (error-message-string error)) :warning)) diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index b2b92b17e28..0cbea2c28d7 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -563,8 +563,9 @@ to invocation.") (set-visited-file-name merge-buffer-file)))) (ediff-with-current-buffer ediff-buffer-C (setq buffer-offer-save t) ; ask before killing buffer - ;; make sure the contents is auto-saved - (auto-save-mode 1)) + (when make-backup-files + ;; make sure the contents is auto-saved + (auto-save-mode 1))) )) diff --git a/lisp/window.el b/lisp/window.el index c0511bec4c4..0346397566a 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -8733,6 +8733,13 @@ documentation for additional customization information." BUFFER-OR-NAME may be a buffer, a string (a buffer name), or nil. Return the buffer switched to. +This uses the function `display-buffer' as a subroutine to +display the buffer; see its documentation for additional +customization information. By default, if the buffer is already +displayed (even in the current frame), that window is selected. +If the buffer isn't displayed in any frame, a new frame is popped +up and the buffer is displayed there. + If called interactively, read the buffer name using `read-buffer'. The variable `confirm-nonexistent-file-or-buffer' determines whether to request confirmation before creating a new buffer. @@ -8744,10 +8751,7 @@ buffer, create a new buffer with that name. If BUFFER-OR-NAME is nil, switch to the buffer returned by `other-buffer'. Optional second arg NORECORD non-nil means do not put this -buffer at the front of the list of recently selected ones. - -This uses the function `display-buffer' as a subroutine; see its -documentation for additional customization information." +buffer at the front of the list of recently selected ones." (interactive (list (read-buffer-to-switch "Switch to buffer in other frame: "))) (pop-to-buffer buffer-or-name display-buffer--other-frame-action norecord)) |