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