File Coverage

blib/lib/Gtk2/Ex/WidgetEvents.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

# Copyright 2007, 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::WidgetEvents;
use 5.008;
use strict;
use warnings;
use Carp;
use Scalar::Util 'refaddr', 'weaken';

use Gtk2 1.183;  # for Glib::Flags->new and overloaded !=
use Glib::Ex::SignalIds;

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

our $VERSION = 48;


# The following fields are hung on a target widget,
#
# Gtk2::Ex::WidgetEvents.obj_hash
#     Hashref of WidgetEvents instances targeting this widget, in the form
#     refaddr($wevents_obj) => $wevents_obj.  Values are weakened.  Entries
#     are removed by WidgetEvents DESTROY, including the whole field removed
#     when the last WidgetEvents on the widget is gone.
#
# Gtk2::Ex::WidgetEvents.signal_ids
#     A Glib::Ex::SignalIds object for the 'realize' signal calling
#     _do_widget_realize().  Removed and disconnected by DESTROY of the last
#     WidgetEvents object on the widget.
#
# Gtk2::Ex::WidgetEvents.base_events
#
# Gtk2::Ex::WidgetEvents.last_win_events
#
#
# The various methods taking events as parameters have arg count checks to
# protect against something like $wevents->add('foo','bar') expecting both
# those events added.  It should instead be a single flags parameter
# arrayref like $wevents->add(['foo','bar']).  It'd be possible to relax and
# accept the former, but everywhere else in Gtk2-Perl demands a single arg
# for flags, so don't want to encourage laziness in that area.


sub new {
  my ($class, $widget, $events) = @_;
  ### WidgetEvents new: "$widget"

  if (@_ != 2 && @_ != 3) {
    croak 'WidgetEvents->new(): one or two arguments expected';
  }

  # coerce to flags object
  if (@_ == 2) { $events = []; } # if arg omitted
  $events = Gtk2::Gdk::EventMask->new ($events);

  my $self = bless { widget => $widget,
                     events => $events }, $class;
  weaken ($self->{'widget'});

  # one 'realize' handler per widget
  $widget->{__PACKAGE__.'.signal_ids'} ||= do {
    # X server query for the base events when first acting on this widget
    # and already realized
    if (my $win = $widget->window) {
      $widget->{__PACKAGE__.'.base_events'} = $win->get_events;
    }
    Glib::Ex::SignalIds->new
        ($widget, $widget->signal_connect (realize => \&_do_widget_realize))
      };

  # autovivify 'obj_hash'
  weaken ($widget->{__PACKAGE__.'.obj_hash'}->{refaddr($self)}
          = $self);

  _update_widget ($widget);
  return $self;
}

sub add {
  if (@_ != 2) { croak 'WidgetEvents->add(): one argument expected'; }
  my ($self, $events) = @_;
  my $old_events = $self->{'events'};
  if (($self->{'events'} += $events) != $old_events) {
    _update_widget ($self->{'widget'});
  }
}
sub remove {
  if (@_ != 2) { croak 'WidgetEvents->remove(): one argument expected'; }
  my ($self, $events) = @_;
  my $old_events = $self->{'events'};
  if (($self->{'events'} -= $events) != $old_events) {
    _update_widget ($self->{'widget'});
  }
}

sub DESTROY {
  my ($self) = @_;
  ### WidgetEvents DESTROY
  my $widget = $self->{'widget'} || return;  # possible weakening

  my $href = $widget->{__PACKAGE__.'.obj_hash'};
  delete $href->{refaddr($self)};

  _update_widget ($widget);  # new event mask

  # when the last WidgetEvents goes away on $widget remove fields
  # except keep base_events permanently (is that a good idea?)
  #
  ### down to count on widget: scalar(%$href)
  if (! %$href) {
    delete @{$widget}{__PACKAGE__.'.signal_ids',
                        __PACKAGE__.'.last_win_events',
                          __PACKAGE__.'.obj_hash'};   # hash slice
    # __PACKAGE__.'.base_events',
  }
}

# 'realize' signal handler
sub _do_widget_realize {
  my ($widget) = @_;
  ### WidgetEvents realize: "$widget"

  if (defined (my $base_events = $widget->{__PACKAGE__.'.base_events'})) {
    $widget->{__PACKAGE__.'.last_win_events'} = $base_events;
  }
  _update_widget ($widget);
}

sub _update_widget {
  my ($widget) = @_;
  if (! $widget) { return; } # possible weakening
  ### WidgetEvents update: "$widget"

  my $win = $widget->window || return;  # nothing to do until realized

  my $base_events = $widget->{__PACKAGE__.'.base_events'};
  if (! defined $base_events) {
    $base_events
      = $widget->{__PACKAGE__.'.last_win_events'}
        = $widget->{__PACKAGE__.'.base_events'}
          = $win->get_events;  # X server round-trip

    ### establish base_events: "$base_events"
  }

  my $want_events = $base_events + $widget->get_events;
  foreach my $obj (values %{$widget->{__PACKAGE__.'.obj_hash'}}) {
    if (defined $obj) {  # possible weakening
      $want_events += $obj->{'events'};
    }
  }

  my $last_win_events = $widget->{__PACKAGE__.'.last_win_events'};
  if (! defined $last_win_events) {
    $last_win_events = $widget->{__PACKAGE__.'.last_win_events'}
      = $win->get_events;  # X server round-trip
  }

  if ($want_events != $last_win_events) {
    $widget->{__PACKAGE__.'.last_win_events'} = $want_events;
    $win->set_events ($want_events);  # XSelectInput to server

    ### install: "@{[$win->get_events]}"
    ### which adds:  "@{[$win->get_events - $last_win_events]}"
    ### and removes: "@{[$last_win_events - $win->get_events]}"
  }
}

1;
__END__