in reply to Re: Perl Tk freezes when command button is clicked !
in thread Perl Tk freezes when command button is clicked !

Its a quite big program and i thought it'll mess up the forum. Anyways i'll post the entire program now. 

my $i=1;
my $array_var;
my $window = MainWindow->new;
$window->title("Breadcrumb Buster");
$window->geometry("600x850");
#my $window=$window->Frame()->pack();
my $lbl_var_1 = $window -> Label(-text=>"Enter the keyword: ")->pack()
+;
my $txt_var_1 = $window -> Entry()->pack(-pady=>20);
my $btn_var_1 = $window -> Button(-text => "Get Breadcrumb !", -comman
+d => \&Getbread)->pack();

$array_var->{"0,0"} = "Sno";
$array_var->{"0,1"} = "Manufacturer Name";
$array_var->{"0,2"} = "Manufacturer URL";
$array_var->{"0,3"} = "Breadcrumb";
my $table = $window->Scrolled('TableMatrix', -cols=>4, -drawmode=>'fas
+t', -variable => $array_var,-state=>"disabled", -flashtime=>0.25,-fla
+shmode=>1,-resizeborders => 'both',-colstretchmode => 'unset', -rowst
+retchmode => 'last')->pack(-pady=>20, -fill=>'x');
$table->configure(-height=>"200");
#$table->rowHeight(0,1);
$table->tagRow('title',0);
$table->tagConfigure('title', -bd=>2, -relief=>'raised');
$table->tagConfigure('OddRow', -bg => 'white', -fg => 'purple');
#$table->colWidth(0,5,3,6,4,10);

