From 0fd60451bc098b57bdcbddfa98cfa210a6b0ab78 Mon Sep 17 00:00:00 2001 From: Po Lu Date: Wed, 8 Jun 2022 20:33:42 +0800 Subject: [PATCH] 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 40b6571e0ad..a234c7188f3 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 1e5b1f823fb..c7e537e53f9 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") -- 2.39.2