LCOV - code coverage report
Current view: top level - lisp - x-dnd.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 393 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 28 0.0 %

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

Generated by: LCOV version 1.12