package HTML::Perlinfo::Modules;
use strict;
use File::Find;
use File::Spec;
use Carp ();
use Config qw(%Config);
use base qw(HTML::Perlinfo::Base);
use CGI qw(escapeHTML);
use HTML::Perlinfo::Common;
our $VERSION = '1.17';
sub new {
my ($class, %params) = @_;
$params{'title'} = exists $params{'title'} ? $params{'title'} : 'Perl Modules';
$class->SUPER::new(%params);
}
sub module_color_check {
my ($module_name, $color_specs) = @_;
if (defined $color_specs && ref($color_specs->[0]) eq 'ARRAY') {
foreach (@{ $color_specs }) {
return $_->[0] if (match_string($module_name,$_->[1])==1);
}
}
else {
return $color_specs->[0] if (defined $color_specs && match_string($module_name,$color_specs->[1])==1);
}
return 0;
}
# get_modinfo
# This sub was created for the files_in option.
# Returns found_mod reference
######################################
sub get_files_in {
my ($file_path) = @_;
return 0 unless $file_path =~ m/\.pm$/;
my $mod_info = module_info($file_path, undef);
return $mod_info;
}
sub sort_modules {
my ($modules, $sort_by) = @_;
my @sorted_modules;
if ($sort_by eq 'name') {
foreach my $key (sort {lc $a cmp lc $b} keys %$modules) {
# Check for duplicate modules
if (ref($modules->{$key}) eq 'ARRAY') {
foreach (@{ $modules->{$key} }) {
push @sorted_modules, $_;
}
}
else {
push @sorted_modules, $modules->{$key};
}
}
}
elsif ($sort_by eq 'version') {
foreach my $key (keys %$modules) {
if (ref($modules->{$key}) eq 'ARRAY') {
@{ $modules->{$key} } = sort {$a->{'version'} cmp $b->{'version'}}@{ $modules->{$key} };
for (@{ $modules->{$key}}) {
push @sorted_modules, $_;
}
}
else {
push @sorted_modules, $modules->{$key};
}
}
@sorted_modules = sort {$a->{'version'} cmp $b->{'version'}}@sorted_modules;
}
return @sorted_modules;
}
sub html_setup {
my ($self, $columns, $color_specs, $section, $full_page) = @_;
my $html;
$html .= $self->print_htmlhead if $full_page;
my %show_columns = (
'name' => 'Module name',
'version' => 'Version',
'path' => 'Location',
'core' => 'Core',
'desc' => 'Description'
);
$html .= $section ? print_section($section) : '';
$html .= print_color_codes($color_specs) if $color_specs && $color_specs->[2];
$html .= print_table_start();
$html .= print_table_header(scalar @$columns, map{ $show_columns{$_} }@$columns);
return $html;
}
sub module_info {
my ($module_path, $show_only) = @_;
( $module_path ) = $module_path =~ /^(.*)$/;
my ($mod_name, $mod_version, $mod_desc);
no warnings 'all'; # silence warnings
open(MOD, $module_path) or return 0;
while () {
unless ($mod_name) {
if (/^ *package +(\S+);/) {
$mod_name = $1;
}
}
unless ($mod_version) {
if (/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/) {
my $line = substr $_, index($_, $1);
my $eval = qq{
package HTML::Perlinfo::_version;
no strict;
local $1$2;
\$$2=undef; do {
$line
}; \$$2
};
( $eval ) = $eval =~ /^(.*)$/sm;
$mod_version = eval($eval);
# Again let us be nice here.
$mod_version = 'unknown' if (not defined $mod_version) || ($@);
$mod_version =~ s/^\s+|\s+$//;
}
}
unless ($mod_desc) {
if (/=head\d\s+NAME/) {
local $/ = '';
local $_;
chomp($_ = );
($mod_desc) = /^.*?-+\s*(.*?)$/ism;
}
}
last if $mod_name && $mod_version && $mod_desc;
}
close (MOD);
return 0 if (! $mod_name || $show_only && ref $show_only && (match_string($mod_name, $show_only) == 0));
$mod_version = 'unknown' if !($mod_version) || ($mod_version !~ /^[\.\d+_]+$/);
$mod_desc = escapeHTML($mod_desc) if $mod_desc;
$mod_desc = "No description found" unless $mod_desc;
return { 'name' => $mod_name, 'version' => $mod_version, 'desc' => $mod_desc };
}
sub print_color_codes {
my $color_specs = shift;
my ($html, $label);
$html .= print_table_start();
$html .= print_table_header(1, "Module Color Codes");
$html .= print_table_color_start();
if (ref($color_specs->[0]) eq 'ARRAY') {
my $count = 0;
foreach (@{ $color_specs }) {
$html .= "" if $count++ % 5 == 0;
$label = $_->[2] || $_->[1];
$html .= print_color_box($_->[0], $label);
$html .= "
" if (($count >= 5 && $count % 5 == 0)||($count >= @{$color_specs}));
}
}
else {
$label = $color_specs->[2] || $color_specs->[1];
$html .= print_color_box($color_specs->[0], $label);
}
$html .= print_table_color_end();
$html .= print_table_end();
return $html;
}
sub print_module_results {
my ($mod_dir, $mod_count, $from, $overall_total, $show_dir) = @_;
my ($html, $total_amount, $searched, @mod_dir, @bad_dir, %seen);
if ($show_dir) {
$html .= print_table_start();
$html .= print_table_header(2, "Directory", "Number of Modules");
for my $dir (keys %{$mod_count}) {
my $amount_found = $mod_count->{$dir};
push (@mod_dir, $dir) if $amount_found;
}
for my $dir1 (@mod_dir) {
for my $dir2 (@mod_dir) {
if ($dir1 ne $dir2 && $dir2 =~ /^$dir1/) {
push @bad_dir, $dir2;
}
}
}
for my $top_dir (@mod_dir) {
unless (grep{$_ eq $top_dir }@bad_dir) {
$html .= print_table_row(2, add_link('local', File::Spec->canonpath($top_dir)), $mod_count->{$top_dir});
}
}
$html .= print_table_end();
}
else {
# Print out directories not in @INC
@mod_dir = grep { -d $_ && -r $_ && !$seen{$_}++ } map {File::Spec->canonpath($_)}@INC;
my @module_paths = grep { not exists $seen{$_} }@$mod_dir;
if (@module_paths >= 1) {
$html .= print_table_start();
$html .= print_table_header(3, "Directory", "Searched", "Number of Modules");
for my $dir (map{ File::Spec->canonpath($_) }@module_paths) {
$searched = (grep { $_ eq $dir } @$mod_dir) ? "yes" : "no";
my $amount_found = ($searched eq 'yes') ? $mod_count->{$dir} : 'unknown';
$html .= print_table_row(3, add_link('local', File::Spec->canonpath($dir)), $searched, $amount_found);
}
$html .= print_table_end();
}
$html .= print_table_start();
$html .= print_table_header(3, "Include path (INC) directories", "Searched", "Number of Modules");
for my $dir (@mod_dir) {
$searched = exists $mod_count->{$dir} ? 'yes' : 'no';
my $amount_found = ($searched eq 'yes') ? $mod_count->{$dir} : 'unknown';
$html .= print_table_row(3, add_link('local', File::Spec->canonpath($dir)), $searched, $amount_found);
}
$html .= print_table_end();
}
$html .= print_table_start();
#my $view = ($from eq 'all') ? 'installed' :
# ($from eq 'core') ? 'core' : 'found';
$html .= print_table_row(2, "Total modules", $overall_total);
$html .= print_table_end();
return $html;
}
sub search_dir {
my ($from, $show_only, $core_dir1, $core_dir2) = @_;
my %seen = ();
my @user_dir = (ref($from) eq 'ARRAY') && $show_only ne 'core' ? @{$from} :
($show_only eq 'core') ? ($core_dir1, $core_dir2) : $from;
# Make sure only unique entries and readable directories in @mod_dir
my @mod_dir = grep { -d $_ && -r $_ && !$seen{$_}++ } map {File::Spec->canonpath($_)}@user_dir;
if (@mod_dir != @user_dir) {
# Looks like there might have been a problem with the directories given to us.
# Or maybe not. @user_dir could have duplicate values and that's ok.
# But let's still warn about any unreadable or non-directories given
my @debug;
%seen = ();
@user_dir = grep { !$seen{$_}++ } map {File::Spec->canonpath($_)}@user_dir;
if (@user_dir > @mod_dir) {
#%seen = map {$_ => undef} @mod_dir;
%seen = ();
@seen{@mod_dir} = ();
my @difference = grep { !$seen{$_}++ }@user_dir;
foreach my $element (@difference) {
if (! -d $element) {
if ( grep {$_ eq $element} map {File::Spec->canonpath($_)}@INC) {
warn "$element is in the Perl include path, but is not a directory";
}
else {
warn "$element is not a directory";
}
push @debug, $element;
}
elsif (! -r $element) {
if ( grep {$_ eq $element} map {File::Spec->canonpath($_)}@INC) {
warn "$element is in the Perl include path, but is not readable";
}
else {
warn "$element is not a readable directory";
}
push @debug, $element;
}
}
}
}
error_msg("Search directories are invalid") unless @mod_dir >= 1;
return @mod_dir;
}
sub get_input {
my $self = shift;
my $args = process_args(@_, \&check_module_args);
my %input = ();
$input{'files_in'} = $args->{'files_in'} || undef;
$input{'sort_by'} = $args->{'sort_by'} || 'name';
$input{'from'} = $args->{'from'} || \@INC;
$input{'show_only'} = $args->{'show_only'} || "";
$input{'color_specs'} = $args->{'color'};
$input{'link'} = $args->{'link'};
$input{'section'} = exists $args->{'section'} ? $args->{'section'} :
$input{'show_only'} eq 'core' ? 'Core Perl modules installed' : '';
$input{'full_page'} = exists $args->{'full_page'} ? $args->{'full_page'} : $self->{'full_page'};
$input{'show_inc'} = exists $args->{'show_inc'} ? $args->{'show_inc'} : 1;
$input{'show_dir'} = exists $args->{'show_dir'} ? $args->{'show_dir'} : 0;
$input{'columns'} = exists $args->{'columns'} ? $args->{'columns'} : ['name','version','desc'];
return %input;
}
sub print_modules {
my %input = get_input(@_);
my ($found_mod, $mod_count, $overall_total, @mod_dir, $core_dir1, $core_dir2);
# Check to see if a search is even needed
if (defined $input{'files_in'}) {
my @files = @{ $input{'files_in'} };
my %found_mod = ();
foreach my $file_path (@files) {
my $mod_info = get_files_in($file_path);
next unless (ref $mod_info eq 'HASH');
$found_mod{$mod_info->{'name'}} = $mod_info;
}
return undef unless (keys %found_mod > 0);
$found_mod = \%found_mod;
}
else {
# Get ready to search
$core_dir1 = File::Spec->canonpath($Config{installarchlib});
$core_dir2 = File::Spec->canonpath($Config{installprivlib});
@mod_dir = search_dir($input{'from'}, $input{'show_only'}, $core_dir1, $core_dir2);
($overall_total, $found_mod, $mod_count) = find_modules($input{'show_only'}, \@mod_dir);
return undef unless $overall_total;
}
my @sorted_modules = sort_modules($found_mod, $input{'sort_by'});
my $html .= html_setup( $_[0],
$input{'columns'},
$input{'color_specs'},
$input{'section'},
$input{'full_page'}
);
my $numberof_columns = scalar @{$input{'columns'}};
foreach my $module (@sorted_modules) {
$html .= print_table_row_color( $numberof_columns,
module_color_check($module->{'name'}, $input{'color_specs'}),
map{
if ($_ eq 'name') {
add_link('cpan', $module->{'name'}, $input{'link'});
}
elsif ($_ eq 'core') {
(grep File::Spec->rel2abs($module->{'path'}) =~ /\Q$_/, ($core_dir1, $core_dir2)) ? 'yes' : 'no';
}
elsif ($_ eq 'path') {
add_link('local', $module->{'path'});
}
else {
$module->{$_};
}
} @{$input{'columns'}} );
}
$html .= print_table_end();
unless (defined $input{'files_in'} && ref $input{'files_in'} eq 'ARRAY') {
$html .= print_module_results( \@mod_dir,
$mod_count,
$input{'from'},
$overall_total,
$input{'show_dir'}) if $input{'show_inc'};
}
$html .= "