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 # stolen from Module::Build::Version and ::Base - this is perl licensed code,
   6 # copyright them.
   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 = '0.36_04';
  15 $VERSION = eval $VERSION;
  16
  17 use File::Spec;
  18 use IO::File;
  19 use Module::Metadata::Version;
  20 use Log::Contextual qw(:log :dlog);
  21 use File::Find qw(find);
  22
  23 my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
  24
  25 my $PKG_REGEXP  = qr{   # match a package declaration
  26   ^[\s\{;]*             # intro chars on a line
  27   package               # the word 'package'
  28   \s+                   # whitespace
  29   ([\w:]+)              # a package name
  30   \s*                   # optional whitespace
  31   ($V_NUM_REGEXP)?        # optional version number
  32   \s*                   # optional whitesapce
  33   ;                     # semicolon line terminator
  34 }x;
  35
  36 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
  37   ([\$*])         # sigil - $ or *
  38   (
  39     (             # optional leading package name
  40       (?:::|\')?  # possibly starting like just :: (Ì  la $::VERSION)
  41       (?:\w+(?:::|\'))*  # Foo::Bar:: ...
  42     )?
  43     VERSION
  44   )\b
  45 }x;
  46
  47 my $VERS_REGEXP = qr{ # match a VERSION definition
  48   (?:
  49     \(\s*$VARNAME_REGEXP\s*\) # with parens
  50   |
  51     $VARNAME_REGEXP           # without parens
  52   )
  53   \s*
  54   =[^=~]  # = but not ==, nor =~
  55 }x;
  56
  57
  58 sub new_from_file {
  59   my $class    = shift;
  60   my $filename = File::Spec->rel2abs( shift );
  61
  62   return undef unless defined( $filename ) && -f $filename;
  63   return $class->_init(undef, $filename, @_);
  64 }
  65
  66 sub new_from_module {
  67   my $class   = shift;
  68   my $module  = shift;
  69   my %props   = @_;
  70
  71   $props{inc} ||= \@INC;
  72   my $filename = $class->find_module_by_name( $module, $props{inc} );
  73   return undef unless defined( $filename ) && -f $filename;
  74   return $class->_init($module, $filename, %props);
  75 }
  76
  77 {
  78
  79   my $compare_versions = sub {
  80     my ($v1, $op, $v2) = @_;
  81     $v1 = Module::Metadata::Version->new($v1)
  82       unless UNIVERSAL::isa($v1,'Module::Metadata::Version');
  83
  84     my $eval_str = "\$v1 $op \$v2";
  85     my $result   = eval $eval_str;
  86     log_info { "error comparing versions: '$eval_str' $@" } if $@;
  87
  88     return $result;
  89   };
  90
  91   my $normalize_version = sub {
  92     my ($version) = @_;
  93     if ( $version =~ /[=<>!,]/ ) { # logic, not just version
  94       # take as is without modification
  95     }
  96     elsif ( ref $version eq 'version' ||
  97             ref $version eq 'Module::Metadata::Version' ) { # version objects
  98       $version = $version->is_qv ? $version->normal : $version->stringify;
  99     }
 100     elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
 101       # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
 102       $version = "v$version";
 103     }
 104     else {
 105       # leave alone
 106     }
 107     return $version;
 108   };
 109
 110   # separate out some of the conflict resolution logic
 111
 112   my $resolve_module_versions = sub {
 113     my $packages = shift;
 114
 115     my( $file, $version );
 116     my $err = '';
 117       foreach my $p ( @$packages ) {
 118         if ( defined( $p->{version} ) ) {
 119         if ( defined( $version ) ) {
 120           if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
 121             $err .= "  $p->{file} ($p->{version})\n";
 122           } else {
 123             # same version declared multiple times, ignore
 124           }
 125         } else {
 126           $file    = $p->{file};
 127           $version = $p->{version};
 128         }
 129         }
 130         $file ||= $p->{file} if defined( $p->{file} );
 131       }
 132
 133     if ( $err ) {
 134       $err = "  $file ($version)\n" . $err;
 135     }
 136
 137     my %result = (
 138       file    => $file,
 139       version => $version,
 140       err     => $err
 141     );
 142
 143     return \%result;
 144   };
 145
 146   sub package_versions_from_directory {
 147     my ( $class, $dir, $files ) = @_;
 148
 149     my @files;
 150
 151     if ( $files ) {
 152       @files = @$files;
 153     } else {
 154       find( {
 155         wanted => sub {
 156           push @files, $_ if -f $_ && /\.pm$/;
 157         },
 158         no_chdir => 1,
 159       }, $dir );
 160     }
 161
 162     # First, we enumerate all packages & versions,
 163     # separating into primary & alternative candidates
 164     my( %prime, %alt );
 165     foreach my $file (@files) {
 166       my $mapped_filename = File::Spec->abs2rel( $file, $dir );
 167       my @path = split( /\//, $mapped_filename );
 168       (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
 169
 170       my $pm_info = $class->new_from_file( $file );
 171
 172       foreach my $package ( $pm_info->packages_inside ) {
 173         next if $package eq 'main';  # main can appear numerous times, ignore
 174         next if $package eq 'DB';    # special debugging package, ignore
 175         next if grep /^_/, split( /::/, $package ); # private package, ignore
 176
 177         my $version = $pm_info->version( $package );
 178
 179         if ( $package eq $prime_package ) {
 180           if ( exists( $prime{$package} ) ) {
 181             # M::B::ModuleInfo will handle this conflict
 182             die "Unexpected conflict in '$package'; multiple versions found.\n";
 183           } else {
 184             $prime{$package}{file} = $mapped_filename;
 185             $prime{$package}{version} = $version if defined( $version );
 186           }
 187         } else {
 188           push( @{$alt{$package}}, {
 189                                     file    => $mapped_filename,
 190                                     version => $version,
 191                                    } );
 192         }
 193       }
 194     }
 195
 196     # Then we iterate over all the packages found above, identifying conflicts
 197     # and selecting the "best" candidate for recording the file & version
 198     # for each package.
 199     foreach my $package ( keys( %alt ) ) {
 200       my $result = $resolve_module_versions->( $alt{$package} );
 201
 202       if ( exists( $prime{$package} ) ) { # primary package selected
 203
 204         if ( $result->{err} ) {
 205         # Use the selected primary package, but there are conflicting
 206         # errors among multiple alternative packages that need to be
 207         # reported
 208           log_info {
 209             "Found conflicting versions for package '$package'\n" .
 210             "  $prime{$package}{file} ($prime{$package}{version})\n" .
 211             $result->{err}
 212           };
 213
 214         } elsif ( defined( $result->{version} ) ) {
 215         # There is a primary package selected, and exactly one
 216         # alternative package
 217
 218         if ( exists( $prime{$package}{version} ) &&
 219              defined( $prime{$package}{version} ) ) {
 220           # Unless the version of the primary package agrees with the
 221           # version of the alternative package, report a conflict
 222           if ( $compare_versions->(
 223                  $prime{$package}{version}, '!=', $result->{version}
 224                )
 225              ) {
 226
 227             log_info {
 228               "Found conflicting versions for package '$package'\n" .
 229               "  $prime{$package}{file} ($prime{$package}{version})\n" .
 230               "  $result->{file} ($result->{version})\n"
 231             };
 232           }
 233
 234         } else {
 235           # The prime package selected has no version so, we choose to
 236           # use any alternative package that does have a version
 237           $prime{$package}{file}    = $result->{file};
 238           $prime{$package}{version} = $result->{version};
 239         }
 240
 241         } else {
 242         # no alt package found with a version, but we have a prime
 243         # package so we use it whether it has a version or not
 244         }
 245
 246       } else { # No primary package was selected, use the best alternative
 247
 248         if ( $result->{err} ) {
 249           log_info {
 250             "Found conflicting versions for package '$package'\n" .
 251             $result->{err}
 252           };
 253         }
 254
 255         # Despite possible conflicting versions, we choose to record
 256         # something rather than nothing
 257         $prime{$package}{file}    = $result->{file};
 258         $prime{$package}{version} = $result->{version}
 259           if defined( $result->{version} );
 260       }
 261     }
 262
 263     # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
 264     # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
 265     for (grep defined $_->{version}, values %prime) {
 266       $_->{version} = $normalize_version->( $_->{version} );
 267     }
 268
 269     return \%prime;
 270   }
 271 }
 272
 273
 274 sub _init {
 275   my $class    = shift;
 276   my $module   = shift;
 277   my $filename = shift;
 278   my %props = @_;
 279
 280   my( %valid_props, @valid_props );
 281   @valid_props = qw( collect_pod inc );
 282   @valid_props{@valid_props} = delete( @props{@valid_props} );
 283   warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
 284
 285   my %data = (
 286     module       => $module,
 287     filename     => $filename,
 288     version      => undef,
 289     packages     => [],
 290     versions     => {},
 291     pod          => {},
 292     pod_headings => [],
 293     collect_pod  => 0,
 294
 295     %valid_props,
 296   );
 297
 298   my $self = bless(\%data, $class);
 299
 300   $self->_parse_file();
 301
 302   unless($self->{module} and length($self->{module})) {
 303     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
 304     if($f =~ /\.pm$/) {
 305       $f =~ s/\..+$//;
 306       my @candidates = grep /$f$/, @{$self->{packages}};
 307       $self->{module} = shift(@candidates); # punt
 308     }
 309     else {
 310       if(grep /main/, @{$self->{packages}}) {
 311         $self->{module} = 'main';
 312       }
 313       else {
 314         $self->{module} = $self->{packages}[0] || '';
 315       }
 316     }
 317   }
 318
 319   $self->{version} = $self->{versions}{$self->{module}}
 320       if defined( $self->{module} );
 321
 322   return $self;
 323 }
 324
 325 # class method
 326 sub _do_find_module {
 327   my $class   = shift;
 328   my $module  = shift || die 'find_module_by_name() requires a package name';
 329   my $dirs    = shift || \@INC;
 330
 331   my $file = File::Spec->catfile(split( /::/, $module));
 332   foreach my $dir ( @$dirs ) {
 333     my $testfile = File::Spec->catfile($dir, $file);
 334     return [ File::Spec->rel2abs( $testfile ), $dir ]
 335         if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
 336     return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
 337         if -e "$testfile.pm";
 338   }
 339   return;
 340 }
 341
 342 # class method
 343 sub find_module_by_name {
 344   my $found = shift()->_do_find_module(@_) or return;
 345   return $found->[0];
 346 }
 347
 348 # class method
 349 sub find_module_dir_by_name {
 350   my $found = shift()->_do_find_module(@_) or return;
 351   return $found->[1];
 352 }
 353
 354
 355 # given a line of perl code, attempt to parse it if it looks like a
 356 # $VERSION assignment, returning sigil, full name, & package name
 357 sub _parse_version_expression {
 358   my $self = shift;
 359   my $line = shift;
 360
 361   my( $sig, $var, $pkg );
 362   if ( $line =~ $VERS_REGEXP ) {
 363     ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
 364     if ( $pkg ) {
 365       $pkg = ($pkg eq '::') ? 'main' : $pkg;
 366       $pkg =~ s/::$//;
 367     }
 368   }
 369
 370   return ( $sig, $var, $pkg );
 371 }
 372
 373 sub _parse_file {
 374   my $self = shift;
 375
 376   my $filename = $self->{filename};
 377   my $fh = IO::File->new( $filename )
 378     or die( "Can't open '$filename': $!" );
 379
 380   $self->_parse_fh($fh);
 381 }
 382
 383 sub _parse_fh {
 384   my ($self, $fh) = @_;
 385
 386   my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
 387   my( @pkgs, %vers, %pod, @pod );
 388   my $pkg = 'main';
 389   my $pod_sect = '';
 390   my $pod_data = '';
 391
 392   while (defined( my $line = <$fh> )) {
 393     my $line_num = $.;
 394
 395     chomp( $line );
 396     next if $line =~ /^\s*#/;
 397
 398     $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
 399
 400     # Would be nice if we could also check $in_string or something too
 401     last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
 402
 403     if ( $in_pod || $line =~ /^=cut/ ) {
 404
 405       if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
 406         push( @pod, $1 );
 407         if ( $self->{collect_pod} && length( $pod_data ) ) {
 408           $pod{$pod_sect} = $pod_data;
 409           $pod_data = '';
 410         }
 411         $pod_sect = $1;
 412
 413
 414       } elsif ( $self->{collect_pod} ) {
 415         $pod_data .= "$line\n";
 416
 417       }
 418
 419     } else {
 420
 421       $pod_sect = '';
 422       $pod_data = '';
 423
 424       # parse $line to see if it's a $VERSION declaration
 425       my( $vers_sig, $vers_fullname, $vers_pkg ) =
 426           $self->_parse_version_expression( $line );
 427
 428       if ( $line =~ $PKG_REGEXP ) {
 429         $pkg = $1;
 430         push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
 431         $vers{$pkg} = (defined $2 ? $2 : undef)  unless exists( $vers{$pkg} );
 432         $need_vers = defined $2 ? 0 : 1;
 433
 434       # VERSION defined with full package spec, i.e. $Module::VERSION
 435       } elsif ( $vers_fullname && $vers_pkg ) {
 436         push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
 437         $need_vers = 0 if $vers_pkg eq $pkg;
 438
 439         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
 440           $vers{$vers_pkg} =
 441             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 442         } else {
 443           # Warn unless the user is using the "$VERSION = eval
 444           # $VERSION" idiom (though there are probably other idioms
 445           # that we should watch out for...)
 446           warn <<"EOM" unless $line =~ /=\s*eval/;
 447 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
 448 ignoring subsequent declaration on line $line_num.
 449 EOM
 450         }
 451
 452       # first non-comment line in undeclared package main is VERSION
 453       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
 454         $need_vers = 0;
 455         my $v =
 456           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 457         $vers{$pkg} = $v;
 458         push( @pkgs, 'main' );
 459
 460       # first non-comment line in undeclared package defines package main
 461       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
 462         $need_vers = 1;
 463         $vers{main} = '';
 464         push( @pkgs, 'main' );
 465
 466       # only keep if this is the first $VERSION seen
 467       } elsif ( $vers_fullname && $need_vers ) {
 468         $need_vers = 0;
 469         my $v =
 470           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 471
 472
 473         unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
 474           $vers{$pkg} = $v;
 475         } else {
 476           warn <<"EOM";
 477 Package '$pkg' already declared with version '$vers{$pkg}'
 478 ignoring new version '$v' on line $line_num.
 479 EOM
 480         }
 481
 482       }
 483
 484     }
 485
 486   }
 487
 488   if ( $self->{collect_pod} && length($pod_data) ) {
 489     $pod{$pod_sect} = $pod_data;
 490   }
 491
 492   $self->{versions} = \%vers;
 493   $self->{packages} = \@pkgs;
 494   $self->{pod} = \%pod;
 495   $self->{pod_headings} = \@pod;
 496 }
 497
 498 {
 499 my $pn = 0;
 500 sub _evaluate_version_line {
 501   my $self = shift;
 502   my( $sigil, $var, $line ) = @_;
 503
 504   # Some of this code came from the ExtUtils:: hierarchy.
 505
 506   # We compile into $vsub because 'use version' would cause
 507   # compiletime/runtime issues with local()
 508   my $vsub;
 509   $pn++; # everybody gets their own package
 510   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
 511     #; package Module::Metadata::_version::p$pn;
 512     use Module::Metadata::Version;
 513     no strict;
 514
 515     local $sigil$var;
 516     \$$var=undef;
 517       \$vsub = sub {
 518         $line;
 519         \$$var
 520       };
 521   }};
 522
 523   local $^W;
 524   # Try to get the $VERSION
 525   eval $eval;
 526   # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
 527   # installed, so we need to hunt in ./lib for it
 528   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
 529     local @INC = ('lib',@INC);
 530     eval $eval;
 531   }
 532   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
 533     if $@;
 534   (ref($vsub) eq 'CODE') or
 535     die "failed to build version sub for $self->{filename}";
 536   my $result = eval { $vsub->() };
 537   die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
 538     if $@;
 539
 540   # Activestate apparently creates custom versions like '1.23_45_01', which
 541   # cause M::B::Version to think it's an invalid alpha.  So check for that
 542   # and strip them
 543   my $num_dots = () = $result =~ m{\.}g;
 544   my $num_unders = () = $result =~ m{_}g;
 545   if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) {
 546     $result =~ s{_}{}g;
 547   }
 548
 549   # Bless it into our own version class
 550   eval { $result = Module::Metadata::Version->new($result) };
 551   die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
 552     if $@;
 553
 554   return $result;
 555 }
 556 }
 557
 558
 559 ############################################################
 560
 561 # accessors
 562 sub name            { $_[0]->{module}           }
 563
 564 sub filename        { $_[0]->{filename}         }
 565 sub packages_inside { @{$_[0]->{packages}}      }
 566 sub pod_inside      { @{$_[0]->{pod_headings}}  }
 567 sub contains_pod    { $#{$_[0]->{pod_headings}} }
 568
 569 sub version {
 570     my $self = shift;
 571     my $mod  = shift || $self->{module};
 572     my $vers;
 573     if ( defined( $mod ) && length( $mod ) &&
 574          exists( $self->{versions}{$mod} ) ) {
 575         return $self->{versions}{$mod};
 576     } else {
 577         return undef;
 578     }
 579 }
 580
 581 sub pod {
 582     my $self = shift;
 583     my $sect = shift;
 584     if ( defined( $sect ) && length( $sect ) &&
 585          exists( $self->{pod}{$sect} ) ) {
 586         return $self->{pod}{$sect};
 587     } else {
 588         return undef;
 589     }
 590 }
 591
 592 1;
 593
 594 __END__
 595
 596 =for :stopwords ModuleInfo
 597
 598 =head1 NAME
 599
 600 ModuleInfo - Gather package and POD information from a perl module file
 601
 602
 603 =head1 DESCRIPTION
 604
 605 =over 4
 606
 607 =item new_from_file($filename, collect_pod => 1)
 608
 609 Construct a C<ModuleInfo> object given the path to a file. Takes an optional
 610 argument C<collect_pod> which is a boolean that determines whether
 611 POD data is collected and stored for reference. POD data is not
 612 collected by default. POD headings are always collected.
 613
 614 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
 615
 616 Construct a C<ModuleInfo> object given a module or package name. In addition
 617 to accepting the C<collect_pod> argument as described above, this
 618 method accepts a C<inc> argument which is a reference to an array of
 619 of directories to search for the module. If none are given, the
 620 default is @INC.
 621
 622 =item name()
 623
 624 Returns the name of the package represented by this module. If there
 625 are more than one packages, it makes a best guess based on the
 626 filename. If it's a script (i.e. not a *.pm) the package name is
 627 'main'.
 628
 629 =item version($package)
 630
 631 Returns the version as defined by the $VERSION variable for the
 632 package as returned by the C<name> method if no arguments are
 633 given. If given the name of a package it will attempt to return the
 634 version of that package if it is specified in the file.
 635
 636 =item filename()
 637
 638 Returns the absolute path to the file.
 639
 640 =item packages_inside()
 641
 642 Returns a list of packages.
 643
 644 =item pod_inside()
 645
 646 Returns a list of POD sections.
 647
 648 =item contains_pod()
 649
 650 Returns true if there is any POD in the file.
 651
 652 =item pod($section)
 653
 654 Returns the POD data in the given section.
 655
 656 =item find_module_by_name($module, \@dirs)
 657
 658 Returns the path to a module given the module or package name. A list
 659 of directories can be passed in as an optional parameter, otherwise
 660 @INC is searched.
 661
 662 Can be called as either an object or a class method.
 663
 664 =item find_module_dir_by_name($module, \@dirs)
 665
 666 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
 667 the module C<$module>. A list of directories can be passed in as an
 668 optional parameter, otherwise @INC is searched.
 669
 670 Can be called as either an object or a class method.
 671
 672 =back
 673
 674
 675 =head1 AUTHOR
 676
 677 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
 678
 679
 680 =head1 COPYRIGHT
 681
 682 Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
 683
 684 This library is free software; you can redistribute it and/or
 685 modify it under the same terms as Perl itself.
 686
 687
 688 =head1 SEE ALSO
 689
 690 perl(1), L<Module::Metadata>(3)
 691
 692 =cut
 693