#!/usr/bin/perl -w
#===================================================================================
#
#         FILE:  pmdesc3
#
#     SYNOPSIS:  Find versions and descriptions of installed perl Modules and PODs
#
#  DESCRIPTION:  See POD below.
#
#      CREATED:  15.06.2004 22:12:41 CEST
#     REVISION:  23.10.2004
#                - Module versions are checked with a regex; avoids unprintable
#                  characters (original version) and doubling of entries.
#                - new option -v
#                28.10.2004
#                - Function get_module_description completely new written.
#                29.01.2005
#                - Look for a description in the DESCRIPTION section if no
#                  NAME section is found.
#                16.04.2005
#                - Adaption for MS Windows.
#         TODO:  Replace UNIX sort pipe.
#
#===================================================================================

package pmdesc3;

$VERSION = 1.2.2;    # update POD at the end of this file

require 5.6.1;

use strict;
use Carp;
use ExtUtils::MakeMaker;
use File::Find qw(find);
use Getopt::Std qw(getopts);

my $MaxDescLength = 150;    # Maximum length for the description field:
                            # prevents slurping in big amount of faulty docs.

my $rgx_version = q/\A\d+(\.\w+)*\Z/;    # regex for module versions

#===  FUNCTION  ====================================================================
#         NAME:  usage
#===================================================================================
sub usage {
    my $searchdirs = " " x 12;
    $searchdirs .=
      join( "\n" . " " x 12, sort { length $b <=> length $a } @INC ) . "\n";
    print <Usage:   pmdesc3 [-h] [-s] [-t ddd] [-v dd] [--] [dir [dir [dir [...]]]]
Options:  -h         print this message
          -s         sort output (not under Windows)
          -t ddd     name column has width ddd (1-3 digits); default 36
          -v  dd     version column has width ddd (1-3 digits); default 10
          If no directories given, searches:
$searchdirs
EOT
    exit;
}

#===  FUNCTION  ====================================================================
#         NAME:  get_module_name
#===================================================================================
sub get_module_name {
    my ( $path, $relative_to ) = @_;

    local $_ = $path;
    s!\A\Q$relative_to\E/?!!;
    s! \.p(?:m|od) \z!!x;
    s!/!::!g;

    return $_;
}

#===  FUNCTION  ====================================================================
#         NAME:  get_module_description
#===================================================================================
sub get_module_description {
    my $desc;
    my ($INFILE_file_name) = @_;    # input file name

    undef $/;                       # undefine input record separator

    open( INFILE, '<', $INFILE_file_name )
      or die "$0 : failed to open input file $INFILE_file_name : $!\n";

    my $file = ;            # slurp mode
    close(INFILE);                  # close input file

    $file =~ s/\cM\cJ/\cJ/g;                  # remove DOS line ends
    $file =~ m/\A=head1\s+NAME(.*?)\n=\w+/s;  # file starts with '=head1' (PODs)
    $desc = $1;

    if ( !defined $desc ) {
        $file =~ m/\n=head1\s+NAME(.*?)\n=\w+/s;    # '=head1' is embedded
        $desc = $1;
    }

    if ( !defined $desc ) {
        $file =~ m/\n=head1\s+DESCRIPTION(.*?)\n=\w+/s;   # '=head1' is embedded
        $desc = $1;
    }

    if ( defined $desc ) {
        $desc =~ s/\A[ \t\n]*//s;       # remove leading whitespaces
        $desc =~ s/\n\s+\n/\n\n/sg;     # make true empty lines
        $desc =~ s/\n\n.*$//s;          # discard all trailing paragraphs
        $desc =~ s/\A.*?\s+-+\s+//s;    # discard leading module name
        $desc =~ s/\n/ /sg;             # join lines
        $desc =~ s/\s+/ /g;             # squeeze whitespaces
        $desc =~ s/\s*$//g;             # remove trailing whitespaces
        $desc = substr $desc, 0, $MaxDescLength;    # limited length
    }
    return $desc;
}

#===  FUNCTION  ====================================================================
#         NAME:  get_module_version
#===================================================================================
sub get_module_version {
    local $_;    # MM->parse_version is naughty
    my $vers_code = MM->parse_version($File::Find::name) || '';
    $vers_code = undef unless $vers_code =~ /$rgx_version/;
    return $vers_code;
}

#===  FUNCTION  ====================================================================
#         NAME:  MAIN
#===================================================================================

my %visited;

$|++;

#---------------------------------------------------------------------------
#  process options and command line arguments
#---------------------------------------------------------------------------
my %options;

