#!/usr/bin/perl

#
# mainloop stuff.
#

use strict;
use warnings;
use Config;

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

GPerlClosures are used for Timeouts, Idle and IO watch handlers in addition
to GSignal stuff.

=cut

my $timeout = undef;

print "ok 2\n";
Glib::Idle->add (sub {print "ok 4 - idle one-shot\n"; 0});
Glib::Idle->add (sub {
		 print "ok 5 - another idle, but this one dies\n";
		 die "killer";
		 print "not ok - after die, shouldn't get here!\n";
		 1 # return true from idle to be called again; we
		   # should never get here, though
	});
$timeout = Glib::Timeout->add (1000, sub {
		    warn "!!!! should never get called";
		    die "oops" });
# timeouts and idles only get executed when there's a mainloop.
{
my $loop = Glib::MainLoop->new;
# the die will simply jump to the eval, leaving side effects in place.
# we have to kill the mainloop ourselves.
local $SIG{__DIE__} = sub {
		print "ok 6 - in __DIE__ handler\n";
		$loop->quit;
	};
local $SIG{__WARN__} = sub {
		print ""
		    . ($_[0] =~ /unhandled exception in callback/
		       ? "ok 7"
		       : "not ok - got something unexpected in __WARN__"
		      )
		    . "\n";
	};
print "ok 3 - running in eval\n";
$loop->run;
# remove this timeout to avoid confusing the next test.
Glib::Source->remove ($timeout);
}

# again, without dying in an idle this time
print "ok 8\n";
Glib::Timeout->add (100, sub { 
		    print "ok 10 - dying with 'waugh'\n";
		    die "waugh"
		    });
my $loop = Glib::MainLoop->new;
print "ok 9 - running in eval\n";
Glib->install_exception_handler (sub {
		print "ok 11 - killing loop from exception handler\n";
		$loop->quit;
		0});
$loop->run;


# this time with IO watchers
use Data::Dumper;

# There's a bug in glib which prevents io channels from marshalling
# properly here.  we don't have versioning API in Glib (yet), so
# we can't do much but just skip this.

if ($Config{archname} =~ m/^(x86_64|mipsel|mips|alpha)/
    && (!Glib->CHECK_VERSION (2,2,4))) {
	print "ok 12 # skip bug in glib\n";
	print "ok 13 # skip bug in glib\n";
	print "ok 14 # skip bug in glib\n";

} elsif ($^O eq "MSWin32") {
	print "ok 12 # skip add_watch on win32\n";
	print "ok 13 # skip add_watch on win32\n";
	print "ok 14 # skip add_watch on win32\n";
} else {
	print "ok 12\n";
	open IN, $0 or die "can't open file\n";
	Glib::IO->add_watch (fileno IN,
		     [qw/in err hup nval/], 
		     sub {
		     	local $/ = undef;
			#print Dumper(\@_);
			$_ = <IN>;
			#print "'$_'";
			#print "eof - ".eof ($_[0])."\n";
			if (eof $_[0]) {
				print "ok 14 - eof, dying with 'done\\n'\n";
				die "done\n";
			}
			1;
		     });
	$loop = Glib::MainLoop->new;
	print "ok 13 - running in eval\n";
	Glib->install_exception_handler (sub {$loop->quit; 0});
	$loop->run;
}


# 1.072 fixes the long-standing "bug" that perl's safe signal handling
# caused asynchronous signals not to be delivered while a main loop is
# running (because control stays in C).  let's make sure that we can
# get a 1 second alarm before a 5 second timeout has a chance to fire.
if ($^O eq 'MSWin32') {
	# XXX Win32 doesn't do SIGALRM the way unix does; either the alarm
	# doesn't interrupt the poll, or alarm just doesn't work.
	my $reason = "async signals don't work on win32 like they do on unix";
	print "ok 15 # skip $reason\n";
	print "ok 16 # skip $reason\n";
} else {
	$loop = Glib::MainLoop->new;
	$SIG{ALRM} = sub {
		print "ok 15 - ALRM handler\n";
		$loop->quit;
	};
	my $timeout_fired = 0;
	Glib::Timeout->add (5000, sub {
		$timeout_fired++;
		$loop->quit;
		0;
	});
	alarm 1;
	$loop->run;
	print ""
	    . ($timeout_fired ? "not ok" : "ok")
	    . " 16 - 1 sec alarm handler fires before 5 sec timeout\n";
}

if (Glib->CHECK_VERSION (2, 4, 0)) {
	print Glib::main_depth() == 0 ?
	  "ok 17\n" : "not ok 17\n";
} else {
	print "ok 17 # skip main_depth\n";
}

print $loop->is_running ?
  "not ok 18\n" : "ok 18\n";

print Glib::MainContext->new ?
  "ok 19\n" : "not ok 19\n";

print Glib::MainContext->default ?
  "ok 20\n" : "not ok 20\n";

print $loop->get_context ?
  "ok 21\n" : "not ok 21\n";

print Glib::MainContext->new->pending ?
  "not ok 22\n" : "ok 22\n";

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 { 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
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.