cpan/Module-Build/lib/Module/Build/ModuleInfo.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::Build::ModuleInfo;
   4
   5 # This module provides routines to gather information about
   6 # perl modules (assuming this may be expanded in the distant
   7 # parrot future to look at other types of modules).
   8
   9 use strict;
  10 use vars qw($VERSION);
  11 $VERSION = '0.35';
  12 $VERSION = eval $VERSION;
  13
  14 use File::Spec;
  15 use IO::File;
  16 use Module::Build::Version;
  17
  18
  19 my $PKG_REGEXP  = qr{   # match a package declaration
  20   ^[\s\{;]*             # intro chars on a line
  21   package               # the word 'package'
  22   \s+                   # whitespace
  23   ([\w:]+)              # a package name
  24   \s*                   # optional whitespace
  25   ;                     # semicolon line terminator
  26 }x;
  27
  28 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
  29   ([\$*])         # sigil - $ or *
  30   (
  31     (             # optional leading package name
  32       (?:::|\')?  # possibly starting like just :: (Ì  la $::VERSION)
  33       (?:\w+(?:::|\'))*  # Foo::Bar:: ...
  34     )?
  35     VERSION
  36   )\b
  37 }x;
  38
  39 my $VERS_REGEXP = qr{ # match a VERSION definition
  40   (?:
  41     \(\s*$VARNAME_REGEXP\s*\) # with parens
  42   |
  43     $VARNAME_REGEXP           # without parens
  44   )
  45   \s*
  46   =[^=~]  # = but not ==, nor =~
  47 }x;
  48
  49
  50 sub new_from_file {
  51   my $class    = shift;
  52   my $filename = File::Spec->rel2abs( shift );
  53
  54   return undef unless defined( $filename ) && -f $filename;
  55   return $class->_init(undef, $filename, @_);
  56 }
  57
  58 sub new_from_module {
  59   my $class   = shift;
  60   my $module  = shift;
  61   my %props   = @_;
  62
  63   $props{inc} ||= \@INC;
  64   my $filename = $class->find_module_by_name( $module, $props{inc} );
  65   return undef unless defined( $filename ) && -f $filename;
  66   return $class->_init($module, $filename, %props);
  67 }
  68
  69 sub _init {
  70   my $class    = shift;
  71   my $module   = shift;
  72   my $filename = shift;
  73   my %props = @_;
  74
  75   my( %valid_props, @valid_props );
  76   @valid_props = qw( collect_pod inc );
  77   @valid_props{@valid_props} = delete( @props{@valid_props} );
  78   warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
  79
  80   my %data = (
  81     module       => $module,
  82     filename     => $filename,
  83     version      => undef,
  84     packages     => [],
  85     versions     => {},
  86     pod          => {},
  87     pod_headings => [],
  88     collect_pod  => 0,
  89
  90     %valid_props,
  91   );
  92
  93   my $self = bless(\%data, $class);
  94
  95   $self->_parse_file();
  96
  97   unless($self->{module} and length($self->{module})) {
  98     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
  99     if($f =~ /\.pm$/) {
 100       $f =~ s/\..+$//;
 101       my @candidates = grep /$f$/, @{$self->{packages}};
 102       $self->{module} = shift(@candidates); # punt
 103     }
 104     else {
 105       if(grep /main/, @{$self->{packages}}) {
 106         $self->{module} = 'main';
 107       }
 108       else {
 109         $self->{module} = $self->{packages}[0] || '';
 110       }
 111     }
 112   }
 113
 114   $self->{version} = $self->{versions}{$self->{module}}
 115       if defined( $self->{module} );
 116
 117   return $self;
 118 }
 119
 120 # class method
 121 sub _do_find_module {
 122   my $class   = shift;
 123   my $module  = shift || die 'find_module_by_name() requires a package name';
 124   my $dirs    = shift || \@INC;
 125
 126   my $file = File::Spec->catfile(split( /::/, $module));
 127   foreach my $dir ( @$dirs ) {
 128     my $testfile = File::Spec->catfile($dir, $file);
 129     return [ File::Spec->rel2abs( $testfile ), $dir ]
 130         if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
 131     return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
 132         if -e "$testfile.pm";
 133   }
 134   return;
 135 }
 136
 137 # class method
 138 sub find_module_by_name {
 139   my $found = shift()->_do_find_module(@_) or return;
 140   return $found->[0];
 141 }
 142
 143 # class method
 144 sub find_module_dir_by_name {
 145   my $found = shift()->_do_find_module(@_) or return;
 146   return $found->[1];
 147 }
 148
 149
 150 # given a line of perl code, attempt to parse it if it looks like a
 151 # $VERSION assignment, returning sigil, full name, & package name
 152 sub _parse_version_expression {
 153   my $self = shift;
 154   my $line = shift;
 155
 156   my( $sig, $var, $pkg );
 157   if ( $line =~ $VERS_REGEXP ) {
 158     ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
 159     if ( $pkg ) {
 160       $pkg = ($pkg eq '::') ? 'main' : $pkg;
 161       $pkg =~ s/::$//;
 162     }
 163   }
 164
 165   return ( $sig, $var, $pkg );
 166 }
 167
 168 sub _parse_file {
 169   my $self = shift;
 170
 171   my $filename = $self->{filename};
 172   my $fh = IO::File->new( $filename )
 173     or die( "Can't open '$filename': $!" );
 174
 175   $self->_parse_fh($fh);
 176 }
 177
 178 sub _parse_fh {
 179   my ($self, $fh) = @_;
 180
 181   my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
 182   my( @pkgs, %vers, %pod, @pod );
 183   my $pkg = 'main';
 184   my $pod_sect = '';
 185   my $pod_data = '';
 186
 187   while (defined( my $line = <$fh> )) {
 188     my $line_num = $.;
 189
 190     chomp( $line );
 191     next if $line =~ /^\s*#/;
 192
 193     $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
 194
 195     # Would be nice if we could also check $in_string or something too
 196     last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
 197
 198     if ( $in_pod || $line =~ /^=cut/ ) {
 199
 200       if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
 201         push( @pod, $1 );
 202         if ( $self->{collect_pod} && length( $pod_data ) ) {
 203           $pod{$pod_sect} = $pod_data;
 204           $pod_data = '';
 205         }
 206         $pod_sect = $1;
 207
 208
 209       } elsif ( $self->{collect_pod} ) {
 210         $pod_data .= "$line\n";
 211
 212       }
 213
 214     } else {
 215
 216       $pod_sect = '';
 217       $pod_data = '';
 218
 219       # parse $line to see if it's a $VERSION declaration
 220       my( $vers_sig, $vers_fullname, $vers_pkg ) =
 221           $self->_parse_version_expression( $line );
 222
 223       if ( $line =~ $PKG_REGEXP ) {
 224         $pkg = $1;
 225         push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
 226         $vers{$pkg} = undef unless exists( $vers{$pkg} );
 227         $need_vers = 1;
 228
 229       # VERSION defined with full package spec, i.e. $Module::VERSION
 230       } elsif ( $vers_fullname && $vers_pkg ) {
 231         push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
 232         $need_vers = 0 if $vers_pkg eq $pkg;
 233
 234         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
 235           $vers{$vers_pkg} =
 236             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 237         } else {
 238           # Warn unless the user is using the "$VERSION = eval
 239           # $VERSION" idiom (though there are probably other idioms
 240           # that we should watch out for...)
 241           warn <<"EOM" unless $line =~ /=\s*eval/;
 242 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
 243 ignoring subsequent declaration on line $line_num.
 244 EOM
 245         }
 246
 247       # first non-comment line in undeclared package main is VERSION
 248       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
 249         $need_vers = 0;
 250         my $v =
 251           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 252         $vers{$pkg} = $v;
 253         push( @pkgs, 'main' );
 254
 255       # first non-comment line in undeclared package defines package main
 256       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
 257         $need_vers = 1;
 258         $vers{main} = '';
 259         push( @pkgs, 'main' );
 260
 261       # only keep if this is the first $VERSION seen
 262       } elsif ( $vers_fullname && $need_vers ) {
 263         $need_vers = 0;
 264         my $v =
 265           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
 266
 267
 268         unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
 269           $vers{$pkg} = $v;
 270         } else {
 271           warn <<"EOM";
 272 Package '$pkg' already declared with version '$vers{$pkg}'
 273 ignoring new version '$v' on line $line_num.
 274 EOM
 275         }
 276
 277       }
 278
 279     }
 280
 281   }
 282
 283   if ( $self->{collect_pod} && length($pod_data) ) {
 284     $pod{$pod_sect} = $pod_data;
 285   }
 286
 287   $self->{versions} = \%vers;
 288   $self->{packages} = \@pkgs;
 289   $self->{pod} = \%pod;
 290   $self->{pod_headings} = \@pod;
 291 }
 292
 293 {
 294 my $pn = 0;
 295 sub _evaluate_version_line {
 296   my $self = shift;
 297   my( $sigil, $var, $line ) = @_;
 298
 299   # Some of this code came from the ExtUtils:: hierarchy.
 300
 301   # We compile into $vsub because 'use version' would cause
 302   # compiletime/runtime issues with local()
 303   my $vsub;
 304   $pn++; # everybody gets their own package
 305   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
 306     #; package Module::Build::ModuleInfo::_version::p$pn;
 307     use Module::Build::Version;
 308     no strict;
 309
 310     local $sigil$var;
 311     \$$var=undef;
 312       \$vsub = sub {
 313         $line;
 314         \$$var
 315       };
 316   }};
 317
 318   local $^W;
 319   # Try to get the $VERSION
 320   eval $eval;
 321   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
 322     if $@;
 323   (ref($vsub) eq 'CODE') or
 324     die "failed to build version sub for $self->{filename}";
 325   my $result = eval { $vsub->() };
 326
 327   die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;
 328
 329   # Bless it into our own version class
 330   $result = Module::Build::Version->new($result);
 331
 332   return $result;
 333 }
 334 }
 335
 336
 337 ############################################################
 338
 339 # accessors
 340 sub name            { $_[0]->{module}           }
 341
 342 sub filename        { $_[0]->{filename}         }
 343 sub packages_inside { @{$_[0]->{packages}}      }
 344 sub pod_inside      { @{$_[0]->{pod_headings}}  }
 345 sub contains_pod    { $#{$_[0]->{pod_headings}} }
 346
 347 sub version {
 348     my $self = shift;
 349     my $mod  = shift || $self->{module};
 350     my $vers;
 351     if ( defined( $mod ) && length( $mod ) &&
 352          exists( $self->{versions}{$mod} ) ) {
 353         return $self->{versions}{$mod};
 354     } else {
 355         return undef;
 356     }
 357 }
 358
 359 sub pod {
 360     my $self = shift;
 361     my $sect = shift;
 362     if ( defined( $sect ) && length( $sect ) &&
 363          exists( $self->{pod}{$sect} ) ) {
 364         return $self->{pod}{$sect};
 365     } else {
 366         return undef;
 367     }
 368 }
 369
 370 1;
 371
 372 __END__
 373
 374 =for :stopwords ModuleInfo
 375
 376 =head1 NAME
 377
 378 ModuleInfo - Gather package and POD information from a perl module file
 379
 380
 381 =head1 DESCRIPTION
 382
 383 =over 4
 384
 385 =item new_from_file($filename, collect_pod => 1)
 386
 387 Construct a C<ModuleInfo> object given the path to a file. Takes an optional
 388 argument C<collect_pod> which is a boolean that determines whether
 389 POD data is collected and stored for reference. POD data is not
 390 collected by default. POD headings are always collected.
 391
 392 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
 393
 394 Construct a C<ModuleInfo> object given a module or package name. In addition
 395 to accepting the C<collect_pod> argument as described above, this
 396 method accepts a C<inc> argument which is a reference to an array of
 397 of directories to search for the module. If none are given, the
 398 default is @INC.
 399
 400 =item name()
 401
 402 Returns the name of the package represented by this module. If there
 403 are more than one packages, it makes a best guess based on the
 404 filename. If it's a script (i.e. not a *.pm) the package name is
 405 'main'.
 406
 407 =item version($package)
 408
 409 Returns the version as defined by the $VERSION variable for the
 410 package as returned by the C<name> method if no arguments are
 411 given. If given the name of a package it will attempt to return the
 412 version of that package if it is specified in the file.
 413
 414 =item filename()
 415
 416 Returns the absolute path to the file.
 417
 418 =item packages_inside()
 419
 420 Returns a list of packages.
 421
 422 =item pod_inside()
 423
 424 Returns a list of POD sections.
 425
 426 =item contains_pod()
 427
 428 Returns true if there is any POD in the file.
 429
 430 =item pod($section)
 431
 432 Returns the POD data in the given section.
 433
 434 =item find_module_by_name($module, \@dirs)
 435
 436 Returns the path to a module given the module or package name. A list
 437 of directories can be passed in as an optional parameter, otherwise
 438 @INC is searched.
 439
 440 Can be called as either an object or a class method.
 441
 442 =item find_module_dir_by_name($module, \@dirs)
 443
 444 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
 445 the module C<$module>. A list of directories can be passed in as an
 446 optional parameter, otherwise @INC is searched.
 447
 448 Can be called as either an object or a class method.
 449
 450 =back
 451
 452
 453 =head1 AUTHOR
 454
 455 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
 456
 457
 458 =head1 COPYRIGHT
 459
 460 Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
 461
 462 This library is free software; you can redistribute it and/or
 463 modify it under the same terms as Perl itself.
 464
 465
 466 =head1 SEE ALSO
 467
 468 perl(1), L<Module::Build>(3)
 469
 470 =cut
 471