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; } |
|
---|
Replies are listed 'Best First'. | |
---|---|
Re: lspm - list names and descriptions of Perl modules in a directory
by jwkrahn (Abbot) on Jul 16, 2006 at 10:25 UTC | |
by Aristotle (Chancellor) on Jul 16, 2006 at 11:07 UTC | |
by jwkrahn (Abbot) on Jul 16, 2006 at 12:19 UTC | |
Re: lspm — list names and descriptions of Perl modules in a directory
by naChoZ (Curate) on Jan 25, 2008 at 21:06 UTC |
Back to
Code Catacombs