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