lib/Module/Metadata.pm

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