#!/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 you don't explicitly list any directories to walk. Note that this default 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 much in length, to avoid pushing all descriptions way over to the right just because a few names are long. The output looks more ragged than with full alignment, but is still lined up locally and only requires the eye to cross small gaps between columns, so is usually more readable.

You can pass an optional positive integer argument to specify the length 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_abbrev );
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( $desc 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::name, $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;
}