I am using the perl Tk interface where I want to have a button test_1 and upon clicking on this button I would like a variable $varchoice to be defined as test_1. If I press on the button test_2, the variable $varchoice should be defined as test_2.
Before is the snippet of code in which I attempted to accomplish this:
$budget_frame->Button(-text => 'test_1',-command => sub{$varchoice=budget_plot_1()})->pack(-side => "left");
$budget_frame->Button(-text => 'test_2',-command => sub{$varchoice=budget_plot_2()})->pack(-side => "left");
sub budget_plot_1()
{
print "plotting 1\n";
my $var=1;
return $var;
}
sub budget_plot_2()
{
print "plotting 2\n";
my $var=2;
return $var;
}
How do I tweak this code to get the desired results?
Your program seems to work fine. Here is an example of how I tested it:
use feature qw(say);
use strict;
use warnings;
use Tk;
my $budget_frame = MainWindow->new(-title=>"Button test");
my $varchoice;
$budget_frame->Button(
-text => 'test_1',
-command => sub{ $varchoice = budget_plot_1() }
)->pack(-side => "left");
$budget_frame->Button(
-text => 'test_2',
-command => sub{ $varchoice = budget_plot_2() }
)->pack(-side => "left");
MainLoop;
say "Value of \$varchoice = $varchoice";
sub budget_plot_1()
{
print "plotting 1\n";
return "test_1";
}
sub budget_plot_2()
{
print "plotting 2\n";
return "test_2";
}
Output:
Value of $varchoice = test_1
Related
I'm trying to replace a problematic and long snippet of code in Perl to something like this:
my $disp = {
option1 => sub { if(true){$disp->{option2}->();}},
option2 => sub { print "opt 2\n"},
option3 => sub { print "opt 3\n"},
default => sub { print "default\n" },
};
$disp->{($disp->{$option})?$option:'default'}->(#args);
My problem occurs when I need to execute for example option2 when the execution is inside option1, but I can't access $disp within $disp and $self isn't present, ideas?
Just declare the variable in a previous statement so you can use it in the next one:
my $disp;
$disp = {
option1 => sub { if(true){$disp->{option2}->();}},
option2 => sub { print "opt 2\n"},
option3 => sub { print "opt 3\n"},
default => sub { print "default\n" },
};
$disp->{($disp->{$option})?$option:'default'}->(#args);
Also, I'd probably write the last line as
($disp->{$option} || $disp->{default})->(#args);
Given this Perl/Tkx code fragment:
#itemList = ({'attrib1' => 'name1', 'attrib2' => 'value1'},
{'attrib1' => 'name2', 'attrib2' => 'value2'});
$row = 0;
foreach $item (#itemList) {
push(#btn_list, new_ttk__button(-text => $item->{'attrib1'}, -command => sub {do_something($item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
(In the real program #itemList is populated from a user editable config file.)
I do see two buttons labeled 'name1' and 'name2'. But when I click on either button it seems that the parameter that is passed to the callback is always $itemList[1]->{'attrib2'}; i.e. 'attrib2' of the last element of the #itemList array. What I would like is to have the first button call do_something($itemList[0]->{'attrib2'} and the second call do_something($itemList[1]->{'attrib2'}.
What am I doing wrong, please and thank you?
You have encountered a subtle feature of for loops in Perl. First the solution: use my in the for loop. Then $item will be able to create a proper closure in the anonymous sub you declare later in the loop.
for my $item (#itemlist) {
push(#btn_list, new_ttk__button(
-text => $item->{'attrib1'},
-command => sub {do_something($item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
Further explanation: Perl implicitly localizes the subject variable of a for loop. If you don't use my in the for loop, the loop will be using a localized version of a package variable. That makes your code equivalent to:
package main;
$main::item = undef;
#itemList = ({'attrib1' => 'name1', 'attrib2' => 'value1'},
{'attrib1' => 'name2', 'attrib2' => 'value2'});
$row = 0;
foreach (#itemList) {
local $main::item = $_;
push(#btn_list, new_ttk__button(
-text => $main::item->{'attrib1'},
-command => sub {do_something($main::item->{'attrib2'});}));
$btn_list[-1]->g_grid(-column => 0, -row => $row);
$row++;
}
# at the end of the loop, value of $main::item restored to undef
Your anonymous subs still refer to the $main::item package variable, whatever value that variable holds at the time that those subroutines are invoked, which is probably undef.
Shorter solution: use strict
Additional proof-of-concept. Try to guess what the following program outputs:
#foo = ( { foo => 'abc', bar => 123 },
{ foo => 'def', bar => 456 } );
my #fn;
foreach $foo (#foo) {
push #fn, sub { "42" . $foo->{bar} . "\n" };
}
foreach my $foo (#foo) {
push #fn, sub { "19" . $foo->{foo} . "\n" };
}
print $_->() for #fn;
Here's the answer:
42
42
19abc
19def
I have a GUI that runs a script from a command button, but how can I get it to display output in the text widget?
If I wanted to display the output via a logfile insert, could I have the command on the same button/sub as the run button?
use warnings;
use strict;
use Tk;
use Tk::Text ;
use POSIX 'strftime';
my $DATE = strftime("Report.pl for %dth %b %Y" , localtime());
my $mw = MainWindow->new;
my $filename = "c:\\Temp\\perl.txt";
$mw->geometry("720x500");
$mw->title(" backupadmin ");
my $main_frame = $mw->Frame()->pack(-side => 'top', -fill => 'x');
my $left_frame = $main_frame->Frame(-background => "snow2")->pack(-side => 'left', -fill => 'y');
my $right_frame = $main_frame->Scrolled("Text", -scrollbars => 'se',-background => "black",-foreground => "yellow",-height => '44')->pack(-expand => 1, -fill => 'both');
my $failures_button = $left_frame->Button(-text => " $DATE ",
-command => [\&runscript])->pack;
my $Close_button = $left_frame->Button(-text => ' Close ',
-command => [$mw => 'destroy'])->pack;
my $Help_button = $left_frame->Button(-text => " Help Guide ",
-command => [\&load_file])->pack(-side => "bottom");
my $Close_help = $left_frame->Button(-text => ' Close Help ',
-command => [$right_frame => \&clear_file])->pack(-side => "bottom");
MainLoop;
sub runscript {
system("report.pl");
}
sub load_file {
open (FH, "$filename");
while (<FH>) { $right_frame->insert("end", $_); }
close (FH);
}
sub clear_file {
$right_frame->('quit');
}
If your report.pl script outputs to STDOUT, then you could try something like this in your runscript callback:
sub runscript {
right_frame->delete('1.0','end');
my $text = `report.pl`;
$right_frame->insert('end', $text);
}
Alternatively, if report.pl outputs to c:\temp\perl.txt then you could try the following:
sub runscript {
right_frame->delete('1.0','end');
system("report.pl");
load_file();
}
I want to implement a history/recent-files functionality for my Perl/Tk program.
Here is a working code excerpt from my program to demonstrate my problem.
#!/usr/bin/perl
use strict;
use warnings;
use English qw( -no_match_vars );
use Tk;
my #history_entries = qw(Back To The History);
my $mw = MainWindow->new();
my $menubar = $mw->Menu();
$mw->configure( -menu => $menubar );
my $file = $menubar->cascade( -label => '~File' );
my $history = $file->cascade( -label => '~History', );
build_history();
MainLoop();
#=== FUNCTION ================================================================
# NAME: build_history
# PURPOSE: Polulate the history
#===============================================================================
sub build_history {
foreach (#history_entries) {
$history->command(
-label => $ARG,
-command => \&some_function,
-compound => 'left',
);
}
return;
} # ---------- end of subroutine build_history ----------
As you can see, the entries are created with $history->command but how can I delete them every time I call build_history?
The reason I want them deleted is that everytime a user opens a file, the last item (in this case 'History') should be deleted and a new item should be put on top of the list. So that I have a maximum of (in this example) four entries.
Any other ways of implementing this functionality with Tk are welcome.
Thanks for your time.
UPDATE:
I followed the advice of "mu" and tried to get the subwidgets with the children() function just after the function is called, like this:
my #child = $history->children();
foreach my $c ( #child ) {
if ($c->Exists()){
$c->destroy;
}
}
The program exits with the error:
Can't locate object method "children" via package "Tk::Menu::Cascade" at /home/alex/Desktop/stack_history.pl line 28.
you can create a submenu from the menubar first:
my $sub_menu = $menubar->Menu(-tearoff => 0);
Then you can pass this submenu to the cascade menuitem:
$file->cascade( -label => '~History', -menu => $sub_menu);
Then you can add/delete menuitems to the submenu:
foreach (#history_entries) {
$sub_menu->command(
-label => $ARG,
-compound => 'left',
);
}
...
$sub_menu->delete(0); # Remove first element
With this solution you can avoid rebulding the whole menu.
I ended up rebuilding the whole menu. That's how my code looks like atm. I am not proud of it but it works ... I am open to any form of advice.
#!/usr/bin/perl
use strict;
use warnings;
use English qw( -no_match_vars );
use Tk;
# History entries are stored in array
my #history_entries = qw(Back To The History);
my $mw = MainWindow->new();
$mw->geometry('200x200');
my $menubar = $mw->Menu();
#Build menus
$mw->configure( -menu => $menubar );
build_menu();
$mw->Button(
-text => 'Update History',
-command => \sub {
#when a user opens a file insert_history is called.
insert_history();
}
)->pack( -side => 'bottom', -anchor => 'sw' );
MainLoop();
#=== FUNCTION ================================================================
# NAME: build_menu
# PURPOSE: Update/Build the menu
#===============================================================================
sub build_menu {
#delete the whole menu
$menubar->delete(1);
#built it again
my $file = $menubar->cascade( -label => '~File' );
my $history = $file->cascade( -label => '~History', );
foreach (#history_entries) {
$history->command(
-label => $ARG,
-compound => 'left',
);
}
return;
} # ---------- end of subroutine build_menu ----------
#=== FUNCTION ================================================================
# NAME: insert_history
# PURPOSE: Do something with the array containing the history entries.
# Then rebuild the menu.
#===============================================================================
sub insert_history {
#make something with the array
my $last_element = pop #history_entries;
unshift #history_entries, $last_element;
#update menu
build_menu();
return;
} # ---------- end of subroutine insert_history ----------
I want to add a new widget to my script that will open a new window with text and will close automatically after 1sec.
how can I do it ?
I think what you want is Tk::after.
#!/usr/bin/perl
use strict;
use warnings;
use Tk;
my $mw = MainWindow->new;
my $spawn = $mw->Button(
-text => 'spawn',
-command => sub {
my $subwindow = MainWindow->new;
my $label = $subwindow->Label(-text => "spawned");
$label->pack;
$subwindow->after(1_000, sub { $subwindow->destroy; });
}
);
$spawn->pack;
my $exit = $mw->Button(
-text => 'exit',
-command => sub { print "exiting...\n"; exit }
);
$exit->pack;
MainLoop;