File Coverage

blib/lib/Gtk2/Ex/SyncCall.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::SyncCall;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2;

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

# version 2 was in with Gtk2-Ex-Dragger ...
our $VERSION = 48;


my $sync_call_atom;

my $get_display = (Gtk2::Widget->can('get_display')
                   ? 'get_display'
                   : do {
                     my $dummy_display = {};
                     sub { $dummy_display }
                   });

sub sync {
  my ($class, $widget, $callback, $userdata) = @_;
  ### SyncCall sync()

  my $display = $widget->$get_display;
  my $data = ($display->{(__PACKAGE__)} ||= do {
    $widget->add_events ('property-change-mask');

    ### widget add_events gives: $widget->window && $widget->window->get_events
    #### window XID: $widget->window && $widget->window->can('XID') && $widget->window->XID

    require Glib::Ex::SignalIds;
    # hash of data
    ({ sync_list => [],
       signal_ids => Glib::Ex::SignalIds->new
       ($widget,
        $widget->signal_connect (property_notify_event =>
                                 \&_do_property_notify),
        $widget->signal_connect (unrealize => \&_do_widget_destroy),
        $widget->signal_connect (destroy   => \&_do_widget_destroy)) })
  });

  $widget = $data->{'signal_ids'}->object;
  my $win = $widget->window
    || croak __PACKAGE__.'->sync(): widget not realized';

  # HACK: in gtk 2.18.4 and 2.18.5 property-change-event's aren't delivered
  # to a non-toplevel widget unless you call $gdkwin->XID on it
  # (ie. gdk_x11_drawable_get_xid()).  This is bizarre and would have to be
  # a bug, but this workaround at least makes SyncCall work (and its
  # dependents like Gtk2::Ex::CrossHair).
  #
  if ($win->can('XID')) { $win->XID; }

  my $self = { display  => $display,
               callback => $callback,
               userdata => $userdata };
  my $aref = $data->{'sync_list'};
  push @$aref, $self;

  if (@$aref == 1) {
    # first entry in sync_list initiates the sync
    $sync_call_atom ||= Gtk2::Gdk::Atom->intern (__PACKAGE__);
    ### property_change of: $sync_call_atom
    $win->property_change ($sync_call_atom,
                           Gtk2::Gdk::Atom->intern('STRING'),
                           Gtk2::Gdk::CHARS, 'append', '');
  }
  return $self;
}

# 'property-notify-event' signal on sync widget
sub _do_property_notify {
  my ($widget, $event) = @_;
  ### SyncCall property-notify handler: $event->atom

  # note, no overloaded != until Gtk2-Perl 1.183, only == prior to that
  if ($event->atom == $sync_call_atom) {
    my $display = $widget->$get_display;
    my $data = $display->{(__PACKAGE__)};
    _call_all ($data);
  }
  # even though $sync_call_atom is supposed to be for us alone, propagate it
  # anyway in case someone else is monitoring what happens
  return 0;  # Gtk2::EVENT_PROPAGATE
}

# 'unrealize' or 'destroy' signal on the sync widget
sub _do_widget_destroy {
  my ($widget) = @_;
  my $display = $widget->$get_display;
  if (my $data = delete $display->{(__PACKAGE__)}) {
    _call_all ($data);
  }
}

sub _call_all {
  my ($data) = @_;
  my $aref = $data->{'sync_list'};
  $data->{'sync_list'} = [];
  foreach my $self (@$aref) {
    $self->{'callback'}->($self->{'userdata'});
  }
}

1;
__END__