view release on metacpan or  search on metacpan

t/MyTestHelpers.pm  view on Meta::CPAN

    }
    warn @_;
  }
  sub nowarnings {
    $SIG{'__WARN__'} = \&nowarnings_handler;
  }
  END {
    if ($warning_count) {
      MyTestHelpers::diag ("Saw $warning_count warning(s):");
      if (defined $stacktraces) {
        MyTestHelpers::diag ($stacktraces);
      } else {
        MyTestHelpers::diag('(Devel::StackTrace not available for backtrace)');
      }
      MyTestHelpers::diag ('Exit code 1 for warnings');
      $? = 1;
    }
  }
}

sub diag {
  if (do { local $@; eval { Test::More->can('diag') }}) {
    Test::More::diag (@_);
  } else {
    my $msg = join('', map {defined($_)?$_:'[undef]'} @_)."\n";
    $msg =~ s/^/# /mg;
    print STDERR $msg;
  }
}

sub dump {
  my ($thing) = @_;
  if (eval { require Data::Dumper; 1 }) {
    MyTestHelpers::diag (Data::Dumper::Dumper ($thing));
  } else {
    MyTestHelpers::diag ("Data::Dumper not available");
  }
}

#-----------------------------------------------------------------------------
# Test::Weaken and other weaking

sub findrefs {
  my ($obj) = @_;
  defined $obj or return;
  require Scalar::Util;
  if (ref $obj && Scalar::Util::reftype($obj) eq 'HASH') {
    MyTestHelpers::diag ("Keys: ",
                         join(' ',
                              map {"$_=".(defined $obj->{$_}
                                          ? "$obj->{$_}" : '[undef]')}
                              keys %$obj));
  }
  if (eval { require Devel::FindRef }) {
    MyTestHelpers::diag (Devel::FindRef::track($obj, 8));
  } else {
    MyTestHelpers::diag ("Devel::FindRef not available -- ", $@);
  }
}

sub test_weaken_show_leaks {
  my ($leaks) = @_;
  $leaks || return;

  my $unfreed = $leaks->unfreed_proberefs;
  my $unfreed_count = scalar(@$unfreed);
  MyTestHelpers::diag ("Test-Weaken leaks $unfreed_count objects");
  MyTestHelpers::dump ($leaks);

  my $proberef;
  foreach $proberef (@$unfreed) {
    MyTestHelpers::diag ("  unfreed ", $proberef);
  }
  foreach $proberef (@$unfreed) {
    MyTestHelpers::diag ("search ", $proberef);
    MyTestHelpers::findrefs($proberef);
  }
}

#-----------------------------------------------------------------------------
# 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 {
  my $count = 0;
  if (DEBUG) { MyTestHelpers::diag ("main_iterations() ..."); }
  while (Gtk2->events_pending) {
    $count++;
    Gtk2->main_iteration_do (0);

    if ($count >= 500) {
      MyTestHelpers::diag ("main_iterations(): oops, bailed out after $count events/iterations");
      return;
    }
  }
  MyTestHelpers::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/
         || $message =~ /\Qrecently-used.xbel/
         ) {
    warn @_;
  }
}

sub glib_gtk_versions {
  my $gtk1_loaded = Gtk->can('init');
  my $gtk2_loaded = Gtk2->can('init');