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.000010_001';
  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         } else {
 587           warn <<"EOM";
 588 Package '$pkg' already declared with version '$vers{$pkg}'
 589 ignoring new version '$v' on line $line_num.
 590 EOM
 591         }
 592
 593       }
 594
 595     }
 596
 597   }
 598
 599   if ( $self->{collect_pod} && length($pod_data) ) {
 600     $pod{$pod_sect} = $pod_data;
 601   }
 602
 603   $self->{versions} = \%vers;
 604   $self->{packages} = \@pkgs;
 605   $self->{pod} = \%pod;
 606   $self->{pod_headings} = \@pod;
 607 }
 608
 609 {
 610 my $pn = 0;
 611 sub _evaluate_version_line {
 612   my $self = shift;
 613   my( $sigil, $var, $line ) = @_;
 614
 615   # Some of this code came from the ExtUtils:: hierarchy.
 616
 617   # We compile into $vsub because 'use version' would cause
 618   # compiletime/runtime issues with local()
 619   my $vsub;
 620   $pn++; # everybody gets their own package
 621   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
 622     #; package Module::Metadata::_version::p$pn;
 623     use version;
 624     no strict;
 625
 626       \$vsub = sub {
 627         local $sigil$var;
 628         \$$var=undef;
 629         $line;
 630         \$$var
 631       };
 632   }};
 633
 634   local $^W;
 635   # Try to get the $VERSION
 636   eval $eval;
 637   # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
 638   # installed, so we need to hunt in ./lib for it
 639   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
 640     local @INC = ('lib',@INC);
 641     eval $eval;
 642   }
 643   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
 644     if $@;
 645   (ref($vsub) eq 'CODE') or
 646     croak "failed to build version sub for $self->{filename}";
 647   my $result = eval { $vsub->() };
 648   croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
 649     if $@;
 650
 651   # Upgrade it into a version object
 652   my $version = eval { _dwim_version($result) };
 653
 654   croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
 655     unless defined $version; # "0" is OK!
 656
 657   return $version;
 658 }
 659 }
 660
 661 # Try to DWIM when things fail the lax version test in obvious ways
 662 {
 663   my @version_prep = (
 664     # Best case, it just works
 665     sub { return shift },
 666
 667     # If we still don't have a version, try stripping any
 668     # trailing junk that is prohibited by lax rules
 669     sub {
 670       my $v = shift;
 671       $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
 672       return $v;
 673     },
 674
 675     # Activestate apparently creates custom versions like '1.23_45_01', which
 676     # cause version.pm to think it's an invalid alpha.  So check for that
 677     # and strip them
 678     sub {
 679       my $v = shift;
 680       my $num_dots = () = $v =~ m{(\.)}g;
 681       my $num_unders = () = $v =~ m{(_)}g;
 682       my $leading_v = substr($v,0,1) eq 'v';
 683       if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
 684         $v =~ s{_}{}g;
 685         $num_unders = () = $v =~ m{(_)}g;
 686       }
 687       return $v;
 688     },
 689
 690     # Worst case, try numifying it like we would have before version objects
 691     sub {
 692       my $v = shift;
 693       no warnings 'numeric';
 694       return 0 + $v;
 695     },
 696
 697   );
 698
 699   sub _dwim_version {
 700     my ($result) = shift;
 701
 702     return $result if ref($result) eq 'version';
 703
 704     my ($version, $error);
 705     for my $f (@version_prep) {
 706       $result = $f->($result);
 707       $version = eval { version->new($result) };
 708       $error ||= $@ if $@; # capture first failure
 709       last if defined $version;
 710     }
 711
 712     croak $error unless defined $version;
 713
 714     return $version;
 715   }
 716 }
 717
 718 ############################################################
 719
 720 # accessors
 721 sub name            { $_[0]->{module}           }
 722
 723 sub filename        { $_[0]->{filename}         }
 724 sub packages_inside { @{$_[0]->{packages}}      }
 725 sub pod_inside      { @{$_[0]->{pod_headings}}  }
 726 sub contains_pod    { $#{$_[0]->{pod_headings}} }
 727
 728 sub version {
 729     my $self = shift;
 730     my $mod  = shift || $self->{module};
 731     my $vers;
 732     if ( defined( $mod ) && length( $mod ) &&
 733          exists( $self->{versions}{$mod} ) ) {
 734         return $self->{versions}{$mod};
 735     } else {
 736         return undef;
 737     }
 738 }
 739
 740 sub pod {
 741     my $self = shift;
 742     my $sect = shift;
 743     if ( defined( $sect ) && length( $sect ) &&
 744          exists( $self->{pod}{$sect} ) ) {
 745         return $self->{pod}{$sect};
 746     } else {
 747         return undef;
 748     }
 749 }
 750
 751 1;
 752
 753 =head1 NAME
 754
 755 Module::Metadata - Gather package and POD information from perl module files
 756
 757 =head1 SYNOPSIS
 758
 759   use Module::Metadata;
 760
 761   # information about a .pm file
 762   my $info = Module::Metadata->new_from_file( $file );
 763   my $version = $info->version;
 764
 765   # CPAN META 'provides' field for .pm files in a directory
 766   my $provides = Module::Metadata->provides(
 767     dir => 'lib', version => 2
 768   );
 769
 770 =head1 DESCRIPTION
 771
 772 This module provides a standard way to gather metadata about a .pm file
 773 without executing unsafe code.
 774
 775 =head1 USAGE
 776
 777 =head2 Class methods
 778
 779 =over 4
 780
 781 =item C<< new_from_file($filename, collect_pod => 1) >>
 782
 783 Constructs a C<Module::Metadata> object given the path to a file.  Returns
 784 undef if the filename does not exist.
 785
 786 C<collect_pod> is a optional boolean argument that determines whether POD
 787 data is collected and stored for reference.  POD data is not collected by
 788 default.  POD headings are always collected.
 789
 790 If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
 791 it is skipped before processing, and the content of the file is also decoded
 792 appropriately starting from perl 5.8.
 793
 794 =item C<< new_from_handle($handle, $filename, collect_pod => 1) >>
 795
 796 This works just like C<new_from_file>, except that a handle can be provided
 797 as the first argument.
 798
 799 Note that there is no validation to confirm that the handle is a handle or
 800 something that can act like one.  Passing something that isn't a handle will
 801 cause a exception when trying to read from it.  The C<filename> argument is
 802 mandatory or undef will be returned.
 803
 804 You are responsible for setting the decoding layers on C<$handle> if
 805 required.
 806
 807 =item C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
 808
 809 Constructs a C<Module::Metadata> object given a module or package name.
 810 Returns undef if the module cannot be found.
 811
 812 In addition to accepting the C<collect_pod> argument as described above,
 813 this method accepts a C<inc> argument which is a reference to an array of
 814 directories to search for the module.  If none are given, the default is
 815 @INC.
 816
 817 If the file that contains the module begins by an UTF-8, UTF-16BE or
 818 UTF-16LE byte-order mark, then it is skipped before processing, and the
 819 content of the file is also decoded appropriately starting from perl 5.8.
 820
 821 =item C<< find_module_by_name($module, \@dirs) >>
 822
 823 Returns the path to a module given the module or package name. A list
 824 of directories can be passed in as an optional parameter, otherwise
 825 @INC is searched.
 826
 827 Can be called as either an object or a class method.
 828
 829 =item C<< find_module_dir_by_name($module, \@dirs) >>
 830
 831 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
 832 the module C<$module>. A list of directories can be passed in as an
 833 optional parameter, otherwise @INC is searched.
 834
 835 Can be called as either an object or a class method.
 836
 837 =item C<< provides( %options ) >>
 838
 839 This is a convenience wrapper around C<package_versions_from_directory>
 840 to generate a CPAN META C<provides> data structure.  It takes key/value
 841 pairs.  Valid option keys include:
 842
 843 =over
 844
 845 =item version B<(required)>
 846
 847 Specifies which version of the L<CPAN::Meta::Spec> should be used as
 848 the format of the C<provides> output.  Currently only '1.4' and '2'
 849 are supported (and their format is identical).  This may change in
 850 the future as the definition of C<provides> changes.
 851
 852 The C<version> option is required.  If it is omitted or if
 853 an unsupported version is given, then C<provides> will throw an error.
 854
 855 =item dir
 856
 857 Directory to search recursively for F<.pm> files.  May not be specified with
 858 C<files>.
 859
 860 =item files
 861
 862 Array reference of files to examine.  May not be specified with C<dir>.
 863
 864 =item prefix
 865
 866 String to prepend to the C<file> field of the resulting output. This defaults
 867 to F<lib>, which is the common case for most CPAN distributions with their
 868 F<.pm> files in F<lib>.  This option ensures the META information has the
 869 correct relative path even when the C<dir> or C<files> arguments are
 870 absolute or have relative paths from a location other than the distribution
 871 root.
 872
 873 =back
 874
 875 For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
 876 is a hashref of the form:
 877
 878   {
 879     'Package::Name' => {
 880       version => '0.123',
 881       file => 'lib/Package/Name.pm'
 882     },
 883     'OtherPackage::Name' => ...
 884   }
 885
 886 =item C<< package_versions_from_directory($dir, \@files?) >>
 887
 888 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
 889 for those files in C<$dir> - and reads each file for packages and versions,
 890 returning a hashref of the form:
 891
 892   {
 893     'Package::Name' => {
 894       version => '0.123',
 895       file => 'Package/Name.pm'
 896     },
 897     'OtherPackage::Name' => ...
 898   }
 899
 900 The C<DB> and C<main> packages are always omitted, as are any "private"
 901 packages that have leading underscores in the namespace (e.g.
 902 C<Foo::_private>)
 903
 904 Note that the file path is relative to C<$dir> if that is specified.
 905 This B<must not> be used directly for CPAN META C<provides>.  See
 906 the C<provides> method instead.
 907
 908 =item C<< log_info (internal) >>
 909
 910 Used internally to perform logging; imported from Log::Contextual if
 911 Log::Contextual has already been loaded, otherwise simply calls warn.
 912
 913 =back
 914
 915 =head2 Object methods
 916
 917 =over 4
 918
 919 =item C<< name() >>
 920
 921 Returns the name of the package represented by this module. If there
 922 are more than one packages, it makes a best guess based on the
 923 filename. If it's a script (i.e. not a *.pm) the package name is
 924 'main'.
 925
 926 =item C<< version($package) >>
 927
 928 Returns the version as defined by the $VERSION variable for the
 929 package as returned by the C<name> method if no arguments are
 930 given. If given the name of a package it will attempt to return the
 931 version of that package if it is specified in the file.
 932
 933 =item C<< filename() >>
 934
 935 Returns the absolute path to the file.
 936
 937 =item C<< packages_inside() >>
 938
 939 Returns a list of packages. Note: this is a raw list of packages
 940 discovered (or assumed, in the case of C<main>).  It is not
 941 filtered for C<DB>, C<main> or private packages the way the
 942 C<provides> method does.
 943
 944 =item C<< pod_inside() >>
 945
 946 Returns a list of POD sections.
 947
 948 =item C<< contains_pod() >>
 949
 950 Returns true if there is any POD in the file.
 951
 952 =item C<< pod($section) >>
 953
 954 Returns the POD data in the given section.
 955
 956 =back
 957
 958 =head1 AUTHOR
 959
 960 Original code from Module::Build::ModuleInfo by Ken Williams
 961 <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
 962
 963 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
 964 assistance from David Golden (xdg) <dagolden@cpan.org>.
 965
 966 =head1 COPYRIGHT & LICENSE
 967
 968 Original code Copyright (c) 2001-2011 Ken Williams.
 969 Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
 970 All rights reserved.
 971
 972 This library is free software; you can redistribute it and/or
 973 modify it under the same terms as Perl itself.
 974
 975 =cut
 976