#!/usr/bin/perl

=head1 NAME

lspm - list names and descriptions of Perl modules in a directory

=head1 SYNOPSIS

 lspm -h
 lspm [-p] [-a] [-c [num]] [-l len] [dir [dir dir ...]]

=head1 DESCRIPTION

Lists all or a subset of installed Perl modules, with version numbers 
+and descriptions.

It will look in Perl's default search path for modules, C<@INC>, if yo
+u don't explicitly list any directories to walk. Note that this defau
+lt search excludes the current directory.

=head1 OPTIONS

=over 4

=item B<-h>, B<--help>

See a synopsis.

=item B<--man>

Browse the manpage.

=item B<-p>, B<--show-path>

Include path of found modules in output.

=item B<-a>, B<--align>

Vertically align descriptions.

=item B<-c>, B<--align-local>, B<--align-cont>

Align descriptions in blocks where the module names don't differ too m
+uch in length, to avoid pushing all descriptions way over to the righ
+t just because a few names are long. The output looks more ragged tha
+n with full alignment, but is still lined up locally and only require
+s the eye to cross small gaps between columns, so is usually more rea
+dable.

You can pass an optional positive integer argument to specify the leng
+th threshold; the default is 7.

=item B<-l>, B<--max-length>, B<--limit>

Cut off descriptions at specified length.

=back

=head1 SEE ALSO

L<http://www.cpan.org/modules/by-authors/id/TOMC/scripts/pmdesc.gz>

=head1 BUGS

I need something to write here.

=head1 COPYRIGHT AND LICENCE

Written by Aristotle Pagaltzis, (c)2006.

This module is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.

=cut

use 5.6.1;
use strict;
use warnings;

use List::Util qw( min max );
use File::Find qw( find );
use File::Spec::Functions qw( rel2abs abs2rel no_upwards );
use ExtUtils::MakeMaker ();
use Getopt::Long 2.24, qw( :config bundling no_ignore_case no_auto_abb
+rev );
use Pod::Usage qw( pod2usage );

$|++;

sub module_name_from_filename {
    local $_ = shift;
    s! \.p(?:m|od) \z!!x;
    s!/!::!g;
    return $_;
}

sub get_module_description {
    my ( $file, $max_length ) = @_;

    my $desc;

    open my $pod, "<", $file
        or ( warn( "\tCannot open $file: $!" ), return );

    my $get_line = sub {
        $_ = <$pod>;
        defined and s/\x0D?\x0A/\n/g; # fix DOS crud; see perlport
        $_;
    };

    local $_;

    # find description
    while ( $get_line->() ) {
        last if m{\A=head\d\s+NAME\b};
    }

    # skip leading junk
    while ( $get_line->() ) {
        last if /\A=\w/;
        if( s{\A.*? - \s*}{} ) {
            $desc .= $_;
            last;
        }
    }

    # collect description
    while ( $get_line->() ) {
        last if /\A=\w/;
        s/\A\s+\z//;
        $desc .= $_;
        last if not length;
    }

    for( $desc ) {
        last if not defined;
        s/\s*\z//;
        s/\s+/ /g;
        $_ = substr $_, 0, $max_length if $max_length;
        undef $_ if not length;
    }

    return $desc;
}

sub get_module_version {
    my ( $file ) = @_;
    local $_ = MM->parse_version( $file );
    $_ = eval if $_ and /[^\d._]/;
    return $_;
}

{
    my %visited;
    sub visited {
        my ( $dir ) = @_;
        my $unique_id;

        if( $^O eq "MSWin32" ) {
            $unique_id = $dir;
        }
        else {
            my ( $dev, $inode ) = stat $dir or return;
            $unique_id = join ':', $dev, $inode;
        }

        return ! ! $visited{ $unique_id }++;
    }
}

sub name_width {
    my ( $module, $version ) = @_;
    length( $module . ( defined $version ? $version : '' ) );
}

sub print_module_info {
    my ( $module, $version, $desc, $path, $name_width ) = @_;
    my @output;
    push @output, do {
        local $_ = $version;
        $_ = '' if not defined;
        my $name = "$module ($_)";
        $name = sprintf '%-*s', $name_width + 3, $name if defined( $de
+sc and $name_width );
        $name;
    };
    push @output, "[$path]" if defined $path;
    push @output, '-', $desc if defined $desc;
    print "@output\n";
}

GetOptions(
    'h|help'                     => sub { pod2usage( -verbose => 1 ) }
+,
    'man'                        => sub { pod2usage( -verbose => 2 ) }
+,
    'show-path|p!'               => \( my $opt_path = '' ),
    'align|a'                    => \( my $opt_align = 0 ),
    'align-local|align-cont|c:7' => \( my $opt_cont ),
    'max-length|limit|l'         => \( my $opt_limit = 0 ),
) or pod2usage( -verbose => 1 );

pod2usage 'argument to --align-local must be a positive integer'
    if $opt_cont and $opt_cont < 1;

@ARGV = no_upwards( @INC ) unless @ARGV;

my @info;
my $min_w = 100;
my $max_w = 0;

for my $inc_dir ( sort { length $b <=> length $a } map rel2abs( $_ ), 
+@ARGV ) {
    find(
        {
            wanted => sub {
                return unless /\.p(?:m|od)\z/;
                s/\.pod\z/.pm/; # if it's POD, parse the corresponding
+ code
                return if not -f;
                my @details = (
                    module_name_from_filename( abs2rel $File::Find::na
+me, $inc_dir ),
                    get_module_version( $_ ),
                    get_module_description( $_, $opt_limit ),
                    $opt_path ? $File::Find::name : undef,
                );

                if( $opt_cont ) {
                    my $cur_w = name_width @details;
                    $max_w = max $max_w, $cur_w;
                    $min_w = min $min_w, $cur_w;
                    if( $max_w - $min_w > $opt_cont ) {
                        print_module_info @$_, $max_w for @info;
                        @info = ();
                        $min_w = $max_w;
                        $max_w = 0;
                    }
                }

                if( $opt_align or $opt_cont ) {
                    push @info, \@details;
                }
                else {
                    print_module_info @details;
                }
            },
            preprocess => sub { visited( $File::Find::dir ) ? () : @_ 
+},
        },
        $inc_dir,
    );
}

if( @info ) {
    my $name_width = max map name_width( @$_ ), @info;
    print_module_info @$_, $name_width for @info;
}
[download]