diff options
Diffstat (limited to 'lisp/x-dnd.el')
| -rw-r--r-- | lisp/x-dnd.el | 877 |
1 files changed, 877 insertions, 0 deletions
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el new file mode 100644 index 00000000000..cdb0a63ace6 --- /dev/null +++ b/lisp/x-dnd.el @@ -0,0 +1,877 @@ +;;; x-dnd.el --- drag and drop support for X. + +;; Copyright (C) 2004 +;; Free Software Foundation, Inc. + +;; Author: Jan Dj,Ad(Brv <jan.h.d@swipnet.se> +;; Maintainer: FSF +;; Keywords: window, drag, drop + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This file provides the drop part only. Currently supported protocols +;; are XDND, Motif and the old KDE 1.x protocol. + +;;; Code: + +;;; Customizable variables + + +(defcustom x-dnd-test-function 'x-dnd-default-test-function + "The function drag and drop uses to determine if to accept or reject a drop. +The function takes three arguments, WINDOW ACTION and TYPES. +WINDOW is where the mouse is when the function is called. WINDOW may be a +frame if the mouse isn't over a real window (i.e. menu bar, tool bar or +scroll bar). ACTION is the suggested action from the drag and drop source, +one of the symbols move, copy link or ask. TYPES is a list of available types +for the drop. + +The function shall return nil to reject the drop or a cons with two values, +the wanted action as car and the wanted type as cdr. The wanted action +can be copy, move, link, ask or private. +The default value for this variable is `x-dnd-default-test-function'." + :type 'symbol + :group 'x) + +(defcustom x-dnd-protocol-alist + '( + ("^file:///" . x-dnd-open-local-file) ; XDND format. + ("^file://" . x-dnd-open-file) ; URL with host + ("^file:" . x-dnd-open-local-file) ; Old KDE, Motif, Sun + ) + + "The functions to call for different protocols when a drop is made. +This variable is used by `x-dnd-handle-uri-list' and `x-dnd-handle-moz-url'. +The list contains of (REGEXP . FUNCTION) pairs. +The functions shall take two arguments, URL, which is the URL dropped and +ACTION which is the action to be performed for the drop (move, copy, link, +private or ask). +If no match is found here, and the value of `browse-url-browser-function' +is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. +Insertion of text is not handeled by these functions, see `x-dnd-types-alist' +for that. +The function shall return the action done (move, copy, link or private) +if some action was made, or nil if the URL is ignored." + :type 'alist + :group 'x) + + +(defcustom x-dnd-types-alist + '( + ("text/uri-list" . x-dnd-handle-uri-list) + ("text/x-moz-url" . x-dnd-handle-moz-url) + ("_NETSCAPE_URL" . x-dnd-handle-uri-list) + ("FILE_NAME" . x-dnd-handle-file-name) + ("UTF8_STRING" . x-dnd-insert-utf8-text) + ("text/plain;charset=UTF-8" . x-dnd-insert-utf8-text) + ("text/plain;charset=utf-8" . x-dnd-insert-utf8-text) + ("text/unicode" . x-dnd-insert-utf16-text) + ("text/plain" . x-dnd-insert-text) + ("COMPOUND_TEXT" . x-dnd-insert-ctext) + ("STRING" . x-dnd-insert-text) + ("TEXT" . x-dnd-insert-text) + ) + "Which function to call to handle a drop of that type. +If the type for the drop is not present, or the function is nil, +the drop is rejected. The function takes three arguments, WINDOW, ACTION +and DATA. WINDOW is where the drop occured, ACTION is the action for +this drop (copy, move, link, private or ask) as determined by a previous +call to `x-dnd-test-function'. DATA is the drop data. +The function shall return the action used (copy, move, link or private) if drop +is successful, nil if not." + :type 'alist + :group 'x) + +(defcustom x-dnd-open-file-other-window nil + "If non-nil, always use find-file-other-window to open dropped files." + :type 'boolean + :group 'x) + +;; Internal variables + +(defvar x-dnd-known-types + '("text/uri-list" + "text/x-moz-url" + "_NETSCAPE_URL" + "FILE_NAME" + "UTF8_STRING" + "text/plain;charset=UTF-8" + "text/plain;charset=utf-8" + "text/unicode" + "text/plain" + "COMPOUND_TEXT" + "STRING" + "TEXT" + ) + "The types accepted by default for dropped data. +The types are chosen in the order they appear in the list.") + +(defvar x-dnd-current-state nil + "The current state for a drop. +This is an alist with one entry for each display. The value for each display +is a vector that contains the state for drag and drop for that display. +Elements in the vector are: +Last buffer drag was in, +last window drag was in, +types available for drop, +the action suggested by the source, +the type we want for the drop, +the action we want for the drop, +any protocol specific data.") + +(defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) + + + +(defun x-dnd-init-frame (&optional frame) + "Setup drag and drop for FRAME (i.e. create appropriate properties)." + (x-dnd-init-xdnd-for-frame frame) + (x-dnd-init-motif-for-frame frame)) + +(defun x-dnd-get-state-cons-for-frame (frame-or-window) + "Return the entry in x-dnd-current-state for a frame or window." + (let* ((frame (if (framep frame-or-window) frame-or-window + (window-frame frame-or-window))) + (display (frame-parameter frame 'display))) + (if (not (assoc display x-dnd-current-state)) + (push (cons display (copy-sequence x-dnd-empty-state)) + x-dnd-current-state)) + (assoc display x-dnd-current-state))) + +(defun x-dnd-get-state-for-frame (frame-or-window) + "Return the state in x-dnd-current-state for a frame or window." + (cdr (x-dnd-get-state-cons-for-frame frame-or-window))) + +(defun x-dnd-default-test-function (window action types) + "The default test function for drag and drop. +WINDOW is where the mouse is when this function is called. It may be a frame +if the mouse is over the menu bar, scroll bar or tool bar. +ACTION is the suggested action from the source, and TYPES are the +types the drop data can have. This function only accepts drops with +types in `x-dnd-known-types'. It always returns the action private." + (let ((type (x-dnd-choose-type types))) + (when type (cons 'private type)))) + + +(defun x-dnd-current-type (frame-or-window) + "Return the type we want the DND data to be in for the current drop. +FRAME-OR-WINDOW is the frame or window that the mouse is over." + (aref (x-dnd-get-state-for-frame frame-or-window) 4)) + +(defun x-dnd-forget-drop (frame-or-window) + "Remove all state for the last drop. +FRAME-OR-WINDOW is the frame or window that the mouse is over." + (setcdr (x-dnd-get-state-cons-for-frame frame-or-window) + (copy-sequence x-dnd-empty-state))) + +(defun x-dnd-maybe-call-test-function (window action) + "Call `x-dnd-test-function' if something has changed. +WINDOW is the window the mouse is over. ACTION is the suggested +action from the source. If nothing has changed, return the last +action and type we got from `x-dnd-test-function'." + (let ((buffer (when (and (windowp window) (window-live-p window)) + (window-buffer window))) + (current-state (x-dnd-get-state-for-frame window))) + (when (or (not (equal buffer (aref current-state 0))) + (not (equal window (aref current-state 1))) + (not (equal action (aref current-state 3)))) + (save-excursion + (when buffer (set-buffer buffer)) + (let* ((action-type (funcall x-dnd-test-function + window + action + (aref current-state 2))) + (handler (cdr (assoc (cdr action-type) x-dnd-types-alist)))) + ;; Ignore action-type if we have no handler. + (setq current-state + (x-dnd-save-state window + action + (when handler action-type))))))) + (let ((current-state (x-dnd-get-state-for-frame window))) + (cons (aref current-state 5) + (aref current-state 4)))) + +(defun x-dnd-save-state (window action action-type &optional types extra-data) + "Save the state of the current drag and drop. +WINDOW is the window the mouse is over. ACTION is the action suggested +by the source. ACTION-TYPE is the result of calling `x-dnd-test-function'. +If given, TYPES are the types for the drop data that the source supports. +EXTRA-DATA is data needed for a specific protocol." + (let ((current-state (x-dnd-get-state-for-frame window))) + (aset current-state 5 (car action-type)) + (aset current-state 4 (cdr action-type)) + (aset current-state 3 action) + (when types (aset current-state 2 types)) + (when extra-data (aset current-state 6 extra-data)) + (aset current-state 1 window) + (aset current-state 0 (if (and (windowp window) + (window-live-p window)) + (window-buffer window) nil)) + (setcdr (x-dnd-get-state-cons-for-frame window) current-state))) + + +(defun x-dnd-handle-one-url (window action arg) + "Handle one dropped url by calling the appropriate handler. +The handler is first localted by looking at `x-dnd-protocol-alist'. +If no match is found here, and the value of `browse-url-browser-function' +is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. +If no match is found, just call `x-dnd-insert-text'. +WINDOW is where the drop happend, ACTION is the action for the drop, +ARG is the URL that has been dropped. +Returns ACTION." + (require 'browse-url) + (let* ((uri (replace-regexp-in-string + "%[A-Z0-9][A-Z0-9]" + (lambda (arg) + (format "%c" (string-to-number (substring arg 1) 16))) + arg)) + ret) + (or + (catch 'done + (dolist (bf x-dnd-protocol-alist) + (when (string-match (car bf) uri) + (setq ret (funcall (cdr bf) uri action)) + (throw 'done t))) + nil) + (when (not (functionp browse-url-browser-function)) + (catch 'done + (dolist (bf browse-url-browser-function) + (when (string-match (car bf) uri) + (setq ret 'private) + (funcall (cdr bf) uri action) + (throw 'done t))) + nil)) + (progn + (x-dnd-insert-text window action uri) + (setq ret 'private))) + ret)) + + +(defun x-dnd-get-local-file-uri (uri) + "Return an uri converted to file:/// syntax if uri is a local file. +Return nil if URI is not a local file." + + ;; The hostname may be our hostname, in that case, convert to a local + ;; file. Otherwise return nil. TODO: How about an IP-address as hostname? + (let ((hostname (when (string-match "^file://\\([^/]*\\)" uri) + (downcase (match-string 1 uri)))) + (system-name-no-dot + (downcase (if (string-match "^[^\\.]+" system-name) + (match-string 0 system-name) + system-name)))) + (when (and hostname + (or (string-equal "localhost" hostname) + (string-equal (downcase system-name) hostname) + (string-equal system-name-no-dot hostname))) + (concat "file://" (substring uri (+ 7 (length hostname))))))) + +(defun x-dnd-get-local-file-name (uri &optional must-exist) + "Return file name converted from file:/// or file: syntax. +URI is the uri for the file. If MUST-EXIST is given and non-nil, +only return non-nil if the file exists. +Return nil if URI is not a local file." + (let ((f (cond ((string-match "^file:///" uri) ; XDND format. + (substring uri (1- (match-end 0)))) + ((string-match "^file:" uri) ; Old KDE, Motif, Sun + (substring uri (match-end 0)))))) + (when (and f must-exist) + (let* ((decoded-f (decode-coding-string + f + (or file-name-coding-system + default-file-name-coding-system))) + (try-f (if (file-readable-p decoded-f) decoded-f f))) + (when (file-readable-p try-f) try-f))))) + + +(defun x-dnd-open-local-file (uri action) + "Open a local file. +The file is opened in the current window, or a new window if +`x-dnd-open-file-other-window' is set. URI is the url for the file, +and must have the format file:file-name or file:///file-name. +The last / in file:/// is part of the file name. ACTION is ignored." + + (let* ((f (x-dnd-get-local-file-name uri t))) + (when f + (if (file-readable-p f) + (progn + (if x-dnd-open-file-other-window + (find-file-other-window f) + (find-file f)) + 'private) + (error "Can not read %s (%s)" f uri))))) + +(defun x-dnd-open-file (uri action) + "Open a local or remote file. +The file is opened in the current window, or a new window if +`x-dnd-open-file-other-window' is set. URI is the url for the file, +and must have the format file://hostname/file-name. ACTION is ignored. +The last / in file://hostname/ is part of the file name." + + ;; The hostname may be our hostname, in that case, convert to a local + ;; file. Otherwise return nil. + (let ((local-file (x-dnd-get-local-file-uri uri))) + (when local-file (x-dnd-open-local-file local-file action)))) + + +(defun x-dnd-handle-moz-url (window action data) + "Handle one item of type text/x-moz-url. +WINDOW is the window where the drop happened. ACTION is ignored. +DATA is the moz-url, which is formatted as two strings separated by \r\n. +The first string is the URL, the second string is the title of that URL. +DATA is encoded in utf-16. Decode the URL and call `x-dnd-handle-uri-list'." + ;; Mozilla and applications based on it (Galeon for example) uses + ;; text/unicode, but it is impossible to tell if it is le or be. Use what + ;; the machine Emacs runs on use. This looses if dropping between machines + ;; with different endian, but it is the best we can do. + (let* ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le)) + (string (decode-coding-string data coding)) + (strings (split-string string "[\r\n]" t)) + ;; Can one drop more than one moz-url ?? Assume not. + (url (car strings)) + (title (car (cdr strings)))) + (x-dnd-handle-uri-list window action url))) + +(defun x-dnd-insert-utf8-text (window action text) + "Decode the UTF-8 text and insert it at point. +TEXT is the text as a string, WINDOW is the window where the drop happened." + (x-dnd-insert-text window action (decode-coding-string text 'utf-8))) + +(defun x-dnd-insert-utf16-text (window action text) + "Decode the UTF-16 text and insert it at point. +TEXT is the text as a string, WINDOW is the window where the drop happened." + ;; See comment in x-dnd-handle-moz-url about coding. + (let ((coding (if (eq (byteorder) ?B) 'utf-16be 'utf-16le))) + (x-dnd-insert-text window action (decode-coding-string text coding)))) + +(defun x-dnd-insert-ctext (window action text) + "Decode the compound text and insert it at point. +TEXT is the text as a string, WINDOW is the window where the drop happened." + (x-dnd-insert-text window action + (decode-coding-string text + 'compound-text-with-extensions))) + +(defun x-dnd-insert-text (window action text) + "Insert text at point or push to the kill ring if buffer is read only. +TEXT is the text as a string, WINDOW is the window where the drop happened." + (if (or buffer-read-only + (not (windowp window))) + (progn + (kill-new text) + (message + (substitute-command-keys + "The dropped text can be accessed with \\[yank]"))) + (insert text)) + action) + +(defun x-dnd-handle-uri-list (window action string) + "Split an uri-list into separate URIs and call `x-dnd-handle-one-url'. +WINDOW is the window where the drop happened. +STRING is the uri-list as a string. The URIs are separated by \r\n." + (let ((uri-list (split-string string "[\0\r\n]" t)) + retval) + (dolist (bf uri-list) + ;; If one URL is handeled, treat as if the whole drop succeeded. + (let ((did-action (x-dnd-handle-one-url window action bf))) + (when did-action (setq retval did-action)))) + retval)) + +(defun x-dnd-handle-file-name (window action string) + "Prepend file:// to file names and call `x-dnd-handle-one-url'. +WINDOW is the window where the drop happened. +STRING is the file names as a string, separated by nulls." + (let ((uri-list (split-string string "[\0\r\n]" t)) + retval) + (dolist (bf uri-list) + ;; If one URL is handeled, treat as if the whole drop succeeded. + (let* ((file-uri (concat "file://" bf)) + (did-action (x-dnd-handle-one-url window action file-uri))) + (when did-action (setq retval did-action)))) + retval)) + + +(defun x-dnd-choose-type (types &optional known-types) + "Choose which type we want to receive for the drop. +TYPES are the types the source of the drop offers, a vector of type names +as strings or symbols. Select among the types in `x-dnd-known-types' or +KNOWN-TYPES if given, and return that type name. +If no suitable type is found, return nil." + (let* ((known-list (or known-types x-dnd-known-types)) + (first-known-type (car known-list)) + (types-array types) + (found (when first-known-type + (catch 'done + (dotimes (i (length types-array)) + (let* ((type (aref types-array i)) + (typename (if (symbolp type) + (symbol-name type) type))) + (when (equal first-known-type typename) + (throw 'done first-known-type)))) + nil)))) + + (if (and (not found) (cdr known-list)) + (x-dnd-choose-type types (cdr known-list)) + found))) + +(defun x-dnd-drop-data (event frame window data type) + "Drop one data item onto a frame. +EVENT is the client message for the drop, FRAME is the frame the drop occurred +on. WINDOW is the window of FRAME where the drop happened. DATA is the data +received from the source, and type is the type for DATA, see +`x-dnd-types-alist'). + +Returns the action used (move, copy, link, private) if drop was successful, +nil if not." + (let* ((type-info (assoc type x-dnd-types-alist)) + (handler (cdr type-info)) + (state (x-dnd-get-state-for-frame frame)) + (action (aref state 5)) + (w (posn-window (event-start event)))) + (when handler + (if (and (windowp w) (window-live-p w)) + ;; If dropping in a window, open files in that window rather + ;; than in a new widow. + (let ((x-dnd-open-file-other-window nil)) + (goto-char (posn-point (event-start event))) + (funcall handler window action data)) + (let ((x-dnd-open-file-other-window t)) ;; Dropping on non-window. + (select-frame frame) + (funcall handler window action data)))))) + +(defun x-dnd-handle-drag-n-drop-event (event) + "Receive drag and drop events (X client messages). +Currently XDND, Motif and old KDE 1.x protocols are recognized." + (interactive "e") + (let* ((client-message (car (cdr (cdr event)))) + (window (posn-window (event-start event))) + (message-atom (aref client-message 0)) + (frame (aref client-message 1)) + (format (aref client-message 2)) + (data (aref client-message 3))) + + (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. + (x-dnd-handle-old-kde event frame window message-atom format data)) + + ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif + (x-dnd-handle-motif event frame window message-atom format data)) + + ((and (> (length message-atom) 4) ; XDND protocol. + (equal "Xdnd" (substring message-atom 0 4))) + (x-dnd-handle-xdnd event frame window message-atom format data))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Old KDE protocol. Only dropping of files. + +(defun x-dnd-handle-old-kde (event frame window message format data) + "Open the files in a KDE 1.x drop." + (let ((values (x-window-property "DndSelection" frame nil 0 t))) + (x-dnd-handle-uri-list window 'private + (replace-regexp-in-string "\0$" "" values)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; XDND protocol. + +(defvar x-dnd-xdnd-to-action + '(("XdndActionPrivate" . private) + ("XdndActionCopy" . copy) + ("XdndActionMove" . move) + ("XdndActionLink" . link) + ("XdndActionAsk" . ask)) + "Mapping from XDND action types to lisp symbols.") + +(defun x-dnd-init-xdnd-for-frame (frame) + "Set the XdndAware property for FRAME to indicate that we do XDND." + (x-change-window-property "XdndAware" + '(5) ;; The version of XDND we support. + frame "ATOM" 32 t)) + +(defun x-dnd-get-drop-width-height (frame w accept) + "Return the widht/height to be sent in a XDndStatus message. +FRAME is the frame and W is the window where the drop happened. +If ACCEPT is nil return 0 (empty rectangle), +otherwise if W is a window, return its widht/height, +otherwise return the frame width/height." + (if accept + (if (windowp w) ;; w is not a window if dropping on the menu bar, + ;; scroll bar or tool bar. + (let ((edges (window-inside-pixel-edges w))) + (cons + (- (nth 2 edges) (nth 0 edges)) ;; right - left + (- (nth 3 edges) (nth 1 edges)))) ;; bottom - top + (cons (frame-pixel-width frame) + (frame-pixel-height frame))) + 0)) + +(defun x-dnd-get-drop-x-y (frame w) + "Return the x/y coordinates to be sent in a XDndStatus message. +Coordinates are required to be absolute. +FRAME is the frame and W is the window where the drop happened. +If W is a window, return its absolute corrdinates, +otherwise return the frame coordinates." + (let* ((frame-left (frame-parameter frame 'left)) + ;; If the frame is outside the display, frame-left looks like + ;; '(0 -16). Extract the -16. + (frame-real-left (if (consp frame-left) (car (cdr frame-left)) + frame-left)) + (frame-top (frame-parameter frame 'top)) + (frame-real-top (if (consp frame-top) (car (cdr frame-top)) + frame-top))) + (if (windowp w) + (let ((edges (window-inside-pixel-edges w))) + (cons + (+ frame-real-left (nth 0 edges)) + (+ frame-real-top (nth 1 edges)))) + (cons frame-real-left frame-real-top)))) + +(defun x-dnd-handle-xdnd (event frame window message format data) + "Receive one XDND event (client message) and send the appropriate reply. +EVENT is the client message. FRAME is where the mouse is now. +WINDOW is the window within FRAME where the mouse is now. +FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." + (cond ((equal "XdndEnter" message) + (let ((version (ash (car (aref data 1)) -8)) + (more-than-3 (cdr (aref data 1))) + (dnd-source (aref data 0))) + (x-dnd-save-state + window nil nil + (if (> more-than-3 0) + (x-window-property "XdndTypeList" + frame "AnyPropertyType" + dnd-source nil t) + (vector (x-get-atom-name (aref data 2)) + (x-get-atom-name (aref data 3)) + (x-get-atom-name (aref data 4))))))) + + ((equal "XdndPosition" message) + (let* ((x (car (aref data 2))) + (y (cdr (aref data 2))) + (action (x-get-atom-name (aref data 4))) + (dnd-source (aref data 0)) + (dnd-time (aref data 3)) + (action-type (x-dnd-maybe-call-test-function + window + (cdr (assoc action x-dnd-xdnd-to-action)))) + (reply-action (car (rassoc (car action-type) + x-dnd-xdnd-to-action))) + (accept ;; 1 = accept, 0 = reject + (if (and reply-action action-type) 1 0)) + (list-to-send + (list (string-to-number + (frame-parameter frame 'outer-window-id)) + accept ;; 1 = Accept, 0 = reject. + (x-dnd-get-drop-x-y frame window) + (x-dnd-get-drop-width-height + frame window (eq accept 1)) + (or reply-action 0) + ))) + (x-send-client-message + frame dnd-source frame "XdndStatus" 32 list-to-send) + )) + + ((equal "XdndLeave" message) + (x-dnd-forget-drop window)) + + ((equal "XdndDrop" message) + (if (windowp window) (select-window window)) + (let* ((dnd-source (aref data 0)) + (value (and (x-dnd-current-type window) + (x-get-selection-internal + 'XdndSelection + (intern (x-dnd-current-type window))))) + success action ret-action) + + (setq action (if value + (condition-case info + (x-dnd-drop-data event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))) + + (setq success (if action 1 0)) + (setq ret-action + (if (eq success 1) + (or (car (rassoc action x-dnd-xdnd-to-action)) + "XdndActionPrivate") + 0)) + + (x-send-client-message + frame dnd-source frame "XdndFinished" 32 + (list (string-to-number (frame-parameter frame 'outer-window-id)) + success ;; 1 = Success, 0 = Error + (if success "XdndActionPrivate" 0) + )) + (x-dnd-forget-drop window))) + + (t (error "Unknown XDND message %s %s" message data)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Motif protocol. + +(defun x-dnd-init-motif-for-frame (frame) + "Set _MOTIF_DRAG_RECEIVER_INFO for FRAME to indicate that we do Motif DND." + (x-change-window-property "_MOTIF_DRAG_RECEIVER_INFO" + (list + (byteorder) + 0 ; The Motif DND version. + 5 ; We want drag dynamic. + 0 0 0 0 0 0 0 + 0 0 0 0 0 0) ; Property must be 16 bytes. + frame "_MOTIF_DRAG_RECEIVER_INFO" 8 t)) + +(defun x-dnd-get-motif-value (data offset size byteorder) + (cond ((eq size 2) + (if (eq byteorder ?l) + (+ (ash (aref data (1+ offset)) 8) + (aref data offset)) + (+ (ash (aref data offset) 8) + (aref data (1+ offset))))) + + ((eq size 4) + (if (eq byteorder ?l) + (cons (+ (ash (aref data (+ 3 offset)) 8) + (aref data (+ 2 offset))) + (+ (ash (aref data (1+ offset)) 8) + (aref data offset))) + (cons (+ (ash (aref data offset) 8) + (aref data (1+ offset))) + (+ (ash (aref data (+ 2 offset)) 8) + (aref data (+ 3 offset)))))))) + +(defun x-dnd-motif-value-to-list (value size byteorder) + (let ((bytes (cond ((eq size 2) + (list (logand (lsh value -8) ?\xff) + (logand value ?\xff))) + + ((eq size 4) + (if (consp value) + (list (logand (lsh (car value) -8) ?\xff) + (logand (car value) ?\xff) + (logand (lsh (cdr value) -8) ?\xff) + (logand (cdr value) ?\xff)) + (list (logand (lsh value -24) ?\xff) + (logand (lsh value -16) ?\xff) + (logand (lsh value -8) ?\xff) + (logand value ?\xff))))))) + (if (eq byteorder ?l) + (reverse bytes) + bytes))) + + +(defvar x-dnd-motif-message-types + '((0 . XmTOP_LEVEL_ENTER) + (1 . XmTOP_LEVEL_LEAVE) + (2 . XmDRAG_MOTION) + (3 . XmDROP_SITE_ENTER) + (4 . XmDROP_SITE_LEAVE) + (5 . XmDROP_START) + (6 . XmDROP_FINISH) + (7 . XmDRAG_DROP_FINISH) + (8 . XmOPERATION_CHANGED)) + "Mapping from numbers to Motif DND message types.") + +(defvar x-dnd-motif-to-action + '((1 . move) + (2 . copy) + (3 . link) ; Both 3 and 4 has been seen as link. + (4 . link) + (2 . private)) ; Motif does not have private, so use copy for private. + "Mapping from number to operation for Motif DND.") + +(defun x-dnd-handle-motif (event frame window message-atom format data) + (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types))) + (source-byteorder (aref data 1)) + (my-byteorder (byteorder)) + (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder)) + (source-action (cdr (assoc (logand ?\xF source-flags) + x-dnd-motif-to-action)))) + + (cond ((eq message-type 'XmTOP_LEVEL_ENTER) + (let* ((dnd-source (x-dnd-get-motif-value + data 8 4 source-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (types (when atom-name + (x-get-selection-internal (intern atom-name) + 'TARGETS)))) + (x-dnd-forget-drop frame) + (when types (x-dnd-save-state window nil nil + types + dnd-source)))) + + ;; Can not forget drop here, LEAVE comes before DROP_START and + ;; we need the state in DROP_START. + ((eq message-type 'XmTOP_LEVEL_LEAVE) + nil) + + ((eq message-type 'XmDRAG_MOTION) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 + source-byteorder) + 4 my-byteorder)) + (x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (dnd-source (aref state 6)) + (first-move (not (aref state 3))) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop. + 2 my-byteorder)) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + (if first-move + 3 ; First time, reply is SITE_ENTER. + 2)) ; Not first time, reply is DRAG_MOTION. + my-byteorder) + reply-flags + timestamp + x + y))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) + + ((eq message-type 'XmOPERATION_CHANGED) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 source-byteorder) + 4 my-byteorder)) + (dnd-source (aref state 6)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop + 2 my-byteorder)) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 8) ; 8 is OPERATION_CHANGED + my-byteorder) + reply-flags + timestamp))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) + + ((eq message-type 'XmDROP_START) + (let* ((x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (dnd-source (x-dnd-get-motif-value + data 16 4 source-byteorder)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + (+ ?\x30 ; 30: drop site, but noop. + ?\x200)) ; 200: drop cancel. + 2 my-byteorder)) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 5) ; DROP_START. + my-byteorder) + reply-flags + x + y)) + (timestamp (x-dnd-get-motif-value + data 4 4 source-byteorder)) + action) + + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (setq action + (when (and reply-action atom-name) + (let* ((value (x-get-selection-internal + (intern atom-name) + (intern (x-dnd-current-type window))))) + (when value + (condition-case info + (x-dnd-drop-data event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))))) + (x-get-selection-internal + (intern atom-name) + (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) + timestamp) + (x-dnd-forget-drop frame))) + + (t (error "Unknown Motif DND message %s %s" message data))))) + + +;;; + + +(provide 'x-dnd) + +;;; arch-tag: b621fb7e-50da-4323-850b-5fc71ae64621 +;;; x-dnd.el ends here |