File Coverage

blib/lib/Gtk2/Ex/AdjustmentBits.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 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::AdjustmentBits;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2 1.220;
use List::Util 'min', 'max';

our $VERSION = 48;

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


# Names a bit too generic to want to import usually.
# use Exporter;
# our @ISA = ('Exporter');
# our @EXPORT_OK = qw(scroll_value
#                     scroll_increment
#                     set_maybe set_empty);

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

sub scroll_value {
  my ($adj, $amount) = @_;
  my $oldval = $adj->value;
  $adj->value (max ($adj->lower,
                    min ($adj->upper - $adj->page_size,
                         $oldval + $amount)));
  # re-fetch $adj->value() for comparison to allow round-off on storing if
  # perl NV is a long double
  if ($adj->value != $oldval) {
    $adj->notify ('value');
    $adj->signal_emit ('value-changed');
  }
}

# Validate $type as "page" or "step" so as not to let dubious input call an
# arbitrary method.
my %increment_method = (page => 'page_increment',
                        step => 'step_increment',
                        # page_increment => 'page_increment',
                        # step_increment => 'step_increment',
                       );
sub scroll_increment {
  my ($adj, $inctype, $inverted) = @_;
  my $method = $increment_method{$inctype}
    || croak "Unrecognised increment type: ",$inctype;
  scroll_value ($adj, $adj->$method * ($inverted ? -1 : 1));
}

my %direction_is_inverted = (up    => 1,  # Gtk2::Gdk::ScrollDirection enum
                             down  => 0,
                             left  => 1,
                             right => 0);
sub scroll_event {
  my ($adj, $event, $inverted) = @_;
  $inverted ^= $direction_is_inverted{$event->direction};
  Gtk2::Ex::AdjustmentBits::scroll_increment
      ($adj,
       ($event->state & 'control-mask' ? 'page' : 'step'),
       $inverted);
  return 0; # Gtk2::EVENT_PROPAGATE
}

#------------------------------------------------------------------------------
# set_maybe()
#
# Gtk 2.0
#   $adj->changed() emits "changed" only
#   $adj->value_changed() emits "value-changed" only
# Gtk 2.6
#   $adj->changed() emits "changed" only
#   $adj->value_changed() emits "value-changed" and "notify::value"

use constant _NOTIFY_EMITS_CHANGED =>
  do {
    my $adj = Gtk2::Adjustment->new (0,0,0,0,0,0);
    my $result = 0;
    $adj->signal_connect (changed => sub { $result = 1 });
    $adj->notify ('upper');
    $result
  };
### _NOTIFY_EMITS_CHANGED is: _NOTIFY_EMITS_CHANGED()

if (_NOTIFY_EMITS_CHANGED) {
  require Glib::Ex::FreezeNotify;
}

sub set_maybe {
  my ($adj, %values) = @_;
  ### AdjustmentBits set_maybe(): "from ",caller()

  my $value = delete $values{'value'};
  if (! defined $value) { $value = $adj->value; }

  # compare after storing to see the value converted to double perhaps
  # from a 64-bit perl integer etc
  foreach my $key (keys %values) {
    my $old = $adj->$key;
    $adj->$key ($values{$key});
    if ($adj->$key == $old) {
      delete $values{$key};
    }
  }
  ### set_maybe change: %values

  $value = max ($adj->lower,
                min ($adj->upper - $adj->page_size,
                     $value));
  {
    my $old = $adj->value;
    $adj->value ($value);
    if ($adj->value != $old) {
      $values{'value'} = 1;
    }
  }

  if (%values) {
    # In gtk 2.18 emitting "notify" wastefully emits "changed" too.
    # Freezing collapses to just one of those "changed".
    my $freezer = _NOTIFY_EMITS_CHANGED && Glib::Ex::FreezeNotify->new($adj);

    foreach my $key (keys %values) {
      $adj->notify ($key);
    }
    $value = delete $values{'value'};

    if (! _NOTIFY_EMITS_CHANGED) {
      if (%values) {
        $adj->changed;
      }
    }
    if (defined $value) {
      # use signal_emit() since gtk_adjustment_value_changed() func varies
      # among gtk versions as to whether it emits "notify::value" too
      $adj->signal_emit('value-changed');
    }
  }
}

# configure() emits notify and changed even if upper/lower etc unchanged, so
# no good.
#
#   if (Gtk2::Adjustment->can('configure')) {
#     # new in gtk 2.14 and Perl-Gtk 1.240
#     eval "\n#line ".(__LINE__+1)." \"".__FILE__."\"\n" . <<'HERE' or die;
#
#   sub set_maybe {
#     my ($adj, %values) = @_;
#     ### AdjustmentBits set_maybe(), with configure()
#
#     $adj->configure (map {
#       my $value = delete $values{$_};
#       (defined $value ? $value : $adj->$_)
#     } qw(value
#          lower upper
#          step_increment page_increment page_size));
#     if (%values) {
#       croak "Unrecognised adjustment field(s) ",join(',',keys %values);
#     }
#   }
#   1;
# HERE

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

sub set_empty {
  my ($adj) = @_;
  Gtk2::Ex::AdjustmentBits::set_maybe ($adj,
                                       upper => 0,
                                       lower => 0,
                                       page_size => 0,
                                       page_increment => 0,
                                       step_increment => 0,
                                       value => 0);
}

1;
__END__