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