child watch source (was: exception trap in key snooper callback)

[Kevin Ryde <user42 zip com au>]

Torsten Schoenfeld <kaffeetisch gmx de> writes:
>
> The docs say that on win32, GPid is typedef'd to some kind of process handle,
> i.e. a pointer.

Inflicting the incapacities of non-free on the free software world :-(

> So I think the cast to int is not correct, at least on some
> architectures.

Without the g_spawn funcs the int is all is for now, I believe.  Ints of
course will, with a little luck, inter-operate with native forking, and
at least a couple of the job-starting modules on cpan.

> Also, can you write a unit test for this?

Below, with a couple of lines to hopefully skip if fork() isn't a real
fork, but I've got no way to try that.


--- GMainLoop.xs	16 Sep 2007 00:10:12 +1000	1.24
+++ GMainLoop.xs	27 Aug 2008 10:09:01 +1000	
@@ -136,6 +136,11 @@
 	g_source_attach (async_watcher, NULL);
 }
 
+static void
+gperl_child_watch_callback (GPid pid, gint status, gpointer cb)
+{
+	gperl_callback_invoke ((GPerlCallback*)cb, NULL, (int) pid, status);
+}
 
 MODULE = Glib::MainLoop	PACKAGE = Glib	PREFIX = g_
 
@@ -549,3 +554,45 @@
     OUTPUT:
 	RETVAL
 
+
+MODULE = Glib::MainLoop	PACKAGE = Glib::Child	PREFIX = g_child_
+
+=for object Glib::MainLoop
+=cut
+
+=for apidoc
+=for arg pid (integer) child process ID
+=for arg callback (subroutine)
+
+Add a source to the default main context which will call
+
+    &$callback ($pid, $waitstatus, $data)
+
+when child process $pid terminates.  The return value is a source id
+which can be used with C<< Glib::Source->remove >>.  When the callback
+is made the source is removed automatically.
+
+In a non-threaded program Glib implements this source by installing a
+SIGCHLD handler.  Don't change $SIG{CHLD} in Perl or the callback will
+never run.
+
+=cut
+guint
+g_child_watch_add (class, int pid, SV *callback, SV *data=NULL, gint priority=G_PRIORITY_DEFAULT)
+    PREINIT:
+	GPerlCallback* cb;
+	GType param_types[2];
+    CODE:
+	/* As of Glib 2.16.4 there's no "callback_closure" func in
+	   g_child_watch_funcs, and none added there by
+	   g_source_set_closure (unlike idle, timeout and io above),
+	   so go GPerlCallback style. */
+	param_types[0] = G_TYPE_INT;
+	param_types[1] = G_TYPE_INT;
+	cb = gperl_callback_new (callback, data, 2, param_types, 0);
+	RETVAL = g_child_watch_add_full (priority, (GPid) pid,
+	       	 			 gperl_child_watch_callback,
+					 cb,
+	       	 	(GDestroyNotify) gperl_callback_destroy);
+    OUTPUT:
+	RETVAL

--- 9.t	18 Jan 2008 10:48:13 +1100	1.16
+++ 9.t	27 Aug 2008 10:28:35 +1000	
@@ -8,7 +8,7 @@
 use warnings;
 use Config;
 
-print "1..25\n";
+print "1..30\n";
 
 use Glib qw/:constants/;
 
@@ -188,6 +188,64 @@
   print "ok 25 # skip\n";
 }
 
+
+{
+  my $pid = fork();
+  if (! defined $pid || $pid < 0) {
+    my $reason;
+    if (! defined $pid) {
+      $reason = "error $!";
+    } else {
+      $reason = "perlfork fakery";
+      waitpid ($pid, 0);
+    }
+    print "ok 26 # skip, no fork: $reason\n";
+    print "ok 27 # skip\n";
+    print "ok 28 # skip\n";
+    print "ok 29 # skip\n";
+    print "ok 30 # skip\n";
+    goto SKIP_CHILD_TESTS;
+  }
+  if ($pid == 0) {
+    # child
+    require POSIX;
+    POSIX::_exit(42);
+  }
+  # parent
+  my $loop = Glib::MainLoop->new;
+  my $userdata = [ 'hello' ];
+  my $id = Glib::Child->watch_add ($pid, sub { die; }, $userdata);
+  require Scalar::Util;
+  Scalar::Util::weaken ($userdata);
+  print '', (defined $userdata ? 'ok' : 'not ok'),
+    " 26 - child userdata kept alive\n";
+  print '', (Glib::Source->remove($id) ? 'ok' : 'not ok'),
+    " 27 - child source removal\n";
+  print '', (! defined $userdata ? 'ok' : 'not ok'),
+    " 28 - child userdata now gone\n";
+
+  # No test of $status here, yet, since it may be a raw number on ms-dos,
+  # instead of a waitpid() style "code*256".  Believe there's no
+  # POSIX::WIFEXITED() etc on dos either to help examining the value.
+  my $timer_id;
+  Glib::Child->watch_add ($pid,
+                          sub {
+                            my ($pid, $status, $userdata) = @_;
+                            print '', ($userdata eq 'hello' ? 'ok' : 'not ok'),
+                              " 29 - child callback userdata value\n";
+                            print "ok 30 - child callback\n";
+                            $loop->quit;
+                          },
+                          'hello');
+  $timer_id = Glib::Timeout->add
+    (30_000, # 30 seconds should be more than enough for child exit
+     sub { die "Oops, child watch callback didn't run\n"; });
+  $loop->run;
+  Glib::Source->remove ($timer_id);
+}
+SKIP_CHILD_TESTS:
+
+
 __END__
 
 Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for the