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