15. User Interfaces

#-----------------------------
use Getopt::Std;

# -v ARG, -D ARG, -o ARG, sets $opt_v, $opt_D, $opt_o
getopt("vDo");              
# -v ARG, -D ARG, -o ARG, sets $args{v}, $args{D}, $args{o}
getopt("vDo", \%args);

getopts("vDo:");         # -v, -D, -o ARG, sets $opt_v, $opt_D, $opt_o
getopts("vDo:", \%args); # -v, -D, -o ARG, sets $args{v}, $args{D}, $args{o}
#-----------------------------
use Getopt::Long;

GetOptions( "verbose"  => \$verbose,     # --verbose
            "Debug"    => \$debug,       # --Debug
            "output=s" => \$output );    # --output=string or --output=string
#-----------------------------
#% rm -r -f /tmp/testdir
#-----------------------------
#% rm -rf /tmp/testdir
#-----------------------------
use Getopt::Std;
getopts("o:");
if ($opt_o) {
    print "Writing output to $opt_o";
}
#-----------------------------
use Getopt::Std;

%option = ();
getopts("Do:", \%option);

if ($option{D}) {
    print "Debugging mode enabled.\n";
}

 # if not set, set output to "-".  opening "-" for writing
 # means STDOUT
 $option{o} = "-" unless defined $option{o};
                             
print "Writing output to file $option{o}\n" unless $option{o} eq "-";
open(STDOUT, "> $option{o}")
     or die "Can't open $option{o} for output: $!\n";
#-----------------------------
#% gnutar --extract --file latest.tar
#-----------------------------
#% gnutar --extract --file=latest.tar
#-----------------------------
use Getopt::Long;

GetOptions( "extract" => \$extract,
            "file=s"  => \$file );

if ($extract) {
    print "I'm extracting.\n";
}

die "I wish I had a file" unless defined $file;
print "Working on the file $file\n";
#-----------------------------

#-----------------------------
sub I_am_interactive {
    return -t STDIN && -t STDOUT;
}
#-----------------------------
use POSIX qw/getpgrp tcgetpgrp/;

sub I_am_interactive {
    local *TTY;  # local file handle
    open(TTY, "/dev/tty") or die "can't open /dev/tty: $!";
    my $tpgrp = tcgetpgrp(fileno(TTY));
    my $pgrp  = getpgrp();
    close TTY;
    return ($tpgrp == $pgrp);
}
#-----------------------------
while (1) {
    if (I_am_interactive()) {
        print "Prompt: ";
    }
    $line = <STDIN>;
    last unless defined $line; 
    # do something with the line
}
#-----------------------------
sub prompt { print "Prompt: " if I_am_interactive() }
for (prompt(); $line = <STDIN>; prompt()) {
    # do something with the line
} 
#-----------------------------

#-----------------------------
use Term::Cap;

$OSPEED = 9600;
eval {
    require POSIX;
    my $termios = POSIX::Termios->new();
    $termios->getattr;
    $OSPEED = $termios->getospeed;
};

$terminal = Term::Cap->Tgetent({OSPEED=>$OSPEED});
$terminal->Tputs('cl', 1, STDOUT);
#-----------------------------
system("clear");
#-----------------------------
$clear = $terminal->Tputs('cl');
$clear = `clear`;
#-----------------------------
print $clear;
#-----------------------------

#-----------------------------
use Term::ReadKey;

