+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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-atom data)))))
+
+
+;;;
+