Commit | Line | Data |
---|---|---|
e9dc55ba | 1 | ;;; x-dnd.el --- drag and drop support for X -*- coding: utf-8 -*- |
133aad74 | 2 | |
ba318903 | 3 | ;; Copyright (C) 2004-2014 Free Software Foundation, Inc. |
133aad74 | 4 | |
e9dc55ba | 5 | ;; Author: Jan Djärv <jan.h.d@swipnet.se> |
34dc21db | 6 | ;; Maintainer: emacs-devel@gnu.org |
133aad74 | 7 | ;; Keywords: window, drag, drop |
bd78fa1d | 8 | ;; Package: emacs |
133aad74 JD |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
eb3fa2cf | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
133aad74 | 13 | ;; it under the terms of the GNU General Public License as published by |
eb3fa2cf GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
133aad74 JD |
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 | |
eb3fa2cf | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
133aad74 JD |
24 | |
25 | ;;; Commentary: | |
26 | ||
27 | ;; This file provides the drop part only. Currently supported protocols | |
49f87d23 | 28 | ;; are XDND, Motif and the old KDE 1.x protocol. |
133aad74 JD |
29 | |
30 | ;;; Code: | |
31 | ||
67988557 | 32 | (require 'dnd) |
133aad74 | 33 | |
67988557 | 34 | ;;; Customizable variables |
133aad74 JD |
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. | |
cd07aa70 | 37 | The function takes three arguments, WINDOW, ACTION and TYPES. |
133aad74 JD |
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, | |
cd07aa70 JB |
41 | one of the symbols move, copy, link or ask. TYPES is a list of available |
42 | types for the drop. | |
133aad74 JD |
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'." | |
bf247b6e | 48 | :version "22.1" |
133aad74 JD |
49 | :type 'symbol |
50 | :group 'x) | |
51 | ||
133aad74 JD |
52 | |
53 | ||
54 | (defcustom x-dnd-types-alist | |
a7610c52 DN |
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) | |
133aad74 JD |
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 | |
bacbcea9 | 72 | and DATA. WINDOW is where the drop occurred, ACTION is the action for |
133aad74 JD |
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. | |
cd07aa70 JB |
75 | The function shall return the action used (copy, move, link or private) |
76 | if drop is successful, nil if not." | |
bf247b6e | 77 | :version "22.1" |
133aad74 JD |
78 | :type 'alist |
79 | :group 'x) | |
80 | ||
7a01b040 | 81 | (defcustom x-dnd-known-types |
1e8780b1 | 82 | (mapcar 'purecopy |
133aad74 JD |
83 | '("text/uri-list" |
84 | "text/x-moz-url" | |
133aad74 | 85 | "_NETSCAPE_URL" |
b9aafad5 | 86 | "FILE_NAME" |
133aad74 JD |
87 | "UTF8_STRING" |
88 | "text/plain;charset=UTF-8" | |
89 | "text/plain;charset=utf-8" | |
90 | "text/unicode" | |
91 | "text/plain" | |
b9aafad5 | 92 | "COMPOUND_TEXT" |
133aad74 JD |
93 | "STRING" |
94 | "TEXT" | |
1e8780b1 | 95 | )) |
133aad74 | 96 | "The types accepted by default for dropped data. |
7a01b040 | 97 | The types are chosen in the order they appear in the list." |
bf247b6e | 98 | :version "22.1" |
7a01b040 JD |
99 | :type '(repeat string) |
100 | :group 'x | |
101 | ) | |
102 | ||
103 | ;; Internal variables | |
133aad74 JD |
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. | |
bf247b6e | 109 | Elements in the vector are: |
133aad74 JD |
110 | Last buffer drag was in, |
111 | last window drag was in, | |
bf247b6e | 112 | types available for drop, |
133aad74 JD |
113 | the action suggested by the source, |
114 | the type we want for the drop, | |
b9aafad5 JD |
115 | the action we want for the drop, |
116 | any protocol specific data.") | |
133aad74 | 117 | |
b9aafad5 | 118 | (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) |
133aad74 | 119 | |
cc63039e | 120 | (declare-function x-register-dnd-atom "xselect.c") |
133aad74 JD |
121 | |
122 | (defun x-dnd-init-frame (&optional frame) | |
123 | "Setup drag and drop for FRAME (i.e. create appropriate properties)." | |
029f9b85 | 124 | (when (eq 'x (window-system frame)) |
3f87f67e KL |
125 | (x-register-dnd-atom "DndProtocol" frame) |
126 | (x-register-dnd-atom "_MOTIF_DRAG_AND_DROP_MESSAGE" frame) | |
127 | (x-register-dnd-atom "XdndEnter" frame) | |
128 | (x-register-dnd-atom "XdndPosition" frame) | |
129 | (x-register-dnd-atom "XdndLeave" frame) | |
130 | (x-register-dnd-atom "XdndDrop" frame) | |
029f9b85 KL |
131 | (x-dnd-init-xdnd-for-frame frame) |
132 | (x-dnd-init-motif-for-frame frame))) | |
133aad74 JD |
133 | |
134 | (defun x-dnd-get-state-cons-for-frame (frame-or-window) | |
cd07aa70 | 135 | "Return the entry in `x-dnd-current-state' for a frame or window." |
133aad74 JD |
136 | (let* ((frame (if (framep frame-or-window) frame-or-window |
137 | (window-frame frame-or-window))) | |
138 | (display (frame-parameter frame 'display))) | |
139 | (if (not (assoc display x-dnd-current-state)) | |
b9aafad5 JD |
140 | (push (cons display (copy-sequence x-dnd-empty-state)) |
141 | x-dnd-current-state)) | |
133aad74 JD |
142 | (assoc display x-dnd-current-state))) |
143 | ||
144 | (defun x-dnd-get-state-for-frame (frame-or-window) | |
cd07aa70 | 145 | "Return the state in `x-dnd-current-state' for a frame or window." |
133aad74 JD |
146 | (cdr (x-dnd-get-state-cons-for-frame frame-or-window))) |
147 | ||
06b60517 | 148 | (defun x-dnd-default-test-function (_window _action types) |
133aad74 | 149 | "The default test function for drag and drop. |
cd07aa70 JB |
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. | |
133aad74 JD |
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 | (let ((type (x-dnd-choose-type types))) | |
156 | (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 | (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." | |
b9aafad5 JD |
167 | (setcdr (x-dnd-get-state-cons-for-frame frame-or-window) |
168 | (copy-sequence x-dnd-empty-state))) | |
133aad74 JD |
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'." | |
011acd18 | 175 | (let ((buffer (when (window-live-p window) |
133aad74 JD |
176 | (window-buffer window))) |
177 | (current-state (x-dnd-get-state-for-frame window))) | |
7fdbcd83 SM |
178 | (unless (and (equal buffer (aref current-state 0)) |
179 | (equal window (aref current-state 1)) | |
180 | (equal action (aref current-state 3))) | |
181 | (save-current-buffer | |
133aad74 JD |
182 | (when buffer (set-buffer buffer)) |
183 | (let* ((action-type (funcall x-dnd-test-function | |
184 | window | |
185 | action | |
186 | (aref current-state 2))) | |
187 | (handler (cdr (assoc (cdr action-type) x-dnd-types-alist)))) | |
188 | ;; Ignore action-type if we have no handler. | |
189 | (setq current-state | |
bf247b6e | 190 | (x-dnd-save-state window |
133aad74 JD |
191 | action |
192 | (when handler action-type))))))) | |
193 | (let ((current-state (x-dnd-get-state-for-frame window))) | |
194 | (cons (aref current-state 5) | |
195 | (aref current-state 4)))) | |
196 | ||
b9aafad5 | 197 | (defun x-dnd-save-state (window action action-type &optional types extra-data) |
133aad74 JD |
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'. | |
b9aafad5 JD |
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." | |
133aad74 JD |
203 | (let ((current-state (x-dnd-get-state-for-frame window))) |
204 | (aset current-state 5 (car action-type)) | |
205 | (aset current-state 4 (cdr action-type)) | |
206 | (aset current-state 3 action) | |
b9aafad5 JD |
207 | (when types (aset current-state 2 types)) |
208 | (when extra-data (aset current-state 6 extra-data)) | |
133aad74 | 209 | (aset current-state 1 window) |
011acd18 | 210 | (aset current-state 0 (and (window-live-p window) (window-buffer window))) |
133aad74 JD |
211 | (setcdr (x-dnd-get-state-cons-for-frame window) current-state))) |
212 | ||
213 | ||
133aad74 JD |
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. | |
cd07aa70 | 217 | DATA is the moz-url, which is formatted as two strings separated by \\r\\n. |
133aad74 JD |
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'." | |
bcfa9925 JD |
220 | ;; Mozilla and applications based on it (Galeon for example) uses |
221 | ;; text/unicode, but it is impossible to tell if it is le or be. Use what | |
537b04b9 | 222 | ;; the machine Emacs runs on use. This loses if dropping between machines |
bcfa9925 JD |
223 | ;; with different endian, but it is the best we can do. |
224 | (let* ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)) | |
225 | (string (decode-coding-string data coding)) | |
133aad74 JD |
226 | (strings (split-string string "[\r\n]" t)) |
227 | ;; Can one drop more than one moz-url ?? Assume not. | |
06b60517 | 228 | (url (car strings))) |
133aad74 JD |
229 | (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." | |
67988557 | 234 | (dnd-insert-text window action (decode-coding-string text 'utf-8))) |
133aad74 JD |
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." | |
bcfa9925 JD |
239 | ;; See comment in x-dnd-handle-moz-url about coding. |
240 | (let ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le))) | |
67988557 | 241 | (dnd-insert-text window action (decode-coding-string text coding)))) |
133aad74 | 242 | |
b9aafad5 JD |
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." | |
67988557 JD |
246 | (dnd-insert-text window action |
247 | (decode-coding-string text | |
248 | 'compound-text-with-extensions))) | |
133aad74 JD |
249 | |
250 | (defun x-dnd-handle-uri-list (window action string) | |
67988557 | 251 | "Split an uri-list into separate URIs and call `dnd-handle-one-url'. |
133aad74 | 252 | WINDOW is the window where the drop happened. |
cd07aa70 | 253 | STRING is the uri-list as a string. The URIs are separated by \\r\\n." |
133aad74 JD |
254 | (let ((uri-list (split-string string "[\0\r\n]" t)) |
255 | retval) | |
256 | (dolist (bf uri-list) | |
cd07aa70 | 257 | ;; If one URL is handled, treat as if the whole drop succeeded. |
67988557 | 258 | (let ((did-action (dnd-handle-one-url window action bf))) |
133aad74 JD |
259 | (when did-action (setq retval did-action)))) |
260 | retval)) | |
261 | ||
b9aafad5 | 262 | (defun x-dnd-handle-file-name (window action string) |
f9be433c | 263 | "Convert file names to URLs and call `dnd-handle-one-url'. |
b9aafad5 JD |
264 | WINDOW is the window where the drop happened. |
265 | STRING is the file names as a string, separated by nulls." | |
266 | (let ((uri-list (split-string string "[\0\r\n]" t)) | |
597e2240 | 267 | (coding (and (default-value 'enable-multibyte-characters) |
f9be433c YM |
268 | (or file-name-coding-system |
269 | default-file-name-coding-system))) | |
b9aafad5 JD |
270 | retval) |
271 | (dolist (bf uri-list) | |
cd07aa70 | 272 | ;; If one URL is handled, treat as if the whole drop succeeded. |
f9be433c YM |
273 | (if coding (setq bf (encode-coding-string bf coding))) |
274 | (let* ((file-uri (concat "file://" | |
275 | (mapconcat 'url-hexify-string | |
276 | (split-string bf "/") "/"))) | |
67988557 | 277 | (did-action (dnd-handle-one-url window action file-uri))) |
b9aafad5 JD |
278 | (when did-action (setq retval did-action)))) |
279 | retval)) | |
280 | ||
133aad74 JD |
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 | |
cd07aa70 | 286 | KNOWN-TYPES if given, and return that type name. |
133aad74 JD |
287 | If no suitable type is found, return nil." |
288 | (let* ((known-list (or known-types x-dnd-known-types)) | |
289 | (first-known-type (car known-list)) | |
290 | (types-array types) | |
291 | (found (when first-known-type | |
292 | (catch 'done | |
293 | (dotimes (i (length types-array)) | |
294 | (let* ((type (aref types-array i)) | |
295 | (typename (if (symbolp type) | |
296 | (symbol-name type) type))) | |
297 | (when (equal first-known-type typename) | |
298 | (throw 'done first-known-type)))) | |
299 | nil)))) | |
300 | ||
301 | (if (and (not found) (cdr known-list)) | |
302 | (x-dnd-choose-type types (cdr known-list)) | |
303 | found))) | |
304 | ||
305 | (defun x-dnd-drop-data (event frame window data type) | |
306 | "Drop one data item onto a frame. | |
cd07aa70 JB |
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'). | |
133aad74 JD |
311 | |
312 | Returns the action used (move, copy, link, private) if drop was successful, | |
313 | nil if not." | |
314 | (let* ((type-info (assoc type x-dnd-types-alist)) | |
315 | (handler (cdr type-info)) | |
316 | (state (x-dnd-get-state-for-frame frame)) | |
317 | (action (aref state 5)) | |
318 | (w (posn-window (event-start event)))) | |
319 | (when handler | |
011acd18 | 320 | (if (and (window-live-p w) |
69a069fa RS |
321 | (not (window-minibuffer-p w)) |
322 | (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. | |
03714c7f | 325 | (progn |
1867217a JD |
326 | (when (not mouse-yank-at-point) |
327 | (goto-char (posn-point (event-start event)))) | |
133aad74 | 328 | (funcall handler window action data)) |
69a069fa RS |
329 | ;; If we can't display the file here, |
330 | ;; make a new window for it. | |
331 | (let ((dnd-open-file-other-window t)) | |
133aad74 JD |
332 | (select-frame frame) |
333 | (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). | |
49f87d23 | 337 | Currently XDND, Motif and old KDE 1.x protocols are recognized." |
133aad74 JD |
338 | (interactive "e") |
339 | (let* ((client-message (car (cdr (cdr event)))) | |
340 | (window (posn-window (event-start event))) | |
341 | (message-atom (aref client-message 0)) | |
342 | (frame (aref client-message 1)) | |
343 | (format (aref client-message 2)) | |
344 | (data (aref client-message 3))) | |
345 | ||
b9aafad5 | 346 | (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. |
133aad74 JD |
347 | (x-dnd-handle-old-kde event frame window message-atom format data)) |
348 | ||
b9aafad5 JD |
349 | ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif |
350 | (x-dnd-handle-motif event frame window message-atom format data)) | |
351 | ||
352 | ((and (> (length message-atom) 4) ; XDND protocol. | |
133aad74 | 353 | (equal "Xdnd" (substring message-atom 0 4))) |
b9aafad5 | 354 | (x-dnd-handle-xdnd event frame window message-atom format data))))) |
133aad74 | 355 | |
133aad74 JD |
356 | |
357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
358 | ;;; Old KDE protocol. Only dropping of files. | |
359 | ||
aa360da1 GM |
360 | (declare-function x-window-property "xfns.c" |
361 | (prop &optional frame type source delete-p vector-ret-p)) | |
362 | ||
06b60517 | 363 | (defun x-dnd-handle-old-kde (_event frame window _message _format _data) |
133aad74 JD |
364 | "Open the files in a KDE 1.x drop." |
365 | (let ((values (x-window-property "DndSelection" frame nil 0 t))) | |
366 | (x-dnd-handle-uri-list window 'private | |
367 | (replace-regexp-in-string "\0$" "" values)))) | |
368 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
369 | ||
370 | ||
371 | ||
372 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
373 | ;;; XDND protocol. | |
374 | ||
a7610c52 | 375 | (defconst x-dnd-xdnd-to-action |
133aad74 JD |
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 | ||
aa360da1 GM |
383 | (declare-function x-change-window-property "xfns.c" |
384 | (prop value &optional frame type format outer-P)) | |
385 | ||
133aad74 | 386 | (defun x-dnd-init-xdnd-for-frame (frame) |
b9aafad5 | 387 | "Set the XdndAware property for FRAME to indicate that we do XDND." |
133aad74 JD |
388 | (x-change-window-property "XdndAware" |
389 | '(5) ;; The version of XDND we support. | |
390 | frame "ATOM" 32 t)) | |
391 | ||
392 | (defun x-dnd-get-drop-width-height (frame w accept) | |
cd07aa70 | 393 | "Return the width/height to be sent in a XDndStatus message. |
133aad74 JD |
394 | FRAME is the frame and W is the window where the drop happened. |
395 | If ACCEPT is nil return 0 (empty rectangle), | |
cd07aa70 | 396 | otherwise if W is a window, return its width/height, |
133aad74 JD |
397 | otherwise return the frame width/height." |
398 | (if accept | |
399 | (if (windowp w) ;; w is not a window if dropping on the menu bar, | |
400 | ;; scroll bar or tool bar. | |
401 | (let ((edges (window-inside-pixel-edges w))) | |
402 | (cons | |
403 | (- (nth 2 edges) (nth 0 edges)) ;; right - left | |
404 | (- (nth 3 edges) (nth 1 edges)))) ;; bottom - top | |
405 | (cons (frame-pixel-width frame) | |
406 | (frame-pixel-height frame))) | |
407 | 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. | |
da6062e6 | 413 | If W is a window, return its absolute coordinates, |
133aad74 JD |
414 | otherwise return the frame coordinates." |
415 | (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 | (frame-real-left (if (consp frame-left) (car (cdr frame-left)) | |
419 | frame-left)) | |
420 | (frame-top (frame-parameter frame 'top)) | |
421 | (frame-real-top (if (consp frame-top) (car (cdr frame-top)) | |
422 | frame-top))) | |
423 | (if (windowp w) | |
424 | (let ((edges (window-inside-pixel-edges w))) | |
425 | (cons | |
426 | (+ frame-real-left (nth 0 edges)) | |
427 | (+ frame-real-top (nth 1 edges)))) | |
428 | (cons frame-real-left frame-real-top)))) | |
429 | ||
aa360da1 GM |
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" | |
cfecdf09 | 434 | (selection-symbol target-type &optional time-stamp terminal)) |
cc63039e | 435 | |
ca530739 JD |
436 | (defun x-dnd-version-from-flags (flags) |
437 | "Return the version byte from the 32 bit FLAGS in an XDndEnter message" | |
438 | (if (consp flags) ;; Long as cons | |
439 | (ash (car flags) -8) | |
440 | (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 | (if (consp flags) | |
445 | (logand (cdr flags) 1) | |
446 | (logand flags 1))) | |
da6062e6 | 447 | |
06b60517 | 448 | (defun x-dnd-handle-xdnd (event frame window message _format data) |
133aad74 JD |
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 | (cond ((equal "XdndEnter" message) | |
18daafed | 454 | (let* ((flags (aref data 1)) |
ca530739 JD |
455 | (version (x-dnd-version-from-flags flags)) |
456 | (more-than-3 (x-dnd-more-than-3-from-flags flags)) | |
18daafed | 457 | (dnd-source (aref data 0))) |
ca530739 | 458 | (message "%s %s" version more-than-3) |
18daafed JD |
459 | (if version ;; If flags is bad, version will be nil. |
460 | (x-dnd-save-state | |
461 | window nil nil | |
462 | (if (> more-than-3 0) | |
463 | (x-window-property "XdndTypeList" | |
464 | frame "AnyPropertyType" | |
465 | dnd-source nil t) | |
466 | (vector (x-get-atom-name (aref data 2)) | |
467 | (x-get-atom-name (aref data 3)) | |
468 | (x-get-atom-name (aref data 4)))))))) | |
133aad74 JD |
469 | |
470 | ((equal "XdndPosition" message) | |
06b60517 | 471 | (let* ((action (x-get-atom-name (aref data 4))) |
133aad74 | 472 | (dnd-source (aref data 0)) |
133aad74 JD |
473 | (action-type (x-dnd-maybe-call-test-function |
474 | window | |
475 | (cdr (assoc action x-dnd-xdnd-to-action)))) | |
476 | (reply-action (car (rassoc (car action-type) | |
477 | x-dnd-xdnd-to-action))) | |
478 | (accept ;; 1 = accept, 0 = reject | |
479 | (if (and reply-action action-type) 1 0)) | |
480 | (list-to-send | |
481 | (list (string-to-number | |
482 | (frame-parameter frame 'outer-window-id)) | |
483 | accept ;; 1 = Accept, 0 = reject. | |
484 | (x-dnd-get-drop-x-y frame window) | |
bf247b6e | 485 | (x-dnd-get-drop-width-height |
133aad74 JD |
486 | frame window (eq accept 1)) |
487 | (or reply-action 0) | |
488 | ))) | |
489 | (x-send-client-message | |
490 | frame dnd-source frame "XdndStatus" 32 list-to-send) | |
491 | )) | |
492 | ||
493 | ((equal "XdndLeave" message) | |
494 | (x-dnd-forget-drop window)) | |
495 | ||
496 | ((equal "XdndDrop" message) | |
497 | (if (windowp window) (select-window window)) | |
498 | (let* ((dnd-source (aref data 0)) | |
499 | (value (and (x-dnd-current-type window) | |
133aad74 JD |
500 | (x-get-selection-internal |
501 | 'XdndSelection | |
502 | (intern (x-dnd-current-type window))))) | |
06b60517 | 503 | success action) |
133aad74 JD |
504 | |
505 | (setq action (if value | |
506 | (condition-case info | |
bf247b6e | 507 | (x-dnd-drop-data event frame window value |
133aad74 | 508 | (x-dnd-current-type window)) |
bf247b6e | 509 | (error |
133aad74 JD |
510 | (message "Error: %s" info) |
511 | nil)))) | |
512 | ||
513 | (setq success (if action 1 0)) | |
133aad74 JD |
514 | |
515 | (x-send-client-message | |
516 | frame dnd-source frame "XdndFinished" 32 | |
517 | (list (string-to-number (frame-parameter frame 'outer-window-id)) | |
518 | success ;; 1 = Success, 0 = Error | |
519 | (if success "XdndActionPrivate" 0) | |
520 | )) | |
521 | (x-dnd-forget-drop window))) | |
522 | ||
523 | (t (error "Unknown XDND message %s %s" message data)))) | |
524 | ||
b9aafad5 JD |
525 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
526 | ;;; Motif protocol. | |
527 | ||
528 | (defun x-dnd-init-motif-for-frame (frame) | |
cd07aa70 | 529 | "Set _MOTIF_DRAG_RECEIVER_INFO for FRAME to indicate that we do Motif DND." |
b9aafad5 JD |
530 | (x-change-window-property "_MOTIF_DRAG_RECEIVER_INFO" |
531 | (list | |
532 | (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) ; Property must be 16 bytes. | |
537 | frame "_MOTIF_DRAG_RECEIVER_INFO" 8 t)) | |
538 | ||
539 | (defun x-dnd-get-motif-value (data offset size byteorder) | |
540 | (cond ((eq size 2) | |
541 | (if (eq byteorder ?l) | |
542 | (+ (ash (aref data (1+ offset)) 8) | |
543 | (aref data offset)) | |
544 | (+ (ash (aref data offset) 8) | |
545 | (aref data (1+ offset))))) | |
546 | ||
547 | ((eq size 4) | |
548 | (if (eq byteorder ?l) | |
549 | (cons (+ (ash (aref data (+ 3 offset)) 8) | |
550 | (aref data (+ 2 offset))) | |
551 | (+ (ash (aref data (1+ offset)) 8) | |
552 | (aref data offset))) | |
553 | (cons (+ (ash (aref data offset) 8) | |
554 | (aref data (1+ offset))) | |
555 | (+ (ash (aref data (+ 2 offset)) 8) | |
556 | (aref data (+ 3 offset)))))))) | |
557 | ||
558 | (defun x-dnd-motif-value-to-list (value size byteorder) | |
559 | (let ((bytes (cond ((eq size 2) | |
560 | (list (logand (lsh value -8) ?\xff) | |
561 | (logand value ?\xff))) | |
562 | ||
563 | ((eq size 4) | |
564 | (if (consp value) | |
565 | (list (logand (lsh (car value) -8) ?\xff) | |
566 | (logand (car value) ?\xff) | |
567 | (logand (lsh (cdr value) -8) ?\xff) | |
568 | (logand (cdr value) ?\xff)) | |
569 | (list (logand (lsh value -24) ?\xff) | |
570 | (logand (lsh value -16) ?\xff) | |
571 | (logand (lsh value -8) ?\xff) | |
572 | (logand value ?\xff))))))) | |
573 | (if (eq byteorder ?l) | |
574 | (reverse bytes) | |
575 | 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 | ||
06b60517 | 598 | (defun x-dnd-handle-motif (event frame window message-atom _format data) |
b9aafad5 JD |
599 | (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types))) |
600 | (source-byteorder (aref data 1)) | |
601 | (my-byteorder (byteorder)) | |
602 | (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder)) | |
603 | (source-action (cdr (assoc (logand ?\xF source-flags) | |
604 | x-dnd-motif-to-action)))) | |
605 | ||
606 | (cond ((eq message-type 'XmTOP_LEVEL_ENTER) | |
607 | (let* ((dnd-source (x-dnd-get-motif-value | |
608 | data 8 4 source-byteorder)) | |
609 | (selection-atom (x-dnd-get-motif-value | |
610 | data 12 4 source-byteorder)) | |
611 | (atom-name (x-get-atom-name selection-atom)) | |
612 | (types (when atom-name | |
613 | (x-get-selection-internal (intern atom-name) | |
614 | 'TARGETS)))) | |
615 | (x-dnd-forget-drop frame) | |
616 | (when types (x-dnd-save-state window nil nil | |
617 | types | |
618 | dnd-source)))) | |
619 | ||
620 | ;; Can not forget drop here, LEAVE comes before DROP_START and | |
621 | ;; we need the state in DROP_START. | |
622 | ((eq message-type 'XmTOP_LEVEL_LEAVE) | |
623 | nil) | |
624 | ||
625 | ((eq message-type 'XmDRAG_MOTION) | |
626 | (let* ((state (x-dnd-get-state-for-frame frame)) | |
627 | (timestamp (x-dnd-motif-value-to-list | |
bf247b6e | 628 | (x-dnd-get-motif-value data 4 4 |
b9aafad5 JD |
629 | source-byteorder) |
630 | 4 my-byteorder)) | |
631 | (x (x-dnd-motif-value-to-list | |
632 | (x-dnd-get-motif-value data 8 2 source-byteorder) | |
633 | 2 my-byteorder)) | |
634 | (y (x-dnd-motif-value-to-list | |
635 | (x-dnd-get-motif-value data 10 2 source-byteorder) | |
636 | 2 my-byteorder)) | |
637 | (dnd-source (aref state 6)) | |
638 | (first-move (not (aref state 3))) | |
639 | (action-type (x-dnd-maybe-call-test-function | |
640 | window | |
641 | source-action)) | |
642 | (reply-action (car (rassoc (car action-type) | |
643 | x-dnd-motif-to-action))) | |
644 | (reply-flags | |
645 | (x-dnd-motif-value-to-list | |
646 | (if reply-action | |
bf247b6e | 647 | (+ reply-action |
b9aafad5 JD |
648 | ?\x30 ; 30: valid drop site |
649 | ?\x700) ; 700: can do copy, move or link | |
650 | ?\x30) ; 30: drop site, but noop. | |
651 | 2 my-byteorder)) | |
652 | (reply (append | |
653 | (list | |
654 | (+ ?\x80 ; 0x80 indicates a reply. | |
655 | (if first-move | |
656 | 3 ; First time, reply is SITE_ENTER. | |
657 | 2)) ; Not first time, reply is DRAG_MOTION. | |
658 | my-byteorder) | |
659 | reply-flags | |
660 | timestamp | |
661 | x | |
662 | y))) | |
663 | (x-send-client-message frame | |
664 | dnd-source | |
665 | frame | |
666 | "_MOTIF_DRAG_AND_DROP_MESSAGE" | |
667 | 8 | |
668 | reply))) | |
669 | ||
670 | ((eq message-type 'XmOPERATION_CHANGED) | |
671 | (let* ((state (x-dnd-get-state-for-frame frame)) | |
672 | (timestamp (x-dnd-motif-value-to-list | |
673 | (x-dnd-get-motif-value data 4 4 source-byteorder) | |
674 | 4 my-byteorder)) | |
675 | (dnd-source (aref state 6)) | |
676 | (action-type (x-dnd-maybe-call-test-function | |
677 | window | |
678 | source-action)) | |
679 | (reply-action (car (rassoc (car action-type) | |
680 | x-dnd-motif-to-action))) | |
681 | (reply-flags | |
682 | (x-dnd-motif-value-to-list | |
683 | (if reply-action | |
bf247b6e | 684 | (+ reply-action |
b9aafad5 JD |
685 | ?\x30 ; 30: valid drop site |
686 | ?\x700) ; 700: can do copy, move or link | |
687 | ?\x30) ; 30: drop site, but noop | |
688 | 2 my-byteorder)) | |
689 | (reply (append | |
690 | (list | |
691 | (+ ?\x80 ; 0x80 indicates a reply. | |
692 | 8) ; 8 is OPERATION_CHANGED | |
693 | my-byteorder) | |
694 | reply-flags | |
695 | timestamp))) | |
696 | (x-send-client-message frame | |
697 | dnd-source | |
698 | frame | |
699 | "_MOTIF_DRAG_AND_DROP_MESSAGE" | |
700 | 8 | |
701 | reply))) | |
702 | ||
703 | ((eq message-type 'XmDROP_START) | |
704 | (let* ((x (x-dnd-motif-value-to-list | |
705 | (x-dnd-get-motif-value data 8 2 source-byteorder) | |
706 | 2 my-byteorder)) | |
707 | (y (x-dnd-motif-value-to-list | |
708 | (x-dnd-get-motif-value data 10 2 source-byteorder) | |
709 | 2 my-byteorder)) | |
710 | (selection-atom (x-dnd-get-motif-value | |
711 | data 12 4 source-byteorder)) | |
712 | (atom-name (x-get-atom-name selection-atom)) | |
713 | (dnd-source (x-dnd-get-motif-value | |
714 | data 16 4 source-byteorder)) | |
715 | (action-type (x-dnd-maybe-call-test-function | |
716 | window | |
717 | source-action)) | |
718 | (reply-action (car (rassoc (car action-type) | |
719 | x-dnd-motif-to-action))) | |
720 | (reply-flags | |
721 | (x-dnd-motif-value-to-list | |
722 | (if reply-action | |
bf247b6e | 723 | (+ reply-action |
b9aafad5 JD |
724 | ?\x30 ; 30: valid drop site |
725 | ?\x700) ; 700: can do copy, move or link | |
726 | (+ ?\x30 ; 30: drop site, but noop. | |
727 | ?\x200)) ; 200: drop cancel. | |
728 | 2 my-byteorder)) | |
729 | (reply (append | |
730 | (list | |
731 | (+ ?\x80 ; 0x80 indicates a reply. | |
732 | 5) ; DROP_START. | |
733 | my-byteorder) | |
734 | reply-flags | |
735 | x | |
736 | y)) | |
bf247b6e | 737 | (timestamp (x-dnd-get-motif-value |
b9aafad5 JD |
738 | data 4 4 source-byteorder)) |
739 | action) | |
740 | ||
741 | (x-send-client-message frame | |
742 | dnd-source | |
743 | frame | |
744 | "_MOTIF_DRAG_AND_DROP_MESSAGE" | |
745 | 8 | |
746 | reply) | |
bf247b6e | 747 | (setq action |
b9aafad5 JD |
748 | (when (and reply-action atom-name) |
749 | (let* ((value (x-get-selection-internal | |
750 | (intern atom-name) | |
751 | (intern (x-dnd-current-type window))))) | |
752 | (when value | |
753 | (condition-case info | |
bf247b6e | 754 | (x-dnd-drop-data event frame window value |
b9aafad5 JD |
755 | (x-dnd-current-type window)) |
756 | (error | |
757 | (message "Error: %s" info) | |
758 | nil)))))) | |
759 | (x-get-selection-internal | |
bf247b6e | 760 | (intern atom-name) |
b9aafad5 JD |
761 | (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) |
762 | timestamp) | |
763 | (x-dnd-forget-drop frame))) | |
764 | ||
7a01b040 | 765 | (t (error "Unknown Motif DND message %s %s" message-atom data))))) |
bf247b6e | 766 | |
b9aafad5 JD |
767 | |
768 | ;;; | |
769 | ||
133aad74 JD |
770 | (provide 'x-dnd) |
771 | ||
133aad74 | 772 | ;;; x-dnd.el ends here |