|
Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:
Dear Monks,
The following script, which is in a routine invoked as a toplevel, is working fine except when I make a second attempt to run it. Essentially I have a script that reads and parses a file, creates an array which is dislayed in a TK::MListbox. The user selects specific elements from one listbox to drop in the second listbox (ie my @elements = $lb2->curselection; in sub select_tag and sub unselect_tag). This works fine the first time, however it doesn't the second time around. Essentially my array of elements to select is empty the second time I open my toplevel. But I am lexically scoping all my variables! The only way I can get this to work is by closing the application and starting afresh. Can anybody see what I am doing wrong? I even tried to withdraw both mlistboxes (ie $lb and lb2) but to no avail! Thank you guys.
my ($tl21);
if (! Exists($tl21)){
$tl21 = $mw->Toplevel(-title=>"Report");
$tl21->Label->pack(-side => 'top');
my $f1= $tl21->Frame(-borderwidth =>2, -relief=> 'groove')->pack(-
+side => 'top', -fill => 'x');
my $f2= $tl21->Frame(-borderwidth =>2, -relief=> 'groove')->pack(-
+side => 'top', -fill => 'x');
my $f3= $tl21->Frame(-borderwidth =>2, -relief=> 'groove')->pack(-
+side => 'top', -fill => 'x');
$lb = $f1->Scrolled("Listbox", -scrollbars => "osoe", -selectmode=
+>"extended",
)->pack(-side => 'left', -fill => 'y');
my $lb->insert("end", @tags_list);
my $lb2 = $f1->Scrolled("Listbox", -scrollbars => "osoe", -selectm
+ode=>"extended",
)->pack(-side => 'left', -fill => 'y');
my $sel_btn=$f2->Button(-text => "> Select Field",
-command => \&select_tag)->pack(-side =>'left', -expand=>1,
+ -anchor => 'center');
$balloon->attach($sel_btn, -msg => "Select field");
+
my $sel1_btn= $f2->Button(-text => "> Unselect Field",
-command => \&unselect_tag)->pack(-side =>'left', -expand=
+>1, -anchor => 'center');
$balloon->attach($sel1_btn, -msg => "Unselect field");
my $sel2_btn= $f2->Button(-text => ">> Select all",
-command => \&select_all)->pack(-side =>'left', -expand=>1
+, -anchor => 'center');
$balloon->attach($sel2_btn, -msg => "Select all");
my $sel3_btn= $f2->Button(-text => "<< Unselect All Fiel
+ds",
-command => \&unselect_all)->pack(-side =>'left', -expand=
+>1, -anchor => 'center');
$balloon->attach($sel3_btn, -msg => "Unselect all fields")
+;
my $convert_btn=$f3->Button(-text=>"Go",
-command=> sub {
my $selected_tags = $lb2->get(0,'end');
if (scalar @$selected_tags < 1){
my $msg_title = "ListBox selection Error";
my $message = "Please make a selection first!";
message_box($msg_title,$message);
}
##print first line with field names, tabbed
$list_selected_tags = join ",", @$selected_tags;
$t->insert('end', $list_selected_tags);
$t->insert('end', "\n");
foreach my $k (sort keys %$users_ref){
foreach my $i (@$selected_tags){
my $temp_i = $users_ref->{$k}{$i};
if ($temp_i =~ /,/){
$temp_i = "\"$temp_i\"";
}
else{
$temp_i = "$temp_i";
}
#$temp_i =~ s/"/""/g;
$t->insert('end', "$temp_i,") unless $i eq @$selecte
+d_tags[-1];;
$t->insert('end', "$temp_i\n") if $i eq @$selected_t
+ags[-1];
}
#$t->insert('end', "\n");
}
$tl21->withdraw;
}
)->pack(-side =>'left', -expand=>1, -anchor => 'center');
$balloon->attach($convert_btn, -msg => "Filter report");
my $cancel_btn=$f3->Button(-text=>"Cancel",
-command=> sub {
$tl21->withdraw
}#end of 2nd inner sub
)->pack(-side =>'left', -expand=>1, -anchor => 'center');
$balloon->attach($cancel_btn, -msg => "Close current window"
+);
sub select_tag {
my @elements = $lb->curselection;
my $delete_point;
if ($#elements>=0){
foreach my $i (0..$#elements) {
$delete_point =$elements[0];
my $element = $lb->get($elements[$i]);
$lb2->insert("end","$element LALA") ;
}
$lb->delete($delete_point,$elements[-1]);
$lb->selectionClear(0,'end');
}
else {
my $msg_title = "ListBox selection Error";
my $message = "Please make a selection first!";
message_box($msg_title,$message);
}
}
sub unselect_tag {
my @elements = $lb2->curselection;
my $delete_point;
if ($#elements>=0){
foreach my $i (0..$#elements) {
$delete_point =$elements[0];
my $element = $lb2->get($elements[$i]);
$lb->insert("end","$element") ;
}
$lb2->delete($delete_point,$elements[-1]);
$lb2->selectionClear(0,'end');
}
else{
my $msg_title = "ListBox selection Error";
my $message = "Please make a selection first!";
message_box($msg_title,$message);
}
}
sub select_all{
$lb2->delete(0,'end');
$lb2->insert(0,@tags_list);
$lb->delete(0,'end');
}
sub unselect_all{
$lb->delete(0,'end');
$lb->insert(0,@tags_list);
$lb2->delete(0,'end');
}
}#end of if (! Exists($tl21))statement
else{
$tl21->deiconify();
$tl21->raise();
}
}
|
Re: TK::MListbox Issue
by GrandFather (Saint) on Oct 05, 2005 at 21:53 UTC
|
Use use strict; use warnings;. At the very least $lb = $f1->scrolled(...); my $lb ... doesn't look right. Also, the trailing } does not match an open bracket anywhere.
When posting a problem like this try to reduce the code to a minimum internally consistent sample that is runable. THe sample you have posted refers to many variables that are not given anywhere.
Perl is Huffman encoded by design.
| [reply]
[d/l]
[select] |
Re: TK::MListbox Issue
by rcseege (Pilgrim) on Oct 06, 2005 at 03:03 UTC
|
I'm glad you were able to figure it out. Sometimes, when I'm trying to track down problems with a Tk script, I find that the more I can simplify it, the easier time I have finding the problem.
There's many approaches I take. Often, taking care in the way I format the code will be enough. Sometimes, when I find that I'm using the same options over and over again for sets of widgets, I'll put the options in an array or hash and assign the collection to the widget (or geometry manager). Sometimes things can be simplified through the use of creation functions/methods that hide the details of creating a particular widget -- especially when the widgets share options for creation, and geometry management.
Having said that, I took your script fragment, and rewrote it slightly to simplify it, as an example. It's a slightly over-the-top example, but I thought it might be helpful.
I dropped out a few pieces that I thought might be non-essential.
By the way, you may want to double-check your select_tag and unselect_tag subs. You will lose entries if a user selects a non-contiguous group of entries, which is possible with the extended selectmode. Also, look how I used one sub to handle select/unselect and one for select/unselect all. Just a thought...
use strict;
use warnings;
use Tk;
my $topLevel;
my @tags = qw(one two three four five six);
my $mw = MainWindow->new;
createButton($mw, "Select Tags", \&selectTags);
MainLoop;
sub selectTags
{
if (!Exists($topLevel)) {
$topLevel = $mw->Toplevel(-title=>"Report");
## 1st Row - Listbox Pair
my $f1 = createFrame($topLevel);
my $lb = createListbox($f1);
my $lb2 = createListbox($f1);
$lb->insert("end", @tags);
## 2nd Row - Listbox Pair Controls
my $f2 = createFrame($topLevel);
createButton($f2, "> Select", [\&moveSelected, $lb, $lb2]);
createButton($f2, "> Unselect", [\&moveSelected, $lb2, $lb]);
createButton($f2, ">> Select All", [\&moveAll, $lb, $lb2]);
createButton($f2, "<< Unselect All", [\&moveAll, $lb2, $lb]);
## 3rd Row - Do something with selection
my $f3 = createFrame($topLevel);
createButton($f3, "Do Something", [\&doSomething, $lb2]);
}
$topLevel->deiconify if !$topLevel->ismapped;
$topLevel->raise;
}
sub doSomething
{
my $slb = shift;
if ($slb->size > 0) {
my $contents = join ",", $slb->get(0, 'end');
print "Contents: $contents\n";
$topLevel->withdraw;
}
else {
print "Please make a selection first!\n";
}
}
sub moveAll
{
my ($lb, $lb2) = @_;
$lb2->delete(0,'end');
$lb2->insert(0,@tags);
$lb->delete(0,'end');
}
sub moveSelected
{
my ($lb, $lb2) = @_;
my @indices = $lb->curselection;
if (@indices) {
foreach my $i (@indices) {
my $element = $lb->get($i);
$lb2->insert('end', $element);
}
$lb->delete(pop @indices) while @indices;
$lb->selectionClear(0,'end');
}
else {
print "Listbox selection error!\n";
print "Please make a selection first\n\n";
}
}
## Simple widget creation routines, intended to illustrate
## one way of reducing duplication.
sub createButton
{
my ($parent, $label, $sub) = @_;
return $parent->Button(
-command => $sub,
-text => $label,
)->pack(qw/-expand 1 -side left -fill x/);
}
sub createFrame
{
return shift->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(qw/-side top -fill x/);
}
sub createListbox
{
return shift->Scrolled("Listbox",
-scrollbars => 'osoe',
-selectmode => 'extended'
)->pack(qw/-side left -fill y/);
}
Anyhow, hope this is useful...
Rob | [reply]
[d/l] |
|
|
Thanks for the follow-up, Rob. Your modification are certainly a lot better and more succint. I'll study them and learn from them. Much appreciated.
| [reply] |
Re: TK::MListbox Issue
by rcseege (Pilgrim) on Oct 05, 2005 at 22:06 UTC
|
You grabbed my attention with the MListbox reference, but I don't see that you're using MListbox anywhere within your script -- am I missing something, or did you really mean Listbox, and not MListbox?
Also, you've made it difficult to help you with a nonworking code fragment containing unmatched braces, undefined vars, and other minor errors.
Rob
| [reply] |
Re: TK::MListbox Issue
by Anonymous Monk on Oct 06, 2005 at 01:01 UTC
|
Sorry, I was rushing to send the code without realizing that there were some mistakes. The problem was related to the nested sub which is referencing a is referencing a lexical variable defined in an outer subroutine. I resorted to using the sub {} syntax and it is working properly. Thank you guys for your advice. use warnings did the trick. | [reply] |
|
|
