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

I created a Perl/tk script to act as a front end to an existing Perl script. This was cloned from a existing (working) script, which I used as a template.

The new script was working and displaying correctly. I was tidying things up and updated the clone to use strict;. After correcting the errors and any problems indicated by Perl -wc the MainLoop hangs. The script runs without error upto the MaonLoop

I tried the following to resolve the issue without success

print "@ main loop\n";
#MainLoop;
while (MainWindow->Count)
{
    print MainWindow->Count,"\n";
    DoOneEvent(ALL_EVENTS);
    #$MainWindow->update();
}

[download]

Console Output:
$perl zip_tk.pl
@ main loop
1


	
$perl -v

This is perl 5, version 16, subversion 0 (v5.16.0) built for MSWin32-x86-multi-thread (with 1 registered patch, see perl -V for more detail)

Copyright 1987-2012, Larry Wall

Binary build 1600 295879 provided by ActiveState http://www.ActiveState.com
Built Jun 11 2012 12:43:38

MainLoop hangs ie: no widgets are displayed. 

#!/usr/local/bin/perl

use Tk;
use Tk::ROText;
use Tk::Text;
use Tk::Balloon;
use Tk::Listbox;
use Tk ':eventtypes';
use strict;

use lib ".";
use lib 'J:\\myWebPage\\WPMC\\files\\DB\\';
use walk_locations;
my %walkLoc = walk_locations->new();

use vars qw($inFile $outFile $formHandler);

my $main = MainWindow->new();
$main->configure (-title=>'WPMC Walk List');

my $topFrame = $main->Frame (-relief=>'sunken', -borderwidth=>1);
my $lftFrame = $main->Frame (-relief=>'sunken', -borderwidth=>1);
my $midFrame = $main->Frame (-relief=>'sunken', -borderwidth=>1);
my $rgtFrame = $main->Frame (-relief=>'sunken', -borderwidth=>1);
my $botFrame = $main->Frame (-relief=>'sunken', -borderwidth=>1);
my $butFrame = $botFrame->Frame (-label=>'', -relief=>'raised', -borde
+rwidth=>1);

$topFrame->pack(-side=>'top',  -anchor=>'w', -fill=>'both');
$lftFrame->pack(-side=>'top',  -anchor=>'e', -fill=>'both');
$midFrame->pack(-side=>'top',  -anchor=>'center', -fill=>'both');
$rgtFrame->pack(-side=>'top',  -anchor=>'w', -fill=>'both');
$botFrame->pack(-side=>'bottom',  -anchor=>'w', -fill=>'both');
$butFrame->pack(-side=>'left', -anchor=>'w', -fill=>'both');

###
# submit/exit buttons
###
my @button;
$button[0] = $butFrame->Button(-text=>'Submit', -command=>\&submit, -f
+g=>"darkgreen", -background=>"ivory", -activebackground=>'lightgreen'
+);
$button[1] = $butFrame->Button(-text=>'Exit', -command=>sub{exit}, -fg
+=>"darkred", -background=>"ivory", -activebackground=>"indianred");
$button[2] = $butFrame->Button(-text=>'Help', -command=>[\&help], -fg=
+>"orange", -activebackground=>"wheat", -background=>"ivory");

$button[0]->pack(-side=>'right', -anchor=>'e', -fill=>'none');
$button[1]->pack(-side=>'right', -anchor=>'e', -fill=>'none');
$button[2]->pack(-side=>'right', -anchor=>'e', -fill=>'none');

# Create the balloon widget
my $b = $butFrame->Balloon(-statusbar => my $status);

$b->attach($button[0], -msg => 'Create e-mail list');
$b->attach($button[1], -msg => 'Exit This Program');
$b->attach($button[2], -msg => 'General Help Screen');

# Listbox
my $label1 = $midFrame->Label(-text => "By Location", -anchor => 'e')-
+>pack(-side=>'left' );
my $listbox = $midFrame->Listbox(-fg=>"darkblue", -background=>"ivory"
+, -height=>-1)->pack(-side=>'left');
getList (my @list);
$listbox->insert('end', @list );
$listbox->selectionSet(1);
#$listbox->curselection

my $label2 = $topFrame->Label(-text => "Distance")->pack();
my $distance = $topFrame->Entry(-fg=>"darkblue", -background=>"ivory")
+->pack();

my $label6 = $topFrame->Label(-text => "City")->pack();
my $city = $topFrame->Entry(-fg=>"darkblue", -background=>"ivory")->pa
+ck();

my $label7 = $topFrame->Label(-text => "State", -anchor => 'center')->
+pack();
my $state = $topFrame->Entry(-fg=>"darkblue", -background=>"ivory")->p
+ack();

my $label3 = $topFrame->Label(-text => "Zip Code", -anchor => 'center'
+)->pack();
my $zipCode = $topFrame->Entry(-fg=>"darkblue", -background=>"ivory")-
+>pack();

my $label4 = $topFrame->Label(-text => "Latitude", -anchor => 'center'
+)->pack();
my $latitude = $topFrame->Entry(-fg=>"darkblue", -background=>"ivory")
+->pack();

