PLEAC-Perl 教程 - User Interfaces (Perl进阶者极力推荐)

最新推荐文章于 2024-08-08 13:28:00 发布
最新推荐文章于 2024-08-08 13:28:00 发布
阅读量952 收藏
点赞数
分类专栏： C & Perl 文章标签： perl user button dialog download output

15. User Interfaces

<script type="text/javascript"> var AdBrite_Title_Color = '0000FF'; var AdBrite_Text_Color = '000000'; var AdBrite_Background_Color = 'FFFFFF'; var AdBrite_Border_Color = 'CCCCCC'; var AdBrite_URL_Color = '008000'; </script> <script src="http://ads.adbrite.com/mb/text_group.php?sid=668781&zs=3732385f3930" type="text/javascript"></script> Your Ad Here

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 ___FCKpd___9lt; )[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 } );
}

#-----------------------------
bsdplus
关注
  • 0
    点赞
  • 踩
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
专栏目录
perl语言进阶
04-23
《Perl语言进阶》这本书不仅是一本关于Perl语言的教程，更是一本深入探索现代计算技术领域的指南。通过对上述章节的细致学习，读者不仅能掌握Perl的高级特性和技术细节，还能了解到如何将这些知识应用于解决实际问题...
perl获取当前用户名
weixin_34289744的博客
04-15 466
在perl中获取当前登陆的用户名,要求在windows和linux下都可用.通过读取系统的环境变量实现，在xp和linux下测试通过,代码如下: my $Sys_name = $^O;if ($Sys_name =~ /MSWin32/){ print $ENV{'USERNAME'},"\n";}else { if($Sys_name ...
Perl 中关于 LWP::UserAgent等模块用法
高锦的博客
06-12 6823
大多数perl关联http模块一般用法
perl详解
彦彦专栏
12-04 5573
第一章 概述 一、Perl是什么?       Perl是Practical Extraction and Report Language的缩写，它是由Larry Wall设计的，并由他不断更新和维护，用于在UNIX环境下编程。       .Perl具有高级语言（如C）的强大能力和灵活性。事实上，你将看到，它的许多特性是从C语言中借用来的。       .与脚本语言一样，Perl不需
perl获取当前系统用户名以及其他
forlong401的专栏--有问题上：http://www.androidren.com
01-08 3444
http://hi.baidu.com/study_cs/item/03d6ce26d8b58e4247996223 在perl中获取当前登陆的用户名,要求在windows和linux下都可用.通过读取系统的环境变量实现，在xp和linux下测试通过,代码如下:      my $Sys_name = $^O;     if ($Sys_name =~ /MSWin32/){
Perl入门学习（一）运行和基本语法
热门推荐
m0_61544122的博客
05-08 1万+
perl程序的运行方法
Using Perl For Web Programming.pdf
08-18
The Future of Web/Database Interfaces G From Here... G Chapter 13 Special Variables $<I<digit>> G $[ G $ACCUMULATOR G $ARG G $ARGV G $BASETIME G $CHILD_ERROR G $DEBUGGING G CONTENTS ...
Mastering_Perl_Tk_1st_ed_2002.pdf
03-19
Perl/Tk is an extension to the Perl programming language that allows for the creation of graphical user interfaces (GUIs). The authors have structured the book to cover the essential concepts and ...
LINUX-SAMBA服务配置.doc
02-23
2. 安装必要的软件包，包括`samba-common`（提供配置文件和语法检查工具）、`samba-client`（客户端软件）、`perl-Convert-ASN1`（依赖项）、`samba`（服务器端软件）以及`xinetd`（用于支持SAMBA的WEB配置工具samba...
Perl套接字编程指南：构建网络通信应用
2402_85762143的博客
08-08 577
Perl是一种功能强大的脚本语言，广泛应用于系统管理、网络编程等多种场景。Perl的套接字编程能力允许开发者创建客户端和服务器端的网络应用。本文将详细介绍Perl中套接字的使用，包括基础概念、API的使用，以及构建简单客户端和服务器的示例代码。
DBO-CNN-BiLSTM-Attention蜣螂算法优化多变量时间序列预测，含优化前后对比（Matlab完整源码和数据）
08-17
1.Matlab实现DBO蜣螂算法优化CNN-BiLSTM-Attention多变量时间序列预测，含优化前后对比（Matlab完整源码和数据）优化学习率，神经元个数，注意力机制的键值, 正则化参数。 2.输出MAE 、 MAPE、MSE、RMSE、R2多指标评价，运行环境Matlab2023及以上。 3.代码特点：参数化编程、参数可方便更改、代码编程思路清晰、注释明细。 4.适用对象：计算机，电子信息工程、数学等专业的大学生课程设计、期末大作业和毕业设计。 5.作者介绍：机器学习之心，博客专家认证，机器学习领域创作者，2023博客之星TOP50，主做机器学习和深度学习时序、回归、分类、聚类和降维等程序设计和案例分析，文章底部有博主联系方式。从事Matlab、Python算法仿真工作8年，更多仿真源码、数据集定制私信.
财务现金记账表（公式计算日期查询）.xlsx
最新发布
08-17
工资表，财务报表，对账表，付款申请，财务报告，费用支出表 适用人群：学习不同技术领域的小白或进阶学习者；可作为毕设项目、课程设计、大作业、工程实训或初期项目立项。
asp.net高校网上教材征订系统的设计与实现(源代码+论文)
08-17
该项目展示了一个基于ASP.NET的高校网上教材征订系统的设计与实现，涵盖源代码和论文部分。该系统旨在简化高校教材征订流程，提高教材管理效率。 源代码 部分包含以下功能模块： 用户管理： 提供用户注册、登录和角色管理功能。包括学生、教师和管理员等不同角色的权限设置，以确保系统的安全性和数据的隐私保护。 教材管理： 实现教材信息的添加、编辑和删除。系统支持教材的分类管理、信息搜索和浏览，确保教材数据的准确性和可用性。 征订管理： 学生可以在线浏览教材列表并提交征订申请，系统支持订单处理、支付集成及订单状态跟踪。管理员可以审核订单、生成发货单并处理退款请求。 报表生成： 提供统计报表生成功能，包括教材销售情况、订单统计、用户活动等，帮助管理人员做出数据驱动的决策。 用户界面： 使用ASP.NET MVC框架构建，前端界面简洁友好，支持多终端访问。系统设计注重用户体验，提供流畅的操作体验。 论文 部分详细描述了系统的设计与实现过程： 需求分析： 明确了系统的主要需求，包括用户管理、教材管理、征订管理和报表功能，确保系统符合用户需求。 系统架构设计： 介绍了系统的总体架构，包
财务系统（小企业会计记账软件）.xls
08-17
工资表，财务报表，对账表，付款申请，财务报告，费用支出表 适用人群：学习不同技术领域的小白或进阶学习者；可作为毕设项目、课程设计、大作业、工程实训或初期项目立项。
农牧集团企业数字化建设总体规划SAP解决方案参考.pdf
08-17
农牧集团企业数字化建设总体规划SAP解决方案参考.pdf
java基于ssm+jsp web个人财务管理系统源码 带毕业论文
08-17
【资源说明】 1、开发环境：ssm框架；内含Mysql数据库；JSP技术 2、该资源包括项目的全部源码，下载可以直接使用！ 3、本项目适合作为计算机、数学、电子信息等专业的课程设计、期末大作业和毕设项目，作为参考资料学习借鉴。 4、本资源作为“参考资料”如果需要实现其他功能，需要能看懂代码，并且热爱钻研，自行调试。
基于STM32+ESP8266实现MQTT客户端协议可远程控制开发板上LED灯源码+项目说明.zip
08-17
本实例代码已在STM32F407ZGTx上测试通过，如在其它型号上运行，可以按以下方法进行简单的移植。 1、用STM32CubeMX配置工程，使能与ESP8266相连接的串口的接收DMA功能，并且使能全局中断。 2、复制esp8266.c、esp8266.h、mqtt.c、mqtt.h到工程相应目录。
java基于ssm+vue在线测试管理系统源码 带毕业论文
08-17
【资源说明】 1、开发环境：ssm框架；内含Mysql数据库；VUE技术 2、该资源包括项目的全部源码，下载可以直接使用！ 3、本项目适合作为计算机、数学、电子信息等专业的课程设计、期末大作业和毕设项目，作为参考资料学习借鉴。 4、本资源作为“参考资料”如果需要实现其他功能，需要能看懂代码，并且热爱钻研，自行调试。
xconf -s /etc/network/interfaces
05-31
这个命令是用来读取并显示 Linux 系统中网络接口的配置文件 /etc/network/interfaces 的内容。该文件用于配置系统中的网络接口，定义了如何配置网络接口并指定网络参数，如 IP 地址、子网掩码、网关等。通过使用 xconf 工具，可以查看此文件的内容，以便更好地了解系统的网络配置信息。
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值