view release on metacpan or  search on metacpan

t/WidgetCursor.t  view on Meta::CPAN

             \@want,
             '_container_recursively - ok on very deep nesting');
}

#-----------------------------------------------------------------------------

# return true if two Glib::Boxed objects $b1 and $b2 point to the same
# underlying C object
sub glib_boxed_equal {
  my ($b1, $b2) = @_;
  my $pspec = Glib::ParamSpec->boxed ('equal', 'equal', 'blurb', ref($b1),
                                      Glib::G_PARAM_READWRITE());
  if ($pspec->can('values_cmp')) {
    # new in Perl-Glib 1.220
    return $pspec->values_cmp($b1,$b2) == 0;
  } else {
    return 1;
  }
}

my $have_blank_cursor = scalar grep {$_->{'nick'} eq 'blank-cursor'}
  Glib::Type->list_values('Gtk2::Gdk::CursorType');
diag "have_blank_cursor is $have_blank_cursor";


# In Perl-Gtk2 before 1.183, passing undef, ie. NULL, to
# Gtk2::Gdk::Display->open() prints warnings, so do it with an actual
# $display_name string.
#
my $default_display = Gtk2::Gdk::Display->get_default;
my $display_name = $default_display->get_name;

# invisible cursor type
{
  my $cursor = Gtk2::Ex::WidgetCursor->invisible_cursor;
  is ($cursor->type,
      ($have_blank_cursor ? 'blank-cursor' : 'cursor-is-pixmap'),
      'invisible cursor type (blank or pixmap as available)');
}

# In the current code this ends up depending on
# gdk_cursor_new_for_display() to cache 'blank-cursor'.  Want to know if
# it doesn't, since the WidgetCursor docs claim invisible_cursor() caches.
#
ok (glib_boxed_equal (Gtk2::Ex::WidgetCursor->invisible_cursor,
                      Gtk2::Ex::WidgetCursor->invisible_cursor),
    'invisible_cursor() object same on two calls');

# different invisible object on different displays
SKIP: {
  my $d1 = $default_display;
  my $d2 = Gtk2::Gdk::Display->open ($display_name);
  if ($d1 == $d2) {
    skip 'due to only one GdkDisplay available', 1;
  }
  my $c1 = Gtk2::Ex::WidgetCursor->invisible_cursor ($d1);
  my $c2 = Gtk2::Ex::WidgetCursor->invisible_cursor ($d2);
  isnt ($c1, $c2, 'invisible_cursor() different on different displays');
}

# an invisible cursor hung on a display doesn't keep that object alive
# forever
#
# Crib note: must destroy the cursor object before destroying the display
# object (either closed or still open), since in Gtk 2.22 the cursor object
# doesn't seem to hold a ref to the display object and bad things happen on
# using the cursor after the display is gone.
#
# For the code here the cursor obj is weak here and hard in $d->{'_invis'}.
# The destroy of those $d fields seems to happen soon enough during the
# destroy of $d to work -- as long as you don't hold a hard ref to $c
# anywhere else.
#
SKIP: {
  require Scalar::Util;
  my $d = Gtk2::Gdk::Display->open ($display_name);
  if ($d == $default_display) {
    skip 'due to only one GdkDisplay available', 1;
  }
  my $c = Gtk2::Ex::WidgetCursor->invisible_cursor ($d);
  Scalar::Util::weaken ($c);
  $d->close;
  Scalar::Util::weaken ($d);
  is ($d, undef, 'display weakened away');
  is ($c, undef, 'invisible_cursor() weakened away with display');
}


# WidgetCursor should be garbage collected
{
  diag "gc";
  my $widget = Gtk2::Label->new ('hi');
  my $wobj = Gtk2::Ex::WidgetCursor->new (widget => $widget);
  Scalar::Util::weaken ($wobj);
  is ($wobj, undef, 'inactive - garbage collect');

  ok (! MyTestHelpers::any_signal_connections($widget),
      'inactive - no leftover signal connections on widget');
  is_deeply (leftover_fields($widget), [],
             'inactive - no leftover fields on widget');
}

