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.000013';
  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   my $in_end = 0;
 522
 523   while (defined( my $line = <$fh> )) {
 524     my $line_num = $.;
 525
 526     chomp( $line );
 527
 528     # From toke.c : any line that begins by "=X", where X is an alphabetic
 529     # character, introduces a POD segment.
 530     my $is_cut;
 531     if ( $line =~ /^=([a-zA-Z].*)/ ) {
 532       my $cmd = $1;
 533       # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
 534       # character (which includes the newline, but here we chomped it away).
 535       $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
 536       $in_pod = !$is_cut;
 537     }
 538
 539     if ( $in_pod ) {
 540
 541       if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
 542         push( @pod, $1 );
 543         if ( $self->{collect_pod} && length( $pod_data ) ) {
 544           $pod{$pod_sect} = $pod_data;
 545           $pod_data = '';
 546         }
 547         $pod_sect = $1;
 548
 549       } elsif ( $self->{collect_pod} ) {
 550         $pod_data .= "$line\n";
 551
 552       }
 553
 554     } elsif ( $is_cut ) {
 555
 556       if ( $self->{collect_pod} && length( $pod_data ) ) {
 557         $pod{$pod_sect} = $pod_data;
 558         $pod_data = '';
 559       }
 560       $pod_sect = '';
 561
 562     } else {
 563
 564       # Skip after __END__
 565       next if $in_end;
 566
 567       # Skip comments in code
 568       next if $line =~ /^\s*#/;
 569
 570       # Would be nice if we could also check $in_string or something too
 571       if ($line eq '__END__') {
 572         $in_end++;
 573         next;
 574       }
 575       last if $line eq '__DATA__';
 576
 577       # parse $line to see if it's a $VERSION declaration
 578       my( $vers_sig, $vers_fullname, $vers_pkg ) =
 579           ($line =~ /VERSION/)
 580               ? $self->_parse_version_expression( $line )
 581               : ();
 582
 583       if ( $line =~ /$PKG_REGEXP/o ) {
 584         $pkg = $1;
 585         push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
 586         $vers{$pkg} = $2 unless exists( $vers{$pkg} );
 587         $need_vers = defined $2 ? 0 : 1;
 588
 589       # VERSION defined with full package spec, i.e. $Module::VERSION
 590       } elsif ( $vers_fullname && $vers_pkg ) {
 591         push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
 592         $need_vers = 0 if $vers_pkg eq $pkg;
 593
 594         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
 595           $vers{$vers_pkg} =
 596             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 597         }
 598
 599       # first non-comment line in undeclared package main is VERSION
 600       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
 601         $need_vers = 0;
 602         my $v =
 603           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 604         $vers{$pkg} = $v;
 605         push( @pkgs, 'main' );
 606
 607       # first non-comment line in undeclared package defines package main
 608       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
 609         $need_vers = 1;
 610         $vers{main} = '';
 611         push( @pkgs, 'main' );
 612
 613       # only keep if this is the first $VERSION seen
 614       } elsif ( $vers_fullname && $need_vers ) {
 615         $need_vers = 0;
 616         my $v =
 617           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 618
 619
 620         unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
 621           $vers{$pkg} = $v;
 622         }
 623
 624       }
 625
 626     }
 627
 628   }
 629
 630   if ( $self->{collect_pod} && length($pod_data) ) {
 631     $pod{$pod_sect} = $pod_data;
 632   }
 633
 634   $self->{versions} = \%vers;
 635   $self->{packages} = \@pkgs;
 636   $self->{pod} = \%pod;
 637   $self->{pod_headings} = \@pod;
 638 }
 639
 640 {
 641 my $pn = 0;
 642 sub _evaluate_version_line {
 643   my $self = shift;
 644   my( $sigil, $var, $line ) = @_;
 645
 646   # Some of this code came from the ExtUtils:: hierarchy.
 647
 648   # We compile into $vsub because 'use version' would cause
 649   # compiletime/runtime issues with local()
 650   my $vsub;
 651   $pn++; # everybody gets their own package
 652   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
 653     #; package Module::Metadata::_version::p$pn;
 654     use version;
 655     no strict;
 656
 657       \$vsub = sub {
 658         local $sigil$var;
 659         \$$var=undef;
 660         $line;
 661         \$$var
 662       };
 663   }};
 664
 665   local $^W;
 666   # Try to get the $VERSION
 667   eval $eval;
 668   # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
 669   # installed, so we need to hunt in ./lib for it
 670   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
 671     local @INC = ('lib',@INC);
 672     eval $eval;
 673   }
 674   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
 675     if $@;
 676   (ref($vsub) eq 'CODE') or
 677     croak "failed to build version sub for $self->{filename}";
 678   my $result = eval { $vsub->() };
 679   croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
 680     if $@;
 681
 682   # Upgrade it into a version object
 683   my $version = eval { _dwim_version($result) };
 684
 685   croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
 686     unless defined $version; # "0" is OK!
 687
 688   return $version;
 689 }
 690 }
 691
 692 # Try to DWIM when things fail the lax version test in obvious ways
 693 {
 694   my @version_prep = (
 695     # Best case, it just works
 696     sub { return shift },
 697
 698     # If we still don't have a version, try stripping any
 699     # trailing junk that is prohibited by lax rules
 700     sub {
 701       my $v = shift;
 702       $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
 703       return $v;
 704     },
 705
 706     # Activestate apparently creates custom versions like '1.23_45_01', which
 707     # cause version.pm to think it's an invalid alpha.  So check for that
 708     # and strip them
 709     sub {
 710       my $v = shift;
 711       my $num_dots = () = $v =~ m{(\.)}g;
 712       my $num_unders = () = $v =~ m{(_)}g;
 713       my $leading_v = substr($v,0,1) eq 'v';
 714       if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
 715         $v =~ s{_}{}g;
 716         $num_unders = () = $v =~ m{(_)}g;
 717       }
 718       return $v;
 719     },
 720
 721     # Worst case, try numifying it like we would have before version objects
 722     sub {
 723       my $v = shift;
 724       no warnings 'numeric';
 725       return 0 + $v;
 726     },
 727
 728   );
 729
 730   sub _dwim_version {
 731     my ($result) = shift;
 732
 733     return $result if ref($result) eq 'version';
 734
 735     my ($version, $error);
 736     for my $f (@version_prep) {
 737       $result = $f->($result);
 738       $version = eval { version->new($result) };
 739       $error ||= $@ if $@; # capture first failure
 740       last if defined $version;
 741     }
 742
 743     croak $error unless defined $version;
 744
 745     return $version;
 746   }
 747 }
 748
 749 ############################################################
 750
 751 # accessors
 752 sub name            { $_[0]->{module}            }
 753
 754 sub filename        { $_[0]->{filename}          }
 755 sub packages_inside { @{$_[0]->{packages}}       }
 756 sub pod_inside      { @{$_[0]->{pod_headings}}   }
 757 sub contains_pod    { 0+@{$_[0]->{pod_headings}} }
 758
 759 sub version {
 760     my $self = shift;
 761     my $mod  = shift || $self->{module};
 762     my $vers;
 763     if ( defined( $mod ) && length( $mod ) &&
 764          exists( $self->{versions}{$mod} ) ) {
 765         return $self->{versions}{$mod};
 766     } else {
 767         return undef;
 768     }
 769 }
 770
 771 sub pod {
 772     my $self = shift;
 773     my $sect = shift;
 774     if ( defined( $sect ) && length( $sect ) &&
 775          exists( $self->{pod}{$sect} ) ) {
 776         return $self->{pod}{$sect};
 777     } else {
 778         return undef;
 779     }
 780 }
 781
 782 1;
 783
 784 =head1 NAME
 785
 786 Module::Metadata - Gather package and POD information from perl module files
 787
 788 =head1 SYNOPSIS
 789
 790   use Module::Metadata;
 791
 792   # information about a .pm file
 793   my $info = Module::Metadata->new_from_file( $file );
 794   my $version = $info->version;
 795
 796   # CPAN META 'provides' field for .pm files in a directory
 797   my $provides = Module::Metadata->provides(
 798     dir => 'lib', version => 2
 799   );
 800
 801 =head1 DESCRIPTION
 802
 803 This module provides a standard way to gather metadata about a .pm file
 804 without executing unsafe code.
 805
 806 =head1 USAGE
 807
 808 =head2 Class methods
 809
 810 =over 4
 811
 812 =item C<< new_from_file($filename, collect_pod => 1) >>
 813
 814 Constructs a C<Module::Metadata> object given the path to a file.  Returns
 815 undef if the filename does not exist.
 816
 817 C<collect_pod> is a optional boolean argument that determines whether POD
 818 data is collected and stored for reference.  POD data is not collected by
 819 default.  POD headings are always collected.
 820
 821 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
 822 it is skipped before processing, and the content of the file is also decoded
 823 appropriately starting from perl 5.8.
 824
 825 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
 826
 827 This works just like C<new_from_file>, except that a handle can be provided
 828 as the first argument.
 829
 830 Note that there is no validation to confirm that the handle is a handle or
 831 something that can act like one.  Passing something that isn't a handle will
 832 cause a exception when trying to read from it.  The C<filename> argument is
 833 mandatory or undef will be returned.
 834
 835 You are responsible for setting the decoding layers on C<$handle> if
 836 required.
 837
 838 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
 839
 840 Constructs a C<Module::Metadata> object given a module or package name.
 841 Returns undef if the module cannot be found.
 842
 843 In addition to accepting the C<collect_pod> argument as described above,
 844 this method accepts a C<inc> argument which is a reference to an array of
 845 directories to search for the module.  If none are given, the default is
 846 @INC.
 847
 848 If the file that contains the module begins by an UTF-8, UTF-16BE or
 849 UTF-16LE byte-order mark, then it is skipped before processing, and the
 850 content of the file is also decoded appropriately starting from perl 5.8.
 851
 852 =item C<< find_module_by_name($module, \@dirs) >>
 853
 854 Returns the path to a module given the module or package name. A list
 855 of directories can be passed in as an optional parameter, otherwise
 856 @INC is searched.
 857
 858 Can be called as either an object or a class method.
 859
 860 =item C<< find_module_dir_by_name($module, \@dirs) >>
 861
 862 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
 863 the module C<$module>. A list of directories can be passed in as an
 864 optional parameter, otherwise @INC is searched.
 865
 866 Can be called as either an object or a class method.
 867
 868 =item C<< provides( %options ) >>
 869
 870 This is a convenience wrapper around C<package_versions_from_directory>
 871 to generate a CPAN META C<provides> data structure.  It takes key/value
 872 pairs.  Valid option keys include:
 873
 874 =over
 875
 876 =item version B<(required)>
 877
 878 Specifies which version of the L<CPAN::Meta::Spec> should be used as
 879 the format of the C<provides> output.  Currently only '1.4' and '2'
 880 are supported (and their format is identical).  This may change in
 881 the future as the definition of C<provides> changes.
 882
 883 The C<version> option is required.  If it is omitted or if
 884 an unsupported version is given, then C<provides> will throw an error.
 885
 886 =item dir
 887
 888 Directory to search recursively for F<.pm> files.  May not be specified with
 889 C<files>.
 890
 891 =item files
 892
 893 Array reference of files to examine.  May not be specified with C<dir>.
 894
 895 =item prefix
 896
 897 String to prepend to the C<file> field of the resulting output. This defaults
 898 to F<lib>, which is the common case for most CPAN distributions with their
 899 F<.pm> files in F<lib>.  This option ensures the META information has the
 900 correct relative path even when the C<dir> or C<files> arguments are
 901 absolute or have relative paths from a location other than the distribution
 902 root.
 903
 904 =back
 905
 906 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
 907 is a hashref of the form:
 908
 909   {
 910     'Package::Name' => {
 911       version => '0.123',
 912       file => 'lib/Package/Name.pm'
 913     },
 914     'OtherPackage::Name' => ...
 915   }
 916
 917 =item C<< package_versions_from_directory($dir, \@files?) >>
 918
 919 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
 920 for those files in C<$dir> - and reads each file for packages and versions,
 921 returning a hashref of the form:
 922
 923   {
 924     'Package::Name' => {
 925       version => '0.123',
 926       file => 'Package/Name.pm'
 927     },
 928     'OtherPackage::Name' => ...
 929   }
 930
 931 The C<DB> and C<main> packages are always omitted, as are any "private"
 932 packages that have leading underscores in the namespace (e.g.
 933 C<Foo::_private>)
 934
 935 Note that the file path is relative to C<$dir> if that is specified.
 936 This B<must not> be used directly for CPAN META C<provides>.  See
 937 the C<provides> method instead.
 938
 939 =item C<< log_info (internal) >>
 940
 941 Used internally to perform logging; imported from Log::Contextual if
 942 Log::Contextual has already been loaded, otherwise simply calls warn.
 943
 944 =back
 945
 946 =head2 Object methods
 947
 948 =over 4
 949
 950 =item C<< name() >>
 951
 952 Returns the name of the package represented by this module. If there
 953 are more than one packages, it makes a best guess based on the
 954 filename. If it's a script (i.e. not a *.pm) the package name is
 955 'main'.
 956
 957 =item C<< version($package) >>
 958
 959 Returns the version as defined by the $VERSION variable for the
 960 package as returned by the C<name> method if no arguments are
 961 given. If given the name of a package it will attempt to return the
 962 version of that package if it is specified in the file.
 963
 964 =item C<< filename() >>
 965
 966 Returns the absolute path to the file.
 967
 968 =item C<< packages_inside() >>
 969
 970 Returns a list of packages. Note: this is a raw list of packages
 971 discovered (or assumed, in the case of C<main>).  It is not
 972 filtered for C<DB>, C<main> or private packages the way the
 973 C<provides> method does.  Invalid package names are not returned,
 974 for example "Foo:Bar".  Strange but valid package names are
 975 returned, for example "Foo::Bar::", and are left up to the caller
 976 on how to handle.
 977
 978 =item C<< pod_inside() >>
 979
 980 Returns a list of POD sections.
 981
 982 =item C<< contains_pod() >>
 983
 984 Returns true if there is any POD in the file.
 985
 986 =item C<< pod($section) >>
 987
 988 Returns the POD data in the given section.
 989
 990 =back
 991
 992 =head1 AUTHOR
 993
 994 Original code from Module::Build::ModuleInfo by Ken Williams
 995 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
 996
 997 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
 998 assistance from David Golden (xdg) <dagolden@cpan.org>.
 999
1000 =head1 COPYRIGHT & LICENSE
1001
1002 Original code Copyright (c) 2001-2011 Ken Williams.
1003 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
1004 All rights reserved.
1005
1006 This library is free software; you can redistribute it and/or
1007 modify it under the same terms as Perl itself.
1008
1009 =cut
1010