Tk::LabEntry - how to reach the configuration of label via callback?

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

Hi All,

I try to validate the content of entry in Tk::LabEntry widget. I would like to change the configuration of the label part if the content is not a number (simply to color it red). I can do this with the background of the entry (code below), however an attempt to reach the option -labelBackground produces an error message "unknown option".

I know that Tk::LabEntry is a Mega-Widget. I cannot find a way to reach its configuration (that is, the label part) via callback. It would work if I call the widget by name (that is, $le->configure(-labelBackground => 'red'); would do the job in the code below). I would like to stick with callback however since I have several such widgets in the real application.

Please give me an advice. Thank you!

#!/perl
use strict;
use warnings FATAL => qw(all);

use Tk;
use Tk::LabEntry;

use List::Util qw(first); 
use Scalar::Util qw(looks_like_number);

my $mw = MainWindow->new();
$mw->title("Test");
my $test = 8;
my $width = 250; my $length = 125;
$mw->minsize($width, $length);

my $FONT = $mw->fontCreate(-family => 'verdana', 
     -size => 14, -weight => 'normal');

my $le = $mw->LabEntry(-label => 'Value',
           -labelPack => [qw/-side left -anchor w/],
       -labelFont => '9x15bold', 
           -font => $FONT,
       -relief => 'ridge',
           -textvariable => \$test,
       -width => 2,
 )->pack();
$le->bind('<Key>' => sub { labelCheck($_[0]);});

MainLoop;

sub labelCheck
{
  my $x = $_[0]->get(); 
  if ( !(looks_like_number($x)) or ($x < 0) )
  {
    $_[0]->delete(0, 'end');
    $_[0]->configure( -background => 'red');
    # $_[0]->configure( -labelBackground => 'red');
  }
  else
  {
    $_[0]->configure( -background => '#f0f0f0',);
    # $_[0]->configure( -labelBackground => '#f0f0f0');
    do_something();
  }
  return 1; 
}

sub do_something { print $test, $/; }
[download]

Comment on Tk::LabEntry - how to reach the configuration of label via callback? Select or Download Code

Replies are listed 'Best First'.
Re: Tk::LabEntry - how to reach the configuration of label via callback? by beech (Parson) on Feb 07, 2016 at 21:43 UTC
If you add a few print/warn statements, you can see that $le is Tk::LabEntry=HASH(0x10b7f8c) but that the bind callback gets a Tk::Entry=HASH(0x10d47cc) You could use Tk::Widget method parent to get back to LabEntry, like this `$_[0]->parent->configure( -labelBackground => 'red');`	[reply] [d/l]
Re^2: Tk::LabEntry - how to reach the configuration of label via callback? by vagabonding electron (Curate) on Feb 08, 2016 at 17:38 UTC
This works as expected, thank you very much!	[reply]
Re: Tk::LabEntry - how to reach the configuration of label via callback? by capfan (Sexton) on Feb 08, 2016 at 13:33 UTC
Hi! Yuu could also use the subwidget command on the LabEntry: #!/perl use strict; use warnings FATAL => qw(all); use Tk; use Tk::LabEntry; use List::Util qw(first); use Scalar::Util qw(looks_like_number); my $mw = MainWindow->new(); $mw->title("Test"); my $test = 8; my $width = 250; my $length = 125; $mw->minsize($width, $length); my $FONT = $mw->fontCreate(-family => 'verdana', -size => 14, -weight => 'normal'); my $le = $mw->LabEntry(-label => 'Value', -labelPack => [qw/-side left -anchor w/], -labelFont => '9x15bold', -font => $FONT, -relief => 'ridge', -textvariable => \$test, -width => 2, )->pack(); $le->bind('<Key>' => sub { labelCheck($_[0]);}); MainLoop; sub labelCheck { my $x = $_[0]->get(); if ( !(looks_like_number($x)) or ($x < 0) ) { $_[0]->delete(0, 'end'); my $label = $le->Subwidget('label'); $label->configure( -background => 'red'); # $_[0]->configure( -labelBackground => 'red'); } else { $_[0]->configure( -background => '#f0f0f0',); # $_[0]->configure( -labelBackground => '#f0f0f0'); do_something(); } return 1; } sub do_something { print $test, $/; } [download]	[reply] [d/l]
Re^2: Tk::LabEntry - how to reach the configuration of label via callback? by vagabonding electron (Curate) on Feb 08, 2016 at 17:46 UTC
Hi capfan and thank you very much for your help. The code works. However it calls the certain LabEntry from within the callback (with `$le->Subwidget('label')`). What I am trying to do is to create the same behavior for several LabEntry's, therefore I do not want to call the specific widget by name. The proposal of beech with `$_[0]->parent->configure` seems to meet this requirement.	[reply] [d/l] [select]
Re^3: Tk::LabEntry - how to reach the configuration of label via callback? by capfan (Sexton) on Feb 10, 2016 at 20:53 UTC
Yeah, that was just lazyness, sorry. You can substitute the `$le` by `$_[0]->parent`. You can see what is inside `$_[0]` by checking `@_`: #!/perl use strict; use warnings FATAL => qw(all); use Tk; use Tk::LabEntry; use Data::Dumper qw/Dumper/; use List::Util qw(first); use Scalar::Util qw(looks_like_number); my $mw = MainWindow->new(); $mw->title("Test"); my $test = 8; my $width = 250; my $length = 125; $mw->minsize($width, $length); my $FONT = $mw->fontCreate(-family => 'verdana', -size => 14, -weight => 'normal'); my $le = $mw->LabEntry(-label => 'Value', -labelPack => [qw/-side left -anchor w/], -labelFont => '9x15bold', -font => $FONT, -relief => 'ridge', -textvariable => \$test, -width => 2, )->pack(); $le->bind('<Key>' => sub { labelCheck($_[0]);}); MainLoop; sub labelCheck { print Dumper \@_; my $x = $_[0]->get(); if ( !(looks_like_number($x)) or ($x < 0) ) { $_[0]->delete(0, 'end'); my $label = $_[0]->parent->Subwidget('label'); $label->configure( -background => 'red'); # $_[0]->configure( -labelBackground => 'red'); } else { $_[0]->configure( -background => '#f0f0f0',); # $_[0]->configure( -labelBackground => '#f0f0f0'); do_something(); } return 1; } sub do_something { print $test, $/; } [download] For me, this returned: `$VAR1 = [ bless( { '_TkValue_' => '.labentry.entry', '_XEvent_' => bless( do{\(my $o = ' $ �� +� �� T� t � A a A (� \ +'�� a �� "�Ԍ')}, 'XEvent' ) }, 'Tk::Entry' ) ];` [download] It's a `Tk::Entry` inside a LabEntry (cf. `.labentry.entry`).	[reply] [d/l] [select]


laziness, impatience, and hubris
	PerlMonks