[Module-build-checkins] Module-Build/lib/Module/Build ModuleInfo.pm,NONE,1.1 Base.pm,1.372,1.373
Status: Beta
Brought to you by:
kwilliams
Menu
▾
▴
[Module-build-checkins] Module-Build/lib/Module/Build ModuleInfo.pm,NONE,1.1 Base.pm,1.372,1.373
|
From: Randy W. S. <si...@us...> - 2005-01-07 11:09:28
|
Update of /cvsroot/module-build/Module-Build/lib/Module/Build In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3413/lib/Module/Build Modified Files: Base.pm Added Files: ModuleInfo.pm Log Message: Refactored methods relating to parsing perl module files for package, version, and pod data into a new class. Index: Base.pm =================================================================== RCS file: /cvsroot/module-build/Module-Build/lib/Module/Build/Base.pm,v retrieving revision 1.372 retrieving revision 1.373 diff -u -d -r1.372 -r1.373 --- Base.pm 7 Jan 2005 00:20:43 -0000 1.372 +++ Base.pm 7 Jan 2005 11:08:57 -0000 1.373 @@ -14,6 +14,8 @@ use Text::ParseWords (); use Carp (); +require Module::Build::ModuleInfo; + #################### Constructors ########################### sub new { my $self = shift()->_construct(@_); @@ -673,7 +675,8 @@ my $version_from = File::Spec->catfile( split '/', $p->{dist_version_from} ); - return $p->{dist_version} = $self->version_from_file($version_from); + my $pm_info = Module::Build::ModuleInfo->new_from_file( $version_from ); + return $p->{dist_version} = $pm_info->version(); } sub dist_author { shift->_pod_parse('author') } @@ -694,65 +697,12 @@ return $p->{$member} = $parser->$method(); } -sub find_module_by_name { - my ($self, $mod, $dirs) = @_; - my $file = File::Spec->catfile(split '::', $mod); - foreach (@$dirs) { - my $testfile = File::Spec->catfile($_, $file); - return $testfile if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp - return "$testfile.pm" if -e "$testfile.pm"; - } - return; -} - -sub _next_code_line { - my ($self, $fh, $pat) = @_; - my $inpod = 0; - - local $_; - while (<$fh>) { - $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; - next if $inpod || /^\s*#/; - return wantarray ? ($_, /$pat/) : $_ - if $_ =~ $pat; - } - return; +sub version_from_file { # Method provided for backwards compatability + return Module::Build::ModuleInfo->new_from_file($_[1])->version(); } -sub version_from_file { - my ($self, $file) = @_; - - # Some of this code came from the ExtUtils:: hierarchy. - my $fh = IO::File->new($file) or die "Can't open '$file' for version: $!"; - - my $match = qr/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; - my ($v_line, $sigil, $var) = $self->_next_code_line($fh, $match) or return undef; - - my $eval = qq{q# Hide from _packages_inside() - #; package Module::Build::Base::_version; - no strict; - - local $sigil$var; - \$$var=undef; do { - $v_line - }; \$$var - }; - local $^W; - - # version.pm will change the ->VERSION method, so we mitigate the - # potential effects here. Unfortunately local(*UNIVERSAL::VERSION) - # will crash perl < 5.8.1. - - my $old_version = \&UNIVERSAL::VERSION; - eval {require version}; - my $result = eval $eval; - *UNIVERSAL::VERSION = $old_version; - $self->log_warn("Error evaling version line '$eval' in $file: $@\n") if $@; - - # Unbless it if it's a version.pm object - $result = "$result" if UNIVERSAL::isa( $result, 'version' ); - - return $result; +sub find_module_by_name { # Method provided for backwards compatability + return Module::Build::ModuleInfo->find_module_by_name(@_[1,2]); } sub _persistent_hash_write { @@ -986,13 +936,13 @@ # Don't try to load if it's already loaded } else { - my $file = $self->find_module_by_name($modname, \@INC); - unless ($file) { + my $pm_info = Module::Build::ModuleInfo->new_from_module( $modname ); + unless (defined( $pm_info )) { @status{ qw(have message) } = ('<none>', "Prerequisite $modname isn't installed"); return \%status; } - $status{have} = $self->version_from_file($file); + $status{have} = $pm_info->version(); if ($spec and !$status{have}) { @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname"); return \%status; @@ -1512,8 +1462,8 @@ sub ACTION_testcover { my ($self) = @_; - unless ($self->find_module_by_name('Devel::Cover', \@INC)) { - $self->log_warn("Cannot run testcover action unless Devel::Cover is installed.\n"); + unless (Module::Build::ModuleInfo->find_module_by_name('Devel::Cover')) { + warn("Cannot run testcover action unless Devel::Cover is installed.\n"); return; } @@ -2007,7 +1957,8 @@ my @parts = File::Spec->splitdir($file); @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar - my $installed = $self->find_module_by_name(join('::', @parts), \@myINC); + my $installed = Module::Build::ModuleInfo->find_module_by_name( + join('::', @parts), \@myINC ); if (not $installed) { print "Only in lib: $file\n"; next; @@ -2443,9 +2394,8 @@ or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first"; # Localize - my %dist_files = (map - {$self->localize_file_path($_) => $_} - keys %$manifest); + my %dist_files = map { $self->localize_file_path($_) => $_ } + keys %$manifest; my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files }; @@ -2454,28 +2404,17 @@ next if $file =~ m{^t/}; # Skip things in t/ my $localfile = File::Spec->catfile( split m{/}, $file ); - my $version = $self->version_from_file( $localfile ); + + my $pm_info = Module::Build::ModuleInfo->new_from_file( $localfile ); - foreach my $package ($self->_packages_inside($localfile)) { + foreach my $package ($pm_info->packages_inside($localfile)) { $out{$package}{file} = $dist_files{$file}; - $out{$package}{version} = $version if defined $version; + $out{$package}{version} = $pm_info->version( $package ); } } return \%out; } -sub _packages_inside { - # XXX this SUCKS SUCKS SUCKS! Damn you perl! - my ($self, $file) = @_; - my $fh = IO::File->new($file) or die "Can't read $file: $!"; - - my (@packages, $p); - push @packages, $p while (undef, $p) = - $self->_next_code_line($fh, qr/^[\s\{;]*package\s+([\w:]+)/); - - return @packages; -} - sub make_tarball { my ($self, $dir, $file) = @_; $file ||= $dir; @@ -2684,10 +2623,10 @@ } else { # Ok, I give up. Just use backticks. - my $xsubpp = $self->find_module_by_name('ExtUtils::xsubpp', \@INC) + my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp') or die "Can't find ExtUtils::xsubpp in INC (@INC)"; - my $typemap = $self->find_module_by_name('ExtUtils::typemap', \@INC); + my $typemap = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::typemap', \@INC); my $cf = $self->{config}; my $perl = $self->{properties}{perl}; --- NEW FILE: ModuleInfo.pm --- package Module::Build::ModuleInfo; # This module provides routines to gather information about # perl modules (assuming this may be expanded in the distant # parrot future to look at other types of modules). use strict; use File::Spec; use IO::File; my $PKG_REGEXP = qr/^[\s\{;]*package\s+([\w:]+)/; my $VERS_REGEXP = qr/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; sub new_from_file { my $package = shift; my $filename = File::Spec->rel2abs( shift ); return undef unless defined( $filename ) && -f $filename; return __PACKAGE__->_init( undef, $filename, @_ ); } sub new_from_module { my $package = shift; my $module = shift; my %props = @_; $props{inc} ||= \@INC; my $filename = __PACKAGE__->find_module_by_name( $module, $props{inc} ); return undef unless defined( $filename ) && -f $filename; return __PACKAGE__->_init( $module, $filename, %props ); } sub _init { my $package = shift; my $module = shift; my $filename = shift; my %props = @_; my( %valid_props, @valid_props ); @valid_props = qw( collect_pod inc ); @valid_props{@valid_props} = delete( @props{@valid_props} ); warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); my %data = ( module => $module, filename => $filename, version => undef, packages => [], versions => {}, pod => {}, pod_headings => [], collect_pod => 0, %valid_props, ); my $self = bless( \%data, $package ); $self->_parse_file(); unless ( $self->{module} && length( $self->{module} ) ) { my( $v, $d, $f ) = File::Spec->splitpath( $self->{filename} ); if ( $f =~ /\.pm$/ ) { $f =~ s/\..+$//; my @candidates = grep /$f$/, @{$self->{packages}}; $self->{module} = shift( @candidates ); # punt } else { if ( grep /main/, @{$self->{packages}} ) { $self->{module} = 'main'; } else { $self->{module} = $self->{packages}[0] || ''; } } } $self->{version} = $self->{versions}{$self->{module}}; return $self; } # class method sub find_module_by_name { my $package = shift; my $module = shift || die 'find_module_by_name() requires a package name'; my $dirs = shift || \@INC; my $file = File::Spec->catfile(split( /::/, $module)); foreach my $dir ( @$dirs ) { my $testfile = File::Spec->catfile($dir, $file); return File::Spec->rel2abs( $testfile ) if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp return File::Spec->rel2abs( "$testfile.pm" ) if -e "$testfile.pm"; } return; } sub _parse_file { my $self = shift; my $filename = $self->{filename}; my $fh = IO::File->new( $filename ) or die( "Can't open '$filename': $!" ); my( $in_pod, $seen_end ) = ( 0, 0 ); my( @pkgs, %vers, %pod, @pod ); my $pkg = 'main'; my $pod_sect = ''; my $pod_data = ''; while (defined( my $line = <$fh> )) { chomp( $line ); next if $line =~ /^\s*#/; $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod; if ( $in_pod || $line =~ /^=cut/ ) { if ( $line =~ /^=head\d\s+(.+)\s*$/ ) { push( @pod, $1 ); if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } $pod_sect = $1; } elsif ( $self->{collect_pod} ) { $pod_data .= "$line\n"; } } else { $pod_sect = ''; $pod_data = ''; if ( $line =~ $PKG_REGEXP ) { $pkg = $1; $vers{$pkg} = undef; push( @pkgs, $pkg ); } elsif ( $line =~ $VERS_REGEXP ) { unless ( defined( $vers{$pkg} ) ) { # only first VERSION my $v = $self->_evaluate_version_line( $line ); $vers{$pkg} = $v; } } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { $vers{main} = ''; push( @pkgs, 'main' ); } } } if ( $self->{collect_pod} && length($pod_data) ) { $pod{$pod_sect} = $pod_data; } $self->{versions} = \%vers; $self->{packages} = \@pkgs; $self->{pod} = \%pod; $self->{pod_headings} = \@pod; } sub _evaluate_version_line { my $self = shift; my $line = shift; # Some of this code came from the ExtUtils:: hierarchy. my ($sigil, $var) = ($line =~ $VERS_REGEXP); my $eval = qq{q# Hide from _packages_inside() #; package Module::Build::ModuleInfo::_version; no strict; local $sigil$var; \$$var=undef; do { $line }; \$$var }; local $^W; # version.pm will change the ->VERSION method, so we mitigate the # potential effects here. Unfortunately local(*UNIVERSAL::VERSION) # will crash perl < 5.8.1. my $old_version = \&UNIVERSAL::VERSION; eval {require version}; my $result = eval $eval; *UNIVERSAL::VERSION = $old_version; warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@; # Unbless it if it's a version.pm object $result = "$result" if UNIVERSAL::isa( $result, 'version' ); return $result; } ############################################################ # accessors sub name { $_[0]->{module} } sub filename { $_[0]->{filename} } sub packages_inside { @{$_[0]->{packages}} } sub pod_inside { @{$_[0]->{pod_headings}} } sub contains_pod { $#{$_[0]->{pod_headings}} } sub version { $_[0]->{versions}{ $_[1] || $_[0]->{module} } } sub pod { $_[0]->{pod}{$_[1]} } 1; __END__ =head1 NAME ModuleInfo - Gather package and POD information from a perl module files =head1 DESCRIPTION =head2 new_from_file( $filename [ , collect_pod => 1 ] ) Construct a ModuleInfo object given the path to a file. Takes an optional arguement C<collect_pod> which is a boolean that determines whether POD data is collected and stored for reference. POD data is not collected by default. POD headings are always collected. =head2 new_from_module( $module [ , collect_pod => 1, inc => \@dirs ] ) Construct a ModuleInfo object given a module or package name. In addition to accepting the C<collect_pod> argument as described above, this method accepts a C<inc> arguemnt which is a reference to an array of of directories to search for the module. If none are given, the default is @INC. =head2 name( ) Returns the name of the package represented by this module. If there are more than one packages, it makes a best guess based on the filename. If it's a script (i.e. not a *.pm) the package name is 'main'. =head2 version( [ $package ] ) Returns the version as defined by the $VERSION variable for the package as returned by the C<name> method if no arguments are given. If given the name of a package it will attempt to return the version of that package if it is specified in the file. =head2 filename( ) Returns the absolute path to the file. =head2 packages_inside( ) Returns a list of packages. =head2 pod_inside( ) Returns a list of POD sections. =head2 contains_pod( ) Returns true if there is any POD in the file. =head2 pod( $section ) Returns the POD data in the given section. =head2 find_module_by_name( $module [ , \@dirs ] ) Returns the path to a module given the module or package name. A list of directories can be passed in as an optional paramater, otherwise @INC is searched. Can be called as both an object and a class method. =cut |
