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