Handle be:actions field in Haiku DND messages

* lisp/term/haiku-win.el (haiku-get-numeric-enum): New function.
(haiku-numeric-enum): New macro.
(haiku-select-encode-xstring, haiku-select-encode-utf-8-string):
Replace hard-coded numeric enumerators.
(haiku-parse-drag-actions): New function.
(haiku-drag-and-drop): Use action returned by that function.
(x-begin-drag): Replace hard-coded enumerator.

1 files changed, 71 insertions, 31 deletions

diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index 024459e6475..f73c8b71252 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -174,6 +174,30 @@ VALUE as a unibyte string, or nil if VALUE was not a string."
                                           (insert "\n")))
                             (buffer-string))))))
 
+(defun haiku-get-numeric-enum (name)
+  "Return the numeric value of the system enumerator NAME."
+  (or (get name 'haiku-numeric-enum)
+      (let ((value 0)
+            (offset 0)
+            (string (symbol-name name)))
+        (cl-loop for octet across string
+                 do (progn
+                      (when (or (< octet 0)
+                                (> octet 255))
+                        (error "Out of range octet: %d" octet))
+                      (setq value
+                            (logior value
+                                    (lsh octet
+                                         (- (* (1- (length string)) 8)
+                                            offset))))
+                      (setq offset (+ offset 8))))
+        (prog1 value
+          (put name 'haiku-enumerator-id value)))))
+
+(defmacro haiku-numeric-enum (name)
+  "Expand to the numeric value NAME as a system identifier."
+  (haiku-get-numeric-enum name))
+
 (declare-function x-open-connection "haikufns.c")
 (declare-function x-handle-args "common-win")
 (declare-function haiku-selection-data "haikuselect.c")
@@ -237,7 +261,7 @@ under the type `text/plain;charset=iso-8859-1'."
                       (buffer-substring (nth 0 bounds)
                                         (nth 1 bounds)))))))
   (when (and (stringp value) (not (string-empty-p value)))
-    (list "text/plain;charset=iso-8859-1" 1296649541
+    (list "text/plain;charset=iso-8859-1" (haiku-numeric-enum MIME)
           (encode-coding-string value 'iso-latin-1))))
 
 (defun haiku-select-encode-utf-8-string (_selection value)
@@ -251,7 +275,7 @@ VALUE will be encoded as UTF-8 and stored under the type
                       (buffer-substring (nth 0 bounds)
                                         (nth 1 bounds)))))))
   (when (and (stringp value) (not (string-empty-p value)))
-    (list "text/plain" 1296649541
+    (list "text/plain" (haiku-numeric-enum MIME)
           (encode-coding-string value 'utf-8-unix))))
 
 (defun haiku-select-encode-file-name (_selection value)
@@ -304,6 +328,21 @@ or a pair of markers) and turns it into a file system reference."
                                  (file-name-nondirectory default-filename)))
     (error "x-file-dialog on a tty frame")))
 
+(defun haiku-parse-drag-actions (message)
+  "Given the drag-and-drop message MESSAGE, retrieve the desired action."
+  (let ((actions (cddr (assoc "be:actions" message)))
+        (sorted nil))
+    (dolist (action (list (haiku-numeric-enum DDCP)
+                          (haiku-numeric-enum DDMV)
+                          (haiku-numeric-enum DDLN)))
+      (when (member action actions)
+        (push sorted action)))
+    (cond
+     ((eql (car sorted) (haiku-numeric-enum DDCP)) 'copy)
+     ((eql (car sorted) (haiku-numeric-enum DDMV)) 'move)
+     ((eql (car sorted) (haiku-numeric-enum DDLN)) 'link)
+     (t 'private))))
+
 (defun haiku-drag-and-drop (event)
   "Handle specified drag-n-drop EVENT."
   (interactive "e")
@@ -311,34 +350,35 @@ or a pair of markers) and turns it into a file system reference."
          (window (posn-window (event-start event))))
     (if (eq string 'lambda) ; This means the mouse moved.
         (dnd-handle-movement (event-start event))
-      (cond
-       ;; Don't allow dropping on something other than the text area.
-       ;; It does nothing and doesn't work with text anyway.
-       ((posn-area (event-start event)))
-       ((assoc "refs" string)
-        (with-selected-window window
-          (dolist (filename (cddr (assoc "refs" string)))
-            (dnd-handle-one-url window 'private
-                                (concat "file:" filename)))))
-       ((assoc "text/uri-list" string)
-        (dolist (text (cddr (assoc "text/uri-list" string)))
-          (let ((uri-list (split-string text "[\0\r\n]" t)))
-            (dolist (bf uri-list)
-              (dnd-handle-one-url window 'private bf)))))
-       ((assoc "text/plain" string)
-        (with-selected-window window
-          (dolist (text (cddr (assoc "text/plain" string)))
-            (unless mouse-yank-at-point
-              (goto-char (posn-point (event-start event))))
-            (dnd-insert-text window 'private
-                             (if (multibyte-string-p text)
-                                 text
-                               (decode-coding-string text 'undecided))))))
-       ((not (eq (cdr (assq 'type string))
-                 3003)) ; Type of the placeholder message Emacs uses
-                        ; to cancel a drop on C-g.
-        (message "Don't know how to drop any of: %s"
-                 (mapcar #'car string)))))))
+      (let ((action (haiku-parse-drag-actions string)))
+        (cond
+         ;; Don't allow dropping on something other than the text area.
+         ;; It does nothing and doesn't work with text anyway.
+         ((posn-area (event-start event)))
+         ((assoc "refs" string)
+          (with-selected-window window
+            (dolist (filename (cddr (assoc "refs" string)))
+              (dnd-handle-one-url window action
+                                  (concat "file:" filename)))))
+         ((assoc "text/uri-list" string)
+          (dolist (text (cddr (assoc "text/uri-list" string)))
+            (let ((uri-list (split-string text "[\0\r\n]" t)))
+              (dolist (bf uri-list)
+                (dnd-handle-one-url window action bf)))))
+         ((assoc "text/plain" string)
+          (with-selected-window window
+            (dolist (text (cddr (assoc "text/plain" string)))
+              (unless mouse-yank-at-point
+                (goto-char (posn-point (event-start event))))
+              (dnd-insert-text window action
+                               (if (multibyte-string-p text)
+                                   text
+                                 (decode-coding-string text 'undecided))))))
+         ((not (eq (cdr (assq 'type string))
+                   3003)) ; Type of the placeholder message Emacs uses
+                          ; to cancel a drop on C-g.
+          (message "Don't know how to drop any of: %s"
+                   (mapcar #'car string))))))))
 
 (define-key special-event-map [drag-n-drop] 'haiku-drag-and-drop)
 
@@ -393,7 +433,7 @@ take effect on menu items until the menu bar is updated again."
                   ;; Add B_MIME_TYPE to the message if the type was not
                   ;; previously specified, or the type if it was.
                   (push (or (get-text-property 0 'type maybe-string)
-                            1296649541)
+                            (haiku-numeric-enum MIME))
                         (alist-get (car selection-result) message
                                    nil nil #'equal))))
               (if (not (consp (cadr selection-result)))