master a1a435b3f6: Respect test function when performing local drag-and-drop

[Po Lu]

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

    Respect test function when performing local drag-and-drop
    
    * lisp/x-dnd.el (x-dnd-test-function): Fix doc string to
    describe what is actually accepted.
    (x-dnd-known-types, x-dnd-targets-list): Fix coding style.
    (x-dnd-handle-native-drop): New function.
    
    * src/xselect.c (x_atom_to_symbol): Export.
    
    * src/xterm.c (x_dnd_note_self_drop): Call new variable to
    determine what action to return.
    (x_clear_dnd_action): New function.
    (x_dnd_begin_drag_and_drop): Respect new variable.
    (syms_of_xterm): New defvar `x-dnd-native-test-function'.
    * src/xterm.h: Update prototypes.
---
 lisp/x-dnd.el | 45 +++++++++++++++++++++++++++++++--------------
 src/xselect.c |  4 ++--
 src/xterm.c   | 54 +++++++++++++++++++++++++++++++++++++++++++++++++-----
 src/xterm.h   |  1 +
 4 files changed, 83 insertions(+), 21 deletions(-)

diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index 7ee20e0fc3..bcf74762cc 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -35,22 +35,24 @@
 (defcustom x-dnd-test-function #'x-dnd-default-test-function
   "The function drag and drop uses to determine if to accept or reject a drop.
 The function takes three arguments, WINDOW, ACTION and TYPES.
-WINDOW is where the mouse is when the function is called.  WINDOW may be a
-frame if the mouse isn't over a real window (i.e. menu bar, tool bar or
-scroll bar).  ACTION is the suggested action from the drag and drop source,
-one of the symbols move, copy, link or ask.  TYPES is a list of available
-types for the drop.
-
-The function shall return nil to reject the drop or a cons with two values,
-the wanted action as car and the wanted type as cdr.  The wanted action
-can be copy, move, link, ask or private.
+WINDOW is where the mouse is when the function is called.  WINDOW
+may be a frame if the mouse isn't over a real window (i.e. menu
+bar, tool bar or scroll bar).  ACTION is the suggested action
+from the drag and drop source, one of the symbols move, copy,
+link or ask.  TYPES is a vector of available types for the drop.
+
+Each element of TYPE should either be a string (containing the
+name of the type's X atom), or a symbol, whose name will be used.
+
+The function shall return nil to reject the drop or a cons with
+two values, the wanted action as car and the wanted type as cdr.
+The wanted action can be copy, move, link, ask or private.
+
 The default value for this variable is `x-dnd-default-test-function'."
   :version "22.1"
   :type 'symbol
   :group 'x)
 
