Perl/FAQ/Пакеты, библиотеки и модули

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

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

Содержание

[править] Introduction 

#-----------------------------
package Alpha;
$name = "first";
 
package Omega;
$name = "last";
 
package main;
print "Alpha is $Alpha::name, Omega is $Omega::name.\n";
 
Alpha is first, Omega is last.
#-----------------------------
require "FileHandle.pm";            # run-time load
require FileHandle;                 # ".pm" assumed; same as previous
 
use FileHandle;                     # compile-time load
 
require "Cards/Poker.pm";           # run-time load
require Cards::Poker;               # ".pm" assumed; same as previous
 
use Cards::Poker;                   # compile-time load
#-----------------------------
1    package Cards::Poker;
2    use Exporter;
 
3    @ISA = ('Exporter');
4    @EXPORT = qw(&shuffle @card_deck);
 
5    @card_deck = ();                       # initialize package global
6    sub shuffle { }                        # fill-in definition later
 
7    1;                                     # don't forget this
#-----------------------------

[править] Defining a Module's Interface 

#-----------------------------
package YourModule;
use strict;
 
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
 
use Exporter;
$VERSION = 1.00;              # Or higher
@ISA = qw(Exporter);
 
@EXPORT      = qw(...);       # Symbols to autoexport (:DEFAULT tag)
@EXPORT_OK   = qw(...);       # Symbols to export on request
 
%EXPORT_TAGS = (              # Define names for sets of symbols
    TAG1 => [...],
    TAG2 => [...],
    ...
 
);
 
########################
# your code goes here
########################
 
1;                            # this should be your last line
#-----------------------------
use YourModule;               # Import default symbols into my package.
use YourModule qw(...);       # Import listed symbols into my package.
 
use YourModule ();            # Do not import any symbols
use YourModule qw(:TAG1);     # Import whole tag set
#-----------------------------
 
    @EXPORT = qw(&F1 &F2 @List);
    @EXPORT = qw( F1  F2 @List);        # same thing
#-----------------------------
 
    @EXPORT_OK = qw(Op_Func %Table);
#-----------------------------
    use YourModule qw(Op_Func %Table F1);
 
#-----------------------------
    use YourModule qw(:DEFAULT %Table);
#-----------------------------
    %EXPORT_TAGS = (
 
        Functions => [ qw(F1 F2 Op_Func) ],
        Variables => [ qw(@List %Table)  ],
 
);
#-----------------------------
    use YourModule qw(:Functions %Table);
#-----------------------------
    @{
 
 
$YourModule::EXPORT_TAGS{Functions}
 
}
, 
#-----------------------------

[править] Trapping Errors in require or use 

#-----------------------------
# no import
 
BEGIN {
    unless (eval "require $mod") {
        warn "couldn't load $mod: $@";
 
    }
}
 
# imports into current package
BEGIN {
    unless (eval "use $mod") {
 
        warn "couldn't load $mod: $@";
    }
}
#-----------------------------
BEGIN {
    my($found, @DBs, $mod);
 
    $found = 0;
    @DBs = qw(Giant::Eenie Giant::Meanie Mouse::Mynie Moe);
    for $mod (@DBs) {
 
        if (eval "require $mod") {
            $mod->
import
();         # if needed
 
            $found = 1;
            last;
        }
    }
    die "None of @DBs loaded" unless $found;
 
}
#-----------------------------

[править] Delaying use Until Run Time 

#-----------------------------
BEGIN {
    unless (@ARGV == 2 && (2 == grep {/^\d+$/} @ARGV)) {
 
        die "usage: $0 num1 num2\n";
    }
}
use Some::Module;
use More::Modules;
 
#-----------------------------
if ($opt_b) {
    require Math::BigInt;
}
 
#-----------------------------
use Fcntl qw(O_EXCL O_CREAT O_RDWR);
#-----------------------------
require Fcntl;
Fcntl->import(qw(O_EXCL O_CREAT O_RDWR));
 
