Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

comment on
( #3333=superdoc: print w/replies, xml ) Need Help??
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

In reply to Perl TK Submit enter incorrect routine by minixman

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (2)
As of 2023-09-22 02:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found
    Notices?