master 45609c347e: Allow dragging files from Dired to other programs

[Po Lu]

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

    Allow dragging files from Dired to other programs
    
    * etc/NEWS: Announce new user option `dired-mouse-drag-files'.
    * lisp/dired.el (dired-mouse-drag-files): New user option.
    (dired-mouse-drag): New command.
    (dired-mouse-drag-files-map): New variable.
    (dired-insert-set-properties): Add additional keymap if mouse
    dragging is enabled.
    
    * lisp/select.el (xselect-convert-to-targets): Handle new
    form of selection converters.
    (xselect-convert-to-username):
    (xselect-convert-to-text-uri-list):
    (xselect-uri-list-available-p): New functions.
    (selection-converter-alist): Add them as selection converters.
    
    * src/xselect.c (x_get_local_selection): Handle new form of
    selection converters.
    (syms_of_xselect): Update doc strings.
---
 etc/NEWS       |  5 +++++
 lisp/dired.el  | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++----
 lisp/select.el | 38 +++++++++++++++++++++++++++++++++++---
 src/xselect.c  | 16 +++++++++++++---
 4 files changed, 104 insertions(+), 10 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index f4d8756950..e2546bb3ca 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -932,6 +932,11 @@ the thumbnail file.
 
 ** Dired
 
+*** New user option 'dired-mouse-drag-files'.
+If non-nil, dragging filenames with the mouse in a Dired buffer will
+initiate a drag-and-drop session allowing them to be opened in other
+programs.
+
 *** New user option 'dired-free-space'.
 Dired will now, by default, include the free space in the first line
 instead of having it on a separate line.  To get the previous behavior
diff --git a/lisp/dired.el b/lisp/dired.el
index bca3018923..da3c3c80cc 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -248,6 +248,18 @@ The target is used in the prompt for file copy, rename 
etc."
           (other :tag "Try to guess" t))
   :group 'dired)
 
+(defcustom dired-mouse-drag-files nil
+  "If non-nil, allow the mouse to drag files from inside a Dired buffer.
+Dragging the mouse and then releasing it over the window of
+another program will result in that program opening the file, or
+creating a copy of it .
+
+If the value is `link', then a symbolic link will be created to
+the file instead by the other program (usually a file manager)."
+  :type '(choice (const :tag "Don't allow dragging" nil)
+                 (const :tag "Copy file to other window" tx)
+                 (const :tag "Create symbolic link to file" link)))
+
 (defcustom dired-copy-preserve-time t
   "If non-nil, Dired preserves the last-modified time in a file copy.
 \(This works on only some systems.)"
@@ -1674,6 +1686,36 @@ see `dired-use-ls-dired' for more details.")
           beg))
         beg))))
 
+(declare-function x-begin-drag "xfns.cx")
+
+(defun dired-mouse-drag (event)
+  "Begin a drag-and-drop operation for the file at EVENT.
+If we get a mouse motion event right "
+  (interactive "e")
+  (save-excursion
+    (goto-char (posn-point (event-end event)))
+    (track-mouse
+      (let ((new-event (read-event)))
+        (if (not (eq (event-basic-type new-event) 'mouse-movement))
+            (push new-event unread-command-events)
+          ;; We can get an error if there's by some chance no file
+          ;; name at point.
+          (condition-case nil
+              (progn
+                (gui-backend-set-selection 'XdndSelection
+                                           (dired-file-name-at-point))
+                (x-begin-drag '("text/uri-list"
+                                "text/x-dnd-username")
+                              (if (eq 'dired-mouse-drag-files 'link)
+                                  'XdndActionLink
+                                'XdndActionCopy)))
+            (error (push new-event unread-command-events))))))))
+
+(defvar dired-mouse-drag-files-map (let ((keymap (make-sparse-keymap)))
+                                     (define-key keymap [down-mouse-1] 
#'dired-mouse-drag)
+                                     keymap)
+  "Keymap applied to file names when `dired-mouse-drag-files' is enabled.")
+
 (defun dired-insert-set-properties (beg end)
   "Add various text properties to the lines in the region, from BEG to END."
   (save-excursion
@@ -1693,10 +1735,15 @@ see `dired-use-ls-dired' for more details.")
           (progn
             (dired-move-to-end-of-filename)
             (point))
-          '(mouse-face
-            highlight
-            dired-filename t
-            help-echo "mouse-2: visit this file in other window"))
+          (append `(mouse-face
+                    highlight
+                    dired-filename t
+                    help-echo ,(if dired-mouse-drag-files
+                                    "down-mouse-1: drag this file to another 
program
+mouse-2: visit this file in other window"
+                                  "mouse-2: visit this file in other window"))
+                   (when dired-mouse-drag-files
+                     `(keymap ,dired-mouse-drag-files-map))))
          (when (< (+ (point) 4) (line-end-position))
            (put-text-property (+ (point) 4) (line-end-position)
                               'invisible 'dired-hide-details-link))))
diff --git a/lisp/select.el b/lisp/select.el
index e9bc545117..36452776e9 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -546,16 +546,22 @@ two markers or an overlay.  Otherwise, it is nil."
     (if len
        (xselect--int-to-cons len))))
 
-(defun xselect-convert-to-targets (_selection _type _value)
+(defun xselect-convert-to-targets (selection _type value)
   ;; return a vector of atoms, but remove duplicates first.
   (let* ((all (cons 'TIMESTAMP
                    (cons 'MULTIPLE
-                         (mapcar 'car selection-converter-alist))))
+                         (mapcar (lambda (conv)
+                                    (if (or (not (consp (cdr conv)))
+                                            (funcall (cadr conv) selection
+                                                     (car conv) value))
+                                        (car conv)
+                                      '_EMACS_INTERNAL))
+                                  selection-converter-alist))))
         (rest all))
     (while rest
       (cond ((memq (car rest) (cdr rest))
             (setcdr rest (delq (car rest) (cdr rest))))
-           ((eq (car (cdr rest)) '_EMACS_INTERNAL)  ; shh, it's a secret
+           ((eq (car (cdr rest)) '_EMACS_INTERNAL)
             (setcdr rest (cdr (cdr rest))))
            (t
             (setq rest (cdr rest)))))
@@ -632,6 +638,30 @@ This function returns the string \"emacs\"."
   (when (eq selection 'CLIPBOARD)
     'NULL))
 
+(defun xselect-convert-to-username (_selection _type _value)
+  (user-real-login-name))
+
+(defun xselect-convert-to-text-uri-list (_selection _type value)
+  (when (and (stringp value)
+             (file-exists-p value))
+    (concat (url-encode-url
+             ;; Uncomment the following code code in a better world where
+             ;; people write correct code that adds the hostname to the URI.
+             ;; Since most programs don't implement this properly, we omit the
+             ;; hostname so that copying files actually works.  Most properly
+             ;; written programs will look at WM_CLIENT_MACHINE to determine
+             ;; the hostname anyway.  (format "file://%s%s\n" (system-name)
+             ;; (expand-file-name value))
+             (concat "file://" (expand-file-name value)))
+            "\n")))
+
+(defun xselect-uri-list-available-p (selection _type value)
+  "Return whether or not `text/uri-list' is a valid target for SELECTION.
+VALUE is the local selection value of SELECTION."
+  (and (eq selection 'XdndSelection)
+       (stringp value)
+       (file-exists-p value)))
+
 (setq selection-converter-alist
       '((TEXT . xselect-convert-to-string)
        (COMPOUND_TEXT . xselect-convert-to-string)
@@ -639,6 +669,8 @@ This function returns the string \"emacs\"."
        (UTF8_STRING . xselect-convert-to-string)
        (text/plain . xselect-convert-to-string)
        (text/plain\;charset=utf-8 . xselect-convert-to-string)
+        (text/uri-list . (xselect-uri-list-available-p . 
xselect-convert-to-text-uri-list))
+        (text/x-xdnd-username . xselect-convert-to-username)
        (TARGETS . xselect-convert-to-targets)
        (LENGTH . xselect-convert-to-length)
        (DELETE . xselect-convert-to-delete)
diff --git a/src/xselect.c b/src/xselect.c
index cdc70d3e24..76a2f9f507 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -386,6 +386,9 @@ x_get_local_selection (Lisp_Object selection_symbol, 
Lisp_Object target_type,
       CHECK_SYMBOL (target_type);
       handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
 
+      if (CONSP (handler_fn))
+       handler_fn = XCDR (handler_fn);
+
       if (!NILP (handler_fn))
        value = call3 (handler_fn,
                       selection_symbol, (local_request ? Qnil : target_type),
@@ -2690,11 +2693,18 @@ syms_of_xselect (void)
   DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
               doc: /* An alist associating X Windows selection-types with 
functions.
 These functions are called to convert the selection, with three args:
-the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
-a desired type to which the selection should be converted;
-and the local selection value (whatever was given to
+the name of the selection (typically `PRIMARY', `SECONDARY', or
+`CLIPBOARD'); a desired type to which the selection should be
+converted; and the local selection value (whatever was given to
 `x-own-selection-internal').
 
+On X Windows, the function can also be a cons of (PREDICATE
+. FUNCTION), where PREDICATE determines whether or not the selection
+type will appear in the list of selection types available to other
+programs, and FUNCTION is the function which is actually called.
+PREDICATE is called with the same arguments as FUNCTION, and should
+return a non-nil value if the data type is to appear in that list.
+
 The function should return the value to send to the X server
 \(typically a string).  A return value of nil
 means that the conversion could not be done.