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