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/); }