($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize();
#-----------------------------
use Term::ReadKey;

($width) = GetTerminalSize();
die "You must have at least 10 characters" unless $width >= 10;

$max = 0;
foreach (@values) {
    $max = $_ if $max < $_;
}

$ratio = ($width-10)/$max;          # chars per unit
foreach (@values) {
    printf("%8.1f %s\n", $_, "*" x ($ratio*$_));
}
#-----------------------------

#-----------------------------
use Term::ANSIColor;

print color("red"), "Danger, Will Robinson!\n", color("reset");
print "This is just normal text.\n";
print colored("<BLINK>Do you hurt yet?</BLINK>", "blink");
#-----------------------------
use Term::ANSIColor qw(:constants);

print RED, "Danger, Will Robinson!\n", RESET;
#-----------------------------
# rhyme for the deadly coral snake
print color("red on_black"),  "venom lack\n";
print color("red on_yellow"), "kill that fellow\n";

print color("green on_cyan blink"), "garish!\n";
print color("reset");
#-----------------------------
print colored("venom lack\n", "red", "on_black");
print colored("kill that fellow\n", "red", "on_yellow");

print colored("garish!\n", "green", "on_cyan", "blink");
#-----------------------------
use Term::ANSIColor qw(:constants);

print BLACK, ON_WHITE, "black on white\n";
print WHITE, ON_BLACK, "white on black\n";
print GREEN, ON_CYAN, BLINK, "garish!\n";
print RESET;
#-----------------------------
END { print color("reset") }
#-----------------------------
$Term::ANSIColor::EACHLINE = $/;
print colored(<<EOF, RED, ON_WHITE, BOLD, BLINK);
This way
each line
has its own
attribute set.
EOF
#-----------------------------

#-----------------------------
use Term::ReadKey;

ReadMode('cbreak');
$key = ReadKey(0);
ReadMode('normal');
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# sascii - Show ASCII values for keypresses

use Term::ReadKey;
ReadMode('cbreak');
print "Press keys to see their ASCII values.  Use Ctrl-C to quit.\n";

while (1) {
    $char = ReadKey(0);
    last unless defined $char;
    printf(" Decimal: %d\tHex: %x\n", ord($char), ord($char));
}

ReadMode('normal');

#-----------------------------

#-----------------------------
print "\aWake up!\n";
#-----------------------------
use Term::Cap;

$OSPEED = 9600;
eval {
    require POSIX;
    my $termios = POSIX::Termios->new();
    $termios->getattr;
    $OSPEED = $termios->getospeed;
};

$terminal = Term::Cap->Tgetent({OSPEED=>$OSPEED});
$vb = "";
eval {
    $terminal->Trequire("vb");
    $vb = $terminal->Tputs('vb', 1);
};

print $vb;                                  # ring visual bell
#-----------------------------

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# demo POSIX termios

use POSIX qw(:termios_h);

$term = POSIX::Termios->new;
$term->getattr(fileno(STDIN));

$erase = $term->getcc(VERASE);
$kill = $term->getcc(VKILL);
printf "Erase is character %d, %s\n", $erase, uncontrol(chr($erase));
printf "Kill is character %d, %s\n", $kill, uncontrol(chr($kill));

$term->setcc(VERASE, ord('#'));
$term->setcc(VKILL, ord('@'));
$term->setattr(1, TCSANOW);

print("erase is #, kill is @; type something: ");
$line = <STDIN>;
print "You typed: $line";

$term->setcc(VERASE, $erase);
$term->setcc(VKILL, $kill);
$term->setattr(1, TCSANOW);

sub uncontrol {
    local $_ = shift;
    s/([\200-\377])/sprintf("M-%c",ord($1) & 0177)/eg;
    s/([\0-\37\177])/sprintf("^%c",ord($1) ^ 0100)/eg;
    return $_;
} 

#-----------------------------
# HotKey.pm
package HotKey;

@ISA = qw(Exporter);
@EXPORT = qw(cbreak cooked readkey);

use strict;
use POSIX qw(:termios_h);
my ($term, $oterm, $echo, $noecho, $fd_stdin);

$fd_stdin = fileno(STDIN);
$term     = POSIX::Termios->new();
$term->getattr($fd_stdin);
$oterm     = $term->getlflag();

$echo     = ECHO | ECHOK | ICANON;
$noecho   = $oterm & ~$echo;

sub cbreak {
    $term->setlflag($noecho);  # ok, so i don't want echo either
    $term->setcc(VTIME, 1);
    $term->setattr($fd_stdin, TCSANOW);
}

sub cooked {
    $term->setlflag($oterm);
    $term->setcc(VTIME, 0);
    $term->setattr($fd_stdin, TCSANOW);
}

sub readkey {
    my $key = '';
    cbreak();
    sysread(STDIN, $key, 1);
    cooked();
    return $key;
}

END { cooked() }

1;
#-----------------------------

#-----------------------------
use Term::ReadKey;

ReadMode ('cbreak');

if (defined ($char = ReadKey(-1)) ) {
    # input was waiting and it was $char
} else {
    # no input was waiting
}

ReadMode ('normal');                  # restore normal tty settings
#-----------------------------

#-----------------------------
use Term::ReadKey;

ReadMode('noecho');
$password = ReadLine(0);
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# checkuser - demonstrates reading and checking a user's password

use Term::ReadKey;

print "Enter your password: ";
ReadMode 'noecho';
$password = ReadLine 0;
chomp $password;
ReadMode 'normal';

print "\n";

($username, $encrypted) = ( getpwuid $< )[0,1];

if (crypt($password, $encrypted) ne $encrypted) {
    die "You are not $username\n";
} else {
    print "Welcome, $username\n";
}

#-----------------------------

#-----------------------------
use Term::ReadLine;

$term = Term::ReadLine->new("APP DESCRIPTION");
$OUT = $term->OUT || *STDOUT;

$term->addhistory($fake_line);
$line = $term->readline(PROMPT);

print $OUT "Any program output\n";
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# vbsh -  very bad shell
use strict;

use Term::ReadLine;
use POSIX qw(:sys_wait_h);

my $term = Term::ReadLine->new("Simple Shell");
my $OUT = $term->OUT() || *STDOUT;
my $cmd;

while (defined ($cmd = $term->readline('$ ') )) {
    my @output = `$cmd`;
    my $exit_value  = $? >> 8;
    my $signal_num  = $? & 127;
    my $dumped_core = $? & 128;
    printf $OUT "Program terminated with status %d from signal %d%s\n",
           $exit_value, $signal_num, 
           $dumped_core ? " (core dumped)" : "";
    print @output;
    $term->addhistory($seed_line);
}

#-----------------------------
$term->addhistory($seed_line);
#-----------------------------
$term->remove_history($line_number);
#-----------------------------
@history = $term->GetHistory;
#-----------------------------

#-----------------------------
#% rep ps aux
#% rep netstat
#% rep -2.5 lpq
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# rep - screen repeat command
use strict;
use Curses;

my $timeout = 10;
if (@ARGV && $ARGV[0] =~ /^-(\d+\.?\d*)$/) { 
    $timeout = $1; 
    shift; 
} 

die "usage: $0 [ -timeout ] cmd args\n" unless @ARGV;
    
initscr();          # start screen
noecho();           
cbreak(); 
nodelay(1);         # so getch() is non-blocking

$SIG{INT} = sub { done("Ouch!") };
sub done { endwin(); print "@_\n"; exit; }

while (1) {
    while ((my $key = getch()) ne ERR) {    # maybe multiple keys
        done("See ya") if $key eq 'q' 
    }
    my @data = `(@ARGV) 2>&1`;              # gather output+errors
    for (my $i = 0; $i < $LINES; $i++) {
        addstr($i, 0, $data[$i] || ' ' x $COLS);
    } 

    standout();
    addstr($LINES-1, $COLS - 24, scalar localtime);
    standend();

    move(0,0); 
    refresh();                              # flush new output to display

    my ($in, $out) = ('', '');
    vec($in,fileno(STDIN),1) = 1;           # look for key on stdin 
    select($out = $in,undef,undef,$timeout);# wait up to this long
}

#-----------------------------
keypad(1);                  # enable keypad mode
$key = getch();
if ($key eq 'k'     ||      # vi mode
    $key eq "\cP"   ||      # emacs mode
    $key eq KEY_UP)         # arrow mode
{
    # do something
} 
#-----------------------------
#		       Template Entry Demonstration 
#
#   Address Data Example                                     Record # ___
#
#   Name: [________________________________________________]
#   Addr: [________________________________________________]
#   City: [__________________]          State: [__]       Zip: [\\\\\] 
#
#   Phone: (\\\) \\\-\\\\                            Password: [^^^^^^^^]
#
#   Enter all information available.
#   Edit fields with left/right arrow keys or "delete".
#   Switch fields with "Tab" or up/down arrow keys.
#   Indicate completion by pressing "Return".
#   Refresh screen with "Control-L".
#   Abort this demo here with "Control-X".
#-----------------------------

#-----------------------------
use Expect;

$command = Expect->spawn("program to run")
    or die "Couldn't start program: $!\n";

# prevent the program's output from being shown on our STDOUT
$command->log_stdout(0);

# wait 10 seconds for "Password:" to appear
unless ($command->expect(10, "Password")) {
    # timed out
}

# wait 20 seconds for something that matches /[lL]ogin: ?/
unless ($command->expect(20, -re => '[lL]ogin: ?')) {
    # timed out
}

# wait forever for "invalid" to appear
unless ($command->expect(undef, "invalid")) {
    # error occurred; the program probably went away
}

# send "Hello, world" and a carriage return to the program
print $command "Hello, world\r";

# if the program will terminate by itself, finish up with
$command->soft_close();
    
# if the program must be explicitly killed, finish up with
$command->hard_close();
#-----------------------------
$which = $command->expect(30, "invalid", "succes", "error", "boom");
if ($which) {
    # found one of those strings
}
#-----------------------------

#-----------------------------
use Tk;

$main = MainWindow->new();

# Create a horizontal space at the top of the window for the
# menu to live in.
$menubar = $main->Frame(-relief              => "raised",
                        -borderwidth         => 2)
                ->pack (-anchor              => "nw",
                        -fill                => "x");

# Create a button labeled "File" that brings up a menu
$file_menu = $menubar->Menubutton(-text      => "File",
                                  -underline => 1)
                     ->pack      (-side      => "left" );
# Create entries in the "File" menu
$file_menu->command(-label   => "Print",
                    -command => \&Print);
#-----------------------------
$file_menu = $menubar->Menubutton(-text     => "File",
                                 -underline => 1,
                                 -menuitems => [
              [ Button => "Print",-command  => \&Print ],
               [ Button => "Save",-command  => \&Save  ] ])
                           ->pack(-side     => "left");
#-----------------------------
    $file_menu->command(-label   => "Quit Immediately",
                        -command => sub { exit } );
#-----------------------------
$file_menu->separator();
#-----------------------------
$options_menu->checkbutton(-label    => "Create Debugging File",
                           -variable => \$debug,
                           -onvalue  => 1,
                           -offvalue => 0);
#-----------------------------
$debug_menu->radiobutton(-label    => "Level 1",
                         -variable => \$log_level,
                         -value    => 1);

$debug_menu->radiobutton(-label    => "Level 2",
                         -variable => \$log_level,
                         -value    => 2);

$debug_menu->radiobutton(-label    => "Level 3",
                         -variable => \$log_level,
                         -value    => 3);
#-----------------------------
# step 1: create the cascading menu entry
$format_menu->cascade          (-label    => "Font");

# step 2: get the new Menu we just made
$font_menu = $format_menu->cget("-menu");

# step 3: populate that Menu
$font_menu->radiobutton        (-label    => "Courier",
                                -variable => \$font_name,
                                -value    => "courier");
$font_menu->radiobutton        (-label    => "Times Roman",
                                -variable => \$font_name,
                                -value    => "times");
#-----------------------------
$format_menu = $menubar->Menubutton(-text      => "Format",
                                    -underline => 1
                                    -tearoff   => 0)
                       ->pack;

$font_menu  = $format_menu->cascade(-label     => "Font",
                                    -tearoff   => 0);
#-----------------------------
my $f = $menubar->Menubutton(-text => "Edit", -underline => 0,
                              -menuitems =>
    [
     [Button => 'Copy',        -command => \&edit_copy ],
     [Button => 'Cut',         -command => \&edit_cut ],
     [Button => 'Paste',       -command => \&edit_paste  ],
     [Button => 'Delete',      -command => \&edit_delete ],
     [Separator => ''],
     [Cascade => 'Object ...', -tearoff => 0,
                               -menuitems => [
        [ Button => "Circle",  -command => \&edit_circle ],
        [ Button => "Square",  -command => \&edit_square ],
        [ Button => "Point",   -command => \&edit_point ] ] ],
    ])->grid(-row => 0, -column => 0, -sticky => 'w');
#-----------------------------

#-----------------------------
use Tk::DialogBox;

$dialog = $main->DialogBox( -title   => "Register This Program",
                            -buttons => [ "Register", "Cancel" ] );

# add widgets to the dialog box with $dialog->Add()

# later, when you need to display the dialog box
$button = $dialog->Show();
if ($button eq "Register") {
    # ...
} elsif ($button eq "Cancel") {
    # ...
} else {
    # this shouldn't happen
}
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# tksample3 - demonstrate dialog boxes

use Tk;
use Tk::DialogBox;

$main = MainWindow->new();

$dialog = $main->DialogBox( -title   => "Register",
                            -buttons => [ "Register", "Cancel" ],
                           );

# the top part of the dialog box will let people enter their names,
# with a Label as a prompt

$dialog->add("Label", -text => "Name")->pack();
$entry = $dialog->add("Entry", -width => 35)->pack();

# we bring up the dialog box with a button
$main->Button( -text    => "Click Here For Registration Form",
               -command => \&register)    ->pack(-side => "left");
$main->Button( -text    => "Quit",
               -command => sub { exit } ) ->pack(-side => "left");

MainLoop;

#
# register
#
# Called to pop up the registration dialog box
#

sub register {
    my $button;
    my $done = 0;

    do {    
        # show the dialog
        $button = $dialog->Show;

        # act based on what button they pushed
        if ($button eq "Register") {
                my $name = $entry->get;

            if (defined($name) && length($name)) {
                print "Welcome to the fold, $name\n";
                $done = 1;
            } else {
                print "You didn't give me your name!\n";
            }
        } else {
            print "Sorry you decided not to register.\n";
            $done = 1;
        }
    } until $done;
}

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# tksample4 - popup dialog boxes for warnings

use Tk;
use Tk::DialogBox;

my $main;

# set up a warning handler that displays the warning in a Tk dialog box

BEGIN {
    $SIG{_     _WARN_     _} = sub {
        if (defined $main) {
            my $dialog = $main->DialogBox( -title   => "Warning",
                                           -buttons => [ "Acknowledge" ]);
            $dialog->add("Label", -text => $_[0])->pack;
            $dialog->Show;
        } else {
            print STDOUT join("\n", @_), "n";
        }
    };
}

# your program goes here

$main = MainWindow->new();

$main->Button( -text   => "Make A Warning",
               -command => \&make_warning) ->pack(-side => "left");
$main->Button( -text   => "Quit",
               -command => sub { exit } )  ->pack(-side => "left");

MainLoop;

# dummy subroutine to generate a warning
    
sub make_warning {
    my $a;
    my $b = 2 * $a;
}

#-----------------------------

#-----------------------------
use Tk;

$main = MainWindow->new();

$main->bind('<Configure>' => sub {
    $xe = $main->XEvent;
    $main->maxsize($xe->w, $xe->h);
    $main->minsize($xe->w, $xe->h);
});
#-----------------------------
$widget->pack( -fill => "both", -expand => 1 );
$widget->pack( -fill => "x",    -expand => 1 );
#-----------------------------
$mainarea->pack( -fill => "both", -expand => 1);
#-----------------------------
$menubar->pack( -fill => "x", -expand => 1 );
#-----------------------------
$menubar->pack (-fill     => "x",
                -expand   => 1,
                -anchor   => "nw" );
#-----------------------------

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# loader - starts Perl scripts without the annoying DOS window
use strict;
use Win32;
use Win32::Process;

# Create the process object.

Win32::Process::Create($Win32::Process::Create::ProcessObj,
    'C:/perl5/bin/perl.exe',            # Whereabouts of Perl
    'perl realprogram',                 #
    0,                                  # Don't inherit.
    DETACHED_PROCESS,                   #
    ".") or                             # current dir.
die print_error();

sub print_error() {
    return Win32::FormatMessage( Win32::GetLastError() );
}

#-----------------------------

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# tcapdemo - show off direct cursor placement

use POSIX;
use Term::Cap;
    
init();                     # Initialize Term::Cap.
zip();                      # Bounce lines around the screen.
finish();                   # Clean up afterward.
exit();

# Two convenience functions.  clear_screen is obvious, and
# clear_end clears to the end of the screen.
sub clear_screen { $tcap->Tputs('cl', 1, *STDOUT) } 
sub clear_end    { $tcap->Tputs('cd', 1, *STDOUT) } 

# Move the cursor to a particular location.
sub gotoxy {
    my($x, $y) = @_;
    $tcap->Tgoto('cm', $x, $y, *STDOUT);
} 

# Get the terminal speed through the POSIX module and use that
# to initialize Term::Cap.
sub init { 
    $| = 1;
    $delay = (shift() || 0) * 0.005;
    my $termios = POSIX::Termios->new();
    $termios->getattr;
    my $ospeed = $termios->getospeed;
    $tcap = Term::Cap->Tgetent ({ TERM => undef, OSPEED => $ospeed });
    $tcap->Trequire(qw(cl cm cd));
}

# Bounce lines around the screen until the user interrupts with
# Ctrl-C.
sub zip { 
    clear_screen();
    ($maxrow, $maxcol) = ($tcap->{_li} - 1, $tcap->{_co} - 1);

    @chars = qw(* - / | \ _ );
    sub circle { push(@chars, shift @chars); }

    $interrupted = 0;
    $SIG{INT} = sub { ++$interrupted };

    $col = $row = 0;
    ($row_sign, $col_sign) = (1,1);

    do {
        gotoxy($col, $row);
        print $chars[0];
        select(undef, undef, undef, $delay);

        $row += $row_sign;
        $col += $col_sign;

        if    ($row == $maxrow) { $row_sign = -1; circle; } 
        elsif ($row == 0 )      { $row_sign = +1; circle; }

        if    ($col == $maxcol) { $col_sign = -1; circle; } 
        elsif ($col == 0 )      { $col_sign = +1; circle; }
    
    } until $interrupted;

}

# Clean up the screen.
sub finish { 
    gotoxy(0, $maxrow);
    clear_end();
}

#-----------------------------
#*     _                       /     |                       \     -
# *   _ \                     - /   | /                     | \   - *
#  * _   \                   -   / |   /                   |   \ -   *
#   *     \                 -     |     /                 |     -     *
#  _ *     \               -     | /     /               |     - \     *
# _   *     \             -     |   /     /             |     -   \     *
#*     *     \           -     |     /     /           |     -     \     *
# *     *     \         -     |       /     /         |     -       \     *
#  *     *     \       -     |         /     /       |     -         \     *
#   *     *     \     -     |           /     /     |     -           \     *
#    *     *     \   -     |             /     /   |     -             \     *
#     *     *     \ -     |               /     / |     -               \     
#      *     -     \     |                 /     /     -                 \    
#	*   - *   - \   |                   /   | /   -                   \   
#	 * -   * -   \ |                     / |   / -                     \ _
#	  -     -     \                       |     /                       _
#-----------------------------

#-----------------------------
#% tkshufflepod chap15.pod
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# tkshufflepod - reorder =head1 sections in a pod file

use Tk;
use strict;

# declare variables

my $podfile;    		 # name of the file to open
my $m;    			     # main window
my $l;    			     # listbox
my ($up, $down);   # positions to move
my @sections;      # list of pod sections
my $all_pod;       # text of pod file (used when reading)

# read the pod file into memory, and split it into sections.

$podfile = shift || "-";

undef $/;
open(F, "< $podfile")
  or die "Can't open $podfile : $!\n";
$all_pod = <F>;
close(F);
@sections = split(/(?==head1)/, $all_pod);

# turn @sections into an array of anonymous arrays.  The first element
# in each of these arrays is the original text of the message, while
# the second element is the text following =head1 (the section title).

foreach (@sections) {
    /(.*)/;
    $_ = [ $_, $1 ];
}

# fire up Tk and display the list of sections.

$m = MainWindow->new();
$l = $m->Listbox('-width' => 60)->pack('-expand' => 1, '-fill' => 'both');

foreach my $section (@sections) {
    $l->insert("end", $section->[1]);
}

# permit dragging by binding to the Listbox widget.
$l->bind( '<Any-Button>'     => \&down );
$l->bind( '<Any-ButtonRelease>' => \&up );

# permit viewing by binding double-click
$l->bind( '<Double-Button>'     => \&view );

# 'q' quits and 's' saves
$m->bind( '<q>'     	=> sub { exit } );
$m->bind( '<s>'    		=> \&save );

MainLoop;

# down(widget): called when the user clicks on an item in the Listbox.

sub down {
    my $self = shift;
    $down = $self->curselection;;
}

# up(widget): called when the user releases the mouse button in the
# Listbox.

sub up {
    my $self = shift;
    my $elt;

    $up = $self->curselection;;

    return if $down == $up;

    # change selection list
    $elt = $sections[$down];
    splice(@sections, $down, 1);
    splice(@sections, $up, 0, $elt);
    $self->delete($down);
    $self->insert($up, $sections[$up]->[1]);
}

# save(widget): called to save the list of sections.

sub save {
    my $self = shift;

    open(F, "> $podfile")
      or die "Can't open $podfile for writing: $!";
    print F map { $_->[0] } @sections;
    close F;

    exit;
}

# view(widget): called to display the widget.  Uses the Pod widget.

sub view {
    my $self = shift;
    my $temporary = "/tmp/$$-section.pod";
    my $popup;

    open(F, "> $temporary")
      or warn ("Can't open $temporary : $!\n"), return;
    print F $sections[$down]->[0];
    close(F);
    $popup = $m->Pod('-file' => $temporary);

    $popup->bind('<Destroy>' => sub { unlink $temporary } );
}

#-----------------------------