Example 12.3: pmdesc

#!/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,        $_
.