lib/Module/Build/ModuleInfo.pm

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