view release on metacpan or  search on metacpan

t/7.t  view on Meta::CPAN

   $my->signal_handler_block ($id_b);
   $my->signal_handler_unblock ($id_b);
   ok($my->signal_handler_is_connected ($id_b), 9);

   $my->signal_handler_disconnect ($id_b);
   $my->something_changed;

   # attempting to marshal the wrong number of params should croak.
   # this is part of the emission process going wrong, not a handler,
   # so it's a bug in the calling code, and thus we shouldn't eat it.
   eval { $my->test_marshaler (); };
   ok( $@ =~ m/Incorrect number/, 10, "signal_emit barfs on bad input" );

   $my->test_marshaler (qw/foo bar 15/, $my);
   pass(11);
   my $id = $my->signal_connect (test_marshaler => sub {
	   ok( $_[0] == $my   &&
	       $_[1] eq 'foo' &&
	       $_[2]          && # string bar is true
	       $_[3] == 15    && # expect an int
	       $_[4] == $my   && # object passes unmolested
	       $_[5][1] eq 'two' # user-data is an array ref
               ,
	       13,
               "marshalling"
           );
	   return 77.1;
   	}, [qw/one two/, 3.1415]);
   ok($id, 12);
   $my->test_marshaler (qw/foo bar/, 15, $my);
   pass(14);

   $my->signal_handler_disconnect ($id);

   # here's a signal handler that has an exception.
   # we should be able to emit the signal all we like without catching
   # exceptions here, because we don't care what other people may have
   # connected to the signal.  the signal's exception can be caught with
   # an installed exception handler.
   $id = $my->signal_connect (test_marshaler => sub {
                              # signal handlers are always eval'd, so
                              # $@ should be empty.
                              warn "internal problem: \$@ is not empty in "
                                 . "signal handler!!!" if $@;
                              die "ouch"
                              });

   my $tag;
   $tag = Glib->install_exception_handler (sub {
                ok( $tag, 16, "exception_handler" );
	   	0  # returning FALSE uninstalls
	   }, [qw/foo bar/, 0]);
   ok($tag, 15, "installed exception handler");

   # the exception in the signal handler should not affect the value of
   # $@ at this code layer.
   $@ = 'neener neener neener';
   print "# before invocation: \$@ $@\n";
   $my->test_marshaler (qw/foo bar/, 4154, $my);
   print "# after invocation: \$@ $@\n";
   pass(17, "still alive after an exception in a callback");
   ok($@ eq 'neener neener neener', 18, "$@ is preserved across signals") ||
        diag "# expected 'neener neener neener'\n",
	     "   # got '$@'";
   $tag = 0;

   # that was a single-shot -- the exception handler shouldn't run again.
   {
   local $SIG{__WARN__} = sub {
	   if ($_[0] =~ m/unhandled/m) {
	   	pass(20, "unhandled exception just warns");
	   } elsif ($_[0] =~ m/isn't numeric/m) {
	   	pass(19, "string value isn't numeric");
	   } else {
		fail("got something unexpected in __WARN__: $_[0]\n");
	   }
	};
   $my->test_marshaler (qw/foo bar baz/, $my);
   pass(21);
   }

   use Data::Dumper;
   $my->signal_connect (returner => sub { pass(23); 0.5 });
   # the class closure should be called in between these two
   $my->signal_connect_after (returner => sub { pass(25); 42.0 });
   pass(22);
   my $ret = $my->returner;
   # we should have the return value from the last handler
   ok( $ret == 42.0, 26 ) || diag("expected 42.0, got $ret");

   # now with our special accumulator
   $my->signal_connect (list_returner => sub { pass(28); 10 });
   $my->signal_connect (list_returner => sub { pass(29); '15' });
   $my->signal_connect (list_returner => sub { pass(30); [20] });
   $my->signal_connect (list_returner => sub { pass(31); {thing => 25} });
   # class closure should before the "connect_after" ones,
   # and this one will stop everything by returning the magic value.
   $my->signal_connect_after (list_returner => sub { pass(33, "stopper"); 42 });
   # if this one is called, the accumulator isn't working right
   $my->signal_connect_after (list_returner => sub { fail("shouldn't get here"); 0 });
   pass(27);
   print Dumper( $my->list_returner );


   # Check that a signal_connect() of a non-existant signal name doesn't
   # leak the subr passed to it, ie. doesn't keep it alive forever.
   #
   # Note $subr has to use $x or similar in its containing environment to be
   # a closure.  If not then it's treated as part of the mainline code and
   # won't be gc'ed immediately -- or something like that.
   {
     my $x = 123;
     my $subr = sub { return $x };

     # handler to suppress the warning message from nosuchsignal
     my $logid = Glib::Log->set_handler ('GLib-GObject', ['warning'], sub { });
     my $sigid = $my->signal_connect ('nosuchsignal' => $subr);
     Glib::Log->remove_handler ('GLib-GObject', $logid);

     ok(! $sigid, 34, "'nosuchsignal' not connected");
     require Scalar::Util;
     Scalar::Util::weaken ($subr);
     ok(! defined $subr, 35, "subr gc'ed after bad signal name");
   }
}

pass(36);




__END__

Copyright (C) 2003, 2009 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.