X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=gdk%2Fgdk.screen.lisp;h=29215d71a0e405237016d13917f87600f8588fe1;hb=e469002e1f9cea158367cc18344817ec6d1c776f;hp=cbc847e1b1312dd6c40a7f49f7d9331ca5ed4f84;hpb=6f2df31b829c09eac1300efddc370cb3c18885d0;p=cl-gtk2.git

diff --git a/gdk/gdk.screen.lisp b/gdk/gdk.screen.lisp
index cbc847e..29215d7 100644
--- a/gdk/gdk.screen.lisp
+++ b/gdk/gdk.screen.lisp
@@ -71,3 +71,86 @@
     (gdk-spawn-command-line-on-screen screen command-line err)))
 
 (export 'spawn-command-line-on-screen)
+
+(defcfun gdk_spawn_on_screen :boolean
+  (screen (g-object screen))
+  (working-directory :string)
+  (argv :pointer)
+  (envp :pointer)
+  (flags glib:g-spawn-flags)
+  (child-setup :pointer)
+  (user-data :pointer)
+  (child-pid (:pointer :int))
+  (g-error :pointer))
+
+(defcfun gdk_spawn_on_screen_with_pipes :boolean
+  (screen (g-object screen))
+  (working-directory :string)
+  (argv :pointer)
+  (envp :pointer)
+  (flags glib:g-spawn-flags)
+  (child-setup :pointer)
+  (user-data :pointer)
+  (child-pid (:pointer :int))
+  (std-input (:pointer :int))
+  (std-output (:pointer :int))
+  (std-err (:pointer :int))
+  (g-error :pointer))
+
+(defmacro with-foreign-string-array ((var strings &key (null-terminated t)) &body body)
+  (let ((strings-var (gensym))
+        (s (gensym))
+        (i (gensym))
+        (n (gensym)))
+    `(let* ((,strings-var ,strings)
+            (,n (length ,strings-var)))
+       (with-foreign-object (,var :pointer ,(if null-terminated `(1+ ,n) `,n))
+         (iter (for ,s in ,strings-var)
+               (for ,i from 0)
+               (setf (mem-aref ,var :pointer ,i) (foreign-string-alloc ,s))
+               ,@(when null-terminated
+                       (list `(finally (setf (mem-aref ,var :pointer ,n) (null-pointer))))))
+         (unwind-protect (progn ,@body)
+           (iter (for ,i from 0 below ,n)
+                 (foreign-string-free (mem-aref ,var :pointer ,i))))))))
+
+(defun gdk-spawn-on-screen (screen argv &key working-directory env (flags '(:search-path)) with-pipes)
+  (unless working-directory (setf working-directory (null-pointer)))
+  (glib:with-g-error (err)
+    (with-foreign-objects ((pid :int) (stdin :int) (stdout :int) (stderr :int))
+      (with-foreign-string-array (argvp argv)
+        (if (null env)
+            (if with-pipes
+                (gdk_spawn_on_screen_with_pipes screen
+                                                working-directory
+                                                argvp
+                                                (null-pointer)
+                                                flags
+                                                (null-pointer)
+                                                (null-pointer)
+                                                pid stdin stdout stderr err)
+                (gdk_spawn_on_screen screen
+                                     working-directory
+                                     argvp
+                                     (null-pointer)
+                                     flags
+                                     (null-pointer)
+                                     (null-pointer)
+                                     pid err))
+            (with-foreign-string-array (envp env)
+              (if with-pipes
+                  (gdk_spawn_on_screen_with_pipes screen
+                                                  working-directory
+                                                  argvp envp flags
+                                                  (null-pointer) (null-pointer)
+                                                  pid stdin stdout stderr err)
+                  (gdk_spawn_on_screen screen
+                                       working-directory
+                                       argvp envp
+                                       flags (null-pointer) (null-pointer)
+                                       pid err)))))
+      (if with-pipes
+          (values (mem-ref pid :int) (mem-ref stdin :int) (mem-ref stdout :int) (mem-ref stderr :int))
+          (mem-ref pid :int)))))
+
+(export 'gdk-spawn-on-screen)