# MyTestHelpers.pm -- my shared test script helpers
# Copyright 2008, 2009, 2010 Kevin Ryde
# MyTestHelpers.pm is shared by several distributions.
#
# MyTestHelpers.pm is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 3, or (at your option) any later
# version.
#
# MyTestHelpers.pm 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 General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with this file. If not, see <http://www.gnu.org/licenses/>.
package MyTestHelpers;
use strict;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
@ISA = ('Exporter');
@EXPORT_OK = qw(findrefs
main_iterations
warn_suppress_gtk_icon
glib_gtk_versions
any_signal_connections
nowarnings);
%EXPORT_TAGS = (all => \@EXPORT_OK);
sub DEBUG { 0 }
#-----------------------------------------------------------------------------
{
my $warning_count;
my $stacktraces;
my $stacktraces_count = 0;
sub nowarnings_handler {
$warning_count++;
if ($stacktraces_count < 3 && eval { require Devel::StackTrace }) {
$stacktraces_count++;
$stacktraces .= "\n" . Devel::StackTrace->new->as_string() . "\n";
}
warn @_;
}
sub nowarnings {
$SIG{'__WARN__'} = \&nowarnings_handler;
}
END {
if ($warning_count) {
require Test::More;
Test::More::diag("Saw $warning_count warning(s):");
Test::More::diag($stacktraces);
Test::More::diag("Exit code 1 for warnings");
$? = 1;
}
}
}
sub findrefs {
my ($obj) = @_;
require Test::More;
defined $obj or return;
require Scalar::Util;
if (ref $obj && Scalar::Util::reftype($obj) eq 'HASH') {
Test::More::diag ("Keys: ", join(',', keys %$obj), "\n");
}
if (eval { require Devel::FindRef }) {
Test::More::diag (Devel::FindRef::track($obj, 8));
} else {
Test::More::diag ("Devel::FindRef not available -- $@\n");
}
}
#-----------------------------------------------------------------------------
# Gtk/Glib helpers
# Gtk 2.16 can go into a hard loop on events_pending() / main_iteration_do()
# if dbus is not running, or something like that. In any case limiting the
# iterations is good for test safety.
#
sub main_iterations {
require Test::More;
my $count = 0;
if (DEBUG) { Test::More::diag ("main_iterations() ..."); }
while (Gtk2->events_pending) {
$count++;
Gtk2->main_iteration_do (0);
if ($count >= 500) {
Test::More::diag ("main_iterations(): oops, bailed out after $count events/iterations");
return;
}
}
Test::More::diag ("main_iterations(): ran $count events/iterations");
}
# warn_suppress_gtk_icon() is a $SIG{__WARN__} handler which suppresses spam
# from Gtk trying to make you buy the hi-colour icon theme. Eg,
#
# {
# local $SIG{'__WARN__'} = \&MyTestHelpers::warn_suppress_gtk_icon;
# $something = SomeThing->new;
# }
#
sub warn_suppress_gtk_icon {
my ($message) = @_;
unless ($message =~ /Gtk-WARNING.*icon/) {
warn @_;
}
}
sub glib_gtk_versions {
require Test::More;
my $gtk2_loaded = Gtk2->can('init');
my $glib_loaded = Glib->can('get_home_dir');
if ($gtk2_loaded) {
Test::More::diag ("Perl-Gtk2 version ",Gtk2->VERSION);
}
if ($glib_loaded) { # when loaded
Test::More::diag ("Perl-Glib version ",Glib->VERSION);
Test::More::diag ("Compiled against Glib version ",
Glib::MAJOR_VERSION(), ".",
Glib::MINOR_VERSION(), ".",
Glib::MICRO_VERSION(), ".");
Test::More::diag ("Running on Glib version ",
Glib::major_version(), ".",
Glib::minor_version(), ".",
Glib::micro_version(), ".");
}
if ($gtk2_loaded) {
Test::More::diag ("Compiled against Gtk version ",
Gtk2::MAJOR_VERSION(), ".",
Gtk2::MINOR_VERSION(), ".",
Gtk2::MICRO_VERSION(), ".");
Test::More::diag ("Running on Gtk version ",
Gtk2::major_version(), ".",
Gtk2::minor_version(), ".",
Gtk2::micro_version(), ".");
}
}
# Return true if there's any signal handlers connected to $obj.
#
# Signal IDs are from 1 up, don't pass 0 to signal_handler_is_connected()
# since in Glib 2.4.1 it spits out a g_log() error.
#
sub any_signal_connections {
my ($obj) = @_;
my @connected = grep {$obj->signal_handler_is_connected ($_)} (1 .. 500);
if (@connected) {
my $connected = join(',',@connected);
Test::More::diag ("$obj signal handlers connected: $connected");
return $connected;
}
return undef;
}
# wait for $signame to be emitted on $widget, with a timeout
sub wait_for_event {
my ($widget, $signame) = @_;
require Test::More;
if (DEBUG) { Test::More::diag ("wait_for_event() $signame on $widget"); }
my $done = 0;
my $got_event = 0;
my $sig_id = $widget->signal_connect
($signame => sub {
if (DEBUG) { Test::More::diag ("wait_for_event() $signame received"); }
$done = 1;
return 0; # Gtk2::EVENT_PROPAGATE (new in Gtk2 1.220)
});
my $timer_id = Glib::Timeout->add
(30_000, # 30 seconds
sub {
$done = 1;
Test::More::diag ("wait_for_event() oops, timeout waiting for $signame on $widget");
return 1; # Glib::SOURCE_CONTINUE (new in Glib 1.220)
});
if ($widget->can('get_display')) {
# GdkDisplay new in Gtk 2.2
$widget->get_display->sync;
} else {
# in Gtk 2.0 gdk_flush() is a sync actually
Gtk2::Gdk->flush;
}
my $count = 0;
while (! $done) {
if (DEBUG >= 2) { Test::More::diag ("wait_for_event() iteration $count"); }
Gtk2->main_iteration;
$count++;
}
Test::More::diag ("wait_for_event(): '$signame' ran $count events/iterations\n");
$widget->signal_handler_disconnect ($sig_id);
Glib::Source->remove ($timer_id);
}
1;
__END__