File Coverage

blib/lib/Test/Weaken/Gtk2.pm

Criterion	Covered	Total	%
statement	32	82	39.0
branch	6	36	16.6
condition	1	18	5.5
subroutine	11	15	73.3
pod	8	8	100.0
total	58	159	36.4

# Copyright 2008, 2009, 2010, 2011, 2012 Kevin Ryde

# This file is part of Gtk2-Ex-WidgetBits.
#
# Gtk2-Ex-WidgetBits 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.
#
# Gtk2-Ex-WidgetBits 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 Gtk2-Ex-WidgetBits.  If not, see .


package Test::Weaken::Gtk2;
use 5.006;  # for "our" (which Test::Weaken itself uses)
use strict;
use warnings;
use Scalar::Util 'refaddr';

# uncomment this to run the ### lines
#use Smart::Comments;

use Exporter;
our @ISA = ('Exporter');
our @EXPORT_OK = qw(contents_container
                    contents_submenu
                    contents_cell_renderers
                    destructor_destroy
                    destructor_destroy_and_iterate
                    ignore_default_display);

our $VERSION = 48;

sub contents_container {
  my ($ref) = @_;
  require Scalar::Util;
  if (Scalar::Util::blessed($ref)
      && $ref->isa('Gtk2::Container')) {
    return $ref->get_children;
  } else {
    return ();
  }
}

sub contents_submenu {
  my ($ref) = @_;
  require Scalar::Util;
  if (Scalar::Util::blessed($ref)) {
    my $menu;
    if ($ref->isa('Gtk2::MenuItem')) {
      $menu = $ref->get_submenu;
    } elsif ($ref->isa('Gtk2::MenuToolButton')) {
      $menu = $ref->get_menu;
    }
    if (defined $menu) {
      return $menu;
    }
  }
  return ();
}

sub contents_cell_renderers {
  my ($ref) = @_;

  require Scalar::Util;
  Scalar::Util::blessed($ref) || return;
  my $method;
  if ($ref->isa('Gtk2::CellLayout')
      && $ref->can('get_cells')) {  # new in Gtk 2.12
    $method = 'get_cells';

  } elsif ($ref->isa('Gtk2::TreeViewColumn') || $ref->isa('Gtk2::CellView')) {
    # gtk_cell_view_get_cell_renderers() or
    # gtk_tree_view_column_get_cell_renderers() pre-dating the interface
    # style
    $method = 'get_cell_renderers';

  } else {
    return;
  }

  # as of Gtk 2.20.1 GtkCellView tries to set the data into the cells
  # returned by either the get_cells interface or
  # gtk_cell_view_get_cell_renderers().  If there's no display_row set then
  # it throws a g_log.  Suppress that in case we're looking for leaks in an
  # empty CellView or without a display_row.
  #
  my @cells;
  {
    my $old_warn = $SIG{__WARN__};
    local $SIG{__WARN__} = sub {
      my ($str) = @_;
      if (index ($str, 'Gtk-CRITICAL **: gtk_cell_view_set_cell_data: assertion') >= 0) {
        ### Suppressed gtk_cell_view_set_cell_data() assertion failure
        return;
      }
      if ($old_warn) {
        $old_warn->(@_);
      } else {
        warn @_;
      }
    };
    @cells = $ref->$method;
  }

  # Gtk2-Perl 1.221 returns a one-element list of undef if no cells.
  # Prefer to return an empty list for that case.
  if (@cells == 1 && ! defined $cells[0]) {
    @cells = ();
  }
  return @cells;
}

#------------------------------------------------------------------------------
sub destructor_destroy {
  my ($ref) = @_;
  if (ref($ref) eq 'ARRAY') {
    $ref = $ref->[0];
  }
  $ref->destroy;
}

sub destructor_destroy_and_iterate {
  my ($ref) = @_;
  destructor_destroy ($ref);
  _main_iterations();
}

# 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.
#
# FIXME: Not sure how aggressive to be on hitting the maximum count.  If
# testing can likely continue then a diagnostic is enough, but maybe a
# count-out means something too broken to continue.
#
# The iterations count actually run is cute to see to check what has gone
# through the main loop.  Would it be worth giving that always, or under an
# option, or something?
#
sub _main_iterations {
  require Test::More;
  my $count = 0;
  ### _main_iterations() ...
  while (Gtk2->events_pending) {
    $count++;
    Gtk2->main_iteration_do (0);

    if ($count >= 1000) {
      ### _main_iterations() count exceeded: $count
      eval {
        Test::More::diag ("main_iterations(): oops, bailed out after $count events/iterations");
      };
      return;
    }
  }
  ### _main_iterations() events/iterations: $count
}

#------------------------------------------------------------------------------
sub ignore_default_display {
  my ($ref) = @_;

  # Gtk2 loaded, and Gtk 2.2 up
  Gtk2::Gdk::Display->can('get_default') || return 0;

  my $default_display = Gtk2::Gdk::Display->get_default
    || return 0;  # undef until Gtk2 inited

  return (refaddr($ref) == refaddr($default_display));
}

sub ignore_default_screen {
  my ($ref) = @_;

 # Gtk2 loaded, and Gtk 2.2 up
  Gtk2::Gdk::Screen->can('get_default') || return 0;

  my $default_screen = Gtk2::Gdk::Screen->get_default
    || return 0;  # undef until Gtk2 inited

  return (refaddr($ref) == refaddr($default_screen));
}

sub ignore_default_root_window {
  my ($ref) = @_;

  # must have Gtk2 loaded
  Gtk2::Gdk->can('get_default_root_window') or return 0;

  # in Gtk 2.2 up must have default screen from Gtk2->init_check() otherwise
  # Gtk2::Gdk->get_default_root_window() gives a g_log() warning
  if (Gtk2::Gdk::Screen->can('get_default')) {
    Gtk2::Gdk::Screen->get_default || return 0;
  }

  # in Gtk 2.0 get NULL from gdk_get_default_root_window() if no
  # Gtk2->init_check() yet
  my $default_root_window = Gtk2::Gdk->get_default_root_window
    || return 0;

  return (refaddr($ref) == refaddr($default_root_window));
}


#------------------------------------------------------------------------------
1;
__END__