# WidgetCursor should be garbage collected when active
{
  diag "gc when active";
  my $widget = Gtk2::Label->new ('hi');
  my $wobj = Gtk2::Ex::WidgetCursor->new (widget => $widget,
                                          active => 1);
  Scalar::Util::weaken ($wobj);
  is ($wobj, undef, 'active - garbage collect');

  ok (! MyTestHelpers::any_signal_connections($widget),
      'active - no leftover signal connections on widget');
  is_deeply (leftover_fields($widget), [],
             'active - no leftover fields on widget');
}

# two WidgetCursors should be garbage collected
{
  my $widget = Gtk2::Label->new ('hi');
  my $wobj1 = Gtk2::Ex::WidgetCursor->new (widget => $widget);
  my $wobj2 = Gtk2::Ex::WidgetCursor->new (widget => $widget);
  Scalar::Util::weaken ($wobj1);
  Scalar::Util::weaken ($wobj2);
  is ($wobj1, undef);
  is ($wobj2, undef);
}

# WidgetCursor on a realized widget should be garbage collected
{
  my $widget = Gtk2::Window->new ('toplevel');
  $widget->show;
  my $wobj = Gtk2::Ex::WidgetCursor->new (widget => $widget);
  Scalar::Util::weaken ($wobj);
  is ($wobj, undef);
}

# WidgetCursor doesn't keep widget alive forever
{
  my $widget = Gtk2::Label->new ('hi');
  my $wobj = Gtk2::Ex::WidgetCursor->new (widget => $widget);
  Scalar::Util::weaken ($widget);
  is ($widget, undef);
  if ($widget) {
    MyTestHelpers::findrefs($widget);
  }
}

# WidgetCursor doesn't keep widgets array alive forever
{
  my $widget1 = Gtk2::Label->new ('hi');
  my $widget2 = Gtk2::Label->new ('bye');
  my $aref = [$widget1, $widget2];
  my $wobj = Gtk2::Ex::WidgetCursor->new (widgets => $aref);

  Scalar::Util::weaken ($aref);
  is ($aref, undef);

  Scalar::Util::weaken ($widget1);
  is ($widget1, undef);

  Scalar::Util::weaken ($widget2);
  is ($widget2, undef);
}

# WidgetCursor add_widgets doesn't keep widget alive forever
{
  my $widget = Gtk2::Label->new ('hi');
  my $wobj = Gtk2::Ex::WidgetCursor->new;
  $wobj->add_widgets ($widget);
  Scalar::Util::weaken ($widget);
  is ($widget, undef);
}

# add_widgets with weakened undefs in wobj
{
  my $widget = Gtk2::Label->new ('hi');
  my $wobj = Gtk2::Ex::WidgetCursor->new (widgets => [ $widget ]);
  $widget = Gtk2::Label->new ('bye');
  $wobj->add_widgets ($widget);
}

# GtkButton when unrealized
{
  my $widget = Gtk2::Button->new;
  my @windows = grep {defined} $widget->Gtk2_Ex_WidgetCursor_windows;
  is_deeply (\@windows, [], ref($widget).' no window when unrealized');
}

# GtkTextView when unrealized
{
  my $widget = Gtk2::TextView->new;
  my @windows = grep {defined} $widget->Gtk2_Ex_WidgetCursor_windows;
  is_deeply (\@windows, [], ref($widget).' no window when unrealized');
}

# GtkEntry when unrealized
{
  my $widget = Gtk2::Entry->new;
  my @windows = grep {defined} $widget->Gtk2_Ex_WidgetCursor_windows;
  is_deeply (\@windows, [], ref($widget).' no window when unrealized');
}

# GtkSpinButton when unrealized
{
  my $adj = Gtk2::Adjustment->new (0, -100, 100, 1, 10, 0);
  my $widget = Gtk2::SpinButton->new ($adj, 10, 0);
  my @windows = grep {defined} $widget->Gtk2_Ex_WidgetCursor_windows;
  is_deeply (\@windows, [], ref($widget).' no window when unrealized');
}

#------------------------------------------------------------------------------
# cursor properties

{
  my $wcursor = Gtk2::Ex::WidgetCursor->new;
  my %notifies;
  $wcursor->signal_connect (notify => sub {
                              my ($wcursor, $pspec) = @_;
                              $notifies{$pspec->get_name} = 1;
                            });

  # claimed defaults
  is ($wcursor->get('cursor'), undef, 'cursor - default');
  is ($wcursor->get('cursor-name'), undef, 'cursor-name - default');
  is ($wcursor->get('cursor-object'), undef, 'cursor-object - default');