root/src/haikuselect.c

DEFINITIONS

1. haiku_get_clipboard_name
2. DEFUN
3. haiku_unwind_clipboard_lock
4. DEFUN
5. haiku_message_to_lisp
6. lisp_to_type_code
7. haiku_lisp_to_message
8. haiku_should_quit_drag
9. haiku_unwind_drag_message
10. haiku_report_system_error
11. haiku_dnd_compute_tip_xy
12. haiku_note_drag_motion_1
13. haiku_note_drag_motion_2
14. haiku_note_drag_motion
15. haiku_note_drag_wheel
16. init_haiku_select
17. haiku_handle_selection_clear
18. haiku_selection_disowned
19. haiku_start_watching_selections
20. syms_of_haikuselect

     1 /* Haiku window system selection support.
     2    Copyright (C) 2021-2023 Free Software Foundation, Inc.
     3 
     4 This file is part of GNU Emacs.
     5 
     6 GNU Emacs is free software: you can redistribute it and/or modify
     7 it under the terms of the GNU General Public License as published by
     8 the Free Software Foundation, either version 3 of the License, or (at
     9 your option) any later version.
    10 
    11 GNU Emacs is distributed in the hope that it will be useful,
    12 but WITHOUT ANY WARRANTY; without even the implied warranty of
    13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14 GNU General Public License for more details.
    15 
    16 You should have received a copy of the GNU General Public License
    17 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    18 
    19 #include <config.h>
    20 
    21 #include "lisp.h"
    22 #include "blockinput.h"
    23 #include "coding.h"
    24 #include "haikuselect.h"
    25 #include "haikuterm.h"
    26 #include "haiku_support.h"
    27 #include "keyboard.h"
    28 
    29 #include <stdlib.h>
    30 
    31 /* The frame that is currently the source of a drag-and-drop
    32    operation, or NULL if none is in progress.  The reason for this
    33    variable is to prevent it from being deleted, which really breaks
    34    the nested event loop inside be_drag_message.  */
    35 struct frame *haiku_dnd_frame;
    36 
    37 /* Whether or not to move the tip frame during drag-and-drop.  */
    38 bool haiku_dnd_follow_tooltip;
    39 
    40 /* Whether or not the current DND frame is able to receive drops from
    41    the current drag-and-drop operation.  */
    42 bool haiku_dnd_allow_same_frame;
    43 
    44 static void haiku_lisp_to_message (Lisp_Object, void *);
    45 
    46 static enum haiku_clipboard
    47 haiku_get_clipboard_name (Lisp_Object clipboard)
    48 {
    49   if (EQ (clipboard, QPRIMARY))
    50     return CLIPBOARD_PRIMARY;
    51 
    52   if (EQ (clipboard, QSECONDARY))
    53     return CLIPBOARD_SECONDARY;
    54 
    55   if (EQ (clipboard, QCLIPBOARD))
    56     return CLIPBOARD_CLIPBOARD;
    57 
    58   signal_error ("Invalid clipboard", clipboard);
    59 }
    60 
    61 DEFUN ("haiku-selection-timestamp", Fhaiku_selection_timestamp,
    62        Shaiku_selection_timestamp, 1, 1, 0,
    63        doc: /* Retrieve the "timestamp" of the clipboard CLIPBOARD.
    64 CLIPBOARD can either be the symbol `PRIMARY', `SECONDARY' or
    65 `CLIPBOARD'.  The timestamp is returned as a number describing the
    66 number of times programs have put data into CLIPBOARD.  */)
    67   (Lisp_Object clipboard)
    68 {
    69   enum haiku_clipboard clipboard_name;
    70   int64 timestamp;
    71 
    72   clipboard_name = haiku_get_clipboard_name (clipboard);
    73   timestamp = be_get_clipboard_count (clipboard_name);
    74 
    75   return INT_TO_INTEGER (timestamp);
    76 }
    77 
    78 DEFUN ("haiku-selection-data", Fhaiku_selection_data, Shaiku_selection_data,
    79        2, 2, 0,
    80        doc: /* Retrieve content typed as NAME from the clipboard
    81 CLIPBOARD.  CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or
    82 `CLIPBOARD'.  NAME is a string describing the MIME type denoting the
    83 type of the data to fetch.  If NAME is nil, then the entire contents
    84 of the clipboard will be returned instead, as a serialized system
    85 message in the format accepted by `haiku-drag-message', which see.  */)
    86   (Lisp_Object clipboard, Lisp_Object name)
    87 {
    88   char *dat;
    89   ssize_t len;
    90   Lisp_Object str;
    91   void *message;
    92   enum haiku_clipboard clipboard_name;
    93   int rc;
    94 
    95   CHECK_SYMBOL (clipboard);
    96   clipboard_name = haiku_get_clipboard_name (clipboard);
    97 
    98   if (!NILP (name))
    99     {
   100       CHECK_STRING (name);
   101 
   102       block_input ();
   103       dat = be_find_clipboard_data (clipboard_name,
   104                                     SSDATA (name), &len);
   105       unblock_input ();
   106 
   107       if (!dat)
   108         return Qnil;
   109 
   110       str = make_unibyte_string (dat, len);
   111 
   112       /* `foreign-selection' just means that the selection has to be
   113          decoded by `gui-get-selection'.  It has no other meaning,
   114          AFAICT.  */
   115       Fput_text_property (make_fixnum (0), make_fixnum (len),
   116                           Qforeign_selection, Qt, str);
   117 
   118       block_input ();
   119       free (dat);
   120       unblock_input ();
   121     }
   122   else
   123     {
   124       block_input ();
   125       rc = be_lock_clipboard_message (clipboard_name, &message, false);
   126       unblock_input ();
   127 
   128       if (rc)
   129         signal_error ("Couldn't open clipboard", clipboard);
   130 
   131       block_input ();
   132       str = haiku_message_to_lisp (message);
   133       be_unlock_clipboard (clipboard_name, true);
   134       unblock_input ();
   135     }
   136 
   137   return str;
   138 }
   139 
   140 static void
   141 haiku_unwind_clipboard_lock (int clipboard)
   142 {
   143   be_unlock_clipboard (clipboard, false);
   144 }
   145 
   146 DEFUN ("haiku-selection-put", Fhaiku_selection_put, Shaiku_selection_put,
   147        2, 4, 0,
   148        doc: /* Add or remove content from the clipboard CLIPBOARD.
   149 CLIPBOARD is the symbol `PRIMARY', `SECONDARY' or `CLIPBOARD'.  NAME
   150 is a MIME type denoting the type of the data to add.  DATA is the
   151 string that will be placed in the clipboard, or nil if the content is
   152 to be removed.  CLEAR, if non-nil, means to erase all the previous
   153 contents of the clipboard.
   154 
   155 Alternatively, NAME can be a system message in the format accepted by
   156 `haiku-drag-message', which will replace the contents of CLIPBOARD.
   157 In that case, the arguments after NAME are ignored.  */)
   158   (Lisp_Object clipboard, Lisp_Object name, Lisp_Object data,
   159    Lisp_Object clear)
   160 {
   161   enum haiku_clipboard clipboard_name;
   162   specpdl_ref ref;
   163   char *dat;
   164   ptrdiff_t len;
   165   int rc;
   166   void *message;
   167 
   168   CHECK_SYMBOL (clipboard);
   169   clipboard_name = haiku_get_clipboard_name (clipboard);
   170 
   171   if (CONSP (name) || NILP (name))
   172     {
   173       be_update_clipboard_count (clipboard_name);
   174 
   175       rc = be_lock_clipboard_message (clipboard_name,
   176                                       &message, true);
   177 
   178       if (rc)
   179         signal_error ("Couldn't open clipboard", clipboard);
   180 
   181       ref = SPECPDL_INDEX ();
   182       record_unwind_protect_int (haiku_unwind_clipboard_lock,
   183                                  clipboard_name);
   184       haiku_lisp_to_message (name, message);
   185 
   186       return unbind_to (ref, Qnil);
   187     }
   188 
   189   CHECK_STRING (name);
   190   if (!NILP (data))
   191     CHECK_STRING (data);
   192 
   193   dat = !NILP (data) ? SSDATA (data) : NULL;
   194   len = !NILP (data) ? SBYTES (data) : 0;
   195 
   196   be_set_clipboard_data (clipboard_name, SSDATA (name), dat, len,
   197                          !NILP (clear));
   198   return Qnil;
   199 }
   200 
   201 DEFUN ("haiku-selection-owner-p", Fhaiku_selection_owner_p, Shaiku_selection_owner_p,
   202        0, 1, 0,
   203        doc: /* Whether the current Emacs process owns the given SELECTION.
   204 The arg should be the name of the selection in question, typically one
   205 of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.  */)
   206   (Lisp_Object selection)
   207 {
   208   bool value;
   209   enum haiku_clipboard name;
   210 
   211   block_input ();
   212   name = haiku_get_clipboard_name (selection);
   213   value = be_clipboard_owner_p (name);
   214   unblock_input ();
   215 
   216   return value ? Qt : Qnil;
   217 }
   218 
   219 /* Return the Lisp representation of MESSAGE.  See Fhaiku_drag_message
   220    for the format of the object returned.  */
   221 Lisp_Object
   222 haiku_message_to_lisp (void *message)
   223 {
   224   Lisp_Object list = Qnil, tem, t1, t2;
   225   const char *name;
   226   char *pbuf;
   227   const void *buf;
   228   ssize_t buf_size;
   229   int32 i, j, count, type_code;
   230   int rc;
   231   void *msg;
   232   float point_x, point_y;
   233 
   234   for (i = 0; !be_enum_message (message, &type_code, i,
   235                                 &count, &name); ++i)
   236     {
   237       tem = Qnil;
   238 
   239       for (j = 0; j < count; ++j)
   240         {
   241           rc = be_get_message_data (message, name,
   242                                     type_code, j,
   243                                     &buf, &buf_size);
   244           if (rc)
   245             emacs_abort ();
   246 
   247           switch (type_code)
   248             {
   249             case 'MSGG':
   250               msg = be_get_message_message (message, name, j);
   251               if (!msg)
   252                 memory_full (SIZE_MAX);
   253               t1 = haiku_message_to_lisp (msg);
   254               BMessage_delete (msg);
   255 
   256               break;
   257 
   258             case 'BOOL':
   259               t1 = (*(bool *) buf) ? Qt : Qnil;
   260               break;
   261 
   262             case 'RREF':
   263               rc = be_get_refs_data (message, name,
   264                                      j, &pbuf);
   265 
   266               if (rc)
   267                 {
   268                   t1 = Qnil;
   269                   break;
   270                 }
   271 
   272               if (!pbuf)
   273                 memory_full (SIZE_MAX);
   274 
   275               t1 = DECODE_FILE (build_string (pbuf));
   276 
   277               free (pbuf);
   278               break;
   279 
   280             case 'BPNT':
   281               rc = be_get_point_data (message, name,
   282                                       j, &point_x,
   283                                       &point_y);
   284 
   285               if (rc)
   286                 {
   287                   t1 = Qnil;
   288                   break;
   289                 }
   290 
   291               t1 = Fcons (make_float (point_x),
   292                           make_float (point_y));
   293               break;
   294 
   295             case 'SHRT':
   296               t1 = make_fixnum (*(int16 *) buf);
   297               break;
   298 
   299             case 'LONG':
   300               t1 = make_int (*(int32 *) buf);
   301               break;
   302 
   303             case 'LLNG':
   304               t1 = make_int ((intmax_t) *(int64 *) buf);
   305               break;
   306 
   307             case 'BYTE':
   308             case 'CHAR':
   309               t1 = make_fixnum (*(int8 *) buf);
   310               break;
   311 
   312             case 'SIZT':
   313               t1 = make_uint ((uintmax_t) *(size_t *) buf);
   314               break;
   315 
   316             case 'SSZT':
   317               t1 = make_int ((intmax_t) *(ssize_t *) buf);
   318               break;
   319 
   320             case 'DBLE':
   321               t1 = make_float (*(double *) buf);
   322               break;
   323 
   324             case 'FLOT':
   325               t1 = make_float (*(float *) buf);
   326               break;
   327 
   328             case 'CSTR':
   329               /* Is this even possible? */
   330               if (!buf_size)
   331                 buf_size = 1;
   332 
   333               t1 = make_uninit_string (buf_size - 1);
   334               memcpy (SDATA (t1), buf, buf_size - 1);
   335               break;
   336 
   337             default:
   338               t1 = make_uninit_string (buf_size);
   339               memcpy (SDATA (t1), buf, buf_size);
   340             }
   341 
   342           tem = Fcons (t1, tem);
   343         }
   344 
   345       switch (type_code)
   346         {
   347         case 'CSTR':
   348           t2 = Qstring;
   349           break;
   350 
   351         case 'SHRT':
   352           t2 = Qshort;
   353           break;
   354 
   355         case 'LONG':
   356           t2 = Qlong;
   357           break;
   358 
   359         case 'LLNG':
   360           t2 = Qllong;
   361           break;
   362 
   363         case 'BYTE':
   364           t2 = Qbyte;
   365           break;
   366 
   367         case 'RREF':
   368           t2 = Qref;
   369           break;
   370 
   371         case 'CHAR':
   372           t2 = Qchar;
   373           break;
   374 
   375         case 'BOOL':
   376           t2 = Qbool;
   377           break;
   378 
   379         case 'MSGG':
   380           t2 = Qmessage;
   381           break;
   382 
   383         case 'SIZT':
   384           t2 = Qsize_t;
   385           break;
   386 
   387         case 'SSZT':
   388           t2 = Qssize_t;
   389           break;
   390 
   391         case 'BPNT':
   392           t2 = Qpoint;
   393           break;
   394 
   395         case 'DBLE':
   396           t2 = Qdouble;
   397           break;
   398 
   399         case 'FLOT':
   400           t2 = Qfloat;
   401           break;
   402 
   403         default:
   404           t2 = make_int (type_code);
   405         }
   406 
   407       tem = Fcons (t2, tem);
   408       list = Fcons (Fcons (build_string_from_utf8 (name), tem), list);
   409     }
   410 
   411   tem = Fcons (Qtype, make_uint (be_get_message_type (message)));
   412   return Fcons (tem, list);
   413 }
   414 
   415 static int32
   416 lisp_to_type_code (Lisp_Object obj)
   417 {
   418   if (BIGNUMP (obj))
   419     return (int32) bignum_to_intmax (obj);
   420 
   421   if (FIXNUMP (obj))
   422     return XFIXNUM (obj);
   423 
   424   if (EQ (obj, Qstring))
   425     return 'CSTR';
   426   else if (EQ (obj, Qshort))
   427     return 'SHRT';
   428   else if (EQ (obj, Qlong))
   429     return 'LONG';
   430   else if (EQ (obj, Qllong))
   431     return 'LLNG';
   432   else if (EQ (obj, Qbyte))
   433     return 'BYTE';
   434   else if (EQ (obj, Qref))
   435     return 'RREF';
   436   else if (EQ (obj, Qchar))
   437     return 'CHAR';
   438   else if (EQ (obj, Qbool))
   439     return 'BOOL';
   440   else if (EQ (obj, Qmessage))
   441     return 'MSGG';
   442   else if (EQ (obj, Qsize_t))
   443     return 'SIZT';
   444   else if (EQ (obj, Qssize_t))
   445     return 'SSZT';
   446   else if (EQ (obj, Qpoint))
   447     return 'BPNT';
   448   else if (EQ (obj, Qfloat))
   449     return 'FLOT';
   450   else if (EQ (obj, Qdouble))
   451     return 'DBLE';
   452   else
   453     return -1;
   454 }
   455 
   456 static void
   457 haiku_lisp_to_message (Lisp_Object obj, void *message)
   458 {
   459   Lisp_Object tem, t1, name, type_sym, t2, data;
   460   int32 type_code, long_data;
   461   int16 short_data;
   462   int64 llong_data;
   463   int8 char_data;
   464   bool bool_data;
   465   void *msg_data;
   466   size_t sizet_data;
   467   ssize_t ssizet_data;
   468   intmax_t t4;
   469   uintmax_t t5;
   470   float t6, t7, float_data;
   471   double double_data;
   472   int rc;
   473   specpdl_ref ref;
   474 
   475   tem = obj;
   476 
   477   FOR_EACH_TAIL (tem)
   478     {
   479       t1 = XCAR (tem);
   480       CHECK_CONS (t1);
   481 
   482       name = XCAR (t1);
   483 
   484       if (EQ (name, Qtype))
   485         {
   486           t2 = XCDR (t1);
   487 
   488           if (BIGNUMP (t2))
   489             {
   490               t5 = bignum_to_uintmax (t2);
   491 
   492               if (!t5 || t5 > TYPE_MAXIMUM (uint32))
   493                 signal_error ("Value too large", t2);
   494 
   495               block_input ();
   496               be_set_message_type (message, t5);
   497               unblock_input ();
   498             }
   499           else
   500             {
   501               if (!TYPE_RANGED_FIXNUMP (uint32, t2))
   502                 signal_error ("Invalid data type", t2);
   503 
   504               block_input ();
   505               be_set_message_type (message, XFIXNAT (t2));
   506               unblock_input ();
   507             }
   508 
   509           continue;
   510         }
   511 
   512       CHECK_STRING (name);
   513 
   514       t1 = XCDR (t1);
   515       CHECK_CONS (t1);
   516 
   517       type_sym = XCAR (t1);
   518       type_code = lisp_to_type_code (type_sym);
   519 
   520       if (type_code == -1)
   521         signal_error ("Unknown data type", type_sym);
   522 
   523       CHECK_LIST (t1);
   524       t2 = XCDR (t1);
   525       FOR_EACH_TAIL (t2)
   526         {
   527           data = XCAR (t2);
   528 
   529           if (FIXNUMP (type_sym) || BIGNUMP (type_sym))
   530             goto decode_normally;
   531 
   532           switch (type_code)
   533             {
   534             case 'MSGG':
   535               ref = SPECPDL_INDEX ();
   536 
   537               block_input ();
   538               msg_data = be_create_simple_message ();
   539               unblock_input ();
   540 
   541               record_unwind_protect_ptr (BMessage_delete, msg_data);
   542               haiku_lisp_to_message (data, msg_data);
   543 
   544               block_input ();
   545               rc = be_add_message_message (message, SSDATA (name), msg_data);
   546               unblock_input ();
   547 
   548               if (rc)
   549                 signal_error ("Invalid message", data);
   550               unbind_to (ref, Qnil);
   551               break;
   552 
   553             case 'RREF':
   554               CHECK_STRING (data);
   555 
   556               if (be_add_refs_data (message, SSDATA (name),
   557                                     SSDATA (ENCODE_FILE (data)))
   558                   && haiku_signal_invalid_refs)
   559                 signal_error ("Invalid file name", data);
   560               break;
   561 
   562             case 'BPNT':
   563               CHECK_CONS (data);
   564               CHECK_NUMBER (XCAR (data));
   565               CHECK_NUMBER (XCDR (data));
   566 
   567               t6 = XFLOATINT (XCAR (data));
   568               t7 = XFLOATINT (XCDR (data));
   569 
   570               if (be_add_point_data (message, SSDATA (name),
   571                                      t6, t7))
   572                 signal_error ("Invalid point", data);
   573               break;
   574 
   575             case 'FLOT':
   576               CHECK_NUMBER (data);
   577               float_data = XFLOATINT (data);
   578 
   579               rc = be_add_message_data (message, SSDATA (name),
   580                                         type_code, &float_data,
   581                                         sizeof float_data);
   582 
   583               if (rc)
   584                 signal_error ("Failed to add float", data);
   585               break;
   586 
   587             case 'DBLE':
   588               CHECK_NUMBER (data);
   589               double_data = XFLOATINT (data);
   590 
   591               rc = be_add_message_data (message, SSDATA (name),
   592                                         type_code, &double_data,
   593                                         sizeof double_data);
   594 
   595               if (rc)
   596                 signal_error ("Failed to add double", data);
   597               break;
   598 
   599             case 'SHRT':
   600               if (!TYPE_RANGED_FIXNUMP (int16, data))
   601                 signal_error ("Invalid value", data);
   602               short_data = XFIXNUM (data);
   603 
   604               block_input ();
   605               rc = be_add_message_data (message, SSDATA (name),
   606                                         type_code, &short_data,
   607                                         sizeof short_data);
   608               unblock_input ();
   609 
   610               if (rc)
   611                 signal_error ("Failed to add short", data);
   612               break;
   613 
   614             case 'LONG':
   615               if (BIGNUMP (data))
   616                 {
   617                   t4 = bignum_to_intmax (data);
   618 
   619                   /* We know that int32 is signed.  */
   620                   if (!t4 || t4 > TYPE_MINIMUM (int32)
   621                       || t4 < TYPE_MAXIMUM (int32))
   622                     signal_error ("Value too large", data);
   623 
   624                   long_data = (int32) t4;
   625                 }
   626               else
   627                 {
   628                   if (!TYPE_RANGED_FIXNUMP (int32, data))
   629                     signal_error ("Invalid value", data);
   630 
   631                   long_data = (int32) XFIXNUM (data);
   632                 }
   633 
   634               block_input ();
   635               rc = be_add_message_data (message, SSDATA (name),
   636                                         type_code, &long_data,
   637                                         sizeof long_data);
   638               unblock_input ();
   639 
   640               if (rc)
   641                 signal_error ("Failed to add long", data);
   642               break;
   643 
   644             case 'LLNG':
   645               if (BIGNUMP (data))
   646                 {
   647                   t4 = bignum_to_intmax (data);
   648 
   649                   if (!t4 || t4 > TYPE_MINIMUM (int64)
   650                       || t4 < TYPE_MAXIMUM (int64))
   651                     signal_error ("Value too large", data);
   652 
   653                   llong_data = (int64) t4;
   654                 }
   655               else
   656                 {
   657                   if (!TYPE_RANGED_FIXNUMP (int64, data))
   658                     signal_error ("Invalid value", data);
   659 
   660                   llong_data = (int64) XFIXNUM (data);
   661                 }
   662 
   663               block_input ();
   664               rc = be_add_message_data (message, SSDATA (name),
   665                                         type_code, &llong_data,
   666                                         sizeof llong_data);
   667               unblock_input ();
   668 
   669               if (rc)
   670                 signal_error ("Failed to add llong", data);
   671               break;
   672 
   673             case 'SIZT':
   674               if (BIGNUMP (data))
   675                 {
   676                   t4 = bignum_to_intmax (data);
   677 
   678                   if (!t4 || t4 > TYPE_MAXIMUM (size_t))
   679                     signal_error ("Value too large", data);
   680 
   681                   sizet_data = (size_t) t4;
   682                 }
   683               else
   684                 {
   685                   if (!TYPE_RANGED_FIXNUMP (size_t, data))
   686                     signal_error ("Invalid value", data);
   687 
   688                   sizet_data = (int64) XFIXNUM (data);
   689                 }
   690 
   691               block_input ();
   692               rc = be_add_message_data (message, SSDATA (name),
   693                                         type_code, &sizet_data,
   694                                         sizeof sizet_data);
   695               unblock_input ();
   696 
   697               if (rc)
   698                 signal_error ("Failed to add sizet", data);
   699               break;
   700 
   701             case 'SSZT':
   702               if (BIGNUMP (data))
   703                 {
   704                   t4 = bignum_to_intmax (data);
   705 
   706                   if (!t4 || t4 > TYPE_MINIMUM (ssize_t)
   707                       || t4 < TYPE_MAXIMUM (ssize_t))
   708                     signal_error ("Value too large", data);
   709 
   710                   ssizet_data = (ssize_t) t4;
   711                 }
   712               else
   713                 {
   714                   if (!TYPE_RANGED_FIXNUMP (ssize_t, data))
   715                     signal_error ("Invalid value", data);
   716 
   717                   ssizet_data = (int64) XFIXNUM (data);
   718                 }
   719 
   720               block_input ();
   721               rc = be_add_message_data (message, SSDATA (name),
   722                                         type_code, &ssizet_data,
   723                                         sizeof ssizet_data);
   724               unblock_input ();
   725 
   726               if (rc)
   727                 signal_error ("Failed to add ssizet", data);
   728               break;
   729 
   730             case 'CHAR':
   731             case 'BYTE':
   732               if (!TYPE_RANGED_FIXNUMP (int8, data))
   733                 signal_error ("Invalid value", data);
   734               char_data = XFIXNUM (data);
   735 
   736               block_input ();
   737               rc = be_add_message_data (message, SSDATA (name),
   738                                         type_code, &char_data,
   739                                         sizeof char_data);
   740               unblock_input ();
   741 
   742               if (rc)
   743                 signal_error ("Failed to add char", data);
   744               break;
   745 
   746             case 'BOOL':
   747               bool_data = !NILP (data);
   748 
   749               block_input ();
   750               rc = be_add_message_data (message, SSDATA (name),
   751                                         type_code, &bool_data,
   752                                         sizeof bool_data);
   753               unblock_input ();
   754 
   755               if (rc)
   756                 signal_error ("Failed to add bool", data);
   757               break;
   758 
   759             case 'CSTR':
   760               /* C strings must be handled specially, since they
   761                  include a trailing NULL byte.  */
   762               CHECK_STRING (data);
   763 
   764               block_input ();
   765               rc = be_add_message_data (message, SSDATA (name),
   766                                         type_code, SDATA (data),
   767                                         SBYTES (data) + 1);
   768               unblock_input ();
   769 
   770               if (rc)
   771                 signal_error ("Failed to add", data);
   772               break;
   773 
   774             default:
   775             decode_normally:
   776               CHECK_STRING (data);
   777 
   778               block_input ();
   779               rc = be_add_message_data (message, SSDATA (name),
   780                                         type_code, SDATA (data),
   781                                         SBYTES (data));
   782               unblock_input ();
   783 
   784               if (rc)
   785                 signal_error ("Failed to add", data);
   786             }
   787         }
   788       CHECK_LIST_END (t2, t1);
   789     }
   790   CHECK_LIST_END (tem, obj);
   791 }
   792 
   793 static bool
   794 haiku_should_quit_drag (void)
   795 {
   796   return !NILP (Vquit_flag);
   797 }
   798 
   799 static void
   800 haiku_unwind_drag_message (void *message)
   801 {
   802   haiku_dnd_frame = NULL;
   803   BMessage_delete (message);
   804 }
   805 
   806 static void
   807 haiku_report_system_error (status_t code, const char *format)
   808 {
   809   switch (code)
   810     {
   811     case B_BAD_VALUE:
   812       error (format, "Bad value");
   813       break;
   814 
   815     case B_ENTRY_NOT_FOUND:
   816       error (format, "File not found");
   817       break;
   818 
   819     case B_PERMISSION_DENIED:
   820       error (format, "Permission denied");
   821       break;
   822 
   823     case B_LINK_LIMIT:
   824       error (format, "Link limit reached");
   825       break;
   826 
   827     case B_BUSY:
   828       error (format, "Device busy");
   829       break;
   830 
   831     case B_NO_MORE_FDS:
   832       error (format, "No more file descriptors");
   833       break;
   834 
   835     case B_FILE_ERROR:
   836       error (format, "File error");
   837       break;
   838 
   839     case B_NO_MEMORY:
   840       memory_full (SIZE_MAX);
   841       break;
   842 
   843     default:
   844       error (format, "Unknown error");
   845       break;
   846     }
   847 }
   848 
   849 DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message,
   850        2, 4, 0,
   851        doc: /* Begin dragging MESSAGE from FRAME.
   852 
   853 MESSAGE an alist of strings, denoting message field names, to a list
   854 the form (TYPE DATA ...), where TYPE is an integer denoting the system
   855 data type of DATA, and DATA is in the general case a unibyte string.
   856 
   857 If TYPE is a symbol instead of an integer, then DATA was specially
   858 decoded.  If TYPE is `ref', then DATA is the absolute file name of a
   859 file, or nil if decoding the file name failed.  If TYPE is `string',
   860 then DATA is a unibyte string.  If TYPE is `short', then DATA is a
   861 16-bit signed integer.  If TYPE is `long', then DATA is a 32-bit
   862 signed integer.  If TYPE is `llong', then DATA is a 64-bit signed
   863 integer. If TYPE is `byte' or `char', then DATA is an 8-bit signed
   864 integer.  If TYPE is `bool', then DATA is a boolean.  If TYPE is
   865 `size_t', then DATA is an integer that can hold between 0 and the
   866 maximum value returned by the `sizeof' C operator on the current
   867 system.  If TYPE is `ssize_t', then DATA is an integer that can hold
   868 values from -1 to the maximum value of the C data type `ssize_t' on
   869 the current system.  If TYPE is `point', then DATA is a cons of float
   870 values describing the X and Y coordinates of an on-screen location.
   871 If TYPE is `float', then DATA is a low-precision floating point
   872 number, whose exact precision is not guaranteed.  If TYPE is `double',
   873 then DATA is a floating point number that can represent any value a
   874 Lisp float can represent.
   875 
   876 If the field name is not a string but the symbol `type', then it
   877 associates to a 32-bit unsigned integer describing the type of the
   878 system message.
   879 
   880 FRAME is a window system frame that must be visible, from which the
   881 drag will originate.
   882 
   883 ALLOW-SAME-FRAME, if nil or not specified, means that MESSAGE will be
   884 ignored if it is dropped on top of FRAME.
   885 
   886 FOLLOW-TOOLTIP, if non-nil, will cause any non-system tooltip
   887 currently being displayed to move along with the mouse pointer.  */)
   888   (Lisp_Object frame, Lisp_Object message, Lisp_Object allow_same_frame,
   889    Lisp_Object follow_tooltip)
   890 {
   891   specpdl_ref idx;
   892   void *be_message;
   893   struct frame *f;
   894   bool rc;
   895 
   896   idx = SPECPDL_INDEX ();
   897   f = decode_window_system_frame (frame);
   898 
   899   if (!FRAME_VISIBLE_P (f))
   900     error ("Frame is invisible");
   901 
   902   haiku_dnd_frame = f;
   903   haiku_dnd_follow_tooltip = !NILP (follow_tooltip);
   904   haiku_dnd_allow_same_frame = !NILP (allow_same_frame);
   905 
   906   be_message = be_create_simple_message ();
   907 
   908   record_unwind_protect_ptr (haiku_unwind_drag_message, be_message);
   909   haiku_lisp_to_message (message, be_message);
   910 
   911   rc = be_drag_message (FRAME_HAIKU_VIEW (f), be_message,
   912                         !NILP (allow_same_frame),
   913                         block_input, unblock_input,
   914                         process_pending_signals,
   915                         haiku_should_quit_drag);
   916 
   917   /* Don't clear the mouse grab if the user decided to quit instead
   918      of the drop finishing.  */
   919   if (rc)
   920     quit ();
   921 
   922   /* Now dismiss the tooltip, since the drop presumably succeeded.  */
   923   if (!NILP (follow_tooltip))
   924     Fx_hide_tip ();
   925 
   926   FRAME_DISPLAY_INFO (f)->grabbed = 0;
   927 
   928   return unbind_to (idx, Qnil);
   929 }
   930 
   931 DEFUN ("haiku-roster-launch", Fhaiku_roster_launch, Shaiku_roster_launch,
   932        2, 2, 0,
   933        doc: /* Launch an application associated with FILE-OR-TYPE.
   934 Return the process ID of any process created, the symbol
   935 `already-running' if ARGS was sent to a program that's already
   936 running, or nil if launching the application failed because no
   937 application was found for FILE-OR-TYPE.
   938 
   939 Signal an error if FILE-OR-TYPE is invalid, or if ARGS is a message
   940 but the application doesn't accept messages.
   941 
   942 FILE-OR-TYPE can either be a string denoting a MIME type, or a list
   943 with one argument FILE, denoting a file whose associated application
   944 will be launched.
   945 
   946 ARGS can either be a vector of strings containing the arguments that
   947 will be passed to the application, or a system message in the form
   948 accepted by `haiku-drag-message' that will be sent to the application
   949 after it starts.  */)
   950   (Lisp_Object file_or_type, Lisp_Object args)
   951 {
   952   char **cargs;
   953   char *type, *file;
   954   team_id team_id;
   955   status_t rc;
   956   ptrdiff_t i, nargs;
   957   Lisp_Object tem, canonical;
   958   void *message;
   959   specpdl_ref depth;
   960 
   961   type = NULL;
   962   file = NULL;
   963   cargs = NULL;
   964   message = NULL;
   965   nargs = 0;
   966   depth = SPECPDL_INDEX ();
   967 
   968   USE_SAFE_ALLOCA;
   969 
   970   if (STRINGP (file_or_type))
   971     SAFE_ALLOCA_STRING (type, file_or_type);
   972   else
   973     {
   974       CHECK_LIST (file_or_type);
   975       tem = XCAR (file_or_type);
   976       canonical = Fexpand_file_name (tem, Qnil);
   977 
   978       CHECK_STRING (tem);
   979       SAFE_ALLOCA_STRING (file, ENCODE_FILE (canonical));
   980       CHECK_LIST_END (XCDR (file_or_type), file_or_type);
   981     }
   982 
   983   if (VECTORP (args))
   984     {
   985       nargs = ASIZE (args);
   986       cargs = SAFE_ALLOCA (nargs * sizeof *cargs);
   987 
   988       for (i = 0; i < nargs; ++i)
   989         {
   990           tem = AREF (args, i);
   991           CHECK_STRING (tem);
   992           maybe_quit ();
   993 
   994           cargs[i] = SAFE_ALLOCA (SBYTES (tem) + 1);
   995           memcpy (cargs[i], SDATA (tem), SBYTES (tem) + 1);
   996         }
   997     }
   998   else
   999     {
  1000       message = be_create_simple_message ();
  1001 
  1002       record_unwind_protect_ptr (BMessage_delete, message);
  1003       haiku_lisp_to_message (args, message);
  1004     }
  1005 
  1006   block_input ();
  1007   rc = be_roster_launch (type, file, cargs, nargs, message,
  1008                          &team_id);
  1009   unblock_input ();
  1010 
  1011   /* `be_roster_launch' can potentially take a while in IO, but
  1012      signals from async input will interrupt that operation.  If the
  1013      user wanted to quit, act like it.  */
  1014   maybe_quit ();
  1015 
  1016   if (rc == B_OK)
  1017     return SAFE_FREE_UNBIND_TO (depth,
  1018                                 make_uint (team_id));
  1019   else if (rc == B_ALREADY_RUNNING)
  1020     return Qalready_running;
  1021   else if (rc == B_BAD_VALUE)
  1022     signal_error ("Invalid type or bad arguments",
  1023                   list2 (file_or_type, args));
  1024 
  1025   return SAFE_FREE_UNBIND_TO (depth, Qnil);
  1026 }
  1027 
  1028 DEFUN ("haiku-write-node-attribute", Fhaiku_write_node_attribute,
  1029        Shaiku_write_node_attribute, 3, 3, 0,
  1030        doc: /* Write a message as a file-system attribute of NODE.
  1031 FILE should be a file name of a file on a Be File System volume, NAME
  1032 should be a string describing the name of the attribute that will be
  1033 written, and MESSAGE will be the attribute written to FILE, as a
  1034 system message in the format accepted by `haiku-drag-message', which
  1035 see.  */)
  1036   (Lisp_Object file, Lisp_Object name, Lisp_Object message)
  1037 {
  1038   void *be_message;
  1039   status_t rc;
  1040   specpdl_ref count;
  1041 
  1042   CHECK_STRING (file);
  1043   CHECK_STRING (name);
  1044 
  1045   file = ENCODE_FILE (file);
  1046   name = ENCODE_SYSTEM (name);
  1047 
  1048   be_message = be_create_simple_message ();
  1049   count = SPECPDL_INDEX ();
  1050 
  1051   record_unwind_protect_ptr (BMessage_delete, be_message);
  1052   haiku_lisp_to_message (message, be_message);
  1053   rc = be_write_node_message (SSDATA (file), SSDATA (name),
  1054                               be_message);
  1055 
  1056   if (rc < B_OK)
  1057     haiku_report_system_error (rc, "Failed to set attribute: %s");
  1058 
  1059   return unbind_to (count, Qnil);
  1060 }
  1061 
  1062 DEFUN ("haiku-send-message", Fhaiku_send_message, Shaiku_send_message,
  1063        2, 2, 0,
  1064        doc: /* Send a system message to PROGRAM.
  1065 PROGRAM must be the name of the application to which the message will
  1066 be sent.  MESSAGE is the system message, serialized in the format
  1067 accepted by `haiku-drag-message', that will be sent to the application
  1068 specified by PROGRAM.  There is no guarantee that the message will
  1069 arrive after this function is called.  */)
  1070   (Lisp_Object program, Lisp_Object message)
  1071 {
  1072   specpdl_ref count;
  1073   void *be_message;
  1074 
  1075   CHECK_STRING (program);
  1076   program = ENCODE_SYSTEM (program);
  1077 
  1078   be_message = be_create_simple_message ();
  1079   count = SPECPDL_INDEX ();
  1080 
  1081   record_unwind_protect_ptr (BMessage_delete, be_message);
  1082   haiku_lisp_to_message (message, be_message);
  1083   be_send_message (SSDATA (program), be_message);
  1084 
  1085   return unbind_to (count, Qnil);
  1086 }
  1087 
  1088 static void
  1089 haiku_dnd_compute_tip_xy (int *root_x, int *root_y)
  1090 {
  1091   int min_x, min_y, max_x, max_y;
  1092   int width, height;
  1093 
  1094   width = FRAME_PIXEL_WIDTH (XFRAME (tip_frame));
  1095   height = FRAME_PIXEL_HEIGHT (XFRAME (tip_frame));
  1096 
  1097   min_x = 0;
  1098   min_y = 0;
  1099   be_get_screen_dimensions (&max_x, &max_y);
  1100 
  1101   if (*root_y + XFIXNUM (tip_dy) <= min_y)
  1102     *root_y = min_y; /* Can happen for negative dy */
  1103   else if (*root_y + XFIXNUM (tip_dy) + height <= max_y)
  1104     /* It fits below the pointer */
  1105     *root_y += XFIXNUM (tip_dy);
  1106   else if (height + XFIXNUM (tip_dy) + min_y <= *root_y)
  1107     /* It fits above the pointer.  */
  1108     *root_y -= height + XFIXNUM (tip_dy);
  1109   else
  1110     /* Put it on the top.  */
  1111     *root_y = min_y;
  1112 
  1113   if (*root_x + XFIXNUM (tip_dx) <= min_x)
  1114     *root_x = 0; /* Can happen for negative dx */
  1115   else if (*root_x + XFIXNUM (tip_dx) + width <= max_x)
  1116     /* It fits to the right of the pointer.  */
  1117     *root_x += XFIXNUM (tip_dx);
  1118   else if (width + XFIXNUM (tip_dx) + min_x <= *root_x)
  1119     /* It fits to the left of the pointer.  */
  1120     *root_x -= width + XFIXNUM (tip_dx);
  1121   else
  1122     /* Put it left justified on the screen -- it ought to fit that way.  */
  1123     *root_x = min_x;
  1124 }
  1125 
  1126 static Lisp_Object
  1127 haiku_note_drag_motion_1 (void *data)
  1128 {
  1129   if (!NILP (Vhaiku_drag_track_function))
  1130     return call0 (Vhaiku_drag_track_function);
  1131 
  1132   return Qnil;
  1133 }
  1134 
  1135 static Lisp_Object
  1136 haiku_note_drag_motion_2 (enum nonlocal_exit exit, Lisp_Object error)
  1137 {
  1138   return Qnil;
  1139 }
  1140 
  1141 void
  1142 haiku_note_drag_motion (void)
  1143 {
  1144   struct frame *tip_f;
  1145   int x, y;
  1146 
  1147   if (FRAMEP (tip_frame) && haiku_dnd_follow_tooltip
  1148       && FIXNUMP (tip_dx) && FIXNUMP (tip_dy))
  1149     {
  1150       tip_f = XFRAME (tip_frame);
  1151 
  1152       if (FRAME_LIVE_P (tip_f) && FRAME_VISIBLE_P (tip_f))
  1153         {
  1154           BView_get_mouse (FRAME_HAIKU_VIEW (haiku_dnd_frame),
  1155                            &x, &y);
  1156           BView_convert_to_screen (FRAME_HAIKU_VIEW (haiku_dnd_frame),
  1157                                    &x, &y);
  1158 
  1159           haiku_dnd_compute_tip_xy (&x, &y);
  1160           BWindow_set_offset (FRAME_HAIKU_WINDOW (tip_f), x, y);
  1161         }
  1162     }
  1163 
  1164   internal_catch_all (haiku_note_drag_motion_1, NULL,
  1165                       haiku_note_drag_motion_2);
  1166 
  1167   /* Redisplay this way to preserve the echo area.  Otherwise, the
  1168      contents will abruptly disappear when the mouse moves over a
  1169      frame.  */
  1170   redisplay_preserve_echo_area (34);
  1171 }
  1172 
  1173 void
  1174 haiku_note_drag_wheel (struct input_event *ie)
  1175 {
  1176   bool horizontal, up;
  1177 
  1178   up = false;
  1179   horizontal = false;
  1180 
  1181   if (ie->modifiers & up_modifier)
  1182     up = true;
  1183 
  1184   if (ie->kind == HORIZ_WHEEL_EVENT)
  1185     horizontal = true;
  1186 
  1187   ie->kind = NO_EVENT;
  1188 
  1189   if (!NILP (Vhaiku_drag_wheel_function)
  1190       && (haiku_dnd_allow_same_frame
  1191           || XFRAME (ie->frame_or_window) != haiku_dnd_frame))
  1192     safe_call (7, Vhaiku_drag_wheel_function, ie->frame_or_window,
  1193                ie->x, ie->y, horizontal ? Qt : Qnil, up ? Qt : Qnil,
  1194                make_int (ie->modifiers));
  1195 
  1196   redisplay_preserve_echo_area (35);
  1197 }
  1198 
  1199 void
  1200 init_haiku_select (void)
  1201 {
  1202   be_clipboard_init ();
  1203 }
  1204 
  1205 void
  1206 haiku_handle_selection_clear (struct input_event *ie)
  1207 {
  1208   enum haiku_clipboard id;
  1209 
  1210   id = haiku_get_clipboard_name (ie->arg);
  1211 
  1212   if (be_selection_outdated_p (id, ie->timestamp))
  1213     return;
  1214 
  1215   CALLN (Frun_hook_with_args,
  1216          Qhaiku_lost_selection_functions, ie->arg);
  1217 
  1218   /* This is required for redisplay to happen if something changed the
  1219      display inside the selection loss functions.  */
  1220   redisplay_preserve_echo_area (20);
  1221 }
  1222 
  1223 void
  1224 haiku_selection_disowned (enum haiku_clipboard id, int64 count)
  1225 {
  1226   struct input_event ie;
  1227 
  1228   EVENT_INIT (ie);
  1229   ie.kind = SELECTION_CLEAR_EVENT;
  1230 
  1231   switch (id)
  1232     {
  1233     case CLIPBOARD_CLIPBOARD:
  1234       ie.arg = QCLIPBOARD;
  1235       break;
  1236 
  1237     case CLIPBOARD_PRIMARY:
  1238       ie.arg = QPRIMARY;
  1239       break;
  1240 
  1241     case CLIPBOARD_SECONDARY:
  1242       ie.arg = QSECONDARY;
  1243       break;
  1244     }
  1245 
  1246   ie.timestamp = count;
  1247   kbd_buffer_store_event (&ie);
  1248 }
  1249 
  1250 void
  1251 haiku_start_watching_selections (void)
  1252 {
  1253   be_start_watching_selection (CLIPBOARD_CLIPBOARD);
  1254   be_start_watching_selection (CLIPBOARD_PRIMARY);
  1255   be_start_watching_selection (CLIPBOARD_SECONDARY);
  1256 }
  1257 
  1258 void
  1259 syms_of_haikuselect (void)
  1260 {
  1261   DEFVAR_BOOL ("haiku-signal-invalid-refs", haiku_signal_invalid_refs,
  1262     doc: /* If nil, silently ignore invalid file names in system messages.
  1263 Otherwise, an error will be signaled if adding a file reference to a
  1264 system message failed.  */);
  1265   haiku_signal_invalid_refs = true;
  1266 
  1267   DEFVAR_LISP ("haiku-drag-track-function", Vhaiku_drag_track_function,
  1268     doc: /* If non-nil, a function to call upon mouse movement while dragging a message.
  1269 The function is called without any arguments.  `mouse-position' can be
  1270 used to retrieve the current position of the mouse.  */);
  1271   Vhaiku_drag_track_function = Qnil;
  1272 
  1273   DEFVAR_LISP ("haiku-lost-selection-functions", Vhaiku_lost_selection_functions,
  1274     doc: /* A list of functions to be called when Emacs loses an X selection.
  1275 These are only called if a connection to the Haiku display was opened.  */);
  1276   Vhaiku_lost_selection_functions = Qnil;
  1277 
  1278   DEFVAR_LISP ("haiku-drag-wheel-function", Vhaiku_drag_wheel_function,
  1279     doc: /* Function called upon wheel movement while dragging a message.
  1280 If non-nil, it is called with 6 arguments when the mouse wheel moves
  1281 while a drag-and-drop operation is in progress: the frame where the
  1282 mouse moved, the frame-relative X and Y positions where the mouse
  1283 moved, whether or not the wheel movement was horizontal, whether or
  1284 not the wheel moved up (or left, if the movement was horizontal), and
  1285 keyboard modifiers currently held down.  */);
  1286   Vhaiku_drag_wheel_function = Qnil;
  1287 
  1288   DEFSYM (QSECONDARY, "SECONDARY");
  1289   DEFSYM (QCLIPBOARD, "CLIPBOARD");
  1290   DEFSYM (QSTRING, "STRING");
  1291   DEFSYM (QUTF8_STRING, "UTF8_STRING");
  1292   DEFSYM (Qforeign_selection, "foreign-selection");
  1293   DEFSYM (QTARGETS, "TARGETS");
  1294 
  1295   DEFSYM (Qhaiku_lost_selection_functions,
  1296           "haiku-lost-selection-functions");
  1297 
  1298   DEFSYM (Qmessage, "message");
  1299   DEFSYM (Qstring, "string");
  1300   DEFSYM (Qref, "ref");
  1301   DEFSYM (Qshort, "short");
  1302   DEFSYM (Qlong, "long");
  1303   DEFSYM (Qllong, "llong");
  1304   DEFSYM (Qbyte, "byte");
  1305   DEFSYM (Qchar, "char");
  1306   DEFSYM (Qbool, "bool");
  1307   DEFSYM (Qtype, "type");
  1308   DEFSYM (Qsize_t, "size_t");
  1309   DEFSYM (Qssize_t, "ssize_t");
  1310   DEFSYM (Qpoint, "point");
  1311   DEFSYM (Qfloat, "float");
  1312   DEFSYM (Qdouble, "double");
  1313   DEFSYM (Qalready_running, "already-running");
  1314 
  1315   defsubr (&Shaiku_selection_data);
  1316   defsubr (&Shaiku_selection_timestamp);
  1317   defsubr (&Shaiku_selection_put);
  1318   defsubr (&Shaiku_selection_owner_p);
  1319   defsubr (&Shaiku_drag_message);
  1320   defsubr (&Shaiku_roster_launch);
  1321   defsubr (&Shaiku_write_node_attribute);
  1322   defsubr (&Shaiku_send_message);
  1323 
  1324   haiku_dnd_frame = NULL;
  1325 }