In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/d190dde9b72a7c306622389007b0dba86901ce52?hp=45d67106f8acd7bf2229260c4804817a9c1c2578>
- Log ----------------------------------------------------------------- commit d190dde9b72a7c306622389007b0dba86901ce52 Author: Nicolas R <[email protected]> Date: Thu Sep 14 14:52:37 2017 -0600 test - Do not run test output at compilation time Even if in most of the cases it seems ok to print output during compilation time, this is a pretty bad idea (when compiling the test for example). Run all the tests at compile time, but only print the test status at run time. (Trailing whitespace cleanup by committer.) For: RT # 132092 M t/op/array_base.t M t/op/caller.t commit c21c9dc52daa35bc02d509e7cf6cb7f3a33dcc36 Author: Nicolas R <[email protected]> Date: Thu Sep 14 14:52:19 2017 -0600 test - Do not use B which is a reserved namespace B is already a reserved namespace. This is a bad idea to use B during unit test, as this increase the complexity when using one of the B subpackage to run the test. Simply rename B to BB ( and A to AA ). (Whitesapce cleanup by committer.) For: RT # 132092 M t/mro/next_inanon.t M t/mro/next_ineval.t M t/op/method.t commit 8b07d9e2085efc07ae6203ced3ea96189339a52e Author: Nicolas R <[email protected]> Date: Thu Sep 14 14:51:42 2017 -0600 tests - remove useless setting in BEGIN These two tests are not using test.pl and do not need to load any special file. No need for fancy setup in BEGIN, all the most we cannot use the generic set_up_inc helper. Simply remove the useless BEGIN block. M t/comp/bproto.t M t/opbasic/cmp.t commit 1ce8be81dfaf09bc8a07faeba2fd9a3a0e4012be Author: Nicolas R <[email protected]> Date: Thu Sep 14 14:51:13 2017 -0600 tests - Use set_up_inc helper to set @INC Test plan should not be declared at compile time M t/comp/parser_run.t M t/op/threads-dirh.t M t/re/anyof.t ----------------------------------------------------------------------- Summary of changes: t/comp/bproto.t | 6 +---- t/comp/parser_run.t | 4 +-- t/mro/next_inanon.t | 18 ++++++------- t/mro/next_ineval.t | 16 ++++++------ t/op/array_base.t | 25 ++++++++++-------- t/op/caller.t | 75 +++++++++++++++++++++++++++++++++++++---------------- t/op/method.t | 60 +++++++++++++++++++++--------------------- t/op/threads-dirh.t | 16 ++++++------ t/opbasic/cmp.t | 5 ---- t/re/anyof.t | 6 +++-- 10 files changed, 129 insertions(+), 102 deletions(-) diff --git a/t/comp/bproto.t b/t/comp/bproto.t index 8d11b915c1..cc91242140 100644 --- a/t/comp/bproto.t +++ b/t/comp/bproto.t @@ -3,11 +3,7 @@ # check if builtins behave as prototyped # -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - +# Ideally tests in t/comp wouldn't use require, as require isn't tested yet print "1..16\n"; my $i = 1; diff --git a/t/comp/parser_run.t b/t/comp/parser_run.t index af35758bee..eba4b9fba8 100644 --- a/t/comp/parser_run.t +++ b/t/comp/parser_run.t @@ -5,11 +5,11 @@ # Note that this should still be runnable under miniperl. BEGIN { - @INC = qw(. ../lib ); chdir 't' if -d 't'; + require './test.pl'; + set_up_inc( qw(. ../lib ) ); } -require './test.pl'; plan(4); # [perl #130814] can reallocate lineptr while looking ahead for diff --git a/t/mro/next_inanon.t b/t/mro/next_inanon.t index b6f0451611..4c3c007d6e 100644 --- a/t/mro/next_inanon.t +++ b/t/mro/next_inanon.t @@ -13,26 +13,26 @@ anonymous subroutine. =cut { - package A; + package AA; use mro 'c3'; sub foo { - return 'A::foo'; + return 'AA::foo'; } sub bar { - return 'A::bar'; + return 'AA::bar'; } } { - package B; - use base 'A'; + package BB; + use base 'AA'; use mro 'c3'; sub foo { my $code = sub { - return 'B::foo => ' . (shift)->next::method(); + return 'BB::foo => ' . (shift)->next::method(); }; return (shift)->$code; } @@ -40,7 +40,7 @@ anonymous subroutine. sub bar { my $code1 = sub { my $code2 = sub { - return 'B::bar => ' . (shift)->next::method(); + return 'BB::bar => ' . (shift)->next::method(); }; return (shift)->$code2; }; @@ -48,10 +48,10 @@ anonymous subroutine. } } -is(B->foo, "B::foo => A::foo", +is(BB->foo, "BB::foo => AA::foo", 'method resolved inside anonymous sub'); -is(B->bar, "B::bar => A::bar", +is(BB->bar, "BB::bar => AA::bar", 'method resolved inside nested anonymous subs'); diff --git a/t/mro/next_ineval.t b/t/mro/next_ineval.t index f8c13a6413..14a49b1c6b 100644 --- a/t/mro/next_ineval.t +++ b/t/mro/next_ineval.t @@ -12,23 +12,23 @@ This tests the use of an eval{} block to wrap a next::method call. =cut { - package A; + package AA; use mro 'c3'; sub foo { - die 'A::foo died'; - return 'A::foo succeeded'; + die 'AA::foo died'; + return 'AA::foo succeeded'; } } { - package B; - use base 'A'; + package BB; + use base 'AA'; use mro 'c3'; sub foo { eval { - return 'B::foo => ' . (shift)->next::method(); + return 'BB::foo => ' . (shift)->next::method(); }; if ($@) { @@ -37,8 +37,8 @@ This tests the use of an eval{} block to wrap a next::method call. } } -like(B->foo, - qr/^A::foo died/, +like(BB->foo, + qr/^AA::foo died/, 'method resolved inside eval{}'); diff --git a/t/op/array_base.t b/t/op/array_base.t index a30236d955..f1c4b37111 100644 --- a/t/op/array_base.t +++ b/t/op/array_base.t @@ -1,22 +1,25 @@ #!perl -w use strict; +my %begin_tests; BEGIN { chdir 't' if -d 't'; require './test.pl'; + use v5.15; + # Run these at BEGIN time, before arybase loads + $begin_tests{123} = eval('$[ = 1; 123'); + $begin_tests{error} = $@; +} - plan (tests => my $tests = 11); +plan (tests => my $tests = 11); # plan should not be set at compile time - # Run these at BEGIN time, before arybase loads - use v5.15; - is(eval('$[ = 1; 123'), undef); - like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/); +is($begin_tests{123}, undef); +like($begin_tests{error}, qr/\AAssigning non-zero to \$\[ is no longer possible/); - if (is_miniperl()) { +if (is_miniperl()) { # skip the rest SKIP: { skip ("no arybase.xs on miniperl", $tests-2) } exit; - } } no warnings 'deprecated'; @@ -25,17 +28,17 @@ is(eval('$['), 0); is(eval('$[ = 0; 123'), 123); is(eval('$[ = 1; 123'), 123); $[ = 1; -ok $INC{'arybase.pm'}; +ok($INC{'arybase.pm'}, "arybase is in INC"); use v5.15; is(eval('$[ = 1; 123'), undef); like($@, qr/\AAssigning non-zero to \$\[ is no longer possible/); -is $[, 0, '$[ is 0 under 5.16'; +is($[, 0, '$[ is 0 under 5.16'); $_ = "hello"; /l/g; my $pos = \pos; -is $$pos, 3; +is($$pos, 3); $$pos = 1; -is $$pos, 1; +is($$pos, 1); 1; diff --git a/t/op/caller.t b/t/op/caller.t index 1ffb5b3443..29f889e4ee 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,12 +5,20 @@ BEGIN { chdir 't' if -d 't'; require './test.pl'; set_up_inc('../lib'); - plan( tests => 100 ); # some tests are run in a BEGIN block } -my @c; +my @tests; +plan( tests => 100 ); + +print "# Tests with caller(0)\n"; + +foreach my $t ( @tests ) { + my $s = \&{'main::'.$t->{type}}; + $s->( @{$t->{args}}, $t->{txt} ); +} +print "# end of BEGIN tests\n"; -BEGIN { print "# Tests with caller(0)\n"; } +my @c; @c = caller(0); ok( (!@c), "caller(0) in main program" ); @@ -36,8 +44,8 @@ ok( $c[4], "hasargs true with deleted sub" ); BEGIN { require strict; - is +(caller 0)[1], __FILE__, - "[perl #68712] filenames after require in a BEGIN block" + push @tests, { type => 'is', args => [ +(caller 0)[1], __FILE__ ], + txt => "[perl #68712] filenames after require in a BEGIN block" }; } print "# Tests with caller(1)\n"; @@ -97,6 +105,18 @@ sub testwarn { check_bits( (caller(0))[9], $w, "warnings match caller ($id)"); } +sub get_caller_0_9 { + return (caller(0))[9]; +} + +sub get_caller_0_9 { + return (caller(0))[9]; +} + +sub get_caller_0_9 { + return (caller(0))[9]; +} + { no warnings; # Build the warnings mask dynamically @@ -109,28 +129,35 @@ sub testwarn { vec($registered, $warnings::LAST_BIT/2, 2) = 1; } - BEGIN { check_bits( ${^WARNING_BITS}, "\0" x $warnings::BYTES, 'all bits off via "no warnings"' ) } + BEGIN { + push @tests, { type => 'check_bits', args => [ ${^WARNING_BITS}, "\0" x $warnings::BYTES ], + txt => 'all bits off via "no warnings"' }; + } testwarn("\0" x $warnings::BYTES, 'no bits'); use warnings; - BEGIN { check_bits( ${^WARNING_BITS}, $default, - 'default bits on via "use warnings"' ); } - BEGIN { testwarn($default, 'all'); } + BEGIN { + push @tests, { type => 'check_bits', args => [ ${^WARNING_BITS}, $default ], txt => 'default bits on via "use warnings"' }; + } + BEGIN { + push @tests, { type => 'check_bits', args => [ get_caller_0_9(), $default ], txt => 'warnings match caller' }; + } # run-time : # the warning mask has been extended by warnings::register testwarn($registered, 'ahead of w::r'); use warnings::register; - BEGIN { check_bits( ${^WARNING_BITS}, $registered, - 'warning bits on via "use warnings::register"' ) } + BEGIN { + push @tests, { type => 'check_bits', args => [ ${^WARNING_BITS}, $registered ], txt => 'warning bits on via "use warnings::register"' }; + } testwarn($registered, 'following w::r'); } # The next two cases test for a bug where caller ignored evals if -# the DB::sub glob existed but &DB::sub did not (for example, if +# the DB::sub glob existed but &DB::sub did not (for example, if # $^P had been set but no debugger has been loaded). The tests -# thus assume that there is no &DB::sub: if there is one, they +# thus assume that there is no &DB::sub: if there is one, they # should both pass no matter whether or not this bug has been # fixed. @@ -316,7 +343,7 @@ is $line, "3000000000", "check large line numbers are preserved"; # This was fixed with commit d4d03940c58a0177, which fixed bug #78742 fresh_perl_is <<'END', "__ANON__::doof\n", {}, package foo; -BEGIN {undef %foo::} +INIT {undef %foo::} # adjust test for B::C sub doof { caller(0) } print +(doof())[3]; END @@ -340,10 +367,10 @@ TODO: { my ($package, $file, $line) = caller; print "$line\n"; } - + tagCall "abc"; - + tagCall sub {}; EOP @@ -357,12 +384,16 @@ do './op/caller.pl' or die $@; package RT129239; BEGIN { my ($pkg, $file, $line) = caller; - ::is $file, 'virtually/op/caller.t', "BEGIN block sees correct caller filename"; - ::is $line, 12345, "BEGIN block sees correct caller line"; - TODO: { - local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]"; - ::is $pkg, 'RT129239', "BEGIN block sees correct caller package"; - } +# push @tests, { type => 'is', args => [ +(caller 0)[1], __FILE__ ], +# txt => "[perl #68712] filenames after require in a BEGIN block" }; + + push @tests, { type => 'is', args => [ $file, 'virtually/op/caller.t' ], txt => "BEGIN block sees correct caller filename" }; + push @tests, { type => 'is', args => [ $line, 12345 ], txt => "BEGIN block sees correct caller line" }; + #TODO: { + # local $::TODO = "BEGIN blocks have wrong caller package [perl #129239]"; + # push @tests, { type => is, args => [ $pkg, 'RT129239' ], txt => "BEGIN block sees correct caller package" }; + #} + push @tests, { type => 'ok', txt => 'SKIPPING the BEGIN TODO test above' }; #line 12345 "virtually/op/caller.t" } } diff --git a/t/op/method.t b/t/op/method.t index ef181c4ce0..82f8263a10 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -15,8 +15,8 @@ no warnings 'once'; plan(tests => 151); -@A::ISA = 'B'; -@B::ISA = 'C'; +@A::ISA = 'BB'; +@BB::ISA = 'C'; sub C::d {"C::d"} sub D::d {"D::d"} @@ -55,7 +55,7 @@ is(method $obj, "method"); is( A->d, "C::d"); # Update hash table; -*B::d = \&D::d; # Import now. +*BB::d = \&D::d; # Import now. is(A->d, "D::d"); # Update hash table; { @@ -67,42 +67,42 @@ is(A->d, "D::d"); # Update hash table; is(A->d, "D::d"); { - local *B::d; - eval 'sub B::d {"B::d1"}'; # Import now. - is(A->d, "B::d1"); # Update hash table; - undef &B::d; + local *BB::d; + eval 'sub BB::d {"BB::d1"}'; # Import now. + is(A->d, "BB::d1"); # Update hash table; + undef &BB::d; is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); } is(A->d, "D::d"); # Back to previous state -eval 'no warnings "redefine"; sub B::d {"B::d2"}'; # Import now. -is(A->d, "B::d2"); # Update hash table; +eval 'no warnings "redefine"; sub BB::d {"BB::d2"}'; # Import now. +is(A->d, "BB::d2"); # Update hash table; # What follows is hardly guarantied to work, since the names in scripts -# are already linked to "pruned" globs. Say, 'undef &B::d' if it were -# after 'delete $B::{d}; sub B::d {}' would reach an old subroutine. +# are already linked to "pruned" globs. Say, 'undef &BB::d' if it were +# after 'delete $BB::{d}; sub BB::d {}' would reach an old subroutine. -undef &B::d; -delete $B::{d}; +undef &BB::d; +delete $BB::{d}; is(A->d, "C::d"); -eval 'sub B::d {"B::d2.5"}'; +eval 'sub BB::d {"BB::d2.5"}'; A->d; # Update hash table; -my $glob = \delete $B::{d}; # non-void context; hang on to the glob +my $glob = \delete $BB::{d}; # non-void context; hang on to the glob is(A->d, "C::d"); # Update hash table; -eval 'sub B::d {"B::d3"}'; # Import now. -is(A->d, "B::d3"); # Update hash table; +eval 'sub BB::d {"BB::d3"}'; # Import now. +is(A->d, "BB::d3"); # Update hash table; -delete $B::{d}; +delete $BB::{d}; *dummy::dummy = sub {}; # Mark as updated is(A->d, "C::d"); -eval 'sub B::d {"B::d4"}'; # Import now. -is(A->d, "B::d4"); # Update hash table; +eval 'sub BB::d {"BB::d4"}'; # Import now. +is(A->d, "BB::d4"); # Update hash table; -delete $B::{d}; # Should work without any help too +delete $BB::{d}; # Should work without any help too is(A->d, "C::d"); { @@ -119,23 +119,23 @@ my $counter; eval <<'EOF'; sub C::e; -BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg +BEGIN { *BB::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg sub Y::f; $counter = 0; @X::ISA = 'Y'; -@Y::ISA = 'B'; +@Y::ISA = 'BB'; -sub B::AUTOLOAD { +sub BB::AUTOLOAD { my $c = ++$counter; - my $method = $B::AUTOLOAD; + my $method = $BB::AUTOLOAD; my $msg = "B: In $method, $c"; eval "sub $method { \$msg }"; goto &$method; } sub C::AUTOLOAD { my $c = ++$counter; - my $method = $C::AUTOLOAD; + my $method = $C::AUTOLOAD; my $msg = "C: In $method, $c"; eval "sub $method { \$msg }"; goto &$method; @@ -157,10 +157,10 @@ is(Y->f(), "B: In Y::f, 3"); # Which sticks { no warnings 'redefine'; -*B::AUTOLOAD = sub { +*BB::AUTOLOAD = sub { use warnings; my $c = ++$counter; - my $method = $::AUTOLOAD; + my $method = $::AUTOLOAD; no strict 'refs'; *$::AUTOLOAD = sub { "new B: In $method, $c" }; goto &$::AUTOLOAD; @@ -198,7 +198,7 @@ my $e; eval '$e = bless {}, "E::A"; E::A->foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::A" at/); -eval '$e = bless {}, "E::B"; $e->foo()'; +eval '$e = bless {}, "E::B"; $e->foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::B" at/); eval 'E::C->foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::C" (perhaps /); @@ -233,7 +233,7 @@ sub OtherSouper::method { "Isidore Ropen, Draft Manager" } @ret = OtherSaab->SUPER::method; ::is $ret[0], 'OtherSaab', "->SUPER::method uses current package, not invocant"; -} +} () = *SUPER::; { local our @ISA = "Souper"; diff --git a/t/op/threads-dirh.t b/t/op/threads-dirh.t index e1d5c996ad..82d90768ab 100644 --- a/t/op/threads-dirh.t +++ b/t/op/threads-dirh.t @@ -4,21 +4,21 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); $| = 1; - require Config; - skip_all_without_config('useithreads'); - skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); - - plan(6); } +skip_all_without_config('useithreads'); +skip_all_if_miniperl("no dynamic loading on miniperl, no threads"); + +plan(6); + use strict; use warnings; -use threads; -use threads::shared; +eval q/use threads/; +eval q/use threads::shared/; use File::Path; use File::Spec::Functions qw 'updir catdir'; use Cwd 'getcwd'; diff --git a/t/opbasic/cmp.t b/t/opbasic/cmp.t index 241eb491a6..5a88d21d0b 100644 --- a/t/opbasic/cmp.t +++ b/t/opbasic/cmp.t @@ -1,10 +1,5 @@ #!./perl -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - # This file has been placed in t/opbasic to indicate that it should not use # functions imported from t/test.pl or Test::More, as those programs/libraries # use operators which are what is being tested in this file. diff --git a/t/re/anyof.t b/t/re/anyof.t index 84f2881e0d..d24e4a71a8 100644 --- a/t/re/anyof.t +++ b/t/re/anyof.t @@ -1,3 +1,5 @@ +#!./perl + use utf8; # This tests that the ANYOF nodes generated by bracketed character classes are @@ -10,9 +12,9 @@ use utf8; BEGIN { chdir 't' if -d 't'; - @INC = ('../lib','.','../ext/re'); - require Config; import Config; require './test.pl'; + set_up_inc('../lib','.','../ext/re'); + require Config; import Config; skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader; } -- Perl5 Master Repository
