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