File Coverage

blib/lib/HTML/Perlinfo/Modules.pm

Criterion	Covered	Total	%
statement	30	283	10.6
branch	0	148	0.0
condition	0	71	0.0
subroutine	10	24	41.6
pod	1	13	7.6
total	41	539	7.6

package HTML::Perlinfo::Modules;

use strict;
use warnings;
use File::Find;
use File::Spec;
use Carp ();
use Config qw(%Config);
use HTML::Entities;
use base qw(HTML::Perlinfo::Base);
use HTML::Perlinfo::Common;

our $VERSION = '1.19';


sub new {

    my ($class, %params) = @_;
    $params{'title'} = exists $params{'title'} ?  $params{'title'} : 'Perl Modules';

    $class->SUPER::new(%params);

}


sub escapeHTML {
    return HTML::Entities::encode_entities(@_);
}

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 && $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 .= "
        $label = $_->[2] || $_->[1];
        $html .= print_color_box($_->[0], $label);
        $html .= "
     }
  }
  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 .= "" if $input{'full_page'};

  defined wantarray ? return $html : print $html;

}

sub find_modules {

  my ($show_only, $mod_dir) = @_;

  my ($overall_total, $module, $base, $start_dir, $new_val, $mod_info);
  # arrays
  my (@modinfo_array, @mod_dir);
  # hashes
  my ( %path, %inc_path, %mod_count, %found_mod);
  @mod_dir = @$mod_dir;

  @path{@mod_dir} = ();
  @inc_path{@INC} = ();
  for $base (@mod_dir) {

    find ({ wanted => sub {
	for (@INC, @mod_dir) {
	  if (index($File::Find::name, $_) == 0) {
	  # lets record it unless we already have hit the dir
	    $mod_count{$_} = 0 unless exists $mod_count{$_};
	  }
        }
	# This prevents mod_dir dirs from being searched again when you have a dir within a dir
        $File::Find::prune = 1, return if exists $path{$File::Find::name} && $File::Find::name ne $File::Find::topdir;

 	# make sure we are dealing with a module
        return unless $File::Find::name =~ m/\.pm$/;
	$mod_info = module_info($File::Find::name, $show_only);
        return unless ref ($mod_info) eq 'HASH';

        # update the counts.
	for (@INC, grep{not exists $inc_path{$_}}@mod_dir) {
	  if (index($File::Find::name, $_) == 0) {
	    $mod_count{$_}++;
          }
	}
	$overall_total++;

    $mod_info->{'path'} = File::Spec->canonpath($File::Find::dir);
	# Check for duplicate modules
    if (exists $found_mod{$mod_info->{'name'}}) {
	  @modinfo_array = ref( $found_mod{$mod_info->{'name'}} ) eq 'ARRAY' ? @{$found_mod{$mod_info->{'name'}}} : $found_mod{$mod_info->{'name'}};
          push @modinfo_array, $mod_info;
          $new_val = [@modinfo_array];
          $found_mod{$mod_info->{'name'}} = $new_val;
        }
	else {
	  $found_mod{$mod_info->{'name'}} = $mod_info;
	}

      },untaint => 1, untaint_pattern => qr|^([-+@\s\S\w./]+)$|}, $base);
   } # end of for loop

  return ($overall_total, \%found_mod, \%mod_count);

}

1;
__END__