This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2f5cb7ef77b87fa61d542327e37433dacfa86cb6
[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.000014';
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 irrelvant -- 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
804 without executing unsafe code.
805
806 =head1 USAGE
807
808 =head2 Class methods
809
810 =over 4
811
812 =item C<< new_from_file($filename, collect_pod => 1) >>
813
814 Constructs a C<Module::Metadata> object given the path to a file.  Returns
815 undef if the filename does not exist.
816
817 C<collect_pod> is a optional boolean argument that determines whether POD
818 data is collected and stored for reference.  POD data is not collected by
819 default.  POD headings are always collected.
820
821 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
822 it is skipped before processing, and the content of the file is also decoded
823 appropriately starting from perl 5.8.
824
825 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
826
827 This works just like C<new_from_file>, except that a handle can be provided
828 as the first argument.
829
830 Note that there is no validation to confirm that the handle is a handle or
831 something that can act like one.  Passing something that isn't a handle will
832 cause a exception when trying to read from it.  The C<filename> argument is
833 mandatory or undef will be returned.
834
835 You are responsible for setting the decoding layers on C<$handle> if
836 required.
837
838 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
839
840 Constructs a C<Module::Metadata> object given a module or package name.
841 Returns undef if the module cannot be found.
842
843 In addition to accepting the C<collect_pod> argument as described above,
844 this method accepts a C<inc> argument which is a reference to an array of
845 directories to search for the module.  If none are given, the default is
846 @INC.
847
848 If the file that contains the module begins by an UTF-8, UTF-16BE or
849 UTF-16LE byte-order mark, then it is skipped before processing, and the
850 content of the file is also decoded appropriately starting from perl 5.8.
851
852 =item C<< find_module_by_name($module, \@dirs) >>
853
854 Returns the path to a module given the module or package name. A list
855 of directories can be passed in as an optional parameter, otherwise
856 @INC is searched.
857
858 Can be called as either an object or a class method.
859
860 =item C<< find_module_dir_by_name($module, \@dirs) >>
861
862 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
863 the module C<$module>. A list of directories can be passed in as an
864 optional parameter, otherwise @INC is searched.
865
866 Can be called as either an object or a class method.
867
868 =item C<< provides( %options ) >>
869
870 This is a convenience wrapper around C<package_versions_from_directory>
871 to generate a CPAN META C<provides> data structure.  It takes key/value
872 pairs.  Valid option keys include:
873
874 =over
875
876 =item version B<(required)>
877
878 Specifies which version of the L<CPAN::Meta::Spec> should be used as
879 the format of the C<provides> output.  Currently only '1.4' and '2'
880 are supported (and their format is identical).  This may change in
881 the future as the definition of C<provides> changes.
882
883 The C<version> option is required.  If it is omitted or if
884 an unsupported version is given, then C<provides> will throw an error.
885
886 =item dir
887
888 Directory to search recursively for F<.pm> files.  May not be specified with
889 C<files>.
890
891 =item files
892
893 Array reference of files to examine.  May not be specified with C<dir>.
894
895 =item prefix
896
897 String to prepend to the C<file> field of the resulting output. This defaults
898 to F<lib>, which is the common case for most CPAN distributions with their
899 F<.pm> files in F<lib>.  This option ensures the META information has the
900 correct relative path even when the C<dir> or C<files> arguments are
901 absolute or have relative paths from a location other than the distribution
902 root.
903
904 =back
905
906 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
907 is a hashref of the form:
908
909   {
910     'Package::Name' => {
911       version => '0.123',
912       file => 'lib/Package/Name.pm'
913     },
914     'OtherPackage::Name' => ...
915   }
916
917 =item C<< package_versions_from_directory($dir, \@files?) >>
918
919 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
920 for those files in C<$dir> - and reads each file for packages and versions,
921 returning a hashref of the form:
922
923   {
924     'Package::Name' => {
925       version => '0.123',
926       file => 'Package/Name.pm'
927     },
928     'OtherPackage::Name' => ...
929   }
930
931 The C<DB> and C<main> packages are always omitted, as are any "private"
932 packages that have leading underscores in the namespace (e.g.
933 C<Foo::_private>)
934
935 Note that the file path is relative to C<$dir> if that is specified.
936 This B<must not> be used directly for CPAN META C<provides>.  See
937 the C<provides> method instead.
938
939 =item C<< log_info (internal) >>
940
941 Used internally to perform logging; imported from Log::Contextual if
942 Log::Contextual has already been loaded, otherwise simply calls warn.
943
944 =back
945
946 =head2 Object methods
947
948 =over 4
949
950 =item C<< name() >>
951
952 Returns the name of the package represented by this module. If there
953 are more than one packages, it makes a best guess based on the
954 filename. If it's a script (i.e. not a *.pm) the package name is
955 'main'.
956
957 =item C<< version($package) >>
958
959 Returns the version as defined by the $VERSION variable for the
960 package as returned by the C<name> method if no arguments are
961 given. If given the name of a package it will attempt to return the
962 version of that package if it is specified in the file.
963
964 =item C<< filename() >>
965
966 Returns the absolute path to the file.
967
968 =item C<< packages_inside() >>
969
970 Returns a list of packages. Note: this is a raw list of packages
971 discovered (or assumed, in the case of C<main>).  It is not
972 filtered for C<DB>, C<main> or private packages the way the
973 C<provides> method does.  Invalid package names are not returned,
974 for example "Foo:Bar".  Strange but valid package names are
975 returned, for example "Foo::Bar::", and are left up to the caller
976 on how to handle.
977
978 =item C<< pod_inside() >>
979
980 Returns a list of POD sections.
981
982 =item C<< contains_pod() >>
983
984 Returns true if there is any POD in the file.
985
986 =item C<< pod($section) >>
987
988 Returns the POD data in the given section.
989
990 =back
991
992 =head1 AUTHOR
993
994 Original code from Module::Build::ModuleInfo by Ken Williams
995 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
996
997 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
998 assistance from David Golden (xdg) <dagolden@cpan.org>.
999
1000 =head1 COPYRIGHT & LICENSE
1001
1002 Original code Copyright (c) 2001-2011 Ken Williams.
1003 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
1004 All rights reserved.
1005
1006 This library is free software; you can redistribute it and/or
1007 modify it under the same terms as Perl itself.
1008
1009 =cut
1010