File Coverage

blib/lib/Tkx/ROText.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Tkx::ROText;
use strict;
use warnings;

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

our $VERSION = '0.06';

__PACKAGE__->_Mega('tkx_ROText');

__PACKAGE__->_Config(
	-state  => ['METHOD'],
	DEFAULT => ['.text'],
);


#-------------------------------------------------------------------------------
# Method  : _Populate
# Purpose : Create a new Tkx::ROText widget
# Notes   :
#-------------------------------------------------------------------------------
sub _Populate {
	my $class  = shift;
	my $widget = shift;
	my $path   = shift;
	my %opt    = (-state => 'readonly', @_);
	my $state  = delete $opt{-state}; # use custom handler for this option

	# create the widget
	my $self = $class->new($path)->_parent
		->new_frame(-name => $path, -class => 'Tkx_ROText');
	$self->_class($class);

	my $text = $self->new_text(-name => 'text', %opt);
	$text->g_pack(-fill => 'both', -expand => 1);

	# Rename the widget to make it private. This enables us to stub the
	# insert/delete methods and make it read-only. Calling _readonly() sets up
	# the handlers for public/private aliasing so that calls to the configure()
	# method work.
	Tkx::rename($text, $text . '.priv');
	$self->_readonly();

	$self->configure(-state => $state);

	return $self;
}


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


#-------------------------------------------------------------------------------
# Method  : insert/delete
# Purpose : Provide methods for programmatic insertions and deletions
# Notes   : The 'm_' prefix is to support method delegation from megawidgets
#           that embed this one.
#-------------------------------------------------------------------------------
sub m_insert { my $self = shift; Tkx::i::call($self . '.text.priv', 'insert', @_) }
sub m_delete { my $self = shift; Tkx::i::call($self . '.text.priv', 'delete', @_) }


#-------------------------------------------------------------------------------
# Method  : _config_state
# Purpose : Handler for configure(-state => )
# Notes   :
#-------------------------------------------------------------------------------
sub _config_state {
	my $self  = shift;
	my $state = shift;
	my $path  = $self . '.text';

	if (defined $state) {

		if ($state eq 'readonly') {
			$self->_readonly(1);
			Tkx::i::call($path , 'configure', '-state', 'normal');
		}
		elsif ($state eq 'normal') {
			$self->_readonly(0);
			Tkx::i::call($path, 'configure', '-state', 'normal');
		}
		elsif ($state eq 'disabled') {
			Tkx::i::call($path, 'configure', '-state', 'disabled');
			# The readonly state doesn't matter when the widget is disabled.
		}
		else {
			croak qq'bad state value "$state": must be normal, disabled, or readonly';
		}

		$self->_data->{-state} = $state;
	}

	return $self->_data->{-state};
}


#-------------------------------------------------------------------------------
# Method  : _readonly
# Purpose : Control whether widget is read-only or read/write.
# Notes   :
#-------------------------------------------------------------------------------
sub _readonly {
	my $self = shift;
	my $ro   = shift;
	my $path = $self . '.text';

	if ($ro) {

		Tkx::eval(<
proc $path {args} [string map [list WIDGET $path] {
	switch [lindex \$args 0] {
		"insert" {}
		"delete" {}
		"default" { return [eval WIDGET.priv \$args] }
	}
}]
EOT

	}
	else {

		Tkx::eval(<
proc $path {args} [string map [list WIDGET $path] {
	return [eval WIDGET.priv \$args]
}]
EOT

	}
}


1;

__END__