Trouble with Perl CGI Form - perl

I have an issue with a Perl CGI form which have two submit buttons. Let me explain with a sample code.
print $q->start_form(
-name => 'main',
-method => 'POST',
);
print $q->popup_menu( #drop down list
-name => 'popup1',
-values => #test,
-default => 'value2'
print $q->submit(
-name => 'do one thing',
);
print $q->submit(
-name => 'do two things',
);
if ($q->param("do one thing")) {
do certain functions;
}
if ($q->param("do two things")) {
##########output a checkbox#############
print $q->checkbox_group(
-name => 'checkemail',
-values => #test2,
-columns => 2,
-rows => 10,
);
###############submit the checkbox###########
print $q->submit(
-name => 'Submit',
);
if ($q->param("Submit")) {
do certain functions;
}
The code is simple. When we click "do one thing" button it should do certain function. When we click "do two things" its should display a checkbox. The form works fine until this. After the checkbox there is a submit button to submit this checkbox and do certain function. Unfortunately if I click submit button to submit checkbox it doesn't do the task after submit button. Also it even don't display the checkbox after we click the submit button of checkbox. Any help is appreciated.

Your indentation is chaotic. It might be a part of the problem: you misplaced the code that handles the Submit button. It is only run if the "do two things" button was pressed, but it is not possible to press both the buttons. Fixed (and runnable) code:
#!/usr/bin/perl
use strict;
use warnings;
use CGI;
my $q = 'CGI'->new;
my #test = qw(a b);
my #test2 = qw(A B);
print $q->start_form( -name => 'main',
-method => 'POST',
);
print $q->popup_menu( #drop down list
-name => 'popup1',
-values => \#test,
-default => 'value2');
print $q->submit(-name => 'do one thing');
print $q->submit(-name => 'do two things');
if ($q->param('do one thing')) {
print "One thing: ", $q->param('popup1'), "\n";
}
if ($q->param('do two things')) {
print $q->checkbox_group( -name => 'checkemail',
-values => \#test2,
-columns => 2,
-rows => 10,
);
print $q->submit(-name => 'Submit');
}
if ($q->param('Submit')) {
print 'Sencond thing', $q->param('checkemail'), "\n";
}
Notice the code uses array references in -values.

Related

Perl Tk Formatting Text in a button

The code below creates Perl/Tk buttons filled with each event's details from the hash %events. Is there a way to format the text inside the buttons so that it appears in aligned columns in the manner printf prints it out on line 16.
use strict;
use Tk;
my %events;
$events{"Jazz Fest"}{city} = "New Orleans";
$events{"Jazz Fest"}{state} = "LA";
$events{"Jazz Fest"}{date} = "June 6th, 2023";
$events{"Lollapalooza"}{city} = "Chicago";
$events{"Lollapalooza"}{state} = "IL";
$events{"Lollapalooza"}{date} = "July 25th, 2023";
$events{"Blues Fest"}{city} = "Chicago";
$events{"Blues Fest"}{state} = "IL";
$events{"Blues Fest"}{date} = "Augsut 4th, 2023";
my %data;
foreach my $event (sort keys %events) {
printf("%-15.15s %-20.20s %-2.2s %18.18s\n", $event, $events{$event}{city}, $events{$event}{state}, $events{$event}{date});
$data{$event} = sprintf("%-15.15s %-20.20s %-2.2s %18.18s", $event, $events{$event}{city}, $events{$event}{state}, $events{$event}{date});
}
my $data;
my $mw = MainWindow->new;
$mw->title("Event Clipboard Copy");
$mw->label("Pick Event Details to Copy.");
for(sort keys %data){
my $text = $data{$_};
$mw->Button( -text => $text, -anchor => 'w', -command => sub {
Clipboard->copy( $text );
}
)->pack( -fill => 'x' );
}
MainLoop;
To align the columns, set font of each button to "Courier" (or another monospaced font). There are at least two ways to do this:
when creating the button
assign the button to a variable and then call configure on it.
#Setting font when creating the button
$mw->Button( -text => $text, -anchor => 'w', -font => [-family => 'Courier'], -command => sub {
#Calling configure on the button
my $button = $mw->Button(-text => $text, -anchor => 'w', -command => sub {
...
}->pack( -fill => 'x' );
$button->configure(-font => [-family => 'Courier']);
Here's how it looks with font set to Courier
And without setting font:

Passing variable from subroutine in tk perl interface

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

How do I get the caller widget from a subroutine in Perl/TK?

in perl Tk I want to ask how to get the calling widget when using the -command option.
I have a dialog widget that is dynamically created by a previously unknown number of entries. There are Entry-widget and next to each a button where one can browse possible (useful) strings for the Entry.
Therefore, if the button next to the 2nd Entry is pressed, the result should be stored in the 2nd Entry and so on.
The code looks as follows.
my $count = 0;
my #name = ();
my #val = ();
my #edit = ();
my #button = ();
my $fr = $wind->Frame->pack;
foreach ( #outputs ) {
$name[$count] = helper::trim($_);
$val[$count] = '';
$fr->Label(-text => $name[$count])->grid(-row => $count, -column => 0, -sticky => 'w');
$edit[$count] = $fr->Entry(-textvariable => \$val[$count], -width => 30)->grid(-row => $count, -column => 1);
$button[$count] = $fr->Button(-width => 20, -text => 'Select',
-command => sub { &select(\$val[$count], \$edit[$count]); }
)->grid(-row => $count, -column => 2);
$count++;
}
However, since &select is called after the complete dialog box was built $count is always on the last value and I don't get the info, which button I have pressed. Lines as
-command => sub { &select(\#val, \#edit, $count); }
also didn't work.
Is there some way to get the widget that called the sub-routine (so I can store necessary infos somehow in the respective button) or use the actual value (of $count here) in such a call?
Best regards.
inside the callback:
my $caller = $Tk::widget;

Delete the subwidgets/entries from a tk::menu widget

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 ----------

How do I enable a disabled context menu item when selection happens in a Perl Tk gui?

For example in the following script:
use Tk;
my $mw = new MainWindow;
my $t = $mw->Scrolled("Text")->pack;
my $popup = $mw->Menu(
-menuitems => [
[
Button => 'Copy Selected',
-state => "disabled",
-command => sub {$t->clipboardColumnCopy}
],
]
);
$t->menu($popup);
MainLoop;
How do I tell when selection happens so that I can use the following code
$popup->entryconfigure(1, -state=>'normal');
to change the menu item state?
UPDATE:
Big thanks to #Chas and #gbacon :)
I think maybe I can also combine the two good answers:
$t->bind(
"<Button1-ButtonRelease>",
sub {
local $#;
my $state = defined eval { $t->SelectionGet } ?
"normal" : "disable";
$popup->entryconfigure(1, -state => $state)
}
);
I don't know Tk very well, but this is an answer (but maybe not the right answer):
#!/usr/bin/perl
use strict;
use warnings;
use Tk;
my $mw = new MainWindow;
my $t = $mw->Text->pack;
my $popup = $mw->Menu(
-menuitems => [
[ Button => 'Copy Selected', -state => "disabled", -command => sub {$t->clipboardColumnCopy} ],
]
);
$t->menu($popup);
$t->bind(
"<Button1-ButtonRelease>",
sub {
my $text = $t->getSelected;
if (length $text) {
$popup->entryconfigure(1, -state => 'normal');
} else {
$popup->entryconfigure(1, -state => 'disabled');
}
}
);
MainLoop;
A few changes produce the behavior you want. The code below watches <ButtonPress-1> which may clear the selection and if so disables Copy Selected. For <ButtonPress-3>, it enables the menu item if a selection is present.
my $copySelectedLabel = "Copy Selected";
my $popup = $mw->Menu(
-menuitems => [
[
Button => $copySelectedLabel,
-state => "disabled",
-command => sub {$t->clipboardColumnCopy}
],
]
);
sub maybeEnableCopySelected {
local $#;
$popup->entryconfigure($copySelectedLabel, -state => "normal")
if defined eval { $t->SelectionGet };
}
sub maybeDisableCopySelected {
local $#;
$popup->entryconfigure($copySelectedLabel, -state => "disabled")
unless defined eval { $t->SelectionGet };
}
$t->bind('<ButtonPress-1>' => \&maybeDisableCopySelected);
$t->bind('<ButtonPress-3>' => \&maybeEnableCopySelected);
$t->menu($popup);