view release on metacpan or  search on metacpan

lib/Tk/EntryCheck.pm  view on Meta::CPAN

package Tk::EntryCheck;
use warnings; # removed to be backward compatible with perl5.005_03
use strict;
use 5.005;
use Carp;

use vars qw( $VERSION );

$VERSION = '0.04';

use base qw( Tk::Derived Tk::Entry );
Construct Tk::Widget 'EntryCheck';
# ------------------------------------------------------------
sub ClassInit {
    my( $class, $parent ) = @_;

    # class bindings here

    $class->SUPER::ClassInit( $parent );
} # ClassInit
# ------------------------------------------------------------
sub Populate {
    my( $self, $args ) = @_;

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

    $self->ConfigSpecs
        (
         -maxlength => [ 'PASSIVE', 'maxlength', undef, $args->{-maxlength} ],
         -pattern   => [ 'PASSIVE', 'pattern'  , undef, qr/./ ],
#         -totalpattern => [ 'PASSIVE', 'totalPattern', undef, qr/./ ],
     );

    my $maxLength = $args->{-maxlength};
    if( defined $maxLength ) {
        if( $maxLength =~ /\D/ ) {
            Carp::carp( "-maxlength not numeric: '$maxLength'" );
        } # if
        elsif( $maxLength =~ /^\d+/ and $maxLength < 1 ) {
            Carp::carp( "-maxlength must be int > 0: '$maxLength'" );
        } # elsif
    } # if

    $self->configure
        (
         -validate => 'all',
         -validatecommand => [ \&_EntryCheckValidate, $self ],
     );

    return $self;
} # Populate
# ------------------------------------------------------------
sub _EntryCheckValidate {
    my ($self, $text, $textNew, $textOld, $pos, $mode) = @_;

    my $maxlength = $self->{Configure}->{-maxlength};
    my $pattern   = $self->{Configure}->{-pattern};

    # check if -maxlength is reached
    if (defined $maxlength and length($text) > $maxlength) {
	if ($mode == -1) { # change done by -textvariable
	    &Carp::carp("EntryCheck: content of textvariabe too long");
	} # if
	return 0;
    } # if

    # allow all deletions
    return 1 if $mode == 0;

    # check if -pattern is matching
    if (defined $pattern) {