diff options
Diffstat (limited to 'gnu/usr.bin/perl/t/comp')
| -rw-r--r-- | gnu/usr.bin/perl/t/comp/bproto.t | 4 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/comp/fold.t | 33 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/t/comp/form_scope.t | 70 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/comp/hints.t | 1 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/comp/parser.t | 140 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/t/comp/uproto.t | 8 |
6 files changed, 234 insertions, 22 deletions
diff --git a/gnu/usr.bin/perl/t/comp/bproto.t b/gnu/usr.bin/perl/t/comp/bproto.t index bc0f1a291bd..8d11b915c1a 100644 --- a/gnu/usr.bin/perl/t/comp/bproto.t +++ b/gnu/usr.bin/perl/t/comp/bproto.t @@ -8,7 +8,7 @@ BEGIN { @INC = '../lib'; } -print "1..14\n"; +print "1..16\n"; my $i = 1; @@ -35,12 +35,14 @@ sub test_no_error { test_too_many($_) for split /\n/, q[ defined(&foo, $bar); + pos(1,$b); undef(&foo, $bar); uc($bar,$bar); ]; test_too_few($_) for split /\n/, q[ unpack; + pack; ]; test_no_error($_) for split /\n/, diff --git a/gnu/usr.bin/perl/t/comp/fold.t b/gnu/usr.bin/perl/t/comp/fold.t index ec95f1aed80..5d6d9bf0892 100644 --- a/gnu/usr.bin/perl/t/comp/fold.t +++ b/gnu/usr.bin/perl/t/comp/fold.t @@ -4,7 +4,7 @@ # we've not yet verified that use works. # use strict; -print "1..19\n"; +print "1..26\n"; my $test = 0; # Historically constant folding was performed by evaluating the ops, and if @@ -118,3 +118,34 @@ is ($@, '', 'no error'); ok scalar $jing =~ (0 || y/fo//), 'lone y/// is not bound via =~ after || folding'; } + +# [perl #78064] or print +package other { # hide the "ok" sub + BEGIN { $^W = 0 } + print 0 ? not_ok : ok; + print " ", ++$test, " - print followed by const ? BEAR : BEAR\n"; + print 1 ? ok : not_ok; + print " ", ++$test, " - print followed by const ? BEAR : BEAR (again)\n"; + print 1 && ok; + print " ", ++$test, " - print followed by const && BEAR\n"; + print 0 || ok; + print " ", ++$test, " - print followed by const || URSINE\n"; + BEGIN { $^W = 1 } +} + +# or stat +print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL"); +print "ok ", ++$test, " - stat(const ? word : ....)\n"; +# in case we are in t/ +print "not " unless stat(1 ? TEST : 0) eq stat("TEST"); +print "ok ", ++$test, " - stat(const ? word : ....)\n"; + +# or truncate +my $n = "for_fold_dot_t$$"; +open F, ">$n" or die "open: $!"; +print F "bralh blah blah \n"; +close F or die "close $!"; +eval "truncate 1 ? $n : 0, 0;"; +print "not " unless -z $n; +print "ok ", ++$test, " - truncate(const ? word : ...)\n"; +unlink $n; diff --git a/gnu/usr.bin/perl/t/comp/form_scope.t b/gnu/usr.bin/perl/t/comp/form_scope.t index d4b5eddeb6c..2370a4bb307 100755 --- a/gnu/usr.bin/perl/t/comp/form_scope.t +++ b/gnu/usr.bin/perl/t/comp/form_scope.t @@ -1,6 +1,6 @@ #!./perl -print "1..7\n"; +print "1..14\n"; # Tests bug #22977. Test case from Dave Mitchell. sub f ($); @@ -75,13 +75,36 @@ defined $x ? "not ok 4 - $x" : "ok 4" print "ok 5 - closure var not available when outer sub is inactive\n"; } +# Formats inside closures should close over the topmost clone of the outer +# sub on the call stack. +# Tests will be out of sequence if the wrong sub is used. +sub make_closure { + my $arg = shift; + sub { + shift == 0 and &$next(1), return; + my $x = "ok $arg"; + format STDOUT4 = +@<<<<<<< +$x +. + sub { write }->(); # separate sub, so as not to rely on it being the + } # currently-running sub +} +*STDOUT = *STDOUT4{FORMAT}; +$clo1 = make_closure 6; +$clo2 = make_closure 7; +$next = $clo1; +&$clo2(0); +$next = $clo2; +&$clo1(0); + # Cloning a format whose outside has been undefined sub x { {my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$t,$u)} my $z; format STDOUT6 = @<<<<<<<<<<<<<<<<<<<<<<<<< -defined $z ? "not ok 6 - $z" : "ok 6" +defined $z ? "not ok 8 - $z" : "ok 8" . } undef &x; @@ -92,5 +115,46 @@ undef &x; local $SIG{__WARN__} = sub { $w = shift }; write; print "not " unless $w =~ /^Variable "\$z" is not available at/; - print "ok 7 - closure var not available when outer sub is undefined\n"; + print "ok 9 - closure var not available when outer sub is undefined\n"; +} + +format STDOUT7 = +@<<<<<<<<<<<<<<<<<<<<<<<<<<< +do { my $x = "ok 10 - closure inside format"; sub { $x }->() } +. +*STDOUT = *STDOUT7{FORMAT}; +write; + +$testn = 12; +format STDOUT8 = +@<<<< - recursive formats +do { my $t = "ok " . $testn--; write if $t =~ 12; $t} +. +*STDOUT = *STDOUT8{FORMAT}; +write; + +sub _13 { + my $x; +format STDOUT13 = +@* - formats closing over redefined subs +ref \$x eq 'SCALAR' ? "ok 13" : "not ok 13"; +. +} +undef &_13; +eval 'sub _13 { my @x; write }'; +*STDOUT = *STDOUT13{FORMAT}; +_13(); + +# This is a variation of bug #22977, which crashes or fails an assertion +# up to 5.16. +# Keep this test last if you want test numbers to be sane. +BEGIN { \&END } +END { + my $test = "ok 14"; + *STDOUT = *STDOUT5{FORMAT}; + write; + format STDOUT5 = +@<<<<<<< +$test +. } diff --git a/gnu/usr.bin/perl/t/comp/hints.t b/gnu/usr.bin/perl/t/comp/hints.t index a857755a4a4..9a08854d86c 100644 --- a/gnu/usr.bin/perl/t/comp/hints.t +++ b/gnu/usr.bin/perl/t/comp/hints.t @@ -4,6 +4,7 @@ BEGIN { @INC = qw(. ../lib); + chdir 't'; } BEGIN { print "1..31\n"; } diff --git a/gnu/usr.bin/perl/t/comp/parser.t b/gnu/usr.bin/perl/t/comp/parser.t index 16b4a826d1a..4f2da90f50e 100644 --- a/gnu/usr.bin/perl/t/comp/parser.t +++ b/gnu/usr.bin/perl/t/comp/parser.t @@ -3,7 +3,7 @@ # Checks if the parser behaves correctly in edge cases # (including weird syntax errors) -print "1..123\n"; +print "1..155\n"; sub failed { my ($got, $expected, $name) = @_; @@ -69,6 +69,13 @@ eval q/"\Nfoo"/; like( $@, qr/^Missing braces on \\N/, 'syntax error in string with incomplete \N' ); +eval q/"\o{"/; +like( $@, qr/^Missing right brace on \\o/, + 'syntax error in string with incomplete \o' ); +eval q/"\ofoo"/; +like( $@, qr/^Missing braces on \\o/, + 'syntax error in string with incomplete \o' ); + eval "a.b.c.d.e.f;sub"; like( $@, qr/^Illegal declaration of anonymous subroutine/, 'found by Markov chain stress testing' ); @@ -125,11 +132,11 @@ is( $@, '', 'PL_lex_brackstack' ); is("${a}[", "A[", "interpolation, qq//"); my @b=("B"); is("@{b}{", "B{", "interpolation, qq//"); - is(qr/${a}{/, '(?^:A{)', "interpolation, qr//"); + is(qr/${a}\{/, '(?^:A\{)', "interpolation, qr//"); my $c = "A{"; - $c =~ /${a}{/; + $c =~ /${a}\{/; is($&, 'A{', "interpolation, m//"); - $c =~ s/${a}{/foo/; + $c =~ s/${a}\{/foo/; is($c, 'foo', "interpolation, s/...//"); $c =~ s/foo/${a}{/; is($c, 'A{', "interpolation, s//.../"); @@ -311,9 +318,9 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); eval qq[ %$xFC ]; like($@, qr/Identifier too long/, "too long id in % sigil ctx"); - eval qq[ \\&$xFC ]; # take a ref since I don't want to call it - is($@, "", "252 character & sigil ident ok"); - eval qq[ \\&$xFD ]; + eval qq[ \\&$xFB ]; # take a ref since I don't want to call it + is($@, "", "251 character & sigil ident ok"); + eval qq[ \\&$xFC ]; like($@, qr/Identifier too long/, "too long id in & sigil ctx"); eval qq[ *$xFC ]; @@ -341,6 +348,12 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); is(defined &zlonk, '', 'but no body defined'); } +# [perl #113016] CORE::print::foo +sub CORE'print'foo { 43 } # apostrophes intentional; do not tempt fate +sub CORE'foo'bar { 43 } +is CORE::print::foo, 43, 'CORE::print::foo is not CORE::print ::foo'; +is scalar eval "CORE::foo'bar", 43, "CORE::foo'bar is not an error"; + # bug #71748 eval q{ $_ = ""; @@ -353,7 +366,99 @@ eval q{ }; is($@, "", "multiline whitespace inside substitute expression"); -# Add new tests HERE: +eval '@A =~ s/a/b/; # compilation error + sub tahi {} + sub rua; + sub toru ($); + sub wha :lvalue; + sub rima ($%&*$&*\$%\*&$%*&) :method; + sub ono :lvalue { die } + sub whitu (_) { die } + sub waru ($;) :method { die } + sub iwa { die } + BEGIN { }'; +is $::{tahi}, undef, 'empty sub decl ignored after compilation error'; +is $::{rua}, undef, 'stub decl ignored after compilation error'; +is $::{toru}, undef, 'stub+proto decl ignored after compilation error'; +is $::{wha}, undef, 'stub+attr decl ignored after compilation error'; +is $::{rima}, undef, 'stub+proto+attr ignored after compilation error'; +is $::{ono}, undef, 'sub decl with attr ignored after compilation error'; +is $::{whitu}, undef, 'sub decl w proto ignored after compilation error'; +is $::{waru}, undef, 'sub w attr+proto ignored after compilation error'; +is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error'; +is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error'; + +$test = $test + 1; +"ok $test - format inside re-eval" =~ /(?{ + format = +@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$_ +. +write +}).*/; + +eval ' +"${; + +=pod + +=cut + +}"; +'; +is $@, "", 'pod inside string in string eval'; +"${; + +=pod + +=cut + +}"; +print "ok ", ++$test, " - pod inside string outside of string eval\n"; + +like "blah blah blah\n", qr/${\ <<END +blah blah blah +END + }/, 'here docs in multiline quoted construct'; +like "blah blah blah\n", eval q|qr/${\ <<END +blah blah blah +END + }/|, 'here docs in multiline quoted construct in string eval'; + +# Unterminated here-docs in subst in eval; used to crash +eval 's/${<<END}//'; +eval 's//${<<END}/'; +print "ok ", ++$test, " - unterminated here-docs in s/// in string eval\n"; + +sub 'Hello'_he_said (_); +is prototype "Hello::_he_said", '_', 'initial tick in sub declaration'; + +{ + my @x = 'string'; + is(eval q{ "$x[0]->strung" }, 'string->strung', + 'literal -> after an array subscript within ""'); + @x = ['string']; + # this used to give "string" + like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/, + 'literal -> [0] after an array subscript within ""'); +} + +eval 'no if $] >= 5.17.4 warnings => "deprecated"'; +is 1,1, ' no crash for "no ... syntax error"'; + +for my $pkg(()){} +$pkg = 3; +is $pkg, 3, '[perl #114942] for my $foo()){} $foo'; + +eval 'Fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' + .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' + .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' + .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' + .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' + .'ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'; +like $@, "^Identifier too long at ", 'ident buffer overflow'; + +# Add new tests HERE (above this line) # bug #74022: Loop on characters in \p{OtherIDContinue} # This test hangs if it fails. @@ -437,15 +542,16 @@ eval <<'EOSTANZA'; die $@ if $@; check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks"); EOSTANZA -{ - my @x = 'string'; - is(eval q{ "$x[0]->strung" }, 'string->strung', - 'literal -> after an array subscript within ""'); - @x = ['string']; - # this used to give "string" - like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0]\z/, - 'literal -> [0] after an array subscript within ""'); -} +#line 531 parser.t +<<EOU; check('parser\.t', 531, 'on same line as heredoc'); +EOU +s//<<EOV/e if 0; +EOV +check('parser\.t', 535, 'after here-doc in quotes'); +<<EOW; +${check('parser\.t', 537, 'first line of interp in here-doc');; + check('parser\.t', 538, 'second line of interp in here-doc');} +EOW __END__ # Don't add new tests HERE. See note above diff --git a/gnu/usr.bin/perl/t/comp/uproto.t b/gnu/usr.bin/perl/t/comp/uproto.t index d3ad19f849e..f81e31411c6 100644 --- a/gnu/usr.bin/perl/t/comp/uproto.t +++ b/gnu/usr.bin/perl/t/comp/uproto.t @@ -72,7 +72,11 @@ eval q{ f(1,2,3,4) }; like( $@, qr/Too many arguments for main::f at/ ); { + # We have not tested require/use/no yet, so we must avoid this: + # no warnings 'deprecated'; + BEGIN { $SIG{__WARN__} = sub {} } my $_ = "quarante-deux"; + BEGIN { $SIG{__WARN__} = undef } $foo = "FOO"; $bar = "BAR"; f("FOO quarante-deux", $foo); @@ -97,7 +101,9 @@ $_ = $expected; g(); g; undef $expected; &g; # $_ not passed +BEGIN { $SIG{__WARN__} = sub {} } { $expected = my $_ = "bar"; g() } +BEGIN { $SIG{__WARN__} = undef } eval q{ sub wrong1 (_$); wrong1(1,2) }; like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); @@ -142,7 +148,9 @@ $_ = 21; double(); is( $_, 42, '$_ is modifiable' ); { + BEGIN { $SIG{__WARN__} = sub {} } my $_ = 22; + BEGIN { $SIG{__WARN__} = undef } double(); is( $_, 44, 'my $_ is modifiable' ); } |