Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

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

by Aristotle (Chancellor)
on Jul 16, 2006 at 05:48 UTC ( #561518=sourcecode: print w/ replies, xml ) Need Help??

Category: Utility Scripts
Author/Contact Info /msg Aristotle
Description:

Remember pmdesc2 - lists modules with description? Itís a script that lists any or a subset of the modules you have installed, complete with the version number and a description, inspired by Tom Christiansenís pmdesc, but without a number of its annoying flaws, with much higher speed and far cleaner code.

This time around, I added a bunch of options and DOS-newline translation to address problems brought up by Fritz Mehner. In the process, I also cleaned the code up even further and added POD and proper --help etc by way of the inimitable Pod::Usage.

Update 2006-07-16T11:03+0200: fixed a minor oopsie with --align-cont.

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

Comment on lspm ó list names and descriptions of Perl modules in a directory
Download Code
Re: lspm - list names and descriptions of Perl modules in a directory
by jwkrahn (Monsignor) on Jul 16, 2006 at 10:25 UTC
    Some modules use more than one hyphen to separate the name from the description so change:
    110 if( s{\A.*? - \s*}{} ) {
    To:
    110 if( s{\A.*? -+ \s*}{} ) {

      Thatís not a clear win. Because much CPAN-related infrastructure insists on a single dash, almost all modules have a single hyphen, which means the more fastidious form picks up nearly all descriptions correctly. If you allow multiple hyphens, you recover some false negatives, at the cost of some false positives, where the description of the module is malformed but thereís a line with multiple hyphens somewhere nearby. Matching ' --? ' at that point has a couple fewer false positives and still almost no false negatives.

      But because of the effect of CPANís rules, itís hardly worth bothering either way, and I prefer to get output thatís consistent with other tools.

      Makeshifts last the longest.

        I also noticed that if a module has a corresponding POD file (for example: POSIX.pm and POSIX.pod) the description is in the POD file and won't get picked up at all. I applied this patch which seems to fix this (it also prevents POSIX.pm from appearing twice in the resulting list):
        202,204c202,206 < return unless /\.p(?:m|od)\z/; < s/\.pod\z/.pm/; # if it's POD, parse t +he corresponding code < return if not -f; --- > return unless -f and /\A(.+)\.pm\z/; > my $module = $1; > my $version = get_module_version( "$mo +dule.pm" ) || -e "$module.pod" && get_module_version( + "$module.pod" ); > my $desc = get_module_description( +"$module.pm", $opt_limit ) || -e "$module.pod" && get_module_descript +ion( "$module.pod", $opt_limit ); > 207,209c209,211 < get_module_version( $_ ), < get_module_description( $_, $o +pt_limit ), < $opt_path ? $File::Find::name +: undef, --- > $version, > $desc, > $opt_path ? $File::Find::name +: undef
        HTH
Re: lspm ó list names and descriptions of Perl modules in a directory
by naChoZ (Curate) on Jan 25, 2008 at 21:06 UTC

    I wanted to add prunepaths support. This patch includes my changes as well as the patch that jwkrahn posted above.

    48,51d47 < =item B<-x>, B<--prunepaths> < < Directories to omit from the search for perl modules. < 191d186 < 'prunepaths|x=s@' => \( my $excludes ), 207,213c202,204 < check_prune($_) && ( $File::Find::prune = 1 ) if $ex +cludes; < < return unless -f and /\A(.+)\.pm\z/; < my $module = $1; < my $version = get_module_version( "$module.pm" ) + || -e "$module.pod" && get_module_version( "$module.pod" + ); < my $desc = get_module_description( "$module.pm", +$opt_limit ) || -e "$module.pod" && get_module_description( "$module. +pod", $opt_limit ); < --- > return unless /\.p(?:m|od)\z/; > s/\.pod\z/.pm/; # if it's POD, parse t +he corresponding code > return if not -f; 216,218c207,209 < $version, < $desc, < $opt_path ? $File::Find::name : undef --- > get_module_version( $_ ), > get_module_description( $_, $o +pt_limit ), > $opt_path ? $File::Find::name +: undef, 250,254d240 < < sub check_prune { < my $name = shift; < return 1 if grep( /\A$name\z/s, @$excludes ) > 0 and -d $name; < }

    --
    naChoZ

    Therapy is expensive. Popping bubble wrap is cheap. You choose.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://561518]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (13)
As of 2014-07-22 19:36 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (126 votes), past polls