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


" if $count++ % 5 == 0; " if (($count >= 5 && $count % 5 == 0)||($count >= @{$color_specs}));
line stmt bran cond sub pod time code
1             package HTML::Perlinfo::Modules;
2              
3 1     1   7 use strict;
  1         2  
  1         28  
4 1     1   5 use warnings;
  1         2  
  1         25  
5 1     1   5 use File::Find;
  1         2  
  1         50  
6 1     1   5 use File::Spec;
  1         2  
  1         37  
7 1     1   6 use Carp ();
  1         2  
  1         19  
8 1     1   4 use Config qw(%Config);
  1         2  
  1         55  
9 1     1   499 use HTML::Entities;
  1         5584  
  1         77  
10 1     1   7 use base qw(HTML::Perlinfo::Base);
  1         2  
  1         463  
11 1     1   8 use HTML::Perlinfo::Common;
  1         2  
  1         806  
12              
13             our $VERSION = '1.19';
14              
15              
16             sub new {
17              
18 0     0 0   my ($class, %params) = @_;
19 0 0         $params{'title'} = exists $params{'title'} ? $params{'title'} : 'Perl Modules';
20              
21 0           $class->SUPER::new(%params);
22              
23             }
24              
25              
26             sub escapeHTML {
27 0     0 0   return HTML::Entities::encode_entities(@_);
28             }
29              
30             sub module_color_check {
31              
32 0     0 0   my ($module_name, $color_specs) = @_;
33 0 0 0       if (defined $color_specs && ref($color_specs->[0]) eq 'ARRAY') {
34 0           foreach (@{ $color_specs }) {
  0            
35 0 0         return $_->[0] if (match_string($module_name,$_->[1])==1);
36             }
37             }
38             else {
39 0 0 0       return $color_specs->[0] if (defined $color_specs && match_string($module_name,$color_specs->[1])==1);
40             }
41 0           return 0;
42             }
43              
44             # get_modinfo
45             # This sub was created for the files_in option.
46             # Returns found_mod reference
47             ######################################
48              
49             sub get_files_in {
50              
51 0     0 0   my ($file_path) = @_;
52            
53 0 0 0       return 0 unless $file_path && $file_path =~ m/\.pm$/;
54 0           my $mod_info = module_info($file_path, undef);
55 0           return $mod_info;
56              
57             }
58              
59              
60             sub sort_modules {
61              
62 0     0 0   my ($modules, $sort_by) = @_;
63 0           my @sorted_modules;
64              
65 0 0         if ($sort_by eq 'name') {
    0          
66 0           foreach my $key (sort {lc $a cmp lc $b} keys %$modules) {
  0            
67             # Check for duplicate modules
68 0 0         if (ref($modules->{$key}) eq 'ARRAY') {
69 0           foreach (@{ $modules->{$key} }) {
  0            
70 0           push @sorted_modules, $_;
71             }
72             }
73             else {
74 0           push @sorted_modules, $modules->{$key};
75             }
76             }
77             }
78             elsif ($sort_by eq 'version') {
79 0           foreach my $key (keys %$modules) {
80 0 0         if (ref($modules->{$key}) eq 'ARRAY') {
81 0           @{ $modules->{$key} } = sort {$a->{'version'} cmp $b->{'version'}}@{ $modules->{$key} };
  0            
  0            
  0            
82 0           for (@{ $modules->{$key}}) {
  0            
83 0           push @sorted_modules, $_;
84             }
85             }
86             else {
87 0           push @sorted_modules, $modules->{$key};
88             }
89             }
90 0           @sorted_modules = sort {$a->{'version'} cmp $b->{'version'}}@sorted_modules;
  0            
91             }
92 0           return @sorted_modules;
93             }
94              
95             sub html_setup {
96            
97 0     0 0   my ($self, $columns, $color_specs, $section, $full_page) = @_;
98            
99 0           my $html;
100              
101 0 0         $html .= $self->print_htmlhead if $full_page;
102              
103 0           my %show_columns = (
104             'name' => 'Module name',
105             'version' => 'Version',
106             'path' => 'Location',
107             'core' => 'Core',
108             'desc' => 'Description'
109             );
110              
111 0 0         $html .= $section ? print_section($section) : '';
112 0 0 0       $html .= print_color_codes($color_specs) if $color_specs && $color_specs->[2];
113 0           $html .= print_table_start();
114 0           $html .= print_table_header(scalar @$columns, map{ $show_columns{$_} }@$columns);
  0            
115 0           return $html;
116             }
117              
118             sub module_info {
119 0     0 0   my ($module_path, $show_only) = @_;
120              
121 0           ( $module_path ) = $module_path =~ /^(.*)$/;
122            
123 0           my ($mod_name, $mod_version, $mod_desc);
124            
125 1     1   9 no warnings 'all'; # silence warnings
  1         3  
  1         2712  
126 0 0         open(MOD, $module_path) or return 0;
127 0           while () {
128            
129 0 0         unless ($mod_name) {
130 0 0         if (/^ *package +(\S+);/) {
131 0           $mod_name = $1;
132             }
133             }
134            
135 0 0         unless ($mod_version) {
136            
137 0 0         if (/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/) {
138            
139 0           my $line = substr $_, index($_, $1);
140 0           my $eval = qq{
141             package HTML::Perlinfo::_version;
142             no strict;
143              
144             local $1$2;
145             \$$2=undef; do {
146             $line
147             }; \$$2
148             };
149            
150 0           ( $eval ) = $eval =~ /^(.*)$/sm;
151 0           $mod_version = eval($eval);
152             # Again let us be nice here.
153 0 0 0       $mod_version = 'unknown' if (not defined $mod_version) || ($@);
154 0           $mod_version =~ s/^\s+|\s+$//;
155             }
156             }
157              
158 0 0         unless ($mod_desc) {
159 0 0         if (/=head\d\s+NAME/) {
160 0           local $/ = '';
161 0           local $_;
162 0           chomp($_ = );
163 0           ($mod_desc) = /^.*?-+\s*(.*?)$/ism;
164             }
165             }
166            
167 0 0 0       last if $mod_name && $mod_version && $mod_desc;
      0        
168            
169             }
170            
171 0           close (MOD);
172 0 0 0       return 0 if (! $mod_name || $show_only && ref $show_only && (match_string($mod_name, $show_only) == 0));
      0        
      0        
173 0 0 0       $mod_version = 'unknown' if !($mod_version) || ($mod_version !~ /^[\.\d+_]+$/);
174 0 0         $mod_desc = escapeHTML($mod_desc) if $mod_desc;
175 0 0         $mod_desc = "No description found" unless $mod_desc;
176 0           return { 'name' => $mod_name, 'version' => $mod_version, 'desc' => $mod_desc };
177             }
178              
179             sub print_color_codes {
180 0     0 0   my $color_specs = shift;
181 0           my ($html, $label);
182 0           $html .= print_table_start();
183 0           $html .= print_table_header(1, "Module Color Codes");
184 0           $html .= print_table_color_start();
185              
186 0 0         if (ref($color_specs->[0]) eq 'ARRAY') {
187 0           my $count = 0;
188 0           foreach (@{ $color_specs }) {
  0            
189 0 0         $html .= "
190 0   0       $label = $_->[2] || $_->[1];
191 0           $html .= print_color_box($_->[0], $label);
192 0 0 0       $html .= "
  0   0        
193             }
194             }
195             else {
196 0   0       $label = $color_specs->[2] || $color_specs->[1];
197 0           $html .= print_color_box($color_specs->[0], $label);
198             }
199              
200 0           $html .= print_table_color_end();
201 0           $html .= print_table_end();
202 0           return $html;
203             }
204              
205             sub print_module_results {
206              
207 0     0 0   my ($mod_dir, $mod_count, $from, $overall_total, $show_dir) = @_;
208              
209 0           my ($html, $total_amount, $searched, @mod_dir, @bad_dir, %seen);
210            
211 0 0         if ($show_dir) {
212              
213 0           $html .= print_table_start();
214 0           $html .= print_table_header(2, "Directory", "Number of Modules");
215 0           for my $dir (keys %{$mod_count}) {
  0            
216 0           my $amount_found = $mod_count->{$dir};
217 0 0         push (@mod_dir, $dir) if $amount_found;
218             }
219            
220 0           for my $dir1 (@mod_dir) {
221 0           for my $dir2 (@mod_dir) {
222 0 0 0       if ($dir1 ne $dir2 && $dir2 =~ /^$dir1/) {
223 0           push @bad_dir, $dir2;
224             }
225             }
226             }
227 0           for my $top_dir (@mod_dir) {
228 0 0         unless (grep{$_ eq $top_dir }@bad_dir) {
  0            
229 0           $html .= print_table_row(2, add_link('local', File::Spec->canonpath($top_dir)), $mod_count->{$top_dir});
230             }
231             }
232 0           $html .= print_table_end();
233             }
234             else {
235             # Print out directories not in @INC
236 0 0 0       @mod_dir = grep { -d $_ && -r $_ && !$seen{$_}++ } map {File::Spec->canonpath($_)}@INC;
  0            
  0            
237 0           my @module_paths = grep { not exists $seen{$_} }@$mod_dir;
  0            
238              
239 0 0         if (@module_paths >= 1) {
240 0           $html .= print_table_start();
241 0           $html .= print_table_header(3, "Directory", "Searched", "Number of Modules");
242              
243 0           for my $dir (map{ File::Spec->canonpath($_) }@module_paths) {
  0            
244 0 0         $searched = (grep { $_ eq $dir } @$mod_dir) ? "yes" : "no";
  0            
245 0 0         my $amount_found = ($searched eq 'yes') ? $mod_count->{$dir} : 'unknown';
246 0           $html .= print_table_row(3, add_link('local', File::Spec->canonpath($dir)), $searched, $amount_found);
247             }
248 0           $html .= print_table_end();
249             }
250            
251            
252 0           $html .= print_table_start();
253 0           $html .= print_table_header(3, "Include path (INC) directories", "Searched", "Number of Modules");
254 0           for my $dir (@mod_dir) {
255 0 0         $searched = exists $mod_count->{$dir} ? 'yes' : 'no';
256 0 0         my $amount_found = ($searched eq 'yes') ? $mod_count->{$dir} : 'unknown';
257 0           $html .= print_table_row(3, add_link('local', File::Spec->canonpath($dir)), $searched, $amount_found);
258             }
259              
260 0           $html .= print_table_end();
261             }
262            
263 0           $html .= print_table_start();
264             #my $view = ($from eq 'all') ? 'installed' :
265             # ($from eq 'core') ? 'core' : 'found';
266              
267 0           $html .= print_table_row(2, "Total modules", $overall_total);
268 0           $html .= print_table_end();
269              
270 0           return $html;
271              
272             }
273              
274             sub search_dir {
275              
276 0     0 0   my ($from, $show_only, $core_dir1, $core_dir2) = @_;
277              
278            
279 0           my %seen = ();
280            
281 0 0 0       my @user_dir = (ref($from) eq 'ARRAY') && $show_only ne 'core' ? @{$from} :
  0 0          
282             ($show_only eq 'core') ? ($core_dir1, $core_dir2) : $from;
283              
284             # Make sure only unique entries and readable directories in @mod_dir
285 0 0 0       my @mod_dir = grep { -d $_ && -r $_ && !$seen{$_}++ } map {File::Spec->canonpath($_)}@user_dir;
  0            
  0            
286 0 0         if (@mod_dir != @user_dir) {
287              
288             # Looks like there might have been a problem with the directories given to us.
289             # Or maybe not. @user_dir could have duplicate values and that's ok.
290             # But let's still warn about any unreadable or non-directories given
291              
292 0           my @debug;
293 0           %seen = ();
294 0           @user_dir = grep { !$seen{$_}++ } map {File::Spec->canonpath($_)}@user_dir;
  0            
  0            
295 0 0         if (@user_dir > @mod_dir) {
296             #%seen = map {$_ => undef} @mod_dir;
297 0           %seen = ();
298 0           @seen{@mod_dir} = ();
299 0           my @difference = grep { !$seen{$_}++ }@user_dir;
  0            
300 0           foreach my $element (@difference) {
301 0 0         if (! -d $element) {
    0          
302 0 0         if ( grep {$_ eq $element} map {File::Spec->canonpath($_)}@INC) {
  0            
  0            
303 0           warn "$element is in the Perl include path, but is not a directory";
304             }
305             else {
306 0           warn "$element is not a directory";
307             }
308 0           push @debug, $element;
309             }
310             elsif (! -r $element) {
311 0 0         if ( grep {$_ eq $element} map {File::Spec->canonpath($_)}@INC) {
  0            
  0            
312 0           warn "$element is in the Perl include path, but is not readable";
313             }
314             else {
315 0           warn "$element is not a readable directory";
316             }
317              
318 0           push @debug, $element;
319             }
320             }
321             }
322             }
323              
324 0 0         error_msg("Search directories are invalid") unless @mod_dir >= 1;
325              
326 0           return @mod_dir;
327             }
328              
329             sub get_input {
330              
331 0     0 0   my $self = shift;
332 0           my $args = process_args(@_, \&check_module_args);
333 0           my %input = ();
334 0   0       $input{'files_in'} = $args->{'files_in'} || undef;
335 0   0       $input{'sort_by'} = $args->{'sort_by'} || 'name';
336 0   0       $input{'from'} = $args->{'from'} || \@INC;
337 0   0       $input{'show_only'} = $args->{'show_only'} || "";
338 0           $input{'color_specs'} = $args->{'color'};
339 0           $input{'link'} = $args->{'link'};
340             $input{'section'} = exists $args->{'section'} ? $args->{'section'} :
341 0 0         $input{'show_only'} eq 'core' ? 'Core Perl modules installed' : '';
    0          
342 0 0         $input{'full_page'} = exists $args->{'full_page'} ? $args->{'full_page'} : $self->{'full_page'};
343 0 0         $input{'show_inc'} = exists $args->{'show_inc'} ? $args->{'show_inc'} : 1;
344 0 0         $input{'show_dir'} = exists $args->{'show_dir'} ? $args->{'show_dir'} : 0;
345 0 0         $input{'columns'} = exists $args->{'columns'} ? $args->{'columns'} : ['name','version','desc'];
346 0           return %input;
347             }
348              
349             sub print_modules {
350            
351 0     0 1   my %input = get_input(@_);
352            
353 0           my ($found_mod, $mod_count, $overall_total, @mod_dir, $core_dir1, $core_dir2);
354            
355             # Check to see if a search is even needed
356 0 0         if (defined $input{'files_in'}) {
357            
358 0           my @files = @{ $input{'files_in'} };
  0            
359 0           my %found_mod = ();
360            
361 0           foreach my $file_path (@files) {
362            
363 0           my $mod_info = get_files_in($file_path);
364 0 0         next unless (ref $mod_info eq 'HASH');
365 0           $found_mod{$mod_info->{'name'}} = $mod_info;
366             }
367 0 0         return undef unless (keys %found_mod > 0);
368 0           $found_mod = \%found_mod;
369             }
370             else {
371            
372             # Get ready to search
373 0           $core_dir1 = File::Spec->canonpath($Config{installarchlib});
374 0           $core_dir2 = File::Spec->canonpath($Config{installprivlib});
375            
376 0           @mod_dir = search_dir($input{'from'}, $input{'show_only'}, $core_dir1, $core_dir2);
377              
378 0           ($overall_total, $found_mod, $mod_count) = find_modules($input{'show_only'}, \@mod_dir);
379            
380 0 0         return undef unless $overall_total;
381              
382             }
383            
384 0           my @sorted_modules = sort_modules($found_mod, $input{'sort_by'});
385            
386             my $html .= html_setup( $_[0],
387             $input{'columns'},
388             $input{'color_specs'},
389             $input{'section'},
390 0           $input{'full_page'}
391             );
392              
393 0           my $numberof_columns = scalar @{$input{'columns'}};
  0            
394            
395 0           foreach my $module (@sorted_modules) {
396            
397             $html .= print_table_row_color( $numberof_columns,
398             module_color_check($module->{'name'}, $input{'color_specs'}),
399             map{
400 0 0         if ($_ eq 'name') {
    0          
    0          
401 0           add_link('cpan', $module->{'name'}, $input{'link'});
402             }
403             elsif ($_ eq 'core') {
404 0 0         (grep File::Spec->rel2abs($module->{'path'}) =~ /\Q$_/, ($core_dir1, $core_dir2)) ? 'yes' : 'no';
405             }
406             elsif ($_ eq 'path') {
407 0           add_link('local', $module->{'path'});
408             }
409             else {
410 0           $module->{$_};
411             }
412            
413 0           } @{$input{'columns'}} );
  0            
414             }
415            
416 0           $html .= print_table_end();
417            
418 0 0 0       unless (defined $input{'files_in'} && ref $input{'files_in'} eq 'ARRAY') {
419             $html .= print_module_results( \@mod_dir,
420             $mod_count,
421             $input{'from'},
422             $overall_total,
423 0 0         $input{'show_dir'}) if $input{'show_inc'};
424             }
425            
426 0 0         $html .= "" if $input{'full_page'};
427            
428 0 0         defined wantarray ? return $html : print $html;
429            
430             }
431              
432             sub find_modules {
433              
434 0     0 0   my ($show_only, $mod_dir) = @_;
435              
436 0           my ($overall_total, $module, $base, $start_dir, $new_val, $mod_info);
437             # arrays
438 0           my (@modinfo_array, @mod_dir);
439             # hashes
440 0           my ( %path, %inc_path, %mod_count, %found_mod);
441 0           @mod_dir = @$mod_dir;
442            
443 0           @path{@mod_dir} = ();
444 0           @inc_path{@INC} = ();
445 0           for $base (@mod_dir) {
446            
447             find ({ wanted => sub {
448 0     0     for (@INC, @mod_dir) {
449 0 0         if (index($File::Find::name, $_) == 0) {
450             # lets record it unless we already have hit the dir
451 0 0         $mod_count{$_} = 0 unless exists $mod_count{$_};
452             }
453             }
454             # This prevents mod_dir dirs from being searched again when you have a dir within a dir
455 0 0 0       $File::Find::prune = 1, return if exists $path{$File::Find::name} && $File::Find::name ne $File::Find::topdir;
456              
457             # make sure we are dealing with a module
458 0 0         return unless $File::Find::name =~ m/\.pm$/;
459 0           $mod_info = module_info($File::Find::name, $show_only);
460 0 0         return unless ref ($mod_info) eq 'HASH';
461              
462             # update the counts.
463 0           for (@INC, grep{not exists $inc_path{$_}}@mod_dir) {
  0            
464 0 0         if (index($File::Find::name, $_) == 0) {
465 0           $mod_count{$_}++;
466             }
467             }
468 0           $overall_total++;
469              
470 0           $mod_info->{'path'} = File::Spec->canonpath($File::Find::dir);
471             # Check for duplicate modules
472 0 0         if (exists $found_mod{$mod_info->{'name'}}) {
473 0 0         @modinfo_array = ref( $found_mod{$mod_info->{'name'}} ) eq 'ARRAY' ? @{$found_mod{$mod_info->{'name'}}} : $found_mod{$mod_info->{'name'}};
  0            
474 0           push @modinfo_array, $mod_info;
475 0           $new_val = [@modinfo_array];
476 0           $found_mod{$mod_info->{'name'}} = $new_val;
477             }
478             else {
479 0           $found_mod{$mod_info->{'name'}} = $mod_info;
480             }
481            
482 0           },untaint => 1, untaint_pattern => qr|^([-+@\s\S\w./]+)$|}, $base);
483             } # end of for loop
484              
485 0           return ($overall_total, \%found_mod, \%mod_count);
486              
487             }
488              
489             1;
490             __END__