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