File Coverage

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