view release on metacpan or  search on metacpan

FmtEntry.pm  view on Meta::CPAN

#=============================================================================
#
# Formatted Entry widget
#
#-----------------------------------------------------------------------------

package Tk::FmtEntry;
use vars qw/$VERSION/;
$VERSION = '0.1';

use Tk::widgets qw/Entry/;
use base qw/Tk::Derived Tk::Entry/;
use strict;
use warnings;
use Carp;

Construct Tk::Widget 'FmtEntry';

sub ClassInit {
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
}

sub Populate {
    my ($w, $args) = @_;
    $w->SUPER::Populate($args);
    $w->{_fe_suppress} = 0;
    $w->{_fe_usrvcmd} = undef;
    $w->{_fe_usrvali} = 'none';
    $w->{_fe_fixuptimer} = undef;
    $w->SUPER::configure(
        -validate => 'key',
        -vcmd     => sub {$w->_fe_validate}
    );
    $w->ConfigSpecs(
        -delay           => [qw/PASSIVE delay Delay 0/],
        -formatcommand   => ['PASSIVE'],
        -fcmd            => '-formatcommand',
        -validate        => ['METHOD'],
        -validatecommand => ['METHOD'],
        'DEFAULT'        => ['SELF']
    );
    return $w;
}

sub validate {
    my $w = shift;
    return $w->{_fe_usrvali} if !@_;
    return if $w->{_fe_suppress};
    my $value = shift;
    croak "Tk::FmtEntry supports only 'none' or 'key' for -validate"
        if ($value ne 'none') && ($value ne 'key');
    $w->{_fe_usrvali} = $value;
}

sub validatecommand {
    my $w = shift;
    return $w->{_fe_usrvcmd} if !@_;
    return if $w->{_fe_suppress};
    my $value = shift;
    $w->{_fe_usrvcmd} = $value;
}

sub _fe_fixup {
    my $w   = shift;
    my $old = $w->get;
    my $i   = $w->index('insert');
    my $fcmd = $w->cget('-formatcommand');
    $w->{_fe_fixuptimer} = undef;

    # Call the formatter, if defined
    my $new = $old;