Line data Source code
1 : ;;; x-dnd.el --- drag and drop support for X
2 :
3 : ;; Copyright (C) 2004-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Jan Djärv <jan.h.d@swipnet.se>
6 : ;; Maintainer: emacs-devel@gnu.org
7 : ;; Keywords: window, drag, drop
8 : ;; Package: emacs
9 :
10 : ;; This file is part of GNU Emacs.
11 :
12 : ;; GNU Emacs is free software: you can redistribute it and/or modify
13 : ;; it under the terms of the GNU General Public License as published by
14 : ;; the Free Software Foundation, either version 3 of the License, or
15 : ;; (at your option) any later version.
16 :
17 : ;; GNU Emacs is distributed in the hope that it will be useful,
18 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 : ;; GNU General Public License for more details.
21 :
22 : ;; You should have received a copy of the GNU General Public License
23 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;; This file provides the drop part only. Currently supported protocols
28 : ;; are XDND, Motif and the old KDE 1.x protocol.
29 :
30 : ;;; Code:
31 :
32 : (require 'dnd)
33 :
34 : ;;; Customizable variables
35 : (defcustom x-dnd-test-function 'x-dnd-default-test-function
36 : "The function drag and drop uses to determine if to accept or reject a drop.
37 : The function takes three arguments, WINDOW, ACTION and TYPES.
38 : WINDOW is where the mouse is when the function is called. WINDOW may be a
39 : frame if the mouse isn't over a real window (i.e. menu bar, tool bar or
40 : scroll bar). ACTION is the suggested action from the drag and drop source,
41 : one of the symbols move, copy, link or ask. TYPES is a list of available
42 : types for the drop.
43 :
44 : The function shall return nil to reject the drop or a cons with two values,
45 : the wanted action as car and the wanted type as cdr. The wanted action
46 : can be copy, move, link, ask or private.
47 : The default value for this variable is `x-dnd-default-test-function'."
48 : :version "22.1"
49 : :type 'symbol
50 : :group 'x)
51 :
52 :
53 :
54 : (defcustom x-dnd-types-alist
55 : `(
56 : (,(purecopy "text/uri-list") . x-dnd-handle-uri-list)
57 : (,(purecopy "text/x-moz-url") . x-dnd-handle-moz-url)
58 : (,(purecopy "_NETSCAPE_URL") . x-dnd-handle-uri-list)
59 : (,(purecopy "FILE_NAME") . x-dnd-handle-file-name)
60 : (,(purecopy "UTF8_STRING") . x-dnd-insert-utf8-text)
61 : (,(purecopy "text/plain;charset=UTF-8") . x-dnd-insert-utf8-text)
62 : (,(purecopy "text/plain;charset=utf-8") . x-dnd-insert-utf8-text)
63 : (,(purecopy "text/unicode") . x-dnd-insert-utf16-text)
64 : (,(purecopy "text/plain") . dnd-insert-text)
65 : (,(purecopy "COMPOUND_TEXT") . x-dnd-insert-ctext)
66 : (,(purecopy "STRING") . dnd-insert-text)
67 : (,(purecopy "TEXT") . dnd-insert-text)
68 : )
69 : "Which function to call to handle a drop of that type.
70 : If the type for the drop is not present, or the function is nil,
71 : the drop is rejected. The function takes three arguments, WINDOW, ACTION
72 : and DATA. WINDOW is where the drop occurred, ACTION is the action for
73 : this drop (copy, move, link, private or ask) as determined by a previous
74 : call to `x-dnd-test-function'. DATA is the drop data.
75 : The function shall return the action used (copy, move, link or private)
76 : if drop is successful, nil if not."
77 : :version "22.1"
78 : :type 'alist
79 : :group 'x)
80 :
81 : (defcustom x-dnd-known-types
82 : (mapcar 'purecopy
83 : '("text/uri-list"
84 : "text/x-moz-url"
85 : "_NETSCAPE_URL"
86 : "FILE_NAME"
87 : "UTF8_STRING"
88 : "text/plain;charset=UTF-8"
89 : "text/plain;charset=utf-8"
90 : "text/unicode"
91 : "text/plain"
92 : "COMPOUND_TEXT"
93 : "STRING"
94 : "TEXT"
95 : ))
96 : "The types accepted by default for dropped data.
97 : The types are chosen in the order they appear in the list."
98 : :version "22.1"
99 : :type '(repeat string)
100 : :group 'x
101 : )
102 :
103 : ;; Internal variables
104 :
105 : (defvar x-dnd-current-state nil
106 : "The current state for a drop.
107 : This is an alist with one entry for each display. The value for each display
108 : is a vector that contains the state for drag and drop for that display.
109 : Elements in the vector are:
110 : Last buffer drag was in,
111 : last window drag was in,
112 : types available for drop,
113 : the action suggested by the source,
114 : the type we want for the drop,
115 : the action we want for the drop,
116 : any protocol specific data.")
117 :
118 : (defvar x-dnd-empty-state [nil nil nil nil nil nil nil])
119 :
120 : (declare-function x-register-dnd-atom "xselect.c")
121 :
122 : (defun x-dnd-init-frame (&optional frame)
123 : "Setup drag and drop for FRAME (i.e. create appropriate properties)."
124 0 : (when (eq 'x (window-system frame))
125 0 : (x-register-dnd-atom "DndProtocol" frame)
126 0 : (x-register-dnd-atom "_MOTIF_DRAG_AND_DROP_MESSAGE" frame)
127 0 : (x-register-dnd-atom "XdndEnter" frame)
128 0 : (x-register-dnd-atom "XdndPosition" frame)
129 0 : (x-register-dnd-atom "XdndLeave" frame)
130 0 : (x-register-dnd-atom "XdndDrop" frame)
131 0 : (x-dnd-init-xdnd-for-frame frame)
132 0 : (x-dnd-init-motif-for-frame frame)))
133 :
134 : (defun x-dnd-get-state-cons-for-frame (frame-or-window)
135 : "Return the entry in `x-dnd-current-state' for a frame or window."
136 0 : (let* ((frame (if (framep frame-or-window) frame-or-window
137 0 : (window-frame frame-or-window)))
138 0 : (display (frame-parameter frame 'display)))
139 0 : (if (not (assoc display x-dnd-current-state))
140 0 : (push (cons display (copy-sequence x-dnd-empty-state))
141 0 : x-dnd-current-state))
142 0 : (assoc display x-dnd-current-state)))
143 :
144 : (defun x-dnd-get-state-for-frame (frame-or-window)
145 : "Return the state in `x-dnd-current-state' for a frame or window."
146 0 : (cdr (x-dnd-get-state-cons-for-frame frame-or-window)))
147 :
148 : (defun x-dnd-default-test-function (_window _action types)
149 : "The default test function for drag and drop.
150 : WINDOW is where the mouse is when this function is called. It may be
151 : a frame if the mouse is over the menu bar, scroll bar or tool bar.
152 : ACTION is the suggested action from the source, and TYPES are the
153 : types the drop data can have. This function only accepts drops with
154 : types in `x-dnd-known-types'. It always returns the action private."
155 0 : (let ((type (x-dnd-choose-type types)))
156 0 : (when type (cons 'private type))))
157 :
158 :
159 : (defun x-dnd-current-type (frame-or-window)
160 : "Return the type we want the DND data to be in for the current drop.
161 : FRAME-OR-WINDOW is the frame or window that the mouse is over."
162 0 : (aref (x-dnd-get-state-for-frame frame-or-window) 4))
163 :
164 : (defun x-dnd-forget-drop (frame-or-window)
165 : "Remove all state for the last drop.
166 : FRAME-OR-WINDOW is the frame or window that the mouse is over."
167 0 : (setcdr (x-dnd-get-state-cons-for-frame frame-or-window)
168 0 : (copy-sequence x-dnd-empty-state)))
169 :
170 : (defun x-dnd-maybe-call-test-function (window action)
171 : "Call `x-dnd-test-function' if something has changed.
172 : WINDOW is the window the mouse is over. ACTION is the suggested
173 : action from the source. If nothing has changed, return the last
174 : action and type we got from `x-dnd-test-function'."
175 0 : (let ((buffer (when (window-live-p window)
176 0 : (window-buffer window)))
177 0 : (current-state (x-dnd-get-state-for-frame window)))
178 0 : (unless (and (equal buffer (aref current-state 0))
179 0 : (equal window (aref current-state 1))
180 0 : (equal action (aref current-state 3)))
181 0 : (save-current-buffer
182 0 : (when buffer (set-buffer buffer))
183 0 : (let* ((action-type (funcall x-dnd-test-function
184 0 : window
185 0 : action
186 0 : (aref current-state 2)))
187 0 : (handler (cdr (assoc (cdr action-type) x-dnd-types-alist))))
188 : ;; Ignore action-type if we have no handler.
189 0 : (setq current-state
190 0 : (x-dnd-save-state window
191 0 : action
192 0 : (when handler action-type)))))))
193 0 : (let ((current-state (x-dnd-get-state-for-frame window)))
194 0 : (cons (aref current-state 5)
195 0 : (aref current-state 4))))
196 :
197 : (defun x-dnd-save-state (window action action-type &optional types extra-data)
198 : "Save the state of the current drag and drop.
199 : WINDOW is the window the mouse is over. ACTION is the action suggested
200 : by the source. ACTION-TYPE is the result of calling `x-dnd-test-function'.
201 : If given, TYPES are the types for the drop data that the source supports.
202 : EXTRA-DATA is data needed for a specific protocol."
203 0 : (let ((current-state (x-dnd-get-state-for-frame window)))
204 0 : (aset current-state 5 (car action-type))
205 0 : (aset current-state 4 (cdr action-type))
206 0 : (aset current-state 3 action)
207 0 : (when types (aset current-state 2 types))
208 0 : (when extra-data (aset current-state 6 extra-data))
209 0 : (aset current-state 1 window)
210 0 : (aset current-state 0 (and (window-live-p window) (window-buffer window)))
211 0 : (setcdr (x-dnd-get-state-cons-for-frame window) current-state)))
212 :
213 :
214 : (defun x-dnd-handle-moz-url (window action data)
215 : "Handle one item of type text/x-moz-url.
216 : WINDOW is the window where the drop happened. ACTION is ignored.
217 : DATA is the moz-url, which is formatted as two strings separated by \\r\\n.
218 : The first string is the URL, the second string is the title of that URL.
219 : DATA is encoded in utf-16. Decode the URL and call `x-dnd-handle-uri-list'."
220 : ;; Mozilla and applications based on it use text/unicode, but it is
221 : ;; impossible to tell if it is le or be. Use what the machine Emacs
222 : ;; runs on uses. This loses if dropping between machines
223 : ;; with different endian-ness, but it is the best we can do.
224 0 : (let* ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le))
225 0 : (string (decode-coding-string data coding))
226 0 : (strings (split-string string "[\r\n]" t))
227 : ;; Can one drop more than one moz-url ?? Assume not.
228 0 : (url (car strings)))
229 0 : (x-dnd-handle-uri-list window action url)))
230 :
231 : (defun x-dnd-insert-utf8-text (window action text)
232 : "Decode the UTF-8 text and insert it at point.
233 : TEXT is the text as a string, WINDOW is the window where the drop happened."
234 0 : (dnd-insert-text window action (decode-coding-string text 'utf-8)))
235 :
236 : (defun x-dnd-insert-utf16-text (window action text)
237 : "Decode the UTF-16 text and insert it at point.
238 : TEXT is the text as a string, WINDOW is the window where the drop happened."
239 : ;; See comment in x-dnd-handle-moz-url about coding.
240 0 : (let ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)))
241 0 : (dnd-insert-text window action (decode-coding-string text coding))))
242 :
243 : (defun x-dnd-insert-ctext (window action text)
244 : "Decode the compound text and insert it at point.
245 : TEXT is the text as a string, WINDOW is the window where the drop happened."
246 0 : (dnd-insert-text window action
247 0 : (decode-coding-string text
248 0 : 'compound-text-with-extensions)))
249 :
250 : (defun x-dnd-handle-uri-list (window action string)
251 : "Split an uri-list into separate URIs and call `dnd-handle-one-url'.
252 : WINDOW is the window where the drop happened.
253 : STRING is the uri-list as a string. The URIs are separated by \\r\\n."
254 0 : (let ((uri-list (split-string string "[\0\r\n]" t))
255 : retval)
256 0 : (dolist (bf uri-list)
257 : ;; If one URL is handled, treat as if the whole drop succeeded.
258 0 : (let ((did-action (dnd-handle-one-url window action bf)))
259 0 : (when did-action (setq retval did-action))))
260 0 : retval))
261 :
262 : (defun x-dnd-handle-file-name (window action string)
263 : "Convert file names to URLs and call `dnd-handle-one-url'.
264 : WINDOW is the window where the drop happened.
265 : STRING is the file names as a string, separated by nulls."
266 0 : (let ((uri-list (split-string string "[\0\r\n]" t))
267 0 : (coding (and (default-value 'enable-multibyte-characters)
268 0 : (or file-name-coding-system
269 0 : default-file-name-coding-system)))
270 : retval)
271 0 : (dolist (bf uri-list)
272 : ;; If one URL is handled, treat as if the whole drop succeeded.
273 0 : (if coding (setq bf (encode-coding-string bf coding)))
274 0 : (let* ((file-uri (concat "file://"
275 0 : (mapconcat 'url-hexify-string
276 0 : (split-string bf "/") "/")))
277 0 : (did-action (dnd-handle-one-url window action file-uri)))
278 0 : (when did-action (setq retval did-action))))
279 0 : retval))
280 :
281 :
282 : (defun x-dnd-choose-type (types &optional known-types)
283 : "Choose which type we want to receive for the drop.
284 : TYPES are the types the source of the drop offers, a vector of type names
285 : as strings or symbols. Select among the types in `x-dnd-known-types' or
286 : KNOWN-TYPES if given, and return that type name.
287 : If no suitable type is found, return nil."
288 0 : (let* ((known-list (or known-types x-dnd-known-types))
289 0 : (first-known-type (car known-list))
290 0 : (types-array types)
291 0 : (found (when first-known-type
292 0 : (catch 'done
293 0 : (dotimes (i (length types-array))
294 0 : (let* ((type (aref types-array i))
295 0 : (typename (if (symbolp type)
296 0 : (symbol-name type) type)))
297 0 : (when (equal first-known-type typename)
298 0 : (throw 'done first-known-type))))
299 0 : nil))))
300 :
301 0 : (if (and (not found) (cdr known-list))
302 0 : (x-dnd-choose-type types (cdr known-list))
303 0 : found)))
304 :
305 : (defun x-dnd-drop-data (event frame window data type)
306 : "Drop one data item onto a frame.
307 : EVENT is the client message for the drop, FRAME is the frame the drop
308 : occurred on. WINDOW is the window of FRAME where the drop happened.
309 : DATA is the data received from the source, and type is the type for DATA,
310 : see `x-dnd-types-alist').
311 :
312 : Returns the action used (move, copy, link, private) if drop was successful,
313 : nil if not."
314 0 : (let* ((type-info (assoc type x-dnd-types-alist))
315 0 : (handler (cdr type-info))
316 0 : (state (x-dnd-get-state-for-frame frame))
317 0 : (action (aref state 5))
318 0 : (w (posn-window (event-start event))))
319 0 : (when handler
320 0 : (if (and (window-live-p w)
321 0 : (not (window-minibuffer-p w))
322 0 : (not (window-dedicated-p w)))
323 : ;; If dropping in an ordinary window which we could use,
324 : ;; let dnd-open-file-other-window specify what to do.
325 0 : (progn
326 0 : (when (not mouse-yank-at-point)
327 0 : (goto-char (posn-point (event-start event))))
328 0 : (funcall handler window action data))
329 : ;; If we can't display the file here,
330 : ;; make a new window for it.
331 0 : (let ((dnd-open-file-other-window t))
332 0 : (select-frame frame)
333 0 : (funcall handler window action data))))))
334 :
335 : (defun x-dnd-handle-drag-n-drop-event (event)
336 : "Receive drag and drop events (X client messages).
337 : Currently XDND, Motif and old KDE 1.x protocols are recognized."
338 : (interactive "e")
339 0 : (let* ((client-message (car (cdr (cdr event))))
340 0 : (window (posn-window (event-start event)))
341 0 : (message-atom (aref client-message 0))
342 0 : (frame (aref client-message 1))
343 0 : (format (aref client-message 2))
344 0 : (data (aref client-message 3)))
345 :
346 0 : (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x.
347 0 : (x-dnd-handle-old-kde event frame window message-atom format data))
348 :
349 0 : ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif
350 0 : (x-dnd-handle-motif event frame window message-atom format data))
351 :
352 0 : ((and (> (length message-atom) 4) ; XDND protocol.
353 0 : (equal "Xdnd" (substring message-atom 0 4)))
354 0 : (x-dnd-handle-xdnd event frame window message-atom format data)))))
355 :
356 :
357 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
358 : ;;; Old KDE protocol. Only dropping of files.
359 :
360 : (declare-function x-window-property "xfns.c"
361 : (prop &optional frame type source delete-p vector-ret-p))
362 :
363 : (defun x-dnd-handle-old-kde (_event frame window _message _format _data)
364 : "Open the files in a KDE 1.x drop."
365 0 : (let ((values (x-window-property "DndSelection" frame nil 0 t)))
366 0 : (x-dnd-handle-uri-list window 'private
367 0 : (replace-regexp-in-string "\0$" "" values))))
368 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
369 :
370 :
371 :
372 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
373 : ;;; XDND protocol.
374 :
375 : (defconst x-dnd-xdnd-to-action
376 : '(("XdndActionPrivate" . private)
377 : ("XdndActionCopy" . copy)
378 : ("XdndActionMove" . move)
379 : ("XdndActionLink" . link)
380 : ("XdndActionAsk" . ask))
381 : "Mapping from XDND action types to lisp symbols.")
382 :
383 : (declare-function x-change-window-property "xfns.c"
384 : (prop value &optional frame type format outer-P))
385 :
386 : (defun x-dnd-init-xdnd-for-frame (frame)
387 : "Set the XdndAware property for FRAME to indicate that we do XDND."
388 0 : (x-change-window-property "XdndAware"
389 : '(5) ;; The version of XDND we support.
390 0 : frame "ATOM" 32 t))
391 :
392 : (defun x-dnd-get-drop-width-height (frame w accept)
393 : "Return the width/height to be sent in a XDndStatus message.
394 : FRAME is the frame and W is the window where the drop happened.
395 : If ACCEPT is nil return 0 (empty rectangle),
396 : otherwise if W is a window, return its width/height,
397 : otherwise return the frame width/height."
398 0 : (if accept
399 0 : (if (windowp w) ;; w is not a window if dropping on the menu bar,
400 : ;; scroll bar or tool bar.
401 0 : (let ((edges (window-inside-pixel-edges w)))
402 0 : (cons
403 0 : (- (nth 2 edges) (nth 0 edges)) ;; right - left
404 0 : (- (nth 3 edges) (nth 1 edges)))) ;; bottom - top
405 0 : (cons (frame-pixel-width frame)
406 0 : (frame-pixel-height frame)))
407 0 : 0))
408 :
409 : (defun x-dnd-get-drop-x-y (frame w)
410 : "Return the x/y coordinates to be sent in a XDndStatus message.
411 : Coordinates are required to be absolute.
412 : FRAME is the frame and W is the window where the drop happened.
413 : If W is a window, return its absolute coordinates,
414 : otherwise return the frame coordinates."
415 0 : (let* ((frame-left (frame-parameter frame 'left))
416 : ;; If the frame is outside the display, frame-left looks like
417 : ;; '(0 -16). Extract the -16.
418 0 : (frame-real-left (if (consp frame-left) (car (cdr frame-left))
419 0 : frame-left))
420 0 : (frame-top (frame-parameter frame 'top))
421 0 : (frame-real-top (if (consp frame-top) (car (cdr frame-top))
422 0 : frame-top)))
423 0 : (if (windowp w)
424 0 : (let ((edges (window-inside-pixel-edges w)))
425 0 : (cons
426 0 : (+ frame-real-left (nth 0 edges))
427 0 : (+ frame-real-top (nth 1 edges))))
428 0 : (cons frame-real-left frame-real-top))))
429 :
430 : (declare-function x-get-atom-name "xselect.c" (value &optional frame))
431 : (declare-function x-send-client-message "xselect.c"
432 : (display dest from message-type format values))
433 : (declare-function x-get-selection-internal "xselect.c"
434 : (selection-symbol target-type &optional time-stamp terminal))
435 :
436 : (defun x-dnd-version-from-flags (flags)
437 : "Return the version byte from the 32 bit FLAGS in an XDndEnter message"
438 0 : (if (consp flags) ;; Long as cons
439 0 : (ash (car flags) -8)
440 0 : (ash flags -24))) ;; Ordinary number
441 :
442 : (defun x-dnd-more-than-3-from-flags (flags)
443 : "Return the nmore-than3 bit from the 32 bit FLAGS in an XDndEnter message"
444 0 : (if (consp flags)
445 0 : (logand (cdr flags) 1)
446 0 : (logand flags 1)))
447 :
448 : (defun x-dnd-handle-xdnd (event frame window message _format data)
449 : "Receive one XDND event (client message) and send the appropriate reply.
450 : EVENT is the client message. FRAME is where the mouse is now.
451 : WINDOW is the window within FRAME where the mouse is now.
452 : FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent."
453 0 : (cond ((equal "XdndEnter" message)
454 0 : (let* ((flags (aref data 1))
455 0 : (version (x-dnd-version-from-flags flags))
456 0 : (more-than-3 (x-dnd-more-than-3-from-flags flags))
457 0 : (dnd-source (aref data 0)))
458 0 : (message "%s %s" version more-than-3)
459 0 : (if version ;; If flags is bad, version will be nil.
460 0 : (x-dnd-save-state
461 0 : window nil nil
462 0 : (if (> more-than-3 0)
463 0 : (x-window-property "XdndTypeList"
464 0 : frame "AnyPropertyType"
465 0 : dnd-source nil t)
466 0 : (vector (x-get-atom-name (aref data 2))
467 0 : (x-get-atom-name (aref data 3))
468 0 : (x-get-atom-name (aref data 4))))))))
469 :
470 0 : ((equal "XdndPosition" message)
471 0 : (let* ((action (x-get-atom-name (aref data 4)))
472 0 : (dnd-source (aref data 0))
473 0 : (action-type (x-dnd-maybe-call-test-function
474 0 : window
475 0 : (cdr (assoc action x-dnd-xdnd-to-action))))
476 0 : (reply-action (car (rassoc (car action-type)
477 0 : x-dnd-xdnd-to-action)))
478 : (accept ;; 1 = accept, 0 = reject
479 0 : (if (and reply-action action-type) 1 0))
480 : (list-to-send
481 0 : (list (string-to-number
482 0 : (frame-parameter frame 'outer-window-id))
483 0 : accept ;; 1 = Accept, 0 = reject.
484 0 : (x-dnd-get-drop-x-y frame window)
485 0 : (x-dnd-get-drop-width-height
486 0 : frame window (eq accept 1))
487 0 : (or reply-action 0)
488 0 : )))
489 0 : (x-send-client-message
490 0 : frame dnd-source frame "XdndStatus" 32 list-to-send)
491 0 : ))
492 :
493 0 : ((equal "XdndLeave" message)
494 0 : (x-dnd-forget-drop window))
495 :
496 0 : ((equal "XdndDrop" message)
497 0 : (if (windowp window) (select-window window))
498 0 : (let* ((dnd-source (aref data 0))
499 0 : (value (and (x-dnd-current-type window)
500 0 : (x-get-selection-internal
501 : 'XdndSelection
502 0 : (intern (x-dnd-current-type window)))))
503 : success action)
504 :
505 0 : (setq action (if value
506 0 : (condition-case info
507 0 : (x-dnd-drop-data event frame window value
508 0 : (x-dnd-current-type window))
509 : (error
510 0 : (message "Error: %s" info)
511 0 : nil))))
512 :
513 0 : (setq success (if action 1 0))
514 :
515 0 : (x-send-client-message
516 0 : frame dnd-source frame "XdndFinished" 32
517 0 : (list (string-to-number (frame-parameter frame 'outer-window-id))
518 0 : success ;; 1 = Success, 0 = Error
519 0 : (if success "XdndActionPrivate" 0)
520 0 : ))
521 0 : (x-dnd-forget-drop window)))
522 :
523 0 : (t (error "Unknown XDND message %s %s" message data))))
524 :
525 : ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
526 : ;;; Motif protocol.
527 :
528 : (defun x-dnd-init-motif-for-frame (frame)
529 : "Set _MOTIF_DRAG_RECEIVER_INFO for FRAME to indicate that we do Motif DND."
530 0 : (x-change-window-property "_MOTIF_DRAG_RECEIVER_INFO"
531 0 : (list
532 0 : (byteorder)
533 : 0 ; The Motif DND version.
534 : 5 ; We want drag dynamic.
535 : 0 0 0 0 0 0 0
536 0 : 0 0 0 0 0 0) ; Property must be 16 bytes.
537 0 : frame "_MOTIF_DRAG_RECEIVER_INFO" 8 t))
538 :
539 : (defun x-dnd-get-motif-value (data offset size byteorder)
540 0 : (cond ((eq size 2)
541 0 : (if (eq byteorder ?l)
542 0 : (+ (ash (aref data (1+ offset)) 8)
543 0 : (aref data offset))
544 0 : (+ (ash (aref data offset) 8)
545 0 : (aref data (1+ offset)))))
546 :
547 0 : ((eq size 4)
548 0 : (if (eq byteorder ?l)
549 0 : (cons (+ (ash (aref data (+ 3 offset)) 8)
550 0 : (aref data (+ 2 offset)))
551 0 : (+ (ash (aref data (1+ offset)) 8)
552 0 : (aref data offset)))
553 0 : (cons (+ (ash (aref data offset) 8)
554 0 : (aref data (1+ offset)))
555 0 : (+ (ash (aref data (+ 2 offset)) 8)
556 0 : (aref data (+ 3 offset))))))))
557 :
558 : (defun x-dnd-motif-value-to-list (value size byteorder)
559 0 : (let ((bytes (cond ((eq size 2)
560 0 : (list (logand (lsh value -8) ?\xff)
561 0 : (logand value ?\xff)))
562 :
563 0 : ((eq size 4)
564 0 : (if (consp value)
565 0 : (list (logand (lsh (car value) -8) ?\xff)
566 0 : (logand (car value) ?\xff)
567 0 : (logand (lsh (cdr value) -8) ?\xff)
568 0 : (logand (cdr value) ?\xff))
569 0 : (list (logand (lsh value -24) ?\xff)
570 0 : (logand (lsh value -16) ?\xff)
571 0 : (logand (lsh value -8) ?\xff)
572 0 : (logand value ?\xff)))))))
573 0 : (if (eq byteorder ?l)
574 0 : (reverse bytes)
575 0 : bytes)))
576 :
577 :
578 : (defvar x-dnd-motif-message-types
579 : '((0 . XmTOP_LEVEL_ENTER)
580 : (1 . XmTOP_LEVEL_LEAVE)
581 : (2 . XmDRAG_MOTION)
582 : (3 . XmDROP_SITE_ENTER)
583 : (4 . XmDROP_SITE_LEAVE)
584 : (5 . XmDROP_START)
585 : (6 . XmDROP_FINISH)
586 : (7 . XmDRAG_DROP_FINISH)
587 : (8 . XmOPERATION_CHANGED))
588 : "Mapping from numbers to Motif DND message types.")
589 :
590 : (defvar x-dnd-motif-to-action
591 : '((1 . move)
592 : (2 . copy)
593 : (3 . link) ; Both 3 and 4 has been seen as link.
594 : (4 . link)
595 : (2 . private)) ; Motif does not have private, so use copy for private.
596 : "Mapping from number to operation for Motif DND.")
597 :
598 : (defun x-dnd-handle-motif (event frame window message-atom _format data)
599 0 : (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types)))
600 0 : (source-byteorder (aref data 1))
601 0 : (my-byteorder (byteorder))
602 0 : (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder))
603 0 : (source-action (cdr (assoc (logand ?\xF source-flags)
604 0 : x-dnd-motif-to-action))))
605 :
606 0 : (cond ((eq message-type 'XmTOP_LEVEL_ENTER)
607 0 : (let* ((dnd-source (x-dnd-get-motif-value
608 0 : data 8 4 source-byteorder))
609 0 : (selection-atom (x-dnd-get-motif-value
610 0 : data 12 4 source-byteorder))
611 0 : (atom-name (x-get-atom-name selection-atom))
612 0 : (types (when atom-name
613 0 : (x-get-selection-internal (intern atom-name)
614 0 : 'TARGETS))))
615 0 : (x-dnd-forget-drop frame)
616 0 : (when types (x-dnd-save-state window nil nil
617 0 : types
618 0 : dnd-source))))
619 :
620 : ;; Can not forget drop here, LEAVE comes before DROP_START and
621 : ;; we need the state in DROP_START.
622 0 : ((eq message-type 'XmTOP_LEVEL_LEAVE)
623 : nil)
624 :
625 0 : ((eq message-type 'XmDRAG_MOTION)
626 0 : (let* ((state (x-dnd-get-state-for-frame frame))
627 0 : (timestamp (x-dnd-motif-value-to-list
628 0 : (x-dnd-get-motif-value data 4 4
629 0 : source-byteorder)
630 0 : 4 my-byteorder))
631 0 : (x (x-dnd-motif-value-to-list
632 0 : (x-dnd-get-motif-value data 8 2 source-byteorder)
633 0 : 2 my-byteorder))
634 0 : (y (x-dnd-motif-value-to-list
635 0 : (x-dnd-get-motif-value data 10 2 source-byteorder)
636 0 : 2 my-byteorder))
637 0 : (dnd-source (aref state 6))
638 0 : (first-move (not (aref state 3)))
639 0 : (action-type (x-dnd-maybe-call-test-function
640 0 : window
641 0 : source-action))
642 0 : (reply-action (car (rassoc (car action-type)
643 0 : x-dnd-motif-to-action)))
644 : (reply-flags
645 0 : (x-dnd-motif-value-to-list
646 0 : (if reply-action
647 0 : (+ reply-action
648 : ?\x30 ; 30: valid drop site
649 0 : ?\x700) ; 700: can do copy, move or link
650 0 : ?\x30) ; 30: drop site, but noop.
651 0 : 2 my-byteorder))
652 0 : (reply (append
653 0 : (list
654 0 : (+ ?\x80 ; 0x80 indicates a reply.
655 0 : (if first-move
656 : 3 ; First time, reply is SITE_ENTER.
657 0 : 2)) ; Not first time, reply is DRAG_MOTION.
658 0 : my-byteorder)
659 0 : reply-flags
660 0 : timestamp
661 0 : x
662 0 : y)))
663 0 : (x-send-client-message frame
664 0 : dnd-source
665 0 : frame
666 : "_MOTIF_DRAG_AND_DROP_MESSAGE"
667 : 8
668 0 : reply)))
669 :
670 0 : ((eq message-type 'XmOPERATION_CHANGED)
671 0 : (let* ((state (x-dnd-get-state-for-frame frame))
672 0 : (timestamp (x-dnd-motif-value-to-list
673 0 : (x-dnd-get-motif-value data 4 4 source-byteorder)
674 0 : 4 my-byteorder))
675 0 : (dnd-source (aref state 6))
676 0 : (action-type (x-dnd-maybe-call-test-function
677 0 : window
678 0 : source-action))
679 0 : (reply-action (car (rassoc (car action-type)
680 0 : x-dnd-motif-to-action)))
681 : (reply-flags
682 0 : (x-dnd-motif-value-to-list
683 0 : (if reply-action
684 0 : (+ reply-action
685 : ?\x30 ; 30: valid drop site
686 0 : ?\x700) ; 700: can do copy, move or link
687 0 : ?\x30) ; 30: drop site, but noop
688 0 : 2 my-byteorder))
689 0 : (reply (append
690 0 : (list
691 0 : (+ ?\x80 ; 0x80 indicates a reply.
692 0 : 8) ; 8 is OPERATION_CHANGED
693 0 : my-byteorder)
694 0 : reply-flags
695 0 : timestamp)))
696 0 : (x-send-client-message frame
697 0 : dnd-source
698 0 : frame
699 : "_MOTIF_DRAG_AND_DROP_MESSAGE"
700 : 8
701 0 : reply)))
702 :
703 0 : ((eq message-type 'XmDROP_START)
704 0 : (let* ((x (x-dnd-motif-value-to-list
705 0 : (x-dnd-get-motif-value data 8 2 source-byteorder)
706 0 : 2 my-byteorder))
707 0 : (y (x-dnd-motif-value-to-list
708 0 : (x-dnd-get-motif-value data 10 2 source-byteorder)
709 0 : 2 my-byteorder))
710 0 : (selection-atom (x-dnd-get-motif-value
711 0 : data 12 4 source-byteorder))
712 0 : (atom-name (x-get-atom-name selection-atom))
713 0 : (dnd-source (x-dnd-get-motif-value
714 0 : data 16 4 source-byteorder))
715 0 : (action-type (x-dnd-maybe-call-test-function
716 0 : window
717 0 : source-action))
718 0 : (reply-action (car (rassoc (car action-type)
719 0 : x-dnd-motif-to-action)))
720 : (reply-flags
721 0 : (x-dnd-motif-value-to-list
722 0 : (if reply-action
723 0 : (+ reply-action
724 : ?\x30 ; 30: valid drop site
725 0 : ?\x700) ; 700: can do copy, move or link
726 0 : (+ ?\x30 ; 30: drop site, but noop.
727 0 : ?\x200)) ; 200: drop cancel.
728 0 : 2 my-byteorder))
729 0 : (reply (append
730 0 : (list
731 0 : (+ ?\x80 ; 0x80 indicates a reply.
732 0 : 5) ; DROP_START.
733 0 : my-byteorder)
734 0 : reply-flags
735 0 : x
736 0 : y))
737 0 : (timestamp (x-dnd-get-motif-value
738 0 : data 4 4 source-byteorder))
739 : action)
740 :
741 0 : (x-send-client-message frame
742 0 : dnd-source
743 0 : frame
744 : "_MOTIF_DRAG_AND_DROP_MESSAGE"
745 : 8
746 0 : reply)
747 0 : (setq action
748 0 : (when (and reply-action atom-name)
749 0 : (let* ((value (x-get-selection-internal
750 0 : (intern atom-name)
751 0 : (intern (x-dnd-current-type window)))))
752 0 : (when value
753 0 : (condition-case info
754 0 : (x-dnd-drop-data event frame window value
755 0 : (x-dnd-current-type window))
756 : (error
757 0 : (message "Error: %s" info)
758 0 : nil))))))
759 0 : (x-get-selection-internal
760 0 : (intern atom-name)
761 0 : (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE)
762 0 : timestamp)
763 0 : (x-dnd-forget-drop frame)))
764 :
765 0 : (t (error "Unknown Motif DND message %s %s" message-atom data)))))
766 :
767 :
768 : ;;;
769 :
770 : (provide 'x-dnd)
771 :
772 : ;;; x-dnd.el ends here
|