view release on metacpan or  search on metacpan

t/9.t  view on Meta::CPAN

if (Glib->CHECK_VERSION (2, 12, 0)) {
  print Glib::MainContext->new->is_owner ?
    "not ok 23\n" : "ok 23\n";
  print Glib::MainContext::is_owner(undef) ?
    "not ok 24\n" : "ok 24\n";
} else {
  print "ok 23 # skip\n";
  print "ok 24 # skip\n";
}

if (Glib->CHECK_VERSION (2, 14, 0)) {
  my $loop = Glib::MainLoop->new;
  Glib::Timeout->add_seconds (1, sub {
    print "ok 25 - in timeout handler\n";
    $loop->quit;
    return FALSE;
  });
  $loop->run;
} else {
  print "ok 25 # skip\n";
}


{
  my $skip_reason = undef;
  if (! $have_fork) {
    $skip_reason = "no fork: $fork_excuse";
  }
  if (! Glib->CHECK_VERSION (2, 4, 0)) {
    $skip_reason = 'need glib >= 2.4';
  }
  if ($^O eq 'freebsd' || $^O eq 'netbsd') {
    if ($Config{ldflags} !~ m/-pthread\b/) {
      $skip_reason = 'need a perl built with "-pthread" on freebsd/netbsd';
    }
  }
  if (defined $skip_reason) {
    print "ok 26 # skip: $skip_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;
  }
  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 {
       warn "*** Oops, child watch callback didn't run\n";
       print "not ok 29\n";
       print "not ok 30\n";
       $loop->quit;
       return Glib::SOURCE_CONTINUE;
     });
  $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
full list)

This library is free software; you can redistribute it and/or modify it under
the terms of the GNU Library General Public License as published by the Free
Software Foundation; either version 2.1 of the License, or (at your option) any
later version.

This library is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Library General Public License for more
details.

You should have received a copy of the GNU Library General Public License along
with this library; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.