Perl TK Submit enter incorrect routine

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

All.

I seem to have an issue with perl TK. I have a program that creates a main menu.
And one of the drop downs from that main menu is a window which contains a username and function box and a submit and cancel button.

Sorry the code is about 4000 lines, so i will try not to post all of it.
When the window pops up and i enter the values, then click on the submit button.

sub show_amend_userorderroute() {
       my $frame = $mainmenu->Toplevel(-title => 'Amend User',); #  ma
+ke a
     $frame->geometry ('+100+400');
     # Widget Initialization
     # Widget Initialization
    our($_frame_1) = $frame->Frame(
    );
    our($_frame_2) = $frame->Frame(
    );
    our($_frame_3) = $frame->Frame(
    );
    our($amufirstlab) = $frame->Label(
    -activeforeground => '#990000',
    -font => '{MS Sans Serif} 8 bold',
    -foreground => '#990000',
    -text => 'Complex Trading admin ( Amend Order Routing )',
    );
    our($amuseclb) = $frame->Label(
    -activeforeground => '#000099',
    -foreground => '#000099',
    -text => 'Select Fix / Fastfix for user routing',
    );
    our($amalbuid) = $frame->Label(-text => 'Userid',);
    our($amuuserid) = $frame->Entry();
    our($amarolenamelb) = $frame->Label(-text => 'Function',);
    our($amurolename) = $frame->Spinbox(-values => "add remove", );
    our($amalbfunct) = $frame->Label(-text => 'Order Routing',);
    our($btsubmit) = $frame->Button(-text => 'Submit',);
    our($btcancel) = $frame->Button(-text => 'Cancel',);
    our($_text_4) = $frame->Text(-height => '0',-width => '0',);
    our($amufunction) = $frame->Spinbox(-values => 'exchangelink fastf
+ix',);
    # widget commands
     $btsubmit->configure(-command => sub {process_amend_userorderrout
+e(
                                            $amuuserid,
                                           $amurolename,
                                           $amufunction,
                                           $frame);});
     $btcancel->configure(
         -command => sub {$frame->destroy;}
     );
    # Geometry Management
    $_frame_1->grid(
    -in     => $frame,
    -column => '1',
    -row    => '1',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => 'news'
    );
    $_frame_2->grid(
    -in     => $frame,
    -column => '1',
    -row    => '2',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => 'news'
    );
    $_frame_3->grid(
    -in     => $frame,
    -column => '1',
    -row    => '3',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => 'news'
    );
    $amufirstlab->grid(
    -in     => $_frame_1,
    -column => '1',
    -row    => '1',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $amuseclb->grid(
    -in     => $_frame_1,
    -column => '1',
    -row    => '2',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $amalbuid->grid(
    -in     => $_frame_2,
    -column => '1',
    -row    => '1',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $amuuserid->grid(
    -in     => $_frame_2,
    -column => '2',
    -row    => '1',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $amarolenamelb->grid(
    -in     => $_frame_2,
    -column => '1',
    -row    => '2',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $amurolename->grid(
    -in     => $_frame_2,
    -column => '2',
    -row    => '2',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $amalbfunct->grid(
    -in     => $_frame_2,
    -column => '1',
    -row    => '3',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $btsubmit->grid(
    -in     => $_frame_3,
    -column => '1',
    -row    => '1',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $btcancel->grid(
    -in     => $_frame_3,
    -column => '2',
    -row    => '1',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );
    $_text_4->grid(
    -in     => $frame,
    -column => '1',
    -row    => '4',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => 'news'
    );
    $amufunction->grid(
    -in     => $_frame_2,
    -column => '2',
    -row    => '3',
    -columnspan => '1',
    -ipadx => '0',
    -ipady => '0',
    -padx => '0',
    -pady => '0',
    -rowspan => '1',
    -sticky => ''
    );


    # Resize Behavior
    $frame->gridRowconfigure(1, -weight => 0, -minsize => 36, -pad => 
+0);
    $frame->gridRowconfigure(2, -weight => 0, -minsize => 40, -pad => 
+0);
    $frame->gridRowconfigure(3, -weight => 0, -minsize => 40, -pad => 
+0);
    $frame->gridRowconfigure(4, -weight => 0, -minsize => 40, -pad => 
+0);
    $frame->gridColumnconfigure(1, -weight => 0, -minsize => 40, -pad 
+=> 0);
    $_frame_1->gridRowconfigure(1, -weight => 0, -minsize => 29, -pad 
+=> 0);
    $_frame_1->gridRowconfigure(2, -weight => 0, -minsize => 20, -pad 
+=> 0);
    $_frame_1->gridColumnconfigure(1, -weight => 0, -minsize => 40, -p
+ad => 0);
    $_frame_2->gridRowconfigure(1, -weight => 0, -minsize => 40, -pad 
+=> 0);
    $_frame_2->gridRowconfigure(2, -weight => 0, -minsize => 40, -pad 
+=> 0);
    $_frame_2->gridRowconfigure(3, -weight => 0, -minsize => 40, -pad 
+=> 0);
    $_frame_2->gridColumnconfigure(1, -weight => 0, -minsize => 40, -p
+ad => 0);
    $_frame_2->gridColumnconfigure(2, -weight => 0, -minsize => 40, -p
+ad => 0);
    $_frame_3->gridRowconfigure(1, -weight => 0, -minsize => 40, -pad 
+=> 0);
    $_frame_3->gridColumnconfigure(1, -weight => 0, -minsize => 40, -p
+ad => 0);
    $_frame_3->gridColumnconfigure(2, -weight => 0, -minsize => 40, -p
+ad => 0);
   # Display a table with all the user order routing, that is on the c
+orrelator
   # this table is held in the database, and then that info is kept fo
+r logging and
   # Audit the real information is kept on the correaltor in the Logon
+.evt file.
   my $sql = qq{SELECT userid,orderrouting FROM apama_owner.user_routi
+ng};
      my $tb = Text::Table->new("User Name", "Routing");
      my $sth = $dbh->prepare($sql);
      $sth->execute();
      my($username,$routing);
      $sth->bind_columns( undef, \$username, \$routing);
      my $ucount = 3;
      while($sth->fetch() ) {
     $ucount++;
        $tb->load(["$username", "$routing"]);
      }
      $sth->finish();
        # Create a txt box so that we can print the outputs
        # to the users screen.
      $txt = $_text_4-> Scrolled('Text',
                    -width => 40,
                    -height => $ucount,
                    -scrollbars=>'e') -> pack ();
      $txt->insert('end',$tb);
   # End order routine table.
}
[download]

Then i run the following routine.

sub process_amend_userorderroute() {
    my($amuuid,$amufunct,$amurouting,$frame) = @_; # Get values from u
+ser input....
   my $guid = $amuuid->get;
   my $func= $amufunct->get;
   my $orderouting = $amurouting->get;
   $txt->insert('end', "INFO: The following admins password ($guid) wa
+s reset\n");
   my $ret1 = &orderrouting("check",$guid,$orderouting); # Check users
+ order routing.
   my $ret2 = &checkuserexists("apama",$guid); # Check user is in the 
+database
   if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderroute_
+rt: userid = $guid");}
   if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderroute_
+rt: function = $func");}
   if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderroute_
+rt: order_routing = $orderouting");}
   if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderroute_
+rt: current routing for uid = $ret1");}
   if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderroute_
+rt: user exists in Apama DB = $ret2");}
   if(($func =~ m/add/i)&&(!$ret1)&&($ret2)&&($orderouting =~ m/fastfi
+x/i)) {  # User does not have the order routing that is being require
+d.
       my $amuid = "$guid-FF";
       $amuid =~ s/-//g;
       my $ans = &sendcorrelatorupdates("ADD:$amuid:$orderouting");   
+# And send the new data into the Correlator Logon.evt file
       if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderro
+ute_rt: correlator response = $ans");}
       if($ans =~ m/COMPLETED:ADDED/i) {
         # WE know the new user has been injected into the correlator,
+ so we update the database.
         &orderrouting("newrouting",$guid,$orderouting);    # Add new 
+routing into the database
         $txt->insert('end', "New Order routing setup $guid:$orderouti
+ng \n");
         &writelog(1,"$date: INFO: New Order routing setup $guid:$orde
+routing ($amuid)");
       }elsif($ans =~ m/REJECTED-EXISTS/i) {
         $txt->insert('end', "Order routing $guid:$orderouting Correla
+tor rejected, Already exists\n");
         &writelog(1,"$date: INFO: Order routing $guid:$orderouting Co
+rrelator rejected, Already exists ($amuid)");
       }
       $frame->destroy;
   }elsif(($func =~ m/add/i)&&(!$ret1)&&($ret2)&&($orderouting =~ m/ex
+changelink/i)) {  # User does not have the order routing that is bein
+g required.
       my $ans = &sendcorrelatorupdates("ADD:$guid:$orderouting");   #
+ And send the new data into the Correlator Logon.evt file
       if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderro
+ute_rt: correlator response = $ans");}
       if($ans =~ m/COMPLETED:ADDED/i) {
         # WE know the new user has been injected into the correlator,
+ so we update the database.
         &orderrouting("newrouting",$guid,$orderouting);    # Add new 
+routing into the database
         $txt->insert('end', "New Order routing setup $guid:$orderouti
+ng \n");
         &writelog(1,"$date: INFO: New Order routing setup $guid:$orde
+routing ");
       }elsif($ans =~ m/REJECTED-EXISTS/i) {
         $txt->insert('end', "Order routing $guid:$orderouting Correla
+tor rejected, Already exists\n");
         &writelog(1,"$date: INFO: Order routing $guid:$orderouting Co
+rrelator rejected, Already exists ");
       }
       $frame->destroy;
   }elsif(($func =~ m/add/i)&&($ret1)&&($ret2)) { # User already has t
+he required routing.
       $txt->insert('end', "New Order routing setup $guid:$orderouting
+ already configured\n");
       &writelog(1,"$date: INFO: New Order routing setup $guid:$ordero
+uting already configured");
       $frame->destroy;
   }
   # Start Delete functions
   # Add in support for FF translation on userid
   elsif(($func =~ /remove/)&&($orderouting =~ /fastfix/)) { # Delete 
+users order routing, and routing is not in database.
    # First run some checks to see if user has order routing and in ap
+ama.
    if($ret1) {
       my $damuid = "$guid-FF";
       my $ans = &sendcorrelatorupdates("DEL:$damuid:$orderouting");  
+  # And send the new data into the Correlator Logon.evt file
       if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderro
+ute_rt: correlator response = $ans ($damuid)");}
       if($ans =~ m/COMPLETED:DEL/i) { # We know the correlator has re
+moved it from the Logon.evt file
         $txt->insert('end', "Order routing setup $guid:$orderouting d
+eleted\n");
         &writelog(1,"$date: INFO: Order routing setup $guid:$orderout
+ing deleted ($damuid)");
         &orderrouting("delrouting",$guid,$orderouting);    # Add new 
+routing into the database
       }elsif($ans =~ m/REJECTED-NOEXISTS/i) {
         $txt->insert('end', "Order routing setup $guid:$orderouting C
+orrelator rejected, Does not exists\n");
         &writelog(1,"$date: INFO: Order routing setup $guid:$orderout
+ing Correlator rejected, Does not exists ($damuid)");
       }
       $frame->destroy;
   }elsif(($func =~ /remove/)&&($orderouting =~ /exchangelink/)) { # D
+elete users order routing, and routing is not in database.
    # First run some checks to see if user has order routing and in ap
+ama.
    if($ret1) {
       my $ans = &sendcorrelatorupdates("DEL:$guid:$orderouting");    
+# And send the new data into the Correlator Logon.evt file
       if($debug){&writelog(1,"$date: DEBUG: process_amend_userorderro
+ute_rt: correlator response = $ans ");}
       if($ans =~ m/COMPLETED:DEL/i) { # We know the correlator has re
+moved it from the Logon.evt file
         $txt->insert('end', "Order routing setup $guid:$orderouting d
+eleted\n");
         &writelog(1,"$date: INFO: Order routing setup $guid:$orderout
+ing deleted ");
         &orderrouting("delrouting",$guid,$orderouting);    # Add new 
+routing into the database
       }elsif($ans =~ m/REJECTED-NOEXISTS/i) {
         $txt->insert('end', "Order routing setup $guid:$orderouting C
+orrelator rejected, Does not exists\n");
         &writelog(1,"$date: INFO: Order routing setup $guid:$orderout
+ing Correlator rejected, Does not exists ");
       }
       $frame->destroy;
    }else{
       $txt->insert('end', "New Order routing setup $guid:$orderouting
+ Not in database \n");
       &writelog(1,"$date: INFO: New Order routing setup $guid:$ordero
+uting Not in database ::$ret1 : $ret2");
       $frame->destroy;
    }
   }
}
[download]

The problem is that, it does not execute this routine, in the txtfield below the window i can output information, and it seems like the submit button is called another routine in my program called process_amed_adminuser
I know this bec i get the following message come up.

INFO: The following admins password (Tester) was reset
[download]

Which is from &process_amed_adminuser(); .
So i guess my questions is how do i debug this i have tried attaching it to Komodo but it does not seem to pass the MainLoop part of the program.
so i can't see why the submit is going to the other routine.

Edit: g0n - added readmore tags

Comment on Perl TK Submit enter incorrect routine Select or Download Code

Replies are listed 'Best First'.
Re: Perl TK Submit enter incorrect routine by thundergnat (Deacon) on Nov 15, 2005 at 12:16 UTC
What a mess! You REALLY need to use warnings; and use strict; and fix all of the problems they report. You have an incredible amount of duplicate and redundant code in there too. (I suspect this is from some kind of code generator) There are too many errors to go into all of them; lots of undeclared variables, use of prototypes where they are clearly NOT useful or desireable, too much copy & paste coding, etc. To answer your main question: Seems to me that the correct routine is being called. If the only thing telling you it ISN'T is the line `INFO: The following admins password (Tester) was reset` [download] then the fifth line of process_amend_userorderroute is suspect. `$txt->insert('end', "INFO: The following admins password ($guid) was r +eset\n");` [download]	[reply] [d/l] [select]
Re^2: Perl TK Submit enter incorrect routine by minixman (Beadle) on Nov 15, 2005 at 12:22 UTC
I am using strict in the program. in the routines TK i have our which i though't kept the variables non-global and in that routine only.	[reply]
Re^3: Perl TK Submit enter incorrect routine by thundergnat (Deacon) on Nov 15, 2005 at 16:33 UTC
I took a longer look at it and have some more detailed comments/advice. In General: Use more white space. It's inexpensive and makes debugging less tedious. (Personal opinion, though many will agree.) Somewhat related, indent consistantly. Inconsistent, semi-random indentation makes finding missing/extra brackets an excercise in frustration. It also makes following the logic of nested if blocks very tedious. Don't declare variables as globals unless necessary, 'our' variables have especially far-reaching scopes and should be avoided if possible. Use 'my' variables instead. Keep variables in the smallest scope practical, don't pass Tk widget names to subroutiness if all you want is the widgets' value, pass the value instead. Action-at-a-distance bugs are hard to track down. If you are just going to use default values for object attributes, don't include them, it clutters up the code unnecessarily and makes it more difficult for others to help you debug. Don't use prototypes for subroutines if you don't need them. And even if you think you do, you probably don't. Don't call subroutines with the leading ampersand unless you need the effects it adds. If you don't know what effects it adds, you probably don't need it. Something I found puzzling, in the sub process_amend_userorderroute, there are many situations where you are writing information out to a text widget, then, before the information could possibly be displayed, destroying the toplevel that the widget is in. Seems like a lot of wasted effort. Anyway, I took the liberty of rewriting some of your code to demonstrate what I am talking about. There are lots of missing subs, so it won't work standalone. It is still more cluttered than I would prefer, but it is a step in the right direction. Take it or leave it as you like. Read more... (15 kB)	[reply] [d/l]
Re: Perl TK Submit enter incorrect routine by blm (Hermit) on Nov 15, 2005 at 12:37 UTC
Personally, debugging is just done by putting print statements in the code to test my assumptions. You have already done this. I would help you debug it but you would have to provide a runnable program that exhibits the undesirable behaviour. I tried to reproduce your bug with the code you have provided by doing the following I copied show_amend_userorderroute() removed the sub declaration, commented out the sql and put `use Tk; my $window = MainWindow->new();` [download] at the beginning, changed `my $frame = $mainmenu->Toplevel(-title => 'Amend User',);` [download] to `my $frame = $window->Toplevel(-title => 'Amend User',);` [download] and put `MainLoop();` [download] at the end. I get `Tk::Error: Undefined subroutine &main::process_amend_userorderroute called at C: \Documents and Settings\blm\Desktop\test2.pl line 37. Tk callback for .toplevel.button Tk::__ANON__ at C:/Perl/site/lib/Tk.pm line 247 Tk::Button::butUp at C:/Perl/site/lib/Tk/Button.pm line 111 <ButtonRelease-1> (command bound to event)` [download] This means the program tried to run the desired routine and I was unsuccessful in reproducing your bug. (I didn't bother copying and pasting the process_amend_userorderroute to my test code)	[reply] [d/l] [select]

Back to Seekers of Perl Wisdom