lib/Module/Metadata.pm

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