diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Module/Build/ModuleInfo.pm')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/Module/Build/ModuleInfo.pm | 491 |
1 files changed, 0 insertions, 491 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Module/Build/ModuleInfo.pm b/Master/tlpkg/tlperl.straw/lib/Module/Build/ModuleInfo.pm deleted file mode 100755 index 053ae18d523..00000000000 --- a/Master/tlpkg/tlperl.straw/lib/Module/Build/ModuleInfo.pm +++ /dev/null @@ -1,491 +0,0 @@ -# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- -# vim:ts=8:sw=2:et:sta:sts=2 -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 vars qw($VERSION); -$VERSION = '0.3603'; -$VERSION = eval $VERSION; - -use File::Spec; -use IO::File; -use Module::Build::Version; - -my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal - -my $PKG_REGEXP = qr{ # match a package declaration - ^[\s\{;]* # intro chars on a line - package # the word 'package' - \s+ # whitespace - ([\w:]+) # a package name - \s* # optional whitespace - ($V_NUM_REGEXP)? # optional version number - \s* # optional whitesapce - ; # semicolon line terminator -}x; - -my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name - ([\$*]) # sigil - $ or * - ( - ( # optional leading package name - (?:::|\')? # possibly starting like just :: (Ì la $::VERSION) - (?:\w+(?:::|\'))* # Foo::Bar:: ... - )? - VERSION - )\b -}x; - -my $VERS_REGEXP = qr{ # match a VERSION definition - (?: - \(\s*$VARNAME_REGEXP\s*\) # with parens - | - $VARNAME_REGEXP # without parens - ) - \s* - =[^=~] # = but not ==, nor =~ -}x; - - -sub new_from_file { - my $class = shift; - my $filename = File::Spec->rel2abs( shift ); - - return undef unless defined( $filename ) && -f $filename; - return $class->_init(undef, $filename, @_); -} - -sub new_from_module { - my $class = shift; - my $module = shift; - my %props = @_; - - $props{inc} ||= \@INC; - my $filename = $class->find_module_by_name( $module, $props{inc} ); - return undef unless defined( $filename ) && -f $filename; - return $class->_init($module, $filename, %props); -} - -sub _init { - my $class = 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, $class); - - $self->_parse_file(); - - unless($self->{module} and 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}} - if defined( $self->{module} ); - - return $self; -} - -# class method -sub _do_find_module { - my $class = 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 ), $dir ] - if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp - return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ] - if -e "$testfile.pm"; - } - return; -} - -# class method -sub find_module_by_name { - my $found = shift()->_do_find_module(@_) or return; - return $found->[0]; -} - -# class method -sub find_module_dir_by_name { - my $found = shift()->_do_find_module(@_) or return; - return $found->[1]; -} - - -# given a line of perl code, attempt to parse it if it looks like a -# $VERSION assignment, returning sigil, full name, & package name -sub _parse_version_expression { - my $self = shift; - my $line = shift; - - my( $sig, $var, $pkg ); - if ( $line =~ $VERS_REGEXP ) { - ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); - if ( $pkg ) { - $pkg = ($pkg eq '::') ? 'main' : $pkg; - $pkg =~ s/::$//; - } - } - - return ( $sig, $var, $pkg ); -} - -sub _parse_file { - my $self = shift; - - my $filename = $self->{filename}; - my $fh = IO::File->new( $filename ) - or die( "Can't open '$filename': $!" ); - - $self->_parse_fh($fh); -} - -sub _parse_fh { - my ($self, $fh) = @_; - - my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); - my( @pkgs, %vers, %pod, @pod ); - my $pkg = 'main'; - my $pod_sect = ''; - my $pod_data = ''; - - while (defined( my $line = <$fh> )) { - my $line_num = $.; - - chomp( $line ); - next if $line =~ /^\s*#/; - - $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod; - - # Would be nice if we could also check $in_string or something too - last if !$in_pod && $line =~ /^__(?:DATA|END)__$/; - - 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 = ''; - - # parse $line to see if it's a $VERSION declaration - my( $vers_sig, $vers_fullname, $vers_pkg ) = - $self->_parse_version_expression( $line ); - - if ( $line =~ $PKG_REGEXP ) { - $pkg = $1; - push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); - $vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} ); - $need_vers = defined $2 ? 0 : 1; - - # VERSION defined with full package spec, i.e. $Module::VERSION - } elsif ( $vers_fullname && $vers_pkg ) { - push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); - $need_vers = 0 if $vers_pkg eq $pkg; - - unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { - $vers{$vers_pkg} = - $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); - } else { - # Warn unless the user is using the "$VERSION = eval - # $VERSION" idiom (though there are probably other idioms - # that we should watch out for...) - warn <<"EOM" unless $line =~ /=\s*eval/; -Package '$vers_pkg' already declared with version '$vers{$vers_pkg}', -ignoring subsequent declaration on line $line_num. -EOM - } - - # first non-comment line in undeclared package main is VERSION - } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) { - $need_vers = 0; - my $v = - $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); - $vers{$pkg} = $v; - push( @pkgs, 'main' ); - - # first non-comment line in undeclared package defines package main - } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { - $need_vers = 1; - $vers{main} = ''; - push( @pkgs, 'main' ); - - # only keep if this is the first $VERSION seen - } elsif ( $vers_fullname && $need_vers ) { - $need_vers = 0; - my $v = - $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); - - - unless ( defined $vers{$pkg} && length $vers{$pkg} ) { - $vers{$pkg} = $v; - } else { - warn <<"EOM"; -Package '$pkg' already declared with version '$vers{$pkg}' -ignoring new version '$v' on line $line_num. -EOM - } - - } - - } - - } - - 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; -} - -{ -my $pn = 0; -sub _evaluate_version_line { - my $self = shift; - my( $sigil, $var, $line ) = @_; - - # Some of this code came from the ExtUtils:: hierarchy. - - # We compile into $vsub because 'use version' would cause - # compiletime/runtime issues with local() - my $vsub; - $pn++; # everybody gets their own package - my $eval = qq{BEGIN { q# Hide from _packages_inside() - #; package Module::Build::ModuleInfo::_version::p$pn; - use Module::Build::Version; - no strict; - - local $sigil$var; - \$$var=undef; - \$vsub = sub { - $line; - \$$var - }; - }}; - - local $^W; - # Try to get the $VERSION - eval $eval; - # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't - # installed, so we need to hunt in ./lib for it - if ( $@ =~ /Can't locate/ && -d 'lib' ) { - local @INC = ('lib',@INC); - eval $eval; - } - warn "Error evaling version line '$eval' in $self->{filename}: $@\n" - if $@; - (ref($vsub) eq 'CODE') or - die "failed to build version sub for $self->{filename}"; - my $result = eval { $vsub->() }; - die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" - if $@; - - # Activestate apparently creates custom versions like '1.23_45_01', which - # cause M::B::Version to think it's an invalid alpha. So check for that - # and strip them - my $num_dots = () = $result =~ m{\.}g; - my $num_unders = () = $result =~ m{_}g; - if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) { - $result =~ s{_}{}g; - } - - # Bless it into our own version class - eval { $result = Module::Build::Version->new($result) }; - die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" - if $@; - - 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 { - my $self = shift; - my $mod = shift || $self->{module}; - my $vers; - if ( defined( $mod ) && length( $mod ) && - exists( $self->{versions}{$mod} ) ) { - return $self->{versions}{$mod}; - } else { - return undef; - } -} - -sub pod { - my $self = shift; - my $sect = shift; - if ( defined( $sect ) && length( $sect ) && - exists( $self->{pod}{$sect} ) ) { - return $self->{pod}{$sect}; - } else { - return undef; - } -} - -1; - -__END__ - -=for :stopwords ModuleInfo - -=head1 NAME - -ModuleInfo - Gather package and POD information from a perl module file - - -=head1 DESCRIPTION - -=over 4 - -=item new_from_file($filename, collect_pod => 1) - -Construct a C<ModuleInfo> object given the path to a file. Takes an optional -argument 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. - -=item new_from_module($module, collect_pod => 1, inc => \@dirs) - -Construct a C<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> argument which is a reference to an array of -of directories to search for the module. If none are given, the -default is @INC. - -=item 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'. - -=item 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. - -=item filename() - -Returns the absolute path to the file. - -=item packages_inside() - -Returns a list of packages. - -=item pod_inside() - -Returns a list of POD sections. - -=item contains_pod() - -Returns true if there is any POD in the file. - -=item pod($section) - -Returns the POD data in the given section. - -=item 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 parameter, otherwise -@INC is searched. - -Can be called as either an object or a class method. - -=item find_module_dir_by_name($module, \@dirs) - -Returns the entry in C<@dirs> (or C<@INC> by default) that contains -the module C<$module>. A list of directories can be passed in as an -optional parameter, otherwise @INC is searched. - -Can be called as either an object or a class method. - -=back - - -=head1 AUTHOR - -Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> - - -=head1 COPYRIGHT - -Copyright (c) 2001-2006 Ken Williams. All rights reserved. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - -=head1 SEE ALSO - -perl(1), L<Module::Build>(3) - -=cut - |