master 0fd60451bc: Allow running some DND tests interactively

[Po Lu]

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

    Allow running some DND tests interactively
    
    * src/xselect.c (x_get_local_selection): Respect new variable.
    (syms_of_xselect): New variable
    `x-treat-local-requests-remotely'.
    
    * test/lisp/dnd-tests.el (x-begin-drag, gui-set-selection):
    Don't redefine these functions under X.
    (dnd-tests-verify-selection-data): Use
    `x-get-selection-internal' under X.
    (dnd-tests-extract-selection-data): New function.
    (dnd-tests-begin-text-drag): Update accordingly.
    (dnd-tests-begin-file-drag, dnd-tests-begin-drag-files):
    Temporarily skip these tests under X.
---
 src/xselect.c          |  13 ++++-
 test/lisp/dnd-tests.el | 140 ++++++++++++++++++++++++++++++-------------------
 2 files changed, 99 insertions(+), 54 deletions(-)

diff --git a/src/xselect.c b/src/xselect.c
index 40b6571e0a..a234c7188f 100644
--- a/src/xselect.c
+++ b/src/xselect.c
@@ -353,7 +353,10 @@ x_get_local_selection (Lisp_Object selection_symbol, 
Lisp_Object target_type,
 
       if (!NILP (handler_fn))
        value = call3 (handler_fn, selection_symbol,
-                      (local_request ? Qnil : target_type),
+                      ((local_request
+                        && NILP (Vx_treat_local_requests_remotely))
+                       ? Qnil
+                       : target_type),
                       tem);
       else
        value = Qnil;
@@ -2798,6 +2801,14 @@ A value of 0 means wait as long as necessary.  This is 
initialized from the
 \"*selectionTimeout\" resource.  */);
   x_selection_timeout = 0;
 
+  DEFVAR_LISP ("x-treat-local-requests-remotely", 
Vx_treat_local_requests_remotely,
+    doc: /* Whether to treat local selection requests as remote ones.
+
+If non-nil, selection converters for string types (`STRING',
+`UTF8_STRING', `COMPOUND_TEXT', etc) will encode the strings, even
+when Emacs itself is converting the selection.  */);
+  Vx_treat_local_requests_remotely = Qnil;
+
   /* QPRIMARY is defined in keyboard.c.  */
   DEFSYM (QSECONDARY, "SECONDARY");
   DEFSYM (QSTRING, "STRING");
diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el
index 1e5b1f823f..c7e537e53f 100644
--- a/test/lisp/dnd-tests.el
+++ b/test/lisp/dnd-tests.el
@@ -22,7 +22,9 @@
 ;; Tests for stuff in dnd.el that doesn't require a window system.
 
 ;; The drag API tests only check the behavior of the simplified drag
-;; APIs in dnd.el.  Actual drags are not performed.
+;; APIs in dnd.el.  Actual drags are not performed during the
+;; automated testing process (make check), but some of the tests can
+;; also be run under X.
 
 ;;; Code:
 
@@ -35,51 +37,59 @@
 (defvar dnd-tests-selection-table nil
   "Alist of selection names to their values.")
 
-;; Substitute for x-begin-drag, which isn't present on all systems.
-(defalias 'x-begin-drag
-  (lambda (_targets &optional action frame &rest _)
-    ;; Verify that frame is either nil or a valid frame.
-    (when (and frame (not (frame-live-p frame)))
-      (signal 'wrong-type-argument frame))
-    ;; Verify that the action is valid and pretend the drag succeeded
-    ;; (by returning the action).
-    (cl-ecase action
-      ('XdndActionCopy action)
-      ('XdndActionMove action)
-      ('XdndActionLink action)
-      ;; These two are not technically valid, but x-begin-drag accepts
-      ;; them anyway.
-      ('XdndActionPrivate action)
-      ('XdndActionAsk 'XdndActionPrivate))))
+(defvar x-treat-local-requests-remotely)
 
-;; This doesn't work during tests.
-(defalias 'gui-set-selection
-  (lambda (type data)
-    (or (gui--valid-simple-selection-p data)
-        (and (vectorp data)
-            (let ((valid t))
-              (dotimes (i (length data))
-                (or (gui--valid-simple-selection-p (aref data i))
-                    (setq valid nil)))
-              valid))
-        (signal 'error (list "invalid selection" data)))
-    (setf (alist-get type dnd-tests-selection-table) data)))
+;; Define some replacements for functions used by the drag-and-drop
+;; code on X when running under something else.
+(unless (eq window-system 'x)
+  ;; Substitute for x-begin-drag, which isn't present on all systems.
+  (defalias 'x-begin-drag
+    (lambda (_targets &optional action frame &rest _)
+      ;; Verify that frame is either nil or a valid frame.
+      (when (and frame (not (frame-live-p frame)))
+        (signal 'wrong-type-argument frame))
+      ;; Verify that the action is valid and pretend the drag succeeded
+      ;; (by returning the action).
+      (cl-ecase action
+        ('XdndActionCopy action)
+        ('XdndActionMove action)
+        ('XdndActionLink action)
+        ;; These two are not technically valid, but x-begin-drag accepts
+        ;; them anyway.
+        ('XdndActionPrivate action)
+        ('XdndActionAsk 'XdndActionPrivate))))
+
+  ;; This doesn't work during tests.
+  (defalias 'gui-set-selection
+    (lambda (type data)
+      (or (gui--valid-simple-selection-p data)
+          (and (vectorp data)
+              (let ((valid t))
+                (dotimes (i (length data))
+                  (or (gui--valid-simple-selection-p (aref data i))
+                      (setq valid nil)))
+                valid))
+          (signal 'error (list "invalid selection" data)))
+      (setf (alist-get type dnd-tests-selection-table) data))))
 
 (defun dnd-tests-verify-selection-data (type)
   "Return the data of the drag-and-drop selection converted to TYPE."
-  (let* ((basic-value (cdr (assq 'XdndSelection
-                                 dnd-tests-selection-table)))
-         (local-value (if (stringp basic-value)
-                          (or (get-text-property 0 type basic-value)
-                              basic-value)
-                        basic-value))
-         (converter-list (cdr (assq type selection-converter-alist)))
-         (converter (if (consp converter-list)
-                        (cdr converter-list)
-                      converter-list)))
-    (if (and local-value converter)
-        (funcall converter 'XdndSelection type local-value)
-      (error "No selection converter or local value: %s" type))))
+  (if (eq window-system 'x)
+      (let ((x-treat-local-requests-remotely t))
+        (x-get-selection-internal 'XdndSelection type))
+    (let* ((basic-value (cdr (assq 'XdndSelection
+                                   dnd-tests-selection-table)))
+           (local-value (if (stringp basic-value)
+                            (or (get-text-property 0 type basic-value)
+                                basic-value)
+                          basic-value))
+           (converter-list (cdr (assq type selection-converter-alist)))
+           (converter (if (consp converter-list)
+                          (cdr converter-list)
+                        converter-list)))
+      (if (and local-value converter)
+          (funcall converter 'XdndSelection type local-value)
+        (error "No selection converter or local value: %s" type)))))
 
 (defun dnd-tests-remote-accessible-p ()
   "Return if a test involving remote files can proceed."
@@ -119,7 +129,26 @@ Return a list of its hostname, real path, and local path."
                          (+ beg 1
                             (string-to-number (match-string 5 netfile)))))))))
 
+(defun dnd-tests-extract-selection-data (selection expect-cons)
+  "Return the selection data in SELECTION.
+SELECTION can either be the value of `gui-get-selection', or the
+return value of a selection converter.
+
+If EXPECT-CONS, then expect SELECTION to be a cons (when not
+running under X).
+
+This function only tries to handle strings."
+  (when (and expect-cons (not (eq window-system 'x)))
+    (should (and (consp selection)
+                 (stringp (cdr selection)))))
+  (if (stringp selection)
+      selection
+    (cdr selection)))
+
 (ert-deftest dnd-tests-begin-text-drag ()
+  ;; When running this test under X, please make sure to drop onto a
+  ;; 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! всем привет"))
     ;; Verify that dragging works.
@@ -128,26 +157,29 @@ Return a list of its hostname, real path, and local path."
     ;; Verify that the important data types are converted correctly.
     (let ((string-data (dnd-tests-verify-selection-data 'STRING)))
       ;; Check that the Latin-1 target is converted correctly.
-      (should (equal (cdr string-data)
+      (should (equal (dnd-tests-extract-selection-data string-data t)
                      (encode-coding-string test-text
                                            'iso-8859-1))))
     ;; And that UTF8_STRING and the Xdnd UTF8 string are as well.
-    (let ((string-data (dnd-tests-verify-selection-data
-                        'UTF8_STRING))
-          (string-data-1 (cdr (dnd-tests-verify-selection-data
-                               'text/plain\;charset=utf-8))))
-      (should (and (stringp (cdr string-data))
-                   (stringp string-data-1)))
-      (should (equal (cdr string-data) string-data-1)))
+    (let* ((string-data (dnd-tests-verify-selection-data
+                         'UTF8_STRING))
+           (string-data-1 (dnd-tests-verify-selection-data
+                           'text/plain\;charset=utf-8))
+           (extracted-1 (dnd-tests-extract-selection-data string-data-1 t))
+           (extracted (dnd-tests-extract-selection-data string-data t)))
+      (should (and (stringp extracted) (stringp extracted-1)))
+      (should (equal extracted extracted)))
     ;; Now check text/plain.
     (let ((string-data (dnd-tests-verify-selection-data
                         'text/plain)))
-      (should (equal (cdr string-data)
+      (should (equal (dnd-tests-extract-selection-data string-data t)
                      (encode-coding-string test-text 'ascii))))))
 
 (ert-deftest dnd-tests-begin-file-drag ()
   ;; These tests also involve handling remote file names.
-  (skip-unless (dnd-tests-remote-accessible-p))
+  (skip-unless (and (dnd-tests-remote-accessible-p)
+                    ;; TODO: make these tests work under X.
+                    (not (eq window-system 'x))))
   (let ((normal-temp-file (expand-file-name (make-temp-name "dnd-test")
                                             temporary-file-directory))
         (remote-temp-file (dnd-tests-make-temp-name)))
@@ -210,7 +242,9 @@ Return a list of its hostname, real path, and local path."
       (delete-file remote-temp-file))))
 
 (ert-deftest dnd-tests-begin-drag-files ()
-  (skip-unless (dnd-tests-remote-accessible-p))
+  (skip-unless (and (dnd-tests-remote-accessible-p)
+                    ;; TODO: make these tests work under X.
+                    (not (eq window-system 'x))))
   (let ((normal-temp-file (expand-file-name (make-temp-name "dnd-test")
                                             temporary-file-directory))
         (normal-temp-file-1 (expand-file-name (make-temp-name "dnd-test")