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