1#!./perl 2 3# Checks if the parser behaves correctly in edge cases 4# (including weird syntax errors) 5 6BEGIN { 7 @INC = qw(. ../lib); 8 chdir 't' if -d 't'; 9} 10 11print "1..191\n"; 12 13sub failed { 14 my ($got, $expected, $name) = @_; 15 16 print "not ok $test - $name\n"; 17 my @caller = caller(1); 18 print "# Failed test at $caller[1] line $caller[2]\n"; 19 if (defined $got) { 20 print "# Got '$got'\n"; 21 } else { 22 print "# Got undef\n"; 23 } 24 print "# Expected $expected\n"; 25 return; 26} 27 28sub like { 29 my ($got, $pattern, $name) = @_; 30 $test = $test + 1; 31 if (defined $got && $got =~ $pattern) { 32 print "ok $test - $name\n"; 33 # Principle of least surprise - maintain the expected interface, even 34 # though we aren't using it here (yet). 35 return 1; 36 } 37 failed($got, $pattern, $name); 38} 39 40sub is { 41 my ($got, $expect, $name) = @_; 42 $test = $test + 1; 43 if (defined $expect) { 44 if (defined $got && $got eq $expect) { 45 print "ok $test - $name\n"; 46 return 1; 47 } 48 failed($got, "'$expect'", $name); 49 } else { 50 if (!defined $got) { 51 print "ok $test - $name\n"; 52 return 1; 53 } 54 failed($got, 'undef', $name); 55 } 56} 57 58eval '%@x=0;'; 59like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' ); 60 61# Bug 20010422.005 (#6874) 62eval q{{s//${}/; //}}; 63like( $@, qr/syntax error/, 'syntax error, used to dump core' ); 64 65# Bug 20010528.007 (#7052) 66eval q/"\x{"/; 67like( $@, qr/^Missing right brace on \\x/, 68 'syntax error in string, used to dump core' ); 69 70eval q/"\N{"/; 71like( $@, qr/^Missing right brace on \\N/, 72 'syntax error in string with incomplete \N' ); 73eval q/"\Nfoo"/; 74like( $@, qr/^Missing braces on \\N/, 75 'syntax error in string with incomplete \N' ); 76 77eval q/"\o{"/; 78like( $@, qr/^Missing right brace on \\o/, 79 'syntax error in string with incomplete \o' ); 80eval q/"\ofoo"/; 81like( $@, qr/^Missing braces on \\o/, 82 'syntax error in string with incomplete \o' ); 83 84eval "a.b.c.d.e.f;sub"; 85like( $@, qr/^Illegal declaration of anonymous subroutine/, 86 'found by Markov chain stress testing' ); 87 88# Bug 20010831.001 (#7605) 89eval '($a, b) = (1, 2);'; 90like( $@, qr/^Can't modify constant item in list assignment/, 91 'bareword in list assignment' ); 92 93eval 'tie FOO, "Foo";'; 94like( $@, qr/^Can't modify constant item in tie /, 95 'tying a bareword causes a segfault in 5.6.1' ); 96 97eval 'undef foo'; 98like( $@, qr/^Can't modify constant item in undef operator /, 99 'undefing constant causes a segfault in 5.6.1 [ID 20010906.019 (#7642)]' ); 100 101eval 'read($bla, FILE, 1);'; 102like( $@, qr/^Can't modify constant item in read /, 103 'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054 (#7847)]' ); 104 105# This used to dump core (bug #17920) 106eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } }; 107like( $@, qr/error/, 'lexical block discarded by yacc' ); 108 109# bug #18573, used to corrupt memory 110eval q{ "\c" }; 111like( $@, qr/^Missing control char name in \\c/, q("\c" string) ); 112 113eval q{ qq(foo$) }; 114like( $@, qr/Final \$ should be \\\$ or \$name/, q($ at end of "" string) ); 115 116# two tests for memory corruption problems in the said variables 117# (used to dump core or produce strange results) 118 119is( "\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Qa", "a", "PL_lex_casestack" ); 120 121eval { 122{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ 123{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ 124{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ 125}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} 126}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} 127}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}} 128}; 129is( $@, '', 'PL_lex_brackstack' ); 130 131{ 132 # tests for bug #20716 133 undef $a; 134 undef @b; 135 my $a="A"; 136 is("${a}{", "A{", "interpolation, qq//"); 137 is("${a}[", "A[", "interpolation, qq//"); 138 my @b=("B"); 139 is("@{b}{", "B{", "interpolation, qq//"); 140 is(qr/${a}\{/, '(?^:A\{)', "interpolation, qr//"); 141 my $c = "A{"; 142 $c =~ /${a}\{/; 143 is($&, 'A{', "interpolation, m//"); 144 $c =~ s/${a}\{/foo/; 145 is($c, 'foo', "interpolation, s/...//"); 146 $c =~ s/foo/${a}{/; 147 is($c, 'A{', "interpolation, s//.../"); 148 is(<<"${a}{", "A{ A[ B{\n", "interpolation, here doc"); 149${a}{ ${a}[ @{b}{ 150${a}{ 151} 152 153eval q{ sub a(;; &) { } a { } }; 154is($@, '', "';&' sub prototype confuses the lexer"); 155 156# Bug #21575 157# ensure that the second print statement works, by playing a bit 158# with the test output. 159my %data = ( foo => "\n" ); 160print "#"; 161print( 162$data{foo}); 163$test = $test + 1; 164print "ok $test\n"; 165 166# Bug #21875 167# { q.* => ... } should be interpreted as hash, not block 168 169foreach my $line (split /\n/, <<'EOF') 1701 { foo => 'bar' } 1711 { qoo => 'bar' } 1721 { q => 'bar' } 1731 { qq => 'bar' } 1740 { q,'bar', } 1750 { q=bar= } 1760 { qq=bar= } 1771 { q=bar= => 'bar' } 178EOF 179{ 180 my ($expect, $eval) = split / /, $line, 2; 181 my $result = eval $eval; 182 is($@, '', "eval $eval"); 183 is(ref $result, $expect ? 'HASH' : '', $eval); 184} 185 186# Bug #24212 187{ 188 local $SIG{__WARN__} = sub { }; # silence mandatory warning 189 eval q{ my $x = -F 1; }; 190 like( $@, qr/(?i:syntax|parse) error .* near "F 1"/, "unknown filetest operators" ); 191 is( 192 eval q{ sub F { 42 } -F 1 }, 193 '-42', 194 '-F calls the F function' 195 ); 196} 197 198# Bug #24762 199{ 200 eval q{ *foo{CODE} ? 1 : 0 }; 201 is( $@, '', "glob subscript in conditional" ); 202} 203 204# Bug #25824 205{ 206 eval q{ sub f { @a=@b=@c; {use} } }; 207 like( $@, qr/syntax error/, "use without body" ); 208} 209 210# [perl #2738] perl segfautls on input 211{ 212 eval q{ sub _ <> {} }; 213 like($@, qr/Illegal declaration of subroutine main::_/, "readline operator as prototype"); 214 215 eval q{ $s = sub <> {} }; 216 like($@, qr/Illegal declaration of anonymous subroutine/, "readline operator as prototype"); 217 218 eval q{ sub _ __FILE__ {} }; 219 like($@, qr/Illegal declaration of subroutine main::_/, "__FILE__ as prototype"); 220} 221 222# tests for "Bad name" 223eval q{ foo::$bar }; 224like( $@, qr/Bad name after foo::/, 'Bad name after foo::' ); 225eval q{ foo''bar }; 226like( $@, qr/Bad name after foo'/, 'Bad name after foo\'' ); 227 228# test for ?: context error 229eval q{($a ? $x : ($y)) = 5}; 230like( $@, qr/Assignment to both a list and a scalar/, 'Assignment to both a list and a scalar' ); 231 232eval q{ s/x/#/e }; 233is( $@, '', 'comments in s///e' ); 234 235# these five used to coredump because the op cleanup on parse error could 236# be to the wrong pad 237 238eval q[ 239 sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; 240 sub { my $z 241]; 242 243like($@, qr/Missing right curly/, 'nested sub syntax error' ); 244 245eval q[ 246 sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s); 247 sub { my $z 248]; 249like($@, qr/Missing right curly/, 'nested sub syntax error 2' ); 250 251eval q[ 252 sub { our $a= 1;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a;$a; 253 use DieDieDie; 254]; 255 256like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup' ); 257 258eval q[ 259 sub { my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s); 260 use DieDieDie; 261]; 262 263like($@, qr/Can't locate DieDieDie.pm/, 'croak cleanup 2' ); 264 265 266eval q[ 267 my @a; 268 my ($a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p,$q,$r,$s); 269 @a =~ s/a/b/; # compile-time error 270 use DieDieDie; 271]; 272 273like($@, qr/Can't modify/, 'croak cleanup 3' ); 274 275# these might leak, or have duplicate frees, depending on the bugginess of 276# the parser stack 'fail in reduce' cleanup code. They're here mainly as 277# something to be run under valgrind, with PERL_DESTRUCT_LEVEL=1. 278 279eval q[ BEGIN { } ] for 1..10; 280is($@, "", 'BEGIN 1' ); 281 282eval q[ BEGIN { my $x; $x = 1 } ] for 1..10; 283is($@, "", 'BEGIN 2' ); 284 285eval q[ BEGIN { \&foo1 } ] for 1..10; 286is($@, "", 'BEGIN 3' ); 287 288eval q[ sub foo2 { } ] for 1..10; 289is($@, "", 'BEGIN 4' ); 290 291eval q[ sub foo3 { my $x; $x=1 } ] for 1..10; 292is($@, "", 'BEGIN 5' ); 293 294eval q[ BEGIN { die } ] for 1..10; 295like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 6' ); 296 297eval q[ BEGIN {\&foo4; die } ] for 1..10; 298like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); 299 300{ 301 # RT #70934 302 # check both the specific case in the ticket, and a few other paths into 303 # S_scan_ident() 304 # simplify long ids 305 my $x100 = "x" x 256; 306 my $xFE = "x" x 254; 307 my $xFD = "x" x 253; 308 my $xFC = "x" x 252; 309 my $xFB = "x" x 251; 310 311 eval qq[ \$#$xFB ]; 312 is($@, "", "251 character \$# sigil ident ok"); 313 eval qq[ \$#$xFC ]; 314 like($@, qr/Identifier too long/, "too long id in \$# sigil ctx"); 315 316 eval qq[ \$$xFB ]; 317 is($@, "", "251 character \$ sigil ident ok"); 318 eval qq[ \$$xFC ]; 319 like($@, qr/Identifier too long/, "too long id in \$ sigil ctx"); 320 321 eval qq[ %$xFB ]; 322 is($@, "", "251 character % sigil ident ok"); 323 eval qq[ %$xFC ]; 324 like($@, qr/Identifier too long/, "too long id in % sigil ctx"); 325 326 eval qq[ \\&$xFB ]; # take a ref since I don't want to call it 327 is($@, "", "251 character & sigil ident ok"); 328 eval qq[ \\&$xFC ]; 329 like($@, qr/Identifier too long/, "too long id in & sigil ctx"); 330 331 eval qq[ *$xFC ]; 332 is($@, "", "252 character glob ident ok"); 333 eval qq[ *$xFD ]; 334 like($@, qr/Identifier too long/, "too long id in glob ctx"); 335 336 eval qq[ for $xFC ]; 337 like($@, qr/^Missing \$ on loop variable /, 338 "252 char id ok, but a different error"); 339 eval qq[ for $xFD; ]; 340 like($@, qr/^Missing \$ on loop variable /, "too long id in for ctx"); 341 342 # the specific case from the ticket 343 # however the parsing code in yyl_foreach has now changed 344 my $x = "x" x 257; 345 eval qq[ for $x ]; 346 like($@, qr/^Missing \$ on loop variable /, "too long id ticket case"); 347 348 # as PL_tokenbuf is now PL_parser->tokenbuf, the "buffer overflow" that was 349 # reported in GH #9993 now corrupts some other part of the parser structure. 350 # Currently, that seems to be the line number. Hence this test will fail if 351 # the fix from commit 0b3da58dfdc35079 is reversed. (However, as the later 352 # commit 61bc22580524a6d9 changed the code (now) in yyl_foreach() from 353 # scan_ident() to scan_word(), to recreate the problem one needs to apply 354 # the buggy change to the calculation of the variable `e` in scan_word() 355 # instead. 356 357 my $x = "x" x 260; 358 eval qq[ for my $x \$foo ]; 359 like($@, qr/at \(eval \d+\) line 1[,.]/, "line number is reported correctly"); 360} 361 362{ 363 is(exists &zlonk, '', 'sub not present'); 364 eval qq[ {sub zlonk} ]; 365 is($@, '', 'sub declaration followed by a closing curly'); 366 is(exists &zlonk, 1, 'sub now stubbed'); 367 is(defined &zlonk, '', 'but no body defined'); 368} 369 370# [perl #113016] CORE::print::foo 371sub CORE'print'foo { 43 } # apostrophes intentional; do not tempt fate 372sub CORE'foo'bar { 43 } 373is CORE::print::foo, 43, 'CORE::print::foo is not CORE::print ::foo'; 374is scalar eval "CORE::foo'bar", 43, "CORE::foo'bar is not an error"; 375 376# bug #71748 377eval q{ 378 $_ = ""; 379 s/(.)/ 380 { 381 # 382 }->{$1}; 383 /e; 384 1; 385}; 386is($@, "", "multiline whitespace inside substitute expression"); 387 388eval '@A =~ s/a/b/; # compilation error 389 sub tahi {} 390 sub rua; 391 sub toru ($); 392 sub wha :lvalue; 393 sub rima ($%&*$&*\$%\*&$%*&) :method; 394 sub ono :lvalue { die } 395 sub whitu (_) { die } 396 sub waru ($;) :method { die } 397 sub iwa { die } 398 BEGIN { }'; 399is $::{tahi}, undef, 'empty sub decl ignored after compilation error'; 400is $::{rua}, undef, 'stub decl ignored after compilation error'; 401is $::{toru}, undef, 'stub+proto decl ignored after compilation error'; 402is $::{wha}, undef, 'stub+attr decl ignored after compilation error'; 403is $::{rima}, undef, 'stub+proto+attr ignored after compilation error'; 404is $::{ono}, undef, 'sub decl with attr ignored after compilation error'; 405is $::{whitu}, undef, 'sub decl w proto ignored after compilation error'; 406is $::{waru}, undef, 'sub w attr+proto ignored after compilation error'; 407is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error'; 408is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error'; 409 410$test = $test + 1; 411"ok $test - format inside re-eval" =~ /(?{ 412 format = 413@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 414$_ 415. 416write 417}).*/; 418 419eval ' 420"${; 421 422=pod 423 424=cut 425 426}"; 427'; 428is $@, "", 'pod inside string in string eval'; 429"${; 430 431=pod 432 433=cut 434 435}"; 436print "ok ", ++$test, " - pod inside string outside of string eval\n"; 437 438like "blah blah blah\n", qr/${\ <<END 439blah blah blah 440END 441 }/, 'here docs in multiline quoted construct'; 442like "blah blah blah\n", eval q|qr/${\ <<END 443blah blah blah 444END 445 }/|, 'here docs in multiline quoted construct in string eval'; 446 447# Unterminated here-docs in subst in eval; used to crash 448eval 's/${<<END}//'; 449eval 's//${<<END}/'; 450print "ok ", ++$test, " - unterminated here-docs in s/// in string eval\n"; 451 452sub 'Hello'_he_said (_); 453is prototype "Hello::_he_said", '_', 'initial tick in sub declaration'; 454 455{ 456 my @x = 'string'; 457 is(eval q{ "$x[0]->strung" }, 'string->strung', 458 'literal -> after an array subscript within ""'); 459 @x = ['string']; 460 # this used to give "string" 461 like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0\]\z/, 462 'literal -> [0] after an array subscript within ""'); 463} 464 465eval 'no if $] >= 5.17.4 warnings => "deprecated"'; 466is 1,1, ' no crash for "no ... syntax error"'; 467 468for my $pkg(()){} 469$pkg = 3; 470is $pkg, 3, '[perl #114942] for my $foo()){} $foo'; 471 472# Check that format 'Foo still works after removing the hack from 473# force_word 474$test++; 475format 'one = 476ok @<< - format 'foo still works 477$test 478. 479{ 480 local $~ = "one"; 481 write(); 482} 483 484$test++; 485format ::two = 486ok @<< - format ::foo still works 487$test 488. 489{ 490 local $~ = "two"; 491 write(); 492} 493 494for(__PACKAGE__) { 495 eval '$_=42'; 496 is $_, 'main', '__PACKAGE__ is read-only'; 497} 498 499$file = __FILE__; 500BEGIN{ ${"_<".__FILE__} = \1 } 501is __FILE__, $file, 502 'no __FILE__ corruption when setting CopFILESV to a ref'; 503 504eval 'Fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' 505 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' 506 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' 507 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' 508 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo' 509 .'ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'; 510like $@, "^Identifier too long at ", 'ident buffer overflow'; 511 512eval 'for my a1b $i (1) {}'; 513# ng: 'Missing $ on loop variable' 514like $@, "^No such class a1b at ", 'TYPE of my of for statement'; 515 516eval 'method {} {$_,undef}'; 517like $@, qq/^Can't call method "method" on unblessed reference at /, 518 'method BLOCK {...} does not try to disambiguate'; 519 520eval '#line 1 maggapom 521 if ($a>3) { $a ++; } 522 else {printf(1/0);}'; 523is $@, "Illegal division by zero at maggapom line 2.\n", 524 'else {foo} line number (no space after {) [perl #122695]'; 525 526# parentheses needed for this to fail an assertion in S_maybe_multideref 527is +(${[{a=>214}]}[0])->{a}, 214, '($array[...])->{...}'; 528 529# This used to fail an assertion because of the OPf_SPECIAL flag on an 530# OP_GV that started out as an OP_CONST. 531 532 sub FILE1 () { 1 } 533 sub dummy { tell FILE1 } 534 535# More potential multideref assertion failures 536# OPf_PARENS on OP_RV2SV in subscript 537 $x[($_)]; 538 is(1,1, "PASS: Previous line successfully parsed. OPf_PARENS on OP_RV2SV"); 539# OPf_SPECIAL on OP_GV in subscript 540 $x[FILE1->[0]]; 541 is(1,1, "PASS: Previous line successfully parsed. OPf_SPECIAL on OP_GV"); 542 543# Used to crash [perl #123542] 544eval 's /${<>{}) //'; 545 546# Also used to crash [perl #123652] 547eval{$1=eval{a:}}; 548 549# Used to fail assertions [perl #123753] 550eval "map+map"; 551eval "grep+grep"; 552 553# ALso failed an assertion [perl #123848] 554{ 555 local $SIG{__WARN__} = sub{}; 556 eval 'my $_; m// ~~ 0'; 557} 558 559# Used to crash [perl #125679] 560eval 'BEGIN {$^H=-1} \eval=time'; 561 562# Used to fail an assertion [perl #129073] 563{ 564 local $SIG{__WARN__} = sub{}; 565 eval '${p{};sub p}()'; 566} 567 568# RT #124207 syntax error during stringify can leave stringify op 569# with multiple children and assertion failures 570 571eval 'qq{@{0]}${}},{})'; 572is(1, 1, "RT #124207"); 573 574# RT #127993 version control conflict markers 575my @conflict_markers = map { $_ x 7 } qw( < = > ); 576" this should keep working 577$conflict_markers[0] 578" =~ / 579$conflict_markers[2] 580/; 581for my $marker (@conflict_markers) { 582 eval "$marker"; 583 like $@, qr/^Version control conflict marker at \(eval \d+\) line 1, near "$marker"/, "VCS marker '$marker' at beginning"; 584 eval "\$_\n$marker"; 585 like $@, qr/^Version control conflict marker at \(eval \d+\) line 2, near "$marker"/, "VCS marker '$marker' after value"; 586 eval "\n\$_ =\n$marker"; 587 like $@, qr/^Version control conflict marker at \(eval \d+\) line 3, near "$marker"/, "VCS marker '$marker' after operator"; 588} 589 590# keys assignments in weird contexts (mentioned in perl #128260) 591eval 'keys(%h) .= "00"'; 592is $@, "", 'keys .='; 593eval 'sub { read $fh, keys %h, 0 }'; 594is $@, "", 'read into keys'; 595eval 'substr keys(%h),0,=3'; 596is $@, "", 'substr keys assignment'; 597 598{ # very large utf8 char in error message was overflowing buffer 599 if (length sprintf("%x", ~0) <= 8) { 600 is 1, 1, "skip because overflows on 32-bit machine"; 601 } 602 else { 603 no warnings; 604 eval "q" . chr(100000000064); 605 like $@, qr/Can't find string terminator "." anywhere before EOF/, 606 'RT 128952'; 607 } 608} 609 610# RT #130311: many parser shifts before a reduce 611 612{ 613 eval '[' . ('{' x 300); 614 like $@, qr/Missing right curly or square bracket/, 'RT #130311'; 615} 616 617# RT #130815: crash in ck_return for malformed code 618{ 619 eval 'm(@{if(0){sub d{]]])}return'; 620 like $@, qr/^syntax error at \(eval \d+\) line 1, near "\{\]"/, 621 'RT #130815: null pointer deref'; 622} 623 624# Add new tests HERE (above this line) 625 626# bug #74022: Loop on characters in \p{OtherIDContinue} 627# This test hangs if it fails. 628eval chr 0x387; # forces loading of utf8.pm 629is(1,1, '[perl #74022] Parser looping on OtherIDContinue chars'); 630 631# More awkward tests for #line. Keep these at the end, as they will screw 632# with sane line reporting for any other test failures 633 634sub check ($$$) { 635 my ($file, $line, $name) = @_; 636 my (undef, $got_file, $got_line) = caller; 637 like ($got_file, $file, "file of $name"); 638 is ($got_line, $line, "line of $name"); 639} 640 641my $this_file = qr/parser\.t(?:\.[bl]eb?)?$/; 642#line 3 6431 unless 6441; 645check($this_file, 5, "[perl #118931]"); 646 647#line 3 648check($this_file, 3, "bare line"); 649 650# line 5 651check($this_file, 5, "bare line with leading space"); 652 653#line 7 654check($this_file, 7, "trailing space still valid"); 655 656# line 11 657check($this_file, 11, "leading and trailing"); 658 659# line 13 660check($this_file, 13, "leading tab"); 661 662#line 17 663check($this_file, 17, "middle tab"); 664 665#line 19 666check($this_file, 19, "loadsaspaces"); 667 668#line 23 KASHPRITZA 669check(qr/^KASHPRITZA$/, 23, "bare filename"); 670 671#line 29 "KAHEEEE" 672check(qr/^KAHEEEE$/, 29, "filename in quotes"); 673 674#line 31 "CLINK CLOINK BZZT" 675check(qr/^CLINK CLOINK BZZT$/, 31, "filename with spaces in quotes"); 676 677#line 37 "THOOM THOOM" 678check(qr/^THOOM THOOM$/, 37, "filename with tabs in quotes"); 679 680#line 41 "GLINK PLINK GLUNK DINK" 681check(qr/^GLINK PLINK GLUNK DINK$/, 41, "a space after the quotes"); 682 683#line 43 "BBFRPRAFPGHPP 684check(qr/^"BBFRPRAFPGHPP$/, 43, "actually missing a quote is still valid"); 685 686#line 47 bang eth 687check(qr/^"BBFRPRAFPGHPP$/, 46, "but spaces aren't allowed without quotes"); 688 689#line 77sevenseven 690check(qr/^"BBFRPRAFPGHPP$/, 49, "need a space after the line number"); 691 692eval <<'EOSTANZA'; die $@ if $@; 693#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." 694check(qr/^With.*down\.$/, 51, "Overflow the second small buffer check"); 695EOSTANZA 696 697# And now, turn on the debugger flag for long names 698$^P = 0x100; 699 700#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." 701check(qr/^For we.*must die\.$/, 53, "Our long line is set up"); 702 703eval <<'EOT'; die $@ if $@; 704#line 59 " " 705check(qr/^ $/, 59, "Overflow the first small buffer check only"); 706EOT 707 708eval <<'EOSTANZA'; die $@ if $@; 709#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." 710check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks"); 711EOSTANZA 712 713sub check_line ($$) { 714 my ($line, $name) = @_; 715 my (undef, undef, $got_line) = caller; 716 is ($got_line, $line, $name); 717} 718 719#line 531 parser.t 720<<EOU; check_line(531, 'on same line as heredoc'); 721EOU 722s//<<EOV/e if 0; 723EOV 724check_line(535, 'after here-doc in quotes'); 725<<EOW; <<EOX; 726${check_line(537, 'first line of interp in here-doc');; 727 check_line(538, 'second line of interp in here-doc');} 728EOW 729${check_line(540, 'first line of interp in second here-doc on same line');; 730 check_line(541, 'second line of interp in second heredoc on same line');} 731EOX 732eval <<'EVAL'; 733#line 545 734"${<<EOY; <<EOZ}"; 735${check_line(546, 'first line of interp in here-doc in quotes in eval');; 736 check_line(547, 'second line of interp in here-doc in quotes in eval');} 737EOY 738${check_line(549, '1st line of interp in 2nd hd, same line in q in eval');; 739 check_line(550, '2nd line of interp in 2nd hd, same line in q in eval');} 740EOZ 741EVAL 742 743time 744#line 42 745;check_line(42, 'line number after "nullary\n#line"'); 746 747"${ 748#line 53 749_}"; 750check_line(54, 'line number after qq"${#line}"'); 751 752#line 24 753" 754${check_line(25, 'line number inside qq/<newline>${...}/')}"; 755 756<<"END"; 757${; 758#line 625 759} 760END 761check_line(627, 'line number after heredoc containing #line'); 762 763#line 638 764<<ENE . ${ 765 766ENE 767"bar"}; 768check_line(642, 'line number after ${expr} surrounding heredoc body'); 769 770 771__END__ 772# Don't add new tests HERE. See "Add new tests HERE" above. 773