http://qs1969.pair.com?node_id=1148859

yedukondalu has asked for the wisdom of the Perl Monks concerning the following question:

#!usr/bin/perl use warnings; use strict; use Tk; #$\="\n"; my $name; my $age; my $dob; open(my $fh,'+<','details.txt') || die "Can't open the file details.tx +t $!"; #creating a Mainwindow: my $window = MainWindow->new(); $window->geometry('480'."x".'320'); #my $first_frame = $window -> Frame(-background => 'red' ,-foreground +=> 'black',)->pack(-side => 'top',-ipadx => 10,-fill => 'x', -ipady = +> 1); my $first_frame = $window -> Frame(-relief=>"solid")->pack(-side => 't +op',-ipadx => 10,-fill => 'x', -ipady => 1); $first_frame -> Label(-text => 'Fill the details listed below') -> gr +id(-row => 0 ,-column => 2,-rowspan => 1); my $frame = $window -> Frame(-background => 'grey')->pack(-side => 'to +p',-ipadx =>150,-fill => 'x',-ipady => 60); my $name_label=$frame -> Label(-text => 'Name') -> grid(-row => 2, -co +lumn=> 0); my $name_entry=$frame->Entry(-background => 'white',-foreground => 'bl +ack', -textvariable => \$name, -validate => 'focusout',-validatecomma +nd => \&check_name)->grid(-row =>2, -column=>1); my $age_label=$frame -> Label(-text => 'age')-> grid(-row => 4, -colum +n=> 0); my $age_entry = $frame -> Entry(-background => 'white',-foreground => +'black', -textvariable => \$age,-validate => 'focusout',-validatecomm +and => \&check_age) -> grid(-row =>4, -column=>1); my $dob_label=$frame -> Label(-text => 'DOB')-> grid(-row => 6, -colum +n=> 0); my $dob_entry = $frame -> Entry(-background => 'white',-foreground => +'black',-textvariable => \$dob,-validate => 'focusout',-validatecomma +nd => \&validate_dob) -> grid(-row =>6, -column=>1); $name = $name_entry -> get(); $age = $age_entry -> get(); $dob = $dob_entry -> get(); #my $submit = $frame -> Button(-text => 'submit', -command =>sub {prin +t " Name : $name \n Age : $age \n DOB : $dob \n"} ) -> grid(-row =>5, + -column=>1); my $submit = $frame -> Button(-text => 'submit', -command =>sub {&subm +it} ) -> grid( -row =>8, -column=>1); $frame -> Label(-background => 'grey') -> grid(-rowspan=> 6); $frame -> Label(-text => 'After adding all the details click quit to e +xit') -> grid( -row => 16, -column=> 1); $frame -> Label(-background => 'grey') -> grid(-rowspan=> 6); my $quit = $frame -> Button(-text => 'Quit', -command =>sub {exit} ) - +> grid(-row =>25, -column=>1); sub submit { if((!$name) || ($name =~ m/[0-9]/) || (($age =~ m/[a-z]/i)|| (!$age) +) || ((!$dob)|| ($dob !~ m/\d{1,2}[\/|\:]\d{1,2}[\/|\:]\d{4}/))) { $frame -> messageBox( -icon => 'info',-message => 'Fill the fileld +s correctly', -type => 'Ok' ); } else { my $line= join(' ',$name,$age,$dob); print $fh $line,"\n"; if(!($?)) { my $button = $frame -> messageBox( -icon => 'info',-message +=> 'Details added successfully to file', -type => 'Ok' ); $name_entry->delete('0', 'end'); $age_entry->delete('0', 'end'); $dob_entry->delete('0', 'end'); $name_entry->focus(); } } } sub check_name { if ((!$name) || ($name =~ m/[0-9]/)) { $name_entry->messageBox( -icon => 'info',-message => 'Name should +not contain numeric values' ,-type => 'Ok'); $name_entry->delete('0', 'end'); $name_entry->focus(); } else { $name_entry->checkbutton(-indicatoron); } } sub check_age { if ((!$age) || ($age=~ m/[a-z]/i)) { $age_entry->messageBox( -icon => 'error',-message => 'age should +not contain characters' ,-type => 'Ok'); $age_entry->delete('0','end'); $age_entry->focus(); } } sub validate_dob { if ((!$dob) || ($dob !~ m/\d{1,2}[\/|\:]\d{1,2}[\/|\:]\d{4}/)) { $dob_entry->messageBox( -icon => 'error',-message => 'Enter valid + date' ,-type => 'Ok'); $dob_entry->delete('0', 'end'); $dob_entry->focus(); } }

When trying to validate the age the dob validation pops without calling it's subroutine.

Replies are listed 'Best First'.
Re: can'yt figure out whats wrong in this code?
by kcott (Archbishop) on Nov 30, 2015 at 08:25 UTC

    G'day yedukondalu,

    "can'yt figure out whats wrong in this code?"

    If I could run your code, I'd take a look; however, it's clear that it will die with something like

    Can't open the file details.txt No such file

    so there's little point in me trying.

    Please provide a cutdown version, that only contains code relevant to your problem, which we can run — see "How do I post a question effectively?" for more details about this.

    Also, that's a terrible title. Consider changing it to something meaningful, perhaps: "Problem validating Tk::Entry field"

    "When trying to validate the age the dob validation pops without calling it's subroutine."

    I can't tell what your problem is from this description. My best guess about the first part is that "-validatecommand => \&check_age" is somehow acting as if it was coded as "-validatecommand => \&validate_dob"; however, the last part is just far too vague (what's calling who's unnamed subroutine?). Please write a description which is descriptive!

    As far as I can see, none of your validation routines are reading the arguments passed to them. Please see the Tk::Entry documentation; in particular, the VALIDATION section. You may also want to look at Tk::callbacks.

    Your actual validation checks are also problematic. As an example:

    sub check_age { if ((!$age) || ($age=~ m/[a-z]/i)) { $age_entry->messageBox( -icon => 'error',-message => 'age should +not contain characters' ,-type => 'Ok'); ...

    According to this, an age of, say, "~!@#$%^&*()_+" would be perfectly OK. I don't think so!

    I'd be more than happy to help you. Help me to do so.

    — Ken

Re: can'yt figure out whats wrong in this code?
by Anonymous Monk on Nov 30, 2015 at 08:35 UTC

    You're changing focus and triggering focus events ... you're also popping up popups, popups are annoying :) its better to validate on key without popups, popup at most only once on submit, on all others ring the bell and flash invalid

    #!/usr/bin/perl -- use strict; use warnings; use Tk; my $mw = tkinit; my $name = $mw->Entry( -validatecommand => \&nodigits, -validate => ' +key',)->pack; $name->focus; #~ $mw->WidgetDump; use Tk::WidgetDump; $mw->MainLoop; sub nodigits { my( $newstring, $difference, $oldstring, $index, $insertOrDelete ) + = @_; my $entry = $Tk::event->W; if( $newstring =~ m/\d/ ){ $entry->bell; $entry->configure( -bg => 'red' ); $entry->after( 300, sub { $entry->configure( -bg => 'white' ) +} ); return undef; } else { $entry->configure( -bg => 'white' ); return 1; } }