Fixed `$metadata->contains_pod`. Because $#x is -1 origin.
[p5sagit/Module-Metadata.git] / 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.000011';
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
522   while (defined( my $line = <$fh> )) {
523     my $line_num = $.;
524
525     chomp( $line );
526
527     # From toke.c : any line that begins by "=X", where X is an alphabetic
528     # character, introduces a POD segment.
529     my $is_cut;
530     if ( $line =~ /^=([a-zA-Z].*)/ ) {
531       my $cmd = $1;
532       # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
533       # character (which includes the newline, but here we chomped it away).
534       $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
535       $in_pod = !$is_cut;
536     }
537
538     if ( $in_pod ) {
539
540       if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
541         push( @pod, $1 );
542         if ( $self->{collect_pod} && length( $pod_data ) ) {
543           $pod{$pod_sect} = $pod_data;
544           $pod_data = '';
545         }
546         $pod_sect = $1;
547
548       } elsif ( $self->{collect_pod} ) {
549         $pod_data .= "$line\n";
550
551       }
552
553     } elsif ( $is_cut ) {
554
555       if ( $self->{collect_pod} && length( $pod_data ) ) {
556         $pod{$pod_sect} = $pod_data;
557         $pod_data = '';
558       }
559       $pod_sect = '';
560
561     } else {
562
563       # Skip comments in code
564       next if $line =~ /^\s*#/;
565
566       # Would be nice if we could also check $in_string or something too
567       last if $line =~ /^__(?:DATA|END)__$/;
568
569       # parse $line to see if it's a $VERSION declaration
570       my( $vers_sig, $vers_fullname, $vers_pkg ) =
571           ($line =~ /VERSION/)
572               ? $self->_parse_version_expression( $line )
573               : ();
574
575       if ( $line =~ /$PKG_REGEXP/o ) {
576         $pkg = $1;
577         push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
578         $vers{$pkg} = $2 unless exists( $vers{$pkg} );
579         $need_vers = defined $2 ? 0 : 1;
580
581       # VERSION defined with full package spec, i.e. $Module::VERSION
582       } elsif ( $vers_fullname && $vers_pkg ) {
583         push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
584         $need_vers = 0 if $vers_pkg eq $pkg;
585
586         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
587           $vers{$vers_pkg} =
588             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
589         }
590
591       # first non-comment line in undeclared package main is VERSION
592       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
593         $need_vers = 0;
594         my $v =
595           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
596         $vers{$pkg} = $v;
597         push( @pkgs, 'main' );
598
599       # first non-comment line in undeclared package defines package main
600       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
601         $need_vers = 1;
602         $vers{main} = '';
603         push( @pkgs, 'main' );
604
605       # only keep if this is the first $VERSION seen
606       } elsif ( $vers_fullname && $need_vers ) {
607         $need_vers = 0;
608         my $v =
609           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
610
611
612         unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
613           $vers{$pkg} = $v;
614         }
615
616       }
617
618     }
619
620   }
621
622   if ( $self->{collect_pod} && length($pod_data) ) {
623     $pod{$pod_sect} = $pod_data;
624   }
625
626   $self->{versions} = \%vers;
627   $self->{packages} = \@pkgs;
628   $self->{pod} = \%pod;
629   $self->{pod_headings} = \@pod;
630 }
631
632 {
633 my $pn = 0;
634 sub _evaluate_version_line {
635   my $self = shift;
636   my( $sigil, $var, $line ) = @_;
637
638   # Some of this code came from the ExtUtils:: hierarchy.
639
640   # We compile into $vsub because 'use version' would cause
641   # compiletime/runtime issues with local()
642   my $vsub;
643   $pn++; # everybody gets their own package
644   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
645     #; package Module::Metadata::_version::p$pn;
646     use version;
647     no strict;
648
649       \$vsub = sub {
650         local $sigil$var;
651         \$$var=undef;
652         $line;
653         \$$var
654       };
655   }};
656
657   local $^W;
658   # Try to get the $VERSION
659   eval $eval;
660   # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
661   # installed, so we need to hunt in ./lib for it
662   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
663     local @INC = ('lib',@INC);
664     eval $eval;
665   }
666   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
667     if $@;
668   (ref($vsub) eq 'CODE') or
669     croak "failed to build version sub for $self->{filename}";
670   my $result = eval { $vsub->() };
671   croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
672     if $@;
673
674   # Upgrade it into a version object
675   my $version = eval { _dwim_version($result) };
676
677   croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
678     unless defined $version; # "0" is OK!
679
680   return $version;
681 }
682 }
683
684 # Try to DWIM when things fail the lax version test in obvious ways
685 {
686   my @version_prep = (
687     # Best case, it just works
688     sub { return shift },
689
690     # If we still don't have a version, try stripping any
691     # trailing junk that is prohibited by lax rules
692     sub {
693       my $v = shift;
694       $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
695       return $v;
696     },
697
698     # Activestate apparently creates custom versions like '1.23_45_01', which
699     # cause version.pm to think it's an invalid alpha.  So check for that
700     # and strip them
701     sub {
702       my $v = shift;
703       my $num_dots = () = $v =~ m{(\.)}g;
704       my $num_unders = () = $v =~ m{(_)}g;
705       my $leading_v = substr($v,0,1) eq 'v';
706       if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
707         $v =~ s{_}{}g;
708         $num_unders = () = $v =~ m{(_)}g;
709       }
710       return $v;
711     },
712
713     # Worst case, try numifying it like we would have before version objects
714     sub {
715       my $v = shift;
716       no warnings 'numeric';
717       return 0 + $v;
718     },
719
720   );
721
722   sub _dwim_version {
723     my ($result) = shift;
724
725     return $result if ref($result) eq 'version';
726
727     my ($version, $error);
728     for my $f (@version_prep) {
729       $result = $f->($result);
730       $version = eval { version->new($result) };
731       $error ||= $@ if $@; # capture first failure
732       last if defined $version;
733     }
734
735     croak $error unless defined $version;
736
737     return $version;
738   }
739 }
740
741 ############################################################
742
743 # accessors
744 sub name            { $_[0]->{module}            }
745
746 sub filename        { $_[0]->{filename}          }
747 sub packages_inside { @{$_[0]->{packages}}       }
748 sub pod_inside      { @{$_[0]->{pod_headings}}   }
749 sub contains_pod    { 0+@{$_[0]->{pod_headings}} }
750
751 sub version {
752     my $self = shift;
753     my $mod  = shift || $self->{module};
754     my $vers;
755     if ( defined( $mod ) && length( $mod ) &&
756          exists( $self->{versions}{$mod} ) ) {
757         return $self->{versions}{$mod};
758     } else {
759         return undef;
760     }
761 }
762
763 sub pod {
764     my $self = shift;
765     my $sect = shift;
766     if ( defined( $sect ) && length( $sect ) &&
767          exists( $self->{pod}{$sect} ) ) {
768         return $self->{pod}{$sect};
769     } else {
770         return undef;
771     }
772 }
773
774 1;
775
776 =head1 NAME
777
778 Module::Metadata - Gather package and POD information from perl module files
779
780 =head1 SYNOPSIS
781
782   use Module::Metadata;
783
784   # information about a .pm file
785   my $info = Module::Metadata->new_from_file( $file );
786   my $version = $info->version;
787
788   # CPAN META 'provides' field for .pm files in a directory
789   my $provides = Module::Metadata->provides(
790     dir => 'lib', version => 2
791   );
792
793 =head1 DESCRIPTION
794
795 This module provides a standard way to gather metadata about a .pm file
796 without executing unsafe code.
797
798 =head1 USAGE
799
800 =head2 Class methods
801
802 =over 4
803
804 =item C<< new_from_file($filename, collect_pod => 1) >>
805
806 Constructs a C<Module::Metadata> object given the path to a file.  Returns
807 undef if the filename does not exist.
808
809 C<collect_pod> is a optional boolean argument that determines whether POD
810 data is collected and stored for reference.  POD data is not collected by
811 default.  POD headings are always collected.
812
813 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
814 it is skipped before processing, and the content of the file is also decoded
815 appropriately starting from perl 5.8.
816
817 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
818
819 This works just like C<new_from_file>, except that a handle can be provided
820 as the first argument.
821
822 Note that there is no validation to confirm that the handle is a handle or
823 something that can act like one.  Passing something that isn't a handle will
824 cause a exception when trying to read from it.  The C<filename> argument is
825 mandatory or undef will be returned.
826
827 You are responsible for setting the decoding layers on C<$handle> if
828 required.
829
830 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
831
832 Constructs a C<Module::Metadata> object given a module or package name.
833 Returns undef if the module cannot be found.
834
835 In addition to accepting the C<collect_pod> argument as described above,
836 this method accepts a C<inc> argument which is a reference to an array of
837 directories to search for the module.  If none are given, the default is
838 @INC.
839
840 If the file that contains the module begins by an UTF-8, UTF-16BE or
841 UTF-16LE byte-order mark, then it is skipped before processing, and the
842 content of the file is also decoded appropriately starting from perl 5.8.
843
844 =item C<< find_module_by_name($module, \@dirs) >>
845
846 Returns the path to a module given the module or package name. A list
847 of directories can be passed in as an optional parameter, otherwise
848 @INC is searched.
849
850 Can be called as either an object or a class method.
851
852 =item C<< find_module_dir_by_name($module, \@dirs) >>
853
854 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
855 the module C<$module>. A list of directories can be passed in as an
856 optional parameter, otherwise @INC is searched.
857
858 Can be called as either an object or a class method.
859
860 =item C<< provides( %options ) >>
861
862 This is a convenience wrapper around C<package_versions_from_directory>
863 to generate a CPAN META C<provides> data structure.  It takes key/value
864 pairs.  Valid option keys include:
865
866 =over
867
868 =item version B<(required)>
869
870 Specifies which version of the L<CPAN::Meta::Spec> should be used as
871 the format of the C<provides> output.  Currently only '1.4' and '2'
872 are supported (and their format is identical).  This may change in
873 the future as the definition of C<provides> changes.
874
875 The C<version> option is required.  If it is omitted or if
876 an unsupported version is given, then C<provides> will throw an error.
877
878 =item dir
879
880 Directory to search recursively for F<.pm> files.  May not be specified with
881 C<files>.
882
883 =item files
884
885 Array reference of files to examine.  May not be specified with C<dir>.
886
887 =item prefix
888
889 String to prepend to the C<file> field of the resulting output. This defaults
890 to F<lib>, which is the common case for most CPAN distributions with their
891 F<.pm> files in F<lib>.  This option ensures the META information has the
892 correct relative path even when the C<dir> or C<files> arguments are
893 absolute or have relative paths from a location other than the distribution
894 root.
895
896 =back
897
898 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
899 is a hashref of the form:
900
901   {
902     'Package::Name' => {
903       version => '0.123',
904       file => 'lib/Package/Name.pm'
905     },
906     'OtherPackage::Name' => ...
907   }
908
909 =item C<< package_versions_from_directory($dir, \@files?) >>
910
911 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
912 for those files in C<$dir> - and reads each file for packages and versions,
913 returning a hashref of the form:
914
915   {
916     'Package::Name' => {
917       version => '0.123',
918       file => 'Package/Name.pm'
919     },
920     'OtherPackage::Name' => ...
921   }
922
923 The C<DB> and C<main> packages are always omitted, as are any "private"
924 packages that have leading underscores in the namespace (e.g.
925 C<Foo::_private>)
926
927 Note that the file path is relative to C<$dir> if that is specified.
928 This B<must not> be used directly for CPAN META C<provides>.  See
929 the C<provides> method instead.
930
931 =item C<< log_info (internal) >>
932
933 Used internally to perform logging; imported from Log::Contextual if
934 Log::Contextual has already been loaded, otherwise simply calls warn.
935
936 =back
937
938 =head2 Object methods
939
940 =over 4
941
942 =item C<< name() >>
943
944 Returns the name of the package represented by this module. If there
945 are more than one packages, it makes a best guess based on the
946 filename. If it's a script (i.e. not a *.pm) the package name is
947 'main'.
948
949 =item C<< version($package) >>
950
951 Returns the version as defined by the $VERSION variable for the
952 package as returned by the C<name> method if no arguments are
953 given. If given the name of a package it will attempt to return the
954 version of that package if it is specified in the file.
955
956 =item C<< filename() >>
957
958 Returns the absolute path to the file.
959
960 =item C<< packages_inside() >>
961
962 Returns a list of packages. Note: this is a raw list of packages
963 discovered (or assumed, in the case of C<main>).  It is not
964 filtered for C<DB>, C<main> or private packages the way the
965 C<provides> method does.  Invalid package names are not returned,
966 for example "Foo:Bar".  Strange but valid package names are
967 returned, for example "Foo::Bar::", and are left up to the caller
968 on how to handle.
969
970 =item C<< pod_inside() >>
971
972 Returns a list of POD sections.
973
974 =item C<< contains_pod() >>
975
976 Returns true if there is any POD in the file.
977
978 =item C<< pod($section) >>
979
980 Returns the POD data in the given section.
981
982 =back
983
984 =head1 AUTHOR
985
986 Original code from Module::Build::ModuleInfo by Ken Williams
987 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
988
989 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
990 assistance from David Golden (xdg) <dagolden@cpan.org>.
991
992 =head1 COPYRIGHT & LICENSE
993
994 Original code Copyright (c) 2001-2011 Ken Williams.
995 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
996 All rights reserved.
997
998 This library is free software; you can redistribute it and/or
999 modify it under the same terms as Perl itself.
1000
1001 =cut
1002