my $label5 = $topFrame->Label(-text => "Longitude", -anchor => 'center
+')->pack( );
my $longitude = $topFrame->Entry(-fg=>"darkblue", -background=>"ivory"
+)->pack();

#defauts
$distance->insert('end', '15');

#Geometry Management
$label2 -> grid(-row=>1,-column=>1);
$distance -> grid(-row=>1,-column=>2,-sticky=>"ns");

$zipCode -> grid(-row=>2,-column=>6,-sticky=>"ns");

$longitude -> grid(-row=>3,-column=>4,-sticky=>"ns");
print "@ main loop\n";
#MainLoop;
while (MainWindow->Count)
{
    print MainWindow->Count,"\n";
    DoOneEvent(ALL_EVENTS);
    #$MainWindow->update();
}

sub submit ()
{
   my %args;
   my $hash;
   my $key;
   my $value;
   my $argv;

   $args{distance}{value}   = $distance->get();

   $args{city}{value}       = $city->get();
   $args{state}{value}      = $state->get();
   $args{zipCode}{value}    = $zipCode->get();
   $args{latitude}{value}   = $latitude->get();
   $args{longitude}{value}  = $longitude->get();

   $args{distance}{argv}   = "-distance=";
   $args{city}{argv}       = "-city=";
   $args{state}{argv}      = "-state=";
   $args{zipCode}{argv}    = "-zip=";
   $args{latitude}{argv}   = "-latitude=";
   $args{longitude}{argv}  = "-longitude=";

   print "--------------------------------------\n$args{distance}{valu
+e}\n";

    my $argString = "";
     while ( ($key, $hash) = each %args )
     {
        print "-->{$key}: \n";
        while ( ($argv, $value) = each %$hash )
        {
         print "inside $argv\n";
         if ($value=~/\s*/==1)
           {    print "true value = ".$value."\t". $value=~/\s*/==1,"\
+n";}
            elsif ($value=~/\s*/!=1)
            {    print "false value = ".$value."\t". $value=~/\s*/==1,
+"\n";}
            else
            {    print "fail all\n";}
        }
        print "\n";
    }

   #print 'perl.exe "J:\myWebPage\WPMC\files\DB\zip.pl" '.$argString;
}

sub help ()
{
   ;
}

sub getList (@)
{
   ###
   #  Walk locations
   ###

   my $key;
   my $value;
   while (($key, $value) = each(%walkLoc))
   {  push (@list, $key);}
}

[download]
package walk_locations;
    use strict;
    use warnings;
    BEGIN {
        require Exporter;
        # set the version for version checking
        our $VERSION     = 0.01;
        # Inherit from Exporter to export functions and variables
        our @ISA         = qw(Exporter);
        # Functions and variables which are exported by default
        our @EXPORT      = qw(new);
        # Functions and variables which can be optionally exported
        our @EXPORT_OK   = qw();
    }
    # exported package globals go here
     ##
        #  Walk locations
        ###
        my %walkLoc = (
        # $degrees + ($minutes/60) + ($seconds/3600)
           Mingo => {
              lat => '40.2041666666667)',
              lon => '-80.0272222222222',},
           Hartwood => {
              lat => '40.5553',
              lon => '-79.9094',},
           DeerLakes => {
              lat => '40.62118209953078)',
              lon => '-79.82713968655357',},
           NorthPark => {
              lat => '40.6036',
              lon => '-80.0169',},
           CoopersRocks => {
              lat => '39.65556',
              lon => '-79.78806',},
           BradysRun => {
              lat => '40.76',
              lon => '-80.32',},
           FallRun => {
              lat => '40.534',
              lon => '-79.9471',},
           Shawnee => {
              lat => '40.03',
              lon => '-78.64',},
           SouthPark => {
              lat => '40.30',
              lon => '-80.00',},
           Moraine => {
              lat => '40.966',
              lon => '-80.1308',},
           BlueKnob => {
              lat => '40.27861',
              lon => '-78.58139',},
           Emmerling => {
              lat => '40.581390',
              lon => '-79.861670',},
           Jennings => {
              lat => '41.0071',
              lon => '-80.0079',},
           Hampton => {
              lat => '40.5886',
              lon => '-79.937',},
           OhioPyle => {
              lat => '39.872',
              lon => '-79.492',},
           DockHollow => {
              lat => '40.69861',
              lon => '-79.66944',},
           FrickPark => {
              lat => '40.4323',
              lon => '-79.9049',},
           TwinLakes => {
              lat => '40.3217356',
              lon => '-79.4772611',},
           test => {
              lat => '40.0',
              lon => '-80',},
        );

        sub new2 {
          my $package = shift;
          return bless({}, $package);
        }

        sub new1 {
            my ( $class, %args ) = @_;
            my $self = {};
            bless( $self, $class );
            return $self;
        }

        sub new()
        {
            return %walkLoc;
        }

END {;}       # module clean-up code here (global destructor)
    1;            # don't forget to return a true value from the file

[download]

Replies are listed 'Best First'.
Re: perl tk MainLoop hangs
by hdb (Monsignor) on Apr 30, 2013 at 14:48 UTC

    MainLoop waits for something to happen but in your example nothing will ever happen. If you add a button, you can see that the script is still responsive. 

    use strict;
use warnings;
use Tk;

my $mw = new MainWindow(-background=>'Gray');
my $btn = $mw->Button(
        -text    => "Exit",
        -command => sub {  print "Button pressed\n"; } )->pack(); 
MainLoop;

    [download]

    UPDATE: In other words, you need to completely set up your application, GUI and response functions and then call MainLoop. MainLoop will watch the GUI and react to any user interaction by executing the provided callback functions.

    If you knew this all already, then there must be a bug in your program elsewhere.

[reply]
[d/l]
Re: perl tk MainLoop hangs
by Anonymous Monk on Apr 30, 2013 at 14:40 UTC

    The script runs without error upto the MaonLoop

    Yes, MainLoop is supposed to hang, that's what MainLoop does

[reply]

Back to Seekers of Perl Wisdom