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 aristotle
  51   $PKG_FIRST_WORD_REGEXP  # a package word
  52   (?:
  53     (?: :: )+             ### aristotle (allow one or many times)
  54     $PKG_ADDL_WORD_REGEXP ### a package word
  55   )*                      # ^ zero, one or many times
  56   (?:
  57     ::                    # allow trailing aristotle
  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 ( $handle ) {
 387     $self->_parse_fh($handle);
 388   }
 389   else {
 390     $self->_parse_file();
 391   }
 392
 393   unless($self->{module} and length($self->{module})) {
 394     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
 395     if($f =~ /\.pm$/) {
 396       $f =~ s/\..+$//;
 397       my @candidates = grep /$f$/, @{$self->{packages}};
 398       $self->{module} = shift(@candidates); # punt
 399     }
 400     else {
 401       if(grep /main/, @{$self->{packages}}) {
 402         $self->{module} = 'main';
 403       }
 404       else {
 405         $self->{module} = $self->{packages}[0] || '';
 406       }
 407     }
 408   }
 409
 410   $self->{version} = $self->{versions}{$self->{module}}
 411       if defined( $self->{module} );
 412
 413   return $self;
 414 }
 415
 416 # class method
 417 sub _do_find_module {
 418   my $class   = shift;
 419   my $module  = shift || croak 'find_module_by_name() requires a package name';
 420   my $dirs    = shift || \@INC;
 421
 422   my $file = File::Spec->catfile(split( /::/, $module));
 423   foreach my $dir ( @$dirs ) {
 424     my $testfile = File::Spec->catfile($dir, $file);
 425     return [ File::Spec->rel2abs( $testfile ), $dir ]
 426         if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
 427     return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
 428         if -e "$testfile.pm";
 429   }
 430   return;
 431 }
 432
 433 # class method
 434 sub find_module_by_name {
 435   my $found = shift()->_do_find_module(@_) or return;
 436   return $found->[0];
 437 }
 438
 439 # class method
 440 sub find_module_dir_by_name {
 441   my $found = shift()->_do_find_module(@_) or return;
 442   return $found->[1];
 443 }
 444
 445
 446 # given a line of perl code, attempt to parse it if it looks like a
 447 # $VERSION assignment, returning sigil, full name, & package name
 448 sub _parse_version_expression {
 449   my $self = shift;
 450   my $line = shift;
 451
 452   my( $sig, $var, $pkg );
 453   if ( $line =~ /$VERS_REGEXP/o ) {
 454     ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
 455     if ( $pkg ) {
 456       $pkg = ($pkg eq '::') ? 'main' : $pkg;
 457       $pkg =~ s/::$//;
 458     }
 459   }
 460
 461   return ( $sig, $var, $pkg );
 462 }
 463
 464 sub _parse_file {
 465   my $self = shift;
 466
 467   my $filename = $self->{filename};
 468   my $fh = IO::File->new( $filename )
 469     or croak( "Can't open '$filename': $!" );
 470
 471   $self->_handle_bom($fh, $filename);
 472
 473   $self->_parse_fh($fh);
 474 }
 475
 476 # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
 477 # If there's one, then skip it and set the :encoding layer appropriately.
 478 sub _handle_bom {
 479   my ($self, $fh, $filename) = @_;
 480
 481   my $pos = $fh->getpos;
 482   return unless defined $pos;
 483
 484   my $buf = ' ' x 2;
 485   my $count = $fh->read( $buf, length $buf );
 486   return unless defined $count and $count >= 2;
 487
 488   my $encoding;
 489   if ( $buf eq "\x{FE}\x{FF}" ) {
 490     $encoding = 'UTF-16BE';
 491   } elsif ( $buf eq "\x{FF}\x{FE}" ) {
 492     $encoding = 'UTF-16LE';
 493   } elsif ( $buf eq "\x{EF}\x{BB}" ) {
 494     $buf = ' ';
 495     $count = $fh->read( $buf, length $buf );
 496     if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
 497       $encoding = 'UTF-8';
 498     }
 499   }
 500
 501   if ( defined $encoding ) {
 502     if ( "$]" >= 5.008 ) {
 503       # $fh->binmode requires perl 5.10
 504       binmode( $fh, ":encoding($encoding)" );
 505     }
 506   } else {
 507     $fh->setpos($pos)
 508       or croak( sprintf "Can't reset position to the top of '$filename'" );
 509   }
 510
 511   return $encoding;
 512 }
 513
 514 sub _parse_fh {
 515   my ($self, $fh) = @_;
 516
 517   my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
 518   my( @pkgs, %vers, %pod, @pod );
 519   my $pkg = 'main';
 520   my $pod_sect = '';
 521   my $pod_data = '';
 522   my $in_end = 0;
 523
 524   while (defined( my $line = <$fh> )) {
 525     my $line_num = $.;
 526
 527     chomp( $line );
 528
 529     # From toke.c : any line that begins by "=X", where X is an alphabetic
 530     # character, introduces a POD segment.
 531     my $is_cut;
 532     if ( $line =~ /^=([a-zA-Z].*)/ ) {
 533       my $cmd = $1;
 534       # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
 535       # character (which includes the newline, but here we chomped it away).
 536       $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
 537       $in_pod = !$is_cut;
 538     }
 539
 540     if ( $in_pod ) {
 541
 542       if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
 543         push( @pod, $1 );
 544         if ( $self->{collect_pod} && length( $pod_data ) ) {
 545           $pod{$pod_sect} = $pod_data;
 546           $pod_data = '';
 547         }
 548         $pod_sect = $1;
 549
 550       } elsif ( $self->{collect_pod} ) {
 551         $pod_data .= "$line\n";
 552
 553       }
 554
 555     } elsif ( $is_cut ) {
 556
 557       if ( $self->{collect_pod} && length( $pod_data ) ) {
 558         $pod{$pod_sect} = $pod_data;
 559         $pod_data = '';
 560       }
 561       $pod_sect = '';
 562
 563     } else {
 564
 565       # Skip after __END__
 566       next if $in_end;
 567
 568       # Skip comments in code
 569       next if $line =~ /^\s*#/;
 570
 571       # Would be nice if we could also check $in_string or something too
 572       if ($line eq '__END__') {
 573         $in_end++;
 574         next;
 575       }
 576       last if $line eq '__DATA__';
 577
 578       # parse $line to see if it's a $VERSION declaration
 579       my( $vers_sig, $vers_fullname, $vers_pkg ) =
 580           ($line =~ /VERSION/)
 581               ? $self->_parse_version_expression( $line )
 582               : ();
 583
 584       if ( $line =~ /$PKG_REGEXP/o ) {
 585         $pkg = $1;
 586         push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
 587         $vers{$pkg} = $2 unless exists( $vers{$pkg} );
 588         $need_vers = defined $2 ? 0 : 1;
 589
 590       # VERSION defined with full package spec, i.e. $Module::VERSION
 591       } elsif ( $vers_fullname && $vers_pkg ) {
 592         push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
 593         $need_vers = 0 if $vers_pkg eq $pkg;
 594
 595         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
 596           $vers{$vers_pkg} =
 597             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 598         }
 599
 600       # first non-comment line in undeclared package main is VERSION
 601       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
 602         $need_vers = 0;
 603         my $v =
 604           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 605         $vers{$pkg} = $v;
 606         push( @pkgs, 'main' );
 607
 608       # first non-comment line in undeclared package defines package main
 609       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
 610         $need_vers = 1;
 611         $vers{main} = '';
 612         push( @pkgs, 'main' );
 613
 614       # only keep if this is the first $VERSION seen
 615       } elsif ( $vers_fullname && $need_vers ) {
 616         $need_vers = 0;
 617         my $v =
 618           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 619
 620
 621         unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
 622           $vers{$pkg} = $v;
 623         }
 624
 625       }
 626
 627     }
 628
 629   }
 630
 631   if ( $self->{collect_pod} && length($pod_data) ) {
 632     $pod{$pod_sect} = $pod_data;
 633   }
 634
 635   $self->{versions} = \%vers;
 636   $self->{packages} = \@pkgs;
 637   $self->{pod} = \%pod;
 638   $self->{pod_headings} = \@pod;
 639 }
 640
 641 {
 642 my $pn = 0;
 643 sub _evaluate_version_line {
 644   my $self = shift;
 645   my( $sigil, $var, $line ) = @_;
 646
 647   # Some of this code came from the ExtUtils:: hierarchy.
 648
 649   # We compile into $vsub because 'use version' would cause
 650   # compiletime/runtime issues with local()
 651   my $vsub;
 652   $pn++; # everybody gets their own package
 653   my $eval = qq{BEGIN { my \$dummy = q#  Hide from _packages_inside()
 654     #; package Module::Metadata::_version::p$pn;
 655     use version;
 656     no strict;
 657     no warnings;
 658
 659       \$vsub = sub {
 660         local $sigil$var;
 661         \$$var=undef;
 662         $line;
 663         \$$var
 664       };
 665   }};
 666
 667   $eval = $1 if $eval =~ m{^(.+)}s;
 668
 669   local $^W;
 670   # Try to get the $VERSION
 671   eval $eval;
 672   # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
 673   # installed, so we need to hunt in ./lib for it
 674   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
 675     local @INC = ('lib',@INC);
 676     eval $eval;
 677   }
 678   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
 679     if $@;
 680   (ref($vsub) eq 'CODE') or
 681     croak "failed to build version sub for $self->{filename}";
 682   my $result = eval { $vsub->() };
 683   croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
 684     if $@;
 685
 686   # Upgrade it into a version object
 687   my $version = eval { _dwim_version($result) };
 688
 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