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