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