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