[Summary view] [Print] [Text view]

   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