Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses

Re: Tk::Gauge errors

by zentara (Archbishop)
on Aug 06, 2012 at 09:08 UTC ( #985634=note: print w/replies, xml ) Need Help??

in reply to Tk::Gauge errors

Hi, I see the same error as you on both versions of the script. I'm on Linux with Perl 14.2.

I don't know the reason it is happening, but you can make a workaround by making your toplevel window reusable, inhibiting its Window Manager's Close icon, and packForgetting its old widgets. This works for me. ( the code could use some cleanup, but it shows the way) :-)

#!/usr/bin/perl -w use Tk; use Tk::Table; use Tk::Gauge; use strict; use diagnostics; my $hw; # make a reusable toplevel my $mw = MainWindow->new; $mw->geometry("75x75"); $mw->title("Gauge testing"); my $button = $mw->Button(-text => "Null", -command => \&button3_sub)-> +pack(-anchor=>'center'); my ($alpha,$alphaone,$beta,$betaone,$mh,$output_text,$gaugevar,$cur); #our ($alpha,$alphaone,$beta,$betaone,$mh,$output_text,$gaugevar,$cur) +; sub button3_sub { $mh= (35+(29-1)*6); $cur=$mh; do_Toplevel(); #my $hw = $mw -> Toplevel; $hw ->geometry("650x450"); $hw ->title('Health Track (!!!WARNING:DO NOT EXIT THIS WINDOW UNTIL DO +NE)'); my $hf = $hw -> Frame(-background => 'white')->pack(-ipadx => 250, -fi +ll => 'both', -expand =>'yes'); my $left_frame = $hf -> Frame (-background=>'white')->pack(-side=>'lef +t', -fill => 'y'); my $right_frame = $hf->Frame(-background=>'white')->pack(-ipadx=>150, +-fill =>'y', -anchor=>'n',-expand=>1); $betaone = $left_frame->Entry(-background => "green",)->pack( +-anchor=>'nw'); my $beta_button = $left_frame->Button(-text => "Alpha Null", - +command => \&update_output)->pack(-anchor=>'nw'); $alphaone = $left_frame->Entry(-background => "red",)->pack(- +anchor=>'nw'); my $alpha_button = $left_frame->Button(-text => "Alpha Null", +-command => \&update_output)->pack(-anchor=>'nw'); $output_text = $left_frame->Text(-height=>5,-width=>15)->pack( +-expand=>0,); my $gauge= $right_frame->Gauge( -background => 'white', -bands =>[ { -piecolor => 'green', -minimum=> 50, -maximum=> 100, -tag=> 'Healthy', }, { -piecolor => 'yellow', -minimum=> 25, -maximum=> 50, -tag=> 'Bloodied', }, { -piecolor => 'red', -minimum=> 0, -maximum=> 25, -tag=> 'Critical', } ], -bandplace => 'underticks', -bandstyle=> 'pieslice', -bandwidth=> 0, -caption => 'Current Value', -captioncolor=> 'black', -extent => -180, -from => 0, -hubcolor => 'black', -huboutline => 'blue', -hubradius => 15, -majortickinterval => 10, -majorticklabelplace =>'outside', -finetickinterval => 1, -minortickinterval => 5, -margin =>40, -needles => [ { -arrowshape => [ 12, 23, 6 ], -color => 'black', -command => undef, -format => '%d', -radius => 196, -showvalue => 1, -tag => 'null', -title => 'null', -titlecolor => 'white', -titlefont =>'Helvetica-12', -titleplace => 'south', -variable => \$gaugevar, -width => 5, } ] , -start => 180, -to => 100, )->pack(-fill=>'both',-expand=>1); ##my $gaugebutton1 = $left_frame ->Button(-text => "Update", -command +=> \&gaugebutton1_sub)->pack(-side=>'bottom'); #currently pointless. +will leave in for possible diagnostics. } sub gaugebutton1_sub { $gaugevar=($cur/$mh)*100; }#above sub redundant(?) due to &update_output# sub update_output { my $beta = $betaone->get(); my $alpja = $alphaone->get(); if ($alpha eq "") { $alpha = 0; } if ($beta eq "") { $beta = 0; } $cur=$cur+$beta-$alpha; if ($cur gt $mh){$cur=$mh;} if ($cur lt 0){$cur=0;} my $output = "Current value:\n$cur"; $output_text->delete('0.0', 'end'); $output_text->insert("end", $output); $betaone->delete('0.0', 'end'); $alphaone->delete('0.0', 'end'); $gaugevar=($cur/$mh)*100; } MainLoop; ###end sub do_Toplevel { if ( !Exists( $hw ) ) { $hw = $mw->Toplevel(); $hw->protocol('WM_DELETE_WINDOW' => sub {}); #prevent WM close + button working $hw->title( "Toplevel" ); $hw->Button( -text => "Close", -command => sub { $hw->withdraw } )->pack; } else { #clear out old widgets my @w = $hw->packSlaves; foreach (@w) { $_->packForget; } $hw->Button( -text => "Close", -command => sub { $hw->withdraw } )->pack; $hw->deiconify(); $hw->raise(); } }

I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh

Replies are listed 'Best First'.
Re^2: Tk::Gauge errors
by Anonymous Monk on Aug 06, 2012 at 11:06 UTC

    Thank you so much zentara, from the testing I've done so far, the script changes work for me as well (although I did find out there was a typoed variable name in the process). I assume that I can extract the do_TopLevel sub and use it in places that are causing similar issues, replacing the variable names as needed? I'll likely continue stalking this to see if someone can figure out what's causing it. To which I'll ask: is it worth sending a bug report to the module page on CPAN even though it appears to have been left to gather dust by the author?

      As far as reusing that sub by replacing variable names, sure, Perl is free to modify.

      What I originally used it for, was I had problems with toplevels accumulating memory, even though they were being destroyed. This may be a another symptom of that.

      Tk::Gauge is old, and I doubt the author, has high priorities for it. A bug report can't hurt, but a better thing would be to offer to take over the module and fix it. :-)

      I'm not really a human, but I play one on earth.
      Old Perl Programmer Haiku ................... flash japh

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://985634]
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (3)
As of 2018-02-25 14:46 GMT
Find Nodes?
    Voting Booth?
    When it is dark outside I am happiest to see ...

    Results (312 votes). Check out past polls.