home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Module / Build / ModuleInfo.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  11.2 KB  |  456 lines
  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.  
  456.