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.

5 files changed, 358 insertions, 4 deletions

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