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