perl-Glib r1037 - in trunk: . t

[tsch svn gnome org]

Author: tsch
Date: Sat Nov  1 19:27:44 2008
New Revision: 1037
URL: http://svn.gnome.org/viewvc/perl-Glib?rev=1037&view=rev

Log:
Wrap g_child_watch_add as Glib::Child::watch_add.  Patch by Kevin Ryde.


Modified:
   trunk/ChangeLog
   trunk/GMainLoop.xs
   trunk/t/9.t

Modified: trunk/GMainLoop.xs
==============================================================================
--- trunk/GMainLoop.xs	(original)
+++ trunk/GMainLoop.xs	Sat Nov  1 19:27:44 2008
@@ -136,6 +136,15 @@
 	g_source_attach (async_watcher, NULL);
 }
 
+#if GLIB_CHECK_VERSION (2, 4, 0)
+
+static void
+gperl_child_watch_callback (GPid pid, gint status, gpointer cb)
+{
+	gperl_callback_invoke ((GPerlCallback*)cb, NULL, (int) pid, status);
+}
+
+#endif /* 2.4 */
 
 MODULE = Glib::MainLoop	PACKAGE = Glib	PREFIX = g_
 
@@ -559,3 +568,49 @@
     OUTPUT:
 	RETVAL
 
+
+MODULE = Glib::MainLoop	PACKAGE = Glib::Child	PREFIX = g_child_
+
+=for object Glib::MainLoop
+=cut
+
+#if GLIB_CHECK_VERSION (2, 4, 0)
+
+=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
+
+#endif /* 2.4 */

Modified: trunk/t/9.t
==============================================================================
--- trunk/t/9.t	(original)
+++ trunk/t/9.t	Sat Nov  1 19:27:44 2008
@@ -8,10 +8,31 @@
 use warnings;
 use Config;
 
-print "1..25\n";
+print "1..30\n";
 
 use Glib qw/:constants/;
 
+my $have_fork = 0;
+my $fork_excuse;
+{
+  my $pid = fork();
+  if (! defined $pid) {
+    $fork_excuse = "error $!";
+  } elsif ($pid == 0) {
+    # child
+    exit (0);
+  } elsif ($pid < 0) {
+    # parent, perlfork
+    $fork_excuse = "perlfork fakery";
+    waitpid ($pid, 0);
+  } else {
+    # parent, real fork
+    $have_fork = 1;
+    waitpid ($pid, 0);
+  }
+}
+
+
 print "ok 1\n";
 
 =out
@@ -188,6 +209,68 @@
   print "ok 25 # skip\n";
 }
 
+
+{
+  if (! $have_fork) {
+    print "ok 26 # skip, no fork: $fork_excuse\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 (! Glib->CHECK_VERSION (2, 4, 0)) {
+    print "ok 26 # skip: need glib >= 2.4\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;
+  }
+  my $pid = fork();
+  if (! defined $pid) {
+    die "oops, cannot fork: $!";
+  }
+  if ($pid == 0) {
+    # child
+    require POSIX;
+    POSIX::_exit(42); # no END etc cleanups
+  }
+  # 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