diff options
author | David Golden <dagolden@cpan.org> | 2011-01-05 22:47:41 -0500 |
---|---|---|
committer | David Golden <dagolden@cpan.org> | 2011-01-06 21:09:48 -0500 |
commit | e8b333e679eb9a7a62c1d86b647515f01821eb60 (patch) | |
tree | 67c3b9dc2c6652667331ede3aa953235ff0b19ce /cpan/Module-Metadata | |
parent | a6e0c6eb63f52bd199e875beddb654231643de92 (diff) | |
download | perl-e8b333e679eb9a7a62c1d86b647515f01821eb60.tar.gz |
Add Module::Metadata as a dual-life core module
This commit adds Module::Metadata 1.000002 as a dual-life module. It
gathers package and POD information from Perl module files. It is a
standalone module based on Module::Build::ModuleInfo for use by other
module installation toolchain components. Module::Build::ModuleInfo
has been deprecated in favor of this module instead.
Diffstat (limited to 'cpan/Module-Metadata')
-rw-r--r-- | cpan/Module-Metadata/lib/Module/Metadata.pm | 760 | ||||
-rw-r--r-- | cpan/Module-Metadata/t/lib/DistGen.pm | 845 | ||||
-rw-r--r-- | cpan/Module-Metadata/t/lib/MBTest.pm | 279 | ||||
-rw-r--r-- | cpan/Module-Metadata/t/lib/Tie/CPHash.pm | 194 | ||||
-rw-r--r-- | cpan/Module-Metadata/t/metadata.t | 460 |
5 files changed, 2538 insertions, 0 deletions
diff --git a/cpan/Module-Metadata/lib/Module/Metadata.pm b/cpan/Module-Metadata/lib/Module/Metadata.pm new file mode 100644 index 0000000000..6541f1e553 --- /dev/null +++ b/cpan/Module-Metadata/lib/Module/Metadata.pm @@ -0,0 +1,760 @@ +# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- +# vim:ts=8:sw=2:et:sta:sts=2 +package Module::Metadata; + +# stolen from Module::Build::Version and ::Base - this is perl licensed code, +# copyright them. + +# 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 = '1.000002'; +$VERSION = eval $VERSION; + +use File::Spec; +use IO::File; +use version 0.87; +BEGIN { + if ($INC{'Log/Contextual.pm'}) { + Log::Contextual->import('log_info'); + } else { + *log_info = sub (&) { warn $_[0]->() }; + } +} +use File::Find qw(find); + +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); +} + +{ + + my $compare_versions = sub { + my ($v1, $op, $v2) = @_; + $v1 = version->new($v1) + unless UNIVERSAL::isa($v1,'version'); + + my $eval_str = "\$v1 $op \$v2"; + my $result = eval $eval_str; + log_info { "error comparing versions: '$eval_str' $@" } if $@; + + return $result; + }; + + my $normalize_version = sub { + my ($version) = @_; + if ( $version =~ /[=<>!,]/ ) { # logic, not just version + # take as is without modification + } + elsif ( ref $version eq 'version' ) { # version objects + $version = $version->is_qv ? $version->normal : $version->stringify; + } + elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots + # normalize string tuples without "v": "1.2.3" -> "v1.2.3" + $version = "v$version"; + } + else { + # leave alone + } + return $version; + }; + + # separate out some of the conflict resolution logic + + my $resolve_module_versions = sub { + my $packages = shift; + + my( $file, $version ); + my $err = ''; + foreach my $p ( @$packages ) { + if ( defined( $p->{version} ) ) { + if ( defined( $version ) ) { + if ( $compare_versions->( $version, '!=', $p->{version} ) ) { + $err .= " $p->{file} ($p->{version})\n"; + } else { + # same version declared multiple times, ignore + } + } else { + $file = $p->{file}; + $version = $p->{version}; + } + } + $file ||= $p->{file} if defined( $p->{file} ); + } + + if ( $err ) { + $err = " $file ($version)\n" . $err; + } + + my %result = ( + file => $file, + version => $version, + err => $err + ); + + return \%result; + }; + + sub package_versions_from_directory { + my ( $class, $dir, $files ) = @_; + + my @files; + + if ( $files ) { + @files = @$files; + } else { + find( { + wanted => sub { + push @files, $_ if -f $_ && /\.pm$/; + }, + no_chdir => 1, + }, $dir ); + } + + # First, we enumerate all packages & versions, + # separating into primary & alternative candidates + my( %prime, %alt ); + foreach my $file (@files) { + my $mapped_filename = File::Spec->abs2rel( $file, $dir ); + my @path = split( /\//, $mapped_filename ); + (my $prime_package = join( '::', @path )) =~ s/\.pm$//; + + my $pm_info = $class->new_from_file( $file ); + + foreach my $package ( $pm_info->packages_inside ) { + next if $package eq 'main'; # main can appear numerous times, ignore + next if $package eq 'DB'; # special debugging package, ignore + next if grep /^_/, split( /::/, $package ); # private package, ignore + + my $version = $pm_info->version( $package ); + + if ( $package eq $prime_package ) { + if ( exists( $prime{$package} ) ) { + # M::B::ModuleInfo will handle this conflict + die "Unexpected conflict in '$package'; multiple versions found.\n"; + } else { + $prime{$package}{file} = $mapped_filename; + $prime{$package}{version} = $version if defined( $version ); + } + } else { + push( @{$alt{$package}}, { + file => $mapped_filename, + version => $version, + } ); + } + } + } + + # Then we iterate over all the packages found above, identifying conflicts + # and selecting the "best" candidate for recording the file & version + # for each package. + foreach my $package ( keys( %alt ) ) { + my $result = $resolve_module_versions->( $alt{$package} ); + + if ( exists( $prime{$package} ) ) { # primary package selected + + if ( $result->{err} ) { + # Use the selected primary package, but there are conflicting + # errors among multiple alternative packages that need to be + # reported + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + $result->{err} + }; + + } elsif ( defined( $result->{version} ) ) { + # There is a primary package selected, and exactly one + # alternative package + + if ( exists( $prime{$package}{version} ) && + defined( $prime{$package}{version} ) ) { + # Unless the version of the primary package agrees with the + # version of the alternative package, report a conflict + if ( $compare_versions->( + $prime{$package}{version}, '!=', $result->{version} + ) + ) { + + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + " $result->{file} ($result->{version})\n" + }; + } + + } else { + # The prime package selected has no version so, we choose to + # use any alternative package that does have a version + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version}; + } + + } else { + # no alt package found with a version, but we have a prime + # package so we use it whether it has a version or not + } + + } else { # No primary package was selected, use the best alternative + + if ( $result->{err} ) { + log_info { + "Found conflicting versions for package '$package'\n" . + $result->{err} + }; + } + + # Despite possible conflicting versions, we choose to record + # something rather than nothing + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version} + if defined( $result->{version} ); + } + } + + # Normalize versions. Can't use exists() here because of bug in YAML::Node. + # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18 + for (grep defined $_->{version}, values %prime) { + $_->{version} = $normalize_version->( $_->{version} ); + } + + return \%prime; + } +} + + +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::Metadata::_version::p$pn; + use 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 $@; + + # Upgrade it into a version object + my $version = eval { _dwim_version($result) }; + + die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + unless defined $version; # "0" is OK! + + return $version; +} +} + +# Try to DWIM when things fail the lax version test in obvious ways +{ + my @version_prep = ( + # Best case, it just works + sub { return shift }, + + # If we still don't have a version, try stripping any + # trailing junk that is prohibited by lax rules + sub { + my $v = shift; + $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b + return $v; + }, + + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause version.pm to think it's an invalid alpha. So check for that + # and strip them + sub { + my $v = shift; + my $num_dots = () = $v =~ m{(\.)}g; + my $num_unders = () = $v =~ m{(_)}g; + my $leading_v = substr($v,0,1) eq 'v'; + if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { + $v =~ s{_}{}g; + $num_unders = () = $v =~ m{(_)}g; + } + return $v; + }, + + # Worst case, try numifying it like we would have before version objects + sub { + my $v = shift; + no warnings 'numeric'; + return 0 + $v; + }, + + ); + + sub _dwim_version { + my ($result) = shift; + + return $result if ref($result) eq 'version'; + + my ($version, $error); + for my $f (@version_prep) { + $result = $f->($result); + $version = eval { version->new($result) }; + $error ||= $@ if $@; # capture first failure + last if defined $version; + } + + die $error unless defined $version; + + return $version; + } +} + +############################################################ + +# 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; + +=head1 NAME + +Module::Metadata - Gather package and POD information from perl module files + +=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. + +=item package_versions_from_directory($dir, \@files?) + +Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks +for those files in C<$dir> - and reads each file for packages and versions, +returning a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + +=item log_info (internal) + +Used internally to perform logging; imported from Log::Contextual if +Log::Contextual has already been loaded, otherwise simply calls warn. + +=back + +=head1 AUTHOR + +Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org> + +Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with +assistance from David Golden (xdg) <dagolden@cpan.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::ModuleInfo>(3) + +=cut + diff --git a/cpan/Module-Metadata/t/lib/DistGen.pm b/cpan/Module-Metadata/t/lib/DistGen.pm new file mode 100644 index 0000000000..9fbd6d0c8c --- /dev/null +++ b/cpan/Module-Metadata/t/lib/DistGen.pm @@ -0,0 +1,845 @@ +package DistGen; + +use strict; + +use vars qw( $VERSION $VERBOSE @EXPORT_OK); + +$VERSION = '0.01'; +$VERBOSE = 0; + +use Carp; + +use MBTest (); +use Cwd (); +use File::Basename (); +use File::Find (); +use File::Path (); +use File::Spec (); +use IO::File (); +use Tie::CPHash; +use Data::Dumper; + +my $vms_mode; +my $vms_lower_case; + +BEGIN { + $vms_mode = 0; + $vms_lower_case = 0; + if( $^O eq 'VMS' ) { + # For things like vmsify() + require VMS::Filespec; + VMS::Filespec->import; + $vms_mode = 1; + $vms_lower_case = 1; + my $vms_efs_case = 0; + my $unix_rpt = 0; + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_efs_case = $efs_case =~ /^[ET1]/i; + } + $vms_mode = 0 if $unix_rpt; + $vms_lower_case = 0 if $vms_efs_case; + } +} +BEGIN { + require Exporter; + *{import} = \&Exporter::import; + @EXPORT_OK = qw( + undent + ); +} + +sub undent { + my ($string) = @_; + + my ($space) = $string =~ m/^(\s+)/; + $string =~ s/^$space//gm; + + return($string); +} + +sub chdir_all ($) { + # OS/2 has "current directory per disk", undeletable; + # doing chdir() to another disk won't change cur-dir of initial disk... + chdir('/') if $^O eq 'os2'; + chdir shift; +} + +######################################################################## + +END { chdir_all(MBTest->original_cwd); } + +sub new { + my $self = bless {}, shift; + $self->reset(@_); +} + +sub reset { + my $self = shift; + my %options = @_; + + $options{name} ||= 'Simple'; + $options{dir} = File::Spec->rel2abs( + defined $options{dir} ? $options{dir} : MBTest->tmpdir + ); + + my %data = ( + no_manifest => 0, + xs => 0, + inc => 0, + %options, + ); + %$self = %data; + + tie %{$self->{filedata}}, 'Tie::CPHash'; + + tie %{$self->{pending}{change}}, 'Tie::CPHash'; + + # start with a fresh, empty directory + if ( -d $self->dirname ) { + warn "Warning: Removing existing directory '@{[$self->dirname]}'\n"; + File::Path::rmtree( $self->dirname ); + } + File::Path::mkpath( $self->dirname ); + + $self->_gen_default_filedata(); + + return $self; +} + +sub remove { + my $self = shift; + $self->chdir_original if($self->did_chdir); + File::Path::rmtree( $self->dirname ); + return $self; +} + +sub revert { + my ($self, $file) = @_; + if ( defined $file ) { + delete $self->{filedata}{$file}; + delete $self->{pending}{$_}{$file} for qw/change remove/; + } + else { + delete $self->{filedata}{$_} for keys %{ $self->{filedata} }; + for my $pend ( qw/change remove/ ) { + delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} }; + } + } + $self->_gen_default_filedata; +} + +sub _gen_default_filedata { + my $self = shift; + + # TODO maybe a public method like this (but with a better name?) + my $add_unless = sub { + my $self = shift; + my ($member, $data) = @_; + $self->add_file($member, $data) unless($self->{filedata}{$member}); + }; + + if ( ! $self->{inc} ) { + $self->$add_unless('Build.PL', undent(<<" ---")); + use strict; + use Module::Build; + + my \$builder = Module::Build->new( + module_name => '$self->{name}', + license => 'perl', + ); + + \$builder->create_build_script(); + --- + } + else { + $self->$add_unless('Build.PL', undent(<<" ---")); + use strict; + use inc::latest 'Module::Build'; + + my \$builder = Module::Build->new( + module_name => '$self->{name}', + license => 'perl', + ); + + \$builder->create_build_script(); + --- + } + + my $module_filename = + join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm'; + + unless ( $self->{xs} ) { + $self->$add_unless($module_filename, undent(<<" ---")); + package $self->{name}; + + use vars qw( \$VERSION ); + \$VERSION = '0.01'; + + use strict; + + 1; + + __END__ + + =head1 NAME + + $self->{name} - Perl extension for blah blah blah + + =head1 DESCRIPTION + + Stub documentation for $self->{name}. + + =head1 AUTHOR + + A. U. Thor, a.u.thor\@a.galaxy.far.far.away + + =cut + --- + + $self->$add_unless('t/basic.t', undent(<<" ---")); + use Test::More tests => 1; + use strict; + + use $self->{name}; + ok 1; + --- + + } else { + $self->$add_unless($module_filename, undent(<<" ---")); + package $self->{name}; + + \$VERSION = '0.01'; + + require Exporter; + require DynaLoader; + + \@ISA = qw(Exporter DynaLoader); + \@EXPORT_OK = qw( okay ); + + bootstrap $self->{name} \$VERSION; + + 1; + + __END__ + + =head1 NAME + + $self->{name} - Perl extension for blah blah blah + + =head1 DESCRIPTION + + Stub documentation for $self->{name}. + + =head1 AUTHOR + + A. U. Thor, a.u.thor\@a.galaxy.far.far.away + + =cut + --- + + my $xs_filename = + join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs'; + $self->$add_unless($xs_filename, undent(<<" ---")); + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + MODULE = $self->{name} PACKAGE = $self->{name} + + SV * + okay() + CODE: + RETVAL = newSVpv( "ok", 0 ); + OUTPUT: + RETVAL + + const char * + xs_version() + CODE: + RETVAL = XS_VERSION; + OUTPUT: + RETVAL + + const char * + version() + CODE: + RETVAL = VERSION; + OUTPUT: + RETVAL + --- + + # 5.6 is missing const char * in its typemap + $self->$add_unless('typemap', undent(<<" ---")); + const char *\tT_PV + --- + + $self->$add_unless('t/basic.t', undent(<<" ---")); + use Test::More tests => 2; + use strict; + + use $self->{name}; + ok 1; + + ok( $self->{name}::okay() eq 'ok' ); + --- + } +} + +sub _gen_manifest { + my $self = shift; + my $manifest = shift; + + my $fh = IO::File->new( ">$manifest" ) or do { + die "Can't write '$manifest'\n"; + }; + + my @files = ( 'MANIFEST', keys %{$self->{filedata}} ); + my $data = join( "\n", sort @files ) . "\n"; + print $fh $data; + close( $fh ); + + $self->{filedata}{MANIFEST} = $data; + $self->{pending}{change}{MANIFEST} = 1; +} + +sub name { shift()->{name} } + +sub dirname { + my $self = shift; + my $dist = $self->{distdir} || join( '-', split( /::/, $self->{name} ) ); + return File::Spec->catdir( $self->{dir}, $dist ); +} + +sub _real_filename { + my $self = shift; + my $filename = shift; + return File::Spec->catfile( split( /\//, $filename ) ); +} + +sub regen { + my $self = shift; + my %opts = @_; + + my $dist_dirname = $self->dirname; + + if ( $opts{clean} ) { + $self->clean() if -d $dist_dirname; + } else { + # TODO: This might leave dangling directories; e.g. if the removed file + # is 'lib/Simple/Simon.pm', the directory 'lib/Simple' will be left + # even if there are no files left in it. However, clean() will remove it. + my @files = keys %{$self->{pending}{remove}}; + foreach my $file ( @files ) { + my $real_filename = $self->_real_filename( $file ); + my $fullname = File::Spec->catfile( $dist_dirname, $real_filename ); + if ( -e $fullname ) { + 1 while unlink( $fullname ); + } + print "Unlinking pending file '$file'\n" if $VERBOSE; + delete( $self->{pending}{remove}{$file} ); + } + } + + foreach my $file ( keys( %{$self->{filedata}} ) ) { + my $real_filename = $self->_real_filename( $file ); + my $fullname = File::Spec->catfile( $dist_dirname, $real_filename ); + + if ( ! -e $fullname || + ( -e $fullname && $self->{pending}{change}{$file} ) ) { + + print "Changed file '$file'.\n" if $VERBOSE; + + my $dirname = File::Basename::dirname( $fullname ); + unless ( -d $dirname ) { + File::Path::mkpath( $dirname ) or do { + die "Can't create '$dirname'\n"; + }; + } + + if ( -e $fullname ) { + 1 while unlink( $fullname ); + } + + my $fh = IO::File->new(">$fullname") or do { + die "Can't write '$fullname'\n"; + }; + print $fh $self->{filedata}{$file}; + close( $fh ); + } + + delete( $self->{pending}{change}{$file} ); + } + + my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' ); + unless ( $self->{no_manifest} ) { + if ( -e $manifest ) { + 1 while unlink( $manifest ); + } + $self->_gen_manifest( $manifest ); + } + return $self; +} + +sub clean { + my $self = shift; + + my $here = Cwd::abs_path(); + my $there = File::Spec->rel2abs( $self->dirname() ); + + if ( -d $there ) { + chdir( $there ) or die "Can't change directory to '$there'\n"; + } else { + die "Distribution not found in '$there'\n"; + } + + my %names; + tie %names, 'Tie::CPHash'; + foreach my $file ( keys %{$self->{filedata}} ) { + my $filename = $self->_real_filename( $file ); + $filename = lc($filename) if $vms_lower_case; + my $dirname = File::Basename::dirname( $filename ); + + $names{$filename} = 0; + + print "Splitting '$dirname'\n" if $VERBOSE; + my @dirs = File::Spec->splitdir( $dirname ); + while ( @dirs ) { + my $dir = ( scalar(@dirs) == 1 + ? $dirname + : File::Spec->catdir( @dirs ) ); + if (length $dir) { + print "Setting directory name '$dir' in \%names\n" if $VERBOSE; + $names{$dir} = 0; + } + pop( @dirs ); + } + } + + File::Find::finddepth( sub { + my $name = File::Spec->canonpath( $File::Find::name ); + + if ($vms_mode) { + if ($name ne '.') { + $name =~ s/\.\z//; + $name = vmspath($name) if -d $name; + } + } + if ($^O eq 'VMS') { + $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir(); + } + + if ( not exists $names{$name} ) { + print "Removing '$name'\n" if $VERBOSE; + File::Path::rmtree( $_ ); + } + }, ($^O eq 'VMS' ? './' : File::Spec->curdir) ); + + chdir_all( $here ); + return $self; +} + +sub add_file { + my $self = shift; + $self->change_file( @_ ); +} + +sub remove_file { + my $self = shift; + my $file = shift; + unless ( exists $self->{filedata}{$file} ) { + warn "Can't remove '$file': It does not exist.\n" if $VERBOSE; + } + delete( $self->{filedata}{$file} ); + $self->{pending}{remove}{$file} = 1; + return $self; +} + +sub change_build_pl { + my ($self, @opts) = @_; + + my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts }; + + local $Data::Dumper::Terse = 1; + (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g; + + $self->change_file( 'Build.PL', undent(<<" ---") ); + use strict; + use Module::Build; + my \$b = Module::Build->new( + # Some CPANPLUS::Dist::Build versions need to allow mismatches + # On logic: thanks to Module::Install, CPAN.pm must set both keys, but + # CPANPLUS sets only the one + allow_mb_mismatch => ( + \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0 + ), + $args + ); + \$b->create_build_script(); + --- + return $self; +} + +sub change_file { + my $self = shift; + my $file = shift; + my $data = shift; + $self->{filedata}{$file} = $data; + $self->{pending}{change}{$file} = 1; + return $self; +} + +sub get_file { + my $self = shift; + my $file = shift; + exists($self->{filedata}{$file}) or croak("no such entry: '$file'"); + return $self->{filedata}{$file}; +} + +sub chdir_in { + my $self = shift; + $self->{original_dir} ||= Cwd::cwd; # only once! + my $dir = $self->dirname; + chdir($dir) or die "Can't chdir to '$dir': $!"; + return $self; +} +######################################################################## + +sub did_chdir { exists shift()->{original_dir} } + +######################################################################## + +sub chdir_original { + my $self = shift; + + my $dir = delete $self->{original_dir}; + chdir_all($dir) or die "Can't chdir to '$dir': $!"; + return $self; +} +######################################################################## + +sub new_from_context { + my ($self, @args) = @_; + require Module::Build; + return Module::Build->new_from_context( quiet => 1, @args ); +} + +sub run_build_pl { + my ($self, @args) = @_; + require Module::Build; + return Module::Build->run_perl_script('Build.PL', [], [@args]) +} + +sub run_build { + my ($self, @args) = @_; + require Module::Build; + my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build'; + return Module::Build->run_perl_script($build_script, [], [@args]) +} + +1; + +__END__ + + +=head1 NAME + +DistGen - Creates simple distributions for testing. + +=head1 SYNOPSIS + + use DistGen; + + # create distribution and prepare to test + my $dist = DistGen->new(name => 'Foo::Bar'); + $dist->chdir_in; + + # change distribution files + $dist->add_file('t/some_test.t', $contents); + $dist->change_file('MANIFEST.SKIP', $new_contents); + $dist->remove_file('t/some_test.t'); + $dist->regen; + + # undo changes and clean up extraneous files + $dist->revert; + $dist->clean; + + # exercise the command-line interface + $dist->run_build_pl(); + $dist->run_build('test'); + + # start over as a new distribution + $dist->reset( name => 'Foo::Bar', xs => 1 ); + $dist->chdir_in; + +=head1 USAGE + +A DistGen object manages a set of files in a distribution directory. + +The C<new()> constructor initializes the object and creates an empty +directory for the distribution. It does not create files or chdir into +the directory. The C<reset()> method re-initializes the object in a +new directory with new parameters. It also does not create files or change +the current directory. + +Some methods only define the target state of the distribution. They do B<not> +make any changes to the filesystem: + + add_file + change_file + change_build_pl + remove_file + revert + +Other methods then change the filesystem to match the target state of +the distribution: + + clean + regen + remove + +Other methods are provided for a convenience during testing. The +most important is the one to enter the distribution directory: + + chdir_in + +Additional methods portably encapsulate running Build.PL and Build: + + run_build_pl + run_build + +=head1 API + +=head2 Constructors + +=head3 new() + +Create a new object and an empty directory to hold the distribution's files. +If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets +a different temp directory for Perl core testing and CPAN testing. + +The C<new> method does not write any files -- see L</regen()> below. + + my $dist = DistGen->new( + name => 'Foo::Bar', + dir => MBTest->tmpdir, + xs => 1, + no_manifest => 0, + ); + +The parameters are as follows. + +=over + +=item name + +The name of the module this distribution represents. The default is +'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar" +dist name. + +=item dir + +The (parent) directory in which to create the distribution directory. The +distribution will be created under this according to C<distdir> parameter +below. Defaults to a temporary directory. + + $dist = DistGen->new( dir => '/tmp/MB-test' ); + $dist->regen; + + # distribution files have been created in /tmp/MB-test/Simple + +=item distdir + +The name of the distribution directory to create. Defaults to the dist form of +C<name>, e.g. 'Foo-Bar' if C<name> is 'Foo::Bar'. + +=item xs + +If true, generates an XS based module. + +=item no_manifest + +If true, C<regen()> will not create a MANIFEST file. + +=back + +The following files are added as part of the default distribution: + + Build.PL + lib/Simple.pm # based on name parameter + t/basic.t + +If an XS module is generated, Simple.pm and basic.t are different and +the following files are also added: + + typemap + lib/Simple.xs # based on name parameter + +=head3 reset() + +The C<reset> method re-initializes the object as if it were generated +from a fresh call to C<new>. It takes the same optional parameters as C<new>. + + $dist->reset( name => 'Foo::Bar', xs => 0 ); + +=head2 Adding and editing files + +Note that C<$filename> should always be specified with unix-style paths, +and are relative to the distribution root directory, e.g. C<lib/Module.pm>. + +No changes are made to the filesystem until the distribution is regenerated. + +=head3 add_file() + +Add a $filename containing $content to the distribution. + + $dist->add_file( $filename, $content ); + +=head3 change_file() + +Changes the contents of $filename to $content. No action is performed +until the distribution is regenerated. + + $dist->change_file( $filename, $content ); + +=head3 change_build_pl() + +A wrapper around change_file specifically for setting Build.PL. Instead +of file C<$content>, it takes a hash-ref of Module::Build constructor +arguments: + + $dist->change_build_pl( + { + module_name => $dist->name, + dist_version => '3.14159265', + license => 'perl', + create_readme => 1, + } + ); + +=head3 get_file + +Retrieves the target contents of C<$filename>. + + $content = $dist->get_file( $filename ); + +=head3 remove_file() + +Removes C<$filename> from the distribution. + + $dist->remove_file( $filename ); + +=head3 revert() + +Returns the object to its initial state, or given a $filename it returns that +file to its initial state if it is one of the built-in files. + + $dist->revert; + $dist->revert($filename); + +=head2 Changing the distribution directory + +These methods immediately affect the filesystem. + +=head3 regen() + +Regenerate all missing or changed files. Also deletes any files +flagged for removal with remove_file(). + + $dist->regen(clean => 1); + +If the optional C<clean> argument is given, it also calls C<clean>. These +can also be chained like this, instead: + + $dist->clean->regen; + +=head3 clean() + +Removes any files that are not part of the distribution. + + $dist->clean; + +=head3 remove() + +Changes back to the original directory and removes the distribution +directory (but not the temporary directory set during C<new()>). + + $dist = DistGen->new->chdir->regen; + # ... do some testing ... + + $dist->remove->chdir_in->regen; + # ... do more testing ... + +This is like a more aggressive form of C<clean>. Generally, calling C<clean> +and C<regen> should be sufficient. + +=head2 Changing directories + +=head3 chdir_in + +Change directory into the dist root. + + $dist->chdir_in; + +=head3 chdir_original + +Returns to whatever directory you were in before chdir_in() (regardless +of the cwd.) + + $dist->chdir_original; + +=head2 Command-line helpers + +These use Module::Build->run_perl_script() to ensure that Build.PL or Build are +run in a separate process using the current perl interpreter. (Module::Build +is loaded on demand). They also ensure appropriate naming for operating +systems that require a suffix for Build. + +=head3 run_build_pl + +Runs Build.PL using the current perl interpreter. Any arguments are +passed on the command line. + + $dist->run_build_pl('--quiet'); + +=head3 run_build + +Runs Build using the current perl interpreter. Any arguments are +passed on the command line. + + $dist->run_build(qw/test --verbose/); + +=head2 Properties + +=head3 name() + +Returns the name of the distribution. + + $dist->name: # e.g. Foo::Bar + +=head3 dirname() + +Returns the directory where the distribution is created. + + $dist->dirname; # e.g. t/_tmp/Simple + +=head2 Functions + +=head3 undent() + +Removes leading whitespace from a multi-line string according to the +amount of whitespace on the first line. + + my $string = undent(" foo(\n bar => 'baz'\n )"); + $string eq "foo( + bar => 'baz' + )"; + +=cut + +# vim:ts=2:sw=2:et:sta diff --git a/cpan/Module-Metadata/t/lib/MBTest.pm b/cpan/Module-Metadata/t/lib/MBTest.pm new file mode 100644 index 0000000000..005920fd8c --- /dev/null +++ b/cpan/Module-Metadata/t/lib/MBTest.pm @@ -0,0 +1,279 @@ +package MBTest; + +use strict; + +use IO::File (); +use File::Spec; +use File::Temp (); +use File::Path (); + + +# Setup the code to clean out %ENV +BEGIN { + # Environment variables which might effect our testing + my @delete_env_keys = qw( + HOME + DEVEL_COVER_OPTIONS + MODULEBUILDRC + PERL_MB_OPT + HARNESS_TIMER + HARNESS_OPTIONS + HARNESS_VERBOSE + PREFIX + INSTALL_BASE + INSTALLDIRS + ); + + # Remember the ENV values because on VMS %ENV is global + # to the user, not the process. + my %restore_env_keys; + + sub clean_env { + for my $key (@delete_env_keys) { + if( exists $ENV{$key} ) { + $restore_env_keys{$key} = delete $ENV{$key}; + } + else { + delete $ENV{$key}; + } + } + } + + END { + while( my($key, $val) = each %restore_env_keys ) { + $ENV{$key} = $val; + } + } +} + + +BEGIN { + clean_env(); + + # In case the test wants to use our other bundled + # modules, make sure they can be loaded. + my $t_lib = File::Spec->catdir('t', 'bundled'); + push @INC, $t_lib; # Let user's installed version override + + if ($ENV{PERL_CORE}) { + # We change directories, so expand @INC and $^X to absolute paths + # Also add . + @INC = (map(File::Spec->rel2abs($_), @INC), "."); + $^X = File::Spec->rel2abs($^X); + } +} + +use Exporter; +use Test::More; +use Config; +use Cwd (); + +# We pass everything through to Test::More +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +$VERSION = 0.01_01; +@ISA = qw(Test::More); # Test::More isa Exporter +@EXPORT = @Test::More::EXPORT; +%EXPORT_TAGS = %Test::More::EXPORT_TAGS; + +# We have a few extra exports, but Test::More has a special import() +# that won't take extra additions. +my @extra_exports = qw( + stdout_of + stderr_of + stdout_stderr_of + slurp + find_in_path + check_compiler + have_module + blib_load + timed_out +); +push @EXPORT, @extra_exports; +__PACKAGE__->export(scalar caller, @extra_exports); +# XXX ^-- that should really happen in import() + + +######################################################################## + +# always return to the current directory +{ + my $cwd = File::Spec->rel2abs(Cwd::cwd); + + sub original_cwd { return $cwd } + + END { + # Go back to where you came from! + chdir $cwd or die "Couldn't chdir to $cwd"; + } +} +######################################################################## + +{ # backwards compatible temp filename recipe adapted from perlfaq + my $tmp_count = 0; + my $tmp_base_name = sprintf("MB-%d-%d", $$, time()); + sub temp_file_name { + sprintf("%s-%04d", $tmp_base_name, ++$tmp_count) + } +} +######################################################################## + +# Setup a temp directory +sub tmpdir { + my ($self, @args) = @_; + my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir; + return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args); +} + +BEGIN { + $ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering +} + +sub save_handle { + my ($handle, $subr) = @_; + my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name()); + + local *SAVEOUT; + open SAVEOUT, ">&" . fileno($handle) + or die "Can't save output handle: $!"; + open $handle, "> $outfile" or die "Can't create $outfile: $!"; + + eval {$subr->()}; + open $handle, ">&SAVEOUT" or die "Can't restore output: $!"; + + my $ret = slurp($outfile); + 1 while unlink $outfile; + return $ret; +} + +sub stdout_of { save_handle(\*STDOUT, @_) } +sub stderr_of { save_handle(\*STDERR, @_) } +sub stdout_stderr_of { + my $subr = shift; + my ($stdout, $stderr); + $stdout = stdout_of ( sub { + $stderr = stderr_of( $subr ) + }); + return wantarray ? ($stdout, $stderr) : $stdout . $stderr; +} + +sub slurp { + my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!"; + local $/; + return scalar <$fh>; +} + +# Some extensions we should know about if we're looking for executables +sub exe_exts { + + if ($^O eq 'MSWin32') { + return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat'); + } + if ($^O eq 'os2') { + return qw(.exe .com .pl .cmd .bat .sh .ksh); + } + return; +} + +sub find_in_path { + my $thing = shift; + + my @exe_ext = exe_exts(); + if ( File::Spec->file_name_is_absolute( $thing ) ) { + foreach my $ext ( '', @exe_ext ) { + return "$thing$ext" if -e "$thing$ext"; + } + } + else { + my @path = split $Config{path_sep}, $ENV{PATH}; + foreach (@path) { + my $fullpath = File::Spec->catfile($_, $thing); + foreach my $ext ( '', @exe_ext ) { + return "$fullpath$ext" if -e "$fullpath$ext"; + } + } + } + return; +} + +sub check_compiler { + return (1,1) if $ENV{PERL_CORE}; + + local $SIG{__WARN__} = sub {}; + + blib_load('Module::Build'); + my $mb = Module::Build->current; + $mb->verbose( 0 ); + + my $have_c_compiler; + stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} ); + + # check noexec tmpdir + my $tmp_exec; + if ( $have_c_compiler ) { + my $dir = MBTest->tmpdir; + my $c_file = File::Spec->catfile($dir,'test.c'); + open my $fh, ">", $c_file; + print {$fh} "int main() { return 0; }\n"; + close $fh; + my $exe = $mb->cbuilder->link_executable( + objects => $mb->cbuilder->compile( source => $c_file ) + ); + $tmp_exec = 0 == system( $exe ); + } + return ($have_c_compiler, $tmp_exec); +} + +sub have_module { + my $module = shift; + return eval "require $module; 1"; +} + +sub blib_load { + # Load the given module and ensure it came from blib/, not the larger system + my $mod = shift; + have_module($mod) or die "Error loading $mod\: $@\n"; + + (my $path = $mod) =~ s{::}{/}g; + $path .= ".pm"; + my ($pkg, $file, $line) = caller; + unless($ENV{PERL_CORE}) { + unless($INC{$path} =~ m/\bblib\b/) { + (my $load_from = $INC{$path}) =~ s{$path$}{}; + die "$mod loaded from '$load_from'\nIt should have been loaded from blib. \@INC contains:\n ", + join("\n ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n"; + } + } +} + +sub timed_out { + my ($sub, $timeout) = @_; + return unless $sub; + $timeout ||= 60; + + my $saw_alarm = 0; + eval { + local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required + alarm $timeout; + $sub->(); + alarm 0; + }; + if ($@) { + die unless $@ eq "alarm\n"; # propagate unexpected errors + } + return $saw_alarm; +} + +sub check_EUI { + my $timed_out; + stdout_stderr_of( sub { + $timed_out = timed_out( sub { + ExtUtils::Installed->new(extra_libs => [@INC]) + } + ); + } + ); + return ! $timed_out; +} + +1; +# vim:ts=2:sw=2:et:sta diff --git a/cpan/Module-Metadata/t/lib/Tie/CPHash.pm b/cpan/Module-Metadata/t/lib/Tie/CPHash.pm new file mode 100644 index 0000000000..b1676221cc --- /dev/null +++ b/cpan/Module-Metadata/t/lib/Tie/CPHash.pm @@ -0,0 +1,194 @@ +#--------------------------------------------------------------------- +package Tie::CPHash; +# +# Copyright 1997 Christopher J. Madsen +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Created: 08 Nov 1997 +# $Revision$ $Date$ +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Case preserving but case insensitive hash +#--------------------------------------------------------------------- + +require 5.000; +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(); + +#===================================================================== +# Package Global Variables: + +$VERSION = '1.02'; + +#===================================================================== +# Tied Methods: +#--------------------------------------------------------------------- +# TIEHASH classname +# The method invoked by the command `tie %hash, classname'. +# Associates a new hash instance with the specified class. + +sub TIEHASH +{ + bless {}, $_[0]; +} # end TIEHASH + +#--------------------------------------------------------------------- +# STORE this, key, value +# Store datum *value* into *key* for the tied hash *this*. + +sub STORE +{ + $_[0]->{lc $_[1]} = [ $_[1], $_[2] ]; +} # end STORE + +#--------------------------------------------------------------------- +# FETCH this, key +# Retrieve the datum in *key* for the tied hash *this*. + +sub FETCH +{ + my $v = $_[0]->{lc $_[1]}; + ($v ? $v->[1] : undef); +} # end FETCH + +#--------------------------------------------------------------------- +# FIRSTKEY this +# Return the (key, value) pair for the first key in the hash. + +sub FIRSTKEY +{ + my $a = scalar keys %{$_[0]}; + &NEXTKEY; +} # end FIRSTKEY + +#--------------------------------------------------------------------- +# NEXTKEY this, lastkey +# Return the next (key, value) pair for the hash. + +sub NEXTKEY +{ + my $v = (each %{$_[0]})[1]; + ($v ? $v->[0] : undef ); +} # end NEXTKEY + +#--------------------------------------------------------------------- +# SCALAR this +# Return bucket usage information for the hash (0 if empty). + +sub SCALAR +{ + scalar %{$_[0]}; +} # end SCALAR + +#--------------------------------------------------------------------- +# EXISTS this, key +# Verify that *key* exists with the tied hash *this*. + +sub EXISTS +{ + exists $_[0]->{lc $_[1]}; +} # end EXISTS + +#--------------------------------------------------------------------- +# DELETE this, key +# Delete the key *key* from the tied hash *this*. +# Returns the old value, or undef if it didn't exist. + +sub DELETE +{ + my $v = delete $_[0]->{lc $_[1]}; + ($v ? $v->[1] : undef); +} # end DELETE + +#--------------------------------------------------------------------- +# CLEAR this +# Clear all values from the tied hash *this*. + +sub CLEAR +{ + %{$_[0]} = (); +} # end CLEAR + +#===================================================================== +# Other Methods: +#--------------------------------------------------------------------- +# Return the case of KEY. + +sub key +{ + my $v = $_[0]->{lc $_[1]}; + ($v ? $v->[0] : undef); +} + +#===================================================================== +# Package Return Value: + +1; + +__END__ + +=head1 NAME + +Tie::CPHash - Case preserving but case insensitive hash table + +=head1 SYNOPSIS + + require Tie::CPHash; + tie %cphash, 'Tie::CPHash'; + + $cphash{'Hello World'} = 'Hi there!'; + printf("The key `%s' was used to store `%s'.\n", + tied(%cphash)->key('HELLO WORLD'), + $cphash{'HELLO world'}); + +=head1 DESCRIPTION + +The B<Tie::CPHash> module provides a hash table that is case +preserving but case insensitive. This means that + + $cphash{KEY} $cphash{key} + $cphash{Key} $cphash{keY} + +all refer to the same entry. Also, the hash remembers which form of +the key was last used to store the entry. The C<keys> and C<each> +functions will return the key that was used to set the value. + +An example should make this clear: + + tie %h, 'Tie::CPHash'; + $h{Hello} = 'World'; + print $h{HELLO}; # Prints 'World' + print keys(%h); # Prints 'Hello' + $h{HELLO} = 'WORLD'; + print $h{hello}; # Prints 'WORLD' + print keys(%h); # Prints 'HELLO' + +The additional C<key> method lets you fetch the case of a specific key: + + # When run after the previous example, this prints 'HELLO': + print tied(%h)->key('Hello'); + +(The C<tied> function returns the object that C<%h> is tied to.) + +If you need a case insensitive hash, but don't need to preserve case, +just use C<$hash{lc $key}> instead of C<$hash{$key}>. This has a lot +less overhead than B<Tie::CPHash>. + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +=cut + +# Local Variables: +# tmtrack-file-task: "Tie::CPHash.pm" +# End: diff --git a/cpan/Module-Metadata/t/metadata.t b/cpan/Module-Metadata/t/metadata.t new file mode 100644 index 0000000000..7f5cd92a7b --- /dev/null +++ b/cpan/Module-Metadata/t/metadata.t @@ -0,0 +1,460 @@ +#!/usr/bin/perl -w +# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- +# vim:ts=8:sw=2:et:sta:sts=2 + +use strict; +use lib 't/lib'; +use MBTest; + +# parse various module $VERSION lines +# these will be reversed later to create %modules +my @modules = ( + '1.23' => <<'---', # declared & defined on same line with 'our' +package Simple; +our $VERSION = '1.23'; +--- + '1.23' => <<'---', # declared & defined on separate lines with 'our' +package Simple; +our $VERSION; +$VERSION = '1.23'; +--- + '1.23' => <<'---', # use vars +package Simple; +use vars qw( $VERSION ); +$VERSION = '1.23'; +--- + '1.23' => <<'---', # choose the right default package based on package/file name +package Simple::_private; +$VERSION = '0'; +package Simple; +$VERSION = '1.23'; # this should be chosen for version +--- + '1.23' => <<'---', # just read the first $VERSION line +package Simple; +$VERSION = '1.23'; # we should see this line +$VERSION = eval $VERSION; # and ignore this one +--- + '1.23' => <<'---', # just read the first $VERSION line in reopened package (1) +package Simple; +$VERSION = '1.23'; +package Error::Simple; +$VERSION = '2.34'; +package Simple; +--- + '1.23' => <<'---', # just read the first $VERSION line in reopened package (2) +package Simple; +package Error::Simple; +$VERSION = '2.34'; +package Simple; +$VERSION = '1.23'; +--- + '1.23' => <<'---', # mentions another module's $VERSION +package Simple; +$VERSION = '1.23'; +if ( $Other::VERSION ) { + # whatever +} +--- + '1.23' => <<'---', # mentions another module's $VERSION in a different package +package Simple; +$VERSION = '1.23'; +package Simple2; +if ( $Simple::VERSION ) { + # whatever +} +--- + '1.23' => <<'---', # $VERSION checked only in assignments, not regexp ops +package Simple; +$VERSION = '1.23'; +if ( $VERSION =~ /1\.23/ ) { + # whatever +} +--- + '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops +package Simple; +$VERSION = '1.23'; +if ( $VERSION == 3.45 ) { + # whatever +} +--- + '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops +package Simple; +$VERSION = '1.23'; +package Simple2; +if ( $Simple::VERSION == 3.45 ) { + # whatever +} +--- + '1.23' => <<'---', # Fully qualified $VERSION declared in package +package Simple; +$Simple::VERSION = 1.23; +--- + '1.23' => <<'---', # Differentiate fully qualified $VERSION in a package +package Simple; +$Simple2::VERSION = '999'; +$Simple::VERSION = 1.23; +--- + '1.23' => <<'---', # Differentiate fully qualified $VERSION and unqualified +package Simple; +$Simple2::VERSION = '999'; +$VERSION = 1.23; +--- + '1.23' => <<'---', # $VERSION declared as package variable from within 'main' package +$Simple::VERSION = '1.23'; +{ + package Simple; + $x = $y, $cats = $dogs; +} +--- + '1.23' => <<'---', # $VERSION wrapped in parens - space inside +package Simple; +( $VERSION ) = '1.23'; +--- + '1.23' => <<'---', # $VERSION wrapped in parens - no space inside +package Simple; +($VERSION) = '1.23'; +--- + '1.23' => <<'---', # $VERSION follows a spurious 'package' in a quoted construct +package Simple; +__PACKAGE__->mk_accessors(qw( + program socket proc + package filename line codeline subroutine finished)); + +our $VERSION = "1.23"; +--- + '1.23' => <<'---', # $VERSION using version.pm + package Simple; + use version; our $VERSION = version->new('1.23'); +--- + '1.23' => <<'---', # $VERSION using version.pm and qv() + package Simple; + use version; our $VERSION = qv('1.230'); +--- + '1.23' => <<'---', # Two version assignments, should ignore second one + $Simple::VERSION = '1.230'; + $Simple::VERSION = eval $Simple::VERSION; +--- + '1.23' => <<'---', # declared & defined on same line with 'our' +package Simple; +our $VERSION = '1.23_00_00'; +--- + '1.23' => <<'---', # package NAME VERSION + package Simple 1.23; +--- + '1.23_01' => <<'---', # package NAME VERSION + package Simple 1.23_01; +--- + 'v1.2.3' => <<'---', # package NAME VERSION + package Simple v1.2.3; +--- + 'v1.2_3' => <<'---', # package NAME VERSION + package Simple v1.2_3; +--- + '1.23' => <<'---', # trailing crud + package Simple; + our $VERSION; + $VERSION = '1.23-alpha'; +--- + '1.23' => <<'---', # trailing crud + package Simple; + our $VERSION; + $VERSION = '1.23b'; +--- + '1.234' => <<'---', # multi_underscore + package Simple; + our $VERSION; + $VERSION = '1.2_3_4'; +--- + '0' => <<'---', # non-numeric + package Simple; + our $VERSION; + $VERSION = 'onetwothree'; +--- +); +my %modules = reverse @modules; + +plan tests => 37 + 2 * keys( %modules ); + +require_ok('Module::Metadata'); + +my $tmp = MBTest->tmpdir; + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); +$dist->regen; + +$dist->chdir_in; + +######################### + +# class method C<find_module_by_name> +my $module = Module::Metadata->find_module_by_name( + 'Module::Metadata' ); +ok( -e $module, 'find_module_by_name() succeeds' ); + + +# fail on invalid module name +my $pm_info = Module::Metadata->new_from_module( + 'Foo::Bar', inc => [] ); +ok( !defined( $pm_info ), 'fail if can\'t find module by module name' ); + + +# fail on invalid filename +my $file = File::Spec->catfile( 'Foo', 'Bar.pm' ); +$pm_info = Module::Metadata->new_from_file( $file, inc => [] ); +ok( !defined( $pm_info ), 'fail if can\'t find module by file name' ); + + +# construct from module filename +$file = File::Spec->catfile( 'lib', split( /::/, $dist->name ) ) . '.pm'; +$pm_info = Module::Metadata->new_from_file( $file ); +ok( defined( $pm_info ), 'new_from_file() succeeds' ); + +# construct from module name, using custom include path +$pm_info = Module::Metadata->new_from_module( + $dist->name, inc => [ 'lib', @INC ] ); +ok( defined( $pm_info ), 'new_from_module() succeeds' ); + + +foreach my $module ( sort keys %modules ) { + my $expected = $modules{$module}; + SKIP: { + skip( "No our() support until perl 5.6", 2 ) + if $] < 5.006 && $module =~ /\bour\b/; + skip( "No package NAME VERSION support until perl 5.11.1", 2 ) + if $] < 5.011001 && $module =~ /package\s+[\w\:\']+\s+v?[0-9._]+/; + + $dist->change_file( 'lib/Simple.pm', $module ); + $dist->regen; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_ for @_ }; + my $pm_info = Module::Metadata->new_from_file( $file ); + + # Test::Builder will prematurely numify objects, so use this form + my $errs; + ok( $pm_info->version eq $expected, + "correct module version (expected '$expected')" ) + or $errs++; + is( $warnings, '', 'no warnings from parsing' ) or $errs++; + diag "Got: '@{[$pm_info->version]}'\nModule contents:\n$module" if $errs; + } +} + +# revert to pristine state +$dist->regen( clean => 1 ); + +# Find each package only once +$dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple; +$VERSION = '1.23'; +package Error::Simple; +$VERSION = '2.34'; +package Simple; +--- + +$dist->regen; + +$pm_info = Module::Metadata->new_from_file( $file ); + +my @packages = $pm_info->packages_inside; +is( @packages, 2, 'record only one occurence of each package' ); + + +# Module 'Simple.pm' does not contain package 'Simple'; +# constructor should not complain, no default module name or version +$dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple::Not; +$VERSION = '1.23'; +--- + +$dist->regen; +$pm_info = Module::Metadata->new_from_file( $file ); + +is( $pm_info->name, undef, 'no default package' ); +is( $pm_info->version, undef, 'no version w/o default package' ); + +# Module 'Simple.pm' contains an alpha version +# constructor should report first $VERSION found +$dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple; +$VERSION = '1.23_01'; +$VERSION = eval $VERSION; +--- + +$dist->regen; +$pm_info = Module::Metadata->new_from_file( $file ); + +is( $pm_info->version, '1.23_01', 'alpha version reported'); + +# NOTE the following test has be done this way because Test::Builder is +# too smart for our own good and tries to see if the version object is a +# dual-var, which breaks with alpha versions: +# Argument "1.23_0100" isn't numeric in addition (+) at +# /usr/lib/perl5/5.8.7/Test/Builder.pm line 505. + +ok( $pm_info->version > 1.23, 'alpha version greater than non'); + +# revert to pristine state +$dist->regen( clean => 1 ); + +# parse $VERSION lines scripts for package main +my @scripts = ( + <<'---', # package main declared +#!perl -w +package main; +$VERSION = '0.01'; +--- + <<'---', # on first non-comment line, non declared package main +#!perl -w +$VERSION = '0.01'; +--- + <<'---', # after non-comment line +#!perl -w +use strict; +$VERSION = '0.01'; +--- + <<'---', # 1st declared package +#!perl -w +package main; +$VERSION = '0.01'; +package _private; +$VERSION = '999'; +--- + <<'---', # 2nd declared package +#!perl -w +package _private; +$VERSION = '999'; +package main; +$VERSION = '0.01'; +--- + <<'---', # split package +#!perl -w +package main; +package _private; +$VERSION = '999'; +package main; +$VERSION = '0.01'; +--- + <<'---', # define 'main' version from other package +package _private; +$::VERSION = 0.01; +$VERSION = '999'; +--- + <<'---', # define 'main' version from other package +package _private; +$VERSION = '999'; +$::VERSION = 0.01; +--- +); + +my ( $i, $n ) = ( 1, scalar( @scripts ) ); +foreach my $script ( @scripts ) { + $dist->change_file( 'bin/simple.plx', $script ); + $dist->regen; + $pm_info = Module::Metadata->new_from_file( + File::Spec->catfile( 'bin', 'simple.plx' ) ); + + is( $pm_info->version, '0.01', "correct script version ($i of $n)" ); + $i++; +} + + +# examine properties of a module: name, pod, etc +$dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple; +$VERSION = '0.01'; +package Simple::Ex; +$VERSION = '0.02'; +=head1 NAME + +Simple - It's easy. + +=head1 AUTHOR + +Simple Simon + +=cut +--- +$dist->regen; + +$pm_info = Module::Metadata->new_from_module( + $dist->name, inc => [ 'lib', @INC ] ); + +is( $pm_info->name, 'Simple', 'found default package' ); +is( $pm_info->version, '0.01', 'version for default package' ); + +# got correct version for secondary package +is( $pm_info->version( 'Simple::Ex' ), '0.02', + 'version for secondary package' ); + +my $filename = $pm_info->filename; +ok( defined( $filename ) && -e $filename, + 'filename() returns valid path to module file' ); + +@packages = $pm_info->packages_inside; +is( @packages, 2, 'found correct number of packages' ); +is( $packages[0], 'Simple', 'packages stored in order found' ); + +# we can detect presence of pod regardless of whether we are collecting it +ok( $pm_info->contains_pod, 'contains_pod() succeeds' ); + +my @pod = $pm_info->pod_inside; +is_deeply( \@pod, [qw(NAME AUTHOR)], 'found all pod sections' ); + +is( $pm_info->pod('NONE') , undef, + 'return undef() if pod section not present' ); + +is( $pm_info->pod('NAME'), undef, + 'return undef() if pod section not collected' ); + + +# collect_pod +$pm_info = Module::Metadata->new_from_module( + $dist->name, inc => [ 'lib', @INC ], collect_pod => 1 ); + +my $name = $pm_info->pod('NAME'); +if ( $name ) { + $name =~ s/^\s+//; + $name =~ s/\s+$//; +} +is( $name, q|Simple - It's easy.|, 'collected pod section' ); + + +{ + # Make sure processing stops after __DATA__ + $dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple; +$VERSION = '0.01'; +__DATA__ +*UNIVERSAL::VERSION = sub { + foo(); +}; +--- + $dist->regen; + + $pm_info = Module::Metadata->new_from_file('lib/Simple.pm'); + is( $pm_info->name, 'Simple', 'found default package' ); + is( $pm_info->version, '0.01', 'version for default package' ); + my @packages = $pm_info->packages_inside; + is_deeply(\@packages, ['Simple'], 'packages inside'); +} + +{ + # Make sure we handle version.pm $VERSIONs well + $dist->change_file( 'lib/Simple.pm', <<'---' ); +package Simple; +$VERSION = version->new('0.60.' . (qw$Revision: 128 $)[1]); +package Simple::Simon; +$VERSION = version->new('0.61.' . (qw$Revision: 129 $)[1]); +--- + $dist->regen; + + $pm_info = Module::Metadata->new_from_file('lib/Simple.pm'); + is( $pm_info->name, 'Simple', 'found default package' ); + is( $pm_info->version, '0.60.128', 'version for default package' ); + my @packages = $pm_info->packages_inside; + is_deeply([sort @packages], ['Simple', 'Simple::Simon'], 'packages inside'); + is( $pm_info->version('Simple::Simon'), '0.61.129', 'version for embedded package' ); +} + |