code.delx.au - gnu-emacs/blob - lisp/x-dnd.el

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