x-dnd.el: Add COMPOUND_TEXT, handle FILE_NAME correctly, add Motif (CDE)

protocol.

2 files changed, 311 insertions, 26 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index cd9bee3d932..177bb887d35 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,20 @@
+2004-02-10  Jan Dj,Ad(Brv  <jan.h.d@swipnet.se>
+
+        * x-dnd.el (x-dnd-types-alist): Add COMPOUND_TEXT,  FILE_NAME
+        handeled by x-dnd-handle-file-name.
+        (x-dnd-known-types): Add COMPOUND_TEXT.
+        (x-dnd-init-frame): Call x-dnd-init-motif-for-frame.
+        (x-dnd-get-state-cons-for-frame): Must do copy-sequence on
+        x-dnd-empty-state.
+        (x-dnd-forget-drop): Ditto.
+        (x-dnd-save-state): Add optional parameter extra-data (for Motif).
+        (x-dnd-handle-one-url): Return private when inserting text.
+        (x-dnd-insert-ctext): New function.
+        (x-dnd-handle-file-name): New function for FILE_NAME.
+        (x-dnd-handle-drag-n-drop-event): Add Motif, remove call to error.
+        (x-dnd-init-motif-for-frame, x-dnd-get-motif-value)
+        (x-dnd-motif-value-to-list, x-dnd-handle-motif): New functions.
+
 2004-02-10  Kenichi Handa  <handa@m17n.org>
 
         * term/x-win.el (x-select-utf8-or-ctext): Use compare-strings
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index ad55e3cbd34..14681ae7497 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -77,13 +77,14 @@ if some action was made, or nil if the URL is ignored."
   '(
     ("text/uri-list" . x-dnd-handle-uri-list)
     ("text/x-moz-url" . x-dnd-handle-moz-url)
-    ("FILE_NAME" . x-dnd-handle-uri-list)
     ("_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)
     )
@@ -108,13 +109,14 @@ is successful, nil if not."
 (defvar x-dnd-known-types
   '("text/uri-list"
     "text/x-moz-url"
-    "FILE_NAME"
     "_NETSCAPE_URL"
+    "FILE_NAME"
     "UTF8_STRING"
     "text/plain;charset=UTF-8"
     "text/plain;charset=utf-8"
     "text/unicode"
     "text/plain"
+    "COMPOUND_TEXT"
     "STRING"
     "TEXT"
     )
@@ -131,15 +133,17 @@ 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.")
+the action we want for the drop,
+any protocol specific data.")
 
-(defvar x-dnd-empty-state [nil nil nil nil nil nil])
+(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-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."
@@ -147,7 +151,8 @@ the action we want for the drop.")
                   (window-frame frame-or-window)))
          (display (frame-parameter frame 'display)))
     (if (not (assoc display x-dnd-current-state))
-        (push (cons display x-dnd-empty-state) 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)
@@ -173,7 +178,8 @@ FRAME-OR-WINDOW is the frame or window that the mouse is over."
 (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) x-dnd-empty-state))
+  (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.
@@ -202,16 +208,18 @@ action and type we got from `x-dnd-test-function'."
     (cons (aref current-state 5)
           (aref current-state 4))))
 
-(defun x-dnd-save-state (window action action-type &optional types)
+(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."
+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)
-    (if types (aset current-state 2 types))
+    (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))
@@ -219,15 +227,6 @@ If given, TYPES are the types for the drop data that the source supports."
     (setcdr (x-dnd-get-state-cons-for-frame window) current-state)))
 
 
-(defun x-dnd-test-and-save-state (window action types)
-  "Test if drop shall be accepted, and save the state for future reference.
-ACTION is the suggested action by the source.
-TYPES is a list of types the source supports."
-  (x-dnd-save-state window
-                    action
-                    (x-dnd-maybe-call-test-function window action)
-                    types))
-
 (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'.
@@ -259,7 +258,9 @@ Returns ACTION."
              (funcall (cdr bf) uri action)
              (throw 'done t)))
          nil))
-     (x-dnd-insert-text window action uri))
+     (progn
+       (x-dnd-insert-text window action uri)
+       (setq ret 'private)))
     ret))
 
 
@@ -352,6 +353,13 @@ TEXT is the text as a string, WINDOW is the window where the drop happened."
 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-16le)))
 
+(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."
@@ -377,6 +385,19 @@ STRING is the uri-list as a string.  The URIs are separated by \r\n."
         (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.
@@ -438,14 +459,16 @@ TODO: Add Motif and OpenWindows."
          (format (aref client-message 2))
          (data (aref client-message 3)))
 
-    (cond ((equal "DndProtocol" message-atom)   ;; Old KDE 1.x.
+    (cond ((equal "DndProtocol" message-atom)   ; Old KDE 1.x.
            (x-dnd-handle-old-kde event frame window message-atom format data))
 
-          ((and (> (length message-atom) 4)     ;; XDND protocol.
+          ((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))
+           (x-dnd-handle-xdnd event frame window message-atom format data)))))
 
-          (t (error "Unknown DND atom: %s" message-atom)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;  Old KDE protocol.  Only dropping of files.
@@ -471,7 +494,7 @@ TODO: Add Motif and OpenWindows."
   "Mapping from XDND action types to lisp symbols.")
 
 (defun x-dnd-init-xdnd-for-frame (frame)
-  "Set the XdndAware for FRAME to indicate that we do XDND."
+  "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))
@@ -566,7 +589,6 @@ FORMAT is 32 (not used).  MESSAGE is the data part of an XClientMessageEvent."
          (if (windowp window) (select-window window))
          (let* ((dnd-source (aref data 0))
                 (value (and (x-dnd-current-type window)
-                            ;; Get selection with target DELETE if move.
                             (x-get-selection-internal
                              'XdndSelection
                              (intern (x-dnd-current-type window)))))
@@ -597,6 +619,252 @@ FORMAT is 32 (not used).  MESSAGE is the data part of an XClientMessageEvent."
 
         (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