Commit | Line | Data |
---|---|---|
133aad74 JD |
1 | ;;; x-dnd.el --- drag and drop support for X. |
2 | ||
3 | ;; Copyright (C) 2004 | |
4 | ;; Free Software Foundation, Inc. | |
5 | ||
6 | ;; Author: Jan Dj\e,Ad\e(Brv <jan.h.d@swipnet.se> | |
7 | ;; Maintainer: FSF | |
8 | ;; Keywords: window, drag, drop | |
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 2, or (at your option) | |
15 | ;; 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; see the file COPYING. If not, write to the | |
24 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 | ;; Boston, MA 02111-1307, USA. | |
26 | ||
27 | ;;; Commentary: | |
28 | ||
29 | ;; This file provides the drop part only. Currently supported protocols | |
30 | ;; are XDND and the old KDE 1.x protocol. | |
31 | ||
32 | ;;; Code: | |
33 | ||
34 | ;;; Customizable variables | |
35 | ||
36 | ||
37 | (defcustom x-dnd-test-function 'x-dnd-default-test-function | |
38 | "The function drag and drop uses to determine if to accept or reject a drop. | |
39 | The function takes three arguments, WINDOW ACTION and TYPES. | |
40 | WINDOW is where the mouse is when the function is called. WINDOW may be a | |
41 | frame if the mouse isn't over a real window (i.e. menu bar, tool bar or | |
42 | scroll bar). ACTION is the suggested action from the drag and drop source, | |
43 | one of the symbols move, copy link or ask. TYPES is a list of available types | |
44 | for the drop. | |
45 | ||
46 | The function shall return nil to reject the drop or a cons with two values, | |
47 | the wanted action as car and the wanted type as cdr. The wanted action | |
48 | can be copy, move, link, ask or private. | |
49 | The default value for this variable is `x-dnd-default-test-function'." | |
50 | :type 'symbol | |
51 | :group 'x) | |
52 | ||
53 | (defcustom x-dnd-protocol-alist | |
54 | '( | |
55 | ("^file:///" . x-dnd-open-local-file) ; XDND format. | |
56 | ("^file://" . x-dnd-open-file) ; URL with host | |
57 | ("^file:" . x-dnd-open-local-file) ; Old KDE, Motif, Sun | |
58 | ) | |
59 | ||
60 | "The functions to call for different protocols when a drop is made. | |
61 | This variable is used by `x-dnd-handle-uri-list' and `x-dnd-handle-moz-url'. | |
62 | The list contains of (REGEXP . FUNCTION) pairs. | |
63 | The functions shall take two arguments, URL, which is the URL dropped and | |
64 | ACTION which is the action to be performed for the drop (move, copy, link, | |
65 | private or ask). | |
66 | If no match is found here, and the value of `browse-url-browser-function' | |
67 | is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. | |
68 | Insertion of text is not handeled by these functions, see `x-dnd-types-alist' | |
69 | for that. | |
70 | The function shall return the action done (move, copy, link or private) | |
71 | if some action was made, or nil if the URL is ignored." | |
72 | :type 'alist | |
73 | :group 'x) | |
74 | ||
75 | ||
76 | (defcustom x-dnd-types-alist | |
77 | '( | |
78 | ("text/uri-list" . x-dnd-handle-uri-list) | |
79 | ("text/x-moz-url" . x-dnd-handle-moz-url) | |
80 | ("FILE_NAME" . x-dnd-handle-uri-list) | |
81 | ("_NETSCAPE_URL" . x-dnd-handle-uri-list) | |
82 | ("UTF8_STRING" . x-dnd-insert-utf8-text) | |
83 | ("text/plain;charset=UTF-8" . x-dnd-insert-utf8-text) | |
84 | ("text/plain;charset=utf-8" . x-dnd-insert-utf8-text) | |
85 | ("text/unicode" . x-dnd-insert-utf16-text) | |
86 | ("text/plain" . x-dnd-insert-text) | |
87 | ("STRING" . x-dnd-insert-text) | |
88 | ("TEXT" . x-dnd-insert-text) | |
89 | ) | |
90 | "Which function to call to handle a drop of that type. | |
91 | If the type for the drop is not present, or the function is nil, | |
92 | the drop is rejected. The function takes three arguments, WINDOW, ACTION | |
93 | and DATA. WINDOW is where the drop occured, ACTION is the action for | |
94 | this drop (copy, move, link, private or ask) as determined by a previous | |
95 | call to `x-dnd-test-function'. DATA is the drop data. | |
96 | The function shall return the action used (copy, move, link or private) if drop | |
97 | is successful, nil if not." | |
98 | :type 'alist | |
99 | :group 'x) | |
100 | ||
101 | (defcustom x-dnd-open-file-other-window nil | |
102 | "If non-nil, always use find-file-other-window to open dropped files." | |
103 | :type 'boolean | |
104 | :group 'x) | |
105 | ||
106 | ;; Internal variables | |
107 | ||
108 | (defvar x-dnd-known-types | |
109 | '("text/uri-list" | |
110 | "text/x-moz-url" | |
111 | "FILE_NAME" | |
112 | "_NETSCAPE_URL" | |
113 | "UTF8_STRING" | |
114 | "text/plain;charset=UTF-8" | |
115 | "text/plain;charset=utf-8" | |
116 | "text/unicode" | |
117 | "text/plain" | |
118 | "STRING" | |
119 | "TEXT" | |
120 | ) | |
121 | "The types accepted by default for dropped data. | |
122 | The types are chosen in the order they appear in the list.") | |
123 | ||
124 | (defvar x-dnd-current-state nil | |
125 | "The current state for a drop. | |
126 | This is an alist with one entry for each display. The value for each display | |
127 | is a vector that contains the state for drag and drop for that display. | |
128 | Elements in the vector are: | |
129 | Last buffer drag was in, | |
130 | last window drag was in, | |
131 | types available for drop, | |
132 | the action suggested by the source, | |
133 | the type we want for the drop, | |
134 | the action we want for the drop.") | |
135 | ||
136 | (defvar x-dnd-empty-state [nil nil nil nil nil nil]) | |
137 | ||
138 | ||
139 | ||
140 | (defun x-dnd-init-frame (&optional frame) | |
141 | "Setup drag and drop for FRAME (i.e. create appropriate properties)." | |
142 | (x-dnd-init-xdnd-for-frame frame)) | |
143 | ||
144 | (defun x-dnd-get-state-cons-for-frame (frame-or-window) | |
145 | "Return the entry in x-dnd-current-state for a frame or window." | |
146 | (let* ((frame (if (framep frame-or-window) frame-or-window | |
147 | (window-frame frame-or-window))) | |
148 | (display (frame-parameter frame 'display))) | |
149 | (if (not (assoc display x-dnd-current-state)) | |
150 | (push (cons display x-dnd-empty-state) x-dnd-current-state)) | |
151 | (assoc display x-dnd-current-state))) | |
152 | ||
153 | (defun x-dnd-get-state-for-frame (frame-or-window) | |
154 | "Return the state in x-dnd-current-state for a frame or window." | |
155 | (cdr (x-dnd-get-state-cons-for-frame frame-or-window))) | |
156 | ||
157 | (defun x-dnd-default-test-function (window action types) | |
158 | "The default test function for drag and drop. | |
159 | WINDOW is where the mouse is when this function is called. It may be a frame | |
160 | if the mouse is over the menu bar, scroll bar or tool bar. | |
161 | ACTION is the suggested action from the source, and TYPES are the | |
162 | types the drop data can have. This function only accepts drops with | |
163 | types in `x-dnd-known-types'. It always returns the action private." | |
164 | (let ((type (x-dnd-choose-type types))) | |
165 | (when type (cons 'private type)))) | |
166 | ||
167 | ||
168 | (defun x-dnd-current-type (frame-or-window) | |
169 | "Return the type we want the DND data to be in for the current drop. | |
170 | FRAME-OR-WINDOW is the frame or window that the mouse is over." | |
171 | (aref (x-dnd-get-state-for-frame frame-or-window) 4)) | |
172 | ||
173 | (defun x-dnd-forget-drop (frame-or-window) | |
174 | "Remove all state for the last drop. | |
175 | FRAME-OR-WINDOW is the frame or window that the mouse is over." | |
176 | (setcdr (x-dnd-get-state-cons-for-frame frame-or-window) x-dnd-empty-state)) | |
177 | ||
178 | (defun x-dnd-maybe-call-test-function (window action) | |
179 | "Call `x-dnd-test-function' if something has changed. | |
180 | WINDOW is the window the mouse is over. ACTION is the suggested | |
181 | action from the source. If nothing has changed, return the last | |
182 | action and type we got from `x-dnd-test-function'." | |
183 | (let ((buffer (when (and (windowp window) (window-live-p window)) | |
184 | (window-buffer window))) | |
185 | (current-state (x-dnd-get-state-for-frame window))) | |
186 | (when (or (not (equal buffer (aref current-state 0))) | |
187 | (not (equal window (aref current-state 1))) | |
188 | (not (equal action (aref current-state 3)))) | |
189 | (save-excursion | |
190 | (when buffer (set-buffer buffer)) | |
191 | (let* ((action-type (funcall x-dnd-test-function | |
192 | window | |
193 | action | |
194 | (aref current-state 2))) | |
195 | (handler (cdr (assoc (cdr action-type) x-dnd-types-alist)))) | |
196 | ;; Ignore action-type if we have no handler. | |
197 | (setq current-state | |
198 | (x-dnd-save-state window | |
199 | action | |
200 | (when handler action-type))))))) | |
201 | (let ((current-state (x-dnd-get-state-for-frame window))) | |
202 | (cons (aref current-state 5) | |
203 | (aref current-state 4)))) | |
204 | ||
205 | (defun x-dnd-save-state (window action action-type &optional types) | |
206 | "Save the state of the current drag and drop. | |
207 | WINDOW is the window the mouse is over. ACTION is the action suggested | |
208 | by the source. ACTION-TYPE is the result of calling `x-dnd-test-function'. | |
209 | If given, TYPES are the types for the drop data that the source supports." | |
210 | (let ((current-state (x-dnd-get-state-for-frame window))) | |
211 | (aset current-state 5 (car action-type)) | |
212 | (aset current-state 4 (cdr action-type)) | |
213 | (aset current-state 3 action) | |
214 | (if types (aset current-state 2 types)) | |
215 | (aset current-state 1 window) | |
216 | (aset current-state 0 (if (and (windowp window) | |
217 | (window-live-p window)) | |
218 | (window-buffer window) nil)) | |
219 | (setcdr (x-dnd-get-state-cons-for-frame window) current-state))) | |
220 | ||
221 | ||
222 | (defun x-dnd-test-and-save-state (window action types) | |
223 | "Test if drop shall be accepted, and save the state for future reference. | |
224 | ACTION is the suggested action by the source. | |
225 | TYPES is a list of types the source supports." | |
226 | (x-dnd-save-state window | |
227 | action | |
228 | (x-dnd-maybe-call-test-function window action) | |
229 | types)) | |
230 | ||
231 | (defun x-dnd-handle-one-url (window action arg) | |
232 | "Handle one dropped url by calling the appropriate handler. | |
233 | The handler is first localted by looking at `x-dnd-protocol-alist'. | |
234 | If no match is found here, and the value of `browse-url-browser-function' | |
235 | is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. | |
b12f0661 | 236 | If no match is found, just call `x-dnd-insert-text'. |
133aad74 JD |
237 | WINDOW is where the drop happend, ACTION is the action for the drop, |
238 | ARG is the URL that has been dropped. | |
239 | Returns ACTION." | |
240 | (require 'browse-url) | |
241 | (let* ((uri (replace-regexp-in-string | |
242 | "%[A-Z0-9][A-Z0-9]" | |
243 | (lambda (arg) | |
244 | (format "%c" (string-to-number (substring arg 1) 16))) | |
245 | arg)) | |
246 | ret) | |
247 | (or | |
248 | (catch 'done | |
249 | (dolist (bf x-dnd-protocol-alist) | |
250 | (when (string-match (car bf) uri) | |
251 | (setq ret (funcall (cdr bf) uri action)) | |
252 | (throw 'done t))) | |
253 | nil) | |
254 | (when (not (functionp browse-url-browser-function)) | |
255 | (catch 'done | |
256 | (dolist (bf browse-url-browser-function) | |
257 | (when (string-match (car bf) uri) | |
258 | (setq ret 'private) | |
259 | (funcall (cdr bf) uri action) | |
260 | (throw 'done t))) | |
261 | nil)) | |
262 | (x-dnd-insert-text window action uri)) | |
263 | ret)) | |
264 | ||
265 | ||
266 | (defun x-dnd-get-local-file-uri (uri) | |
267 | "Return an uri converted to file:/// syntax if uri is a local file. | |
268 | Return nil if URI is not a local file." | |
269 | ||
270 | ;; The hostname may be our hostname, in that case, convert to a local | |
271 | ;; file. Otherwise return nil. TODO: How about an IP-address as hostname? | |
272 | (let ((hostname (when (string-match "^file://\\([^/]*\\)" uri) | |
273 | (downcase (match-string 1 uri)))) | |
274 | (system-name-no-dot | |
275 | (downcase (if (string-match "^[^\\.]+" system-name) | |
276 | (match-string 0 system-name) | |
277 | system-name)))) | |
278 | (when (and hostname | |
279 | (or (string-equal "localhost" hostname) | |
280 | (string-equal (downcase system-name) hostname) | |
281 | (string-equal system-name-no-dot hostname))) | |
282 | (concat "file://" (substring uri (+ 7 (length hostname))))))) | |
283 | ||
284 | (defun x-dnd-get-local-file-name (uri &optional must-exist) | |
285 | "Return file name converted from file:/// or file: syntax. | |
286 | URI is the uri for the file. If MUST-EXIST is given and non-nil, | |
287 | only return non-nil if the file exists. | |
288 | Return nil if URI is not a local file." | |
289 | (let ((f (cond ((string-match "^file:///" uri) ; XDND format. | |
290 | (substring uri (1- (match-end 0)))) | |
291 | ((string-match "^file:" uri) ; Old KDE, Motif, Sun | |
14ca8854 | 292 | (substring uri (match-end 0)))))) |
133aad74 JD |
293 | (when (and f must-exist) |
294 | (let* ((decoded-f (decode-coding-string | |
295 | f | |
296 | (or file-name-coding-system | |
297 | default-file-name-coding-system))) | |
298 | (try-f (if (file-readable-p decoded-f) decoded-f f))) | |
299 | (when (file-readable-p try-f) try-f))))) | |
300 | ||
301 | ||
302 | (defun x-dnd-open-local-file (uri action) | |
303 | "Open a local file. | |
304 | The file is opened in the current window, or a new window if | |
305 | `x-dnd-open-file-other-window' is set. URI is the url for the file, | |
306 | and must have the format file:file-name or file:///file-name. | |
307 | The last / in file:/// is part of the file name. ACTION is ignored." | |
308 | ||
309 | (let* ((f (x-dnd-get-local-file-name uri t))) | |
310 | (when f | |
311 | (if (file-readable-p f) | |
312 | (progn | |
313 | (if x-dnd-open-file-other-window | |
314 | (find-file-other-window f) | |
315 | (find-file f)) | |
316 | 'private) | |
317 | (error "Can not read %s (%s)" f uri))))) | |
318 | ||
319 | (defun x-dnd-open-file (uri action) | |
320 | "Open a local or remote file. | |
321 | The file is opened in the current window, or a new window if | |
322 | `x-dnd-open-file-other-window' is set. URI is the url for the file, | |
323 | and must have the format file://hostname/file-name. ACTION is ignored. | |
324 | The last / in file://hostname/ is part of the file name." | |
325 | ||
326 | ;; The hostname may be our hostname, in that case, convert to a local | |
327 | ;; file. Otherwise return nil. | |
328 | (let ((local-file (x-dnd-get-local-file-uri uri))) | |
329 | (when local-file (x-dnd-open-local-file local-file action)))) | |
330 | ||
331 | ||
332 | (defun x-dnd-handle-moz-url (window action data) | |
333 | "Handle one item of type text/x-moz-url. | |
334 | WINDOW is the window where the drop happened. ACTION is ignored. | |
335 | DATA is the moz-url, which is formatted as two strings separated by \r\n. | |
336 | The first string is the URL, the second string is the title of that URL. | |
337 | DATA is encoded in utf-16. Decode the URL and call `x-dnd-handle-uri-list'." | |
338 | (let* ((string (decode-coding-string data 'utf-16le)) ;; ALWAYS LE??? | |
339 | (strings (split-string string "[\r\n]" t)) | |
340 | ;; Can one drop more than one moz-url ?? Assume not. | |
341 | (url (car strings)) | |
342 | (title (car (cdr strings)))) | |
343 | (x-dnd-handle-uri-list window action url))) | |
344 | ||
345 | (defun x-dnd-insert-utf8-text (window action text) | |
346 | "Decode the UTF-8 text and insert it at point. | |
347 | TEXT is the text as a string, WINDOW is the window where the drop happened." | |
348 | (x-dnd-insert-text window action (decode-coding-string text 'utf-8))) | |
349 | ||
350 | (defun x-dnd-insert-utf16-text (window action text) | |
351 | "Decode the UTF-16 text and insert it at point. | |
352 | TEXT is the text as a string, WINDOW is the window where the drop happened." | |
353 | (x-dnd-insert-text window action (decode-coding-string text 'utf-16le))) | |
354 | ||
355 | (defun x-dnd-insert-text (window action text) | |
356 | "Insert text at point or push to the kill ring if buffer is read only. | |
357 | TEXT is the text as a string, WINDOW is the window where the drop happened." | |
358 | (if (or buffer-read-only | |
359 | (not (windowp window))) | |
360 | (progn | |
361 | (kill-new text) | |
362 | (message | |
363 | (substitute-command-keys | |
364 | "The dropped text can be accessed with \\[yank]"))) | |
365 | (insert text)) | |
366 | action) | |
367 | ||
368 | (defun x-dnd-handle-uri-list (window action string) | |
369 | "Split an uri-list into separate URIs and call `x-dnd-handle-one-url'. | |
370 | WINDOW is the window where the drop happened. | |
371 | STRING is the uri-list as a string. The URIs are separated by \r\n." | |
372 | (let ((uri-list (split-string string "[\0\r\n]" t)) | |
373 | retval) | |
374 | (dolist (bf uri-list) | |
375 | ;; If one URL is handeled, treat as if the whole drop succeeded. | |
376 | (let ((did-action (x-dnd-handle-one-url window action bf))) | |
377 | (when did-action (setq retval did-action)))) | |
378 | retval)) | |
379 | ||
380 | ||
381 | (defun x-dnd-choose-type (types &optional known-types) | |
382 | "Choose which type we want to receive for the drop. | |
383 | TYPES are the types the source of the drop offers, a vector of type names | |
384 | as strings or symbols. Select among the types in `x-dnd-known-types' or | |
385 | KNOWN-TYPES if given, and return that type name. | |
386 | If no suitable type is found, return nil." | |
387 | (let* ((known-list (or known-types x-dnd-known-types)) | |
388 | (first-known-type (car known-list)) | |
389 | (types-array types) | |
390 | (found (when first-known-type | |
391 | (catch 'done | |
392 | (dotimes (i (length types-array)) | |
393 | (let* ((type (aref types-array i)) | |
394 | (typename (if (symbolp type) | |
395 | (symbol-name type) type))) | |
396 | (when (equal first-known-type typename) | |
397 | (throw 'done first-known-type)))) | |
398 | nil)))) | |
399 | ||
400 | (if (and (not found) (cdr known-list)) | |
401 | (x-dnd-choose-type types (cdr known-list)) | |
402 | found))) | |
403 | ||
404 | (defun x-dnd-drop-data (event frame window data type) | |
405 | "Drop one data item onto a frame. | |
406 | EVENT is the client message for the drop, FRAME is the frame the drop occurred | |
407 | on. WINDOW is the window of FRAME where the drop happened. DATA is the data | |
408 | received from the source, and type is the type for DATA, see | |
409 | `x-dnd-types-alist'). | |
410 | ||
411 | Returns the action used (move, copy, link, private) if drop was successful, | |
412 | nil if not." | |
413 | (let* ((type-info (assoc type x-dnd-types-alist)) | |
414 | (handler (cdr type-info)) | |
415 | (state (x-dnd-get-state-for-frame frame)) | |
416 | (action (aref state 5)) | |
417 | (w (posn-window (event-start event)))) | |
418 | (when handler | |
419 | (if (and (windowp w) (window-live-p w)) | |
420 | ;; If dropping in a window, open files in that window rather | |
421 | ;; than in a new widow. | |
422 | (let ((x-dnd-open-file-other-window nil)) | |
423 | (goto-char (posn-point (event-start event))) | |
424 | (funcall handler window action data)) | |
425 | (let ((x-dnd-open-file-other-window t)) ;; Dropping on non-window. | |
426 | (select-frame frame) | |
427 | (funcall handler window action data)))))) | |
428 | ||
429 | (defun x-dnd-handle-drag-n-drop-event (event) | |
430 | "Receive drag and drop events (X client messages). | |
431 | Currently XDND and old KDE 1.x protocols are recognized. | |
432 | TODO: Add Motif and OpenWindows." | |
433 | (interactive "e") | |
434 | (let* ((client-message (car (cdr (cdr event)))) | |
435 | (window (posn-window (event-start event))) | |
436 | (message-atom (aref client-message 0)) | |
437 | (frame (aref client-message 1)) | |
438 | (format (aref client-message 2)) | |
439 | (data (aref client-message 3))) | |
440 | ||
441 | (cond ((equal "DndProtocol" message-atom) ;; Old KDE 1.x. | |
442 | (x-dnd-handle-old-kde event frame window message-atom format data)) | |
443 | ||
444 | ((and (> (length message-atom) 4) ;; XDND protocol. | |
445 | (equal "Xdnd" (substring message-atom 0 4))) | |
446 | (x-dnd-handle-xdnd event frame window message-atom format data)) | |
447 | ||
448 | (t (error "Unknown DND atom: %s" message-atom))))) | |
449 | ||
450 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
451 | ;;; Old KDE protocol. Only dropping of files. | |
452 | ||
453 | (defun x-dnd-handle-old-kde (event frame window message format data) | |
454 | "Open the files in a KDE 1.x drop." | |
455 | (let ((values (x-window-property "DndSelection" frame nil 0 t))) | |
456 | (x-dnd-handle-uri-list window 'private | |
457 | (replace-regexp-in-string "\0$" "" values)))) | |
458 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
459 | ||
460 | ||
461 | ||
462 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
463 | ;;; XDND protocol. | |
464 | ||
465 | (defvar x-dnd-xdnd-to-action | |
466 | '(("XdndActionPrivate" . private) | |
467 | ("XdndActionCopy" . copy) | |
468 | ("XdndActionMove" . move) | |
469 | ("XdndActionLink" . link) | |
470 | ("XdndActionAsk" . ask)) | |
471 | "Mapping from XDND action types to lisp symbols.") | |
472 | ||
473 | (defun x-dnd-init-xdnd-for-frame (frame) | |
474 | "Set the XdndAware for FRAME to indicate that we do XDND." | |
475 | (x-change-window-property "XdndAware" | |
476 | '(5) ;; The version of XDND we support. | |
477 | frame "ATOM" 32 t)) | |
478 | ||
479 | (defun x-dnd-get-drop-width-height (frame w accept) | |
480 | "Return the widht/height to be sent in a XDndStatus message. | |
481 | FRAME is the frame and W is the window where the drop happened. | |
482 | If ACCEPT is nil return 0 (empty rectangle), | |
483 | otherwise if W is a window, return its widht/height, | |
484 | otherwise return the frame width/height." | |
485 | (if accept | |
486 | (if (windowp w) ;; w is not a window if dropping on the menu bar, | |
487 | ;; scroll bar or tool bar. | |
488 | (let ((edges (window-inside-pixel-edges w))) | |
489 | (cons | |
490 | (- (nth 2 edges) (nth 0 edges)) ;; right - left | |
491 | (- (nth 3 edges) (nth 1 edges)))) ;; bottom - top | |
492 | (cons (frame-pixel-width frame) | |
493 | (frame-pixel-height frame))) | |
494 | 0)) | |
495 | ||
496 | (defun x-dnd-get-drop-x-y (frame w) | |
497 | "Return the x/y coordinates to be sent in a XDndStatus message. | |
498 | Coordinates are required to be absolute. | |
499 | FRAME is the frame and W is the window where the drop happened. | |
500 | If W is a window, return its absolute corrdinates, | |
501 | otherwise return the frame coordinates." | |
502 | (let* ((frame-left (frame-parameter frame 'left)) | |
503 | ;; If the frame is outside the display, frame-left looks like | |
504 | ;; '(0 -16). Extract the -16. | |
505 | (frame-real-left (if (consp frame-left) (car (cdr frame-left)) | |
506 | frame-left)) | |
507 | (frame-top (frame-parameter frame 'top)) | |
508 | (frame-real-top (if (consp frame-top) (car (cdr frame-top)) | |
509 | frame-top))) | |
510 | (if (windowp w) | |
511 | (let ((edges (window-inside-pixel-edges w))) | |
512 | (cons | |
513 | (+ frame-real-left (nth 0 edges)) | |
514 | (+ frame-real-top (nth 1 edges)))) | |
515 | (cons frame-real-left frame-real-top)))) | |
516 | ||
517 | (defun x-dnd-handle-xdnd (event frame window message format data) | |
518 | "Receive one XDND event (client message) and send the appropriate reply. | |
519 | EVENT is the client message. FRAME is where the mouse is now. | |
520 | WINDOW is the window within FRAME where the mouse is now. | |
521 | FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." | |
522 | (cond ((equal "XdndEnter" message) | |
523 | (let ((version (ash (car (aref data 1)) -8)) | |
524 | (more-than-3 (cdr (aref data 1))) | |
525 | (dnd-source (aref data 0))) | |
526 | (x-dnd-save-state | |
527 | window nil nil | |
528 | (if (> more-than-3 0) | |
529 | (x-window-property "XdndTypeList" | |
530 | frame "AnyPropertyType" | |
531 | dnd-source nil t) | |
532 | (vector (x-get-atom-name (aref data 2)) | |
533 | (x-get-atom-name (aref data 3)) | |
534 | (x-get-atom-name (aref data 4))))))) | |
535 | ||
536 | ((equal "XdndPosition" message) | |
537 | (let* ((x (car (aref data 2))) | |
538 | (y (cdr (aref data 2))) | |
539 | (action (x-get-atom-name (aref data 4))) | |
540 | (dnd-source (aref data 0)) | |
541 | (dnd-time (aref data 3)) | |
542 | (action-type (x-dnd-maybe-call-test-function | |
543 | window | |
544 | (cdr (assoc action x-dnd-xdnd-to-action)))) | |
545 | (reply-action (car (rassoc (car action-type) | |
546 | x-dnd-xdnd-to-action))) | |
547 | (accept ;; 1 = accept, 0 = reject | |
548 | (if (and reply-action action-type) 1 0)) | |
549 | (list-to-send | |
550 | (list (string-to-number | |
551 | (frame-parameter frame 'outer-window-id)) | |
552 | accept ;; 1 = Accept, 0 = reject. | |
553 | (x-dnd-get-drop-x-y frame window) | |
554 | (x-dnd-get-drop-width-height | |
555 | frame window (eq accept 1)) | |
556 | (or reply-action 0) | |
557 | ))) | |
558 | (x-send-client-message | |
559 | frame dnd-source frame "XdndStatus" 32 list-to-send) | |
560 | )) | |
561 | ||
562 | ((equal "XdndLeave" message) | |
563 | (x-dnd-forget-drop window)) | |
564 | ||
565 | ((equal "XdndDrop" message) | |
566 | (if (windowp window) (select-window window)) | |
567 | (let* ((dnd-source (aref data 0)) | |
568 | (value (and (x-dnd-current-type window) | |
569 | ;; Get selection with target DELETE if move. | |
570 | (x-get-selection-internal | |
571 | 'XdndSelection | |
572 | (intern (x-dnd-current-type window))))) | |
573 | success action ret-action) | |
574 | ||
575 | (setq action (if value | |
576 | (condition-case info | |
577 | (x-dnd-drop-data event frame window value | |
578 | (x-dnd-current-type window)) | |
579 | (error | |
580 | (message "Error: %s" info) | |
581 | nil)))) | |
582 | ||
583 | (setq success (if action 1 0)) | |
584 | (setq ret-action | |
585 | (if (eq success 1) | |
586 | (or (car (rassoc action x-dnd-xdnd-to-action)) | |
587 | "XdndActionPrivate") | |
588 | 0)) | |
589 | ||
590 | (x-send-client-message | |
591 | frame dnd-source frame "XdndFinished" 32 | |
592 | (list (string-to-number (frame-parameter frame 'outer-window-id)) | |
593 | success ;; 1 = Success, 0 = Error | |
594 | (if success "XdndActionPrivate" 0) | |
595 | )) | |
596 | (x-dnd-forget-drop window))) | |
597 | ||
598 | (t (error "Unknown XDND message %s %s" message data)))) | |
599 | ||
600 | (provide 'x-dnd) | |
601 | ||
95e224b7 | 602 | ;;; arch-tag: b621fb7e-50da-4323-850b-5fc71ae64621 |
133aad74 | 603 | ;;; x-dnd.el ends here |