File Coverage

blib/lib/Gtk2/Ex/ActionTooltips.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# 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 Gtk2::Ex::ActionTooltips;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2 1.160; # for $widget->set_tooltip_text new in Gtk2 1.152

our $VERSION = 48;

use Exporter;
our @ISA = ('Exporter');
our @EXPORT_OK = qw(group_tooltips_to_menuitems
                    action_tooltips_to_menuitems_dynamic);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

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

# Cribs:
#
# $action->get_proxies can't be used within a 'connect-proxy' handler until
# Gtk2-Perl 1.220 (due to floating ref handling problems).  That means not
# using group_tooltips_to_menuitems() within connect-proxy until that
# version, though doing so from there would be pretty unusual anyway.
#
# $action->get_tooltip isn't wrapped (gtk_action_get_tooltip()) as of
# Gtk2-Perl 1.220, hence use of $action->get('tooltip').
# $widget->set_tooltip_text is wrapped in 1.160, and will want at least that
# or newer for bug fixes, so may as well use that method instead of the
# 'tooltip-text' property.
#

my $connect_hook_id;
sub _ensure_connect_hook {
  $connect_hook_id ||= Gtk2::ActionGroup->signal_add_emission_hook
    (connect_proxy => \&_do_connect_proxy);
}

sub group_tooltips_to_menuitems {
  Gtk2::Widget->can('set_tooltip_text') || return; # only in Gtk 2.12 up

  foreach my $actiongroup (@_) {
    $actiongroup->{(__PACKAGE__)} = undef;
    _ensure_connect_hook ();

    foreach my $action ($actiongroup->list_actions) {
      _do_action_tooltip ($action);
    }
  }
}

sub action_tooltips_to_menuitems_dynamic {
  Gtk2::Widget->can('set_tooltip_text') || return; # only in Gtk 2.12 up

  foreach my $action (@_) {
    $action->{(__PACKAGE__)} = undef;
    _ensure_connect_hook ();

    $action->signal_connect ('notify::tooltip' => \&_do_action_tooltip);
    _do_action_tooltip ($action);
  }
}

# Gtk2::ActionGroup 'connect-proxy' emission hook handler
sub _do_connect_proxy {
  my ($invocation_hint, $parameters) = @_;
  my ($actiongroup, $action, $widget) = @$parameters;
  ### dynamic connect: ("@{[$action->get_name]} $action onto $widget")

  if ((exists $actiongroup->{(__PACKAGE__)}
       || exists $action->{(__PACKAGE__)})
      && $widget->isa('Gtk2::MenuItem')) {
    $widget->set_tooltip_text ($action->get('tooltip'));
  }
  return 1; # stay connected
}

# Gtk2::Action 'notify::tooltip' signal handler, and called directly
sub _do_action_tooltip {
  my ($action) = @_;
  my $tip = $action->get('tooltip');
  ### tooltip: ["@{[$action->get_name]} $action, tip ", $tip]

  foreach my $widget ($action->get_proxies) {
    ### proxy: $widget
    if ($widget->isa('Gtk2::MenuItem')) {
      $widget->set_tooltip_text ($tip);
    }
  }
}

1;
__END__