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