This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7ea1210a241561c0b0d12fdfdf4470929cc8c0e8
[perl5.git] / cpan / Module-Metadata / lib / Module / Metadata.pm
1 # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2 # vim:ts=8:sw=2:et:sta:sts=2
3 package Module::Metadata; # git description: v1.000025-7-g47ca1b2
4
5 # Adapted from Perl-licensed code originally distributed with
6 # Module-Build by Ken Williams
7
8 # This module provides routines to gather information about
9 # perl modules (assuming this may be expanded in the distant
10 # parrot future to look at other types of modules).
11
12 sub __clean_eval { eval $_[0] }
13 use strict;
14 use warnings;
15
16 our $VERSION = '1.000026';
17
18 use Carp qw/croak/;
19 use File::Spec;
20 BEGIN {
21        # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
22        eval {
23                require Fcntl; Fcntl->import('SEEK_SET'); 1;
24        } or *SEEK_SET = sub { 0 }
25 }
26 use version 0.87;
27 BEGIN {
28   if ($INC{'Log/Contextual.pm'}) {
29     Log::Contextual->import('log_info');
30   } else {
31     *log_info = sub (&) { warn $_[0]->() };
32   }
33 }
34 use File::Find qw(find);
35
36 my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
37
38 my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
39   [a-zA-Z_]                     # the first word CANNOT start with a digit
40     (?:
41       [\w']?                    # can contain letters, digits, _, or ticks
42       \w                        # But, NO multi-ticks or trailing ticks
43     )*
44 }x;
45
46 my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
47   \w                           # the 2nd+ word CAN start with digits
48     (?:
49       [\w']?                   # and can contain letters or ticks
50       \w                       # But, NO multi-ticks or trailing ticks
51     )*
52 }x;
53
54 my $PKG_NAME_REGEXP = qr{ # match a package name
55   (?: :: )?               # a pkg name can start with arisdottle
56   $PKG_FIRST_WORD_REGEXP  # a package word
57   (?:
58     (?: :: )+             ### arisdottle (allow one or many times)
59     $PKG_ADDL_WORD_REGEXP ### a package word
60   )*                      # ^ zero, one or many times
61   (?:
62     ::                    # allow trailing arisdottle
63   )?
64 }x;
65
66 my $PKG_REGEXP  = qr{   # match a package declaration
67   ^[\s\{;]*             # intro chars on a line
68   package               # the word 'package'
69   \s+                   # whitespace
70   ($PKG_NAME_REGEXP)    # a package name
71   \s*                   # optional whitespace
72   ($V_NUM_REGEXP)?        # optional version number
73   \s*                   # optional whitesapce
74   [;\{]                 # semicolon line terminator or block start (since 5.16)
75 }x;
76
77 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
78   ([\$*])         # sigil - $ or *
79   (
80     (             # optional leading package name
81       (?:::|\')?  # possibly starting like just :: (a la $::VERSION)
82       (?:\w+(?:::|\'))*  # Foo::Bar:: ...
83     )?
84     VERSION
85   )\b
86 }x;
87
88 my $VERS_REGEXP = qr{ # match a VERSION definition
89   (?:
90     \(\s*$VARNAME_REGEXP\s*\) # with parens
91   |
92     $VARNAME_REGEXP           # without parens
93   )
94   \s*
95   =[^=~>]  # = but not ==, nor =~, nor =>
96 }x;
97
98 sub new_from_file {
99   my $class    = shift;
100   my $filename = File::Spec->rel2abs( shift );
101
102   return undef unless defined( $filename ) && -f $filename;
103   return $class->_init(undef, $filename, @_);
104 }
105
106 sub new_from_handle {
107   my $class    = shift;
108   my $handle   = shift;
109   my $filename = shift;
110   return undef unless defined($handle) && defined($filename);
111   $filename = File::Spec->rel2abs( $filename );
112
113   return $class->_init(undef, $filename, @_, handle => $handle);
114
115 }
116
117
118 sub new_from_module {
119   my $class   = shift;
120   my $module  = shift;
121   my %props   = @_;
122
123   $props{inc} ||= \@INC;
124   my $filename = $class->find_module_by_name( $module, $props{inc} );
125   return undef unless defined( $filename ) && -f $filename;
126   return $class->_init($module, $filename, %props);
127 }
128
129 {
130
131   my $compare_versions = sub {
132     my ($v1, $op, $v2) = @_;
133     $v1 = version->new($v1)
134       unless UNIVERSAL::isa($v1,'version');
135
136     my $eval_str = "\$v1 $op \$v2";
137     my $result   = eval $eval_str;
138     log_info { "error comparing versions: '$eval_str' $@" } if $@;
139
140     return $result;
141   };
142
143   my $normalize_version = sub {
144     my ($version) = @_;
145     if ( $version =~ /[=<>!,]/ ) { # logic, not just version
146       # take as is without modification
147     }
148     elsif ( ref $version eq 'version' ) { # version objects
149       $version = $version->is_qv ? $version->normal : $version->stringify;
150     }
151     elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
152       # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
153       $version = "v$version";
154     }
155     else {
156       # leave alone
157     }
158     return $version;
159   };
160
161   # separate out some of the conflict resolution logic
162
163   my $resolve_module_versions = sub {
164     my $packages = shift;
165
166     my( $file, $version );
167     my $err = '';
168       foreach my $p ( @$packages ) {
169         if ( defined( $p->{version} ) ) {
170           if ( defined( $version ) ) {
171             if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
172               $err .= "  $p->{file} ($p->{version})\n";
173             } else {
174               # same version declared multiple times, ignore
175             }
176           } else {
177             $file    = $p->{file};
178             $version = $p->{version};
179           }
180         }
181       $file ||= $p->{file} if defined( $p->{file} );
182     }
183
184     if ( $err ) {
185       $err = "  $file ($version)\n" . $err;
186     }
187
188     my %result = (
189       file    => $file,
190       version => $version,
191       err     => $err
192     );
193
194     return \%result;
195   };
196
197   sub provides {
198     my $class = shift;
199
200     croak "provides() requires key/value pairs \n" if @_ % 2;
201     my %args = @_;
202
203     croak "provides() takes only one of 'dir' or 'files'\n"
204       if $args{dir} && $args{files};
205
206     croak "provides() requires a 'version' argument"
207       unless defined $args{version};
208
209     croak "provides() does not support version '$args{version}' metadata"
210         unless grep { $args{version} eq $_ } qw/1.4 2/;
211
212     $args{prefix} = 'lib' unless defined $args{prefix};
213
214     my $p;
215     if ( $args{dir} ) {
216       $p = $class->package_versions_from_directory($args{dir});
217     }
218     else {
219       croak "provides() requires 'files' to be an array reference\n"
220         unless ref $args{files} eq 'ARRAY';
221       $p = $class->package_versions_from_directory($args{files});
222     }
223
224     # Now, fix up files with prefix
225     if ( length $args{prefix} ) { # check in case disabled with q{}
226       $args{prefix} =~ s{/$}{};
227       for my $v ( values %$p ) {
228         $v->{file} = "$args{prefix}/$v->{file}";
229       }
230     }
231
232     return $p
233   }
234
235   sub package_versions_from_directory {
236     my ( $class, $dir, $files ) = @_;
237
238     my @files;
239
240     if ( $files ) {
241       @files = @$files;
242     } else {
243       find( {
244         wanted => sub {
245           push @files, $_ if -f $_ && /\.pm$/;
246         },
247         no_chdir => 1,
248       }, $dir );
249     }
250
251     # First, we enumerate all packages & versions,
252     # separating into primary & alternative candidates
253     my( %prime, %alt );
254     foreach my $file (@files) {
255       my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
256       my @path = split( /\//, $mapped_filename );
257       (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
258
259       my $pm_info = $class->new_from_file( $file );
260
261       foreach my $package ( $pm_info->packages_inside ) {
262         next if $package eq 'main';  # main can appear numerous times, ignore
263         next if $package eq 'DB';    # special debugging package, ignore
264         next if grep /^_/, split( /::/, $package ); # private package, ignore
265
266         my $version = $pm_info->version( $package );
267
268         $prime_package = $package if lc($prime_package) eq lc($package);
269         if ( $package eq $prime_package ) {
270           if ( exists( $prime{$package} ) ) {
271             croak "Unexpected conflict in '$package'; multiple versions found.\n";
272           } else {
273             $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
274             $prime{$package}{file} = $mapped_filename;
275             $prime{$package}{version} = $version if defined( $version );
276           }
277         } else {
278           push( @{$alt{$package}}, {
279                                     file    => $mapped_filename,
280                                     version => $version,
281                                    } );
282         }
283       }
284     }
285
286     # Then we iterate over all the packages found above, identifying conflicts
287     # and selecting the "best" candidate for recording the file & version
288     # for each package.
289     foreach my $package ( keys( %alt ) ) {
290       my $result = $resolve_module_versions->( $alt{$package} );
291
292       if ( exists( $prime{$package} ) ) { # primary package selected
293
294         if ( $result->{err} ) {
295         # Use the selected primary package, but there are conflicting
296         # errors among multiple alternative packages that need to be
297         # reported
298           log_info {
299             "Found conflicting versions for package '$package'\n" .
300             "  $prime{$package}{file} ($prime{$package}{version})\n" .
301             $result->{err}
302           };
303
304         } elsif ( defined( $result->{version} ) ) {
305         # There is a primary package selected, and exactly one
306         # alternative package
307
308         if ( exists( $prime{$package}{version} ) &&
309              defined( $prime{$package}{version} ) ) {
310           # Unless the version of the primary package agrees with the
311           # version of the alternative package, report a conflict
312         if ( $compare_versions->(
313                  $prime{$package}{version}, '!=', $result->{version}
314                )
315              ) {
316
317             log_info {
318               "Found conflicting versions for package '$package'\n" .
319               "  $prime{$package}{file} ($prime{$package}{version})\n" .
320               "  $result->{file} ($result->{version})\n"
321             };
322           }
323
324         } else {
325           # The prime package selected has no version so, we choose to
326           # use any alternative package that does have a version
327           $prime{$package}{file}    = $result->{file};
328           $prime{$package}{version} = $result->{version};
329         }
330
331         } else {
332         # no alt package found with a version, but we have a prime
333         # package so we use it whether it has a version or not
334         }
335
336       } else { # No primary package was selected, use the best alternative
337
338         if ( $result->{err} ) {
339           log_info {
340             "Found conflicting versions for package '$package'\n" .
341             $result->{err}
342           };
343         }
344
345         # Despite possible conflicting versions, we choose to record
346         # something rather than nothing
347         $prime{$package}{file}    = $result->{file};
348         $prime{$package}{version} = $result->{version}
349           if defined( $result->{version} );
350       }
351     }
352
353     # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
354     # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
355     for (grep defined $_->{version}, values %prime) {
356       $_->{version} = $normalize_version->( $_->{version} );
357     }
358
359     return \%prime;
360   }
361 }
362
363
364 sub _init {
365   my $class    = shift;
366   my $module   = shift;
367   my $filename = shift;
368   my %props = @_;
369
370   my $handle = delete $props{handle};
371   my( %valid_props, @valid_props );
372   @valid_props = qw( collect_pod inc );
373   @valid_props{@valid_props} = delete( @props{@valid_props} );
374   warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
375
376   my %data = (
377     module       => $module,
378     filename     => $filename,
379     version      => undef,
380     packages     => [],
381     versions     => {},
382     pod          => {},
383     pod_headings => [],
384     collect_pod  => 0,
385
386     %valid_props,
387   );
388
389   my $self = bless(\%data, $class);
390
391   if ( not $handle ) {
392     my $filename = $self->{filename};
393     open $handle, '<', $filename
394       or croak( "Can't open '$filename': $!" );
395
396     $self->_handle_bom($handle, $filename);
397   }
398   $self->_parse_fh($handle);
399
400   unless($self->{module} and length($self->{module})) {
401     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
402     if($f =~ /\.pm$/) {
403       $f =~ s/\..+$//;
404       my @candidates = grep /$f$/, @{$self->{packages}};
405       $self->{module} = shift(@candidates); # punt
406     }
407     else {
408       if(grep /main/, @{$self->{packages}}) {
409         $self->{module} = 'main';
410       }
411       else {
412         $self->{module} = $self->{packages}[0] || '';
413       }
414     }
415   }
416
417   $self->{version} = $self->{versions}{$self->{module}}
418       if defined( $self->{module} );
419
420   return $self;
421 }
422
423 # class method
424 sub _do_find_module {
425   my $class   = shift;
426   my $module  = shift || croak 'find_module_by_name() requires a package name';
427   my $dirs    = shift || \@INC;
428
429   my $file = File::Spec->catfile(split( /::/, $module));
430   foreach my $dir ( @$dirs ) {
431     my $testfile = File::Spec->catfile($dir, $file);
432     return [ File::Spec->rel2abs( $testfile ), $dir ]
433       if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
434     $testfile .= '.pm';
435     return [ File::Spec->rel2abs( $testfile ), $dir ]
436       if -e $testfile;
437   }
438   return;
439 }
440
441 # class method
442 sub find_module_by_name {
443   my $found = shift()->_do_find_module(@_) or return;
444   return $found->[0];
445 }
446
447 # class method
448 sub find_module_dir_by_name {
449   my $found = shift()->_do_find_module(@_) or return;
450   return $found->[1];
451 }
452
453
454 # given a line of perl code, attempt to parse it if it looks like a
455 # $VERSION assignment, returning sigil, full name, & package name
456 sub _parse_version_expression {
457   my $self = shift;
458   my $line = shift;
459
460   my( $sigil, $variable_name, $package);
461   if ( $line =~ /$VERS_REGEXP/o ) {
462     ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
463     if ( $package ) {
464       $package = ($package eq '::') ? 'main' : $package;
465       $package =~ s/::$//;
466     }
467   }
468
469   return ( $sigil, $variable_name, $package );
470 }
471
472 # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
473 # If there's one, then skip it and set the :encoding layer appropriately.
474 sub _handle_bom {
475   my ($self, $fh, $filename) = @_;
476
477   my $pos = tell $fh;
478   return unless defined $pos;
479
480   my $buf = ' ' x 2;
481   my $count = read $fh, $buf, length $buf;
482   return unless defined $count and $count >= 2;
483
484   my $encoding;
485   if ( $buf eq "\x{FE}\x{FF}" ) {
486     $encoding = 'UTF-16BE';
487   } elsif ( $buf eq "\x{FF}\x{FE}" ) {
488     $encoding = 'UTF-16LE';
489   } elsif ( $buf eq "\x{EF}\x{BB}" ) {
490     $buf = ' ';
491     $count = read $fh, $buf, length $buf;
492     if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
493       $encoding = 'UTF-8';
494     }
495   }
496
497   if ( defined $encoding ) {
498     if ( "$]" >= 5.008 ) {
499       binmode( $fh, ":encoding($encoding)" );
500     }
501   } else {
502     seek $fh, $pos, SEEK_SET
503       or croak( sprintf "Can't reset position to the top of '$filename'" );
504   }
505
506   return $encoding;
507 }
508
509 sub _parse_fh {
510   my ($self, $fh) = @_;
511
512   my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
513   my( @packages, %vers, %pod, @pod );
514   my $package = 'main';
515   my $pod_sect = '';
516   my $pod_data = '';
517   my $in_end = 0;
518
519   while (defined( my $line = <$fh> )) {
520     my $line_num = $.;
521
522     chomp( $line );
523
524     # From toke.c : any line that begins by "=X", where X is an alphabetic
525     # character, introduces a POD segment.
526     my $is_cut;
527     if ( $line =~ /^=([a-zA-Z].*)/ ) {
528       my $cmd = $1;
529       # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
530       # character (which includes the newline, but here we chomped it away).
531       $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
532       $in_pod = !$is_cut;
533     }
534
535     if ( $in_pod ) {
536
537       if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
538         push( @pod, $1 );
539         if ( $self->{collect_pod} && length( $pod_data ) ) {
540           $pod{$pod_sect} = $pod_data;
541           $pod_data = '';
542         }
543         $pod_sect = $1;
544
545       } elsif ( $self->{collect_pod} ) {
546         $pod_data .= "$line\n";
547
548       }
549
550     } elsif ( $is_cut ) {
551
552       if ( $self->{collect_pod} && length( $pod_data ) ) {
553         $pod{$pod_sect} = $pod_data;
554         $pod_data = '';
555       }
556       $pod_sect = '';
557
558     } else {
559
560       # Skip after __END__
561       next if $in_end;
562
563       # Skip comments in code
564       next if $line =~ /^\s*#/;
565
566       # Would be nice if we could also check $in_string or something too
567       if ($line eq '__END__') {
568         $in_end++;
569         next;
570       }
571       last if $line eq '__DATA__';
572
573       # parse $line to see if it's a $VERSION declaration
574       my( $version_sigil, $version_fullname, $version_package ) =
575           index($line, 'VERSION') >= 1
576               ? $self->_parse_version_expression( $line )
577               : ();
578
579       if ( $line =~ /$PKG_REGEXP/o ) {
580         $package = $1;
581         my $version = $2;
582         push( @packages, $package ) unless grep( $package eq $_, @packages );
583         $need_vers = defined $version ? 0 : 1;
584
585         if ( not exists $vers{$package} and defined $version ){
586           # Upgrade to a version object.
587           my $dwim_version = eval { _dwim_version($version) };
588           croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
589               unless defined $dwim_version;  # "0" is OK!
590           $vers{$package} = $dwim_version;
591         }
592
593       # VERSION defined with full package spec, i.e. $Module::VERSION
594       } elsif ( $version_fullname && $version_package ) {
595         push( @packages, $version_package ) unless grep( $version_package eq $_, @packages );
596         $need_vers = 0 if $version_package eq $package;
597
598         unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
599         $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
600       }
601
602       # first non-comment line in undeclared package main is VERSION
603       } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
604         $need_vers = 0;
605         my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
606         $vers{$package} = $v;
607         push( @packages, 'main' );
608
609       # first non-comment line in undeclared package defines package main
610       } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
611         $need_vers = 1;
612         $vers{main} = '';
613         push( @packages, 'main' );
614
615       # only keep if this is the first $VERSION seen
616       } elsif ( $version_fullname && $need_vers ) {
617         $need_vers = 0;
618         my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
619
620         unless ( defined $vers{$package} && length $vers{$package} ) {
621           $vers{$package} = $v;
622         }
623       }
624     }
625   }
626
627   if ( $self->{collect_pod} && length($pod_data) ) {
628     $pod{$pod_sect} = $pod_data;
629   }
630
631   $self->{versions} = \%vers;
632   $self->{packages} = \@packages;
633   $self->{pod} = \%pod;
634   $self->{pod_headings} = \@pod;
635 }
636
637 {
638 my $pn = 0;
639 sub _evaluate_version_line {
640   my $self = shift;
641   my( $sigil, $variable_name, $line ) = @_;
642
643   # We compile into a local sub because 'use version' would cause
644   # compiletime/runtime issues with local()
645   $pn++; # everybody gets their own package
646   my $eval = qq{ my \$dummy = q#  Hide from _packages_inside()
647     #; package Module::Metadata::_version::p${pn};
648     use version;
649     sub {
650       local $sigil$variable_name;
651       $line;
652       \$$variable_name
653     };
654   };
655
656   $eval = $1 if $eval =~ m{^(.+)}s;
657
658   local $^W;
659   # Try to get the $VERSION
660   my $vsub = __clean_eval($eval);
661   # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
662   # installed, so we need to hunt in ./lib for it
663   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
664     local @INC = ('lib',@INC);
665     $vsub = __clean_eval($eval);
666   }
667   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
668     if $@;
669
670   (ref($vsub) eq 'CODE') or
671     croak "failed to build version sub for $self->{filename}";
672
673   my $result = eval { $vsub->() };
674   # FIXME: $eval is not the right thing to print here
675   croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
676     if $@;
677
678   # Upgrade it into a version object
679   my $version = eval { _dwim_version($result) };
680
681   # FIXME: $eval is not the right thing to print here
682   croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
683     unless defined $version; # "0" is OK!
684
685   return $version;
686 }
687 }
688
689 # Try to DWIM when things fail the lax version test in obvious ways
690 {
691   my @version_prep = (
692     # Best case, it just works
693     sub { return shift },
694
695     # If we still don't have a version, try stripping any
696     # trailing junk that is prohibited by lax rules
697     sub {
698       my $v = shift;
699       $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
700       return $v;
701     },
702
703     # Activestate apparently creates custom versions like '1.23_45_01', which
704     # cause version.pm to think it's an invalid alpha.  So check for that
705     # and strip them
706     sub {
707       my $v = shift;
708       my $num_dots = () = $v =~ m{(\.)}g;
709       my $num_unders = () = $v =~ m{(_)}g;
710       my $leading_v = substr($v,0,1) eq 'v';
711       if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
712         $v =~ s{_}{}g;
713         $num_unders = () = $v =~ m{(_)}g;
714       }
715       return $v;
716     },
717
718     # Worst case, try numifying it like we would have before version objects
719     sub {
720       my $v = shift;
721       no warnings 'numeric';
722       return 0 + $v;
723     },
724
725   );
726
727   sub _dwim_version {
728     my ($result) = shift;
729
730     return $result if ref($result) eq 'version';
731
732     my ($version, $error);
733     for my $f (@version_prep) {
734       $result = $f->($result);
735       $version = eval { version->new($result) };
736       $error ||= $@ if $@; # capture first failure
737       last if defined $version;
738     }
739
740     croak $error unless defined $version;
741
742     return $version;
743   }
744 }
745
746 ############################################################
747
748 # accessors
749 sub name            { $_[0]->{module}            }
750
751 sub filename        { $_[0]->{filename}          }
752 sub packages_inside { @{$_[0]->{packages}}       }
753 sub pod_inside      { @{$_[0]->{pod_headings}}   }
754 sub contains_pod    { 0+@{$_[0]->{pod_headings}} }
755
756 sub version {
757     my $self = shift;
758     my $mod  = shift || $self->{module};
759     my $vers;
760     if ( defined( $mod ) && length( $mod ) &&
761          exists( $self->{versions}{$mod} ) ) {
762         return $self->{versions}{$mod};
763     } else {
764         return undef;
765     }
766 }
767
768 sub pod {
769     my $self = shift;
770     my $sect = shift;
771     if ( defined( $sect ) && length( $sect ) &&
772          exists( $self->{pod}{$sect} ) ) {
773         return $self->{pod}{$sect};
774     } else {
775         return undef;
776     }
777 }
778
779 sub is_indexable {
780   my ($self, $package) = @_;
781
782   my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside;
783
784   # check for specific package, if provided
785   return !! grep { $_ eq $package } @indexable_packages if $package;
786
787   # otherwise, check for any indexable packages at all
788   return !! @indexable_packages;
789 }
790
791 1;
792
793 =head1 NAME
794
795 Module::Metadata - Gather package and POD information from perl module files
796
797 =head1 SYNOPSIS
798
799   use Module::Metadata;
800
801   # information about a .pm file
802   my $info = Module::Metadata->new_from_file( $file );
803   my $version = $info->version;
804
805   # CPAN META 'provides' field for .pm files in a directory
806   my $provides = Module::Metadata->provides(
807     dir => 'lib', version => 2
808   );
809
810 =head1 DESCRIPTION
811
812 This module provides a standard way to gather metadata about a .pm file through
813 (mostly) static analysis and (some) code execution.  When determining the
814 version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
815 in the CPAN toolchain.
816
817 =head1 USAGE
818
819 =head2 Class methods
820
821 =over 4
822
823 =item C<< new_from_file($filename, collect_pod => 1) >>
824
825 Constructs a C<Module::Metadata> object given the path to a file.  Returns
826 undef if the filename does not exist.
827
828 C<collect_pod> is a optional boolean argument that determines whether POD
829 data is collected and stored for reference.  POD data is not collected by
830 default.  POD headings are always collected.
831
832 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
833 it is skipped before processing, and the content of the file is also decoded
834 appropriately starting from perl 5.8.
835
836 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
837
838 This works just like C<new_from_file>, except that a handle can be provided
839 as the first argument.
840
841 Note that there is no validation to confirm that the handle is a handle or
842 something that can act like one.  Passing something that isn't a handle will
843 cause a exception when trying to read from it.  The C<filename> argument is
844 mandatory or undef will be returned.
845
846 You are responsible for setting the decoding layers on C<$handle> if
847 required.
848
849 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
850
851 Constructs a C<Module::Metadata> object given a module or package name.
852 Returns undef if the module cannot be found.
853
854 In addition to accepting the C<collect_pod> argument as described above,
855 this method accepts a C<inc> argument which is a reference to an array of
856 directories to search for the module.  If none are given, the default is
857 @INC.
858
859 If the file that contains the module begins by an UTF-8, UTF-16BE or
860 UTF-16LE byte-order mark, then it is skipped before processing, and the
861 content of the file is also decoded appropriately starting from perl 5.8.
862
863 =item C<< find_module_by_name($module, \@dirs) >>
864
865 Returns the path to a module given the module or package name. A list
866 of directories can be passed in as an optional parameter, otherwise
867 @INC is searched.
868
869 Can be called as either an object or a class method.
870
871 =item C<< find_module_dir_by_name($module, \@dirs) >>
872
873 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
874 the module C<$module>. A list of directories can be passed in as an
875 optional parameter, otherwise @INC is searched.
876
877 Can be called as either an object or a class method.
878
879 =item C<< provides( %options ) >>
880
881 This is a convenience wrapper around C<package_versions_from_directory>
882 to generate a CPAN META C<provides> data structure.  It takes key/value
883 pairs.  Valid option keys include:
884
885 =over
886
887 =item version B<(required)>
888
889 Specifies which version of the L<CPAN::Meta::Spec> should be used as
890 the format of the C<provides> output.  Currently only '1.4' and '2'
891 are supported (and their format is identical).  This may change in
892 the future as the definition of C<provides> changes.
893
894 The C<version> option is required.  If it is omitted or if
895 an unsupported version is given, then C<provides> will throw an error.
896
897 =item dir
898
899 Directory to search recursively for F<.pm> files.  May not be specified with
900 C<files>.
901
902 =item files
903
904 Array reference of files to examine.  May not be specified with C<dir>.
905
906 =item prefix
907
908 String to prepend to the C<file> field of the resulting output. This defaults
909 to F<lib>, which is the common case for most CPAN distributions with their
910 F<.pm> files in F<lib>.  This option ensures the META information has the
911 correct relative path even when the C<dir> or C<files> arguments are
912 absolute or have relative paths from a location other than the distribution
913 root.
914
915 =back
916
917 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
918 is a hashref of the form:
919
920   {
921     'Package::Name' => {
922       version => '0.123',
923       file => 'lib/Package/Name.pm'
924     },
925     'OtherPackage::Name' => ...
926   }
927
928 =item C<< package_versions_from_directory($dir, \@files?) >>
929
930 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
931 for those files in C<$dir> - and reads each file for packages and versions,
932 returning a hashref of the form:
933
934   {
935     'Package::Name' => {
936       version => '0.123',
937       file => 'Package/Name.pm'
938     },
939     'OtherPackage::Name' => ...
940   }
941
942 The C<DB> and C<main> packages are always omitted, as are any "private"
943 packages that have leading underscores in the namespace (e.g.
944 C<Foo::_private>)
945
946 Note that the file path is relative to C<$dir> if that is specified.
947 This B<must not> be used directly for CPAN META C<provides>.  See
948 the C<provides> method instead.
949
950 =item C<< log_info (internal) >>
951
952 Used internally to perform logging; imported from Log::Contextual if
953 Log::Contextual has already been loaded, otherwise simply calls warn.
954
955 =back
956
957 =head2 Object methods
958
959 =over 4
960
961 =item C<< name() >>
962
963 Returns the name of the package represented by this module. If there
964 is more than one package, it makes a best guess based on the
965 filename. If it's a script (i.e. not a *.pm) the package name is
966 'main'.
967
968 =item C<< version($package) >>
969
970 Returns the version as defined by the $VERSION variable for the
971 package as returned by the C<name> method if no arguments are
972 given. If given the name of a package it will attempt to return the
973 version of that package if it is specified in the file.
974
975 =item C<< filename() >>
976
977 Returns the absolute path to the file.
978
979 =item C<< packages_inside() >>
980
981 Returns a list of packages. Note: this is a raw list of packages
982 discovered (or assumed, in the case of C<main>).  It is not
983 filtered for C<DB>, C<main> or private packages the way the
984 C<provides> method does.  Invalid package names are not returned,
985 for example "Foo:Bar".  Strange but valid package names are
986 returned, for example "Foo::Bar::", and are left up to the caller
987 on how to handle.
988
989 =item C<< pod_inside() >>
990
991 Returns a list of POD sections.
992
993 =item C<< contains_pod() >>
994
995 Returns true if there is any POD in the file.
996
997 =item C<< pod($section) >>
998
999 Returns the POD data in the given section.
1000
1001 =item C<< is_indexable($package) >> or C<< is_indexable() >>
1002
1003 Returns a boolean indicating whether the package (if provided) or any package
1004 (otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server.
1005 Note This only checks for valid C<package> declarations, and does not take any
1006 ownership information into account.
1007
1008 =back
1009
1010 =head1 AUTHOR
1011
1012 Original code from Module::Build::ModuleInfo by Ken Williams
1013 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
1014
1015 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
1016 assistance from David Golden (xdg) <dagolden@cpan.org>.
1017
1018 =head1 COPYRIGHT & LICENSE
1019
1020 Original code Copyright (c) 2001-2011 Ken Williams.
1021 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
1022 All rights reserved.
1023
1024 This library is free software; you can redistribute it and/or
1025 modify it under the same terms as Perl itself.
1026
1027 =cut
1028