-
-
 (defcustom x-dnd-types-alist
   `((,(purecopy "text/uri-list") . x-dnd-handle-uri-list)
     (,(purecopy "text/x-moz-url") . x-dnd-handle-moz-url)
@@ -94,8 +96,7 @@ if drop is successful, nil if not."
 The types are chosen in the order they appear in the list."
   :version "22.1"
   :type '(repeat string)
-  :group 'x
-)
+  :group 'x)
 
 ;; Internal variables
 
@@ -163,7 +164,6 @@ types in `x-dnd-known-types'.  It always returns the action 
private."
   (let ((type (x-dnd-choose-type types)))
     (when type (cons 'private type))))
 
-
 (defun x-dnd-current-type (frame-or-window)
   "Return the type we want the DND data to be in for the current drop.
 FRAME-OR-WINDOW is the frame or window that the mouse is over."
@@ -896,6 +896,23 @@ Return a vector of atoms containing the selection targets."
                 (member "COMPOUND_TEXT" targets)
                 (member "TEXT" targets)))))
 
+(defvar x-dnd-targets-list)
+(defvar x-dnd-native-test-function)
+
+(defun x-dnd-handle-native-drop (pos action)
+  "Compute the action for a drop at POS.
+Return the appropriate drag-and-drop action for a local drop at POS.
+ACTION is the action given to `x-begin-drag'."
+  (let ((state (funcall x-dnd-test-function
+                        (posn-window pos)
+                        (cdr (assoc (symbol-name action)
+                                    x-dnd-xdnd-to-action))
+                        (apply #'vector x-dnd-targets-list))))
+    (when state
+      (intern (car (rassq (car state) x-dnd-xdnd-to-action))))))
+
+(setq x-dnd-native-test-function #'x-dnd-handle-native-drop)
+
 (provide 'x-dnd)
 
 ;;; x-dnd.el ends here
diff --git a/src/xselect.c b/src/xselect.c
index bb5a1447df..490a008dfc 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -112,7 +112,7 @@ selection_quantum (Display *display)
          : MAX_SELECTION_QUANTUM);
 }
 
-#define LOCAL_SELECTION(selection_symbol,dpyinfo)                      \
+#define LOCAL_SELECTION(selection_symbol, dpyinfo)                     \
   assq_no_quit (selection_symbol, dpyinfo->terminal->Vselection_alist)
 
 
@@ -179,7 +179,7 @@ symbol_to_x_atom (struct x_display_info *dpyinfo, 
Lisp_Object sym)
 /* This converts a server Atom to a Lisp symbol, avoiding server roundtrips
    and calls to intern whenever possible.  */
 
-static Lisp_Object
+Lisp_Object
 x_atom_to_symbol (struct x_display_info *dpyinfo, Atom atom)
 {
   char *str;
diff --git a/src/xterm.c b/src/xterm.c
index 81b3b5cbef..d9dd29ca12 100644
--- a/src/xterm.c
+++ b/src/xterm.c
@@ -1228,6 +1228,10 @@ static XRectangle x_dnd_mouse_rect;
    protocol, this is set to the atom XdndActionPrivate.  */
 static Atom x_dnd_action;
 
+/* The symbol to return from `x-begin-drag' if non-nil.  Takes
+   precedence over `x_dnd_action`.  */
+static Lisp_Object x_dnd_action_symbol;
+
 /* The action we want the drop target to perform.  The drop target may
    elect to perform some different action, which is guaranteed to be
    in `x_dnd_action' upon completion of a drop.  */
@@ -1242,7 +1246,7 @@ static uint8_t x_dnd_motif_operations;
 static uint8_t x_dnd_first_motif_operation;
 
 /* Array of selection targets available to the drop target.  */
-static Atom *x_dnd_targets = NULL;
+static Atom *x_dnd_targets;
 
 /* The number of elements in that array.  */
 static int x_dnd_n_targets;
@@ -4298,15 +4302,30 @@ x_dnd_note_self_drop (struct x_display_info *dpyinfo, 
Window target,
   if (!f)
     return;
 
+  if (NILP (Vx_dnd_native_test_function))
+    return;
+
   if (!XTranslateCoordinates (dpyinfo->display, dpyinfo->root_window,
                              FRAME_X_WINDOW (f), root_x, root_y,
                              &win_x, &win_y, &dummy))
     return;
 
-  /* Emacs can't respond to DND events inside the nested event
-     loop, so when dragging items to itself, always return
-     XdndActionPrivate.  */
-  x_dnd_action = dpyinfo->Xatom_XdndActionPrivate;
+  /* Emacs can't respond to DND events inside the nested event loop,
+     so when dragging items to itself, call the test function
+     manually.  */
+
+  XSETFRAME (lval, f);
+  x_dnd_action = None;
+  x_dnd_action_symbol
+    = safe_call2 (Vx_dnd_native_test_function,
+                 Fposn_at_x_y (make_fixnum (win_x),
+                               make_fixnum (win_y),
+                               lval, Qnil),
+                 x_atom_to_symbol (dpyinfo,
+                                   x_dnd_wanted_action));
+
+  if (!SYMBOLP (x_dnd_action_symbol))
+    return;
 
   EVENT_INIT (ie);
 
@@ -10779,6 +10798,12 @@ x_detect_pending_selection_requests (void)
   return pending_selection_requests;
 }
 
+static void
+x_clear_dnd_action (void)
+{
+  x_dnd_action_symbol = Qnil;
+}
+
 /* This function is defined far away from the rest of the XDND code so
    it can utilize `x_any_window_to_frame'.  */
 
@@ -10922,6 +10947,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, 
Atom xaction,
 
   x_set_dnd_targets (target_atoms, ntargets);
   record_unwind_protect_void (x_free_dnd_targets);
+  record_unwind_protect_void (x_clear_dnd_action);
 
   ltimestamp = x_timestamp_for_selection (FRAME_DISPLAY_INFO (f),
                                          QXdndSelection);
@@ -11042,6 +11068,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, 
Atom xaction,
   x_dnd_last_motif_style = XM_DRAG_STYLE_NONE;
   x_dnd_mouse_rect_target = None;
   x_dnd_action = None;
+  x_dnd_action_symbol = Qnil;
   x_dnd_wanted_action = xaction;
   x_dnd_return_frame = 0;
   x_dnd_waiting_for_finish = false;
@@ -11435,6 +11462,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, 
Atom xaction,
   x_dnd_return_frame_object = NULL;
   FRAME_DISPLAY_INFO (f)->grabbed = 0;
 
+  if (!NILP (x_dnd_action_symbol))
+    return unbind_to (base, x_dnd_action_symbol);
+
   if (x_dnd_action != None)
     {
       block_input ();
@@ -26942,6 +26972,9 @@ syms_of_xterm (void)
   x_dnd_monitors = Qnil;
   staticpro (&x_dnd_monitors);
 
+  x_dnd_action_symbol = Qnil;
+  staticpro (&x_dnd_action_symbol);
+
   DEFSYM (Qvendor_specific_keysyms, "vendor-specific-keysyms");
   DEFSYM (Qlatin_1, "latin-1");
   DEFSYM (Qnow, "now");
@@ -27189,4 +27222,15 @@ This variable contains the list of drag-and-drop 
selection targets
 during a drag-and-drop operation, in the same format as the TARGET
 argument to `x-begin-drag'.  */);
   Vx_dnd_targets_list = Qnil;
+
+  DEFVAR_LISP ("x-dnd-native-test-function", Vx_dnd_native_test_function,
+    doc: /* Function called to determine return when dropping on Emacs itself.
+It should accept two arguments POS and ACTION, and return a symbol
+describing what to return from `x-begin-drag'.  POS is a mouse
+position list detailing the location of the drop, and ACTION is the
+action specified by the caller of `x-begin-drag'.
+
+If nil or a non-symbol value is returned, the drop will be
+cancelled.  */);
+  Vx_dnd_native_test_function = Qnil;
 }
diff --git a/src/xterm.h b/src/xterm.h
index 25d145c6c0..25c2453ee7 100644
--- a/src/xterm.h
+++ b/src/xterm.h
@@ -1535,6 +1535,7 @@ extern void x_handle_property_notify (const 
XPropertyEvent *);
 extern void x_handle_selection_notify (const XSelectionEvent *);
 extern void x_handle_selection_event (struct selection_input_event *);
 extern void x_clear_frame_selections (struct frame *);
+extern Lisp_Object x_atom_to_symbol (struct x_display_info *, Atom);
 
 extern bool x_handle_dnd_message (struct frame *,
                                  const XClientMessageEvent *,