1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
;;; dnd-tests.el --- Tests for X DND support -*- lexical-binding: t; -*-
;; Copyright (C) 2022-2025 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Tests for stuff in x-dnd.el that doesn't require a window system.
;;; Code:
(require 'x-dnd)
(require 'cl-lib)
(when (display-graphic-p)
(error "This test cannot be run under X"))
;; Dummy replacements.
(defconst x-dnd-tests-drag-window-xid 3948573
"XID of the drag window returned during the test.")
(defvar x-dnd-tests-xds-property-value nil
"The value of the `XdndDirectSave0' window property.")
(defconst x-dnd-tests-targets-table
(base64-decode-string
"bAArAKIBAAAGAB8AAABqAQAANgIAAJMCAAAFAwAABgMAAAEAkMJbAAEAINNbAAUAHwAAAGoBAAA2
AgAAkwIAANkfAAALAB8AAABqAQAANgIAAJMCAADyAgAA2R8AANwfAADgHwAA4R8AAOIfAADjHwAA
AQDQMAgCAQBQTggCAQCwe5IAAQDQmZIABgDyAgAA9wIAABcRAADgHwAAvSEAAI3AAAABAHC52AAB
AGDY2AABAABq3QABAGBw3QAIAB8AAAA2AgAA8gIAANwfAADgHwAA4R8AAOIfAADjHwAAAQBwBOEA
AQCACuEAAQAwLwUCAQDwPgUCAQBQxoQBAQCQ3YQBAQCQBYoBAQDACYoBAQCgMooBAQCgOIoBAQAf
AAAAAQDATrcDAQAQ1LcDAQCw/sADAQAgBcEDAQBQt7oDAQAAUsIDAQCAc7wDAQAwerwDAQBAIKUE
AQAALKUEAQDwfKUEAQDgg6UEAQCgjesEAQAAmusEAQCA7+sEAQCw9usECAAfAAAAagEAADYCAACT
AgAABQMAAAYDAAATGwAAGhsAAA==")
"Predefined Motif targets table used to test the targets table parser.")
(defconst x-dnd-tests-lispy-targets-table [[31 362 566 659 773 774] [6013584] [6017824]
[31 362 566 659 8153]
[31 362 566 659 754 8153 8156 8160 8161 8162 8163]
[34091216] [34098768] [9599920]
[9607632] [754 759 4375 8160 8637 49293]
[14203248] [14211168] [14510592]
[14512224] [31 566 754 8156 8160 8161 8162 8163]
[14746736] [14748288] [33894192] [33898224]
[25478736] [25484688] [25822608] [25823680]
[25834144] [25835680] [31] [62344896] [62379024]
[62979760] [62981408] [62568272] [63066624]
[62681984] [62683696] [77930560] [77933568]
[77954288] [77956064] [82546080] [82549248]
[82571136] [82572976] [31 362 566 659 773 774 6931 6938]]
"The expected result of parsing that targets table.")
(defalias 'x-window-property
(lambda (prop &optional _frame type window-id delete-p _vector-ret-p)
(cond
((and (equal prop "_MOTIF_DRAG_WINDOW")
(zerop window-id) (equal type "WINDOW"))
x-dnd-tests-drag-window-xid)
((and (equal prop "_MOTIF_DRAG_TARGETS")
(equal type "_MOTIF_DRAG_TARGETS")
(equal window-id x-dnd-tests-drag-window-xid))
x-dnd-tests-targets-table)
((and (equal prop "XdndDirectSave0")
(or (equal type "text/plain")
(equal type "AnyPropertyType")))
(prog1 x-dnd-tests-xds-property-value
(when delete-p
(setq x-dnd-tests-xds-property-value nil)))))))
;; This test also serves to exercise most of the Motif value
;; extraction code.
(ert-deftest x-dnd-tests-read-xm-targets-table ()
(should (equal (x-dnd-xm-read-targets-table nil)
x-dnd-tests-lispy-targets-table)))
;;; XDS tests.
(defvar x-dnd-xds-testing)
(defvar x-dnd-tests-xds-target-dir nil
"The name of the target directory where the file will be saved.")
(defvar x-dnd-tests-xds-name nil
"The name that the dragged file should be saved under.")
(defvar x-dnd-tests-xds-include-hostname nil
"Whether or not to include the hostname inside the XDS URI.")
(defun x-dnd-tests-call-xds-converter ()
"Look up the XDS selection converter and call it.
Return the result of the selection."
(let ((conv (cdr (assq 'XdndDirectSave0
selection-converter-alist))))
(should (functionp conv))
(funcall conv 'XdndDirectSave0 'XdndDirectSave0 nil)))
(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))
(prog1 'XdndActionDirectSave
;; Verify that the action is `XdndActionDirectSave'.
(should (eq action 'XdndActionDirectSave))
;; Set the property value to the URI of the new file.
(should (and (stringp x-dnd-tests-xds-property-value)
(not (multibyte-string-p x-dnd-tests-xds-property-value))))
(let ((uri (if x-dnd-tests-xds-include-hostname
(format "file://%s%s" (system-name)
(expand-file-name x-dnd-tests-xds-property-value
x-dnd-tests-xds-target-dir))
(concat "file://" (expand-file-name x-dnd-tests-xds-property-value
x-dnd-tests-xds-target-dir)))))
(setq x-dnd-tests-xds-property-value
(encode-coding-string (url-encode-url uri)
'raw-text)))
;; Convert the selection and verify its success.
(should (equal (x-dnd-tests-call-xds-converter)
'(STRING . "S"))))))
(defalias 'x-change-window-property
(lambda (prop value &optional _frame type format outer-p _window-id)
;; Check that the properties are the right type.
(should (equal prop "XdndDirectSave0"))
(should (equal value (encode-coding-string
x-dnd-tests-xds-name
(or file-name-coding-system
default-file-name-coding-system))))
(should (equal type "text/plain"))
(should (equal format 8))
(should (not outer-p))
(setq x-dnd-tests-xds-property-value value)))
(defalias 'x-delete-window-property
(lambda (&rest _args)
;; This function shouldn't ever be reached during XDS.
(setq x-dnd-tests-xds-property-value nil)))
(defun x-dnd-tests-do-direct-save-internal (include-hostname)
"Test the behavior of `x-dnd-do-direct-save'.
Make it perform a direct save to a randomly generated directory,
and check that the file exists. If INCLUDE-HOSTNAME, include the
hostname in the target URI."
(let ((x-dnd-tests-xds-include-hostname include-hostname)
(x-dnd-tests-xds-target-dir
(file-name-as-directory (expand-file-name
(make-temp-name "x-dnd-test")
temporary-file-directory)))
(original-file (expand-file-name
(make-temp-name "x-dnd-test")
temporary-file-directory))
(x-dnd-tests-xds-name (make-temp-name "x-dnd-test-target"))
(x-dnd-xds-testing t))
;; The call to `gui-set-selection' is only used for providing the
;; conventional `text/uri-list' target and can be ignored.
(cl-flet ((gui-set-selection #'ignore))
(unwind-protect
(progn
;; Touch `original-file' if it doesn't exist.
(unless (file-exists-p original-file)
(write-region "" 0 original-file))
;; Create `x-dnd-tests-xds-target-dir'.
(make-directory x-dnd-tests-xds-target-dir)
;; Start the direct save and verify it returns the correct action.
(should (eq (x-dnd-do-direct-save original-file
x-dnd-tests-xds-name
nil nil)
'XdndActionDirectSave))
;; Now verify that the new file exists.
(should (file-exists-p
(expand-file-name x-dnd-tests-xds-name
x-dnd-tests-xds-target-dir)))
;; The XDS protocol makes very clear that the window
;; property must be deleted after the drag-and-drop
;; operation completes.
(should (not x-dnd-tests-xds-property-value)))
;; Clean up after ourselves.
(ignore-errors
(delete-file original-file))
(ignore-errors
(delete-directory x-dnd-tests-xds-target-dir t))))))
(ert-deftest x-dnd-tests-do-direct-save ()
;; TODO: add tests for application/octet-stream transfer.
(x-dnd-tests-do-direct-save-internal nil)
;; Test with both kinds of file: URIs, since different programs
;; generate different kinds.
(x-dnd-tests-do-direct-save-internal t))
(provide 'x-dnd-tests)
;;; x-dnd-tests.el ends here
|
