master f1b4c0aff5: Allow keyboard modifiers to control the action taken during dired DND

[Po Lu]

branch: master
commit f1b4c0aff507e32d0311e04c927b866dcb457ac3
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Allow keyboard modifiers to control the action taken during dired DND
    
    * doc/emacs/dired.texi (Misc Dired Features): Update
    documentation.
    * lisp/dired.el (dired-mouse-drag-files): Update defcustom for
    new values.
    (dired-mouse-drag): Recognize more values of
    `dired-mouse-drag-files' and keyboard modifiers.
    (dired-mouse-drag-files-map): Add C-down-mouse-1, M-down-mouse-1
    and S-down-mouse-1.
---
 doc/emacs/dired.texi |   9 ++--
 lisp/dired.el        | 135 ++++++++++++++++++++++++++++++---------------------
 2 files changed, 87 insertions(+), 57 deletions(-)

diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi
index ed4ff5213f..9e14e0f9a9 100644
--- a/doc/emacs/dired.texi
+++ b/doc/emacs/dired.texi
@@ -1711,6 +1711,9 @@ the originating program.  Dragging files out of a Dired 
buffer is also
 supported, by enabling the user option @code{dired-mouse-drag-files},
 the mouse can be used to drag files onto other programs.  When set to
 @code{link}, it will make the other program (typically a file manager)
-create a symbolic link to the file, and setting it to any other
-non-@code{nil} value will make the other program open or create a copy
-of the file.
+create a symbolic link to the file; when set to @code{move}, it will
+make the other program move the file to a new location, and setting it
+to any other non-@code{nil} value will make the other program open or
+create a copy of the file.  The keyboard modifiers pressed during the
+drag-and-drop operation can also control what action the other program
+takes towards the file.
diff --git a/lisp/dired.el b/lisp/dired.el
index 4d3d93441b..7df50a7b2a 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -259,7 +259,21 @@ files if it was marked).  This feature is supported only 
on X
 Windows, Haiku, and Nextstep (macOS or GNUstep).
 
 If the value is `link', then a symbolic link will be created to
-the file instead by the other program (usually a file manager)."
+the file instead by the other program (usually a file manager).
+
+If the value is `move', then the default action will be for the
+other program to move the file to a different location.  For this
+to work optimally, `auto-revert-mode' should be enabled in the
+Dired buffer.
+
+If the Meta key is held down when the mouse button is pressed,
+then this will always be equivalent to `link'.
+
+If the Control key is held down when the mouse button is pressed,
+then dragging the file will always copy it to the new location.
+
+If the Shift key is held down when the mouse button is pressed,
+then this will always be equivalent to `move'."
   :set (lambda (option value)
          (set-default option value)
          (dolist (buffer (buffer-list))
@@ -267,7 +281,8 @@ the file instead by the other program (usually a file 
manager)."
              (when (derived-mode-p 'dired-mode)
                (revert-buffer nil t)))))
   :type '(choice (const :tag "Don't allow dragging" nil)
-                 (const :tag "Copy file to other window" t)
+                 (const :tag "Copy file to new location" t)
+                 (const :tag "Move file to new location" t)
                  (const :tag "Create symbolic link to file" link))
   :group 'dired
   :version "29.1")
@@ -1717,61 +1732,73 @@ other marked file as well.  Otherwise, unmark all 
files."
   (interactive "e")
   (when mark-active
     (deactivate-mark))
