Perl/FAQ/Пользовательский интерфейс

Материал из Wiki.crossplatform.ru

Перейти к: навигация, поиск
Perl ·

Содержание

Parsing Program Arguments

#-----------------------------
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";
 
#-----------------------------

Testing Whether a Program Is Running Interactively

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

Clearing the Screen

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

Determining Terminal or Window Size

#-----------------------------
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*$_));
}
 
#-----------------------------

Changing Text Color

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

Reading from the Keyboard

#-----------------------------
 
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');
 
#-----------------------------

Ringing the Terminal Bell

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

Using POSIX termios

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

Checking for Waiting Input

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

Reading Passwords

#-----------------------------
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";
}
 
#-----------------------------

Editing Input

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

Managing the Screen

#-----------------------------
#% 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".
#-----------------------------

Controlling Another Program with Expect

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

Creating Menus with Tk

#-----------------------------
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');
 
#-----------------------------

Creating Dialog Boxes with Tk

#-----------------------------
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;
}
 
#-----------------------------

Responding to Tk Resize Events

#-----------------------------
 
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" );
 
#-----------------------------

Removing the DOS Shell Window with Windows Perl/Tk

#-----------------------------
# 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() );
 
}
 
#-----------------------------

Program: Small termcap program

#-----------------------------
# 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();
}
 
#-----------------------------
#*     _                       /     |                       \     -
# *   _ \                     - /   | /                     | \   - *
#  * _   \                   -   / |   /                   |   \ -   *
#   *     \                 -     |     /                 |     -     *
#  _ *     \               -     | /     /               |     - \     *
# _   *     \             -     |   /     /             |     -   \     *
#*     *     \           -     |     /     /           |     -     \     *
# *     *     \         -     |       /     /         |     -       \     *
#  *     *     \       -     |         /     /       |     -         \     *
#   *     *     \     -     |           /     /     |     -           \     *
#    *     *     \   -     |             /     /   |     -             \     *
#     *     *     \ -     |               /     / |     -               \     
 
#      *     -     \     |                 /     /     -                 \    
#	*   - *   - \   |                   /   | /   -                   \   
#	 * -   * -   \ |                     / |   / -                     \ _
#	  -     -     \                       |     /                       _
#-----------------------------

Program: tkshufflepod

#-----------------------------
#% 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 } );
 
}
 
#-----------------------------