| 1 | ;;; x-dnd.el --- drag and drop support for X -*- coding: utf-8 -*- |
| 2 | |
| 3 | ;; Copyright (C) 2004-2014 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 | (when (eq 'x (window-system frame)) |
| 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) |
| 131 | (x-dnd-init-xdnd-for-frame frame) |
| 132 | (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 | (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)) |
| 140 | (push (cons display (copy-sequence x-dnd-empty-state)) |
| 141 | x-dnd-current-state)) |
| 142 | (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 | (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 | (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." |
| 167 | (setcdr (x-dnd-get-state-cons-for-frame frame-or-window) |
| 168 | (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 | (let ((buffer (when (window-live-p window) |
| 176 | (window-buffer window))) |
| 177 | (current-state (x-dnd-get-state-for-frame window))) |
| 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 |
| 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 |
| 190 | (x-dnd-save-state window |
| 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 | |
| 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 | (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) |
| 207 | (when types (aset current-state 2 types)) |
| 208 | (when extra-data (aset current-state 6 extra-data)) |
| 209 | (aset current-state 1 window) |
| 210 | (aset current-state 0 (and (window-live-p window) (window-buffer window))) |
| 211 | (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 (Galeon for example) uses |
| 221 | ;; text/unicode, but it is impossible to tell if it is le or be. Use what |
| 222 | ;; the machine Emacs runs on use. This loses if dropping between machines |
| 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)) |
| 226 | (strings (split-string string "[\r\n]" t)) |
| 227 | ;; Can one drop more than one moz-url ?? Assume not. |
| 228 | (url (car strings))) |
| 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." |
| 234 | (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 | (let ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le))) |
| 241 | (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 | (dnd-insert-text window action |
| 247 | (decode-coding-string text |
| 248 | '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 | (let ((uri-list (split-string string "[\0\r\n]" t)) |
| 255 | retval) |
| 256 | (dolist (bf uri-list) |
| 257 | ;; If one URL is handled, treat as if the whole drop succeeded. |
| 258 | (let ((did-action (dnd-handle-one-url window action bf))) |
| 259 | (when did-action (setq retval did-action)))) |
| 260 | 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 | (let ((uri-list (split-string string "[\0\r\n]" t)) |
| 267 | (coding (and (default-value 'enable-multibyte-characters) |
| 268 | (or file-name-coding-system |
| 269 | default-file-name-coding-system))) |
| 270 | retval) |
| 271 | (dolist (bf uri-list) |
| 272 | ;; If one URL is handled, treat as if the whole drop succeeded. |
| 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 "/") "/"))) |
| 277 | (did-action (dnd-handle-one-url window action file-uri))) |
| 278 | (when did-action (setq retval did-action)))) |
| 279 | 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 | (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. |
| 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 | (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 |
| 320 | (if (and (window-live-p w) |
| 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. |
| 325 | (progn |
| 326 | (when (not mouse-yank-at-point) |
| 327 | (goto-char (posn-point (event-start event)))) |
| 328 | (funcall handler window action data)) |
| 329 | ;; If we can't display the file here, |
| 330 | ;; make a new window for it. |
| 331 | (let ((dnd-open-file-other-window t)) |
| 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). |
| 337 | Currently XDND, Motif and old KDE 1.x protocols are recognized." |
| 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 | |
| 346 | (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. |
| 347 | (x-dnd-handle-old-kde event frame window message-atom format data)) |
| 348 | |
| 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. |
| 353 | (equal "Xdnd" (substring message-atom 0 4))) |
| 354 | (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 | (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 | |
| 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 | (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) |
| 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 | (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. |
| 413 | If W is a window, return its absolute coordinates, |
| 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 | |
| 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 | (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))) |
| 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 | (cond ((equal "XdndEnter" message) |
| 454 | (let* ((flags (aref data 1)) |
| 455 | (version (x-dnd-version-from-flags flags)) |
| 456 | (more-than-3 (x-dnd-more-than-3-from-flags flags)) |
| 457 | (dnd-source (aref data 0))) |
| 458 | (message "%s %s" version more-than-3) |
| 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)))))))) |
| 469 | |
| 470 | ((equal "XdndPosition" message) |
| 471 | (let* ((action (x-get-atom-name (aref data 4))) |
| 472 | (dnd-source (aref data 0)) |
| 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) |
| 485 | (x-dnd-get-drop-width-height |
| 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) |
| 500 | (x-get-selection-internal |
| 501 | 'XdndSelection |
| 502 | (intern (x-dnd-current-type window))))) |
| 503 | success action) |
| 504 | |
| 505 | (setq action (if value |
| 506 | (condition-case info |
| 507 | (x-dnd-drop-data event frame window value |
| 508 | (x-dnd-current-type window)) |
| 509 | (error |
| 510 | (message "Error: %s" info) |
| 511 | nil)))) |
| 512 | |
| 513 | (setq success (if action 1 0)) |
| 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 | |
| 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 | (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 | |
| 598 | (defun x-dnd-handle-motif (event frame window message-atom _format data) |
| 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 |
| 628 | (x-dnd-get-motif-value data 4 4 |
| 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 |
| 647 | (+ reply-action |
| 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 |
| 684 | (+ reply-action |
| 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 |
| 723 | (+ reply-action |
| 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)) |
| 737 | (timestamp (x-dnd-get-motif-value |
| 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) |
| 747 | (setq action |
| 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 |
| 754 | (x-dnd-drop-data event frame window value |
| 755 | (x-dnd-current-type window)) |
| 756 | (error |
| 757 | (message "Error: %s" info) |
| 758 | nil)))))) |
| 759 | (x-get-selection-internal |
| 760 | (intern atom-name) |
| 761 | (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) |
| 762 | timestamp) |
| 763 | (x-dnd-forget-drop frame))) |
| 764 | |
| 765 | (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 |