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
++;
$stacktraces_count
++;
$stacktraces
.=
"\n"
. Devel::StackTrace->new->as_string() .
"\n"
;
}
warn
@_
;
}
sub
nowarnings {
$SIG
{
'__WARN__'
} = \
&nowarnings_handler
;
}
END {
if
(
$warning_count
) {
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
) =
@_
;
defined
$obj
or
return
;
if
(
ref
$obj
&& Scalar::Util::reftype(
$obj
) eq
'HASH'
) {
Test::More::diag (
"Keys: "
,
join
(
','
,
keys
%$obj
),
"\n"
);
}
Test::More::diag (Devel::FindRef::track(
$obj
, 8));
}
else
{
Test::More::diag (
"Devel::FindRef not available -- $@\n"
);
}
}
sub
main_iterations {
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"
);
}
sub
warn_suppress_gtk_icon {
my
(
$message
) =
@_
;
unless
(
$message
=~ /Gtk-WARNING.
*icon
/) {
warn
@_
;
}
}
sub
glib_gtk_versions {
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
) {
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(),
"."
);
}
}
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
;
}
sub
wait_for_event {
my
(
$widget
,
$signame
) =
@_
;
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;
});
my
$timer_id
= Glib::Timeout->add
(30_000,
sub
{
$done
= 1;
Test::More::diag (
"wait_for_event() oops, timeout waiting for $signame on $widget"
);
return
1;
});
if
(
$widget
->can(
'get_display'
)) {
$widget
->get_display->sync;
}
else
{
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;