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