1# MyTestHelpers.pm -- my shared test script helpers 2 3# Copyright 2008, 2009, 2010, 2011, 2012, 2015, 2017, 2018 Kevin Ryde 4 5# MyTestHelpers.pm is shared by several distributions. 6# 7# MyTestHelpers.pm is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by the 9# Free Software Foundation; either version 3, or (at your option) any later 10# version. 11# 12# MyTestHelpers.pm is distributed in the hope that it will be useful, but 13# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 14# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15# for more details. 16# 17# You should have received a copy of the GNU General Public License along 18# with this file. If not, see <http://www.gnu.org/licenses/>. 19 20BEGIN { require 5 } 21package MyTestHelpers; 22use strict; 23 24 25# Don't want to load Exporter here since that could hide a problem of a 26# module missing a "use Exporter". Though Test.pm and Test::More (via 27# Test::Builder::Module) both use it anyway. 28# 29# use Exporter; 30# use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS); 31# @ISA = ('Exporter'); 32# @EXPORT_OK = qw(findrefs 33# main_iterations 34# warn_suppress_gtk_icon 35# glib_gtk_versions 36# any_signal_connections 37# nowarnings); 38# %EXPORT_TAGS = (all => \@EXPORT_OK); 39 40sub DEBUG { 0 } 41 42 43#----------------------------------------------------------------------------- 44 45{ 46 my $warning_count; 47 my $stacktraces; 48 my $stacktraces_count = 0; 49 sub nowarnings_handler { 50 my ($msg) = @_; 51 # don't error out for cpan alpha version number warnings 52 unless (defined $msg 53 && $msg =~ /^Argument "[0-9._]+" isn't numeric in numeric gt/) { 54 $warning_count++; 55 if ($stacktraces_count < 3 && eval { require Devel::StackTrace }) { 56 $stacktraces_count++; 57 $stacktraces .= "\n" . Devel::StackTrace->new->as_string() . "\n"; 58 } 59 } 60 warn @_; 61 } 62 sub nowarnings { 63 $SIG{'__WARN__'} = \&nowarnings_handler; 64 } 65 END { 66 if ($warning_count) { 67 MyTestHelpers::diag ("Saw $warning_count warning(s):"); 68 if (defined $stacktraces) { 69 MyTestHelpers::diag ($stacktraces); 70 } else { 71 MyTestHelpers::diag('(Devel::StackTrace not available for backtrace)'); 72 } 73 MyTestHelpers::diag ('Exit code 1 for warnings'); 74 $? = 1; 75 } 76 } 77} 78 79sub diag { 80 if (do { local $@; eval { Test::More->can('diag') }}) { 81 Test::More::diag (@_); 82 } else { 83 my $msg = join('', map {defined($_)?$_:'[undef]'} @_)."\n"; 84 $msg =~ s/^/# /mg; 85 print STDERR $msg; 86 } 87} 88 89sub dump { 90 my ($thing) = @_; 91 if (eval { require Data::Dumper; 1 }) { 92 MyTestHelpers::diag (Data::Dumper::Dumper ($thing)); 93 } else { 94 MyTestHelpers::diag ("Data::Dumper not available"); 95 } 96} 97 98#----------------------------------------------------------------------------- 99# Test::Weaken and other weaking 100 101sub findrefs { 102 my ($obj) = @_; 103 defined $obj or return; 104 require Scalar::Util; 105 if (ref $obj && Scalar::Util::reftype($obj) eq 'HASH') { 106 MyTestHelpers::diag ("Keys: ", 107 join(' ', 108 map {"$_=".(defined $obj->{$_} 109 ? "$obj->{$_}" : '[undef]')} 110 keys %$obj)); 111 } 112 if (eval { require Devel::FindRef }) { 113 MyTestHelpers::diag (Devel::FindRef::track($obj, 8)); 114 } else { 115 MyTestHelpers::diag ("Devel::FindRef not available -- ", $@); 116 } 117} 118 119sub test_weaken_show_leaks { 120 my ($leaks) = @_; 121 $leaks || return; 122 123 my $unfreed = $leaks->unfreed_proberefs; 124 my $unfreed_count = scalar(@$unfreed); 125 MyTestHelpers::diag ("Test-Weaken leaks $unfreed_count objects"); 126 MyTestHelpers::dump ($leaks); 127 128 my $proberef; 129 foreach $proberef (@$unfreed) { 130 MyTestHelpers::diag (" unfreed ", $proberef); 131 } 132 foreach $proberef (@$unfreed) { 133 MyTestHelpers::diag ("search ", $proberef); 134 MyTestHelpers::findrefs($proberef); 135 } 136} 137 138#----------------------------------------------------------------------------- 139# Gtk/Glib helpers 140 141# Gtk 2.16 can go into a hard loop on events_pending() / main_iteration_do() 142# if dbus is not running, or something like that. In any case limiting the 143# iterations is good for test safety. 144# 145sub main_iterations { 146 my $count = 0; 147 if (DEBUG) { MyTestHelpers::diag ("main_iterations() ..."); } 148 while (Gtk2->events_pending) { 149 $count++; 150 Gtk2->main_iteration_do (0); 151 152 if ($count >= 500) { 153 MyTestHelpers::diag ("main_iterations(): oops, bailed out after $count events/iterations"); 154 return; 155 } 156 } 157 MyTestHelpers::diag ("main_iterations(): ran $count events/iterations"); 158} 159 160# warn_suppress_gtk_icon() is a $SIG{__WARN__} handler which suppresses spam 161# from Gtk trying to make you buy the hi-colour icon theme. Eg, 162# 163# { 164# local $SIG{'__WARN__'} = \&MyTestHelpers::warn_suppress_gtk_icon; 165# $something = SomeThing->new; 166# } 167# 168sub warn_suppress_gtk_icon { 169 my ($message) = @_; 170 unless ($message =~ /Gtk-WARNING.*icon/ 171 || $message =~ /\Qrecently-used.xbel/ 172 ) { 173 warn @_; 174 } 175} 176 177sub glib_gtk_versions { 178 my $gtk1_loaded = Gtk->can('init'); 179 my $gtk2_loaded = Gtk2->can('init'); 180 my $glib_loaded = Glib->can('get_home_dir'); 181 182 if ($gtk1_loaded) { 183 MyTestHelpers::diag ("Perl-Gtk1 version ",Gtk->VERSION); 184 } 185 if ($gtk2_loaded) { 186 MyTestHelpers::diag ("Perl-Gtk2 version ",Gtk2->VERSION); 187 } 188 if ($glib_loaded) { # when loaded 189 MyTestHelpers::diag ("Perl-Glib version ",Glib->VERSION); 190 MyTestHelpers::diag ("Compiled against Glib version ", 191 Glib::MAJOR_VERSION(), ".", 192 Glib::MINOR_VERSION(), ".", 193 Glib::MICRO_VERSION(), "."); 194 MyTestHelpers::diag ("Running on Glib version ", 195 Glib::major_version(), ".", 196 Glib::minor_version(), ".", 197 Glib::micro_version(), "."); 198 } 199 if ($gtk2_loaded) { 200 MyTestHelpers::diag ("Compiled against Gtk version ", 201 Gtk2::MAJOR_VERSION(), ".", 202 Gtk2::MINOR_VERSION(), ".", 203 Gtk2::MICRO_VERSION(), "."); 204 MyTestHelpers::diag ("Running on Gtk version ", 205 Gtk2::major_version(), ".", 206 Gtk2::minor_version(), ".", 207 Gtk2::micro_version(), "."); 208 } 209 if ($gtk1_loaded) { 210 MyTestHelpers::diag ("Running on Gtk version ", 211 Gtk->major_version(), ".", 212 Gtk->minor_version(), ".", 213 Gtk->micro_version(), "."); 214 } 215} 216 217# Return true if there's any signal handlers connected to $obj. 218# 219# Signal IDs are from 1 up, don't pass 0 to signal_handler_is_connected() 220# since in Glib 2.4.1 it spits out a g_log() error. 221# 222sub any_signal_connections { 223 my ($obj) = @_; 224 my @connected = grep {$obj->signal_handler_is_connected ($_)} (1 .. 500); 225 if (@connected) { 226 my $connected = join(',',@connected); 227 MyTestHelpers::diag ("$obj signal handlers connected: $connected"); 228 return $connected; 229 } 230 return undef; 231} 232 233# wait for $signame to be emitted on $widget, with a timeout 234sub wait_for_event { 235 my ($widget, $signame) = @_; 236 if (DEBUG) { MyTestHelpers::diag ("wait_for_event() $signame on ",$widget); } 237 my $done = 0; 238 my $got_event = 0; 239 my $sig_id = $widget->signal_connect 240 ($signame => sub { 241 if (DEBUG) { MyTestHelpers::diag ("wait_for_event() $signame received"); } 242 $done = 1; 243 return 0; # Gtk2::EVENT_PROPAGATE (new in Gtk2 1.220) 244 }); 245 my $timer_id = Glib::Timeout->add 246 (30_000, # 30 seconds 247 sub { 248 $done = 1; 249 MyTestHelpers::diag ("wait_for_event() oops, timeout waiting for $signame on ",$widget); 250 return 1; # Glib::SOURCE_CONTINUE (new in Glib 1.220) 251 }); 252 if ($widget->can('get_display')) { 253 # display new in Gtk 2.2 254 $widget->get_display->sync; 255 } else { 256 # in Gtk 2.0 gdk_flush() is a sync actually 257 Gtk2::Gdk->flush; 258 } 259 260 my $count = 0; 261 while (! $done) { 262 if (DEBUG >= 2) { MyTestHelpers::diag ("wait_for_event() iteration $count"); } 263 Gtk2->main_iteration; 264 $count++; 265 } 266 MyTestHelpers::diag ("wait_for_event(): '$signame' ran $count events/iterations\n"); 267 268 $widget->signal_handler_disconnect ($sig_id); 269 Glib::Source->remove ($timer_id); 270} 271 272 273#----------------------------------------------------------------------------- 274# X11::Protocol helpers 275 276sub X11_chosen_screen_number { 277 my ($X) = @_; 278 my $i; 279 foreach $i (0 .. $#{$X->{'screens'}}) { 280 if ($X->{'screens'}->[$i]->{'root'} == $X->{'root'}) { 281 return $i; 282 } 283 } 284 die "Oops, current screen not found"; 285} 286 287sub X11_server_info { 288 my ($X) = @_; 289 MyTestHelpers::diag(""); 290 MyTestHelpers::diag("X server info"); 291 MyTestHelpers::diag("vendor: ",$X->{'vendor'}); 292 MyTestHelpers::diag("release_number: ",$X->{'release_number'}); 293 MyTestHelpers::diag("protocol_major_version: ",$X->{'protocol_major_version'}); 294 MyTestHelpers::diag("protocol_minor_version: ",$X->{'protocol_minor_version'}); 295 MyTestHelpers::diag("byte_order: ",$X->{'byte_order'}); 296 MyTestHelpers::diag("num screens: ",scalar(@{$X->{'screens'}})); 297 MyTestHelpers::diag("width_in_pixels: ",$X->{'width_in_pixels'}); 298 MyTestHelpers::diag("height_in_pixels: ",$X->{'height_in_pixels'}); 299 MyTestHelpers::diag("width_in_millimeters: ",$X->{'width_in_millimeters'}); 300 MyTestHelpers::diag("height_in_millimeters: ",$X->{'height_in_millimeters'}); 301 302 MyTestHelpers::diag("root_visual: ",$X->{'root_visual'}); 303 my $visual_info = $X->{'visuals'}->{$X->{'root_visual'}}; 304 MyTestHelpers::diag(" depth: ",$visual_info->{'depth'}); 305 MyTestHelpers::diag(" class: ",$visual_info->{'class'}, 306 ' ', $X->interp('VisualClass', $visual_info->{'class'})); 307 MyTestHelpers::diag(" colormap_entries: ",$visual_info->{'colormap_entries'}); 308 MyTestHelpers::diag(" bits_per_rgb_value: ",$visual_info->{'bits_per_rgb_value'}); 309 MyTestHelpers::diag(" red_mask: ",sprintf('%#X',$visual_info->{'red_mask'})); 310 MyTestHelpers::diag(" green_mask: ",sprintf('%#X',$visual_info->{'green_mask'})); 311 MyTestHelpers::diag(" blue_mask: ",sprintf('%#X',$visual_info->{'blue_mask'})); 312 313 MyTestHelpers::diag("ima"."ge_byte_order: ",$X->{'ima'.'ge_byte_order'}, 314 ' ', $X->interp('Significance', $X->{'ima'.'ge_byte_order'})); 315 MyTestHelpers::diag("black_pixel: ",sprintf('%#X',$X->{'black_pixel'})); 316 MyTestHelpers::diag("white_pixel: ",sprintf('%#X',$X->{'white_pixel'})); 317 foreach (0 .. $#{$X->{'screens'}}) { 318 if ($X->{'screens'}->[$_]->{'root'} == $X->{'root'}) { 319 MyTestHelpers::diag("chosen screen: $_"); 320 } 321 } 322 MyTestHelpers::diag(""); 323} 324 325 1; 326__END__ 327