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