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