File Coverage

blib/lib/Gtk2/Ex/Dragger.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 Kevin Ryde

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

package Gtk2::Ex::Dragger;
use 5.008;
use strict;
use warnings;
use Carp;
use POSIX ();
use Glib 1.220; # 1.220 for Glib::SOURCE_REMOVE
use Gtk2 1.220; # 1.220 for Gtk2::EVENT_PROPAGATE
use List::Util qw(min max);
use Scalar::Util;

use Glib::Ex::SignalIds;
use Gtk2::Ex::WidgetEvents;

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

our $VERSION = 10;

use constant DELAY_MILLISECONDS => 250;

BEGIN {
  Glib::Type->register_enum ('Gtk2::Ex::Dragger::UpdatePolicy',
                             'default',
                             'continuous',
                             'delayed',
                             'discontinuous',
                            );
}

use Glib::Object::Subclass
  'Glib::Object',
  properties => [ Glib::ParamSpec->object
                  ('widget',
                   'Target widget',
                   'The target widget whose contents are to be moved around.  (For a widget inside a Gtk2::ViewPort this property should be the ViewPort.)',
                   'Gtk2::Widget',
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->object
                  ('hadjustment',
                   (do {
                     my $str = 'Horizontal adjustment';
                     # translation if available
                     eval { require Locale::Messages;
                            Locale::Messages::dgettext('gtk20-properties',$str)
                            } || $str }),
                   'Horizontal adjustment to change, or undef for no horizontal drag.',
                   'Gtk2::Adjustment',
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->object
                  ('vadjustment',
                   (do {
                     my $str = 'Vertical adjustment';
                     # translation if available
                     eval { require Locale::Messages;
                            Locale::Messages::dgettext('gtk20-properties',$str)
                            } || $str }),
                   'Vertical adjustment to change, or undef for no vertical drag.',
                   'Gtk2::Adjustment',
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->boolean
                  ('hinverted',
                   'Horizontal inverted',
                   'Whether to invert horizontal movement, for hadjustment valuess increasing to the left (ie. decreasing X coordinate).',
                   0, # default no
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->boolean
                  ('vinverted',
                   'Vertical inverted',
                   'Whether to invert vertical movement, for vadjustment values increasing up the screen (ie. decreasing Y coordinate).',
                   0, # default no
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->boolean
                  ('confine',
                   'Confine pointer',
                   'Confine the mouse pointer to the draggable extent per upper/lower range of the adjustments.',
                   0, # default no
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->enum
                  ('update-policy',
                   'Update policy',
                   'How often to update the hadjustment and vadjustment objects for drag movement.',
                   'Gtk2::Ex::Dragger::UpdatePolicy',
                   'default',
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->scalar
                  ('cursor',
                   'Cursor',
                   'Cursor to show while dragging, as any name or object accepted by Gtk2::Ex::WidgetCursor.',
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->string
                  ('cursor-name',
                   'Cursor name',
                   'Cursor to show while dragging, as cursor type enum nick, or "invisible".',
                   (eval {Glib->VERSION(1.240);1}
                    ? undef # default
                    : ''),  # no undef/NULL before Perl-Glib 1.240
                   Glib::G_PARAM_READWRITE),

                  Glib::ParamSpec->boxed
                  ('cursor-object',
                   'Cursor object',
                   'Cursor to show while dragging, as cursor object.',
                   'Gtk2::Gdk::Cursor',
                   Glib::G_PARAM_READWRITE),

                ];

sub INIT_INSTANCE {
  my ($self) = @_;
  $self->{'h'} = {};
  $self->{'v'} = {};
}

sub FINALIZE_INSTANCE {
  my ($self) = @_;
  $self->stop;
}

sub GET_PROPERTY {
  my ($self, $pspec) = @_;
  my $pname = $pspec->get_name;
  ### Dragger GET_PROPERTY(): $pname

  if ($pname eq 'cursor_name') {
    my $cursor = $self->{'cursor'};
    if (Scalar::Util::blessed($cursor)) {
      $cursor = $cursor->type;
      # think prefer undef over cursor-is-pixmap for the get()
      if ($cursor eq 'cursor-is-pixmap') {
        undef $cursor;
      }
    }
    return $cursor;
  }
  if ($pname eq 'cursor_object') {
    my $cursor = $self->{'cursor'};
    return (Scalar::Util::blessed($cursor)
            && $cursor->isa('Gtk2::Gdk::Cursor')
            && $cursor);
  }

  return $self->{$pname};
}

sub SET_PROPERTY {
  my ($self, $pspec, $newval) = @_;
  ### Dragger SET_PROPERTY(): $pspec->get_name
  my $pname = $pspec->get_name;

  my $pname_is_cursor = ($pname =~ s/^(cursor).*/$1/);
  my $oldval = $self->{$pname};
  $self->{$pname} = $newval;

  if ($pname_is_cursor) {
    # copy boxed GdkCursor in case the caller frees it, and in particular
    # for $pname eq 'cursor_object' it might be freed immediately by the
    # GValue call-out stuff
    # if (blessed($newval) && $newval->isa('Gtk2::Gdk::Cursor')) {
    #   $self->{$pname} = $newval->copy;
    # }
    _widget_cursor($self);
    $self->notify('cursor');
    $self->notify('cursor-name');
    $self->notify('cursor-object');

  } elsif ($pname eq 'widget') {
    my $widget = $newval;
    if (! $newval
        || ($oldval && $newval != $oldval)) {
      # ENHANCE-ME: might be able to switch to an active grab on the new
      # widget and continue
      $self->stop;
    }
    if ($widget) {
      Scalar::Util::weaken ($self->{'widget'});
    }
    $self->{'wevents'} = $widget && Gtk2::Ex::WidgetEvents->new
      ($widget, ['button-press-mask',
                 'button-motion-mask',
                 'button-release-mask']);
    _widget_signals($self);

  } elsif ($pname =~ /([hv])(adjustment|inverted)/) {
    my $axis = $self->{$1};
    my $field = $2;
    $axis->{$field} = $newval;

    if ($field eq 'adjustment') {
      $axis->{'last_value'} = $newval && $newval->value;
      _axis_signals($self,$axis);
      _do_adjustment_changed ($newval, \$self);
    }

  } elsif ($pname eq 'confine') {
    _resize_confine_win ($self);
  }
}

# create or update WidgetCursor according to $self->{'cursor'}
# doesn't load WidgetCursor until drag active
sub _widget_cursor {
  my ($self) = @_;
  $self->{'wcursor'} = ($self->{'active'}
                        && $self->{'cursor'}
                        && do {
                          require Gtk2::Ex::WidgetCursor;
                          Gtk2::Ex::WidgetCursor->new
                              (widget => $self->{'widget'},
                               cursor => $self->{'cursor'},
                               active => 1);
                        });
}

# update $self->{'h'}->{'adjustment_ids'} or $self->{'v'}->... signal handlers
# handlers only applied while 'active'
sub _axis_signals {
  my ($self, $axis) = @_;
  my $adj;
  $axis->{'adjustment_ids'} =
    ($self->{'active'}
     && ($adj = $axis->{'adjustment'})
     && do {
       my $ref_weak_self = _ref_weak ($self);

       ### _axis_signals() connect
       Glib::Ex::SignalIds->new
           ($adj,
            $adj->signal_connect (changed => \&_do_adjustment_changed,
                                  $ref_weak_self),
            $adj->signal_connect (value_changed => \&_do_adjustment_value_changed,
                                  $ref_weak_self))
         });
}

# make signal handler connections on $self->{'widget'} if active
sub _widget_signals {
  my ($self) = @_;
  my $widget;
  $self->{'widget_ids'} =
    ($self->{'active'}
     && ($widget = $self->{'widget'})
     && do {
       my $ref_weak_self = _ref_weak ($self);

       ### _widget_signals() connect
       Glib::Ex::SignalIds->new
           ($widget,
            $widget->signal_connect (motion_notify_event => \&_do_motion_notify,
                                     $ref_weak_self),
            $widget->signal_connect (button_release_event => \&_do_button_release,
                                     $ref_weak_self),
            $widget->signal_connect (configure_event => \&_do_configure_event,
                                     $ref_weak_self),
            $widget->signal_connect (grab_broken_event => \&_do_grab_broken,
                                     $ref_weak_self))
         });
}

sub start {
  my ($self, $event) = @_;
  ### Dragger start()

  # maybe a second start() call could transition to a different button, but
  # for now disallow it
  if ($self->{'active'}) {
    croak __PACKAGE__.'->start(): drag already active';
  }
  (Scalar::Util::blessed($event) && $event->isa('Gtk2::Gdk::Event::Button'))
    or croak __PACKAGE__.'->start(): must have button press event';

  my $widget = $self->{'widget'};
  my $win = $widget->Gtk2_Ex_Dragger_window
    or croak __PACKAGE__.'->start(): widget not realized';

  $self->{'active'} = 1;
  _widget_cursor($self);
  _widget_signals($self);

  foreach my $axis ($self->{'h'}, $self->{'v'}) {
    my $adj = $axis->{'adjustment'} or next;
    $axis->{'unapplied'} = 0;
    $axis->{'pending'} = 0;
    $axis->{'last_value'} = $adj->value;
    _axis_signals ($self, $axis);
  }

  $self->{'button'} = $event->button;
  ($self->{'h'}->{'last_pixel'}, $self->{'v'}->{'last_pixel'})
    = $event->get_root_coords;

  if ($self->{'confine'}) {
    my $confine_win = ($self->{'confine_win'} ||= Gtk2::Gdk::Window->new
                       ($widget->get_root_window,
                        { window_type       => 'temp',
                          wclass            => 'GDK_INPUT_ONLY',
                          override_redirect => 1 }));
    ### confine_win: "$confine_win"
    _resize_confine_win ($self);
    $confine_win->show;

    # ENHANCE-ME: $win->get_events is a server round-trip, maybe fetch only
    # the first time, or fetch once and then mask in the widget 'events'
    # property subsequently; or something cooperating with WidgetEvents ...
    #
    ### widget events: $widget->get_events.''
    ### window events: $widget->window->get_events.''
    my $event_mask
      = ($win->get_events & ['button-press-mask',
                             'pointer-motion-hint-mask',
                             'structure-mask',
                             'property-change-mask' ])
        + ['button-motion-mask', 'button-release-mask'];
    ### events: "$event_mask"
    ### grab to           : $widget->window.''
    ### cf button press on: $event->window.''
    ### cf size win       : "$win"

    my $status = Gtk2::Gdk->pointer_grab ($widget->window,
                                          0,      # owner events
                                          $event_mask,
                                          $confine_win,
                                          undef,  # cursor inherited
                                          $event->time);
    ### grab: "$status time ".$event->time
    if ($status eq 'success') {
      $self->{'grabbed'} = 1;
    } else {
      carp __PACKAGE__."->start(): cannot grab: $status";
    }
  }
}

# 'grab-broken-event' signal on the target widget
#
# This event is a client-side invention of gdk, we listen to it to know when
# gdk's grab tracking says we lost the grab due to a window unmap or another
# grab by a different part of the program.  This (almost certainly) means we
# should stop dragging.
#
# Gtk2::Gdk->pointer_grab() above will itself enqueue a grab broken event if
# the $widget->window we supply there is different from the one the implicit
# grab of the button press was in.  That can happen when there's multiple
# GdkWindows within $widget, with all of their events dispatched to $widget.
# For example if you put a no-window child into a Gtk2::Viewport then a
# button press on it goes to the "view_window" sub-window of the Viewport,
# which is the large moving subwindow of $widget->window (in fact
# sub-sub-window, since there's a "bin_window" in between too).
#
# The code here checks if $event->window is our pointer_grab()
# $widget->window losing the grab.  (A pointer_grab() call asking for the
# same window as currently holding the grab doesn't produce a grab broken
# event, so that test is safe against a button press and grab to the same
# child window.)
#
# It'd also be possible to look at $event->grab_window to see who has the
# current grab window, to see if it's our desired $widget->window.  That'd
# be a kind of more positive test, but $event->grab_window is not wrapped
# until Gtk2-Perl 1.190.
#
sub _do_grab_broken {
  my ($widget, $event, $ref_weak_self) = @_;
  my $self = $$ref_weak_self || return Gtk2::EVENT_PROPAGATE;
  ### Dragger _do_grab_broken()
  ### event window : $event->window.''
  ### widget window: $widget->window.''

  if ($self->{'grabbed'} && $event->window == $widget->window) {
    $self->{'grabbed'} = 0;
    $self->stop ($event);
  }
  return Gtk2::EVENT_PROPAGATE;
}

# 'button-release-event' signal on the target widget
sub _do_button_release {
  my ($widget, $event, $ref_weak_self) = @_;
  ### Dragger _do_button_release()
  my $self = $$ref_weak_self || return Gtk2::EVENT_PROPAGATE;

  if ($event->button == $self->{'button'}) {
    _do_motion_notify ($widget, $event, \$self); # final position
    $self->stop ($event);
  }
  return Gtk2::EVENT_PROPAGATE;
}

sub stop {
  my ($self, $event) = @_;
  ### Dragger stop()

  if (! delete $self->{'active'}) { return; }

  if (delete $self->{'grabbed'}) {
    Gtk2::Gdk->pointer_ungrab (defined $event
                               ? $event->time : Gtk2::GDK_CURRENT_TIME);
  }
  if (my $confine_win = $self->{'confine_win'}) {
    $confine_win->hide;
  }
  if (my $id = delete $self->{'idle_id'}) {
    Glib::Source->remove ($id);
  }
  if (my $id = delete $self->{'timer_id'}) {
    Glib::Source->remove ($id);
  }
  delete $self->{'widget_ids'};
  delete $self->{'wcursor'};
  delete $self->{'h'}->{'adjustment_ids'};
  delete $self->{'v'}->{'adjustment_ids'};
  _emit_pending ($self);
}

# 'configure-event' signal on the target widget
sub _do_configure_event {
  my ($widget, $event, $ref_weak_self) = @_;
  my $self = $$ref_weak_self || return Gtk2::EVENT_PROPAGATE;

  # new window size changes the scale factor and hence how many pixels to
  # the adjustable limits
  _resize_confine_win ($self);
  return Gtk2::EVENT_PROPAGATE;
}

# 'changed' signal on either hadjustment or vadjustment
sub _do_adjustment_changed {
  my ($adj, $ref_weak_self) = @_;
  my $self = $$ref_weak_self || return;
  ### Dragger _do_adjustment_changed(): "$adj"

  # new page size changes the scale factor and hence how many pixels to the
  # adjustable limits
  _resize_confine_win ($self);
}

# 'value-changed' signal on either hadjustment or vadjustment
#
# If the value we see is what we set then no action.  If it's something
# different then it's a change made by the keyboard or something else
# external.
#
# We must reset any 'unapplied' amount because we can't have a non-zero
# unapplied when the value is somewhere not at the upper or lower limits,
# because unapplied is essentially how far beyond those limits the mouse is.
# (The effect of leaving an 'unapplied' is for the value to jump down or up
# unnaturally on the next drag update.)
#
sub _do_adjustment_value_changed {
  my ($adj, $ref_weak_self) = @_;
  my $self = $$ref_weak_self || return;
  my $axis = ($adj == ($self->{'h'}->{'adjustment'} || 0)
              ? $self->{'h'}
              : $self->{'v'});

  if ($adj->value == $axis->{'last_value'}) { return; }

  ### Dragger value changed externally to: $adj->value
  $axis->{'last_value'} = $axis->{'adjustment'}->value;
  $axis->{'unapplied'} = 0;

  # new positions for the limits relative to the mouse position
  _resize_confine_win ($self);
}

sub _resize_confine_win {
  my ($self) = @_;
  my $confine_win = $self->{'confine_win'} || return;

  my $widget = $self->{'widget'};
  my $win = $widget->Gtk2_Ex_Dragger_window;
  my ($win_width, $win_height) = $win->get_size;

  my $root = $widget->get_root_window;
  my ($root_width, $root_height) = $root->get_size;

  # default full root window, no confine
  my $confine_x = 0;
  my $confine_y = 0;
  my $confine_width = $root_width;
  my $confine_height = $root_height;

  # The x position is so a move that far to the left would hit the limit of
  # the adjustment.  For normal direction a mouse move to the left increases
  # adjustment value, so look at how far "value" is from "upper - page".
  # For inverted a move to the left decreases adjustment value, so look at
  # how far "value" is from "lower".
  #
  if (my $hadj = $self->{'h'}->{'adjustment'}) {
    if (my $page_size = $hadj->page_size) {
      $confine_x = $self->{'h'}->{'last_pixel'} -
        ($win_width / $page_size)
          * ($self->{'h'}->{'inverted'}
             ? $hadj->value - $hadj->lower
             : $hadj->upper - $hadj->page_size - $hadj->value);
      $confine_width = $win_width
        * ($hadj->upper - $hadj->lower - $hadj->page_size) / $hadj->page_size;
    }
  }
  if (my $vadj = $self->{'v'}->{'adjustment'}) {
    if (my $page_size = $vadj->page_size) {
      $confine_y = $self->{'v'}->{'last_pixel'} -
        ($win_height / $page_size)
          * ($self->{'v'}->{'inverted'}
             ? $vadj->value - $vadj->lower
             : $vadj->upper - $vadj->page_size - $vadj->value);
      $confine_height = $win_height
        * ($vadj->upper - $vadj->lower - $vadj->page_size) / $vadj->page_size;
    }
  }

  # round x,y down to integers, increasing width,height by what's subtracted
  {
    my $frac;
    ($confine_x, $frac) = _floor_and_frac ($confine_x);
    $confine_width += $frac;
    ($confine_y, $frac) = _floor_and_frac ($confine_y);
    $confine_height += $frac;
  }

  # round up width,height to integers
  $confine_width  = POSIX::ceil ($confine_width);
  $confine_height = POSIX::ceil ($confine_height);

  # allow an extra pixel left,right,top and bottom just in case the rounding
  # is a bit off, or whatever
  $confine_x--;
  $confine_y--;
  $confine_width += 2;
  $confine_height += 2;

  # Bring any negative top-left X,Y into range of the screen.  This is in
  # case X,Y are big negatives that overflow the signed 16-bit value in the
  # X protocol.
  if ($confine_x < 0) {
    $confine_width += $confine_x;  # reduce width accordingly
    $confine_x = 0;
  }
  if ($confine_y < 0) {
    $confine_height += $confine_y;  # reduce height accordingly
    $confine_y = 0;
  }

  # If the X,Y position is off the right or bottom of the screen then go to
  # a single pixel at that right or bottom.  Suspect this shouldn't occur,
  # because the confine window will contain the current mouse position, and
  # that's certainly somewhere on-screen.
  #
  if ($confine_x >= $root_width) {
    $confine_x = $root_width - 1;
    $confine_width = 1;
  }
  if ($confine_y >= $root_height) {
    $confine_y = $root_height - 1;
    $confine_height = 1;
  }

  # Chop off any width/height exceeding the screen.  This is in case
  # width,height are big values which overflow the 16-bit integers in the X
  # protocol.
  $confine_width  = min ($confine_width,  $root_width  - $confine_x);
  $confine_height = min ($confine_height, $root_height - $confine_y);

  ### confine to: "$confine_x,$confine_y   ${confine_width}x${confine_height}"
  $confine_win->move_resize ($confine_x, $confine_y,
                             $confine_width, $confine_height);
}

# 'motion-notify-event' on widget, and also called for button release.
#
# The basic operation is simply to look at how many pixels the new x,y in
# $event has moved from our last_x,last_y and apply those amounts to the
# "value" in the adjustments.  But with attention to the following:
#
# * Scale factor $value_per_pixel converts between a window worth of pixels
#   equivalent to a page size amount in the adjust.
#
# * last_x and last_y are kept in root window coordinates.  This makes no
#   difference to each "delta" calculated, but means we're safe against any
#   changes to the widget window position; and also makes the confine_win
#   calculation a little easier.
#
# * The hinverted/vinverted settings are tricky to get the right way around.
#   In normal state a move to the right reduces the value, and when inverted
#   it's the other way around.
#
# * An "unapplied" amount of value is maintained horizontally and vertically
#   if the prospective value would be outside the adjustment upper/lower
#   bounds.  It gets added back each time, with the effect of keeping the
#   same widget contents position under the mouse if you go beyond the limit
#   and then come back.
#
sub _do_motion_notify {
  my ($widget, $event, $ref_weak_self) = @_;
  #### Dragger _do_motion_notify()
  my $self = $$ref_weak_self || return Gtk2::EVENT_PROPAGATE;

  # Believe no need for Gtk 2.12 $event->request_motions here since our
  # device is only ever the mouse, so $win->get_pointer is enough.  Besides,
  # request_motions() looks pretty slack -- surely if you're going to do a
  # server round trip (as $disp->get_pointer or $device->get_state) then you
  # should use the position obtained, not throw it away.
  #
  # test can('is_hint') to allow for final $event a Gtk2::Gdk::Event::Button
  # release; such an event doesn't have an is_hint field.
  #
  my ($x, $y);
  if ($event->can('is_hint') && $event->is_hint) {
    (undef, $x, $y) = $widget->get_root_window->get_pointer;
  } else {
    ($x, $y) = $event->get_root_coords;
  }

  my $win = $widget->Gtk2_Ex_Dragger_window;
  my ($win_width, $win_height) = $win->get_size;
  _set_value ($self, $self->{'h'}, $win_width, $x);
  _set_value ($self, $self->{'v'}, $win_height, $y);
  return Gtk2::EVENT_PROPAGATE;
}

sub _set_value {
  my ($self, $axis, $win_size, $pixel) = @_;
  ##### Dragger _set_value(): "pixel $pixel", $axis

  my $adj = $axis->{'adjustment'} || return;

  my $delta_pixel = $pixel - $axis->{'last_pixel'};
  if ($delta_pixel == 0) { return; }
  $axis->{'last_pixel'} = $pixel;
  if ($axis->{'inverted'}) { $delta_pixel = - $delta_pixel; }

  my $page_size = $adj->page_size;
  my $value_per_pixel = $page_size / $win_size;
  my $old_value = $adj->value;
  my $new_value
    = $old_value + $axis->{'unapplied'} - $delta_pixel * $value_per_pixel;
  my $unapplied = 0;

  my $lower = $adj->lower;
  if ($new_value < $lower) {
    $unapplied = $new_value - $lower; # negative
    $new_value = $lower;
  }
  my $upper = $adj->upper - $page_size;
  if ($new_value > $upper) {
    $unapplied = $new_value - $upper; # positive
    $new_value = $upper;
  }
  $axis->{'unapplied'} = $unapplied;

  ### set value: $new_value
  $adj->value ($new_value);
  $new_value = $axis->{'last_value'} = $adj->value; # refetch in case rounding
  ### rounded from NV: $new_value
  if ($old_value == $new_value) {
    ### unchanged, no signals
    return;
  }

  $adj->notify ('value');

  my $update_policy = $self->{'update_policy'} || 'default';
  if ($update_policy eq 'continuous') {
    # emit on every set
    $adj->value_changed;
    return;
  }

  $axis->{'pending'} = 1;

  if ($update_policy eq 'discontinuous') {
    # don't emit at all until stop
    return;
  }

  if ($update_policy eq 'delayed') {
    $self->{'timer_id'} ||= Glib::Timeout->add
      (DELAY_MILLISECONDS, \&_do_timer_delayed, _ref_weak ($self));
    return;
  }

  # default policy
  require Gtk2::Ex::SyncCall;
  if (! $self->{'sync_obj'} && ! $self->{'timer_id'}) {
    #### Dragger SyncCall send
    my $ref_weak_self = _ref_weak ($self);
    $self->{'sync_obj'} = Gtk2::Ex::SyncCall->sync
      ($self->{'widget'}, \&_do_sync, $ref_weak_self);
    $self->{'timer_id'} = Glib::Timeout->add
      (DELAY_MILLISECONDS, \&_do_timer_sync, $ref_weak_self);
  }
}

# timer expiry for 'delayed' policy
# emit 'value-changed' when the timer expires
#
sub _do_timer_delayed {
  my ($ref_weak_self) = @_;
  my $self = $$ref_weak_self || return Glib::SOURCE_REMOVE;
  #### Dragger _do_timer_delayed()

  $self->{'timer_id'} = 0;
  _emit_pending ($self);
  return Glib::SOURCE_REMOVE;
}

# sync response for 'default' policy
#
# At this point we wait for the timer or for idle, whichever comes first.
# It's possible the timer has already gone off (zeroing 'timer_id'), if
# that's the case them we emit immediately; otherwise start an idle.
#
sub _do_sync {
  my ($ref_weak_self) = @_;
  #### Dragger _do_sync()
  my $self = $$ref_weak_self || return;

  $self->{'sync_obj'} = 0;
  if ($self->{'timer_id'}) {
    $self->{'idle_id'} ||= Glib::Idle->add
      (\&_do_idle, _ref_weak ($self), Gtk2::GDK_PRIORITY_REDRAW - 1);
  } else {
    _emit_pending ($self);
  }
}

# timer expiry for 'default' policy
#
# If the sync response hasn't yet been received then we do nothing, instead
# wait for that.  If it has been received then we can emit now, and cancel
# the idle that was running.
#
sub _do_timer_sync {
  my ($ref_weak_self) = @_;
  my $self = $$ref_weak_self || return Glib::SOURCE_REMOVE;
  #### Dragger _do_timer_sync() with sync: "$self->{'sync_obj'}"

  if (my $id = $self->{'idle_id'}) {
    $self->{'idle_id'} = 0;
    Glib::Source->remove ($id);
  }
  $self->{'timer_id'} = 0;

  if (! $self->{'sync_obj'}) {
    _emit_pending ($self);
  }
  return Glib::SOURCE_REMOVE;
}

# idle handler for 'default' policy
sub _do_idle {
  my ($ref_weak_self) = @_;
  #### Dragger _do_idle() after sync
  my $self = $$ref_weak_self || return Glib::SOURCE_REMOVE;

  if (my $id = $self->{'timer_id'}) {
    $self->{'timer_id'} = 0;
    Glib::Source->remove ($id);
  }
  $self->{'idle_id'} = 0;
  _emit_pending ($self);
  return Glib::SOURCE_REMOVE;
}

sub _emit_pending {
  my ($self) = @_;
  foreach my $axis ($self->{'h'}, $self->{'v'}) {
    if ($axis->{'pending'}) {
      $axis->{'pending'} = 0;
      $axis->{'adjustment'}->value_changed;
    }
  }
}

#------------------------------------------------------------------------------
# $widget->Gtk2_Ex_Dragger_window() returns the window in $widget which the
# dragger should operate on (the size to page conversion).
#
# Crib notes:
#
# GtkLayout, and subclasses like GnomeCanvas
#     Plain $widget->window is the visible extent, so nothing special
#     needed.  The scrolls move the bin_window subwindow, but how scrolling
#     is drawn doesn't matter to us.
#

sub Gtk2::Widget::Gtk2_Ex_Dragger_window {
  my ($widget) = @_;
  if (exists $widget->{'Gtk2_Ex_Dragger_window'}) {
    # user override -- but this not (yet) a documented feature as such
    return $widget->{'Gtk2_Ex_Dragger_window'};
  }
  # default
  return $widget->window;
}

# for TextView the "text" window is the visible extent
sub Gtk2::TextView::Gtk2_Ex_Dragger_window {
  my ($textview) = @_;
  return $textview->get_window ('text');
}

# for TreeView the "bin" window is the visible extent
*Gtk2::TreeView::Gtk2_Ex_Dragger_window
  = \&Gtk2::TreeView::get_bin_window;

# For Viewport there's $widget->window then within that a "view_window"
# which is smaller by the border size.  This view_window is the scrollable
# part we're interested in, but it's not a documented feature, so this is a
# nasty hack to pick it out.
#
# The $viewport->get_bin_window is a sub-window of the view_window.  It
# contains the viewport children.  (In the gtk manual in gtk 2.20 but not
# explained as such.)
#
sub Gtk2::Viewport::Gtk2_Ex_Dragger_window {
  my ($viewport) = @_;
  my $win;
  return (($win = $viewport->window) # if realized
          && ($win->get_children)[0]);
}


#------------------------------------------------------------------------------
# generic helpers

# Return two values ($floor, $frac).
# $floor is $x rounded down to an integer towards negative infinity
# $frac is the fractional part subtracted from $x to get to $floor,
# so $floor+$frac == $x
#
sub _floor_and_frac {
  my ($x) = @_;
  my $f = POSIX::floor ($x);
  return ($f, $x - $f);
}

sub _ref_weak {
  my ($self) = @_;
  Scalar::Util::weaken ($self);
  return \$self;
}


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

1;
__END__