#!/usr/bin/env perl -l

use strict;
use warnings;

use Tk;

my $mw = MainWindow::->new();

my @choices = qw{A B C D};
my $chosen;
my $tl;

$mw->Button(-text => 'Make Choice', -command => sub {
    make_choice(\$mw, \$tl, \@choices, \$chosen);
})->pack();
$mw->Button(-text => 'Show Choice', -command => sub {
    if (defined $chosen) {
        print "You chose: $chosen";
    }
    else {
        print "Nothing chosen yet!";
    }
})->pack();
$mw->Button(-text => 'Exit', -command => sub { exit })->pack();

MainLoop;

sub make_choice {
    my ($parent, $tl, $choices, $chosen) = @_;

    if (! Exists($$tl)) {
        $$tl = $$parent->Toplevel();
        my $lb = $$tl->Scrolled('Listbox',
            -selectmode => 'single',
            -scrollbars => 'osoe',
        )->pack();
        $lb->insert(end => @$choices);

        $$tl->Button(-text => 'Done', -command => sub {
            my $selection = $lb->curselection();

            if (ref $selection) {
                $$chosen = $choices->[$selection->[0]];
            }

            $$tl->grabRelease();
            $$tl->withdraw();
        })->pack();
    }
    else {
        $$tl->deiconify();
        $$tl->raise();
    }

    $$tl->grab();
}