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