commit 575c3beb4c001687ce7a4581de005a16d6f2e081 (HEAD, refs/remotes/origin/master) Author: Juri Linkov Date: Tue Apr 5 23:08:48 2022 +0300 Allow completion wrapping in minibuffer completion navigation commands * lisp/minibuffer.el (minibuffer-previous-completion) (minibuffer-next-completion): Don't set completion-wrap-movement. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 8a0e15ce05..c79c5a7a5d 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -4360,19 +4360,17 @@ and execute the forms." "Run `previous-completion' from the minibuffer in its completions window." (interactive "p") (with-minibuffer-completions-window - (let ((completion-wrap-movement nil)) - (when completions-highlight-face - (setq-local cursor-face-highlight-nonselected-window t)) - (previous-completion n)))) + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (previous-completion n))) (defun minibuffer-next-completion (&optional n) "Run `next-completion' from the minibuffer in its completions window." (interactive "p") (with-minibuffer-completions-window - (let ((completion-wrap-movement nil)) - (when completions-highlight-face - (setq-local cursor-face-highlight-nonselected-window t)) - (next-completion n)))) + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (next-completion n))) (defun minibuffer-choose-previous-completion (&optional n) "Run `previous-completion' from the minibuffer in its completions window. commit 0e37fa7ed694c22fcfd8bfb5004c64eb0cbd13f8 Author: Glenn Morris Date: Tue Apr 5 12:45:59 2022 -0700 * test/lisp/ses-tests.el: Require ert-x, for ert-simulate-keys. diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index b60ddeea78..2d58e38898 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (require 'ses) ;; Silence byte-compiler. commit 4e2c70272f4fbb686fd9aa4168b058ca1ad6f922 Author: Juri Linkov Date: Tue Apr 5 22:20:16 2022 +0300 New commands for navigating completions from the minibuffer. * lisp/simple.el (minibuffer-local-shell-command-map): * lisp/minibuffer.el (minibuffer-local-completion-map): Bind "M-" to minibuffer-choose-previous-completion, "M-" to minibuffer-choose-next-completion, "M-S-" to minibuffer-previous-completion, "M-S-" to minibuffer-next-completion, "M-RET" to minibuffer-choose-completion. (with-minibuffer-completions-window): New macro. (minibuffer-previous-completion, minibuffer-next-completion) (minibuffer-choose-previous-completion) (minibuffer-choose-next-completion) (minibuffer-choose-completion): New commands. https://lists.gnu.org/archive/html/emacs-devel/2022-03/msg00335.html diff --git a/etc/NEWS b/etc/NEWS index b567caedb3..6b7bb7a18e 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -601,6 +601,17 @@ value. ** Minibuffer and Completions +*** New commands for navigating completions from the minibuffer. +When the minibuffer is the current buffer, typing 'M-' or +'M-' selects a previous/next completion candidate from the +"*Completions*" buffer and inserts it to the minibuffer. +'M-S-' and 'M-S-' do the same, but without inserting +a completion candidate to the minibuffer, then 'M-RET' can be used +to choose the currently active candidate from the "*Completions*" +buffer and exit the minibuffer. With a prefix argument, 'C-u M-RET' +inserts the currently active candidate to the minibuffer, but doesn't +exit the minibuffer. + +++ *** The "*Completions*" buffer can now be automatically selected. To enable this behavior, customize the user option diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 393555fc62..8a0e15ce05 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2748,7 +2748,12 @@ The completion method is determined by `completion-at-point-functions'." "?" #'minibuffer-completion-help "" #'switch-to-completions "M-v" #'switch-to-completions - "M-g M-c" #'switch-to-completions) + "M-g M-c" #'switch-to-completions + "M-" #'minibuffer-choose-previous-completion + "M-" #'minibuffer-choose-next-completion + "M-S-" #'minibuffer-previous-completion + "M-S-" #'minibuffer-next-completion + "M-RET" #'minibuffer-choose-completion) (defvar-keymap minibuffer-local-must-match-map :doc "Local keymap for minibuffer input with completion, for exact match." @@ -4338,6 +4343,64 @@ the minibuffer was activated, and execute the forms." (with-minibuffer-selected-window (scroll-other-window-down arg))) +(defmacro with-minibuffer-completions-window (&rest body) + "Execute the forms in BODY from the minibuffer in its completions window. +When used in a minibuffer window, select the window with completions, +and execute the forms." + (declare (indent 0) (debug t)) + `(let ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) + (when window + (with-selected-window window + ,@body)))) + +(defun minibuffer-previous-completion (&optional n) + "Run `previous-completion' from the minibuffer in its completions window." + (interactive "p") + (with-minibuffer-completions-window + (let ((completion-wrap-movement nil)) + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (previous-completion n)))) + +(defun minibuffer-next-completion (&optional n) + "Run `next-completion' from the minibuffer in its completions window." + (interactive "p") + (with-minibuffer-completions-window + (let ((completion-wrap-movement nil)) + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (next-completion n)))) + +(defun minibuffer-choose-previous-completion (&optional n) + "Run `previous-completion' from the minibuffer in its completions window. +Also insert the selected completion to the minibuffer." + (interactive "p") + (minibuffer-previous-completion n) + (minibuffer-choose-completion t t)) + +(defun minibuffer-choose-next-completion (&optional n) + "Run `next-completion' from the minibuffer in its completions window. +Also insert the selected completion to the minibuffer." + (interactive "p") + (minibuffer-next-completion n) + (minibuffer-choose-completion t t)) + +(defun minibuffer-choose-completion (&optional no-exit no-quit) + "Run `choose-completion' from the minibuffer in its completions window. +With prefix argument NO-EXIT, insert the completion at point to the +minibuffer, but don't exit the minibuffer. When the prefix argument +is not provided, then whether to exit the minibuffer depends on the value +of `completion-no-auto-exit'. +If NO-QUIT is non-nil, insert the completion at point to the +minibuffer, but don't quit the completions window." + (interactive "P") + (with-minibuffer-completions-window + (let ((completion-use-base-affixes t)) + (choose-completion nil no-exit no-quit)))) + (defcustom minibuffer-default-prompt-format " (default %s)" "Format string used to output \"default\" values. When prompting for input, there will often be a default value, diff --git a/lisp/simple.el b/lisp/simple.el index 5bf1c32e1d..ef52006501 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -3892,6 +3892,11 @@ to the end of the list of defaults just after the default value." (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) (define-key map "\t" 'completion-at-point) + (define-key map [M-up] 'minibuffer-choose-previous-completion) + (define-key map [M-down] 'minibuffer-choose-next-completion) + (define-key map [M-S-up] 'minibuffer-previous-completion) + (define-key map [M-S-down] 'minibuffer-next-completion) + (define-key map [?\M-\r] 'minibuffer-choose-completion) map) "Keymap used for completing shell commands in minibuffer.") commit 7aaffe25eb178f69027fb0af844a89a86db4b1f2 Author: Juri Linkov Date: Tue Apr 5 21:54:11 2022 +0300 Use base prefix and suffix instead of completion-base-position (bug#49931) * lisp/minibuffer.el (minibuffer-completion-help): Set completion-base-affixes from base-prefix and base-suffix. In completion-list-insert-choice-function handle string values of start/end as prefix/suffix. * lisp/simple.el (completion-base-affixes) (completion-use-base-affixes): New variables. (choose-completion): Let-bind base-affixes to completion-base-affixes. Use base-affixes when completion-use-base-affixes is non-nil. (completion-setup-function): Sync values of base-affixes and completion-base-affixes. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 5ad44a7a2d..393555fc62 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2284,6 +2284,9 @@ variables.") (let* ((last (last completions)) (base-size (or (cdr last) 0)) (prefix (unless (zerop base-size) (substring string 0 base-size))) + (base-prefix (buffer-substring (minibuffer--completion-prompt-end) + (+ start base-size))) + (base-suffix (buffer-substring (point) (point-max))) (all-md (completion--metadata (buffer-substring-no-properties start (point)) base-size md @@ -2375,20 +2378,28 @@ variables.") ;; completion-all-completions does not give us the ;; necessary information. end)) + (setq-local completion-base-affixes + (list base-prefix base-suffix)) (setq-local 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) + (if (and (stringp start) (stringp end)) + (progn + (delete-minibuffer-contents) + (insert start choice) + ;; Keep point after completion before suffix + (save-excursion (insert end))) + (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) diff --git a/lisp/simple.el b/lisp/simple.el index e49a0ff0f6..5bf1c32e1d 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9119,6 +9119,16 @@ Its value is a list of the form (START END) where START is the place where the completion should be inserted and END (if non-nil) is the end of the text to replace. If END is nil, point is used instead.") +(defvar completion-base-affixes nil + "Base context of the text corresponding to the shown completions. +This variable is used in the *Completions* buffer. +Its value is a list of the form (PREFIX SUFFIX) where PREFIX is the text +before the place where completion should be inserted, and SUFFIX is the text +after the completion.") + +(defvar completion-use-base-affixes nil + "Non-nil means to restore original prefix and suffix in the minibuffer.") + (defvar completion-list-insert-choice-function #'completion--replace "Function to use to insert the text chosen in *Completions*. Called with three arguments (BEG END TEXT), it should replace the text @@ -9245,6 +9255,7 @@ minibuffer, but don't quit the completions window." (with-current-buffer (window-buffer (posn-window (event-start event))) (let ((buffer completion-reference-buffer) (base-position completion-base-position) + (base-affixes completion-base-affixes) (insert-function completion-list-insert-choice-function) (completion-no-auto-exit (if no-exit t completion-no-auto-exit)) (choice @@ -9270,7 +9281,8 @@ minibuffer, but don't quit the completions window." (with-current-buffer buffer (choose-completion-string choice buffer - (or base-position + (or (and completion-use-base-affixes base-affixes) + base-position ;; If all else fails, just guess. (list (choose-completion-guess-base-position choice))) insert-function))))) @@ -9424,9 +9436,11 @@ Called from `temp-buffer-show-hook'." (buffer-substring (minibuffer-prompt-end) (point))))))) (with-current-buffer standard-output (let ((base-position completion-base-position) + (base-affixes completion-base-affixes) (insert-fun completion-list-insert-choice-function)) (completion-list-mode) (setq-local completion-base-position base-position) + (setq-local completion-base-affixes base-affixes) (setq-local completion-list-insert-choice-function insert-fun)) (setq-local completion-reference-buffer mainbuf) (if base-dir (setq default-directory base-dir)) commit 6a50ff10f7aadb1ec0daee9081df66215369553b Author: Juri Linkov Date: Tue Apr 5 21:21:42 2022 +0300 Choosing a completion with a prefix argument doesn't exit the minibuffer * lisp/simple.el (choose-completion): New optional args NO-EXIT and NO-QUIT. (bug#47417) diff --git a/etc/NEWS b/etc/NEWS index 640e18c6bd..b567caedb3 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -645,6 +645,11 @@ When this user option names a face, the current candidate in the "*Completions*" buffer is highlighted with that face. The nil value disables this highlighting. +*** Choosing a completion with a prefix argument doesn't exit the minibuffer. +This means that typing 'C-u RET' on a completion candidate in the +"*Completions*" buffer inserts the completion to the minibuffer, +bot doesn't exit the minibuffer. + ** Isearch and Replace +++ diff --git a/lisp/simple.el b/lisp/simple.el index 7918767a75..e49a0ff0f6 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9229,10 +9229,16 @@ backward)." (when (/= 0 n) (switch-to-minibuffer)))) -(defun choose-completion (&optional event) +(defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. -If EVENT, use EVENT's position to determine the starting position." - (interactive (list last-nonmenu-event)) +If EVENT, use EVENT's position to determine the starting position. +With prefix argument NO-EXIT, insert the completion at point to the +minibuffer, but don't exit the minibuffer. When the prefix argument +is not provided, then whether to exit the minibuffer depends on the value +of `completion-no-auto-exit'. +If NO-QUIT is non-nil, insert the completion at point to the +minibuffer, but don't quit the completions window." + (interactive (list last-nonmenu-event current-prefix-arg)) ;; In case this is run via the mouse, give temporary modes such as ;; isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) @@ -9240,6 +9246,7 @@ If EVENT, use EVENT's position to determine the starting position." (let ((buffer completion-reference-buffer) (base-position completion-base-position) (insert-function completion-list-insert-choice-function) + (completion-no-auto-exit (if no-exit t completion-no-auto-exit)) (choice (save-excursion (goto-char (posn-point (event-start event))) @@ -9257,7 +9264,8 @@ If EVENT, use EVENT's position to determine the starting position." (unless (buffer-live-p buffer) (error "Destination buffer is dead")) - (quit-window nil (posn-window (event-start event))) + (unless no-quit + (quit-window nil (posn-window (event-start event)))) (with-current-buffer buffer (choose-completion-string commit ab9c28e01fd6dd01cb192e2e69ed060fba2482a4 Author: Juri Linkov Date: Tue Apr 5 20:52:28 2022 +0300 * test/lisp/replace-tests.el: New tests for query-replace (bug#54733) * test/lisp/replace-tests.el (query-replace-tests): New defconst. (query-replace--perform-tests): New function. (query-replace-tests, query-replace-search-function-tests): New ert-deftest. diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index 5ba11ed0d5..364e1f8b1d 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -405,6 +405,72 @@ Each element has the format: (and (buffer-name temp-buffer) (kill-buffer temp-buffer))))) + +;;; General tests for `query-replace' and `query-replace-regexp'. + +(defconst query-replace-tests + '( + ;; query-replace + ("aaa" "M-% a RET 1 RET !" "111") + ("aaa" "M-% a RET 1 RET y n y" "1a1") + ;; Empty inputs + ("aaa" "M-% a RET RET !" "") + ("aaa" "M-% RET 1 RET !" "1a1a1a") + ;; Reuse the previous default + ("aaa" "M-% a RET 1 RET . M-% RET !" "111") + + ;; query-replace-regexp + ("aaa" "C-M-% a* RET 1 RET !" "1") + ;; Empty inputs + ("aaa" "C-M-% a* RET RET !" "") + ("aaa" "C-M-% RET 1 RET !" "1a1a1a") + ;; Empty matches + ("aaa" "C-M-% b* RET 1 RET !" "1a1a1a") + ;; Complete matches + ("aaa" "C-M-% .* RET 1 RET !" "1") + ;; Adjacent matches + ("abaab" "C-M-% ab* RET 12 RET !" "121212") + + )) + +(defun query-replace--perform-tests (tests) + (with-temp-buffer + (save-window-excursion + ;; `execute-kbd-macro' is applied to window only + (set-window-buffer nil (current-buffer)) + (dolist (case tests) + ;; Ensure empty input means empty string to replace: + (setq query-replace-defaults nil) + (delete-region (point-min) (point-max)) + (insert (nth 0 case)) + (goto-char (point-min)) + (execute-kbd-macro (kbd (nth 1 case))) + (should (equal (buffer-string) (nth 2 case))))))) + +(ert-deftest query-replace-tests () + (query-replace--perform-tests query-replace-tests)) + +(ert-deftest query-replace-search-function-tests () + (let* ((replace-re-search-function #'re-search-forward)) + (query-replace--perform-tests query-replace-tests)) + + (let* ((pairs '((1 . 2) (3 . 4))) + (replace-re-search-function + (lambda (string &optional _bound noerror count) + (let (found) + (while (and (not found) pairs) + (goto-char (caar pairs)) + (when (re-search-forward string (cdar pairs) noerror count) + (setq found t)) + (pop pairs)) + found))) + (tests + '( + ;; FIXME: this test should pass after fixing bug#54733: + ;; ("aaaa" "C-M-% .* RET 1 RET !" "1a1a") + ))) + (query-replace--perform-tests tests))) + ;;; Tests for `query-replace' undo feature. commit fef5f9ef5f1e4b8458d1bb19df45b7925d431528 Author: Robert Pluim Date: Tue Apr 5 18:12:59 2022 +0200 ; * admin/notes/emba: Fix typos diff --git a/admin/notes/emba b/admin/notes/emba index 90a9c9cc3c..4c8c27dfea 100644 --- a/admin/notes/emba +++ b/admin/notes/emba @@ -33,11 +33,11 @@ The Emacs jobset is defined in the Emacs source tree, file 'test/infra'. They could be adapted for every Emacs branch, see . -Only branches which name start with 'master', 'emacs', 'feature', or +Only branches whose name starts with 'master', 'emacs', 'feature', or 'fix' are considered. This is declared in the workflow rules of file 'test/infra/gitlab-ci.yml'. -A jobset on Gitlab is called pipeline. Emacs pipelines run through +A jobset on Gitlab is called a pipeline. Emacs pipelines run through the stages 'build-images', 'platform-images' and 'native-comp-images' (create an Emacs instance by 'make bootstrap' with different configuration parameters) as well as 'normal', 'platforms' and @@ -46,11 +46,11 @@ configuration parameters) as well as 'normal', 'platforms' and The jobs for stage 'normal' are contained in the file 'test/infra/test-jobs.yml'. This file is generated by calling 'make -C test generate-test-jobs' in the Emacs source tree, and the -resulting file shall be pushed to the Emacs git repository afterwards. +resulting file should be pushed to the Emacs git repository afterwards. Every job runs in a Debian docker container. It uses the local clone of the Emacs git repository to perform a bootstrap and test of Emacs. -This could happen for several jobs with changed configuration, compile +This could happen for several jobs with changed configuration, compile, and test parameters. The 'build-image-*' jobs of the different '*-images' stages run only commit 0e9420bc8ff2a9ff9dc7b3c032f8db1c7cc01b41 Author: Robert Pluim Date: Tue Mar 1 15:24:08 2022 +0100 Reject invalid time-string in appt-add immediately * lisp/calendar/appt.el (appt-add): Check the provided time-string for validity immediately after reading it rather than after reading all the parameters. (Bug#54210) diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index ebdafb438e..a7d13cff9a 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -510,9 +510,13 @@ The time should be in either 24 hour format or am/pm format. Optional argument WARNTIME is an integer (or string) giving the number of minutes before the appointment at which to start warning. The default is `appt-message-warning-time'." - (interactive "sTime (hh:mm[am/pm]): \nsMessage: \n\ -sMinutes before the appointment to start warning: ") - (unless (string-match appt-time-regexp time) + (interactive (list (let ((time (read-string "Time (hh:mm[am/pm]): "))) + (unless (string-match-p appt-time-regexp time) + (user-error "Unacceptable time-string")) + time) + (read-string "Message: ") + (read-string "Minutes before the appointment to start warning: "))) + (unless (string-match-p appt-time-regexp time) (user-error "Unacceptable time-string")) (and (stringp warntime) (setq warntime (unless (string-equal warntime "") commit e48ac2e2040cf0dd628b7fee6991a1738ceb2349 Author: Michael Albinus Date: Tue Apr 5 17:08:03 2022 +0200 Handle remote system processes * doc/lispref/files.texi (Magic File Names): Add list-system-processes and process-attributes. * doc/lispref/processes.texi (System Processes): Document changes in list-system-processes and process-attributes. * doc/misc/tramp.texi (Customizing Completion): Use @ftable. (Remote processes): Document changes in list-system-processes and process-attributes. * etc/NEWS: Document changes in proced, list-system-processes and process-attributes. * lisp/proced.el (proced-show-remote-processes): New defcustom. (proced-remote-directory): Remove. (proced-filter-alist): Use it. (proced-user-name): New defun. (proced-available): Set it to t. (proced-mode): Adapt docstring. (proced): Adapt docstring. Acknowledge prefix argument. (proced-format): Change initialization of `standard-attributes'. (proced-send-signal, proced-renice): Adapt docstring. Remove special handling of prefix argument. * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist): * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist): * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist): * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist): * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist): * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist): * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist): * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist): Add 'list-system-processes' and `process-attributes'. * lisp/net/tramp-integration.el (files-x): Require `files-x'. (tramp-bsd-process-attributes-ps-args) (tramp-bsd-process-attributes-ps-format) (tramp-connection-local-bsd-ps-variables) (tramp-busybox-process-attributes-ps-args) (tramp-busybox-process-attributes-ps-format) (tramp-connection-local-busybox-ps-variables): * lisp/net/tramp-adb.el (tramp-adb-connection-local-default-ps-variables): New defconsts. Add them to connection-local variables. * lisp/net/tramp.el (tramp-file-name-for-operation): Add 'list-system-processes' and `process-attributes'. (tramp-process-attributes-ps-args) (tramp-process-attributes-ps-format): New defconsts. (tramp-ps-time, tramp-get-process-attributes) (tramp-handle-list-system-processes) (tramp-handle-process-attributes): New defuns. * src/process.c (Flist_system_processes, Fprocess_attributes): Support remote system processes. (Qlist_system_processes, Qprocess_attributes): Declare symbols. diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 6e59e87d28..d8b55b114a 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -3344,6 +3344,7 @@ first, before handlers for jobs such as remote file access. @code{get-file-buffer}, @code{insert-directory}, @code{insert-file-contents},@* +@code{list-system-processes}, @code{load}, @code{lock-file}, @code{make-auto-save-file-name}, @code{make-directory}, @@ -3352,7 +3353,7 @@ first, before handlers for jobs such as remote file access. @code{make-nearby-temp-file}, @code{make-process}, @code{make-symbolic-link},@* -@code{process-file}, +@code{process-attributes}, @code{process-file}, @code{rename-file}, @code{set-file-acl}, @code{set-file-modes}, @code{set-file-selinux-context}, @code{set-file-times}, @code{set-visited-file-modtime}, @code{shell-command}, @@ -3405,6 +3406,7 @@ first, before handlers for jobs such as remote file access. @code{get-file-buffer}, @code{insert-directory}, @code{insert-file-contents}, +@code{list-system-processes}, @code{load}, @code{lock-file}, @code{make-auto-save-file-name}, @code{make-direc@discretionary{}{}{}tory}, @@ -3413,7 +3415,7 @@ first, before handlers for jobs such as remote file access. @code{make-nearby-temp-file}, @code{make-process}, @code{make-symbolic-link}, -@code{process-file}, +@code{process-attributes}, @code{process-file}, @code{rename-file}, @code{set-file-acl}, @code{set-file-modes}, @code{set-file-selinux-context}, @code{set-file-times}, @code{set-visited-file-modtime}, @code{shell-command}, diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index ffc0f10a78..18f446735b 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2258,9 +2258,8 @@ query flag of all processes is ignored. In addition to accessing and manipulating processes that are subprocesses of the current Emacs session, Emacs Lisp programs can -also access other processes running on the same machine. We call -these @dfn{system processes}, to distinguish them from Emacs -subprocesses. +also access other processes. We call these @dfn{system processes}, to +distinguish them from Emacs subprocesses. Emacs provides several primitives for accessing system processes. Not all platforms support these primitives; on those which don't, @@ -2272,6 +2271,9 @@ system. Each process is identified by its @acronym{PID}, a numerical process ID that is assigned by the OS and distinguishes the process from all the other processes running on the same machine at the same time. + +If @code{default-directory} points to a remote host, processes of that +host are returned. @end defun @defun process-attributes pid @@ -2283,6 +2285,9 @@ attribute @var{key}s that this function can return are listed below. Not all platforms support all of these attributes; if an attribute is not supported, its association will not appear in the returned alist. +If @code{default-directory} points to a remote host, @var{pid} is +regarded as process of that host. + @table @code @item euid The effective user ID of the user who invoked the process. The diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index 526e92aadd..e4a586f817 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -1881,29 +1881,25 @@ Example: The following predefined functions parsing configuration files exist: -@table @asis +@ftable @asis @item @code{tramp-parse-rhosts} -@findex tramp-parse-rhosts This function parses files which are syntactical equivalent to @file{~/.rhosts}. It returns both host names and user names, if specified. @item @code{tramp-parse-shosts} -@findex tramp-parse-shosts This function parses files which are syntactical equivalent to @file{~/.ssh/known_hosts}. Since there are no user names specified in such files, it can return host names only. @item @code{tramp-parse-sconfig} -@findex tramp-parse-sconfig This function returns the host nicknames defined by @option{Host} entries in @file{~/.ssh/config} style files. @item @code{tramp-parse-shostkeys} -@findex tramp-parse-shostkeys SSH2 parsing of directories @file{/etc/ssh2/hostkeys/*} and @file{~/ssh2/hostkeys/*}. Hosts are coded in file names @@ -1911,7 +1907,6 @@ SSH2 parsing of directories @file{/etc/ssh2/hostkeys/*} and are always @code{nil}. @item @code{tramp-parse-sknownhosts} -@findex tramp-parse-sknownhosts Another SSH2 style parsing of directories like @file{/etc/ssh2/knownhosts/*} and @file{~/ssh2/knownhosts/*}. This @@ -1919,26 +1914,22 @@ case, hosts names are coded in file names @file{@var{host-name}.@var{algorithm}.pub}. User names are always @code{nil}. @item @code{tramp-parse-hosts} -@findex tramp-parse-hosts A function dedicated to @file{/etc/hosts} for host names. @item @code{tramp-parse-passwd} -@findex tramp-parse-passwd A function which parses @file{/etc/passwd} for user names. @item @code{tramp-parse-etc-group} -@findex tramp-parse-etc-group A function which parses @file{/etc/group} for group names. @item @code{tramp-parse-netrc} -@findex tramp-parse-netrc A function which parses @file{~/.netrc} and @file{~/.authinfo}-style files. -@end table +@end ftable To keep a custom file with custom data in a custom structure, a custom function has to be provided. This function must meet the following @@ -4047,6 +4038,100 @@ arguments). This does not show the additional shell sugar inspect @value{tramp} @ref{Traces and Profiles, traces}. @end itemize +@findex list-system-processes +@findex process-attributes +The functions @code{list-system-processes} and +@code{process-attributes} return information about processes on the +respective remote host. In order to retrieve this information, they +use the command @command{ps}, driven by the following constants: + +@defvr Constant tramp-process-attributes-ps-args +This is a list of arguments (strings) @command{ps} is called with. +The default value is appropriate for GNU/Linux remote hosts. +@end defvr + +@defvr Constant tramp-process-attributes-ps-format +This is a list of cons cells @code{(@var{key} . @var{type})} for +interpretation of the @command{ps} output. @var{key} is a key used in +the @code{process-attributes} output plus the key @code{pid}, and +@var{type} is the respective value returned by @command{ps}. It can +be + + +@multitable {@bullet{} @code{numberp}} {--- a string of @var{number} width, could contain spaces} +@item @bullet{} @code{numberp} @tab --- a number +@item @bullet{} @code{stringp} @tab --- a string without spaces +@item @bullet{} @var{number} +@tab --- a string of @var{number} width, could contain spaces +@item @bullet{} @code{nil} @tab --- a string until end of line +@end multitable + +The default value is appropriate for GNU/Linux remote hosts. +@end defvr + +If, for example, @code{tramp-process-attributes-ps-args} is declared +as @code{("-eww" "-o" "pid,euid,euser,egid,egroup,comm:40,state")}, +the output of the respective @command{ps} command would look like + +@smallexample +@group + PID EUID EUSER EGID EGROUP COMMAND S + 1 0 root 0 root systemd S + 1610 0 root 0 root NFSv4 callback S + @dots{} +@end group +@end smallexample + +The corresponding @code{tramp-process-attributes-ps-format} has the value + +@smallexample +@group +@code{((pid . numberp) (euid . numberp) (user . stringp) + (egid . numberp) (group . stringp) (comm . 40) (state . stringp))} +@end group +@end smallexample + +@vindex tramp-adb-connection-local-default-ps-profile +@vindex tramp-adb-connection-local-default-ps-variables +@vindex tramp-connection-local-bsd-ps-profile +@vindex tramp-connection-local-bsd-ps-variables +@vindex tramp-connection-local-busybox-ps-profile +@vindex tramp-connection-local-busybox-ps-variables +The default values for @code{tramp-process-attributes-ps-args} and +@code{tramp-process-attributes-ps-format} can be overwritten by +connection-local variables. +@ifinfo +@xref{Connection Variables, , , emacs}. +@end ifinfo +This is already done by @value{tramp} for the @option{adb} method, see +@code{tramp-adb-connection-local-default-ps-profile} and +@code{tramp-adb-connection-local-default-ps-variables}. + +There are two further predefined sets of connection-local variables +for remote BSD systems, and for a remote @command{ps} command +implemented with @command{busybox}. These are called +@code{tramp-connection-local-bsd-ps-profile}, +@code{tramp-connection-local-bsd-ps-variables}, +@code{tramp-connection-local-busybox-ps-profile}, and +@code{tramp-connection-local-busybox-ps-variables}. Use them +like + +@lisp +@group +(connection-local-set-profiles + '(:application tramp :machine "mybsdhost") + 'tramp-connection-local-bsd-ps-profile) +@end group +@end lisp + +@cindex proced +@vindex proced-show-remote-processes +If you want to see a listing of remote system processes when calling +@code{proced}, set user option @code{proced-show-remote-processes} to +non-@code{nil}, or invoke that command with a negative argument like +@kbd{C-u - M-x proced @key{RET}} when your buffer has a remote +@code{default-directory}. + @anchor{Improving performance of asynchronous remote processes} @subsection Improving performance of asynchronous remote processes diff --git a/etc/NEWS b/etc/NEWS index f81d194a2f..640e18c6bd 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1175,11 +1175,12 @@ modes to emulate the behavior of the historical editor Twenex Emacs. It is believed to no longer be useful. --- -** proced.el supports sending signals to local processes with root permissions. -When typing 'C-u k' or 'C-u r', sending a signal to or renicing of a -local process will use alternative credentials. The credentials to be -used can be customised by the user option 'proced-remote-directory', -which defaults to "/sudo::". 'proced-signal-function' has been marked obsolete. +** proced.el shows system processes of remote hosts. +When 'default-directory' is remote, and 'proced' is invoked with a +negative argument like 'C-u - proced', the system processes of that +remote host are shown. Alternatively, the user option +'proced-show-remote-processes' can be set to non-nil. +'proced-signal-function' has been marked obsolete. * New Modes and Packages in Emacs 29.1 @@ -1855,6 +1856,24 @@ deliver the signal. This allows Tramp to send the signal to remote asynchronous processes. The hitherto existing implementation has been moved to 'signal-default-interrupt-process'. ++++ +** 'list-system-processes' returns remote process IDs now. +This happens, when the current buffer's 'default-directory' is +remote. In order to preserve the old behavior, apply + + (let ((default-directory temporary-file-directory)) + (list-system-processes)) + ++++ +** 'process-attributes' expects a remote process ID now. +When current buffer's 'default-directory' is remote, the PID argument +of 'process-attributes' is regarded as a remote process ID. In order +to preserve the old behavior, apply + + (let ((default-directory temporary-file-directory)) + (process-attributes pid)) + + * Changes in Emacs 29.1 on Non-Free Operating Systems diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index ab20185d5a..d897594f8d 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -159,6 +159,7 @@ It is used for TCP/IP devices." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -168,6 +169,7 @@ It is used for TCP/IP devices." (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) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) (set-file-acl . ignore) @@ -1368,10 +1370,29 @@ connection if a previous connection has died for some reason." 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) +(defconst tramp-adb-connection-local-default-ps-variables + '((tramp-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ((user . string) + (pid . number) + (ppid . number) + (vsize . number) + (rss . number) + (wchan . string) ; ?? + (pc . string) ; ?? + (state . string) + (args . nil)))) + "Default connection-local ps variables for remote adb connections.") + +(connection-local-set-profile-variables + 'tramp-adb-connection-local-default-ps-profile + tramp-adb-connection-local-default-ps-variables) + (with-eval-after-load 'shell (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) - 'tramp-adb-connection-local-default-shell-profile)) + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-profile)) ;; `shell-mode' tries to open remote files like "/adb::~/.history". ;; This fails, because the tilde cannot be expanded. Tell diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 890c8dbb75..7f4eca3f7c 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -267,6 +267,7 @@ It must be supported by libarchive(3).") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-archive-handle-load) (lock-file . ignore) (make-auto-save-file-name . ignore) @@ -276,6 +277,7 @@ It must be supported by libarchive(3).") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-archive-handle-not-implemented) (set-file-acl . ignore) diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index fb3ba08bb1..ca7bcf35ce 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -209,6 +209,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-crypt-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -218,6 +219,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-crypt-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index d6120d2bee..752dfdb068 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -796,6 +796,7 @@ It has been changed in GVFS 1.14.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -805,6 +806,7 @@ It has been changed in GVFS 1.14.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 3b2e7c0f91..089093a420 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -28,6 +28,7 @@ ;;; Code: (require 'tramp-compat) +(require 'files-x) ;; Pacify byte-compiler. (require 'cl-lib) @@ -285,9 +286,11 @@ NAME must be equal to `tramp-current-connection'." 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(connection-local-set-profiles +(apply + #'connection-local-set-profiles '(:application tramp) - 'tramp-connection-local-default-system-profile) + (cons 'tramp-connection-local-default-system-profile + (connection-local-get-profiles '(:application tramp)))) (defconst tramp-connection-local-default-shell-variables '((shell-file-name . "/bin/sh") @@ -299,9 +302,138 @@ NAME must be equal to `tramp-current-connection'." tramp-connection-local-default-shell-variables) (with-eval-after-load 'shell - (connection-local-set-profiles + (apply + #'connection-local-set-profiles '(:application tramp) - 'tramp-connection-local-default-shell-profile)) + (cons 'tramp-connection-local-default-shell-profile + (connection-local-get-profiles '(:application tramp))))) + +;; Tested with FreeBSD 12.2. +(defconst tramp-bsd-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "user" + "egid" + "egroup" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" + ,(mapconcat + #'identity + '("state" + "ppid" + "pgid" + "sid" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-bsd-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 52) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-bsd-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-bsd-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-bsd-process-attributes-ps-format)) + "Default connection-local ps variables for remote BSD connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-bsd-ps-profile + tramp-connection-local-bsd-ps-variables) + +;; Tested with BusyBox v1.24.1. +(defconst tramp-busybox-process-attributes-ps-args + `("-o" + ,(mapconcat + #'identity + '("pid" + "user" + "group" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "stat=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "tty" + "time" + "nice" + "etime" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-busybox-process-attributes-ps-format + '((pid . number) + (user . string) + (group . string) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (ttname . string) + (time . tramp-ps-time) + (nice . number) + (etime . tramp-ps-time) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-busybox-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-busybox-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-busybox-process-attributes-ps-format)) + "Default connection-local ps variables for remote Busybox connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-busybox-ps-profile + tramp-connection-local-busybox-ps-variables) (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-integration 'force))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 126b09fcbf..bbc7685131 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -123,6 +123,7 @@ ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -132,6 +133,7 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-rclone-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 3ab5e4d169..a8f265223f 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1005,6 +1005,7 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -1014,6 +1015,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (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) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sh-handle-process-file) (rename-file . tramp-sh-handle-rename-file) (set-file-acl . tramp-sh-handle-set-file-acl) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index db6b0fc174..4af5a4204f 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -274,6 +274,7 @@ See `tramp-actions-before-shell' for more info.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -283,6 +284,7 @@ See `tramp-actions-before-shell' for more info.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) (set-file-acl . tramp-smb-handle-set-file-acl) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 9dcb6259fb..02c0da3f18 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -126,6 +126,7 @@ ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-sshfs-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -135,6 +136,7 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sshfs-handle-process-file) (rename-file . tramp-sshfs-handle-rename-file) (set-file-acl . ignore) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 242a6c7f58..fb885ebd05 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -117,6 +117,7 @@ See `tramp-actions-before-shell' for more info.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -126,6 +127,7 @@ See `tramp-actions-before-shell' for more info.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-sudoedit-handle-rename-file) (set-file-acl . tramp-sudoedit-handle-set-file-acl) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index bddbe3f91a..1f429edf4f 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2599,7 +2599,9 @@ Must be handled by the callers." '(make-nearby-temp-file process-file shell-command start-file-process temporary-file-directory ;; Emacs 27+ only. - exec-path make-process)) + exec-path make-process + ;; Emacs 29+ only. + list-system-processes process-attributes)) default-directory) ;; PROC. ((member operation '(file-notify-rm-watch file-notify-valid-p)) @@ -4001,6 +4003,155 @@ Let-bind it when necessary.") ;; Result. (cons filename (cdr result))))) +(defun tramp-ps-time () + "Read printed time oif \"ps\" in format \"[[DD-]hh:]mm:ss\". +Return it as number of seconds. Used in `tramp-process-attributes-ps-format'." + (search-forward-regexp "\\s-+") + (search-forward-regexp + (concat + "\\(?:" "\\(?:" "\\([0-9]+\\)-" "\\)?" + "\\([0-9]+\\):" "\\)?" + "\\([0-9]+\\):" + ;; Seconds can also be a floating point number. + "\\([0-9.]+\\)") + (line-end-position) 'noerror) + (+ (* 24 60 60 (string-to-number (or (match-string 1) "0"))) + (* 60 60 (string-to-number (or (match-string 2) "0"))) + (* 60 (string-to-number (or (match-string 3) "0"))) + (string-to-number (or (match-string 4) "0")))) + +(defconst tramp-process-attributes-ps-args + `("-eww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "euser" + "egid" + "egroup" + "comm:80" + "state" + "ppid" + "pgrp" + "sess" + "tname" + "tpgid" + "min_flt" + "maj_flt" + "times" + "pri" + "nice" + "thcount" + "vsize" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for calling \"ps\". +See `tramp-get-process-attributes'. + +This list is the default value on remote GNU/Linux systems.") + +(defconst tramp-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 80) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . number) + (pri . number) + (nice . number) + (thcount . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist where each element is a cons cell of the form `\(KEY . TYPE)'. +KEY is a key (symbol) used in `process-attributes'. TYPE is the +printed result for KEY of the \"ps\" command, it can be `number', +`string', a number (string of that length), a symbol (a function +to be applied), or nil (for the last column of the \"ps\" output. + +This alist is used to parse the output of calling \"ps\" in +`tramp-get-process-attributes'. + +This alist is the default value on remote GNU/Linux systems.") + +(defun tramp-get-process-attributes (vec) + "Return all process attributes for connection VEC. +Parsing the remote \"ps\" output is controlled by +`tramp-process-attributes-ps-args' and +`tramp-process-attributes-ps-format'. + +It is not guaranteed, that all process attributes as described in +`process-attributes' are returned. The additional attribute +`pid' shall be returned always." + (with-tramp-file-property vec "/" "process-attributes" + (ignore-errors + (with-temp-buffer + (hack-connection-local-variables-apply + (connection-local-criteria-for-default-directory)) + ;; (pop-to-buffer (current-buffer)) + (when (zerop + (apply + #'process-file + "ps" nil t nil tramp-process-attributes-ps-args)) + (let (result res) + (goto-char (point-min)) + (while (not (eobp)) + ;; (tramp-test-message + ;; "%s" (buffer-substring (point) (line-end-position))) + (when (save-excursion + (search-forward-regexp + "[[:digit:]]" (line-end-position) 'noerror)) + (setq res nil) + (dolist (elt tramp-process-attributes-ps-format) + (push + (cons + (car elt) + (cond + ((eq (cdr elt) 'number) (read (current-buffer))) + ((eq (cdr elt) 'string) + (search-forward-regexp "\\S-+") + (match-string 0)) + ((numberp (cdr elt)) + (search-forward-regexp "\\s-+") + (search-forward-regexp ".+" (+ (point) (cdr elt))) + (string-trim (match-string 0))) + ((fboundp (cdr elt)) + (funcall (cdr elt))) + ((null (cdr elt)) + (search-forward-regexp "\\s-+") + (buffer-substring (point) (line-end-position))) + (t nil))) + res)) + ;; `nice' could be `-'. + (setq res (rassq-delete-all '- res)) + (push (append res) result)) + (forward-line)) + ;; Return result. + result)))))) + +(defun tramp-handle-list-system-processes () + "Like `list-system-processes' for Tramp files." + (let ((v (tramp-dissect-file-name default-directory))) + (tramp-flush-file-property v "/" "process-attributes") + (mapcar (lambda (x) (cdr (assq 'pid x))) (tramp-get-process-attributes v)))) + (defun tramp-get-lock-file (file) "Read lockfile info of FILE. Return nil when there is no lockfile." @@ -4407,6 +4558,14 @@ support symbolic links." (tramp-dissect-file-name (expand-file-name linkname)) 'file-error "make-symbolic-link not supported")) +(defun tramp-handle-process-attributes (pid) + "Like `process-attributes' for Tramp files." + (catch 'result + (dolist (elt (tramp-get-process-attributes + (tramp-dissect-file-name default-directory))) + (when (= (cdr (assq 'pid elt)) pid) + (throw 'result elt))))) + (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) diff --git a/lisp/proced.el b/lisp/proced.el index 7966ccfb08..a27638d367 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -51,6 +51,12 @@ :group 'unix :prefix "proced-") +(defcustom proced-show-remote-processes nil + "Whether processes of the remote host shall be shown. +This happens only when `default-directory' is remote." + :version "29.1" + :type 'boolean) + (defcustom proced-signal-function #'signal-process "Name of signal function. It can be an elisp function (usually `signal-process') or a string specifying @@ -59,13 +65,6 @@ the external command (usually \"kill\")." (string :tag "command"))) (make-obsolete-variable 'proced-signal-function "no longer used." "29.1") -(defcustom proced-remote-directory "/sudo::" - "Remote directory to be used when sending a signal. -It must point to the local host, via a `sudo' or `doas' method, -or alike. See `proced-send-signal' and `proced-renice'." - :version "29.1" - :type '(string :tag "remote directory")) - (defcustom proced-renice-command "renice" "Name of renice command." :version "24.3" @@ -279,8 +278,8 @@ It can also be a list of keys appearing in `proced-grammar-alist'." ;; FIXME: is there a better name for filter `user' that does not coincide ;; with an attribute key? (defcustom proced-filter-alist - `((user (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'"))) - (user-running (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'")) + `((user (user . proced-user-name)) + (user-running (user . proced-user-name) (state . "\\`[Rr]\\'")) (all) (all-running (state . "\\`[Rr]\\'")) @@ -370,7 +369,7 @@ May be used to revert the process listing." ;; Internal variables -(defvar proced-available (not (null (list-system-processes))) +(defvar proced-available t;(not (null (list-system-processes))) "Non-nil means Proced is known to work on this system.") (defvar-local proced-process-alist nil @@ -569,6 +568,12 @@ Important: the match ends just after the marker.") :help "Renice Marked Processes"])) ;; helper functions +(defun proced-user-name (user) + "Check the `user' attribute with user name `proced' is running for." + (string-equal user (if (file-remote-p default-directory) + (file-remote-p default-directory 'user) + (user-real-login-name)))) + (defun proced-marker-regexp () "Return regexp matching `proced-marker-char'." ;; `proced-marker-char' must appear in column zero @@ -631,8 +636,6 @@ Type \\[proced] to start a Proced session. In a Proced buffer type \\\\[proced-mark] to mark a process for later commands. Type \\[proced-send-signal] to send signals to marked processes. Type \\[proced-renice] to renice marked processes. -With a prefix argument \\[universal-argument], sending signals to and renicing of processes -will be performed with the credentials of `proced-remote-directory'. The initial content of a listing is defined by the variable `proced-filter' and the variable `proced-format'. @@ -684,8 +687,13 @@ After displaying or updating a Proced buffer, Proced runs the normal hook (defun proced (&optional arg) "Generate a listing of UNIX system processes. \\ -If invoked with optional ARG, do not select the window displaying -the process information. +If invoked with optional non-negative ARG, do not select the +window displaying the process information. + +If `proced-show-remote-processes' is non-nil or the command is +invoked with a negative ARG `\\[universal-argument] \\[negative-argument]', \ +and `default-directory' +points to a remote host, the system processes of that host are shown. This function runs the normal hook `proced-post-display-hook'. @@ -696,6 +704,11 @@ Proced buffers." (error "Proced is not available on this system")) (let ((buffer (get-buffer-create "*Proced*")) new) (set-buffer buffer) + (when (and (file-remote-p default-directory) + (not + (or proced-show-remote-processes + (eq arg '-)))) + (setq default-directory temporary-file-directory)) (setq new (zerop (buffer-size))) (when new (proced-mode) @@ -1413,7 +1426,7 @@ Replace newline characters by \"^J\" (two characters)." ;; If none of the alternatives is non-nil, the attribute is ignored ;; in the listing. (let ((standard-attributes - (car (proced-process-attributes (list (emacs-pid))))) + (car (proced-process-attributes (list-system-processes)))) new-format fmi) (if (and proced-tree-flag (assq 'ppid standard-attributes)) @@ -1773,10 +1786,7 @@ runs the normal hook `proced-after-send-signal-hook'. For backward compatibility SIGNAL and PROCESS-ALIST may be nil. Then PROCESS-ALIST contains the marked processes or the process point is on and SIGNAL is queried interactively. This noninteractive usage is still -supported but discouraged. It will be removed in a future version of Emacs. - -With a prefix argument \\[universal-argument], send the signal with the credentials of -`proced-remote-directory'." +supported but discouraged. It will be removed in a future version of Emacs." (interactive (let* ((process-alist (proced-marked-processes)) (pnum (if (= 1 (length process-alist)) @@ -1818,10 +1828,7 @@ With a prefix argument \\[universal-argument], send the signal with the credenti proced-signal-list nil nil nil nil "TERM")))))) - (let ((default-directory - (if (and current-prefix-arg (stringp proced-remote-directory)) - proced-remote-directory temporary-file-directory)) - failures) + (let (failures) ;; Why not always use `signal-process'? See ;; https://lists.gnu.org/r/emacs-devel/2008-03/msg02955.html (if (functionp proced-signal-function) @@ -1876,10 +1883,7 @@ PROCESS-ALIST is an alist as returned by `proced-marked-processes'. Interactively, PROCESS-ALIST contains the marked processes. If no process is marked, it contains the process point is on, After renicing all processes in PROCESS-ALIST, this command runs -the normal hook `proced-after-send-signal-hook'. - -With a prefix argument \\[universal-argument], apply renice with the credentials of -`proced-remote-directory'." +the normal hook `proced-after-send-signal-hook'." (interactive (let ((process-alist (proced-marked-processes))) (proced-with-processes-buffer process-alist @@ -1888,10 +1892,7 @@ With a prefix argument \\[universal-argument], apply renice with the credentials proced-mode) (if (numberp priority) (setq priority (number-to-string priority))) - (let ((default-directory - (if (and current-prefix-arg (stringp proced-remote-directory)) - proced-remote-directory temporary-file-directory)) - failures) + (let (failures) (dolist (process process-alist) (with-temp-buffer (condition-case nil diff --git a/src/process.c b/src/process.c index e8aafd02d7..d4a78521ab 100644 --- a/src/process.c +++ b/src/process.c @@ -8203,16 +8203,25 @@ DEFUN ("list-system-processes", Flist_system_processes, Slist_system_processes, 0, 0, 0, doc: /* Return a list of numerical process IDs of all running processes. If this functionality is unsupported, return nil. +If `default-directory' is remote, return process IDs of the respective remote host. See `process-attributes' for getting attributes of a process given its ID. */) (void) { + Lisp_Object handler + = Ffind_file_name_handler (BVAR (current_buffer, directory), + Qlist_system_processes); + if (!NILP (handler)) + return call1 (handler, Qlist_system_processes); + return list_system_processes (); } DEFUN ("process-attributes", Fprocess_attributes, Sprocess_attributes, 1, 1, 0, doc: /* Return attributes of the process given by its PID, a number. +If `default-directory' is remote, PID is regarded as process +identifier on the respective remote host. Value is an alist where each element is a cons cell of the form @@ -8263,6 +8272,12 @@ integer or floating point values. args -- command line which invoked the process (string). */) ( Lisp_Object pid) { + Lisp_Object handler + = Ffind_file_name_handler (BVAR (current_buffer, directory), + Qprocess_attributes); + if (!NILP (handler)) + return call2 (handler, Qprocess_attributes, pid); + return system_process_attributes (pid); } @@ -8438,6 +8453,8 @@ void syms_of_process (void) { DEFSYM (Qmake_process, "make-process"); + DEFSYM (Qlist_system_processes, "list-system-processes"); + DEFSYM (Qprocess_attributes, "process-attributes"); #ifdef subprocesses commit 7d504c9acc0c8d75d11c3a2b5e016f39e6156bf8 Author: Po Lu Date: Tue Apr 5 20:03:48 2022 +0800 Mark some data during drag-and-drop It doesn't make sense to prevent the return frame or movement frame from being deleted, but we should at least protect them from garbage collection. * src/alloc.c (garbage_collect): Call mark_xterm. * src/xterm.c (x_dnd_begin_drag_and_drop) (x_dnd_cleanup_drag_and_drop): Clear movement and return frames upon DND completion. (mark_xterm): Mark those frames. * src/xterm.h: Update prototypes. diff --git a/src/alloc.c b/src/alloc.c index 6d91ec3358..733f7733fa 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6196,6 +6196,10 @@ garbage_collect (void) mark_fringe_data (); #endif +#ifdef HAVE_X_WINDOWS + mark_xterm (); +#endif + /* Everything is now marked, except for the data in font caches, undo lists, and finalizers. The first two are compacted by removing an items which aren't reachable otherwise. */ diff --git a/src/xterm.c b/src/xterm.c index 922aafbbdf..b9a5355b41 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -3497,6 +3497,8 @@ x_dnd_cleanup_drag_and_drop (void *frame) #ifdef USE_GTK current_hold_quit = NULL; #endif + x_dnd_return_frame_object = NULL; + x_dnd_movement_frame = NULL; block_input (); /* Restore the old event mask. */ @@ -9528,6 +9530,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, if (x_dnd_use_toplevels) x_dnd_free_toplevels (); + x_dnd_return_frame_object = NULL; + x_dnd_movement_frame = NULL; + FRAME_DISPLAY_INFO (f)->grabbed = 0; #ifdef USE_GTK current_hold_quit = NULL; @@ -9546,6 +9551,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, #ifdef USE_GTK current_hold_quit = NULL; #endif + x_dnd_movement_frame = NULL; /* Restore the old event mask. */ XSelectInput (FRAME_X_DISPLAY (f), @@ -9554,14 +9560,18 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, unblock_input (); - if (x_dnd_return_frame == 3) + if (x_dnd_return_frame == 3 + && FRAME_LIVE_P (x_dnd_return_frame_object)) { x_dnd_return_frame_object->mouse_moved = true; XSETFRAME (action, x_dnd_return_frame_object); + x_dnd_return_frame_object = NULL; return action; } + x_dnd_return_frame_object = NULL; + if (x_dnd_use_toplevels) x_dnd_free_toplevels (); FRAME_DISPLAY_INFO (f)->grabbed = 0; @@ -23015,6 +23025,24 @@ init_xterm (void) } #endif +void +mark_xterm (void) +{ + Lisp_Object val; + + if (x_dnd_return_frame_object) + { + XSETFRAME (val, x_dnd_return_frame_object); + mark_object (val); + } + + if (x_dnd_movement_frame) + { + XSETFRAME (val, x_dnd_movement_frame); + mark_object (val); + } +} + void syms_of_xterm (void) { diff --git a/src/xterm.h b/src/xterm.h index 79dee6a569..4eb16d0c14 100644 --- a/src/xterm.h +++ b/src/xterm.h @@ -1557,6 +1557,8 @@ extern struct frame *x_dnd_frame; struct xi_device_t *xi_device_from_id (struct x_display_info *, int); #endif +extern void mark_xterm (void); + /* Is the frame embedded into another application? */ #define FRAME_X_EMBEDDED_P(f) (FRAME_X_OUTPUT(f)->explicit_parent != 0) commit 91ca41e292184bf0c21b55a8e51f3eb1a8c89bb7 Author: Jimmy Aguilar Mena Date: Tue Apr 5 13:08:36 2022 +0200 Fix some details in completions * lisp/minibuffer.el (completion--insert-one-column) : Remove the extra new-line at the end. * lisp/simple.el (next-completion) : Fix behavior when completion-wrap-movement and remove bobp and eobp. This removes the extra tab ad the end of the list before wrapping or going to the minibuffer and apparently also fixes bug#54374 (switch-to-completions) : Simplify condition code and remove comment not applicable anymore. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index d8df1799c9..5ad44a7a2d 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2044,7 +2044,8 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (when title (insert (format completions-group-format title) "\n"))))) (completion--insert str group-fun) - (insert "\n"))))) + (insert "\n"))) + (delete-char -1))) (defun completion--insert (str group-fun) (if (not (consp str)) diff --git a/lisp/simple.el b/lisp/simple.el index c60abcb1f4..7918767a75 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9179,46 +9179,53 @@ backward)." ((/= prev (point)) (point)) (t prev)))) - (let ((beg (point-min)) (end (point-max))) + + (let ((beg (point-min)) + (end (point-max)) + (tabcommand (member (this-command-keys) '("\t" [backtab]))) + prop) (catch 'bound (while (> n 0) ;; If in a completion, move to the end of it. (when (get-text-property (point) 'mouse-face) (goto-char (next-single-property-change (point) 'mouse-face nil end))) ;; If at the last completion option, wrap or skip to the - ;; minibuffer, if requested. - (when (and completion-wrap-movement (eobp)) - (if (and (member (this-command-keys) '("\t" [backtab])) - completion-auto-select) + ;; minibuffer, if requested. We can't use (eobp) because some + ;; extra text may be after the last candidate: ex: when + ;; completion-detailed + (setq prop (next-single-property-change (point) 'mouse-face nil end)) + (when (and completion-wrap-movement (eq end prop)) + (if (and completion-auto-select tabcommand) (throw 'bound nil) (goto-char (point-min)))) ;; Move to start of next one. (unless (get-text-property (point) 'mouse-face) (goto-char (next-single-property-change (point) 'mouse-face nil end))) (setq n (1- n))) + (while (and (< n 0) (not (bobp))) - (let ((prop (get-text-property (1- (point)) 'mouse-face))) - ;; If in a completion, move to the start of it. - (when (and prop (eq prop (get-text-property (point) 'mouse-face))) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; Move to end of the previous completion. - (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; If at the first completion option, wrap or skip to the - ;; minibuffer, if requested. - (when (and completion-wrap-movement (bobp)) - (if (and (member (this-command-keys) '("\t" [backtab])) - completion-auto-select) - (progn - (goto-char (next-single-property-change (point) 'mouse-face nil end)) - (throw 'bound nil)) - (goto-char (point-max)))) - ;; Move to the start of that one. + (setq prop (get-text-property (1- (point)) 'mouse-face)) + ;; If in a completion, move to the start of it. + (when (and prop (eq prop (get-text-property (point) 'mouse-face))) (goto-char (previous-single-property-change - (point) 'mouse-face nil beg)) - (setq n (1+ n))))) + (point) 'mouse-face nil beg))) + ;; Move to end of the previous completion. + (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg))) + ;; If at the first completion option, wrap or skip to the + ;; minibuffer, if requested. + (setq prop (previous-single-property-change (point) 'mouse-face nil beg)) + (when (and completion-wrap-movement (eq beg prop)) + (if (and completion-auto-select tabcommand) + (progn + (goto-char (next-single-property-change (point) 'mouse-face nil end)) + (throw 'bound nil)) + (goto-char (point-max)))) + ;; Move to the start of that one. + (goto-char (previous-single-property-change + (point) 'mouse-face nil beg)) + (setq n (1+ n)))) (when (/= 0 n) (switch-to-minibuffer)))) @@ -9436,22 +9443,18 @@ select the completion near point.\n\n"))))) (defun switch-to-completions () "Select the completion list window." (interactive) - (let ((window (or (get-buffer-window "*Completions*" 0) - ;; Make sure we have a completions window. - (progn (minibuffer-completion-help) - (get-buffer-window "*Completions*" 0))))) - (when window - (select-window window) + (when-let ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) + (select-window window) + (when (bobp) (cond ((and (memq this-command '(completion-at-point minibuffer-complete)) - (equal (this-command-keys) [backtab]) - (bobp)) + (equal (this-command-keys) [backtab])) (goto-char (point-max)) (previous-completion 1)) - ;; In the new buffer, go to the first completion. - ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. - ((bobp) - (next-completion 1)))))) + (t (next-completion 1)))))) (defun read-expression-switch-to-completions () "Select the completion list window while reading an expression." commit 28b9dcb002ac56d296b48499e6a0ff2617185a08 Author: Po Lu Date: Tue Apr 5 10:33:45 2022 +0000 ; * lisp/term/haiku-win.el: Fix compiler warning on X. diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el index fd0b68b5fc..6f8f9ac519 100644 --- a/lisp/term/haiku-win.el +++ b/lisp/term/haiku-win.el @@ -45,6 +45,7 @@ (defvar haiku-initialized) (defvar haiku-signal-invalid-refs) +(defvar haiku-drag-track-function) (defvar haiku-dnd-selection-value nil "The local value of the special `XdndSelection' selection.") commit be89d888de10964c2195b6e2e6bc26845ad7cebb Author: Po Lu Date: Tue Apr 5 16:19:02 2022 +0800 Allow dropping text to the root window * src/xterm.c (x_dnd_send_unsupported_drop): Allow dropping to the root window. (handle_one_xevent): Send unsupported drops to the last toplevel instead of the target window. diff --git a/src/xterm.c b/src/xterm.c index 77861c3fc0..922aafbbdf 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -2806,7 +2806,10 @@ x_dnd_send_unsupported_drop (struct x_display_info *dpyinfo, Window target_windo XSETFRAME (frame, x_dnd_frame); x_catch_errors (dpyinfo->display); + child = dpyinfo->root_window; + dest_x = root_x; + dest_y = root_y; while (XTranslateCoordinates (dpyinfo->display, child, child, root_x, root_y, &dest_x, @@ -2821,27 +2824,24 @@ x_dnd_send_unsupported_drop (struct x_display_info *dpyinfo, Window target_windo root_y = dest_y; } - if (child != dpyinfo->root_window) - { - x_own_selection (QPRIMARY, Qnil, frame); + x_own_selection (QPRIMARY, Qnil, frame); - event.xbutton.window = child; - event.xbutton.x = dest_x; - event.xbutton.y = dest_y; - event.xbutton.state = 0; - event.xbutton.button = 2; - event.xbutton.same_screen = True; - event.xbutton.time = before + 1; - event.xbutton.time = before + 2; + event.xbutton.window = child; + event.xbutton.x = dest_x; + event.xbutton.y = dest_y; + event.xbutton.state = 0; + event.xbutton.button = 2; + event.xbutton.same_screen = True; + event.xbutton.time = before + 1; + event.xbutton.time = before + 2; - x_set_pending_dnd_time (before); + x_set_pending_dnd_time (before); - XSendEvent (dpyinfo->display, child, - True, ButtonPressMask, &event); - event.xbutton.type = ButtonRelease; - XSendEvent (dpyinfo->display, child, - True, ButtonReleaseMask, &event); - } + XSendEvent (dpyinfo->display, child, + True, ButtonPressMask, &event); + event.xbutton.type = ButtonRelease; + XSendEvent (dpyinfo->display, child, + True, ButtonReleaseMask, &event); x_uncatch_errors (); } @@ -15443,7 +15443,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, else { x_set_pending_dnd_time (event->xbutton.time); - x_dnd_send_unsupported_drop (dpyinfo, x_dnd_last_seen_window, + x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None + ? x_dnd_last_seen_toplevel + : x_dnd_last_seen_window), event->xbutton.x_root, event->xbutton.y_root, event->xbutton.time); } @@ -16605,7 +16607,9 @@ handle_one_xevent (struct x_display_info *dpyinfo, else { x_set_pending_dnd_time (xev->time); - x_dnd_send_unsupported_drop (dpyinfo, x_dnd_last_seen_window, + x_dnd_send_unsupported_drop (dpyinfo, (x_dnd_last_seen_toplevel != None + ? x_dnd_last_seen_toplevel + : x_dnd_last_seen_window), xev->root_x, xev->root_y, xev->time); } }