master b9ca1a8e4f: Implement wallpaper.el support for Haiku

[Po Lu]

branch: master
commit b9ca1a8e4fbd3f8ef0d384d402ec5721ddcad28c
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>

    Implement wallpaper.el support for Haiku
    
    * lisp/image/wallpaper.el (haiku-set-wallpaper, wallpaper-set):
    Use `haiku-set-wallpaper' on Haiku.
    * lisp/term/haiku-win.el (haiku-write-node-attribute)
    (haiku-send-message, haiku-set-wallpaper): New function.
    * src/haiku_support.cc (be_write_node_message, be_send_message):
    New functions.
    * src/haiku_support.h: Update prototypes.
    * src/haikuselect.c (haiku_message_to_lisp)
    (haiku_lisp_to_message): Fix CSTR type handling to include NULL
    byte.
    (haiku_report_system_error, Fhaiku_write_node_attribute)
    (Fhaiku_send_message): New functions.
    (syms_of_haikuselect): Add defsubrs.
---
 lisp/image/wallpaper.el |  56 +++++++++++----------
 lisp/term/haiku-win.el  |  39 +++++++++++++++
 src/haiku_support.cc    |  53 ++++++++++++++++++++
 src/haiku_support.h     |   3 ++
 src/haikuselect.c       | 129 ++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 254 insertions(+), 26 deletions(-)

diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el
index ca2b36db2e..19741a20f1 100644
--- a/lisp/image/wallpaper.el
+++ b/lisp/image/wallpaper.el
@@ -105,6 +105,8 @@ You can also use \\[report-emacs-bug]."
                (executable-find (car cmd)))
           (throw 'found cmd)))))
 
+(declare-function haiku-set-wallpaper "term/haiku-win.el")
+
 (defun wallpaper-set (file)
   "Set the desktop background to FILE in a graphical environment."
   (interactive (list (and
@@ -121,32 +123,34 @@ You can also use \\[report-emacs-bug]."
   (unless (file-readable-p file)
     (error "File is not readable: %s" file))
   (when (display-graphic-p)
-    (let* ((command (wallpaper--find-command))
-           (fmt-spec `((?f . ,(expand-file-name file))
-                       (?h . ,(display-pixel-height))
-                       (?w . ,(display-pixel-width))))
-           (bufname (format " *wallpaper-%s*" (random)))
-           (process
-            (and command
-                 (apply #'start-process "set-wallpaper" bufname
-                        (car command)
-                        (mapcar (lambda (arg) (format-spec arg fmt-spec))
-                                (cdr command))))))
-      (unless command
-        (error "Can't find a suitable command for setting the wallpaper"))
-      (wallpaper-debug "Using command %s" (car command))
-      (setf (process-sentinel process)
-            (lambda (process status)
-              (unwind-protect
-                  (unless (and (eq (process-status process) 'exit)
-                               (zerop (process-exit-status process)))
-                    (message "command %S %s: %S" (string-join (process-command 
process) " ")
-                             (string-replace "\n" "" status)
-                             (with-current-buffer (process-buffer process)
-                               (string-clean-whitespace (buffer-string)))))
-                (ignore-errors
-                  (kill-buffer (process-buffer process))))))
-      process)))
+    (if (featurep 'haiku)
+        (haiku-set-wallpaper file)
+      (let* ((command (wallpaper--find-command))
+             (fmt-spec `((?f . ,(expand-file-name file))
+                         (?h . ,(display-pixel-height))
+                         (?w . ,(display-pixel-width))))
+             (bufname (format " *wallpaper-%s*" (random)))
+             (process
+              (and command
+                   (apply #'start-process "set-wallpaper" bufname
+                          (car command)
+                          (mapcar (lambda (arg) (format-spec arg fmt-spec))
+                                  (cdr command))))))
+        (unless command
+          (error "Can't find a suitable command for setting the wallpaper"))
+        (wallpaper-debug "Using command %s" (car command))
+        (setf (process-sentinel process)
+              (lambda (process status)
+                (unwind-protect
+                    (unless (and (eq (process-status process) 'exit)
+                                 (zerop (process-exit-status process)))
+                      (message "command %S %s: %S" (string-join 
(process-command process) " ")
+                               (string-replace "\n" "" status)
+                               (with-current-buffer (process-buffer process)
+                                 (string-clean-whitespace (buffer-string)))))
+                  (ignore-errors
+                    (kill-buffer (process-buffer process))))))
+        process))))
 
 (provide 'wallpaper)
 
diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el
index a16169d477..24942d96c1 100644
--- a/lisp/term/haiku-win.el
+++ b/lisp/term/haiku-win.el
@@ -598,6 +598,45 @@ MODIFIERS is the internal modifier mask of the wheel 
movement."
     ;; the Deskbar will not, so kill ourself here.
     (unless cancel-shutdown (kill-emacs))))
 
+;;;; Wallpaper support.
+
+
+(declare-function haiku-write-node-attribute "haikuselect.c")
+(declare-function haiku-send-message "haikuselect.c")
+
+(defun haiku-set-wallpaper (file)
+  "Make FILE the wallpaper.
+Set the desktop background to the image FILE, on all workspaces,
+with an offset of 0, 0."
+  (let ((encoded-file (encode-coding-string
+                       (expand-file-name file)
+                       (or file-name-coding-system
+                           default-file-name-coding-system))))
+    ;; Write the necessary information to the desktop directory.
+    (haiku-write-node-attribute "/boot/home/Desktop"
+                                "be:bgndimginfo"
+                                (list '(type . 0)
+                                      '("be:bgndimginfoerasetext" bool t)
+                                      (list "be:bgndimginfopath" 'string
+                                            encoded-file)
+                                      '("be:bgndimginfoworkspaces" long
+                                        ;; This is a mask of all the
+                                        ;; workspaces the background
+                                        ;; image will be applied to.  It
+                                        ;; is treated as an unsigned
+                                        ;; value by the Tracker, despite
+                                        ;; the type being signed.
+                                        -1)
+                                      ;; Don't apply an offset
+                                      '("be:bgndimginfooffset" point (0 . 0))
+                                      ;; Don't stretch or crop or anything
+                                      '("be:bgndimginfomode" long 0)
+                                      ;; Don't apply a set
+                                      '("be:bgndimginfoset" long 0)))
+    ;; Tell the tracker to redisplay the wallpaper.
+    (haiku-send-message "application/x-vnd.Be-TRAK"
+                        (list (cons 'type (haiku-numeric-enum Tbgr))))))
+
 
 ;;;; Cursors.
 
diff --git a/src/haiku_support.cc b/src/haiku_support.cc
index 983928442a..0f8e26d0db 100644
--- a/src/haiku_support.cc
+++ b/src/haiku_support.cc
@@ -54,12 +54,14 @@ along with GNU Emacs.  If not, see 
<https://www.gnu.org/licenses/>.  */
 #include <game/WindowScreen.h>
 #include <game/DirectWindow.h>
 
+#include <storage/FindDirectory.h>
 #include <storage/Entry.h>
 #include <storage/Path.h>
 #include <storage/FilePanel.h>
 #include <storage/AppFileInfo.h>
 #include <storage/Path.h>
 #include <storage/PathFinder.h>
+#include <storage/Node.h>
 
 #include <support/Beep.h>
 #include <support/DataIO.h>
@@ -5501,3 +5503,54 @@ be_set_use_frame_synchronization (void *view, bool sync)
   vw = (EmacsView *) view;
   vw->SetFrameSynchronization (sync);
 }
+
+status_t
+be_write_node_message (const char *path, const char *name, void *message)
+{
+  BNode node (path);
+  status_t rc;
+  ssize_t flat, result;
+  char *buffer;
+  BMessage *msg;
+
+  rc = node.InitCheck ();
+  msg = (BMessage *) message;
+
+  if (rc < B_OK)
+    return rc;
+
+  flat = msg->FlattenedSize ();
+  if (flat < B_OK)
+    return flat;
+
+  buffer = new (std::nothrow) char[flat];
+  if (!buffer)
+    return B_NO_MEMORY;
+
+  rc = msg->Flatten (buffer, flat);
+  if (rc < B_OK)
+    {
+      delete[] buffer;
+      return rc;
+    }
+
+  result = node.WriteAttr (name, B_MIME_TYPE, 0,
+                          buffer, flat);
+  delete[] buffer;
+
+  if (result < B_OK)
+    return result;
+
+  if (result != flat)
+    return B_ERROR;
+
+  return B_OK;
+}
+
+void
+be_send_message (const char *app_id, void *message)
+{
+  BMessenger messenger (app_id);
+
+  messenger.SendMessage ((BMessage *) message);
+}
diff --git a/src/haiku_support.h b/src/haiku_support.h
index ca1808556a..d66dbc5fa6 100644
--- a/src/haiku_support.h
+++ b/src/haiku_support.h
@@ -724,6 +724,9 @@ extern void be_get_window_decorator_frame (void *, int *, 
int *, int *, int *);
 extern void be_send_move_frame_event (void *);
 extern void be_set_window_fullscreen_mode (void *, enum haiku_fullscreen_mode);
 
+extern status_t be_write_node_message (const char *, const char *, void *);
+extern void be_send_message (const char *, void *);
+
 extern void be_lock_window (void *);
 extern void be_unlock_window (void *);
 extern bool be_get_explicit_workarea (int *, int *, int *, int *);
diff --git a/src/haikuselect.c b/src/haikuselect.c
index 7eb93a2754..bd004f4900 100644
--- a/src/haikuselect.c
+++ b/src/haikuselect.c
@@ -325,6 +325,15 @@ haiku_message_to_lisp (void *message)
              t1 = make_float (*(float *) buf);
              break;
 
+           case 'CSTR':
+             /* Is this even possible? */
+             if (!buf_size)
+               buf_size = 1;
+
+             t1 = make_uninit_string (buf_size - 1);
+             memcpy (SDATA (t1), buf, buf_size - 1);
+             break;
+
            default:
              t1 = make_uninit_string (buf_size);
              memcpy (SDATA (t1), buf, buf_size);
@@ -747,6 +756,21 @@ haiku_lisp_to_message (Lisp_Object obj, void *message)
                signal_error ("Failed to add bool", data);
              break;
 
+           case 'CSTR':
+             /* C strings must be handled specially, since they
+                include a trailing NULL byte.  */
+             CHECK_STRING (data);
+
+             block_input ();
+             rc = be_add_message_data (message, SSDATA (name),
+                                       type_code, SDATA (data),
+                                       SBYTES (data) + 1);
+             unblock_input ();
+
+             if (rc)
+               signal_error ("Failed to add", data);
+             break;
+
            default:
            decode_normally:
              CHECK_STRING (data);
@@ -779,6 +803,49 @@ haiku_unwind_drag_message (void *message)
   BMessage_delete (message);
 }
 
+static void
+haiku_report_system_error (status_t code, const char *format)
+{
+  switch (code)
+    {
+    case B_BAD_VALUE:
+      error (format, "Bad value");
+      break;
+
+    case B_ENTRY_NOT_FOUND:
+      error (format, "File not found");
+      break;
+
+    case B_PERMISSION_DENIED:
+      error (format, "Permission denied");
+      break;
+
+    case B_LINK_LIMIT:
+      error (format, "Link limit reached");
+      break;
+
+    case B_BUSY:
+      error (format, "Device busy");
+      break;
+
+    case B_NO_MORE_FDS:
+      error (format, "No more file descriptors");
+      break;
+
+    case B_FILE_ERROR:
+      error (format, "File error");
+      break;
+
+    case B_NO_MEMORY:
+      memory_full (SIZE_MAX);
+      break;
+
+    default:
+      error (format, "Unknown error");
+      break;
+    }
+}
+
 DEFUN ("haiku-drag-message", Fhaiku_drag_message, Shaiku_drag_message,
        2, 4, 0,
        doc: /* Begin dragging MESSAGE from FRAME.
@@ -958,6 +1025,66 @@ after it starts.  */)
   return SAFE_FREE_UNBIND_TO (depth, Qnil);
 }
 
+DEFUN ("haiku-write-node-attribute", Fhaiku_write_node_attribute,
+       Shaiku_write_node_attribute, 3, 3, 0,
+       doc: /* Write a message as a file-system attribute of NODE.
+FILE should be a file name of a file on a Be File System volume, NAME
+should be a string describing the name of the attribute that will be
+written, and MESSAGE will be the attribute written to FILE, as a
+system message in the format accepted by `haiku-drag-message', which
+see.  */)
+  (Lisp_Object file, Lisp_Object name, Lisp_Object message)
+{
+  void *be_message;
+  status_t rc;
+  specpdl_ref count;
+
+  CHECK_STRING (file);
+  CHECK_STRING (name);
+
+  file = ENCODE_FILE (file);
+  name = ENCODE_SYSTEM (name);
+
+  be_message = be_create_simple_message ();
+  count = SPECPDL_INDEX ();
+
+  record_unwind_protect_ptr (BMessage_delete, be_message);
+  haiku_lisp_to_message (message, be_message);
+  rc = be_write_node_message (SSDATA (file), SSDATA (name),
+                             be_message);
+
+  if (rc < B_OK)
+    haiku_report_system_error (rc, "Failed to set attribute: %s");
+
+  return unbind_to (count, Qnil);
+}
+
+DEFUN ("haiku-send-message", Fhaiku_send_message, Shaiku_send_message,
+       2, 2, 0,
+       doc: /* Send a system message to PROGRAM.
+PROGRAM must be the name of the application to which the message will
+be sent.  MESSAGE is the system message, serialized in the format
+accepted by `haiku-drag-message', that will be sent to the application
+specified by PROGRAM.  There is no guarantee that the message will
+arrive after this function is called.  */)
+  (Lisp_Object program, Lisp_Object message)
+{
+  specpdl_ref count;
+  void *be_message;
+
+  CHECK_STRING (program);
+  program = ENCODE_SYSTEM (program);
+
+  be_message = be_create_simple_message ();
+  count = SPECPDL_INDEX ();
+
+  record_unwind_protect_ptr (BMessage_delete, be_message);
+  haiku_lisp_to_message (message, be_message);
+  be_send_message (SSDATA (program), be_message);
+
+  return unbind_to (count, Qnil);
+}
+
 static void
 haiku_dnd_compute_tip_xy (int *root_x, int *root_y)
 {
@@ -1191,6 +1318,8 @@ keyboard modifiers currently held down.  */);
   defsubr (&Shaiku_selection_owner_p);
   defsubr (&Shaiku_drag_message);
   defsubr (&Shaiku_roster_launch);
+  defsubr (&Shaiku_write_node_attribute);
+  defsubr (&Shaiku_send_message);
 
   haiku_dnd_frame = NULL;
 }