getopts( "hst:v:", \%options ) or $options{h} = 1;

my @args = @ARGV;
@ARGV = @INC unless @ARGV;

usage() if $options{h};    #  option -h  :  usage

#---------------------------------------------------------------------------
#  option -t : width of the module name column
#---------------------------------------------------------------------------
usage() if $options{t} && $options{t} !~ /^\d{1,3}$/;    # width 1-3 digits

$options{t} = "36" unless $options{t};

#---------------------------------------------------------------------------
#  option -v : width of the version column
#---------------------------------------------------------------------------
usage() if $options{v} && $options{v} !~ /^\d{1,2}$/;    # width 1-2 digits

$options{v} = "10" unless $options{v};

#---------------------------------------------------------------------------
#  option -s  :  install an output filter to sort the module list
#---------------------------------------------------------------------------
if ( $options{s} ) {
    usage() if $^O eq "MSWin32";
    if ( open( ME, "-|" ) ) {
        $/ = "";
        while () {
            chomp;
            print join( "\n", sort split /\n/ ), "\n";
        }
        exit;
    }
}

#---------------------------------------------------------------------------
#  process
#---------------------------------------------------------------------------
#
# :WARNING:15.04.2005:Mn: under Windows descending into subdirs will be
# suppressed by the the preprocessing part of the following call to find
# :TODO:16.04.2005:Mn: remove code doubling
#
if ( $^O ne "MSWin32" ) {    # ----- UNIX, Linux, ...

    for my $inc_dir ( sort { length $b <=> length $a } @ARGV ) {
        find(
            {
                wanted => sub {
                    return unless /\.p(?:m|od)\z/ && -f;

          #---------------------------------------------------------------------
          #  return from function if there exists a pod-file for this module
          #---------------------------------------------------------------------
                    my $pod = $_;
                    my $pm  = $_;
                    if (m/\.pm\z/) {
                        $pod =~ s/\.pm\z/\.pod/;
                        return if -f $pod;
                    }

                    my $module = get_module_name( $File::Find::name, $inc_dir );
                    my $version;
                    if (/\.pod\z/) {
                        $pm =~ s/\.pod\z/\.pm/;

            #-------------------------------------------------------------------
            #  try to find the version from the pm-file
            #-------------------------------------------------------------------
                        if ( -f $pm ) {
                            local $_;
                            $version = MM->parse_version($pm) || "";
                            $version = undef unless $version =~ /$rgx_version/;
                        }
                    }
                    else {
                        $version = get_module_version($_);
                    }
                    my $desc = get_module_description($_);

                    $version = defined $version ? " ($version)" : " (n/a)";
                    $desc =
                      defined $desc ? " $desc" : " ";

                    printf( "%-${options{t}}s%-${options{v}}s%-s\n",
                        $module, $version, $desc );

                },

                preprocess => sub {
                    my ( $dev, $inode ) = stat $File::Find::dir or return;
                    $visited{"$dev:$inode"}++ ? () : @_;
                },
            },
            $inc_dir
        );
    }
}
else {    # ----- MS Windows
    for my $inc_dir ( sort { length $b <=> length $a } @ARGV ) {
        find(
            {
                wanted => sub {
                    return unless /\.p(?:m|od)\z/ && -f;

          #---------------------------------------------------------------------
          #  return from function if there exists a pod-file for this module
          #---------------------------------------------------------------------
                    my $pod = $_;
                    my $pm  = $_;
                    if (m/\.pm\z/) {
                        $pod =~ s/\.pm\z/\.pod/;
                        return if -f $pod;
                    }

                    my $module = get_module_name( $File::Find::name, $inc_dir );
                    my $version;
                    if (/\.pod\z/) {
                        $pm =~ s/\.pod\z/\.pm/;

            #-------------------------------------------------------------------
            #  try to find the version from the pm-file
            #-------------------------------------------------------------------
                        if ( -f $pm ) {
                            local $_;
                            $version = MM->parse_version($pm) || "";
                            $version = undef unless $version =~ /$rgx_version/;
                        }
                    }
                    else {
                        $version = get_module_version($_);
                    }
                    my $desc = get_module_description($_);

                    $version = defined $version ? " ($version)" : " (n/a)";
                    $desc =
                      defined $desc ? " $desc" : " ";

                    printf( "%-${options{t}}s%-${options{v}}s%-s\n",
                        $module, $version, $desc );

                },
            },
            $inc_dir
        );
    }
}