lisp/x-dnd.el

   1 ;;; x-dnd.el --- drag and drop support for X.
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009
   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 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 looses 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          (title (car (cdr strings))))
 230     (x-dnd-handle-uri-list window action url)))
 231
 232 (defun x-dnd-insert-utf8-text (window action text)
 233   "Decode the UTF-8 text and insert it at point.
 234 TEXT is the text as a string, WINDOW is the window where the drop happened."
 235   (dnd-insert-text window action (decode-coding-string text 'utf-8)))
 236
 237 (defun x-dnd-insert-utf16-text (window action text)
 238   "Decode the UTF-16 text and insert it at point.
 239 TEXT is the text as a string, WINDOW is the window where the drop happened."
 240   ;; See comment in x-dnd-handle-moz-url about coding.
 241   (let ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)))
 242     (dnd-insert-text window action (decode-coding-string text coding))))
 243
 244 (defun x-dnd-insert-ctext (window action text)
 245   "Decode the compound text and insert it at point.
 246 TEXT is the text as a string, WINDOW is the window where the drop happened."
 247   (dnd-insert-text window action
 248                    (decode-coding-string text
 249                                          'compound-text-with-extensions)))
 250
 251 (defun x-dnd-handle-uri-list (window action string)
 252   "Split an uri-list into separate URIs and call `dnd-handle-one-url'.
 253 WINDOW is the window where the drop happened.
 254 STRING is the uri-list as a string.  The URIs are separated by \\r\\n."
 255   (let ((uri-list (split-string string "[\0\r\n]" t))
 256         retval)
 257     (dolist (bf uri-list)
 258       ;; If one URL is handled, treat as if the whole drop succeeded.
 259       (let ((did-action (dnd-handle-one-url window action bf)))
 260         (when did-action (setq retval did-action))))
 261     retval))
 262
 263 (defun x-dnd-handle-file-name (window action string)
 264   "Convert file names to URLs and call `dnd-handle-one-url'.
 265 WINDOW is the window where the drop happened.
 266 STRING is the file names as a string, separated by nulls."
 267   (let ((uri-list (split-string string "[\0\r\n]" t))
 268         (coding (and (default-value 'enable-multibyte-characters)
 269                      (or file-name-coding-system
 270                          default-file-name-coding-system)))
 271         retval)
 272     (dolist (bf uri-list)
 273       ;; If one URL is handled, treat as if the whole drop succeeded.
 274       (if coding (setq bf (encode-coding-string bf coding)))
 275       (let* ((file-uri (concat "file://"
 276                                (mapconcat 'url-hexify-string
 277                                           (split-string bf "/") "/")))
 278              (did-action (dnd-handle-one-url window action file-uri)))
 279         (when did-action (setq retval did-action))))
 280     retval))
 281
 282
 283 (defun x-dnd-choose-type (types &optional known-types)
 284   "Choose which type we want to receive for the drop.
 285 TYPES are the types the source of the drop offers, a vector of type names
 286 as strings or symbols.  Select among the types in `x-dnd-known-types' or
 287 KNOWN-TYPES if given, and return that type name.
 288 If no suitable type is found, return nil."
 289   (let* ((known-list (or known-types x-dnd-known-types))
 290          (first-known-type (car known-list))
 291          (types-array types)
 292          (found (when first-known-type
 293                   (catch 'done
 294                     (dotimes (i (length types-array))
 295                       (let* ((type (aref types-array i))
 296                              (typename (if (symbolp type)
 297                                            (symbol-name type) type)))
 298                         (when (equal first-known-type typename)
 299                           (throw 'done first-known-type))))
 300                     nil))))
 301
 302     (if (and (not found) (cdr known-list))
 303         (x-dnd-choose-type types (cdr known-list))
 304       found)))
 305
 306 (defun x-dnd-drop-data (event frame window data type)
 307   "Drop one data item onto a frame.
 308 EVENT is the client message for the drop, FRAME is the frame the drop
 309 occurred on.  WINDOW is the window of FRAME where the drop happened.
 310 DATA is the data received from the source, and type is the type for DATA,
 311 see `x-dnd-types-alist').
 312
 313 Returns the action used (move, copy, link, private) if drop was successful,
 314 nil if not."
 315   (let* ((type-info (assoc type x-dnd-types-alist))
 316          (handler (cdr type-info))
 317          (state (x-dnd-get-state-for-frame frame))
 318          (action (aref state 5))
 319          (w (posn-window (event-start event))))
 320     (when handler
 321       (if (and (window-live-p w)
 322                (not (window-minibuffer-p w))
 323                (not (window-dedicated-p w)))
 324           ;; If dropping in an ordinary window which we could use,
 325           ;; let dnd-open-file-other-window specify what to do.
 326           (progn
 327             (when (not mouse-yank-at-point)
 328               (goto-char (posn-point (event-start event))))
 329             (funcall handler window action data))
 330         ;; If we can't display the file here,
 331         ;; make a new window for it.
 332         (let ((dnd-open-file-other-window t))
 333           (select-frame frame)
 334           (funcall handler window action data))))))
 335
 336 (defun x-dnd-handle-drag-n-drop-event (event)
 337   "Receive drag and drop events (X client messages).
 338 Currently XDND, Motif and old KDE 1.x protocols are recognized."
 339   (interactive "e")
 340   (let* ((client-message (car (cdr (cdr event))))
 341          (window (posn-window (event-start event)))
 342          (message-atom (aref client-message 0))
 343          (frame (aref client-message 1))
 344          (format (aref client-message 2))
 345          (data (aref client-message 3)))
 346
 347     (cond ((equal "DndProtocol" message-atom)   ; Old KDE 1.x.
 348            (x-dnd-handle-old-kde event frame window message-atom format data))
 349
 350           ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom)  ; Motif
 351            (x-dnd-handle-motif event frame window message-atom format data))
 352
 353           ((and (> (length message-atom) 4)     ; XDND protocol.
 354                 (equal "Xdnd" (substring message-atom 0 4)))
 355            (x-dnd-handle-xdnd event frame window message-atom format data)))))
 356
 357
 358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 359 ;;;  Old KDE protocol.  Only dropping of files.
 360
 361 (declare-function x-window-property "xfns.c"
 362                   (prop &optional frame type source delete-p vector-ret-p))
 363
 364 (defun x-dnd-handle-old-kde (event frame window message format data)
 365   "Open the files in a KDE 1.x drop."
 366   (let ((values (x-window-property "DndSelection" frame nil 0 t)))
 367     (x-dnd-handle-uri-list window 'private
 368                            (replace-regexp-in-string "\0$" "" values))))
 369 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 370
 371
 372
 373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 374 ;;;  XDND protocol.
 375
 376 (defconst x-dnd-xdnd-to-action
 377   '(("XdndActionPrivate" . private)
 378     ("XdndActionCopy" . copy)
 379     ("XdndActionMove" . move)
 380     ("XdndActionLink" . link)
 381     ("XdndActionAsk" . ask))
 382   "Mapping from XDND action types to lisp symbols.")
 383
 384 (declare-function x-change-window-property "xfns.c"
 385                   (prop value &optional frame type format outer-P))
 386
 387 (defun x-dnd-init-xdnd-for-frame (frame)
 388   "Set the XdndAware property for FRAME to indicate that we do XDND."
 389   (x-change-window-property "XdndAware"
 390                             '(5)        ;; The version of XDND we support.
 391                             frame "ATOM" 32 t))
 392
 393 (defun x-dnd-get-drop-width-height (frame w accept)
 394   "Return the width/height to be sent in a XDndStatus message.
 395 FRAME is the frame and W is the window where the drop happened.
 396 If ACCEPT is nil return 0 (empty rectangle),
 397 otherwise if W is a window, return its width/height,
 398 otherwise return the frame width/height."
 399   (if accept
 400       (if (windowp w)   ;; w is not a window if dropping on the menu bar,
 401                         ;; scroll bar or tool bar.
 402           (let ((edges (window-inside-pixel-edges w)))
 403             (cons
 404              (- (nth 2 edges) (nth 0 edges))    ;; right - left
 405              (- (nth 3 edges) (nth 1 edges))))  ;; bottom - top
 406         (cons (frame-pixel-width frame)
 407               (frame-pixel-height frame)))
 408     0))
 409
 410 (defun x-dnd-get-drop-x-y (frame w)
 411   "Return the x/y coordinates to be sent in a XDndStatus message.
 412 Coordinates are required to be absolute.
 413 FRAME is the frame and W is the window where the drop happened.
 414 If W is a window, return its absolute corrdinates,
 415 otherwise return the frame coordinates."
 416   (let* ((frame-left (frame-parameter frame 'left))
 417          ;; If the frame is outside the display, frame-left looks like
 418          ;; '(0 -16).  Extract the -16.
 419          (frame-real-left (if (consp frame-left) (car (cdr frame-left))
 420                             frame-left))
 421          (frame-top (frame-parameter frame 'top))
 422          (frame-real-top (if (consp frame-top) (car (cdr frame-top))
 423                            frame-top)))
 424     (if (windowp w)
 425         (let ((edges (window-inside-pixel-edges w)))
 426           (cons
 427            (+ frame-real-left (nth 0 edges))
 428            (+ frame-real-top (nth 1 edges))))
 429       (cons frame-real-left frame-real-top))))
 430
 431 (declare-function x-get-atom-name "xselect.c" (value &optional frame))
 432 (declare-function x-send-client-message "xselect.c"
 433                   (display dest from message-type format values))
 434 (declare-function x-get-selection-internal "xselect.c"
 435                   (selection-symbol target-type &optional time-stamp))
 436
 437 (defun x-dnd-handle-xdnd (event frame window message format data)
 438   "Receive one XDND event (client message) and send the appropriate reply.
 439 EVENT is the client message.  FRAME is where the mouse is now.
 440 WINDOW is the window within FRAME where the mouse is now.
 441 FORMAT is 32 (not used).  MESSAGE is the data part of an XClientMessageEvent."
 442   (cond ((equal "XdndEnter" message)
 443          (let* ((flags (aref data 1))
 444                 (version (and (consp flags) (ash (car flags) -8)))
 445                 (more-than-3 (and (consp flags) (cdr flags)))
 446                 (dnd-source (aref data 0)))
 447            (if version  ;; If flags is bad, version will be nil.
 448                (x-dnd-save-state
 449                 window nil nil
 450                 (if (> more-than-3 0)
 451                     (x-window-property "XdndTypeList"
 452                                        frame "AnyPropertyType"
 453                                        dnd-source nil t)
 454                   (vector (x-get-atom-name (aref data 2))
 455                           (x-get-atom-name (aref data 3))
 456                           (x-get-atom-name (aref data 4))))))))
 457
 458         ((equal "XdndPosition" message)
 459          (let* ((x (car (aref data 2)))
 460                 (y (cdr (aref data 2)))
 461                 (action (x-get-atom-name (aref data 4)))
 462                 (dnd-source (aref data 0))
 463                 (dnd-time (aref data 3))
 464                 (action-type (x-dnd-maybe-call-test-function
 465                               window
 466                               (cdr (assoc action x-dnd-xdnd-to-action))))
 467                 (reply-action (car (rassoc (car action-type)
 468                                            x-dnd-xdnd-to-action)))
 469                 (accept ;; 1 = accept, 0 = reject
 470                  (if (and reply-action action-type) 1 0))
 471                 (list-to-send
 472                  (list (string-to-number
 473                         (frame-parameter frame 'outer-window-id))
 474                        accept ;; 1 = Accept, 0 = reject.
 475                        (x-dnd-get-drop-x-y frame window)
 476                        (x-dnd-get-drop-width-height
 477                         frame window (eq accept 1))
 478                        (or reply-action 0)
 479                        )))
 480            (x-send-client-message
 481             frame dnd-source frame "XdndStatus" 32 list-to-send)
 482            ))
 483
 484         ((equal "XdndLeave" message)
 485          (x-dnd-forget-drop window))
 486
 487         ((equal "XdndDrop" message)
 488          (if (windowp window) (select-window window))
 489          (let* ((dnd-source (aref data 0))
 490                 (value (and (x-dnd-current-type window)
 491                             (x-get-selection-internal
 492                              'XdndSelection
 493                              (intern (x-dnd-current-type window)))))
 494                 success action ret-action)
 495
 496            (setq action (if value
 497                             (condition-case info
 498                                 (x-dnd-drop-data event frame window value
 499                                                  (x-dnd-current-type window))
 500                               (error
 501                                (message "Error: %s" info)
 502                                nil))))
 503
 504            (setq success (if action 1 0))
 505            (setq ret-action
 506                  (if (eq success 1)
 507                      (or (car (rassoc action x-dnd-xdnd-to-action))
 508                          "XdndActionPrivate")
 509                    0))
 510
 511            (x-send-client-message
 512             frame dnd-source frame "XdndFinished" 32
 513             (list (string-to-number (frame-parameter frame 'outer-window-id))
 514                   success       ;; 1 = Success, 0 = Error
 515                   (if success "XdndActionPrivate" 0)
 516                   ))
 517            (x-dnd-forget-drop window)))
 518
 519         (t (error "Unknown XDND message %s %s" message data))))
 520
 521 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 522 ;;;  Motif protocol.
 523
 524 (defun x-dnd-init-motif-for-frame (frame)
 525   "Set _MOTIF_DRAG_RECEIVER_INFO for FRAME to indicate that we do Motif DND."
 526   (x-change-window-property "_MOTIF_DRAG_RECEIVER_INFO"
 527                             (list
 528                              (byteorder)
 529                              0                  ; The Motif DND version.
 530                              5                  ; We want drag dynamic.
 531                              0 0 0 0 0 0 0
 532                              0 0 0 0 0 0)       ; Property must be 16 bytes.
 533                             frame "_MOTIF_DRAG_RECEIVER_INFO" 8 t))
 534
 535 (defun x-dnd-get-motif-value (data offset size byteorder)
 536   (cond ((eq size 2)
 537          (if (eq byteorder ?l)
 538              (+ (ash (aref data (1+ offset)) 8)
 539                 (aref data offset))
 540            (+ (ash (aref data offset) 8)
 541               (aref data (1+ offset)))))
 542
 543         ((eq size 4)
 544          (if (eq byteorder ?l)
 545              (cons (+ (ash (aref data (+ 3 offset)) 8)
 546                       (aref data (+ 2 offset)))
 547                    (+ (ash (aref data (1+ offset)) 8)
 548                       (aref data offset)))
 549            (cons (+ (ash (aref data offset) 8)
 550                     (aref data (1+ offset)))
 551                  (+ (ash (aref data (+ 2 offset)) 8)
 552                     (aref data (+ 3 offset))))))))
 553
 554 (defun x-dnd-motif-value-to-list (value size byteorder)
 555   (let ((bytes (cond ((eq size 2)
 556                       (list (logand (lsh value -8) ?\xff)
 557                             (logand value ?\xff)))
 558
 559                      ((eq size 4)
 560                       (if (consp value)
 561                           (list (logand (lsh (car value) -8) ?\xff)
 562                                 (logand (car value) ?\xff)
 563                                 (logand (lsh (cdr value) -8) ?\xff)
 564                                 (logand (cdr value) ?\xff))
 565                         (list (logand (lsh value -24) ?\xff)
 566                               (logand (lsh value -16) ?\xff)
 567                               (logand (lsh value -8) ?\xff)
 568                               (logand value ?\xff)))))))
 569     (if (eq byteorder ?l)
 570         (reverse bytes)
 571       bytes)))
 572
 573
 574 (defvar x-dnd-motif-message-types
 575   '((0 . XmTOP_LEVEL_ENTER)
 576     (1 . XmTOP_LEVEL_LEAVE)
 577     (2 . XmDRAG_MOTION)
 578     (3 . XmDROP_SITE_ENTER)
 579     (4 . XmDROP_SITE_LEAVE)
 580     (5 . XmDROP_START)
 581     (6 . XmDROP_FINISH)
 582     (7 . XmDRAG_DROP_FINISH)
 583     (8 . XmOPERATION_CHANGED))
 584   "Mapping from numbers to Motif DND message types.")
 585
 586 (defvar x-dnd-motif-to-action
 587   '((1 . move)
 588     (2 . copy)
 589     (3 . link)  ; Both 3 and 4 has been seen as link.
 590     (4 . link)
 591     (2 . private)) ; Motif does not have private, so use copy for private.
 592   "Mapping from number to operation for Motif DND.")
 593
 594 (defun x-dnd-handle-motif (event frame window message-atom format data)
 595   (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types)))
 596          (source-byteorder (aref data 1))
 597          (my-byteorder (byteorder))
 598          (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder))
 599          (source-action (cdr (assoc (logand ?\xF source-flags)
 600                                     x-dnd-motif-to-action))))
 601
 602     (cond ((eq message-type 'XmTOP_LEVEL_ENTER)
 603            (let* ((dnd-source (x-dnd-get-motif-value
 604                                data 8 4 source-byteorder))
 605                   (selection-atom (x-dnd-get-motif-value
 606                                    data 12 4 source-byteorder))
 607                   (atom-name (x-get-atom-name selection-atom))
 608                   (types (when atom-name
 609                            (x-get-selection-internal (intern atom-name)
 610                                                      'TARGETS))))
 611              (x-dnd-forget-drop frame)
 612              (when types (x-dnd-save-state window nil nil
 613                                            types
 614                                            dnd-source))))
 615
 616           ;; Can not forget drop here, LEAVE comes before DROP_START and
 617           ;; we need the state in DROP_START.
 618           ((eq message-type 'XmTOP_LEVEL_LEAVE)
 619            nil)
 620
 621           ((eq message-type 'XmDRAG_MOTION)
 622            (let* ((state (x-dnd-get-state-for-frame frame))
 623                   (timestamp (x-dnd-motif-value-to-list
 624                               (x-dnd-get-motif-value data 4 4
 625                                                      source-byteorder)
 626                               4 my-byteorder))
 627                   (x (x-dnd-motif-value-to-list
 628                       (x-dnd-get-motif-value data 8 2 source-byteorder)
 629                       2 my-byteorder))
 630                   (y (x-dnd-motif-value-to-list
 631                       (x-dnd-get-motif-value data 10 2 source-byteorder)
 632                       2 my-byteorder))
 633                   (dnd-source (aref state 6))
 634                   (first-move (not (aref state 3)))
 635                   (action-type (x-dnd-maybe-call-test-function
 636                                 window
 637                                 source-action))
 638                   (reply-action (car (rassoc (car action-type)
 639                                              x-dnd-motif-to-action)))
 640                   (reply-flags
 641                    (x-dnd-motif-value-to-list
 642                     (if reply-action
 643                         (+ reply-action
 644                            ?\x30        ; 30:  valid drop site
 645                            ?\x700)      ; 700: can do copy, move or link
 646                       ?\x30)            ; 30:  drop site, but noop.
 647                     2 my-byteorder))
 648                   (reply (append
 649                           (list
 650                            (+ ?\x80     ; 0x80 indicates a reply.
 651                               (if first-move
 652                                   3     ; First time, reply is SITE_ENTER.
 653                                 2))     ; Not first time, reply is DRAG_MOTION.
 654                            my-byteorder)
 655                           reply-flags
 656                           timestamp
 657                           x
 658                           y)))
 659              (x-send-client-message frame
 660                                     dnd-source
 661                                     frame
 662                                     "_MOTIF_DRAG_AND_DROP_MESSAGE"
 663                                     8
 664                                     reply)))
 665
 666           ((eq message-type 'XmOPERATION_CHANGED)
 667            (let* ((state (x-dnd-get-state-for-frame frame))
 668                   (timestamp (x-dnd-motif-value-to-list
 669                               (x-dnd-get-motif-value data 4 4 source-byteorder)
 670                               4 my-byteorder))
 671                   (dnd-source (aref state 6))
 672                   (action-type (x-dnd-maybe-call-test-function
 673                                 window
 674                                 source-action))
 675                   (reply-action (car (rassoc (car action-type)
 676                                              x-dnd-motif-to-action)))
 677                   (reply-flags
 678                    (x-dnd-motif-value-to-list
 679                     (if reply-action
 680                         (+ reply-action
 681                            ?\x30        ; 30:  valid drop site
 682                            ?\x700)      ; 700: can do copy, move or link
 683                       ?\x30)            ; 30:  drop site, but noop
 684                     2 my-byteorder))
 685                   (reply (append
 686                           (list
 687                            (+ ?\x80     ; 0x80 indicates a reply.
 688                               8)        ; 8 is OPERATION_CHANGED
 689                            my-byteorder)
 690                           reply-flags
 691                           timestamp)))
 692              (x-send-client-message frame
 693                                     dnd-source
 694                                     frame
 695                                     "_MOTIF_DRAG_AND_DROP_MESSAGE"
 696                                     8
 697                                     reply)))
 698
 699           ((eq message-type 'XmDROP_START)
 700            (let* ((x (x-dnd-motif-value-to-list
 701                       (x-dnd-get-motif-value data 8 2 source-byteorder)
 702                       2 my-byteorder))
 703                   (y (x-dnd-motif-value-to-list
 704                       (x-dnd-get-motif-value data 10 2 source-byteorder)
 705                       2 my-byteorder))
 706                   (selection-atom (x-dnd-get-motif-value
 707                                    data 12 4 source-byteorder))
 708                   (atom-name (x-get-atom-name selection-atom))
 709                   (dnd-source (x-dnd-get-motif-value
 710                                data 16 4 source-byteorder))
 711                   (action-type (x-dnd-maybe-call-test-function
 712                                 window
 713                                 source-action))
 714                   (reply-action (car (rassoc (car action-type)
 715                                              x-dnd-motif-to-action)))
 716                   (reply-flags
 717                    (x-dnd-motif-value-to-list
 718                     (if reply-action
 719                         (+ reply-action
 720                            ?\x30        ; 30:  valid drop site
 721                            ?\x700)      ; 700: can do copy, move or link
 722                       (+ ?\x30          ; 30:  drop site, but noop.
 723                          ?\x200))       ; 200: drop cancel.
 724                     2 my-byteorder))
 725                   (reply (append
 726                           (list
 727                            (+ ?\x80     ; 0x80 indicates a reply.
 728                               5)        ; DROP_START.
 729                            my-byteorder)
 730                           reply-flags
 731                           x
 732                           y))
 733                   (timestamp (x-dnd-get-motif-value
 734                               data 4 4 source-byteorder))
 735                   action)
 736
 737              (x-send-client-message frame
 738                                     dnd-source
 739                                     frame
 740                                     "_MOTIF_DRAG_AND_DROP_MESSAGE"
 741                                     8
 742                                     reply)
 743              (setq action
 744                    (when (and reply-action atom-name)
 745                      (let* ((value (x-get-selection-internal
 746                                     (intern atom-name)
 747                                     (intern (x-dnd-current-type window)))))
 748                        (when value
 749                          (condition-case info
 750                              (x-dnd-drop-data event frame window value
 751                                               (x-dnd-current-type window))
 752                            (error
 753                             (message "Error: %s" info)
 754                             nil))))))
 755              (x-get-selection-internal
 756               (intern atom-name)
 757               (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE)
 758               timestamp)
 759              (x-dnd-forget-drop frame)))
 760
 761           (t (error "Unknown Motif DND message %s %s" message-atom data)))))
 762
 763
 764 ;;;
 765
 766 (provide 'x-dnd)
 767
 768 ;; arch-tag: b621fb7e-50da-4323-850b-5fc71ae64621
 769 ;;; x-dnd.el ends here