From: Steve Peters Date: Tue, 10 Apr 2007 15:44:51 +0000 (+0000) Subject: Upgrade to Module-Build-0.2807 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7253302f2d3ad6cffc89ef8a0aa41e45bb4dc935;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Module-Build-0.2807 p4raw-id: //depot/perl@30893 --- diff --git a/lib/Module/Build.pm b/lib/Module/Build.pm index ce65415..aa9db8a 100644 --- a/lib/Module/Build.pm +++ b/lib/Module/Build.pm @@ -15,7 +15,7 @@ use Module::Build::Base; use vars qw($VERSION @ISA); @ISA = qw(Module::Build::Base); -$VERSION = '0.2806_01'; +$VERSION = '0.2807'; $VERSION = eval $VERSION; # Okay, this is the brute-force method of finding out what kind of @@ -162,12 +162,12 @@ action), 'test', and 'install'. Other actions defined so far include: distdir retest distmeta skipcheck distsign test - disttest testcover - docs testdb - fakeinstall testpod - help testpodcoverage - html versioninstall - install + disttest testall + docs testcover + fakeinstall testdb + help testpod + html testpodcoverage + install versioninstall You can run the 'help' action for a complete list of actions. @@ -585,6 +585,33 @@ or use a C-style pattern: ./Build test --test_files 't/01-*.t' +=item testall + +[verion 0.2807] + +[Note: the 'testall' action and the code snippets below are currently +in alpha stage, see +L<"http://www.nntp.perl.org/group/perl.module.build/2007/03/msg584.html"> ] + +Runs the C action plus each of the C actions defined by +the keys of the C parameter. + +Currently, you need to define the ACTION_test$type method yourself and +enumerate them in the test_types parameter. + + my $mb = Module::Build->subclass( + code => q( + sub ACTION_testspecial { shift->generic_test(type => 'special'); } + sub ACTION_testauthor { shift->generic_test(type => 'author'); } + ) + )->new( + ... + test_types => { + special => '.st', + author => '.at', + }, + ... + =item testcover [version 0.26] diff --git a/lib/Module/Build/API.pod b/lib/Module/Build/API.pod index 88a602b..cbb7ebb 100644 --- a/lib/Module/Build/API.pod +++ b/lib/Module/Build/API.pod @@ -1013,6 +1013,17 @@ by C. This method also creates some temporary data in a directory called C<_build/>. Both of these will be removed when the C action is performed. +Among the files created in C<_build/> is a F<_build/prereqs> file +containing the set of prerequisites for this distribution, as a hash +of hashes. This file may be C-ed to obtain the authoritative +set of prereqs, which might be different from the contents of META.yml +(because F might have set them dynamically). But fancy +developers take heed: do not put any fancy custom runtime code in the +F<_build/prereqs> file, leave it as a static declaration containing +only strings and numbers. Similarly, do not alter the structure of +the internal C<< $self->{properties}{requires} >> (etc.) data members, +because that's where this data comes from. + =item current_action() [version 0.28] @@ -1410,10 +1421,15 @@ C<"wallet">). The user will be asked the question once. If C detects that it is not running interactively and there is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable -is set to true, the $default will be used without prompting. This -prevents automated processes from blocking on user input. +is set to true, the $default will be used without prompting. + +To prevent automated processes from blocking, the user must either set +PERL_MM_USE_DEFAULT or attach something to STDIN (this can be a +pipe/file containing a scripted set of answers or /dev/null.) -If no $default is provided an empty string will be used instead. +If no $default is provided an empty string will be used instead. In +non-interactive mode, the absence of $default is an error (though +explicitly passing C as the default is valid as of 0.27.) This method may be called as a class or object method. diff --git a/lib/Module/Build/Base.pm b/lib/Module/Build/Base.pm index 76a6634..305ab58 100644 --- a/lib/Module/Build/Base.pm +++ b/lib/Module/Build/Base.pm @@ -74,7 +74,8 @@ sub resume { unless ($self->allow_mb_mismatch) { my $mb_version = $Module::Build::VERSION; die(" * ERROR: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}',\n". - " but we are now using version '$mb_version'. Please re-run the Build.PL or Makefile.PL script.\n") + " but we are now using version '$mb_version'. Please re-run the Build.PL or Makefile.PL script,\n". + " or use --allow_mb_mismatch 1 to skip this version check.\n") if $mb_version ne $self->{properties}{mb_version}; } @@ -94,7 +95,7 @@ sub new_from_context { # as it is during resume() (and thereafter). { local @ARGV = $package->unparse_args(\%args); - do 'Build.PL'; + do './Build.PL'; die $@ if $@; } return $package->resume; @@ -469,9 +470,11 @@ sub _is_interactive { return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? } +# NOTE this is a blocking operation if(-t STDIN) sub _is_unattended { my $self = shift; - return $ENV{PERL_MM_USE_DEFAULT} || ( !$self->_is_interactive && eof STDIN ); + return $ENV{PERL_MM_USE_DEFAULT} || + ( !$self->_is_interactive && eof STDIN ); } sub _readline { @@ -488,25 +491,30 @@ sub prompt { my $mess = shift or die "prompt() called without a prompt message"; - my $def; - if ( $self->_is_unattended && !@_ ) { + # use a list to distinguish a default of undef() from no default + my @def; + @def = (shift) if @_; + # use dispdef for output + my @dispdef = scalar(@def) ? + ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') : + (' ', ''); + + local $|=1; + print "$mess ", @dispdef; + + if ( $self->_is_unattended && !@def ) { die <_readline(); if ( !defined($ans) # Ctrl-D or unattended or !length($ans) ) { # User hit return - print "$def\n"; - $ans = $def; + print "$dispdef[1]\n"; + $ans = scalar(@def) ? $def[0] : ''; } return $ans; @@ -520,13 +528,6 @@ sub y_n { die "Invalid default value: y_n() default must be 'y' or 'n'" if $def && $def !~ /^[yn]/i; - if ( $self->_is_unattended && !$def ) { - die <prompt(@_); @@ -1008,7 +1009,7 @@ sub read_config { my ($self) = @_; my $file = $self->config_file('build_params') - or die "No build_params?"; + or die "Can't find 'build_params' in " . $self->config_dir; my $fh = IO::File->new($file) or die "Can't read '$file': $!"; my $ref = eval do {local $/; <$fh>}; die if $@; @@ -1857,34 +1858,32 @@ sub known_actions { } sub get_action_docs { - my ($self, $action, $actions) = @_; - $actions ||= $self->known_actions; - $@ = ''; - ($@ = "No known action '$action'\n"), return - unless $actions->{$action}; - + my ($self, $action) = @_; + my $actions = $self->known_actions; + die "No known action '$action'" unless $actions->{$action}; + my ($files_found, @docs) = (0); foreach my $class ($self->super_classes) { (my $file = $class) =~ s{::}{/}g; $file = $INC{$file . '.pm'} or next; my $fh = IO::File->new("< $file") or next; $files_found++; - + # Code below modified from /usr/bin/perldoc - + # Skip to ACTIONS section local $_; while (<$fh>) { last if /^=head1 ACTIONS\s/; } - + # Look for our action my ($found, $inlist) = (0, 0); while (<$fh>) { if (/^=item\s+\Q$action\E\b/) { - $found = 1; + $found = 1; } elsif (/^=(item|back)/) { - last if $found > 1 and not $inlist; + last if $found > 1 and not $inlist; } next unless $found; push @docs, $_; @@ -1967,8 +1966,8 @@ sub ACTION_help { my $actions = $self->known_actions; if (@{$self->{args}{ARGV}}) { - my $msg = $self->get_action_docs($self->{args}{ARGV}[0], $actions) || "$@\n"; - print $msg; + my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)}; + print $@ ? "$@\n" : $msg; return; } @@ -2013,13 +2012,62 @@ sub ACTION_retest { $self->do_tests; } +sub ACTION_testall { + my ($self) = @_; + + my @types; + for my $action (grep { $_ ne 'all' } $self->get_test_types) { + # XXX We can't just dispatch because we get multiple summaries but + # we'll need to dispatch to support custom setup/teardown in the + # action. To support that, we'll need to call something besides + # Harness::runtests() because we'll need to collect the results in + # parts, then run the summary. + push(@types, $action); + #$self->_call_action( "test$action" ); + } + $self->generic_test(types => ['default', @types]); +} + +sub get_test_types { + my ($self) = @_; + + my $t = $self->{properties}->{test_types}; + return ( defined $t ? ( keys %$t ) : () ); +} + sub ACTION_test { my ($self) = @_; + $self->generic_test(type => 'default'); +} + +sub generic_test { + my $self = shift; + (@_ % 2) and croak('Odd number of elements in argument hash'); + my %args = @_; + my $p = $self->{properties}; - + + my @types = ( + (exists($args{type}) ? $args{type} : ()), + (exists($args{types}) ? @{$args{types}} : ()), + ); + @types or croak "need some types of tests to check"; + + my %test_types = ( + default => '.t', + (defined($p->{test_types}) ? %{$p->{test_types}} : ()), + ); + + for my $type (@types) { + croak "$type not defined in test_types!" + unless defined $test_types{ $type }; + } + + # we use local here because it ends up two method calls deep + local $p->{test_file_exts} = [ @test_types{@types} ]; $self->depends_on('code'); - + # Protect others against our @INC changes local @INC = @INC; @@ -2083,8 +2131,12 @@ sub test_files { sub expand_test_dir { my ($self, $dir) = @_; - return sort @{$self->rscan_dir($dir, qr{^[^.].*\.t$})} if $self->recursive_test_files; - return sort glob File::Spec->catfile($dir, "*.t"); + my $exts = $self->{properties}{test_file_exts} || ['.t']; + + return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts + if $self->recursive_test_files; + + return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts; } sub ACTION_testdb { @@ -2263,7 +2315,7 @@ sub find_script_files { sub find_test_files { my $self = shift; my $p = $self->{properties}; - + if (my $files = $p->{test_files}) { $files = [keys %$files] if UNIVERSAL::isa($files, 'HASH'); $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ } @@ -2350,7 +2402,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' rename("$file.new", $file) or die "Can't rename $file.new to $file: $!"; - unlink "$file.bak" + $self->delete_filetree("$file.bak") or $self->log_warn("Couldn't clean up $file.bak, leaving it there"); $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':'; @@ -3995,7 +4047,8 @@ sub do_system { my %seen; my $sep = $self->config('path_sep'); local $ENV{PERL5LIB} = - ( length($ENV{PERL5LIB}) < 500 + ( !exists($ENV{PERL5LIB}) ? '' : + length($ENV{PERL5LIB}) < 500 ? $ENV{PERL5LIB} : join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB}) ); @@ -4045,7 +4098,14 @@ sub copy_if_modified { File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777)); $self->log_info("Copying $file -> $to_path\n") if $args{verbose}; - File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!"; + + if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite + chmod 0666, $to_path; + File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!"; + } else { + File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!"; + } + # mode is read-only + (executable if source is executable) my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 ); chmod( $mode, $to_path ); @@ -4137,3 +4197,5 @@ modify it under the same terms as Perl itself. perl(1), Module::Build(3) =cut + +# vim:ts=8:sw=2:et:sta:sts=2 diff --git a/lib/Module/Build/ModuleInfo.pm b/lib/Module/Build/ModuleInfo.pm index 0a05359..7241f83 100644 --- a/lib/Module/Build/ModuleInfo.pm +++ b/lib/Module/Build/ModuleInfo.pm @@ -286,20 +286,29 @@ sub _evaluate_version_line { # Some of this code came from the ExtUtils:: hierarchy. - my $eval = qq{q# Hide from _packages_inside() - #; package Module::Build::ModuleInfo::_version; - no strict; - - local $sigil$var; - \$$var=undef; do { - $line - }; \$$var - }; + # We compile into $vsub because 'use version' would cause + # compiletime/runtime issues with local() + my $vsub; + my $eval = qq{BEGIN { q# Hide from _packages_inside() + #; package Module::Build::ModuleInfo::_version; + no strict; + + local $sigil$var; + \$$var=undef; + \$vsub = sub { + $line; + \$$var + }; + }}; local $^W; - # Try and get the $VERSION - my $result = eval $eval; - warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@; + # Try to get the $VERSION + 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 = $vsub->(); # Bless it into our own version class $result = Module::Build::Version->new($result); diff --git a/lib/Module/Build/Version.pm b/lib/Module/Build/Version.pm index 1e5a657..2299946 100644 --- a/lib/Module/Build/Version.pm +++ b/lib/Module/Build/Version.pm @@ -1,7 +1,7 @@ package Module::Build::Version; use strict; -eval "use version 0.661"; +eval "use version 0.70"; if ($@) { # can't locate version files, use our own # Avoid redefined warnings if an old version.pm was available @@ -92,9 +92,9 @@ sub import { package version::vpp; use strict; -use Scalar::Util; +use locale; use vars qw ($VERSION @ISA @REGEXS); -$VERSION = 0.67; +$VERSION = 0.71; push @REGEXS, qr/ ^v? # optional leading 'v' @@ -104,15 +104,21 @@ push @REGEXS, qr/ /x; use overload ( - '""' => \&stringify, - 'cmp' => \&vcmp, - '<=>' => \&vcmp, + '""' => \&stringify, + '0+' => \&numify, + 'cmp' => \&vcmp, + '<=>' => \&vcmp, + 'bool' => \&vbool, + 'nomethod' => \&vnoop, ); sub new { my ($class, $value) = @_; my $self = bless ({}, ref ($class) || $class); + require POSIX; + my $currlocale = POSIX::setlocale(&POSIX::LC_ALL); + my $radix_comma = ( POSIX::localeconv()->{decimal_point} eq ',' ); if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison @@ -125,21 +131,21 @@ sub new $value = 'v'.$_[2]; } - # may be a v-string - if ( $] >= 5.006_002 && length($value) >= 3 && $value !~ /[._]/ ) { - my $tvalue = sprintf("%vd",$value); - if ( $tvalue =~ /^\d+\.\d+\.\d+$/ ) { - # must be a v-string - $value = $tvalue; - } - } + $value = _un_vstring($value); # exponential notation - if ( $value =~ /\d+e-?\d+/ ) { + if ( $value =~ /\d+.?\d*e-?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; } + # if the original locale used commas for decimal points, we + # just replace commas with decimal places, rather than changing + # locales + if ( $radix_comma ) { + $value =~ tr/,/./; + } + # This is not very efficient, but it is morally equivalent # to the XS code (as that is the reference implementation). # See vutil/vutil.c for details @@ -164,14 +170,20 @@ sub new # pre-scan the input string to check for decimals/underbars while ( substr($value,$pos,1) =~ /[._\d]/ ) { if ( substr($value,$pos,1) eq '.' ) { - die "Invalid version format (underscores before decimal)" - if $alpha; + if ($alpha) { + require Carp; + Carp::croak("Invalid version format ". + "(underscores before decimal)"); + } $saw_period++; $last = $pos; } elsif ( substr($value,$pos,1) eq '_' ) { - die "Invalid version format (multiple underscores)" - if $alpha; + if ($alpha) { + require Carp; + Carp::croak("Invalid version format ". + "(multiple underscores)"); + } $alpha = 1; $width = $pos - $last - 1; # natural width of sub-version } @@ -179,7 +191,13 @@ sub new } if ( $alpha && !$saw_period ) { - die "Invalid version format (alpha without decimal)"; + require Carp; + Carp::croak("Invalid version format (alpha without decimal)"); + } + + if ( $alpha && $saw_period && $width == 0 ) { + require Carp; + Carp::croak("Invalid version format (misplaced _ in number)"); } if ( $saw_period > 1 ) { @@ -226,7 +244,8 @@ sub new $rev += substr($value,$s,1) * $mult; $mult /= 10; if ( abs($orev) > abs($rev) ) { - die "Integer overflow in version"; + require Carp; + Carp::croak("Integer overflow in version"); } $s++; if ( substr($value,$s,1) eq '_' ) { @@ -240,7 +259,8 @@ sub new $rev += substr($value,$end,1) * $mult; $mult *= 10; if ( abs($orev) > abs($rev) ) { - die "Integer overflow in version"; + require Carp; + Carp::croak("Integer overflow in version"); } } } @@ -299,7 +319,8 @@ sub numify { my ($self) = @_; unless (_verify($self)) { - die "Invalid version object"; + require Carp; + Carp::croak("Invalid version object"); } my $width = $self->{width} || 3; my $alpha = $self->{alpha} || ""; @@ -339,7 +360,8 @@ sub normal { my ($self) = @_; unless (_verify($self)) { - die "Invalid version object"; + require Carp; + Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; @@ -374,7 +396,8 @@ sub stringify { my ($self) = @_; unless (_verify($self)) { - die "Invalid version object"; + require Carp; + Carp::croak("Invalid version object"); } if ( exists $self->{qv} ) { return $self->normal; @@ -397,10 +420,12 @@ sub vcmp ($left, $right) = ($right, $left); } unless (_verify($left)) { - die "Invalid version object"; + require Carp; + Carp::croak("Invalid version object"); } unless (_verify($right)) { - die "Invalid version object"; + require Carp; + Carp::croak("Invalid version object"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; @@ -451,6 +476,16 @@ sub vcmp return $retval; } +sub vbool { + my ($self) = @_; + return vcmp($self,$self->new("0"),1); +} + +sub vnoop { + require Carp; + Carp::croak("operation not supported with version object"); +} + sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); @@ -459,20 +494,21 @@ sub is_alpha { sub qv { my ($value) = @_; - my $eval = eval 'Scalar::Util::isvstring($value)'; - if ( !$@ and $eval ) { - $value = sprintf("v%vd",$value); - } - else { - $value = 'v'.$value unless $value =~ /^v/; - } + $value = _un_vstring($value); + $value = 'v'.$value unless $value =~ /^v/; return version->new($value); # always use base class } +sub is_qv { + my ($self) = @_; + return (exists $self->{qv}); +} + + sub _verify { my ($self) = @_; - if ( Scalar::Util::reftype($self) eq 'HASH' - && exists $self->{version} + if ( ref($self) + && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; @@ -482,6 +518,19 @@ sub _verify { } } +sub _un_vstring { + my $value = shift; + # may be a v-string + if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) { + my $tvalue = sprintf("%vd",$value); + if ( $tvalue =~ /^\d+\.\d+\.\d+$/ ) { + # must be a v-string + $value = $tvalue; + } + } + return $value; +} + # Thanks to Yitzchak Scott-Thoennes for this mode of operation { local $^W; @@ -491,34 +540,54 @@ sub _verify { no strict 'refs'; eval "require $class" unless %{"$class\::"}; # already existing - die "$class defines neither package nor VERSION--version check failed" - if $@ or not %{"$class\::"}; + return undef if $@ =~ /Can't locate/ and not defined $req; + + if ( not %{"$class\::"} and $] >= 5.008) { # file but no package + require Carp; + Carp::croak( "$class defines neither package nor VERSION" + ."--version check failed"); + } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { + local $^W if $] <= 5.008; $version = version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { - my $msg = "$class does not define ". - "\$$class\::VERSION--version check failed"; + require Carp; + my $msg = $] < 5.006 + ? "$class version $req required--this is only version " + : "$class does not define \$$class\::VERSION" + ."--version check failed"; + if ( $ENV{VERSION_DEBUG} ) { - require Carp; Carp::confess($msg); } else { - die($msg); + Carp::croak($msg); } } $req = version::vpp->new($req); if ( $req > $version ) { - die sprintf ("%s version %s (%s) required--". - "this is only version %s (%s)", $class, - $req->numify, $req->normal, - $version->numify, $version->normal); + require Carp; + if ( $req->is_qv ) { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->normal, $version->normal) + ); + } + else { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->numify, $version->numify) + ); + } } } diff --git a/lib/Module/Build/YAML.pm b/lib/Module/Build/YAML.pm index 1b0605f..2106308 100644 --- a/lib/Module/Build/YAML.pm +++ b/lib/Module/Build/YAML.pm @@ -104,29 +104,22 @@ sub _yaml_chunk { sub _yaml_value { my ($value) = @_; # undefs become ~ - if (! defined $value) { - return("~"); - } + return '~' if not defined $value; + # empty strings will become empty strings - elsif (! defined $value || $value eq "") { - return('""'); - } - # quote and escape strings with special values - elsif ($value =~ /["'`~\n!\@\#^\&\*\(\)\{\}\[\]\|<>\?]/) { - if ($value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/) { # nothing but " or @ or < or > (email addresses) - return("'" . $value . "'"); - } - else { - $value =~ s/\n/\\n/g; # handle embedded newlines - $value =~ s/"/\\"/g; # handle embedded quotes - return('"' . $value . '"'); - } - } + return '""' if $value eq ''; + # allow simple scalars (without embedded quote chars) to be unquoted # (includes $%_+=-\;:,./) - else { - return($value); - } + return $value if $value !~ /["'`~\n!\@\#^\&\*\(\)\{\}\[\]\|<>\?]/; + + # quote and escape strings with special values + return "'$value'" + if $value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/; # nothing but " or @ or < or > (email addresses) + + $value =~ s/\n/\\n/g; # handle embedded newlines + $value =~ s/"/\\"/g; # handle embedded quotes + return qq{"$value"}; } 1; diff --git a/lib/Module/Build/t/extend.t b/lib/Module/Build/t/extend.t index 513483c..924c9db 100644 --- a/lib/Module/Build/t/extend.t +++ b/lib/Module/Build/t/extend.t @@ -2,7 +2,7 @@ use strict; use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; -use MBTest tests => 64; +use MBTest tests => 65; use Cwd (); my $cwd = Cwd::cwd; @@ -231,10 +231,12 @@ print "Hello, World!\n"; $ENV{PERL_MM_USE_DEFAULT} = 1; eval{ $mb->y_n('Is this a question?') }; + print "\n"; # fake because the prompt prints before the checks like $@, qr/ERROR:/, 'Do not allow default-less y_n() for unattended builds'; eval{ $ans = $mb->prompt('Is this a question?') }; + print "\n"; # fake because the prompt prints before the checks like $@, qr/ERROR:/, 'Do not allow default-less prompt() for unattended builds'; @@ -266,6 +268,9 @@ print "Hello, World!\n"; $ans = $mb->y_n("Is this a question", 'y'); ok $ans, " y_n() with a default"; + + my @ans = $mb->prompt("Is this a question", undef); + is_deeply([@ans], [undef], " prompt() with undef() default"); } } diff --git a/lib/Module/Build/t/lib/MBTest.pm b/lib/Module/Build/t/lib/MBTest.pm index 35bff92..f25c840 100644 --- a/lib/Module/Build/t/lib/MBTest.pm +++ b/lib/Module/Build/t/lib/MBTest.pm @@ -74,16 +74,26 @@ sub slurp { return scalar <$fh>; } +sub exe_exts { + # Some extensions we should know about if we're looking for executables + + 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 @path = split $Config{path_sep}, $ENV{PATH}; - my @exe_ext = $^O eq 'MSWin32' ? ('', # may have extension already - split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat')) : - (''); + my @exe_ext = exe_exts(); foreach (@path) { my $fullpath = File::Spec->catfile($_, $thing); - foreach my $ext ( @exe_ext ) { + foreach my $ext ( '', @exe_ext ) { return "$fullpath$ext" if -e "$fullpath$ext"; } } diff --git a/lib/Module/Build/t/manifypods.t b/lib/Module/Build/t/manifypods.t index e66f376..cdf6a13 100644 --- a/lib/Module/Build/t/manifypods.t +++ b/lib/Module/Build/t/manifypods.t @@ -147,7 +147,7 @@ is( $mb2->{properties}->{libdoc_dirs}->[0], 'foo', 'override libdoc_dirs' ); # Make sure we can find our own action documentation ok $mb2->get_action_docs('build'); -ok !$mb2->get_action_docs('foo'); +ok !eval{$mb2->get_action_docs('foo')}; # Make sure those docs are the correct ones foreach ('testcover', 'disttest') { diff --git a/lib/Module/Build/t/metadata.t b/lib/Module/Build/t/metadata.t index d5b5ee1..6dc67a8 100644 --- a/lib/Module/Build/t/metadata.t +++ b/lib/Module/Build/t/metadata.t @@ -141,9 +141,9 @@ is_deeply($mb->find_dist_packages, { $dist->change_file( 'lib/Simple.pm', <<'---' ); package Simple; -$VERSION = version->new('0.60.' . qw$Revision: 128 $[1]); +$VERSION = version->new('0.60.' . (qw$Revision: 128 $)[1]); package Simple::Simon; -$VERSION = version->new('0.61.' . qw$Revision: 129 $[1]); +$VERSION = version->new('0.61.' . (qw$Revision: 129 $)[1]); --- $dist->regen; my $provides = new_build()->prepare_metadata()->{provides}; diff --git a/lib/Module/Build/t/moduleinfo.t b/lib/Module/Build/t/moduleinfo.t index 50c5104..b08d5a2 100644 --- a/lib/Module/Build/t/moduleinfo.t +++ b/lib/Module/Build/t/moduleinfo.t @@ -411,9 +411,9 @@ __DATA__ # 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]); +$VERSION = version->new('0.60.' . (qw$Revision: 128 $)[1]); package Simple::Simon; -$VERSION = version->new('0.61.' . qw$Revision: 129 $[1]); +$VERSION = version->new('0.61.' . (qw$Revision: 129 $)[1]); --- $dist->regen; diff --git a/lib/Module/Build/t/new_from_context.t b/lib/Module/Build/t/new_from_context.t new file mode 100644 index 0000000..b623e1f --- /dev/null +++ b/lib/Module/Build/t/new_from_context.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl -w + +use strict; +use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; +use MBTest tests => 2; + +use Cwd (); +my $cwd = Cwd::cwd; +my $tmp = File::Spec->catdir( $cwd, 't', '_tmp' ); + +use DistGen; +my $dist = DistGen->new( dir => $tmp ); + +my $libdir = 'badlib'; +$dist->add_file("$libdir/Build.PL", 'die'); +$dist->regen; + +chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!"; + +use IO::File; +use Module::Build; + +unshift(@INC, $libdir); +my $mb = eval { Module::Build->new_from_context}; +ok(! $@, 'dodged the bullet') or die; +ok($mb); + +# cleanup +chdir( $cwd ) or die "Can''t chdir to '$cwd': $!"; +$dist->remove; + +use File::Path; +rmtree( $tmp ); + +# vim:ts=2:sw=2:et:sta diff --git a/lib/Module/Build/t/ppm.t b/lib/Module/Build/t/ppm.t index c437598..09d06ff 100644 --- a/lib/Module/Build/t/ppm.t +++ b/lib/Module/Build/t/ppm.t @@ -123,7 +123,9 @@ $tar->read( $tarfile, 1 ); my $files = { map { $_ => 1 } $tar->list_files }; -exists_ok($files, 'blib/arch/auto/Simple/Simple.' . $mb->config('dlext')); +my $fname = 'Simple'; +$fname = DynaLoader::mod2fname([$fname]) if defined &DynaLoader::mod2fname; +exists_ok($files, "blib/arch/auto/Simple/$fname." . $mb->config('dlext')); exists_ok($files, 'blib/lib/Simple.pm'); exists_ok($files, 'blib/script/hello'); diff --git a/lib/Module/Build/t/test_type.t b/lib/Module/Build/t/test_type.t new file mode 100644 index 0000000..5608d6e --- /dev/null +++ b/lib/Module/Build/t/test_type.t @@ -0,0 +1,72 @@ +#!/usr/bin/perl -w + +use strict; +use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; +use MBTest tests => 8; + +use Cwd (); +my $cwd = Cwd::cwd; +my $tmp = File::Spec->catdir( $cwd, 't', '_tmp' ); + +use DistGen; + +my $dist = DistGen->new( dir => $tmp ); + + +$dist->add_file('t/special_ext.st', <<'---' ); +#!perl +use Test::More tests => 2; +ok(1, 'first test in special_ext'); +ok(1, 'second test in special_ext'); +--- + +$dist->regen; + +chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!"; + +######################### + +use_ok 'Module::Build'; + +# Here we make sure we can define an action that will test a particular type +$::x = 0; +my $mb = Module::Build->subclass( + code => q# + sub ACTION_testspecial { + $::x++; + shift->generic_test(type => 'special'); + } + # +)->new( + module_name => $dist->name, + test_types => { special => '.st' } +); + +ok $mb; + +$mb->dispatch('testspecial'); +is($::x, 1, "called once"); + + +$mb->add_to_cleanup('save_out'); +# Use uc() so we don't confuse the current test output +my $verbose_output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 1)} +)); + +like($verbose_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m); +like($verbose_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m); + +is( $::x, 2, "called again"); + +my $output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 0)} +)); +like($output, qr/\.\.OK/); + +is($::x, 3, "called a third time"); + +chdir( $cwd ) or die "Can't chdir to '$cwd': $!"; +$dist->remove; + +# vim:ts=4:sw=4:et:sta diff --git a/lib/Module/Build/t/test_types.t b/lib/Module/Build/t/test_types.t new file mode 100644 index 0000000..86bb0df --- /dev/null +++ b/lib/Module/Build/t/test_types.t @@ -0,0 +1,186 @@ +#!/usr/bin/perl -w + +use strict; +use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; +use MBTest tests => 14 + 12; + +use Cwd (); +my $cwd = Cwd::cwd(); +my $tmp = File::Spec->catdir($cwd, 't', '_tmp'); + +use DistGen; + +my $dist = DistGen->new(dir => $tmp); + +$dist->add_file('t/special_ext.st', <<'---'); +#!perl +use Test::More tests => 2; +ok(1, 'first test in special_ext'); +ok(1, 'second test in special_ext'); +--- + +$dist->add_file('t/another_ext.at', <<'---'); +#!perl +use Test::More tests => 2; +ok(1, 'first test in another_ext'); +ok(1, 'second test in another_ext'); +--- +$dist->add_file('t/foo.txt', <<'---'); +#!perl +use Test::More tests => 1; +ok 0, "don't run this non-test file"; +die "don't run this non-test file"; +--- + +$dist->regen; + +chdir($dist->dirname) or die "Can't chdir to '@{[$dist->dirname]}': $!"; + +######################### + +use_ok 'Module::Build'; + +my $mb = Module::Build->subclass( + code => q# + sub ACTION_testspecial { + shift->generic_test(type => 'special'); + } + + sub ACTION_testanother { + shift->generic_test(type => 'another'); + } + # + )->new( + module_name => $dist->name, + test_types => { + special => '.st', + another => '.at', + }, + ); + + +ok $mb; + +my $special_output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 1)} +)); + +like($special_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'saw expected output from first test'); +like($special_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'saw expected output from second test'); + +my $another_output = uc(stdout_of( + sub {$mb->dispatch('testanother', verbose => 1)} +)); + +ok($another_output, 'we have some test output'); + +like($another_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m, + 'saw expected output from first test'); +like($another_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m, + 'saw expected output from second test'); + + +my $all_output = uc(stdout_of( + sub {$mb->dispatch('testall', verbose => 1)} +)); + +0 and warn "\ntestall said >>>\n$all_output\n<<<\n"; + +like($all_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); +like($all_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); + +like($all_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m); +like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m); + +# we get a third one from basic.t +is(scalar(@{[$all_output =~ m/OK 1/mg]}), 3 ); +is(scalar(@{[$all_output =~ m/OK/mg]}), 8 ); +is(scalar(@{[$all_output =~ m/ALL TESTS SUCCESSFUL\./mg]}), 1); + +chdir($cwd) or die "Can't chdir to '$cwd': $!"; +$dist->remove; + +{ # once-again + +$dist->add_file('t/foo/special.st', <<'---'); +#!perl +use Test::More tests => 2; +ok(1, 'first test in special_ext'); +ok(1, 'second test in special_ext'); +--- +$dist->add_file('t/foo/basic_foo.t', <<'---'); +use Test::More tests => 1; +use strict; use Simple; +ok 1; +--- +$dist->regen; + +chdir($dist->dirname) or die "Can't chdir to '@{[$dist->dirname]}': $!"; + +my $mb = Module::Build->subclass( + code => q# + sub ACTION_testspecial { + shift->generic_test(type => 'special'); + } + + sub ACTION_testanother { + shift->generic_test(type => 'another'); + } + # + )->new( + recursive_test_files => 1, + module_name => $dist->name, + test_types => { + special => '.st', + another => '.at', + }, + ); + +ok $mb; + +my $special_output = uc(stdout_of( + sub {$mb->dispatch('testspecial', verbose => 1)} +)); + +like($special_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'saw expected output from first test'); +like($special_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'saw expected output from second test'); + +my $another_output = uc(stdout_of( + sub {$mb->dispatch('testanother', verbose => 1)} +)); + +ok($another_output, 'we have some test output'); + +like($another_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m, + 'saw expected output from first test'); +like($another_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m, + 'saw expected output from second test'); + + +my $all_output = uc(stdout_of( + sub {$mb->dispatch('testall', verbose => 1)} +)); + +like($all_output, qr/^OK 1 - FIRST TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); +like($all_output, qr/^OK 2 - SECOND TEST IN SPECIAL_EXT/m, + 'expected output from basic.t'); + +like($all_output, qr/^OK 1 - FIRST TEST IN ANOTHER_EXT/m); +like($all_output, qr/^OK 2 - SECOND TEST IN ANOTHER_EXT/m); + +# we get a third one from basic.t +is(scalar(@{[$all_output =~ m/(OK 1)/mg]}), 5 ); +is(scalar(@{[$all_output =~ m/(OK)/mg]}), 13 ); + +chdir($cwd) or die "Can't chdir to '$cwd': $!"; +$dist->remove; +} # end once-again + +# vim:ts=4:sw=4:et:sta diff --git a/lib/Module/Build/t/tilde.t b/lib/Module/Build/t/tilde.t index 3d42933..13a3f4f 100644 --- a/lib/Module/Build/t/tilde.t +++ b/lib/Module/Build/t/tilde.t @@ -4,7 +4,7 @@ use strict; use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib'; -use MBTest tests => 11; +use MBTest tests => 10; use Cwd (); my $cwd = Cwd::cwd; @@ -46,9 +46,6 @@ sub run_sample { $mb = run_sample( install_base => '~/foo' ); is( $mb->install_base, "$ENV{HOME}/foo" ); - $mb = run_sample( install_base => '~~' ); - is( $mb->install_base, '~~' ); - $mb = run_sample( install_base => 'foo~' ); is( $mb->install_base, 'foo~' );