X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/917949e3eede66c55d04d689749b55827e9f7fd3..cbf45e8454c586302a9f324433b3155521872636:/t/comp/parser.t diff --git a/t/comp/parser.t b/t/comp/parser.t index 0532ab3..cca4966 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -4,12 +4,56 @@ # (including weird syntax errors) BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw(. ../lib); + chdir 't'; } -require "./test.pl"; -plan( tests => 58 ); +print "1..159\n"; + +sub failed { + my ($got, $expected, $name) = @_; + + print "not ok $test - $name\n"; + my @caller = caller(1); + print "# Failed test at $caller[1] line $caller[2]\n"; + if (defined $got) { + print "# Got '$got'\n"; + } else { + print "# Got undef\n"; + } + print "# Expected $expected\n"; + return; +} + +sub like { + my ($got, $pattern, $name) = @_; + $test = $test + 1; + if (defined $got && $got =~ $pattern) { + print "ok $test - $name\n"; + # Principle of least surprise - maintain the expected interface, even + # though we aren't using it here (yet). + return 1; + } + failed($got, $pattern, $name); +} + +sub is { + my ($got, $expect, $name) = @_; + $test = $test + 1; + if (defined $expect) { + if (defined $got && $got eq $expect) { + print "ok $test - $name\n"; + return 1; + } + failed($got, "'$expect'", $name); + } else { + if (!defined $got) { + print "ok $test - $name\n"; + return 1; + } + failed($got, 'undef', $name); + } +} eval '%@x=0;'; like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' ); @@ -30,6 +74,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' ); @@ -86,11 +137,11 @@ is( $@, '', 'PL_lex_brackstack' ); is("${a}[", "A[", "interpolation, qq//"); my @b=("B"); is("@{b}{", "B{", "interpolation, qq//"); - is(qr/${a}{/, '(?-xism: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//.../"); @@ -109,7 +160,8 @@ my %data = ( foo => "\n" ); print "#"; print( $data{foo}); -pass(); +$test = $test + 1; +print "ok $test\n"; # Bug #21875 # { q.* => ... } should be interpreted as hash, not block @@ -127,7 +179,7 @@ EOF { my ($expect, $eval) = split / /, $line, 2; my $result = eval $eval; - ok($@ eq '', "eval $eval"); + is($@, '', "eval $eval"); is(ref $result, $expect ? 'HASH' : '', $eval); } @@ -135,7 +187,7 @@ EOF { local $SIG{__WARN__} = sub { }; # silence mandatory warning eval q{ my $x = -F 1; }; - like( $@, qr/(?:syntax|parse) error .* near "F 1"/, "unknown filetest operators" ); + like( $@, qr/(?i:syntax|parse) error .* near "F 1"/, "unknown filetest operators" ); is( eval q{ sub F { 42 } -F 1 }, '-42', @@ -155,15 +207,6 @@ EOF like( $@, qr/syntax error/, "use without body" ); } -# Bug #27024 -{ - # this used to segfault (because $[=1 is optimized away to a null block) - my $x; - $[ = 1 while $x; - pass(); - $[ = 0; # restore the original value for less side-effects -} - # [perl #2738] perl segfautls on input { eval q{ sub _ <> {} }; @@ -176,30 +219,392 @@ EOF like($@, qr/Illegal declaration of subroutine main::_/, "__FILE__ as prototype"); } -# [perl #36313] perl -e "1for$[=0" crash -{ - my $x; - $x = 1 for ($[) = 0; - pass('optimized assignment to $[ used to segfault in list context'); - if ($[ = 0) { $x = 1 } - pass('optimized assignment to $[ used to segfault in scalar context'); - $x = ($[=2.4); - is($x, 2, 'scalar assignment to $[ behaves like other variables'); - $x = (($[) = 0); - is($x, 1, 'list assignment to $[ behaves like other variables'); - $x = eval q{ ($[, $x) = (0) }; - like($@, qr/That use of \$\[ is unsupported/, - 'cannot assign to $[ in a list'); - eval q{ ($[) = (0, 1) }; - like($@, qr/That use of \$\[ is unsupported/, - 'cannot assign list of >1 elements to $['); - eval q{ ($[) = () }; - like($@, qr/That use of \$\[ is unsupported/, - 'cannot assign list of <1 elements to $['); -} - # tests for "Bad name" eval q{ foo::$bar }; like( $@, qr/Bad name after foo::/, 'Bad name after foo::' ); eval q{ foo''bar }; like( $@, qr/Bad name after foo'/, 'Bad name after foo\'' ); + +# test for ?: context error +eval q{($a ? $x : ($y)) = 5}; +like( $@, qr/Assignment to both a list and a scalar/, 'Assignment to both a list and a scalar' ); + +eval q{ s/x/#/e }; +is( $@, '', 'comments in s///e' ); + +# these five used to coredump because the op cleanup on parse error could +# be to the wrong pad + +eval q[ + sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; + sub { my $z +]; + +like($@, qr/Missing right curly/, 'nested sub syntax error' ); + +eval q[ + sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); + sub { my $z +]; +like($@, qr/Missing right curly/, 'nested sub syntax error 2' ); + +eval q[ + sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; + use DieDieDie; +]; + +like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup' ); + +eval q[ + sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); + use DieDieDie; +]; + +like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup 2' ); + + +eval q[ + my @a; + my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s,$r); + @a =~ s/a/b/; # compile-time error + use DieDieDie; +]; + +like($@, qr/Can't modify/, 'croak cleanup 3' ); + +# these might leak, or have duplicate frees, depending on the bugginess of +# the parser stack 'fail in reduce' cleanup code. They're here mainly as +# something to be run under valgrind, with PERL_DESTRUCT_LEVEL=1. + +eval q[ BEGIN { } ] for 1..10; +is($@, "", 'BEGIN 1' ); + +eval q[ BEGIN { my $x; $x = 1 } ] for 1..10; +is($@, "", 'BEGIN 2' ); + +eval q[ BEGIN { \&foo1 } ] for 1..10; +is($@, "", 'BEGIN 3' ); + +eval q[ sub foo2 { } ] for 1..10; +is($@, "", 'BEGIN 4' ); + +eval q[ sub foo3 { my $x; $x=1 } ] for 1..10; +is($@, "", 'BEGIN 5' ); + +eval q[ BEGIN { die } ] for 1..10; +like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 6' ); + +eval q[ BEGIN {\&foo4; die } ] for 1..10; +like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); + +{ + # RT #70934 + # check both the specific case in the ticket, and a few other paths into + # S_scan_ident() + # simplify long ids + my $x100 = "x" x 256; + my $xFE = "x" x 254; + my $xFD = "x" x 253; + my $xFC = "x" x 252; + my $xFB = "x" x 251; + + eval qq[ \$#$xFB ]; + is($@, "", "251 character \$# sigil ident ok"); + eval qq[ \$#$xFC ]; + like($@, qr/Identifier too long/, "too long id in \$# sigil ctx"); + + eval qq[ \$$xFB ]; + is($@, "", "251 character \$ sigil ident ok"); + eval qq[ \$$xFC ]; + like($@, qr/Identifier too long/, "too long id in \$ sigil ctx"); + + eval qq[ %$xFB ]; + is($@, "", "251 character % sigil ident ok"); + eval qq[ %$xFC ]; + like($@, qr/Identifier too long/, "too long id in % sigil ctx"); + + 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 ]; + is($@, "", "252 character glob ident ok"); + eval qq[ *$xFD ]; + like($@, qr/Identifier too long/, "too long id in glob ctx"); + + eval qq[ for $xFD ]; + like($@, qr/Missing \$ on loop variable/, + "253 char id ok, but a different error"); + eval qq[ for $xFE; ]; + like($@, qr/Identifier too long/, "too long id in for ctx"); + + # the specific case from the ticket + my $x = "x" x 257; + eval qq[ for $x ]; + like($@, qr/Identifier too long/, "too long id ticket case"); +} + +{ + is(exists &zlonk, '', 'sub not present'); + eval qq[ {sub zlonk} ]; + is($@, '', 'sub declaration followed by a closing curly'); + is(exists &zlonk, 1, 'sub now stubbed'); + 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{ + $_ = ""; + s/(.)/ + { + # + }->{$1}; + /e; + 1; +}; +is($@, "", "multiline whitespace inside substitute expression"); + +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/${\ <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'; + +# Check that format 'Foo still works after removing the hack from +# force_word +$test++; +format 'one = +ok @<< - format 'foo still works +$test +. +{ + local $~ = "one"; + write(); +} + +$test++; +format ::two = +ok @<< - format ::foo still works +$test +. +{ + local $~ = "two"; + write(); +} + +for(__PACKAGE__) { + eval '$_=42'; + is $_, 'main', '__PACKAGE__ is read-only'; +} + +$file = __FILE__; +BEGIN{ ${"_<".__FILE__} = \1 } +is __FILE__, $file, + 'no __FILE__ corruption when setting CopFILESV to a ref'; + +# Add new tests HERE (above this line) + +# bug #74022: Loop on characters in \p{OtherIDContinue} +# This test hangs if it fails. +eval chr 0x387; # forces loading of utf8.pm +is(1,1, '[perl #74022] Parser looping on OtherIDContinue chars'); + +# More awkward tests for #line. Keep these at the end, as they will screw +# with sane line reporting for any other test failures + +sub check ($$$) { + my ($file, $line, $name) = @_; + my (undef, $got_file, $got_line) = caller; + like ($got_file, $file, "file of $name"); + is ($got_line, $line, "line of $name"); +} + +my $this_file = qr/parser\.t(?:\.[bl]eb?)?$/; +#line 3 +1 unless +1; +check($this_file, 5, "[perl #118931]"); + +#line 3 +check($this_file, 3, "bare line"); + +# line 5 +check($this_file, 5, "bare line with leading space"); + +#line 7 +check($this_file, 7, "trailing space still valid"); + +# line 11 +check($this_file, 11, "leading and trailing"); + +# line 13 +check($this_file, 13, "leading tab"); + +#line 17 +check($this_file, 17, "middle tab"); + +#line 19 +check($this_file, 19, "loadsaspaces"); + +#line 23 KASHPRITZA +check(qr/^KASHPRITZA$/, 23, "bare filename"); + +#line 29 "KAHEEEE" +check(qr/^KAHEEEE$/, 29, "filename in quotes"); + +#line 31 "CLINK CLOINK BZZT" +check(qr/^CLINK CLOINK BZZT$/, 31, "filename with spaces in quotes"); + +#line 37 "THOOM THOOM" +check(qr/^THOOM THOOM$/, 37, "filename with tabs in quotes"); + +#line 41 "GLINK PLINK GLUNK DINK" +check(qr/^GLINK PLINK GLUNK DINK$/, 41, "a space after the quotes"); + +#line 43 "BBFRPRAFPGHPP +check(qr/^"BBFRPRAFPGHPP$/, 43, "actually missing a quote is still valid"); + +#line 47 bang eth +check(qr/^"BBFRPRAFPGHPP$/, 46, "but spaces aren't allowed without quotes"); + +#line 77sevenseven +check(qr/^"BBFRPRAFPGHPP$/, 49, "need a space after the line number"); + +eval <<'EOSTANZA'; die $@ if $@; +#line 51 "With wonderful deathless ditties|We build up the world's great cities,|And out of a fabulous story|We fashion an empire's glory:|One man with a dream, at pleasure,|Shall go forth and conquer a crown;|And three with a new song's measure|Can trample a kingdom down." +check(qr/^With.*down\.$/, 51, "Overflow the second small buffer check"); +EOSTANZA + +# And now, turn on the debugger flag for long names +$^P = 0x100; + +#line 53 "For we are afar with the dawning|And the suns that are not yet high,|And out of the infinite morning|Intrepid you hear us cry-|How, spite of your human scorning,|Once more God's future draws nigh,|And already goes forth the warning|That ye of the past must die." +check(qr/^For we.*must die\.$/, 53, "Our long line is set up"); + +eval <<'EOT'; die $@ if $@; +#line 59 " " +check(qr/^ $/, 59, "Overflow the first small buffer check only"); +EOT + +eval <<'EOSTANZA'; die $@ if $@; +#line 61 "Great hail! we cry to the comers|From the dazzling unknown shore;|Bring us hither your sun and your summers;|And renew our world as of yore;|You shall teach us your song's new numbers,|And things that we dreamed not before:|Yea, in spite of a dreamer who slumbers,|And a singer who sings no more." +check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks"); +EOSTANZA + +sub check_line ($$) { + my ($line, $name) = @_; + my (undef, undef, $got_line) = caller; + is ($got_line, $line, $name); +} + +#line 531 parser.t +<${...}/')}"; + +__END__ +# Don't add new tests HERE. See note above