lisp/x-dnd.el

   1 ;;; x-dnd.el --- drag and drop support for X  -*- coding: utf-8 -*-
   2
   3 ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Jan Djärv <jan.h.d@swipnet.se>
   7 ;; Maintainer: FSF
   8 ;; Keywords: window, drag, drop
   9 ;; Package: emacs
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  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
  43 types 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     (,(purecopy "text/uri-list") . x-dnd-handle-uri-list)
  58     (,(purecopy "text/x-moz-url") . x-dnd-handle-moz-url)
  59     (,(purecopy "_NETSCAPE_URL") . x-dnd-handle-uri-list)
  60     (,(purecopy "FILE_NAME") . x-dnd-handle-file-name)
  61     (,(purecopy "UTF8_STRING") . x-dnd-insert-utf8-text)
  62     (,(purecopy "text/plain;charset=UTF-8") . x-dnd-insert-utf8-text)
  63     (,(purecopy "text/plain;charset=utf-8") . x-dnd-insert-utf8-text)
  64     (,(purecopy "text/unicode") . x-dnd-insert-utf16-text)
  65     (,(purecopy "text/plain") . dnd-insert-text)
  66     (,(purecopy "COMPOUND_TEXT") . x-dnd-insert-ctext)
  67     (,(purecopy "STRING") . dnd-insert-text)
  68     (,(purecopy "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 occurred, 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)
  77 if drop is successful, nil if not."
  78   :version "22.1"
  79   :type 'alist
  80   :group 'x)
  81
  82 (defcustom x-dnd-known-types
  83   (mapcar 'purecopy
  84   '("text/uri-list"
  85     "text/x-moz-url"
  86     "_NETSCAPE_URL"
  87     "FILE_NAME"
  88     "UTF8_STRING"
  89     "text/plain;charset=UTF-8"
  90     "text/plain;charset=utf-8"
  91     "text/unicode"
  92     "text/plain"
  93     "COMPOUND_TEXT"
  94     "STRING"
  95     "TEXT"
  96     ))
  97   "The types accepted by default for dropped data.
  98 The types are chosen in the order they appear in the list."
  99   :version "22.1"
 100   :type '(repeat string)
 101   :group 'x
 102 )
 103
 104 ;; Internal variables
 105
 106 (defvar x-dnd-current-state nil
 107   "The current state for a drop.
 108 This is an alist with one entry for each display.  The value for each display
 109 is a vector that contains the state for drag and drop for that display.
 110 Elements in the vector are:
 111 Last buffer drag was in,
 112 last window drag was in,
 113 types available for drop,
 114 the action suggested by the source,
 115 the type we want for the drop,
 116 the action we want for the drop,
 117 any protocol specific data.")
 118
 119 (defvar x-dnd-empty-state [nil nil nil nil nil nil nil])
 120
 121 (declare-function x-register-dnd-atom "xselect.c")
 122
 123 (defun x-dnd-init-frame (&optional frame)
 124   "Setup drag and drop for FRAME (i.e. create appropriate properties)."
 125   (when (eq 'x (window-system frame))
 126     (x-register-dnd-atom "DndProtocol" frame)
 127     (x-register-dnd-atom "_MOTIF_DRAG_AND_DROP_MESSAGE" frame)
 128     (x-register-dnd-atom "XdndEnter" frame)
 129     (x-register-dnd-atom "XdndPosition" frame)
 130     (x-register-dnd-atom "XdndLeave" frame)
 131     (x-register-dnd-atom "XdndDrop" frame)
 132     (x-dnd-init-xdnd-for-frame frame)
 133     (x-dnd-init-motif-for-frame frame)))
 134
 135 (defun x-dnd-get-state-cons-for-frame (frame-or-window)
 136   "Return the entry in `x-dnd-current-state' for a frame or window."
 137   (let* ((frame (if (framep frame-or-window) frame-or-window
 138                   (window-frame frame-or-window)))
 139          (display (frame-parameter frame 'display)))
 140     (if (not (assoc display x-dnd-current-state))
 141         (push (cons display (copy-sequence x-dnd-empty-state))
 142               x-dnd-current-state))
 143     (assoc display x-dnd-current-state)))
 144
 145 (defun x-dnd-get-state-for-frame (frame-or-window)
 146   "Return the state in `x-dnd-current-state' for a frame or window."
 147   (cdr (x-dnd-get-state-cons-for-frame frame-or-window)))
 148
 149 (defun x-dnd-default-test-function (window action types)
 150   "The default test function for drag and drop.
 151 WINDOW is where the mouse is when this function is called.  It may be
 152 a frame if the mouse is over the menu bar, scroll bar or tool bar.
 153 ACTION is the suggested action from the source, and TYPES are the
 154 types the drop data can have.  This function only accepts drops with
 155 types in `x-dnd-known-types'.  It always returns the action private."
 156   (let ((type (x-dnd-choose-type types)))
 157     (when type (cons 'private type))))
 158
 159
 160 (defun x-dnd-current-type (frame-or-window)
 161   "Return the type we want the DND data to be in for the current drop.
 162 FRAME-OR-WINDOW is the frame or window that the mouse is over."
 163   (aref (x-dnd-get-state-for-frame frame-or-window) 4))
 164
 165 (defun x-dnd-forget-drop (frame-or-window)
 166   "Remove all state for the last drop.
 167 FRAME-OR-WINDOW is the frame or window that the mouse is over."
 168   (setcdr (x-dnd-get-state-cons-for-frame frame-or-window)
 169           (copy-sequence x-dnd-empty-state)))
 170
 171 (defun x-dnd-maybe-call-test-function (window action)
 172   "Call `x-dnd-test-function' if something has changed.
 173 WINDOW is the window the mouse is over.  ACTION is the suggested
 174 action from the source.  If nothing has changed, return the last
 175 action and type we got from `x-dnd-test-function'."
 176   (let ((buffer (when (window-live-p window)
 177                   (window-buffer window)))
 178         (current-state (x-dnd-get-state-for-frame window)))
 179     (unless (and (equal buffer (aref current-state 0))
 180                  (equal window (aref current-state 1))
 181                  (equal action (aref current-state 3)))
 182       (save-current-buffer
 183         (when buffer (set-buffer buffer))
 184         (let* ((action-type (funcall x-dnd-test-function
 185                                      window
 186                                      action
 187                                      (aref current-state 2)))
 188                (handler (cdr (assoc (cdr action-type) x-dnd-types-alist))))
 189           ;; Ignore action-type if we have no handler.
 190           (setq current-state
 191                 (x-dnd-save-state window
 192                                   action
 193                                   (when handler action-type)))))))
 194   (let ((current-state (x-dnd-get-state-for-frame window)))
 195     (cons (aref current-state 5)
 196           (aref current-state 4))))
 197
 198 (defun x-dnd-save-state (window action action-type &optional types extra-data)
 199   "Save the state of the current drag and drop.
 200 WINDOW is the window the mouse is over.  ACTION is the action suggested
 201 by the source.  ACTION-TYPE is the result of calling `x-dnd-test-function'.
 202 If given, TYPES are the types for the drop data that the source supports.
 203 EXTRA-DATA is data needed for a specific protocol."
 204   (let ((current-state (x-dnd-get-state-for-frame window)))
 205     (aset current-state 5 (car action-type))
 206     (aset current-state 4 (cdr action-type))
 207     (aset current-state 3 action)
 208     (when types (aset current-state 2 types))
 209     (when extra-data (aset current-state 6 extra-data))
 210     (aset current-state 1 window)
 211     (aset current-state 0 (and (window-live-p window) (window-buffer window)))
 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 handled, 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-value '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 handled, 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
 310 occurred on.  WINDOW is the window of FRAME where the drop happened.
 311 DATA is the data received from the source, and type is the type for DATA,
 312 see `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 (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 (declare-function x-window-property "xfns.c"
 363                   (prop &optional frame type source delete-p vector-ret-p))
 364
 365 (defun x-dnd-handle-old-kde (event frame window message format data)
 366   "Open the files in a KDE 1.x drop."
 367   (let ((values (x-window-property "DndSelection" frame nil 0 t)))
 368     (x-dnd-handle-uri-list window 'private
 369                            (replace-regexp-in-string "\0$" "" values))))
 370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 371
 372
 373
 374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 375 ;;;  XDND protocol.
 376
 377 (defconst x-dnd-xdnd-to-action
 378   '(("XdndActionPrivate" . private)
 379     ("XdndActionCopy" . copy)
 380     ("XdndActionMove" . move)
 381     ("XdndActionLink" . link)
 382     ("XdndActionAsk" . ask))
 383   "Mapping from XDND action types to lisp symbols.")
 384
 385 (declare-function x-change-window-property "xfns.c"
 386                   (prop value &optional frame type format outer-P))
 387
 388 (defun x-dnd-init-xdnd-for-frame (frame)
 389   "Set the XdndAware property for FRAME to indicate that we do XDND."
 390   (x-change-window-property "XdndAware"
 391                             '(5)        ;; The version of XDND we support.
 392                             frame "ATOM" 32 t))
 393
 394 (defun x-dnd-get-drop-width-height (frame w accept)
 395   "Return the width/height to be sent in a XDndStatus message.
 396 FRAME is the frame and W is the window where the drop happened.
 397 If ACCEPT is nil return 0 (empty rectangle),
 398 otherwise if W is a window, return its width/height,
 399 otherwise return the frame width/height."
 400   (if accept
 401       (if (windowp w)   ;; w is not a window if dropping on the menu bar,
 402                         ;; scroll bar or tool bar.
 403           (let ((edges (window-inside-pixel-edges w)))
 404             (cons
 405              (- (nth 2 edges) (nth 0 edges))    ;; right - left
 406              (- (nth 3 edges) (nth 1 edges))))  ;; bottom - top
 407         (cons (frame-pixel-width frame)
 408               (frame-pixel-height frame)))
 409     0))
 410
 411 (defun x-dnd-get-drop-x-y (frame w)
 412   "Return the x/y coordinates to be sent in a XDndStatus message.
 413 Coordinates are required to be absolute.
 414 FRAME is the frame and W is the window where the drop happened.
 415 If W is a window, return its absolute corrdinates,
 416 otherwise return the frame coordinates."
 417   (let* ((frame-left (frame-parameter frame 'left))
 418          ;; If the frame is outside the display, frame-left looks like
 419          ;; '(0 -16).  Extract the -16.
 420          (frame-real-left (if (consp frame-left) (car (cdr frame-left))
 421                             frame-left))
 422          (frame-top (frame-parameter frame 'top))
 423          (frame-real-top (if (consp frame-top) (car (cdr frame-top))
 424                            frame-top)))
 425     (if (windowp w)
 426         (let ((edges (window-inside-pixel-edges w)))
 427           (cons
 428            (+ frame-real-left (nth 0 edges))
 429            (+ frame-real-top (nth 1 edges))))
 430       (cons frame-real-left frame-real-top))))
 431
 432 (declare-function x-get-atom-name "xselect.c" (value &optional frame))
 433 (declare-function x-send-client-message "xselect.c"
 434                   (display dest from message-type format values))
 435 (declare-function x-get-selection-internal "xselect.c"
 436                   (selection-symbol target-type &optional time-stamp))
 437
 438 (defun x-dnd-handle-xdnd (event frame window message format data)
 439   "Receive one XDND event (client message) and send the appropriate reply.
 440 EVENT is the client message.  FRAME is where the mouse is now.
 441 WINDOW is the window within FRAME where the mouse is now.
 442 FORMAT is 32 (not used).  MESSAGE is the data part of an XClientMessageEvent."
 443   (cond ((equal "XdndEnter" message)
 444          (let* ((flags (aref data 1))
 445                 (version (and (consp flags) (ash (car flags) -8)))
 446                 (more-than-3 (and (consp flags) (cdr flags)))
 447                 (dnd-source (aref data 0)))
 448            (if version  ;; If flags is bad, version will be nil.
 449                (x-dnd-save-state
 450                 window nil nil
 451                 (if (> more-than-3 0)
 452                     (x-window-property "XdndTypeList"
 453                                        frame "AnyPropertyType"
 454                                        dnd-source nil t)
 455                   (vector (x-get-atom-name (aref data 2))
 456                           (x-get-atom-name (aref data 3))
 457                           (x-get-atom-name (aref data 4))))))))
 458
 459         ((equal "XdndPosition" message)
 460          (let* ((x (car (aref data 2)))
 461                 (y (cdr (aref data 2)))
 462                 (action (x-get-atom-name (aref data 4)))
 463                 (dnd-source (aref data 0))
 464                 (dnd-time (aref data 3))
 465                 (action-type (x-dnd-maybe-call-test-function
 466                               window
 467                               (cdr (assoc action x-dnd-xdnd-to-action))))
 468                 (reply-action (car (rassoc (car action-type)
 469                                            x-dnd-xdnd-to-action)))
 470                 (accept ;; 1 = accept, 0 = reject
 471                  (if (and reply-action action-type) 1 0))
 472                 (list-to-send
 473                  (list (string-to-number
 474                         (frame-parameter frame 'outer-window-id))
 475                        accept ;; 1 = Accept, 0 = reject.
 476                        (x-dnd-get-drop-x-y frame window)
 477                        (x-dnd-get-drop-width-height
 478                         frame window (eq accept 1))
 479                        (or reply-action 0)
 480                        )))
 481            (x-send-client-message
 482             frame dnd-source frame "XdndStatus" 32 list-to-send)
 483            ))
 484
 485         ((equal "XdndLeave" message)
 486          (x-dnd-forget-drop window))
 487
 488         ((equal "XdndDrop" message)
 489          (if (windowp window) (select-window window))
 490          (let* ((dnd-source (aref data 0))
 491                 (value (and (x-dnd-current-type window)
 492                             (x-get-selection-internal
 493                              'XdndSelection
 494                              (intern (x-dnd-current-type window)))))
 495                 success action ret-action)
 496
 497            (setq action (if value
 498                             (condition-case info
 499                                 (x-dnd-drop-data event frame window value
 500                                                  (x-dnd-current-type window))
 501                               (error
 502                                (message "Error: %s" info)
 503                                nil))))
 504
 505            (setq success (if action 1 0))
 506            (setq ret-action
 507                  (if (eq success 1)
 508                      (or (car (rassoc action x-dnd-xdnd-to-action))
 509                          "XdndActionPrivate")
 510                    0))
 511
 512            (x-send-client-message
 513             frame dnd-source frame "XdndFinished" 32
 514             (list (string-to-number (frame-parameter frame 'outer-window-id))
 515                   success       ;; 1 = Success, 0 = Error
 516                   (if success "XdndActionPrivate" 0)
 517                   ))
 518            (x-dnd-forget-drop window)))
 519
 520         (t (error "Unknown XDND message %s %s" message data))))
 521
 522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 523 ;;;  Motif protocol.
 524
 525 (defun x-dnd-init-motif-for-frame (frame)
 526   "Set _MOTIF_DRAG_RECEIVER_INFO for FRAME to indicate that we do Motif DND."
 527   (x-change-window-property "_MOTIF_DRAG_RECEIVER_INFO"
 528                             (list
 529                              (byteorder)
 530                              0                  ; The Motif DND version.
 531                              5                  ; We want drag dynamic.
 532                              0 0 0 0 0 0 0
 533                              0 0 0 0 0 0)       ; Property must be 16 bytes.
 534                             frame "_MOTIF_DRAG_RECEIVER_INFO" 8 t))
 535
 536 (defun x-dnd-get-motif-value (data offset size byteorder)
 537   (cond ((eq size 2)
 538          (if (eq byteorder ?l)
 539              (+ (ash (aref data (1+ offset)) 8)
 540                 (aref data offset))
 541            (+ (ash (aref data offset) 8)
 542               (aref data (1+ offset)))))
 543
 544         ((eq size 4)
 545          (if (eq byteorder ?l)
 546              (cons (+ (ash (aref data (+ 3 offset)) 8)
 547                       (aref data (+ 2 offset)))
 548                    (+ (ash (aref data (1+ offset)) 8)
 549                       (aref data offset)))
 550            (cons (+ (ash (aref data offset) 8)
 551                     (aref data (1+ offset)))
 552                  (+ (ash (aref data (+ 2 offset)) 8)
 553                     (aref data (+ 3 offset))))))))
 554
 555 (defun x-dnd-motif-value-to-list (value size byteorder)
 556   (let ((bytes (cond ((eq size 2)
 557                       (list (logand (lsh value -8) ?\xff)
 558                             (logand value ?\xff)))
 559
 560                      ((eq size 4)
 561                       (if (consp value)
 562                           (list (logand (lsh (car value) -8) ?\xff)
 563                                 (logand (car value) ?\xff)
 564                                 (logand (lsh (cdr value) -8) ?\xff)
 565                                 (logand (cdr value) ?\xff))
 566                         (list (logand (lsh value -24) ?\xff)
 567                               (logand (lsh value -16) ?\xff)
 568                               (logand (lsh value -8) ?\xff)
 569                               (logand value ?\xff)))))))
 570     (if (eq byteorder ?l)
 571         (reverse bytes)
 572       bytes)))
 573
 574
 575 (defvar x-dnd-motif-message-types
 576   '((0 . XmTOP_LEVEL_ENTER)
 577     (1 . XmTOP_LEVEL_LEAVE)
 578     (2 . XmDRAG_MOTION)
 579     (3 . XmDROP_SITE_ENTER)
 580     (4 . XmDROP_SITE_LEAVE)
 581     (5 . XmDROP_START)
 582     (6 . XmDROP_FINISH)
 583     (7 . XmDRAG_DROP_FINISH)
 584     (8 . XmOPERATION_CHANGED))
 585   "Mapping from numbers to Motif DND message types.")
 586
 587 (defvar x-dnd-motif-to-action
 588   '((1 . move)
 589     (2 . copy)
 590     (3 . link)  ; Both 3 and 4 has been seen as link.
 591     (4 . link)
 592     (2 . private)) ; Motif does not have private, so use copy for private.
 593   "Mapping from number to operation for Motif DND.")
 594
 595 (defun x-dnd-handle-motif (event frame window message-atom format data)
 596   (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types)))
 597          (source-byteorder (aref data 1))
 598          (my-byteorder (byteorder))
 599          (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder))
 600          (source-action (cdr (assoc (logand ?\xF source-flags)
 601                                     x-dnd-motif-to-action))))
 602
 603     (cond ((eq message-type 'XmTOP_LEVEL_ENTER)
 604            (let* ((dnd-source (x-dnd-get-motif-value
 605                                data 8 4 source-byteorder))
 606                   (selection-atom (x-dnd-get-motif-value
 607                                    data 12 4 source-byteorder))
 608                   (atom-name (x-get-atom-name selection-atom))
 609                   (types (when atom-name
 610                            (x-get-selection-internal (intern atom-name)
 611                                                      'TARGETS))))
 612              (x-dnd-forget-drop frame)
 613              (when types (x-dnd-save-state window nil nil
 614                                            types
 615                                            dnd-source))))
 616
 617           ;; Can not forget drop here, LEAVE comes before DROP_START and
 618           ;; we need the state in DROP_START.
 619           ((eq message-type 'XmTOP_LEVEL_LEAVE)
 620            nil)
 621
 622           ((eq message-type 'XmDRAG_MOTION)
 623            (let* ((state (x-dnd-get-state-for-frame frame))
 624                   (timestamp (x-dnd-motif-value-to-list
 625                               (x-dnd-get-motif-value data 4 4
 626                                                      source-byteorder)
 627                               4 my-byteorder))
 628                   (x (x-dnd-motif-value-to-list
 629                       (x-dnd-get-motif-value data 8 2 source-byteorder)
 630                       2 my-byteorder))
 631                   (y (x-dnd-motif-value-to-list
 632                       (x-dnd-get-motif-value data 10 2 source-byteorder)
 633                       2 my-byteorder))
 634                   (dnd-source (aref state 6))
 635                   (first-move (not (aref state 3)))
 636                   (action-type (x-dnd-maybe-call-test-function
 637                                 window
 638                                 source-action))
 639                   (reply-action (car (rassoc (car action-type)
 640                                              x-dnd-motif-to-action)))
 641                   (reply-flags
 642                    (x-dnd-motif-value-to-list
 643                     (if reply-action
 644                         (+ reply-action
 645                            ?\x30        ; 30:  valid drop site
 646                            ?\x700)      ; 700: can do copy, move or link
 647                       ?\x30)            ; 30:  drop site, but noop.
 648                     2 my-byteorder))
 649                   (reply (append
 650                           (list
 651                            (+ ?\x80     ; 0x80 indicates a reply.
 652                               (if first-move
 653                                   3     ; First time, reply is SITE_ENTER.
 654                                 2))     ; Not first time, reply is DRAG_MOTION.
 655                            my-byteorder)
 656                           reply-flags
 657                           timestamp
 658                           x
 659                           y)))
 660              (x-send-client-message frame
 661                                     dnd-source
 662                                     frame
 663                                     "_MOTIF_DRAG_AND_DROP_MESSAGE"
 664                                     8
 665                                     reply)))
 666
 667           ((eq message-type 'XmOPERATION_CHANGED)
 668            (let* ((state (x-dnd-get-state-for-frame frame))
 669                   (timestamp (x-dnd-motif-value-to-list
 670                               (x-dnd-get-motif-value data 4 4 source-byteorder)
 671                               4 my-byteorder))
 672                   (dnd-source (aref state 6))
 673                   (action-type (x-dnd-maybe-call-test-function
 674                                 window
 675                                 source-action))
 676                   (reply-action (car (rassoc (car action-type)
 677                                              x-dnd-motif-to-action)))
 678                   (reply-flags
 679                    (x-dnd-motif-value-to-list
 680                     (if reply-action
 681                         (+ reply-action
 682                            ?\x30        ; 30:  valid drop site
 683                            ?\x700)      ; 700: can do copy, move or link
 684                       ?\x30)            ; 30:  drop site, but noop
 685                     2 my-byteorder))
 686                   (reply (append
 687                           (list
 688                            (+ ?\x80     ; 0x80 indicates a reply.
 689                               8)        ; 8 is OPERATION_CHANGED
 690                            my-byteorder)
 691                           reply-flags
 692                           timestamp)))
 693              (x-send-client-message frame
 694                                     dnd-source
 695                                     frame
 696                                     "_MOTIF_DRAG_AND_DROP_MESSAGE"
 697                                     8
 698                                     reply)))
 699
 700           ((eq message-type 'XmDROP_START)
 701            (let* ((x (x-dnd-motif-value-to-list
 702                       (x-dnd-get-motif-value data 8 2 source-byteorder)
 703                       2 my-byteorder))
 704                   (y (x-dnd-motif-value-to-list
 705                       (x-dnd-get-motif-value data 10 2 source-byteorder)
 706                       2 my-byteorder))
 707                   (selection-atom (x-dnd-get-motif-value
 708                                    data 12 4 source-byteorder))
 709                   (atom-name (x-get-atom-name selection-atom))
 710                   (dnd-source (x-dnd-get-motif-value
 711                                data 16 4 source-byteorder))
 712                   (action-type (x-dnd-maybe-call-test-function
 713                                 window
 714                                 source-action))
 715                   (reply-action (car (rassoc (car action-type)
 716                                              x-dnd-motif-to-action)))
 717                   (reply-flags
 718                    (x-dnd-motif-value-to-list
 719                     (if reply-action
 720                         (+ reply-action
 721                            ?\x30        ; 30:  valid drop site
 722                            ?\x700)      ; 700: can do copy, move or link
 723                       (+ ?\x30          ; 30:  drop site, but noop.
 724                          ?\x200))       ; 200: drop cancel.
 725                     2 my-byteorder))
 726                   (reply (append
 727                           (list
 728                            (+ ?\x80     ; 0x80 indicates a reply.
 729                               5)        ; DROP_START.
 730                            my-byteorder)
 731                           reply-flags
 732                           x
 733                           y))
 734                   (timestamp (x-dnd-get-motif-value
 735                               data 4 4 source-byteorder))
 736                   action)
 737
 738              (x-send-client-message frame
 739                                     dnd-source
 740                                     frame
 741                                     "_MOTIF_DRAG_AND_DROP_MESSAGE"
 742                                     8
 743                                     reply)
 744              (setq action
 745                    (when (and reply-action atom-name)
 746                      (let* ((value (x-get-selection-internal
 747                                     (intern atom-name)
 748                                     (intern (x-dnd-current-type window)))))
 749                        (when value
 750                          (condition-case info
 751                              (x-dnd-drop-data event frame window value
 752                                               (x-dnd-current-type window))
 753                            (error
 754                             (message "Error: %s" info)
 755                             nil))))))
 756              (x-get-selection-internal
 757               (intern atom-name)
 758               (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE)
 759               timestamp)
 760              (x-dnd-forget-drop frame)))
 761
 762           (t (error "Unknown Motif DND message %s %s" message-atom data)))))
 763
 764
 765 ;;;
 766
 767 (provide 'x-dnd)
 768
 769 ;; arch-tag: b621fb7e-50da-4323-850b-5fc71ae64621
 770 ;;; x-dnd.el ends here