File Coverage

blib/lib/Tkx/Scrolled.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

#===============================================================================
# Tkx/Scrolled.pm
# Copyright 2009-2010 Michael J. Carman. All rights reserved.
#===============================================================================
package Tkx::Scrolled;
use 5.006;
use strict;
use warnings;

use Carp qw(croak);
use Tkx;
use base qw(Tkx::widget Tkx::MegaConfig);

our $VERSION = '0.06';

__PACKAGE__->_Mega('tkx_Scrolled');

__PACKAGE__->_Config(
	DEFAULT => ['.scrolled'],
);

my $initialized;
my $tile_available;

# regular expression for validation of -scrollbars argument
my $valid_scrollbar_position = qr/
	(?:^o?[ns]?o?[ew]?$)  # normal directions: n, s, e, w, ne, nw, se, sw
	|(?:^o?[ew]o?[ns]$)   # unusual variants: en, es, wn, ws
/xi;

#-------------------------------------------------------------------------------
# Subroutine : _ClassInit
# Purpose    : Perform class initialization.
# Notes      :
#-------------------------------------------------------------------------------
sub _ClassInit {
	# determine availability of themed widgets
	$tile_available = eval { Tkx::package_require('tile') };
	$initialized++;
}


#-------------------------------------------------------------------------------
# Method  : _Populate
# Purpose : Create a new Tkx::Scrolled widget
# Notes   :
#-------------------------------------------------------------------------------
sub _Populate {
	my $class  = shift;
	my $widget = shift;
	my $path   = shift;
	my $type   = shift;
	my %opt    = (
		-tile       => 1,
		-scrollbars => 'se',
		@_,
	);

	_ClassInit() unless $initialized;

	# Create the megawidget.
	my $self = ($tile_available && $opt{-tile})
		? $class->new($path)->_parent->new_ttk__frame(-name => $path, -class => 'Tkx_Scrolled')
		: $class->new($path)->_parent->new_frame(-name => $path, -class => 'Tkx_Scrolled');
	$self->_class($class);

	my $data = $self->_data();

	# Delete megawidget options so that we can safely pass the remaining
	# ones through to the scrolled subwidget.
	$data->{-tile}       = delete $opt{-tile} && $tile_available;
	$data->{-scrollbars} = delete $opt{-scrollbars};

	# Validate requested scrollbar positions.
	if ($data->{-scrollbars} =~ $valid_scrollbar_position) {
		$data->{xscrollbar}{optional} = ($data->{-scrollbars} =~ /o[ns]/);
		$data->{yscrollbar}{optional} = ($data->{-scrollbars} =~ /o[ew]/);
	}
	else {
		croak("Invalid value for option '-scrollbars', must be n, s, e, w or a combination");
	}

	# Create the widgets.
	my $new_thing = "new_$type";
	my $w = $self->$new_thing(-name => 'scrolled',   %opt);
	my $x = $self->_scrollbar(-name => 'xscrollbar', -orient => 'horizontal');
	my $y = $self->_scrollbar(-name => 'yscrollbar', -orient => 'vertical');

	# Create widget bindings. If the scrolled widget is a megawidget (e.g.
	# Tkx::ROText) any method delegation it does won't work because the
	# scrollbar widgets operate in Tcl/Tk; they are oblivious to the Perl layer
	# above it. We use _mpath() to resolve any delegation now and provide the
	# Tcl pathname of the delegate for use by the scrollbars.
	$x->configure(-command        => [$w->_mpath('xview'), 'xview']);
	$y->configure(-command        => [$w->_mpath('yview'), 'yview']);
	$w->configure(-xscrollcommand => [\&_set, $self, 'xscrollbar']);
	$w->configure(-yscrollcommand => [\&_set, $self, 'yscrollbar']);

	# Determine the placement of the scrollbars. The corner between the
	# scrollbars is left empty; this keeps the ends of the scrollbars from
	# overlapping.
	my ($r, $c);
	for ($self->_data->{-scrollbars}) {
		/n/ && do { $r = 0 };
		/s/ && do { $r = 2 };
		/e/ && do { $c = 2 };
		/w/ && do { $c = 0 };
	}

	# Layout the widgets
	$w->g_grid(-row => 1,  -column => 1,  -sticky => 'nsew');
	$x->g_grid(-row => $r, -column => 1,  -sticky => 'ew'  ) if defined $r;
	$y->g_grid(-row => 1,  -column => $c, -sticky => 'ns'  ) if defined $c;

	Tkx::grid('columnconfigure', $self, 1, '-weight', 1);
	Tkx::grid('rowconfigure',    $self, 1, '-weight', 1);

	Tkx::grid('remove', $x) if $data->{xscrollbar}{optional};
	Tkx::grid('remove', $y) if $data->{yscrollbar}{optional};

	return $self;
}


#-------------------------------------------------------------------------------
# Method  : _mpath
# Purpose : Delegate all method calls to the scrolled subwidget.
# Notes   :
#-------------------------------------------------------------------------------
sub _mpath { $_[0] . '.scrolled' }


#-------------------------------------------------------------------------------
# Method  : _scrollbar
# Purpose : Create a scrollbar widget using the tile setting.
# Notes   :
#-------------------------------------------------------------------------------
sub _scrollbar {
	my $self = shift;

	return $self->_data->{-tile}
		? $self->new_ttk__scrollbar(@_)
		: $self->new_scrollbar(@_);
}


#-------------------------------------------------------------------------------
# Method  : _set
# Purpose : Set a scrollbar, possibly hiding/showing it if it's optional
# Notes   :
#    * $self is the *third* argument due to the way the Tcl bridge works.
#    * There is a (literal) corner case that can cause optional scrollbars to
#      flicker when:
#         1) A line of text is at the bottom of the scrolled area.
#         2) The line is the only one long enough to require scrolling.
#         3) Drawing the horizontal scrollbar hides the line (making
#            scrolling unnecessary).
#      Tk doesn't provide a good mechanism for detecting this and handling it
#      robustly. Instead we kludge it it by briefly inhibiting removal of a
#      scrollbar after drawing it.
#-------------------------------------------------------------------------------
sub _set {
	my ($first, $last, $self, $kid) = @_;
	my $sb  = $self->_kid($kid);
	my $cfg = $self->_data()->{$kid};

	$sb->set($first, $last);

	return unless $cfg->{optional};

	if ($first > 0 || $last < 1) {
		return if Tkx::grid('info', $sb);  # Already visible
		$sb->g_grid();                     # Make visible

		# inhibit immediate removal
		$cfg->{inhibit} = 1;
		Tkx::after(10, sub { $cfg->{inhibit} = 0 });
	}
	else {
		return unless Tkx::grid('info', $sb);  # Already hidden
		return if     $cfg->{inhibit};         # Can't hide yet
		Tkx::grid('remove', $sb);              # Hide scrollbar
	}
}


1;

__END__