Implement cross-program drag-and-drop on Haiku

* doc/lispref/frames.texi (Drag and Drop): Fix documentation of
`x-begin-drag' to match actual function arity.
* lisp/term/haiku-win.el (haiku-dnd-selection-value): New
variable.
(haiku-dnd-selection-converters): New variable.
(haiku-dnd-convert-string): New function.
(gui-backend-get-selection, gui-backend-set-selection): Handle
XdndSelection specially.
(x-begin-drag): New function.

* src/haiku_select.cc (be_create_simple_message)
(be_add_message_data): New functions.
* src/haiku_support.cc (WAIT_FOR_RELEASE): New message type.
(class EmacsView, MouseUp): If waiting for release, reply and
drop event.
(be_drag_message, be_drag_message_thread_entry): New functions.
* src/haiku_support.h: Update prototypes.

* src/haikuselect.c (lisp_to_type_code, haiku_lisp_to_message)
(Fhaiku_drag_message): New functions.
(syms_of_haikuselect): Define new subr.

* src/haikuselect.h: Update prototypes.

7 files changed, 411 insertions, 7 deletions

diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index 97283a525c4..31ebeb51b41 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -4042,7 +4042,7 @@ you want to alter Emacs behavior, you can customize these variables.
   On capable window systems, Emacs also supports dragging contents
 from its frames to windows of other applications.
 
-@defun x-begin-drag targets action &optional frame return-frame
+@defun x-begin-drag targets &optional action frame return-frame
 This function begins a drag from @var{frame}, and returns when the
 drag-and-drop operation ends, either because the drop was successful,
 or because the drop was rejected.  The drop occurs when all mouse
diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index 3b3f2f0874e..b7f1991381b 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -45,6 +45,25 @@
 
 (defvar haiku-initialized)
 
+(defvar haiku-dnd-selection-value nil
+  "The local value of the special `XdndSelection' selection.")
+
+(defvar haiku-dnd-selection-converters '((STRING . haiku-dnd-convert-string))
+  "Alist of X selection types to functions that act as selection converters.
+The functions should accept a single argument VALUE, describing
+the value of the drag-and-drop selection, and return a list of
+two elements TYPE and DATA, where TYPE is a string containing the
+MIME type of DATA, and DATA is a unibyte string, or nil if the
+data could not be converted.")
+
+(defun haiku-dnd-convert-string (value)
+  "Convert VALUE to a UTF-8 string and appropriate MIME type.
+Return a list of the appropriate MIME type, and UTF-8 data of
+VALUE as a unibyte string, or nil if VALUE was not a string."
+  (when (stringp value)
+    (list "text/plain" (string-to-unibyte
+                        (encode-coding-string value 'utf-8)))))
+
 (declare-function x-open-connection "haikufns.c")
 (declare-function x-handle-args "common-win")
 (declare-function haiku-selection-data "haikuselect.c")
@@ -52,6 +71,7 @@
 (declare-function haiku-selection-targets "haikuselect.c")
 (declare-function haiku-selection-owner-p "haikuselect.c")
 (declare-function haiku-put-resource "haikufns.c")
+(declare-function haiku-drag-message "haikuselect.c")
 
 (defun haiku--handle-x-command-line-resources (command-line-resources)
   "Handle command line X resources specified with the option `-xrm'.
@@ -97,11 +117,15 @@ If TYPE is nil, return \"text/plain\"."
   (if (eq data-type 'TARGETS)
       (apply #'vector (mapcar #'intern
                               (haiku-selection-targets type)))
-    (haiku-selection-data type (haiku--selection-type-to-mime data-type))))
+    (if (eq type 'XdndSelection)
+        haiku-dnd-selection-value
+      (haiku-selection-data type (haiku--selection-type-to-mime data-type)))))
 
 (cl-defmethod gui-backend-set-selection (type value
                                               &context (window-system haiku))
-  (haiku-selection-put type "text/plain" value t))
+  (if (eq type 'XdndSelection)
+      (setq haiku-dnd-selection-value value)
+    (haiku-selection-put type "text/plain" value t)))
 
 (cl-defmethod gui-backend-selection-exists-p (selection
                                               &context (window-system haiku))
@@ -159,6 +183,32 @@ This is necessary because on Haiku `use-system-tooltip' doesn't
 take effect on menu items until the menu bar is updated again."
   (force-mode-line-update t))
 
+(defun x-begin-drag (targets &optional action frame return-frame)
+  "SKIP: real doc in xfns.c."
+  (unless haiku-dnd-selection-value
+    (error "No local value for XdndSelection"))
+  (let ((message nil))
+    (dolist (target targets)
+      (let ((selection-converter (cdr (assoc (intern target)
+                                             haiku-dnd-selection-converters))))
+        (when selection-converter
+          (let ((selection-result
+                 (funcall selection-converter
+                          haiku-dnd-selection-value)))
+            (when selection-result
+              (let ((field (cdr (assoc (car selection-result) message))))
+                (unless (cadr field)
+                  ;; Add B_MIME_TYPE to the message if the type was not
+                  ;; previously defined.
+                  (push 1296649641 (alist-get (car selection-result) message
+                                              nil nil #'equal))))
+              (push (cadr selection-result)
+                    (cdr (alist-get (car selection-result) message
+                                    nil nil #'equal))))))))
+    (prog1 (or action 'XdndActionCopy)
+      (haiku-drag-message (or frame (selected-frame))
+                          message))))
+
 (add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher)
 
 (provide 'haiku-win)
diff --git a/src/haiku_select.cc b/src/haiku_select.cc
index abb07b20028..4212f60a480 100644
--- a/src/haiku_select.cc
+++ b/src/haiku_select.cc
@@ -321,3 +321,19 @@ be_get_message_data (void *message, const char *name,
   return msg->FindData (name, type_code,
 			index, buf_return, size_return) != B_OK;
 }
+
+void *
+be_create_simple_message (void)
+{
+  return new BMessage (B_SIMPLE_DATA);
+}
+
+int
+be_add_message_data (void *message, const char *name,
+		     int32 type_code, const void *buf,
+		     ssize_t buf_size)
+{
+  BMessage *msg = (BMessage *) message;
+
+  return msg->AddData (name, type_code, buf, buf_size) != B_OK;
+}
diff --git a/src/haiku_support.cc b/src/haiku_support.cc
index 884e3583e25..626b2fb607b 100644
--- a/src/haiku_support.cc
+++ b/src/haiku_support.cc
@@ -81,6 +81,7 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 #include "haiku_support.h"
 
 #define SCROLL_BAR_UPDATE 3000
+#define WAIT_FOR_RELEASE 3001
 
 static color_space dpy_color_space = B_NO_COLOR_SPACE;
 static key_map *key_map = NULL;
@@ -1177,6 +1178,7 @@ public:
 #endif
 
   BPoint tt_absl_pos;
+  BMessage *wait_for_release_message = NULL;
 
   color_space cspace;
 
@@ -1187,6 +1189,9 @@ public:
 
   ~EmacsView ()
   {
+    if (wait_for_release_message)
+      gui_abort ("Wait for release message still exists");
+
     TearDownDoubleBuffering ();
   }
 
@@ -1196,6 +1201,28 @@ public:
     cspace = B_RGBA32;
   }
 
+  void
+  MessageReceived (BMessage *msg)
+  {
+    uint32 buttons;
+    BLooper *looper = Looper ();
+
+    if (msg->what == WAIT_FOR_RELEASE)
+      {
+	if (wait_for_release_message)
+	  gui_abort ("Wait for release message already exists");
+
+	GetMouse (NULL, &buttons, false);
+
+	if (!buttons)
+	  msg->SendReply (msg);
+	else
+	  wait_for_release_message = looper->DetachCurrentMessage ();
+      }
+    else
+      BView::MessageReceived (msg);
+  }
+
 #ifdef USE_BE_CAIRO
   void
   DetachCairoSurface (void)
@@ -1483,6 +1510,16 @@ public:
 
     this->GetMouse (&point, &buttons, false);
 
+    if (!buttons && wait_for_release_message)
+      {
+	wait_for_release_message->SendReply (wait_for_release_message);
+	delete wait_for_release_message;
+	wait_for_release_message = NULL;
+
+	previous_buttons = buttons;
+	return;
+      }
+
     rq.window = this->Window ();
 
     if ((previous_buttons & B_PRIMARY_MOUSE_BUTTON)
@@ -3870,3 +3907,78 @@ BMessage_delete (void *message)
 {
   delete (BMessage *) message;
 }
+
+static int32
+be_drag_message_thread_entry (void *thread_data)
+{
+  BMessenger *messenger;
+  BMessage reply;
+
+  messenger = (BMessenger *) thread_data;
+  messenger->SendMessage (WAIT_FOR_RELEASE, &reply);
+
+  return 0;
+}
+
+void
+be_drag_message (void *view, void *message,
+		 void (*block_input_function) (void),
+		 void (*unblock_input_function) (void),
+		 void (*process_pending_signals_function) (void))
+{
+  EmacsView *vw = (EmacsView *) view;
+  BMessage *msg = (BMessage *) message;
+  BMessage wait_for_release;
+  BMessenger messenger (vw);
+  struct object_wait_info infos[2];
+  ssize_t stat;
+
+  block_input_function ();
+  if (!vw->LockLooper ())
+    gui_abort ("Failed to lock view looper for drag");
+
+  vw->DragMessage (msg, BRect (0, 0, 0, 0));
+  vw->UnlockLooper ();
+
+  infos[0].object = port_application_to_emacs;
+  infos[0].type = B_OBJECT_TYPE_PORT;
+  infos[0].events = B_EVENT_READ;
+
+  infos[1].object = spawn_thread (be_drag_message_thread_entry,
+				  "Drag waiter thread",
+				  B_DEFAULT_MEDIA_PRIORITY,
+				  (void *) &messenger);
+  infos[1].type = B_OBJECT_TYPE_THREAD;
+  infos[1].events = B_EVENT_INVALID;
+  unblock_input_function ();
+
+  if (infos[1].object < B_OK)
+    return;
+
+  block_input_function ();
+  resume_thread (infos[1].object);
+  unblock_input_function ();
+
+  while (true)
+    {
+      block_input_function ();
+      stat = wait_for_objects ((struct object_wait_info *) &infos, 2);
+      unblock_input_function ();
+
+      if (stat == B_INTERRUPTED || stat == B_TIMED_OUT
+	  || stat == B_WOULD_BLOCK)
+	continue;
+
+      if (stat < B_OK)
+	gui_abort ("Failed to wait for drag");
+
+      if (infos[0].events & B_EVENT_READ)
+	process_pending_signals_function ();
+
+      if (infos[1].events & B_EVENT_INVALID)
+	return;
+
+      infos[0].events = B_EVENT_READ;
+      infos[1].events = B_EVENT_INVALID;
+    }
+}
diff --git a/src/haiku_support.h b/src/haiku_support.h
index 78d51b83d8b..af7216286a7 100644
--- a/src/haiku_support.h
+++ b/src/haiku_support.h
@@ -945,6 +945,12 @@ extern "C"
   extern void
   BMessage_delete (void *message);
 
+  extern void
+  be_drag_message (void *view, void *message,
+		   void (*block_input_function) (void),
+		   void (*unblock_input_function) (void),
+		   void (*process_pending_signals_function) (void));
+
 #ifdef __cplusplus
   extern void *
   find_appropriate_view_for_draw (void *vw);
diff --git a/src/haikuselect.c b/src/haikuselect.c
index f291fa70edd..322e01f7918 100644
--- a/src/haikuselect.c
+++ b/src/haikuselect.c
@@ -23,6 +23,7 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 #include "coding.h"
 #include "haikuselect.h"
 #include "haikuterm.h"
+#include "haiku_support.h"
 
 #include <stdlib.h>
 
@@ -181,10 +182,10 @@ same as `SECONDARY'.  */)
 
 /* Return the Lisp representation of MESSAGE.
 
-   It is an alist of strings, denoting message parameter names, to a
-   list the form (TYPE . (DATA ...)), where TYPE is an integer
-   denoting the system data type of DATA, and DATA is in the general
-   case a unibyte string.
+   It is an alist of strings, denoting message field names, to a list
+   of the form (TYPE DATA ...), where TYPE is an integer denoting the
+   system data type of DATA, and DATA is in the general case a unibyte
+   string.
 
    If TYPE is a symbol instead of an integer, then DATA was specially
    decoded.  If TYPE is `ref', then DATA is the absolute file name of
@@ -311,6 +312,220 @@ haiku_message_to_lisp (void *message)
   return list;
 }
 
+static int32
+lisp_to_type_code (Lisp_Object obj)
+{
+  if (BIGNUMP (obj))
+    return (int32) bignum_to_intmax (obj);
+
+  if (FIXNUMP (obj))
+    return XFIXNUM (obj);
+
+  if (EQ (obj, Qstring))
+    return 'CSTR';
+  else if (EQ (obj, Qshort))
+    return 'SHRT';
+  else if (EQ (obj, Qlong))
+    return 'LONG';
+  else if (EQ (obj, Qllong))
+    return 'LLNG';
+  else if (EQ (obj, Qbyte))
+    return 'BYTE';
+  else if (EQ (obj, Qref))
+    return 'RREF';
+  else if (EQ (obj, Qchar))
+    return 'CHAR';
+  else if (EQ (obj, Qbool))
+    return 'BOOL';
+  else
+    return -1;
+}
+
+static void
+haiku_lisp_to_message (Lisp_Object obj, void *message)
+{
+  Lisp_Object tem, t1, name, type_sym, t2, data;
+  int32 type_code, long_data;
+  int16 short_data;
+  int64 llong_data;
+  int8 char_data;
+  bool bool_data;
+  intmax_t t4;
+
+  CHECK_LIST (obj);
+  for (tem = obj; CONSP (tem); tem = XCDR (tem))
+    {
+      t1 = XCAR (tem);
+      CHECK_CONS (t1);
+
+      name = XCAR (t1);
+      CHECK_STRING (name);
+
+      t1 = XCDR (t1);
+      CHECK_CONS (t1);
+
+      type_sym = XCAR (t1);
+      type_code = lisp_to_type_code (type_sym);
+
+      if (type_code == -1)
+	signal_error ("Unknown data type", type_sym);
+
+      CHECK_LIST (t1);
+      for (t2 = XCDR (t1); CONSP (t2); t2 = XCDR (t2))
+	{
+	  data = XCAR (t2);
+
+	  switch (type_code)
+	    {
+	    case 'RREF':
+	      signal_error ("Cannot deserialize data type", type_sym);
+	      break;
+
+	    case 'SHRT':
+	      if (!TYPE_RANGED_FIXNUMP (int16, data))
+		signal_error ("Invalid value", data);
+	      short_data = XFIXNUM (data);
+
+	      block_input ();
+	      be_add_message_data (message, SSDATA (name),
+				   type_code, &short_data,
+				   sizeof short_data);
+	      unblock_input ();
+	      break;
+
+	    case 'LONG':
+	      if (BIGNUMP (data))
+		{
+		  t4 = bignum_to_intmax (data);
+
+		  /* We know that int32 is signed.  */
+		  if (!t4 || t4 > TYPE_MINIMUM (int32)
+		      || t4 < TYPE_MAXIMUM (int32))
+		    signal_error ("Value too large", data);
+
+		  long_data = (int32) t4;
+		}
+	      else
+		{
+		  if (!TYPE_RANGED_FIXNUMP (int32, data))
+		    signal_error ("Invalid value", data);
+
+		  long_data = (int32) XFIXNUM (data);
+		}
+
+	      block_input ();
+	      be_add_message_data (message, SSDATA (name),
+				   type_code, &long_data,
+				   sizeof long_data);
+	      unblock_input ();
+	      break;
+
+	    case 'LLNG':
+	      if (BIGNUMP (data))
+		{
+		  t4 = bignum_to_intmax (data);
+
+		  if (!t4 || t4 > TYPE_MINIMUM (int64)
+		      || t4 < TYPE_MAXIMUM (int64))
+		    signal_error ("Value too large", data);
+
+		  llong_data = (int64) t4;
+		}
+	      else
+		{
+		  if (!TYPE_RANGED_FIXNUMP (int64, data))
+		    signal_error ("Invalid value", data);
+
+		  llong_data = (int64) XFIXNUM (data);
+		}
+
+	      block_input ();
+	      be_add_message_data (message, SSDATA (name),
+				   type_code, &llong_data,
+				   sizeof llong_data);
+	      unblock_input ();
+	      break;
+
+	    case 'CHAR':
+	    case 'BYTE':
+	      if (!TYPE_RANGED_FIXNUMP (int8, data))
+		signal_error ("Invalid value", data);
+	      char_data = XFIXNUM (data);
+
+	      block_input ();
+	      be_add_message_data (message, SSDATA (name),
+				   type_code, &char_data,
+				   sizeof char_data);
+	      unblock_input ();
+	      break;
+
+	    case 'BOOL':
+	      bool_data = !NILP (data);
+
+	      block_input ();
+	      be_add_message_data (message, SSDATA (name),
+				   type_code, &bool_data,
+				   sizeof bool_data);
+	      unblock_input ();
+	      break;
+
+	    default:
+	      CHECK_STRING (data);
+
+	      block_input ();
+	      be_add_message_data (message, SSDATA (name),
+				   type_code, SDATA (data),
+				   SBYTES (data));
+	      unblock_input ();
+	    }
+	}
+      CHECK_LIST_END (t2, t1);
+    }
+  CHECK_LIST_END (tem, obj);
+}
+
+DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message,
+       2, 2, 0,
+       doc: /* Begin dragging MESSAGE from FRAME.
+
+MESSAGE an alist of strings, denoting message field names, to a list
+the form (TYPE DATA ...), where TYPE is an integer denoting the system
+data type of DATA, and DATA is in the general case a unibyte string.
+
+If TYPE is a symbol instead of an integer, then DATA was specially
+decoded.  If TYPE is `ref', then DATA is the absolute file name of a
+file, or nil if decoding the file name failed.  If TYPE is `string',
+then DATA is a unibyte string.  If TYPE is `short', then DATA is a
+16-bit signed integer.  If TYPE is `long', then DATA is a 32-bit
+signed integer.  If TYPE is `llong', then DATA is a 64-bit signed
+integer. If TYPE is `byte' or `char', then DATA is an 8-bit signed
+integer.  If TYPE is `bool', then DATA is a boolean.
+
+FRAME is a window system frame that must be visible, from which the
+drag will originate.  */)
+  (Lisp_Object frame, Lisp_Object message)
+{
+  specpdl_ref idx;
+  void *be_message;
+  struct frame *f;
+
+  idx = SPECPDL_INDEX ();
+  f = decode_window_system_frame (frame);
+
+  if (!FRAME_VISIBLE_P (f))
+    error ("Frame is invisible");
+
+  be_message = be_create_simple_message ();
+
+  record_unwind_protect_ptr (BMessage_delete, be_message);
+  haiku_lisp_to_message (message, be_message);
+  be_drag_message (FRAME_HAIKU_VIEW (f), be_message,
+		   block_input, unblock_input,
+		   process_pending_signals);
+
+  return unbind_to (idx, Qnil);
+}
+
 void
 syms_of_haikuselect (void)
 {
@@ -333,4 +548,5 @@ syms_of_haikuselect (void)
   defsubr (&Shaiku_selection_put);
   defsubr (&Shaiku_selection_targets);
   defsubr (&Shaiku_selection_owner_p);
+  defsubr (&Shaiku_drag_message);
 }
diff --git a/src/haikuselect.h b/src/haikuselect.h
index 5b9abc7a8aa..366890d1a46 100644
--- a/src/haikuselect.h
+++ b/src/haikuselect.h
@@ -87,6 +87,10 @@ extern "C"
 				  ssize_t *size_return);
   extern int be_get_refs_data (void *message, const char *name,
 			       int32 index, char **path_buffer);
+  extern void *be_create_simple_message (void);
+  extern int be_add_message_data (void *message, const char *name,
+				  int32 type_code, const void *buf,
+				  ssize_t buf_size);
 #ifdef __cplusplus
 };
 #endif