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