-  (save-excursion
-    (with-selected-window (posn-window (event-end event))
-      (goto-char (posn-point (event-end event))))
-    (track-mouse
-      (let ((beginning-position (mouse-pixel-position))
-            new-event)
-        (catch 'track-again
-          (setq new-event (read-event))
-          (if (not (eq (event-basic-type new-event) 'mouse-movement))
-              (when (eq (event-basic-type new-event) 'mouse-1)
-                (push new-event unread-command-events))
-            (let ((current-position (mouse-pixel-position)))
-              ;; If the mouse didn't move far enough, don't
-              ;; inadvertently trigger a drag.
-              (when (and (eq (car current-position) (car beginning-position))
-                         (ignore-errors
-                           (and (> 3 (abs (- (cadr beginning-position)
-                                             (cadr current-position))))
-                                (> 3 (abs (- (caddr beginning-position)
-                                             (caddr current-position)))))))
-                (throw 'track-again nil)))
-            ;; We can get an error if there's by some chance no file
-            ;; name at point.
-            (condition-case nil
-                (let ((filename (with-selected-window (posn-window
-                                                       (event-end event))
-                                  (let ((marked-files (dired-map-over-marks 
(dired-get-filename
-                                                                             
nil 'no-error-if-not-filep)
-                                                                            
'marked))
-                                        (file-name (dired-get-filename nil 
'no-error-if-not-filep)))
-                                    (if (and marked-files
-                                             (member file-name marked-files))
-                                        marked-files
-                                      (when marked-files
-                                        (dired-map-over-marks (dired-unmark 
nil)
-                                                              'marked))
-                                      file-name)))))
-                  (when filename
-                    (if (and (consp filename)
-                             (cdr filename))
-                        (dnd-begin-drag-files filename nil
-                                              (if (eq dired-mouse-drag-files 
'link)
-                                                  'link 'copy)
-                                              t)
-                      (dnd-begin-file-drag (if (stringp filename)
-                                               filename
-                                             (car filename))
-                                           nil (if (eq dired-mouse-drag-files 
'link)
-                                                   'link 'copy)
-                                           t))))
-              (error (when (eq (event-basic-type new-event) 'mouse-1)
-                       (push new-event unread-command-events))))))))))
+  (let* ((modifiers (event-modifiers event))
+         (action (cond ((memq 'control modifiers) 'copy)
+                       ((memq 'shift modifiers) 'move)
+                       ((memq 'meta modifiers) 'link)
+                       (t (if (memq dired-mouse-drag-files
+                                    '(copy move link))
+                              dired-mouse-drag-files
+                            'copy)))))
+    (save-excursion
+      (with-selected-window (posn-window (event-end event))
+        (goto-char (posn-point (event-end event))))
+      (track-mouse
+        (let ((beginning-position (mouse-pixel-position))
+              new-event)
+          (catch 'track-again
+            (setq new-event (read-event))
+            (if (not (eq (event-basic-type new-event) 'mouse-movement))
+                (when (eq (event-basic-type new-event) 'mouse-1)
+                  (push new-event unread-command-events))
+              (let ((current-position (mouse-pixel-position)))
+                ;; If the mouse didn't move far enough, don't
+                ;; inadvertently trigger a drag.
+                (when (and (eq (car current-position) (car beginning-position))
+                           (ignore-errors
+                             (and (> 3 (abs (- (cadr beginning-position)
+                                               (cadr current-position))))
+                                  (> 3 (abs (- (caddr beginning-position)
+                                               (caddr current-position)))))))
+                  (throw 'track-again nil)))
+              ;; We can get an error if there's by some chance no file
+              ;; name at point.
+              (condition-case error
+                  (let ((filename (with-selected-window (posn-window
+                                                         (event-end event))
+                                    (let ((marked-files (dired-map-over-marks 
(dired-get-filename
+                                                                               
nil 'no-error-if-not-filep)
+                                                                              
'marked))
+                                          (file-name (dired-get-filename nil 
'no-error-if-not-filep)))
+                                      (if (and marked-files
+                                               (member file-name marked-files))
+                                          marked-files
+                                        (when marked-files
+                                          (dired-map-over-marks (dired-unmark 
nil)
+                                                                'marked))
+                                        file-name)))))
+                    (when filename
+                      (if (and (consp filename)
+                               (cdr filename))
+                          (dnd-begin-drag-files filename nil action t)
+                        (dnd-begin-file-drag (if (stringp filename)
+                                                 filename
+                                               (car filename))
+                                             nil action t))))
+                (error (when (eq (event-basic-type new-event) 'mouse-1)
+                         (push new-event unread-command-events))
+                       ;; Errors from `dnd-begin-drag-file' should be
+                       ;; treated as user errors, since they should
+                       ;; only occur when the user performs an invalid
+                       ;; action, such as trying to create a link to
+                       ;; an invalid file.
+                       (user-error error))))))))))
 
 (defvar dired-mouse-drag-files-map (let ((keymap (make-sparse-keymap)))
                                      (define-key keymap [down-mouse-1] 
#'dired-mouse-drag)
+                                     (define-key keymap [C-down-mouse-1] 
#'dired-mouse-drag)
+                                     (define-key keymap [S-down-mouse-1] 
#'dired-mouse-drag)
+                                     (define-key keymap [M-down-mouse-1] 
#'dired-mouse-drag)
                                      keymap)
   "Keymap applied to file names when `dired-mouse-drag-files' is enabled.")