commit 3273e2ace788a58bef77cef936021d151815ea94 (HEAD, refs/remotes/origin/master) Author: Juri Linkov Date: Mon Mar 30 01:57:36 2020 +0300 Deprecate with-displayed-buffer-window, use body-function instead (bug#39822) * doc/lispref/display.texi (Temporary Displays): Remove defmac with-displayed-buffer-window. * doc/lispref/windows.texi (Buffer Display Action Alists): Add body-function. * lisp/window.el (with-displayed-buffer-window): Declare macro obsolete. (window--display-buffer): Call 'body-function' after displaying the buffer. * lisp/dired.el (dired-mark-pop-up): * lisp/files.el (save-buffers-kill-emacs): * lisp/minibuffer.el (minibuffer-completion-help): Replace with-displayed-buffer-window with with-current-buffer-window and add action alist entry 'body-function' with former macro body. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 2b25d6023c..9fbf995d7e 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -1318,12 +1318,6 @@ the buffer specified by @var{buffer-or-name} current for running @var{body}. @end defmac -@defmac with-displayed-buffer-window buffer-or-name action quit-function &rest body -This macro is like @code{with-current-buffer-window} but unlike that -displays the buffer specified by @var{buffer-or-name} @emph{before} -running @var{body}. -@end defmac - A window showing a temporary buffer can be fitted to the size of that buffer using the following mode: diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index d0791d4019..00142d87dc 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -3048,6 +3048,15 @@ since there is no guarantee that an arbitrary caller of @code{display-buffer} will be able to handle the case that no window will display the buffer. @code{display-buffer-no-window} is the only action function that cares about this entry. + +@vindex body-function@r{, a buffer display action alist entry} +@item body-function +The value must be a function taking one argument (a displayed window). +This function can be used to fill the displayed window's body with +some contents. It is called @emph{after} the buffer is displayed, and +@emph{before} the entries @code{window-height}, @code{window-width} +and @code{preserve-size} are applied that could resize the window +to fit it to the inserted contents. @end table By convention, the entries @code{window-height}, @code{window-width} diff --git a/etc/NEWS b/etc/NEWS index bb5f549a2e..765a923bf7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -266,6 +266,10 @@ It was used to allow loading Lisp libraries compiled by XEmacs, a modified version of Emacs which is no longer actively maintained. This is no longer supported, and setting this variable has no effect. ++++ +** The macro 'with-displayed-buffer-window' is now obsolete. +Use macro 'with-current-buffer-window' with action alist entry 'body-function'. + * Lisp Changes in Emacs 28.1 diff --git a/lisp/dired.el b/lisp/dired.el index 72d1cc250a..b66bb03471 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -3521,26 +3521,27 @@ argument or confirmation)." ;; Mark *Marked Files* window as softly-dedicated, to prevent ;; other buffers e.g. *Completions* from reusing it (bug#17554). (display-buffer-mark-dedicated 'soft)) - (with-displayed-buffer-window + (with-current-buffer-window buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) + `(display-buffer-below-selected + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + ;; Handle (t FILE) just like (FILE), here. That value is + ;; used (only in some cases), to mean just one file that was + ;; marked, rather than the current line file. + (dired-format-columns-of-files + (if (eq (car files) t) (cdr files) files)) + (remove-text-properties (point-min) (point-max) + '(mouse-face nil help-echo nil)) + (setq tab-line-exclude nil)))) #'(lambda (window _value) (with-selected-window window (unwind-protect (apply function args) (when (window-live-p window) - (quit-restore-window window 'kill))))) - ;; Handle (t FILE) just like (FILE), here. That value is - ;; used (only in some cases), to mean just one file that was - ;; marked, rather than the current line file. - (with-current-buffer buffer - (dired-format-columns-of-files - (if (eq (car files) t) (cdr files) files)) - (remove-text-properties (point-min) (point-max) - '(mouse-face nil help-echo nil)) - (setq tab-line-exclude nil)))))) + (quit-restore-window window 'kill))))))))) (defun dired-format-columns-of-files (files) (let ((beg (point))) diff --git a/lisp/files.el b/lisp/files.el index 8ce0187f5b..1f5fae9502 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -7253,10 +7253,15 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq active t)) (setq processes (cdr processes))) (or (not active) - (with-displayed-buffer-window + (with-current-buffer-window (get-buffer-create "*Process List*") - '(display-buffer--maybe-at-bottom - (dedicated . t)) + `(display-buffer--maybe-at-bottom + (dedicated . t) + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + (list-processes t)))) #'(lambda (window _value) (with-selected-window window (unwind-protect @@ -7264,8 +7269,7 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq confirm nil) (yes-or-no-p "Active processes exist; kill them and exit anyway? ")) (when (window-live-p window) - (quit-restore-window window 'kill))))) - (list-processes t))))) + (quit-restore-window window 'kill))))))))) ;; Query the user for other things, perhaps. (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 7f5b597542..9e0e6339c6 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1973,7 +1973,7 @@ variables.") ;; minibuffer-hide-completions will know whether to ;; delete the window or not. (display-buffer-mark-dedicated 'soft)) - (with-displayed-buffer-window + (with-current-buffer-window "*Completions*" ;; This is a copy of `display-buffer-fallback-action' ;; where `display-buffer-use-some-window' is replaced @@ -1991,62 +1991,64 @@ variables.") '(window-height . resize-temp-buffer-window) '(window-height . fit-window-to-buffer)) ,(when temp-buffer-resize-mode - '(preserve-size . (nil . t)))) - nil - ;; Remove the base-size tail because `sort' requires a properly - ;; nil-terminated list. - (when last (setcdr last nil)) - (setq completions - ;; FIXME: This function is for the output of all-completions, - ;; not completion-all-completions. Often it's the same, but - ;; not always. - (let ((sort-fun (completion-metadata-get - all-md 'display-sort-function))) - (if sort-fun - (funcall sort-fun completions) - (sort completions 'string-lessp)))) - (when afun - (setq completions - (mapcar (lambda (s) - (let ((ann (funcall afun s))) - (if ann (list s ann) s))) - completions))) - - (with-current-buffer standard-output - (set (make-local-variable 'completion-base-position) - (list (+ start base-size) - ;; FIXME: We should pay attention to completion - ;; boundaries here, but currently - ;; completion-all-completions does not give us the - ;; necessary information. - end)) - (set (make-local-variable 'completion-list-insert-choice-function) - (let ((ctable minibuffer-completion-table) - (cpred minibuffer-completion-predicate) - (cprops completion-extra-properties)) - (lambda (start end choice) - (unless (or (zerop (length prefix)) - (equal prefix - (buffer-substring-no-properties - (max (point-min) - (- start (length prefix))) - start))) - (message "*Completions* out of date")) - ;; FIXME: Use `md' to do quoting&terminator here. - (completion--replace start end choice) - (let* ((minibuffer-completion-table ctable) - (minibuffer-completion-predicate cpred) - (completion-extra-properties cprops) - (result (concat prefix choice)) - (bounds (completion-boundaries - result ctable cpred ""))) - ;; If the completion introduces a new field, then - ;; completion is not finished. - (completion--done result - (if (eq (car bounds) (length result)) - 'exact 'finished))))))) - - (display-completion-list completions)))) + '(preserve-size . (nil . t))) + (body-function + . ,#'(lambda (_window) + ;; Remove the base-size tail because `sort' requires a properly + ;; nil-terminated list. + (when last (setcdr last nil)) + (setq completions + ;; FIXME: This function is for the output of all-completions, + ;; not completion-all-completions. Often it's the same, but + ;; not always. + (let ((sort-fun (completion-metadata-get + all-md 'display-sort-function))) + (if sort-fun + (funcall sort-fun completions) + (sort completions 'string-lessp)))) + (when afun + (setq completions + (mapcar (lambda (s) + (let ((ann (funcall afun s))) + (if ann (list s ann) s))) + completions))) + + (with-current-buffer standard-output + (set (make-local-variable 'completion-base-position) + (list (+ start base-size) + ;; FIXME: We should pay attention to completion + ;; boundaries here, but currently + ;; completion-all-completions does not give us the + ;; necessary information. + end)) + (set (make-local-variable 'completion-list-insert-choice-function) + (let ((ctable minibuffer-completion-table) + (cpred minibuffer-completion-predicate) + (cprops completion-extra-properties)) + (lambda (start end choice) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + ;; FIXME: Use `md' to do quoting&terminator here. + (completion--replace start end choice) + (let* ((minibuffer-completion-table ctable) + (minibuffer-completion-predicate cpred) + (completion-extra-properties cprops) + (result (concat prefix choice)) + (bounds (completion-boundaries + result ctable cpred ""))) + ;; If the completion introduces a new field, then + ;; completion is not finished. + (completion--done result + (if (eq (car bounds) (length result)) + 'exact 'finished))))))) + + (display-completion-list completions)))) + nil))) nil)) (defun minibuffer-hide-completions () diff --git a/lisp/window.el b/lisp/window.el index b54f1633f5..0121a78191 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -226,7 +226,9 @@ BODY." "Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer. This construct is like `with-current-buffer-window' but unlike that, displays the buffer specified by BUFFER-OR-NAME before running BODY." - (declare (debug t) (indent 3)) + (declare (debug t) (indent 3) + (obsolete "use `with-current-buffer-window' with action alist entry `body-function'." + "28.1")) (let ((buffer (make-symbol "buffer")) (window (make-symbol "window")) (value (make-symbol "value"))) @@ -7070,6 +7072,12 @@ Return WINDOW if BUFFER and WINDOW are live." (set-window-dedicated-p window display-buffer-mark-dedicated)))) (when (memq type '(window frame tab)) (set-window-prev-buffers window nil)) + + (when (functionp (cdr (assq 'body-function alist))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (funcall (cdr (assq 'body-function alist)) window))) + (let ((quit-restore (window-parameter window 'quit-restore)) (height (cdr (assq 'window-height alist))) (width (cdr (assq 'window-width alist))) commit 7a6f5a5167037cdc3a0e9e312393781daedec085 Author: Juri Linkov Date: Mon Mar 30 01:34:47 2020 +0300 Support state changing VC operations on directories in Dired (bug#34949) * lisp/dired-aux.el (dired-vc-next-action): New command. (dired-vc-deduce-fileset): Rename from vc-dired-deduce-fileset in vc.el. * lisp/dired.el (dired-mode-map): Remap vc-next-action to dired-vc-next-action. * lisp/vc/vc-dir.el (vc-dir-mark-files): New function. (vc-dir-refresh): Run hook vc-dir-refresh-hook. * lisp/vc/vc.el (vc-deduce-fileset): Rename arg 'observer' to 'not-state-changing' and document it in docstring. (vc-dired-deduce-fileset): Rename to dired-vc-deduce-fileset in dired-aux.el. * lisp/cedet/ede.el (ede-turn-on-hook, ede-minor-mode): * lisp/desktop.el (desktop-minor-mode-table): Rename the long ago obsolete vc-dired-mode to vc-dir-mode. diff --git a/etc/NEWS b/etc/NEWS index 4b477e5def..bb5f549a2e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -108,8 +108,8 @@ Mark mode, then Dired commands operate only on files in the active region. The values 'file' and 'line' of this user option define the details of marking the file at the end of the region. -*** State changing VC operations are supported in 'dired-mode' on files -(but still not on directories). +*** State changing VC operations are supported in Dired on files and +directories with the help of new command 'dired-vc-next-action'. ** Change Logs and VC diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index c203687828..8c336117c9 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -470,7 +470,7 @@ To be used in hook functions." ;; Emacs 21 has no buffer file name for directory edits. ;; so we need to add these hacks in. (eq major-mode 'dired-mode) - (eq major-mode 'vc-dired-mode)) + (eq major-mode 'vc-dir-mode)) (ede-minor-mode 1))) (define-minor-mode ede-minor-mode @@ -481,7 +481,7 @@ controlled project, then this mode is activated automatically provided `global-ede-mode' is enabled." :group 'ede (cond ((or (eq major-mode 'dired-mode) - (eq major-mode 'vc-dired-mode)) + (eq major-mode 'vc-dir-mode)) (ede-dired-minor-mode (if ede-minor-mode 1 -1))) (ede-minor-mode (if (not ede-constructing) diff --git a/lisp/desktop.el b/lisp/desktop.el index de601a4de8..9d117c6f0d 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -534,7 +534,7 @@ can guess how to load the mode's definition.") '((defining-kbd-macro nil) (isearch-mode nil) (vc-mode nil) - (vc-dired-mode nil) + (vc-dir-mode nil) (erc-track-minor-mode nil) (savehist-mode nil)) "Table mapping minor mode variables to minor mode functions. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 6f50a3da6c..60a352d78e 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -3050,6 +3050,68 @@ instead." (backward-delete-char 1)) (message "%s" (buffer-string))))) + +;;; Version control from dired + +(declare-function vc-dir-unmark-all-files "vc-dir") +(declare-function vc-dir-mark-files "vc-dir") + +;;;###autoload +(defun dired-vc-next-action (verbose) + "Do the next version control operation on marked files/directories. +When only files are marked then call `vc-next-action' with the +same value of the VERBOSE argument. +When also directories are marked then call `vc-dir' and mark +the same files/directories in the VC-Dir buffer that were marked +in the Dired buffer." + (interactive "P") + (let* ((marked-files + (dired-get-marked-files nil nil nil nil t)) + (mark-files + (when (cl-some #'file-directory-p marked-files) + ;; Fix deficiency of Dired by adding slash to dirs + (mapcar (lambda (file) + (if (file-directory-p file) + (file-name-as-directory file) + file)) + marked-files)))) + (if mark-files + (let ((transient-hook (make-symbol "vc-dir-mark-files"))) + (fset transient-hook + (lambda () + (remove-hook 'vc-dir-refresh-hook transient-hook t) + (vc-dir-unmark-all-files t) + (vc-dir-mark-files mark-files))) + (vc-dir-root) + (add-hook 'vc-dir-refresh-hook transient-hook nil t)) + (vc-next-action verbose)))) + +(declare-function vc-compatible-state "vc") + +(defun dired-vc-deduce-fileset (&optional state-model-only-files not-state-changing) + (let ((backend (vc-responsible-backend default-directory)) + (files (dired-get-marked-files nil nil nil nil t)) + only-files-list + state + model) + (when (and (not not-state-changing) (cl-some #'file-directory-p files)) + (user-error "State changing VC operations on directories supported only in `vc-dir'")) + + (when state-model-only-files + (setq only-files-list (mapcar (lambda (file) (cons file (vc-state file))) files)) + (setq state (cdar only-files-list)) + ;; Check that all files are in a consistent state, since we use that + ;; state to decide which operation to perform. + (dolist (crt (cdr only-files-list)) + (unless (vc-compatible-state (cdr crt) state) + (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s" + (car crt) (cdr crt) (caar only-files-list) state))) + (setq only-files-list (mapcar 'car only-files-list)) + (when (and state (not (eq state 'unregistered))) + (setq model (vc-checkout-model backend only-files-list)))) + (list backend files only-files-list state model))) + + (provide 'dired-aux) ;; Local Variables: diff --git a/lisp/dired.el b/lisp/dired.el index 41bbf9f56a..72d1cc250a 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1870,6 +1870,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map "\177" 'dired-unmark-backward) (define-key map [remap undo] 'dired-undo) (define-key map [remap advertised-undo] 'dired-undo) + (define-key map [remap vc-next-action] 'dired-vc-next-action) ;; thumbnail manipulation (image-dired) (define-key map "\C-td" 'image-dired-display-thumbs) (define-key map "\C-tt" 'image-dired-tag-files) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index b760e17067..ab5943917b 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -696,6 +696,17 @@ share the same state." (vc-dir-mark-file crt))) (setq crt (ewoc-next vc-ewoc crt)))))))) +(defun vc-dir-mark-files (mark-files) + "Mark files specified by file names in the argument MARK-FILES. +MARK-FILES should be a list of absolute filenames." + (ewoc-map + (lambda (filearg) + (when (member (expand-file-name (vc-dir-fileinfo->name filearg)) + mark-files) + (setf (vc-dir-fileinfo->marked filearg) t) + t)) + vc-ewoc)) + (defun vc-dir-unmark-file () ;; Unmark the current file and move to the next line. (let* ((crt (ewoc-locate vc-ewoc)) @@ -1193,7 +1204,8 @@ Throw an error if another update process is in progress." (if remaining (vc-dir-refresh-files (mapcar 'vc-dir-fileinfo->name remaining)) - (setq mode-line-process nil)))))))))))) + (setq mode-line-process nil) + (run-hooks 'vc-dir-refresh-hook)))))))))))) (defun vc-dir-show-fileentry (file) "Insert an entry for a specific file into the current *VC-dir* listing. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 607fb37807..d4323d59eb 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -1006,12 +1006,18 @@ Within directories, only files already under version control are noticed." (declare-function vc-dir-current-file "vc-dir" ()) (declare-function vc-dir-deduce-fileset "vc-dir" (&optional state-model-only-files)) +(declare-function dired-vc-deduce-fileset "dired-aux" (&optional state-model-only-files not-state-changing)) -(defun vc-deduce-fileset (&optional observer allow-unregistered +(defun vc-deduce-fileset (&optional not-state-changing + allow-unregistered state-model-only-files) "Deduce a set of files and a backend to which to apply an operation. Return (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL). +NOT-STATE-CHANGING if non-nil, means that the operation +requesting the fileset doesn't intend to change VC state, +such as printing the log or showing the diff. + If we're in VC-dir mode, FILESET is the list of marked files, or the directory if no files are marked. Otherwise, if in a buffer visiting a version-controlled file, @@ -1025,14 +1031,12 @@ the FILESET-ONLY-FILES STATE and MODEL info. Otherwise, that part may be skipped. BEWARE: this function may change the current buffer." - ;; FIXME: OBSERVER is unused. The name is not intuitive and is not - ;; documented. It's set to t when called from diff and print-log. (let (backend) (cond ((derived-mode-p 'vc-dir-mode) (vc-dir-deduce-fileset state-model-only-files)) ((derived-mode-p 'dired-mode) - (vc-dired-deduce-fileset state-model-only-files observer)) + (dired-vc-deduce-fileset state-model-only-files not-state-changing)) ((setq backend (vc-backend buffer-file-name)) (if state-model-only-files (list backend (list buffer-file-name) @@ -1048,7 +1052,7 @@ BEWARE: this function may change the current buffer." (derived-mode-p 'dired-mode))))) (progn ;FIXME: Why not `with-current-buffer'? --Stef. (set-buffer vc-parent-buffer) - (vc-deduce-fileset observer allow-unregistered state-model-only-files))) + (vc-deduce-fileset not-state-changing allow-unregistered state-model-only-files))) ((and (derived-mode-p 'log-view-mode) (setq backend (vc-responsible-backend default-directory))) (list backend nil)) @@ -1065,32 +1069,6 @@ BEWARE: this function may change the current buffer." (list buffer-file-name)))) (t (error "File is not under version control"))))) -(declare-function dired-get-marked-files "dired" - (&optional localp arg filter distinguish-one-marked error)) - -(defun vc-dired-deduce-fileset (&optional state-model-only-files observer) - (let ((backend (vc-responsible-backend default-directory)) - (files (dired-get-marked-files nil nil nil nil t)) - only-files-list - state - model) - (when (and (not observer) (cl-some #'file-directory-p files)) - (error "State changing VC operations on directories not supported in `dired-mode'")) - - (when state-model-only-files - (setq only-files-list (mapcar (lambda (file) (cons file (vc-state file))) files)) - (setq state (cdar only-files-list)) - ;; Check that all files are in a consistent state, since we use that - ;; state to decide which operation to perform. - (dolist (crt (cdr only-files-list)) - (unless (vc-compatible-state (cdr crt) state) - (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s" - (car crt) (cdr crt) (caar only-files-list) state))) - (setq only-files-list (mapcar 'car only-files-list)) - (when (and state (not (eq state 'unregistered))) - (setq model (vc-checkout-model backend only-files-list)))) - (list backend files only-files-list state model))) - (defun vc-ensure-vc-buffer () "Make sure that the current buffer visits a version-controlled file." (cond commit 1276c8e10b000b571a12227ebe9216cc6305ef7f Author: Eli Zaretskii Date: Sun Mar 29 16:43:56 2020 +0300 Use hard links to Emacs executable in "make install" on MS-Windows * configure.ac (LN_S_FILEONLY): Set to "/bin/ln" for MinGW unconditionally. diff --git a/configure.ac b/configure.ac index a4daf1414d..9907160482 100644 --- a/configure.ac +++ b/configure.ac @@ -1246,18 +1246,12 @@ emacs_cv_ln_s_fileonly='cp -p' dnl On MinGW, ensure we will call the MSYS /bin/ln.exe, not some dnl random program in the current directory. if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - if test "$opsys" = "mingw32"; then - emacs_cv_ln_s_fileonly='/bin/ln -s' - else - emacs_cv_ln_s_fileonly='ln -s' - fi + if test "$opsys" = "mingw32"; then + emacs_cv_ln_s_fileonly=/bin/ln + elif ln -s conf$$.file conf$$ 2>/dev/null; then + emacs_cv_ln_s_fileonly='ln -s' elif ln conf$$.file conf$$ 2>/dev/null; then - if test "$opsys" = "mingw32"; then - emacs_cv_ln_s_fileonly=/bin/ln - else - emacs_cv_ln_s_fileonly=ln - fi + emacs_cv_ln_s_fileonly=ln fi fi commit 76b3bd8cbb9a0a01941d9c1766c054960e4bfd97 Author: Michael Albinus Date: Sun Mar 29 12:24:04 2020 +0200 Improve Tramp cache for asynchronous processes * lisp/net/tramp-adb.el (tramp-adb-handle-exec-path) (tramp-adb-get-device): * lisp/net/tramp-gvfs.el (tramp-gvfs-handler-askquestion): * lisp/net/tramp-sh.el (tramp-remote-selinux-p, tramp-remote-acl-p) (tramp-open-connection-setup-interactive-shell) (tramp-maybe-open-connection, tramp-get-remote-path) (tramp-get-inline-compress, tramp-get-inline-coding): * lisp/net/tramp-smb.el (tramp-smb-get-cifs-capabilities) (tramp-smb-get-stat-capability): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-remote-acl-p) (tramp-sudoedit-remote-selinux-p): Cache property in main process. * lisp/net/tramp-cache.el (tramp-cache-undefined): New defconst. (tramp-get-hash-table, tramp-connection-property-p): Use it. (tramp-set-connection-property, tramp-flush-connection-property) (tramp-flush-connection-properties): Add sanity checks. (tramp-get-file-property, tramp-set-file-property) (tramp-get-connection-property, tramp-set-connection-property) (tramp-dump-connection-properties): Adapt docstring. * lisp/net/tramp-cmds.el (tramp-cleanup-connection): Delete all processes. * lisp/net/tramp-gvfs.el (tramp-gvfs-unmount): Use `tramp-cleanup-connection'. * lisp/net/tramp-sh.el (tramp-sh-handle-vc-registered): Use `bound-and-true-p'. * lisp/net/tramp.el (tramp-get-process): New defun. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 4512179eb1..aae25d1dbf 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1097,7 +1097,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `exec-path' for Tramp files." (append (with-parsed-tramp-file-name default-directory nil - (with-tramp-connection-property v "remote-path" + (with-tramp-connection-property (tramp-get-process v) "remote-path" (tramp-adb-send-command v "echo \\\"$PATH\\\"") (split-string (with-current-buffer (tramp-get-connection-buffer v) @@ -1112,11 +1112,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." - ;; Sometimes this is called before there is a connection process - ;; yet. In order to work with the connection cache, we flush all - ;; unwanted entries first. - (tramp-flush-connection-properties nil) - (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (with-tramp-connection-property (tramp-get-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 91ed546569..93eeb16f54 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -31,13 +31,13 @@ ;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; -;; - localname is NIL. This are reusable properties. Examples: +;; - localname is nil. These are reusable properties. Examples: ;; "remote-shell" identifies the POSIX shell to be called on the ;; remote host, or "perl" is the command to be called on the remote ;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; -;; - localname is a string. This are temporary properties, which are +;; - localname is a string. These are temporary properties, which are ;; related to the file localname is referring to. Examples: ;; "file-exists-p" is t or nil, depending on the file existence, or ;; "file-attributes" caches the result of the function @@ -45,21 +45,32 @@ ;; expire after `remote-file-name-inhibit-cache' seconds if this ;; variable is set. ;; -;; - The key is a process. This are temporary properties related to +;; - The key is a process. These are temporary properties related to ;; 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. ;; -;; - The key is nil. This are temporary properties related to the +;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep ;; the results of parsing "/etc/passwd" and "/etc/group", ;; "{uid,gid}-{integer,string}" are the local uid and gid, and ;; "locale" is the used shell locale. +;; +;; - The key is `tramp-cache-undefined'. All functions return the +;; expected values, but nothing is cached. ;; Some properties are handled special: ;; ;; - "process-name", "process-buffer" and "first-password-request" are -;; not saved in the file `tramp-persistency-file-name'. +;; not saved in the file `tramp-persistency-file-name', although +;; being connection properties related to a `tramp-file-name' +;; structure. +;; +;; - Reusable properties, which should not be saved, are kept in the +;; process key retrieved by `tramp-get-process' (the main connection +;; process). Other processes could reuse these properties, avoiding +;; recomputation when a new asynchronous process is created by +;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). ;;; Code: @@ -96,25 +107,31 @@ details see the info pages." (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload +(defconst tramp-cache-undefined 'undef + "The symbol marking undefined hash keys and values.") + (defun tramp-get-hash-table (key) "Return the hash table for KEY. If it doesn't exist yet, it is created and initialized with -matching entries of `tramp-connection-properties'." - (or (gethash key tramp-cache-data) - (let ((hash - (puthash key (make-hash-table :test #'equal) tramp-cache-data))) - (when (tramp-file-name-p key) - (dolist (elt tramp-connection-properties) - (when (string-match-p - (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) - (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) - hash))) +matching entries of `tramp-connection-properties'. +If KEY is `tramp-cache-undefined', don't create anything, and return nil." + (unless (eq key tramp-cache-undefined) + (or (gethash key tramp-cache-data) + (let ((hash + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) + (when (tramp-file-name-p key) + (dolist (elt tramp-connection-properties) + (when (string-match-p + (or (nth 0 elt) "") + (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) + hash)))) ;;;###tramp-autoload (defun tramp-get-file-property (key file property default) "Get the PROPERTY of FILE from the cache context of KEY. -Returns DEFAULT if not set." +Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -152,7 +169,7 @@ Returns DEFAULT if not set." ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. -Returns VALUE." +Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -283,8 +300,9 @@ This is suppressed for temporary buffers." "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. If the -value is not set for the connection, returns DEFAULT." +used to cache connection properties of the local machine. +If KEY is `tramp-cache-undefined', or if the value is not set for +the connection, return DEFAULT." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) @@ -308,19 +326,22 @@ value is not set for the connection, returns DEFAULT." "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. -PROPERTY is set persistent when KEY is a `tramp-file-name' structure." +used to cache connection properties of the local machine. If KEY +is `tramp-cache-undefined', nothing is set. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure. +Return VALUE." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (let ((hash (tramp-get-hash-table key))) - (puthash property value hash) - (setq tramp-cache-data-changed t) - (tramp-message key 7 "%s %s" property value) - value)) + (when-let ((hash (tramp-get-hash-table key))) + (puthash property value hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-tramp-file-p key))) + (tramp-message key 7 "%s %s" property value) + value) ;;;###tramp-autoload (defun tramp-connection-property-p (key property) @@ -328,7 +349,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is used to cache connection properties of the local machine." - (not (eq (tramp-get-connection-property key property 'undef) 'undef))) + (not (eq (tramp-get-connection-property key property tramp-cache-undefined) + tramp-cache-undefined))) ;;;###tramp-autoload (defun tramp-flush-connection-property (key property) @@ -343,8 +365,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (remhash property (tramp-get-hash-table key)) - (setq tramp-cache-data-changed t) + (when-let ((hash (tramp-get-hash-table key))) + (remhash property hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-tramp-file-p key))) (tramp-message key 7 "%s" property)) ;;;###tramp-autoload @@ -361,9 +385,10 @@ used to cache connection properties of the local machine." (tramp-file-name-hop key) nil)) (tramp-message key 7 "%s %s" key - (let ((hash (gethash key tramp-cache-data))) - (when (hash-table-p hash) (hash-table-keys hash)))) - (setq tramp-cache-data-changed t) + (when-let ((hash (gethash key tramp-cache-data))) + (hash-table-keys hash))) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-tramp-file-p key))) (remhash key tramp-cache-data)) ;;;###tramp-autoload @@ -414,7 +439,8 @@ used to cache connection properties of the local machine." (hash-table-keys tramp-cache-data))))) (defun tramp-dump-connection-properties () - "Write persistent connection properties into file `tramp-persistency-file-name'." + "Write persistent connection properties into file \ +`tramp-persistency-file-name'." ;; We shouldn't fail, otherwise Emacs might not be able to be closed. (ignore-errors (when (and (hash-table-p tramp-cache-data) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index b4dca2321c..7d353e262a 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -107,21 +107,19 @@ When called interactively, a Tramp connection has to be selected." ;; suppressed. (setq tramp-current-connection nil) - ;; Flush file cache. - (tramp-flush-directory-properties vec "") - - ;; Flush connection cache. - (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-properties (tramp-get-connection-process vec)) - (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-properties vec) - ;; Cancel timer. (dolist (timer timer-list) (when (and (eq (timer--function timer) 'tramp-timeout-session) (tramp-file-name-equal-p vec (car (timer--args timer)))) (cancel-timer timer))) + ;; Delete processes. + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (processp key) + (tramp-file-name-equal-p (process-get key 'vector) vec)) + (tramp-flush-connection-properties key) + (delete-process key))) + ;; Remove buffers. (dolist (buf (list (get-buffer (tramp-buffer-name vec)) @@ -130,6 +128,12 @@ When called interactively, a Tramp connection has to be selected." (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))) + ;; Flush file cache. + (tramp-flush-directory-properties vec "") + + ;; Flush connection cache. + (tramp-flush-connection-properties vec) + ;; The end. (run-hook-with-args 'tramp-cleanup-connection-hook vec))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 85f2807616..526c564ee3 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1731,8 +1731,7 @@ a downcased host name only." (list t ;; handled. nil ;; no abort of D-Bus. - (with-tramp-connection-property - (tramp-get-connection-process v) message + (with-tramp-connection-property (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether ;; to accept an unknown host signature or certificate. @@ -1946,8 +1945,7 @@ a downcased host name only." (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) (while (tramp-gvfs-connection-mounted-p vec) (read-event nil nil 0.1)) - (tramp-flush-connection-properties vec) - (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 06dca31227..c770e3ce40 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1539,7 +1539,7 @@ of." (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (tramp-send-command-and-check vec "selinuxenabled"))) (defun tramp-sh-handle-file-selinux-context (filename) @@ -1588,7 +1588,7 @@ of." (defun tramp-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (tramp-send-command-and-check vec "getfacl /"))) (defun tramp-sh-handle-file-acl (filename) @@ -3580,23 +3580,29 @@ STDERR can also be a file name." remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize ;; process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) - (not (with-tramp-connection-property v vc-bzr-program - (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) + (when (and + (memq 'Bzr vc-handled-backends) + (not (and + (bound-and-true-p vc-bzr-program) + (with-tramp-connection-property v vc-bzr-program + (tramp-find-executable + v vc-bzr-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) - (not (with-tramp-connection-property v vc-git-program - (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) + (when (and + (memq 'Git vc-handled-backends) + (not (and + (bound-and-true-p vc-git-program) + (with-tramp-connection-property v vc-git-program + (tramp-find-executable + v vc-git-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) - (not (with-tramp-connection-property v vc-hg-program - (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) + (when (and + (memq 'Hg vc-handled-backends) + (not (and + (bound-and-true-p vc-hg-program) + (with-tramp-connection-property v vc-hg-program + (tramp-find-executable + v vc-hg-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Hg vc-handled-backends))) ;; Run. (tramp-with-demoted-errors @@ -4290,11 +4296,15 @@ process to set up. VEC specifies the connection." ;; connection properties. We start again with ;; `tramp-maybe-open-connection', it will be caught there. (tramp-message vec 5 "Checking system information") - (let ((old-uname (tramp-get-connection-property vec "uname" nil)) - (uname - (tramp-set-connection-property - vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (let* ((old-uname (tramp-get-connection-property vec "uname" nil)) + (uname + ;; If we are in `make-process', we don't need to recompute. + (if (and old-uname + (tramp-get-connection-property vec "process-name" nil)) + old-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))) (when (and (stringp old-uname) (not (string-equal old-uname uname))) (tramp-message vec 3 @@ -5053,7 +5063,7 @@ connection if a previous connection has died for some reason." ;; we cannot use `tramp-get-connection-process'. (tmpfile (with-tramp-connection-property - (get-process (tramp-buffer-name vec)) "temp-file" + (tramp-get-process vec) "temp-file" (make-temp-name (expand-file-name tramp-temp-name-prefix @@ -5426,7 +5436,7 @@ Nonexistent directories are removed from spec." ;; cache the result for the session only. Otherwise, the ;; result is cached persistently. (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) + (tramp-get-process vec) vec) "remote-path" (let* ((remote-path (copy-tree tramp-remote-path)) @@ -5945,10 +5955,9 @@ the length of the file to be compressed. If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) (> size tramp-inline-compress-start-size)) - (with-tramp-connection-property (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil)))) + (tramp-get-connection-property (tramp-get-process vec) prop nil)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -5966,11 +5975,9 @@ function cell is returned to be applied on a buffer." ;; no inline coding is found. (ignore-errors (let ((coding - (with-tramp-connection-property - (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil))) + (tramp-get-connection-property (tramp-get-process vec) prop nil))) (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 100ddfaa68..d361db483a 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1845,7 +1845,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and (process-live-p (tramp-get-connection-process vec)) (tramp-get-connection-property vec "posix" t)) (with-tramp-connection-property - (tramp-get-connection-process vec) "cifs-capabilities" + (tramp-get-process vec) "cifs-capabilities" (save-match-data (when (tramp-smb-send-command vec "posix") (with-current-buffer (tramp-get-connection-buffer vec) @@ -1862,8 +1862,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; When we are not logged in yet, we return nil. (if (and (tramp-smb-get-share vec) (process-live-p (tramp-get-connection-process vec))) - (with-tramp-connection-property - (tramp-get-connection-process vec) "stat-capability" + (with-tramp-connection-property (tramp-get-process vec) "stat-capability" (tramp-smb-send-command vec "stat \"/\"")))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index b6861ba788..68e68a242c 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -373,7 +373,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) (defun tramp-sudoedit-handle-file-acl (filename) @@ -478,7 +478,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (zerop (tramp-call-process vec "selinuxenabled")))) (defun tramp-sudoedit-handle-file-selinux-context (filename) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3ce2225cb8..e30f27fd33 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -37,7 +37,7 @@ ;; For more detailed instructions, please see the info file. ;; ;; Notes: -;; ----- +;; ------ ;; ;; Also see the todo list at the bottom of this file. ;; @@ -46,6 +46,7 @@ ;; ;; There's a mailing list for this, as well. Its name is: ;; tramp-devel@gnu.org + ;; You can use the Web to subscribe, under the following URL: ;; https://lists.gnu.org/mailman/listinfo/tramp-devel ;; @@ -1631,6 +1632,15 @@ from the default one." (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec))) +(defun tramp-get-process (vec-or-proc) + "Get the default connection process to be used for VEC-OR-PROC. +Return `tramp-cache-undefined' in case it doesn't exist." + (or (and (tramp-file-name-p vec-or-proc) + (get-buffer-process (tramp-buffer-name vec-or-proc))) + (and (processp vec-or-proc) + (tramp-get-process (process-get vec-or-proc 'vector))) + tramp-cache-undefined)) + (defun tramp-get-connection-process (vec) "Get the connection process to be used for VEC. In case a second asynchronous communication has been started, it is different