sub Getbread()
{
    my $bread;
    my $input_keyword=$txt_var_1->get();
    print "$input_keyword\n";
    my $query_url="http://www.google.com/products?as_q=$input_keyword&
+as_epq=&as_oq=&as_eq=&num=100&scoring=r&as_occt=any&price1=&price2=&s
+how=dd&safe=active";
    loop:
    my $content=&Geturl($query_url);
    while($content=~m/<li\s*class\=\"result\"[^>]*?>([\w\W]*?)<\/li>/i
+gs)
    {
        my ($temp_content, $cse_url, $cse_url_temp, $cse_url_old, $pro
+duct_title, $new_price, $used_price, $number_sellers, $cse_content, $
+mer_url, $merchant_name);
        $temp_content=$1;
        if($temp_content=~m/\"result\-seller\">\s*from\s*[\d]+\s*selle
+rs/is)
        {
            if($temp_content=~m/<h3\s*class\=\"result\-title\">\s*<a\s
+*href\=\"([^>]*?)\"\s*>\s*([\w\W]*?)\s*<\/h3>/is)
            {            
                $cse_url_temp=$1;
                $product_title=$2;
                $cse_url="http://www.google.com".$cse_url_temp;
                decode_entities($cse_url);
                $product_title=~s/<[^>]*?>//igs;
                decode_entities($product_title);
                $product_title=~s/\'/\'\'/igs;
            }
            $cse_url=~s/\#p/\&os\=sellers\#p/igs;
            $cse_url_old=$cse_url;
            paging:
            $cse_content=&Geturl($cse_url);
            while($cse_content=~m/(<tr[^>]*?id\=\"[^>]*?>[\w\W]*?<\/sp
+an>\s*<\/td>\s*<\/tr>)/igs)
            {
                my ($yahoo_store, $meta_keyword, $meta_description, $m
+erchant_content, $online_since, $alexa_rank, $merchant_status,  $merc
+hant_url_temp, $merchant_url, $merchant_name, $temp_cse_content);
                $temp_cse_content=$1;
                if($temp_cse_content=~m/\"seller\-name\"><a\s*href\=\"
+[^>]*?\?q\=(http(?:s)?\:\/\/[^>]*?\/[^>]*?)\&fr[^>]*?\"\s*>([\w\W]*?)
+<\/a>/is)
                {
                    $mer_url=$1;
                    $merchant_name=$2;
                    $merchant_name=decode_entities($merchant_name);
                    $merchant_name=~s/\'/\'\'/igs;
                    $mer_url=uri_unescape($mer_url);                  
+  
                }
                $bread=&Get_merchant($mer_url);
                
            }
        }
        elsif($temp_content=~m/<h3\s*class\=\"result\-title\">\s*<a\s*
+href\=\"([^>]*?)\"\s*>\s*([\w\W]*?)\s*<\/h3>/is)
        {
            $cse_url_temp=$1;
            $cse_url_temp=uri_unescape($cse_url_temp);
            $merchant_name=$2;
            if($cse_url_temp=~m/q\=([^>]*?)\&fr/is)
            {
                $mer_url=$1;
                $mer_url=uri_unescape($mer_url);
            }
            $merchant_name=~s/<[^>]*?>/ /igs;
            $bread=&Get_merchant($mer_url);    
                
        }
        if($bread ne "")
        {
            $array_var->{"$i,0"} = $i ;
            $array_var->{"$i,1"} = "$merchant_name";
            $array_var->{"$i,2"} = "$mer_url";
            $array_var->{"$i,3"} = "$bread";            
            $i++;
            print "\n$merchant_name";
            last if $i==6;
        }        
    }
}

sub Geturl()
{
    my $url=shift;
    $url=uri_unescape(uri_unescape(uri_unescape($url)));
    start:
     my $req=HTTP::Request->new(GET => "$url");
    $req->header("Content-Type"=> "application/x-www-form-urlencoded")
+;
    my $res=$ua->request($req);
    my $con=$res->content(); 
    
    if($con=~m/<form\s*action\=\"Captcha\"/is)
    {
        print "\nGoogle Blocked - Now Sleeping...";
        sleep(1200);
        goto start;
    }
    return $con;
}

sub Get_merchant()
{
    my $merchant_url=shift;
    my $breadcrumb;
    my $merchant_content=&Geturl($merchant_url);
    if($merchant_content=~m/<h1\s*class\=\"breadcrumbfull\">\s*([\w\W]
+*?)\s*<\/h1>/is)
    {
        $breadcrumb=$1;
    }
    elsif($merchant_content=~m/<div[^>]*?(?:bread|crumb)[^>]*?>\s*([\w
+\W]*?)\s*<\/div>/is)
    {
        $breadcrumb=$1;
    }    
    elsif($merchant_content=~m/<td[^>]*?NavPath[^>]*?>\s*([\w\W]*?)\s*
+<\/td>/is)
    {
        $breadcrumb=$1;
    }
    $breadcrumb=~s/<[^>]*?>//igs;
    decode_entities($breadcrumb);
    $breadcrumb=~s/\'/\'\'/igs;
    chomp($breadcrumb);
    return $breadcrumb;    
}

MainLoop;

[download]

Replies are listed 'Best First'.
Re^3: Perl Tk freezes when command button is clicked !
by zentara (Cardinal) on Feb 17, 2010 at 13:21 UTC
    Your problem is a common one, in all gui toolkits, it's called "blocking the event loop". All gui's use an event loop, that is why they can be responsive to button clicks, etc. When you put a sleep statement, or do something which is long and intensive like getting a url thru a slow netlink, the event loop will freeze until it regains control. This can be shown is the following example. After 2.5 seconds, it will freeze for 5 seconds 
    #!/usr/bin/perl
use Tk;

my $mw = MainWindow->new;
$mw->geometry('100x100+100+100');
#$mw->overrideredirect(1);

my @color = qw/red green/;

my $bits = pack("b8"x8,
"...11...",
"..1111..",
".111111.",
"11111111",
"11111111",
".111111.",
"..1111..",
"...11...",);

$mw->DefineBitmap('indicator' => 8,8, $bits);

my $label = $mw->Label(
              -bitmap=>'indicator', 
          -bg=>'black',
          -fg=>'red',
          )->pack;

$mw->repeat(500,sub{$label->configure(
                               -fg=>$color[0]);
                               @color=reverse(@color);
 });


# put in simulated eventloop blocker after 2.5 seconds
# to freeze tk for 5 seconds
$mw->after(2500,sub{ sleep (5)  });

MainLoop;

    [download]
    There are many ways around this problem. First never use sleep in a gui app, unless it's in a thread. Second, put your url_fetching operations into threads or fork them off. You can try to manually pump the loop by liberally sprinkingly DoOneEvent(); in areas where the code is in a delay loop( like your in while( $fh ). Finally, use Tk::fileevent to read your filehandles, instead of a while loop. Use timers when needing delays, like Tk::repeat.

    There are many examples out there on google for using Tk with threads and shared variables. See Tk events by Lidie and a few examples of using threads and fileno's with Tk ztk-BBC-World-News-Rss-TickerTape and Re^3: Passing globs between threads

    I'm not really a human, but I play one on earth.
    Old Perl Programmer Haiku
[reply]
[d/l]

      As an alternative to using threads, it is also possible to unblock the event loop by manually calling $mw->update() at frequent intervals to alllow the GUI to update, respond etc. This may or may not be easier/better for you, depending on what you are trying to do. I think it doesn't matter what Tk object you call the update() method on, although I usually use the main window.

      --

      "Any sufficiently analyzed magic is indistinguishable from science" - Agatha Heterodyne

[reply]
[d/l]
[select]
        The problem with using $mw->update or DoOneLoop() is that they still will block on slow network calls that are sluggish. When you use $lwp->get( $url), there is no place to insert the update, unless you use the more extended manual callback available in lwp, as shown in 
        #!/usr/bin/perl -w
use strict;
use LWP::UserAgent;

# don't buffer the prints to make the status update
$| = 1;

my $ua = LWP::UserAgent->new();
my $received_size = 0;
my $url = 'http://www.cpan.org/authors/id/J/JG/JGOFF/parrot-0_0_7.tgz'
+;
print "Fetching $url\n";
my $request_time = time;
my $last_update = 0;
my $response = $ua->get($url,
                        ':content_cb'     => \&callback,
                        ':read_size_hint' => 8192,
                       );
print "\n";

sub callback {
  my ($data, $response, $protocol) = @_;

  my $total_size = $response->header('Content-Length') || 0;
  $received_size += length $data;

  my $time_now = time;

  # this to make the status only update once per second.
  return unless $time_now > $last_update or $received_size == $total_s
+ize;
  $last_update = $time_now;

  print "\rReceived $received_size bytes";
  printf " (%i%%)", (100/$total_size)*$received_size if $total_size;
  printf " %6.1f/bps", $received_size/(($time_now-$request_time)||1)
     if $received_size;
}

        [download]
        If you don't put your update calls into that callback, it will still block Tk until the get returns. And if the get() hangs, your Tk program could be hung forever, unless you set timers on it.

        But it really is easier just to use a thread. :-)

        I'm not really a human, but I play one on earth.
        Old Perl Programmer Haiku
[reply]
[d/l]
      always i love your code zentara ; it is lucid and educational
      thanks
[reply]

In Section Seekers of Perl Wisdom