File Coverage

blib/lib/Tk/FilterEntry.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Tk::FilterEntry;

use vars qw($VERSION);
$VERSION = '0.02';

use strict;
use Tk;
use Tk::Entry;

use base qw(Tk::Derived Tk::Entry);

Construct Tk::Widget 'FilterEntry';

sub ClassInit {
	my ($class, $mw) = @_;

	$class->SUPER::ClassInit($mw);

	$mw->bind($class, '' => \&FocusIn);
	$mw->bind($class, '' => \&FocusOut);
	$mw->bind($class, '' => \&FocusOut);
}

sub Populate {
	my ($self, $args) = @_;

	$self->SUPER::Populate($args);

	$self->ConfigSpecs(
			-background		=> ['PASSIVE', 'background', undef, 'white'],
			-fg_valid		=> ['PASSIVE', 'fg_valid', undef, 'black'],
			-fg_invalid		=> ['PASSIVE', 'fg_invalid', undef, 'red'],
			-filter			=> ['PASSIVE', 'filter', undef, '.*'],
			-anchors		=> ['PASSIVE', 'anchors', undef, 1],
			-trim			=> ['PASSIVE', 'trim', undef, 1],
	);
}

sub FocusIn {
	my $self = shift;

	my $fg = $self->cget(-fg_valid);
	$self->Tk::Entry::configure(-foreground => $fg);
}

sub FocusOut {
	my $self = shift;

	my $filter = $self->cget(-filter);
	my $trim = $self->cget(-trim);
	my $anchors = $self->cget(-anchors);
	$filter = '\s*' . $filter . '\s*' if ($trim);
	$filter = '^' . $filter . '$' if ($anchors);
	my $value = $self->get();
	my $r_vcmd = $self->cget(-validatecommand);
	my (@vcmd, $vcmd);
	if (defined $r_vcmd) {
		@vcmd = @{$r_vcmd};
		$vcmd = shift @vcmd;
	}

	if (       ( defined $vcmd and ! &{$vcmd}($self, @vcmd) )
			or ( defined $filter   and ( $value !~ /$filter/ ) ) ) {
		my $fg = $self->cget(-fg_invalid);
		$self->Tk::Entry::configure(-foreground => $fg);
		my $r_invcmd = $self->cget(-invalidcommand);
		if (defined $r_invcmd) {
			my @invcmd = @{$r_invcmd};
			my $invcmd = shift @invcmd;
			&{$invcmd}($self, @invcmd);
		}
	}
}

sub validate {
	my $self = shift;

	my $r_vcmd = $self->cget(-validatecommand);
	if (defined $r_vcmd) {
		my @vcmd = @{$r_vcmd};
		my $vcmd = shift @vcmd;
		return &{$vcmd}($self, @vcmd);
	}

	my $filter = $self->cget(-filter);
	my $trim = $self->cget(-trim);
	my $anchors = $self->cget(-anchors);
	$filter = '\s*' . $filter . '\s*' if ($trim);
	$filter = '^' . $filter . '$' if ($anchors);
	my $value = $self->get();
	return ( $value =~ /$filter/ ) if (defined $filter);

	return 1;
}

1;

__END__