#-----------------------------
sub load_module {
    require $_[0];  #WRONG
    import  $_[0];  #WRONG
 
}
#-----------------------------
load_module('Fcntl', qw(O_EXCL O_CREAT O_RDWR));
 
sub load_module {
 
    eval "require $_[0]";
    die if $@;
    $_[0]->import(@_[1 .. $#_]);
 
}
#-----------------------------
use autouse Fcntl => qw( O_EXCL() O_CREAT() O_RDWR() );
 
#-----------------------------

[править] Making Variables Private to a Module 

#-----------------------------
package Alpha;
my $aa = 10;
   $x = "azure";
 
package Beta;
my $bb = 20;
   $x = "blue";
 
package main;
print "$aa, $bb, $x, $Alpha::x, $Beta::x\n";
10, 20, , azure, blue
#-----------------------------
# Flipper.pm
package Flipper;
 
use strict;
 
require Exporter;
use vars qw(@ISA @EXPORT $VERSION);
 
@ISA     = qw(Exporter);
@EXPORT  = qw(flip_words flip_boundary);
$VERSION = 1.0;
 
my $Separatrix = ' ';  # default to blank; must precede functions
 
sub flip_boundary {
 
    my $prev_sep = $Separatrix;
    if (@_) { $Separatrix = $_[0] }
 
    return $prev_sep;
}
sub flip_words {
    my $line  = $_[0];
 
    my @words = split($Separatrix, $line);
    return join($Separatrix, reverse @words);
 
}
1;
#-----------------------------

[править] Determining the Caller's Package 

#-----------------------------
$this_pack = __PACKAGE__;
#-----------------------------
$that_pack = caller();
 
#-----------------------------
print "I am in package __PACKAGE__\n";              # WRONG!
I am in package __PACKAGE__
#-----------------------------
package Alpha;
 
runit('$line = <TEMP>');
 
package Beta;
sub runit {
 
    my $codestr = shift;
    eval $codestr;
    die if $@;
 
}
#-----------------------------
package Beta;
sub runit {
    my $codestr = shift;
 
    my $hispack = caller;
    eval "package $hispack; $codestr";
    die if $@;
 
}
#-----------------------------
package Alpha;
runit( sub { $line = <TEMP> } );
 
package Beta;
sub runit {
    my $coderef = shift;
 
    &$coderef();
}
#-----------------------------
open (FH, "< /etc/termcap")
    or die "can't open /etc/termcap: $!";
 
($a, $b, $c) = nreadline(3, 'FH');
 
use Symbol ();
 
use Carp;
sub nreadline {
    my ($count, $handle) = @_;
 
    my(@retlist,$line);
 
    croak "count must be > 0" unless $count > 0;
 
    $handle = Symbol::qualify($handle, (
caller()
)[0]);
    croak "need open filehandle" unless defined fileno($handle);
 
    push(@retlist, $line) while defined($line = <$handle>) && $count--;
 
    return @retlist;
}
#-----------------------------

[править] Automating Module Clean-Up 

#-----------------------------
$Logfile = "/tmp/mylog" unless defined $Logfile;
 
open(LF, ">>$Logfile")
    or die "can't append to $Logfile: $!";
select(((select(LF), $|=1))[0]);  # unbuffer LF
 
logmsg("startup");
 
sub logmsg {
    my $now = scalar gmtime;
 
    print LF "$0 $$ $now: @_\n"
        or die "write to $Logfile failed: $!";
}
 
END {
    logmsg("shutdown");
    close(LF)                     
 
        or die "close $Logfile failed: $!";
}
#-----------------------------
use sigtrap qw(die normal-signals error-signals);
 
#-----------------------------

[править] Keeping Your Own Module Directory 

#-----------------------------
#% perl -e 'for (@INC) { printf "%d %s\n", $i++, $_ }'
#0 /usr/local/perl/lib/i686-linux/5.004
#
#1 /usr/local/perl/lib
#
#2 /usr/local/perl/lib/site_perl/i686-linux
#
#3 /usr/local/perl/lib/site_perl
#
#4 .
#-----------------------------
# syntax for sh, bash, ksh, or zsh
#$ export PERL5LIB=$HOME/perllib
 
# syntax for csh or tcsh
#% setenv PERL5LIB ~/perllib
#-----------------------------
use lib "/projects/spectre/lib";
 
#-----------------------------
use FindBin;
use lib $FindBin::Bin;
#-----------------------------
use FindBin qw($Bin);
 
use lib "$Bin/../lib";
#-----------------------------

[править] Preparing a Module for Distribution 

#-----------------------------
#% h2xs -XA -n Planets
#% h2xs -XA -n Astronomy::Orbits
#-----------------------------
package Astronomy::Orbits;
#-----------------------------
require Exporter;
 
require AutoLoader;
@ISA = qw(Exporter AutoLoader);
#-----------------------------
require Exporter;
 
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
#-----------------------------
#% make dist
#-----------------------------

[править] Speeding Module Loading with SelfLoader 

#-----------------------------
require Exporter;
 
require SelfLoader;
@ISA = qw(Exporter SelfLoader);
#
# other initialization or declarations here
#
#__DATA__
#sub abc { .... }
#sub def { .... }
#-----------------------------

[править] Speeding Up Module Loading with Autoloader 

#-----------------------------
#% h2xs -Xn Sample
#% cd Sample
#% perl Makefile.PL LIB=~/perllib
#% (edit Sample.pm)
#% make install
#-----------------------------

[править] Overriding Built-In Functions 

#-----------------------------
 
package FineTime;
use strict;
require Exporter;
use vars qw(@ISA @EXPORT_OK);
 
@ISA = qw(Exporter);
@EXPORT_OK = qw(time);
 
sub time() { ..... }  # TBA
#-----------------------------
use FineTime qw(time);
 
$start = time();
1 while print time() - $start, "\n";
 
#-----------------------------

[править] Reporting Errors and Warnings Like Built-Ins 

#-----------------------------
sub even_only {
    my $n = shift;
 
    die "$n is not even" if $n & 1;  # one way to test
    #....
}
 
#-----------------------------
use Carp;
sub even_only {
    my $n = shift;
 
    croak "$n is not even" if $n % 2;  # here's another
    #....
}
#-----------------------------
use Carp;
 
sub even_only {
    my $n = shift;
    if ($n & 1) {         # test whether odd number
 
        carp "$n is not even, continuing";
        ++$n;
    }
    #....
}
#-----------------------------
 
carp "$n is not even, continuing" if $^W;
#-----------------------------

[править] Referring to Packages Indirectly 

#-----------------------------
{
    no strict 'refs';
 
    $val  = ${ $packname . "::" . $varname };
    @vals = @{ $packname . "::" . $aryname };
 
    &{ $packname . "::" . $funcname }("args");
    ($packname . "::" . $funcname) -> ("args");
 
}
#-----------------------------
eval "package $packname; \$'$val = \$$varname"; # set $main'val
die if $@;
#-----------------------------
 
printf "log2  of 100 is %.2f\n", log2(100);
printf "log10 of 100 is %.2f\n", log10(100);
#-----------------------------
 
$packname = 'main';
for ($i = 2; $i < 1000; $i++) {
 
    $logN = log($i);
    eval "sub ${packname}::log$i { log(shift) / $logN }";
    die if $@;
 
}
#-----------------------------
$packname = 'main';
for ($i = 2; $i < 1000; $i++) {
 
    my $logN = log($i);
    no strict 'refs';
 
    *{"${packname}::log$i"} = sub { log(shift) / $logN };
 
}
#-----------------------------
*blue       = \&Colors::blue;
*main::blue = \&Colors::azure;
#-----------------------------

[править] Using h2ph to Translate C #include Files 

#-----------------------------
#Can't locate sys/syscall.ph in @INC (did you run h2ph?)
#
#(@INC contains: /usr/lib/perl5/i686-linux/5.00404 /usr/lib/perl5
#
#/usr/lib/perl5/site_perl/i686-linux /usr/lib/perl5/site_perl .)
#
#at some_program line 7.
#-----------------------------
#% cd /usr/include; h2ph sys/syscall.h
#-----------------------------
#% cd /usr/include; h2ph *.h */*.h
#-----------------------------
#% cd /usr/include; find . -name '*.h' -print | xargs h2ph
#-----------------------------
# file FineTime.pm
 
package main;
require 'sys/syscall.ph';
die "No SYS_gettimeofday in sys/syscall.ph"
    unless defined &SYS_gettimeofday;
 
package FineTime;
    use strict;
require Exporter;
 
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
 
@EXPORT_OK = qw(time);
 
sub time() {
    my $tv = pack("LL", ());  # presize buffer to two longs
 
    syscall(&main::SYS_gettimeofday, $tv, undef) >= 0
        or die "gettimeofday: $!";
 
    my($seconds, $microseconds) = unpack("LL", $tv);
    return $seconds + ($microseconds / 1_000_000);
 
}
 
1;
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# jam - stuff characters down STDIN's throat
require 'sys/ioctl.ph';
die "no TIOCSTI" unless defined &TIOCSTI;
 
sub jam {
    local $SIG{TTOU} = "IGNORE"; # "Stopped for tty output"
 
    local *TTY;  # make local filehandle
    open(TTY, "+</dev/tty")                 or die "no tty: $!";
 
    for (split(//, $_[0])) {
        ioctl(TTY, &TIOCSTI, $_)            or die "bad TIOCSTI: $!";
 
    }
    close(TTY);
}
jam("@ARGV\n");
 
#-----------------------------
#% cat > tio.c <<EOF && cc tio.c && a.out
##include <sys/ioctl.h>
#main() { printf("%#08x\n", TIOCSTI); }
#EOF
#0x005412
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# winsz - find x and y for chars and pixels
 
require 'sys/ioctl.ph';
die "no TIOCGWINSZ " unless defined &TIOCGWINSZ;
open(TTY, "+</dev/tty")                     or die "No tty: $!";
 
unless (ioctl(TTY, &TIOCGWINSZ, $winsize='')) {
    die sprintf "$0: ioctl TIOCGWINSZ (%08x: $!)\n", &TIOCGWINSZ;
 
}
($row, $col, $xpixel, $ypixel) = unpack('S4', $winsize);
print "(row,col) = ($row,$col)";
 
print "  (xpixel,ypixel) = ($xpixel,$ypixel)" if $xpixel || $ypixel;
print "\n";
 
#-----------------------------

[править] Using h2xs to Make a Module with C Code 

#-----------------------------
#% perl Makefile.PL
#% make
#-----------------------------
#% h2xs -cn FineTime
#-----------------------------
#% perl Makefile.PL
#-----------------------------
#'LIBS'      => [''],   # e.g., '-lm'
#-----------------------------
#'LIBS'      => ['-L/usr/redhat/lib -lrpm'],
#-----------------------------
#% perl Makefile.PL LIB=~/perllib
#-----------------------------
package FineTime;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
 
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
 
@EXPORT_OK = qw(time);
$VERSION = '0.01';
bootstrap FineTime $VERSION;
 
1;
#-----------------------------
#include <unistd.h>
#include <sys/time.h>
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
 
 
MODULE = FineTime           PACKAGE = FineTime
 
double
time()
    CODE:
        struct timeval tv;
        gettimeofday(&tv,0);
 
        RETVAL = tv.tv_sec + ((double) tv.tv_usec) / 1000000;
    OUTPUT:
        RETVAL
 
#-----------------------------
#% make install
#mkdir ./blib/lib/auto/FineTime
#cp FineTime.pm ./blib/lib/FineTime.pm
#/usr/local/bin/perl -I/usr/lib/perl5/i686-linux/5.00403  -I/usr/lib/perl5
#/usr/lib/perl5/ExtUtils/xsubpp -typemap 
#    /usr/lib/perl5/ExtUtils/typemap FineTime.xs
#FineTime.tc && mv FineTime.tc FineTime.ccc -c -Dbool=char -DHAS_BOOL 
#    -O2-DVERSION=\"0.01\" -DXS_VERSION=\"0.01\" -fpic 
 
#    -I/usr/lib/perl5/i686-linux/5.00403/CORE  
#FineTime.cRunning Mkbootstrap for FineTime ()
#chmod 644 FineTime.bs
#LD_RUN_PATH="" cc -o blib/arch/auto/FineTime/FineTime.so 
#    -shared -L/usr/local/lib FineTime.o
#chmod 755 blib/arch/auto/FineTime/FineTime.so
#cp FineTime.bs ./blib/arch/auto/FineTime/FineTime.bs
#chmod 644 blib/arch/auto/FineTime/FineTime.bs
#Installing /home/tchrist/perllib/i686-linux/./auto/FineTime/FineTime.so
#Installing /home/tchrist/perllib/i686-linux/./auto/FineTime/FineTime.bs
#Installing /home/tchrist/perllib/./FineTime.pm
#Writing /home/tchrist/perllib/i686-linux/auto/FineTime/.packlist
#Appending installation info to /home/tchrist/perllib/i686-linux/perllocal.pod
#-----------------------------
#% perl -I ~/perllib -MFineTime=time -le '1 while print time()' | head
#888177070.090978
#
#888177070.09132
#
#888177070.091389
#
#888177070.091453
#
#888177070.091515
#
#888177070.091577
#
#888177070.091639
#
#888177070.0917
#
#888177070.091763
#
#888177070.091864
#-----------------------------

[править] Documenting Your Module with Pod 

#-----------------------------
#=head2 Discussion
#
#If we had a I<.h> file with function prototype declarations, we
#could include that, but since we're writing this one from scratch,
#we'll use the B<-c> flag to omit building code to translate any
#C<#define> symbols. The B<-n> flag says to create a module directory
#named I<FineTime/>, which will have the following files.
#-----------------------------
#=for troff
#.EQ
#log sub n (x) = { {log sub e (x)} over {log sub e (n)} }
#.EN
#-----------------------------
#=for later
#next if 1 .. ?^$?;
#s/^(.)/>$1/;
#s/(.{73})........*/$1<SNIP>/;
#
#=cut back to perl
#-----------------------------
 
=begin comment
 
if (!open(FILE, $file)) {
    unless ($opt_q) {  #)
 
        warn "$me: $file: $!\n";
        $Errors++;
    }
    next FILE;
 
}
 
$total = 0;
$matches = 0;
 
=end comment
#-----------------------------

[править] Building and Installing a CPAN Module 

#-----------------------------
#% gunzip Some-Module-4.54.tar.gz
#% tar xf Some-Module-4.54
#% cd Some-Module-4.54
#% perl Makefile.PL
#% make
#% make test
#% make install
#-----------------------------
#% gunzip MD5-1.7.tar.gz
#% tar xf MD5-1.7.tar
#% cd MD5-1.7
#% perl Makefile.PL 
 
#Checking if your kit is complete...
#
#Looks good
#
#Writing Makefile for MD5
#
#% make
#mkdir ./blib
#
#mkdir ./blib/lib
#
#cp MD5.pm ./blib/lib/MD5.pm
#
#AutoSplitting MD5 (./blib/lib/auto/MD5)
#
#/usr/bin/perl -I/usr/local/lib/perl5/i386 ...
#
#...
#
#cp MD5.bs ./blib/arch/auto/MD5/MD5.bs
#
#chmod 644 ./blib/arch/auto/MD5/MD5.bsmkdir ./blib/man3
#
#Manifying ./blib/man3/MD5.3
#
#% make test
#PERL_DL_NONLAZY=1 /usr/bin/perl -I./blib/arch -I./blib/lib
#
#-I/usr/local/lib/perl5/i386-freebsd/5.00404 -I/usr/local/lib/perl5 test.pl
#
#1..14
#
#ok 1
#
#ok 2
#
#...
#
#ok 13
#
#ok 14
#
#% sudo make install
#Password:
#
#Installing /usr/local/lib/perl5/site_perl/i386-freebsd/./auto/MD5/
#
#    MD5.so
#
#Installing /usr/local/lib/perl5/site_perl/i386-freebsd/./auto/MD5/
#
#    MD5.bs
#
#Installing /usr/local/lib/perl5/site_perl/./auto/MD5/autosplit.ix
#
#Installing /usr/local/lib/perl5/site_perl/./MD5.pm
#
#Installing /usr/local/lib/perl5/man/man3/./MD5.3
#
#Writing /usr/local/lib/perl5/site_perl/i386-freebsd/auto/MD5/.packlist
#
#Appending installation info to /usr/local/lib/perl5/i386-freebsd/
#
#5.00404/perllocal.pod
#-----------------------------
# if you just want the modules installed in your own directory
#% perl Makefile.PL LIB=~/lib
#
# if you have your own a complete distribution
#% perl Makefile.PL PREFIX=~/perl5-private
#-----------------------------

[править] Example: Module Template 

#-----------------------------
package Some::Module;  # must live in Some/Module.pm
 
use strict;
 
require Exporter;
 
use vars       qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
 
# set the version for version checking
$VERSION     = 0.01;
 
@ISA         = qw(Exporter);
@EXPORT      = qw(&func1 &func2 &func4);
 
%EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
 
# your exported package globals go here,
# as well as any optionally exported functions
@EXPORT_OK   = qw($Var1 %Hashit &func3);
 
use vars qw($Var1 %Hashit);
# non-exported package globals go here
use vars      qw(@more $stuff);
 
# initialize package globals, first exported ones
$Var1   = '';
%Hashit = ();
 
# then the others (which are still accessible as $Some::Module::stuff)
$stuff  = '';
 
@more   = ();
 
# all file-scoped lexicals must be created before
# the functions below that use them.
 
# file-private lexicals go here
my $priv_var    = '';
 
my %secret_hash = ();
 
# here's a file-private function as a closure,
# callable as &$priv_func.
my $priv_func = sub {
 
    # stuff goes here.
};
 
# make all your functions, whether exported or not;
# remember to put something interesting in the {} stubs
sub func1      { .... }    # no prototype
sub func2()    { .... }    # proto'd void
 
sub func3($$)  { .... }    # proto'd to 2 scalars
 
# this one isn't auto-exported, but could be called!
sub func4(\%)  { .... }    # proto'd to 1 hash ref
 
 
END { }       # module clean-up code here (global destructor)
 
1;
#-----------------------------

[править] Program: Finding Versions and Descriptions of Installed Modules 

#-----------------------------
#% pmdesc
#-----------------------------
#FileHandle (2.00) - supply object methods for filehandles
#
#IO::File (1.06021) - supply object methods for filehandles
#
#IO::Select (1.10) - OO interface to the select system call
#
#IO::Socket (1.1603) - Object interface to socket communications
#
#...
#-----------------------------
#% pmdesc -v
#
#<<<Modules from /usr/lib/perl5/i686-linux/5.00404>>>
 
#
#
#FileHandle (2.00) - supply object methods for filehandles
#
#    ...
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# pmdesc - describe pm files
# tchrist@perl.com
 
use strict;
use File::Find      qw(find);
 
use Getopt::Std     qw(getopts);
use Carp;
 
use vars (
 
    q!$opt_v!,              # give debug info
    q!$opt_w!,              # warn about missing descs on modules
    q!$opt_a!,              # include relative paths
    q!$opt_s!,              # sort output within each directory
 
);
 
$| = 1;
 
getopts('wvas')             or die "bad usage";
 
@ARGV = @INC unless @ARGV;
 
# Globals.  wish I didn't really have to do this.
use vars (
 
    q!$Start_Dir!,          # The top directory find was called with
    q!%Future!,             # topdirs find will handle later
);
 
my $Module;
 
# install an output filter to sort my module list, if wanted.
if ($opt_s) {
    if (open(ME, "-|")) {
 
        $/ = '';
        while (<ME>) {
            chomp;
 
            print join("\n", sort split /\n/), "\n";
 
        }
        exit;
    }
}
 
MAIN: {
 
    my %visited;
    my ($dev,$ino);
 
    @Future{@ARGV} = (1) x @ARGV;
 
    foreach $Start_Dir (@ARGV) {
        delete $Future{$Start_Dir};
 
        print "\n<<Modules from $Start_Dir>>\n\n"
            if $opt_v;
 
        next unless ($dev,$ino) = stat($Start_Dir);
 
        next if $visited{$dev,$ino}++;
        next unless $opt_a || $Start_Dir =~ m!^/!;
 
        find(\&wanted, $Start_Dir);
    }
    exit;
}
 
# calculate module name from file and directory
sub modname {
    local $_ = $File::Find::name;
 
    if (index($_, $Start_Dir . '/') == 0) {
        substr($_, 0, 1+length($Start_Dir)) = '';
 
    }
 
    s { /              }    {::}gx;
 
    s { \.p(m|od)$     }    {}x;
 
    return $_;
}
 
# decide if this is a module we want
sub wanted {
 
    if ( $Future{$File::Find::name} ) {
        warn "\t(Skipping $File::Find::name, qui venit in futuro.)\n"
 
            if 0 and $opt_v;
        $File::Find::prune = 1;
        return;
 
    }
    return unless /\.pm$/ && -f;
    $Module = &modname;
 
    # skip obnoxious modules
    if ($Module =~ /^CPAN(\Z|::)/) {
        warn("$Module -- skipping because it misbehaves\n");
 
        return;
    }
 
    my    $file = $_;
 
    unless (open(POD, "< $file")) {
        warn "\tcannot open $file: $!";
 
            # if $opt_w;
        return 0;
    }
 
    $: = " -:";
 
    local $/ = '';
    local $_;
    while (<POD>) {
 
        if (/=head\d\s+NAME/) {
            chomp($_ = <POD>);
            s/^.*?-\s+//s;
 
            s/\n/ /g;
            #write;
            my $v;
            if (defined ($v = getversion($Module))) {
 
                print "$Module ($v) ";
            } else {
                print "$Module ";
 
            }
            print "- $_\n";
            return 1;
        }
 
    }
 
    warn "\t(MISSING DESC FOR $File::Find::name)\n"
        if $opt_w;
 
    return 0;
 
}
 
# run Perl to load the module and print its verson number, redirecting
# errors to /dev/null
sub getversion {
    my $mod = shift;
 
    my $vers = `$^X -m$mod -e 'print \$${mod}::VERSION' 2>/dev/null`;
    $vers =~ s/^\s*(.*?)\s*$/$1/; # remove stray whitespace
 
    return ($vers || undef);
}
 
format  =
^<<<<<<<<<<<<<<<<<~~^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$Module,        $_
.
 
 
#-----------------------------
Источник — «http://wiki.crossplatform.ru/index.php?title=Perl/FAQ/%D0%9F%D0%B0%D0%BA%D0%B5%D1%82%D1%8B,_%D0%B1%D0%B8%D0%B1%D0%BB%D0%B8%D0%BE%D1%82%D0%B5%D0%BA%D0%B8_%D0%B8_%D0%BC%D0%BE%D0%B4%D1%83%D0%BB%D0%B8»