master 0e6516a1f0: Fix reported problem with drag-and-drop inside VirtualBox

[Po Lu]

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

    Fix reported problem with drag-and-drop inside VirtualBox
    
    * lisp/x-dnd.el (x-dnd-handle-old-kde, x-dnd-handle-offix)
    (x-dnd-handle-motif): Select window before handling drop, like
    on Xdnd.
    (x-dnd-convert-to-offix, x-dnd-do-offix-drop)
    (x-dnd-handle-unsupported-drop): Accept local selection data and
    use that instead.
    
    * src/keyboard.c (kbd_buffer_get_event): Call unsupported drop
    function with local selection data as 8th arg.
    * src/xselect.c (x_get_local_selection): Accept new arg
    `local_value'.  All callers changed.
    (Fx_get_local_selection): New function.
    (syms_of_xselect): Update defsubrs.
    
    * src/xterm.c (x_dnd_lose_ownership): New function.
    (x_dnd_begin_drag_and_drop): Unless new variable is true, disown
    XdndSelection after returning.  This supposedly makes
    drag-and-drop from guest to host work in VirtualBox without
    causing pointer motion to become choppy afterwards.
    (syms_of_xterm): New variable `x_dnd_preserve_selection_data'
    and update doc string of `x-dnd-unsupported-drop-function'.
    
    * test/lisp/dnd-tests.el (dnd-tests-begin-text-drag)
    (dnd-tests-begin-file-drag, dnd-tests-begin-drag-files): Set new
    variable to nil during tests.
---
 lisp/x-dnd.el          | 41 +++++++++++++++++++---------
 src/keyboard.c         |  5 ++--
 src/xselect.c          | 74 ++++++++++++++++++++++++++++++++++++++++++++------
 src/xterm.c            | 51 ++++++++++++++++++++++++++--------
 test/lisp/dnd-tests.el | 10 +++++--
 5 files changed, 142 insertions(+), 39 deletions(-)

diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 22277033f5..5c6d25ba68 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -443,6 +443,8 @@ EVENT, FRAME, WINDOW and DATA mean the same thing they do in
         ;; Now call the test function to decide what action to perform.
         (x-dnd-maybe-call-test-function window 'private)
         (unwind-protect
+            (when (windowp window)
+              (select-window window))
             (x-dnd-drop-data event frame window data
                              (symbol-name type))
           (x-dnd-forget-drop window))))))
@@ -500,6 +502,8 @@ message (format 32) that caused EVENT to be generated."
     ;; Now call the test function to decide what action to perform.
     (x-dnd-maybe-call-test-function window 'private)
     (unwind-protect
+        (when (windowp window)
+          (select-window window))
         (x-dnd-drop-data event frame window data
                          (symbol-name type))
       (x-dnd-forget-drop window))))
@@ -926,6 +930,8 @@ Return a vector of atoms containing the selection targets."
                                      reply)))
 
            ((eq message-type 'XmDROP_START)
+             (when (windowp window)
+               (select-window window))
             (let* ((x (x-dnd-motif-value-to-list
                        (x-dnd-get-motif-value data 8 2 source-byteorder)
                        2 my-byteorder))
@@ -1014,19 +1020,22 @@ Return a vector of atoms containing the selection 
targets."
 ;;; Handling drops.
 
 (defvar x-treat-local-requests-remotely)
+(declare-function x-get-local-selection "xfns.c")
 
-(defun x-dnd-convert-to-offix (targets)
-  "Convert the contents of `XdndSelection' to OffiX data.
+(defun x-dnd-convert-to-offix (targets local-selection)
+  "Convert local selection data to OffiX data.
 TARGETS should be the list of targets currently available in
 `XdndSelection'.  Return a list of an OffiX type, and data
 suitable for passing to `x-change-window-property', or nil if the
-data could not be converted."
+data could not be converted.
+LOCAL-SELECTION should be the local selection data describing the
+selection data to convert."
   (let ((x-treat-local-requests-remotely t)
         file-name-data string-data)
     (cond
      ((and (member "FILE_NAME" targets)
            (setq file-name-data
-                 (gui-get-selection 'XdndSelection 'FILE_NAME)))
+                 (x-get-local-selection local-selection 'FILE_NAME)))
       (if (string-match-p "\0" file-name-data)
           ;; This means there are multiple file names in
           ;; XdndSelection.  Convert the file name data to a format
@@ -1035,19 +1044,23 @@ data could not be converted."
         (cons 'DndTypeFile (concat file-name-data "\0"))))
      ((and (member "STRING" targets)
            (setq string-data
-                 (gui-get-selection 'XdndSelection 'STRING)))
+                 (x-get-local-selection local-selection 'STRING)))
       (cons 'DndTypeText (encode-coding-string string-data
                                                'latin-1))))))
 
-(defun x-dnd-do-offix-drop (targets x y frame window-id)
-  "Perform an OffiX drop on WINDOW-ID with the contents of `XdndSelection'.
+(defun x-dnd-do-offix-drop (targets x y frame window-id contents)
+  "Perform an OffiX drop on WINDOW-ID with the given selection contents.
 Return non-nil if the drop succeeded, or nil if it did not
 happen, which can happen if TARGETS didn't contain anything that
 the OffiX protocol can represent.
 
 X and Y are the root window coordinates of the drop.  TARGETS is
-the list of targets `XdndSelection' can be converted to."
-  (if-let* ((data (x-dnd-convert-to-offix targets))
+the list of targets CONTENTS can be converted to, and CONTENTS is
+the local selection data to drop onto the target window.
+
+FRAME is the frame that will act as a source window for the
+drop."
+  (if-let* ((data (x-dnd-convert-to-offix targets contents))
             (type-id (car (rassq (car data)
                                  x-dnd-offix-id-to-name)))
             (source-id (string-to-number
@@ -1074,18 +1087,20 @@ the list of targets `XdndSelection' can be converted 
to."
                              frame "_DND_PROTOCOL"
                              32 message-data))))
 
-(defun x-dnd-handle-unsupported-drop (targets x y action window-id frame _time)
+(defun x-dnd-handle-unsupported-drop (targets x y action window-id frame _time 
local-selection-data)
   "Return non-nil if the drop described by TARGETS and ACTION should not 
proceed.
 X and Y are the root window coordinates of the drop.
 FRAME is the frame the drop originated on.
-WINDOW-ID is the X window the drop should happen to."
+WINDOW-ID is the X window the drop should happen to.
+LOCAL-SELECTION-DATA is the local selection data of the drop."
   (not (and (or (eq action 'XdndActionCopy)
                 (eq action 'XdndActionMove))
-            (not (and x-dnd-use-offix-drop
+            (not (and x-dnd-use-offix-drop local-selection-data
                       (or (not (eq x-dnd-use-offix-drop 'files))
                           (member "FILE_NAME" targets))
                       (x-dnd-do-offix-drop targets x
-                                           y frame window-id)))
+                                           y frame window-id
+                                           local-selection-data)))
             (or
              (member "STRING" targets)
              (member "UTF8_STRING" targets)
diff --git a/src/keyboard.c b/src/keyboard.c
index e5708c06d9..8b8d348c41 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -4056,12 +4056,13 @@ kbd_buffer_get_event (KBOARD **kbp,
 
          if (!NILP (Vx_dnd_unsupported_drop_function))
            {
-             if (!NILP (call7 (Vx_dnd_unsupported_drop_function,
+             if (!NILP (call8 (Vx_dnd_unsupported_drop_function,
                                XCAR (XCDR (event->ie.arg)), event->ie.x,
                                event->ie.y, XCAR (XCDR (XCDR (event->ie.arg))),
                                make_uint (event->ie.code),
                                event->ie.frame_or_window,
-                               make_int (event->ie.timestamp))))
+                               make_int (event->ie.timestamp),
+                               Fcopy_sequence (XCAR (event->ie.arg)))))
                break;
            }
 
diff --git a/src/xselect.c b/src/xselect.c
index d90916c6b6..a1f590632f 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -307,18 +307,30 @@ x_own_selection (Lisp_Object selection_name, Lisp_Object 
selection_value,
    This function is used both for remote requests (LOCAL_REQUEST is zero)
    and for local x-get-selection-internal (LOCAL_REQUEST is nonzero).
 
+   If LOCAL_VALUE is non-nil, use it as the local copy.  Also allow
+   quitting in that case, and let DPYINFO be NULL.
+
    This calls random Lisp code, and may signal or gc.  */
 
 static Lisp_Object
 x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
-                      bool local_request, struct x_display_info *dpyinfo)
+                      bool local_request, struct x_display_info *dpyinfo,
+                      Lisp_Object local_value)
 {
-  Lisp_Object local_value, tem;
+  Lisp_Object tem;
   Lisp_Object handler_fn, value, check;
+  bool may_quit;
+  specpdl_ref count;
+
+  may_quit = false;
 
-  local_value = LOCAL_SELECTION (selection_symbol, dpyinfo);
+  if (NILP (local_value))
+    local_value = LOCAL_SELECTION (selection_symbol, dpyinfo);
+  else
+    may_quit = true;
 
-  if (NILP (local_value)) return Qnil;
+  if (NILP (local_value))
+    return Qnil;
 
   /* TIMESTAMP is a special case.  */
   if (EQ (target_type, QTIMESTAMP))
@@ -331,8 +343,10 @@ x_get_local_selection (Lisp_Object selection_symbol, 
Lisp_Object target_type,
       /* Don't allow a quit within the converter.
         When the user types C-g, he would be surprised
         if by luck it came during a converter.  */
-      specpdl_ref count = SPECPDL_INDEX ();
-      specbind (Qinhibit_quit, Qt);
+      count = SPECPDL_INDEX ();
+
+      if (!may_quit)
+       specbind (Qinhibit_quit, Qt);
 
       CHECK_SYMBOL (target_type);
       handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
@@ -804,7 +818,9 @@ x_handle_selection_request (struct selection_input_event 
*event)
      target that doesn't support XDND.  */
   if (SELECTION_EVENT_TIME (event) == pending_dnd_time + 1
       || SELECTION_EVENT_TIME (event) == pending_dnd_time + 2)
-    selection_symbol = QXdndSelection;
+    /* Always reply with the contents of PRIMARY, since that's where
+       the selection data is.  */
+    selection_symbol = QPRIMARY;
 
   local_selection_data = LOCAL_SELECTION (selection_symbol, dpyinfo);
 
@@ -915,7 +931,7 @@ x_convert_selection (Lisp_Object selection_symbol,
 
   lisp_selection
     = x_get_local_selection (selection_symbol, target_symbol,
-                            false, dpyinfo);
+                            false, dpyinfo, Qnil);
 
   frame = selection_request_stack;
 
@@ -2131,7 +2147,7 @@ On Nextstep, TIME-STAMP and TERMINAL are unused.  */)
     }
 
   val = x_get_local_selection (selection_symbol, target_type, true,
-                              FRAME_DISPLAY_INFO (f));
+                              FRAME_DISPLAY_INFO (f), Qnil);
 
   if (NILP (val) && FRAME_LIVE_P (f))
     {
@@ -2273,6 +2289,45 @@ On Nextstep, TERMINAL is unused.  */)
   return (owner ? Qt : Qnil);
 }
 
+DEFUN ("x-get-local-selection", Fx_get_local_selection, Sx_get_local_selection,
+       0, 2, 0,
+       doc: /* Run selection converters for VALUE, and return the result.
+TARGET is the selection target that is used to find a suitable
+converter.  VALUE is a list of 4 values NAME, SELECTION-VALUE,
+TIMESTAMP and FRAME.  NAME is the name of the selection that will be
+passed to selection converters, SELECTION-VALUE is the value of the
+selection used by the converter, TIMESTAMP is not meaningful (but must
+be a number that fits in an X timestamp), and FRAME is the frame
+describing the terminal for which the selection converter will be
+run.  */)
+  (Lisp_Object value, Lisp_Object target)
+{
+  Time time;
+  Lisp_Object name, timestamp, frame, result;
+
+  CHECK_SYMBOL (target);
+  name = Fnth (make_fixnum (0), value);
+  timestamp = Fnth (make_fixnum (2), value);
+  frame = Fnth (make_fixnum (3), value);
+
+  CHECK_SYMBOL (name);
+  CONS_TO_INTEGER (timestamp, Time, time);
+  check_window_system (decode_live_frame (frame));
+
+  result = x_get_local_selection (name, target, true,
+                                 NULL, value);
+
+  if (CONSP (result) && SYMBOLP (XCAR (result)))
+    {
+      result = XCDR (result);
+
+      if (CONSP (result) && NILP (XCDR (result)))
+       result = XCAR (result);
+    }
+
+  return clean_local_selection_data (result);
+}
+
 
 /* Send clipboard manager a SAVE_TARGETS request with a UTF8_STRING
    property (https://www.freedesktop.org/wiki/ClipboardManager/).  */
@@ -2809,6 +2864,7 @@ syms_of_xselect (void)
   defsubr (&Sx_get_atom_name);
   defsubr (&Sx_send_client_message);
   defsubr (&Sx_register_dnd_atom);
+  defsubr (&Sx_get_local_selection);
 
   reading_selection_reply = Fcons (Qnil, Qnil);
   staticpro (&reading_selection_reply);
diff --git a/src/xterm.c b/src/xterm.c
index d7c3bfa7af..7298feb43a 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -11234,6 +11234,19 @@ x_dnd_delete_action_list (Lisp_Object frame)
   unblock_input ();
 }
 
+static void
+x_dnd_lose_ownership (Lisp_Object timestamp_and_frame)
+{
+  struct frame *f;
+
+  f = XFRAME (XCDR (timestamp_and_frame));
+
+  if (FRAME_LIVE_P (f))
+    Fx_disown_selection_internal (QXdndSelection,
+                                 XCAR (timestamp_and_frame),
+                                 XCDR (timestamp_and_frame));
+}
+
 /* This function is defined far away from the rest of the XDND code so
    it can utilize `x_any_window_to_frame'.  */
 
@@ -11324,12 +11337,13 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time 
time, Atom xaction,
 
       if (!NILP (Vx_dnd_unsupported_drop_function))
        {
-         if (!NILP (call7 (Vx_dnd_unsupported_drop_function,
+         if (!NILP (call8 (Vx_dnd_unsupported_drop_function,
                            XCAR (XCDR (event->ie.arg)), event->ie.x,
                            event->ie.y, XCAR (XCDR (XCDR (event->ie.arg))),
                            make_uint (event->ie.code),
                            event->ie.frame_or_window,
-                           make_int (event->ie.timestamp))))
+                           make_int (event->ie.timestamp),
+                           Fcopy_sequence (XCAR (event->ie.arg)))))
            continue;
        }
 
@@ -11364,12 +11378,6 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, 
Atom xaction,
   /* If local_value is nil, then we lost ownership of XdndSelection.
      Signal a more informative error than args-out-of-range.  */
   if (NILP (local_value))
-    error ("Lost ownership of XdndSelection");
-
-  if (CONSP (local_value))
-    x_own_selection (QXdndSelection,
-                    Fnth (make_fixnum (1), local_value), frame);
-  else
     error ("No local value for XdndSelection");
 
   if (popup_activated ())
@@ -11387,6 +11395,14 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, 
Atom xaction,
   else
     x_dnd_selection_timestamp = XFIXNUM (ltimestamp);
 
+  /* Release ownership of XdndSelection after this function returns.
+     VirtualBox uses the owner of XdndSelection to determine whether
+     or not mouse motion is part of a drag-and-drop operation.  */
+
+  if (!x_dnd_preserve_selection_data)
+    record_unwind_protect (x_dnd_lose_ownership,
+                          Fcons (ltimestamp, frame));
+
   x_dnd_motif_operations
     = xm_side_effect_from_action (FRAME_DISPLAY_INFO (f), xaction);
 
@@ -27959,17 +27975,21 @@ mouse position list.  */);
 
   DEFVAR_LISP ("x-dnd-unsupported-drop-function", 
Vx_dnd_unsupported_drop_function,
     doc: /* Function called when trying to drop on an unsupported window.
+
 This function is called whenever the user tries to drop something on a
 window that does not support either the XDND or Motif protocols for
 drag-and-drop.  It should return a non-nil value if the drop was
 handled by the function, and nil if it was not.  It should accept
-several arguments TARGETS, X, Y, ACTION, WINDOW-ID, FRAME and TIME,
-where TARGETS is the list of targets that was passed to
-`x-begin-drag', WINDOW-ID is the numeric XID of the window that is
+several arguments TARGETS, X, Y, ACTION, WINDOW-ID, FRAME, TIME and
+LOCAL-SELECTION, where TARGETS is the list of targets that was passed
+to `x-begin-drag', WINDOW-ID is the numeric XID of the window that is
 being dropped on, X and Y are the root window-relative coordinates
 where the drop happened, ACTION is the action that was passed to
 `x-begin-drag', FRAME is the frame which initiated the drag-and-drop
-operation, and TIME is the X server time when the drop happened.  */);
+operation, TIME is the X server time when the drop happened, and
+LOCAL-SELECTION is the contents of the `XdndSelection' when
+`x-begin-drag' was run, which can be passed to
+`x-get-local-selection'.  */);
   Vx_dnd_unsupported_drop_function = Qnil;
 
   DEFVAR_INT ("x-color-cache-bucket-size", x_color_cache_bucket_size,
@@ -27996,4 +28016,11 @@ should return a symbol describing what to return from
 If the value is nil, or the function returns a value that is not
 a symbol, a drop on an Emacs frame will be canceled.  */);
   Vx_dnd_native_test_function = Qnil;
+
+  DEFVAR_BOOL ("x-dnd-preserve-selection-data", x_dnd_preserve_selection_data,
+    doc: /* Preserve selection data after `x-begin-drag' returns.
+This lets you inspect the contents of `XdndSelection' after a
+drag-and-drop operation, which is useful when writing tests for
+drag-and-drop code.  */);
+  x_dnd_preserve_selection_data = false;
 }
diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el
index aae9c80273..18dd55c206 100644
--- a/test/lisp/dnd-tests.el
+++ b/test/lisp/dnd-tests.el
@@ -38,6 +38,7 @@
   "Alist of selection names to their values.")
 
 (defvar x-treat-local-requests-remotely)
+(defvar x-dnd-preserve-selection-data)
 
 ;; Define some replacements for functions used by the drag-and-drop
 ;; code on X when running under something else.
@@ -152,7 +153,8 @@ This function only tries to handle strings."
   ;; program with reasonably correct behavior, such as dtpad, gedit,
   ;; or Mozilla.
   ;;                ASCII            Latin-1       UTF-8
-  (let ((test-text "hello, everyone! sæl öllsömul! всем привет"))
+  (let ((test-text "hello, everyone! sæl öllsömul! всем привет")
+        (x-dnd-preserve-selection-data t))
     ;; Verify that dragging works.
     (should (eq (dnd-begin-text-drag test-text) 'copy))
     (should (eq (dnd-begin-text-drag test-text nil 'move) 'move))
@@ -187,7 +189,8 @@ This function only tries to handle strings."
         (normal-multibyte-file (expand-file-name
                                 (make-temp-name "тест-на-перетаскивание")
                                 temporary-file-directory))
-        (remote-temp-file (dnd-tests-make-temp-name)))
+        (remote-temp-file (dnd-tests-make-temp-name))
+        (x-dnd-preserve-selection-data t))
     ;; Touch those files if they don't exist.
     (unless (file-exists-p normal-temp-file)
       (write-region "" 0 normal-temp-file))
@@ -273,7 +276,8 @@ This function only tries to handle strings."
          (expand-file-name (make-temp-name "dnd-test")
                            temporary-file-directory))
         (nonexistent-remote-file (dnd-tests-make-temp-name))
-        (nonexistent-remote-file-1 (dnd-tests-make-temp-name)))
+        (nonexistent-remote-file-1 (dnd-tests-make-temp-name))
+        (x-dnd-preserve-selection-data t))
     ;; Touch those files if they don't exist.
     (unless (file-exists-p normal-temp-file)
       (write-region "" 0 normal-temp-file))