This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bump test count in t/comp/parser.t
[perl5.git] / t / comp / parser.t
CommitLineData
923be969
RGS
1#!./perl
2
3# Checks if the parser behaves correctly in edge cases
4# (including weird syntax errors)
5
561e8675
CB
6BEGIN {
7 @INC = qw(. ../lib);
a817e89d 8 chdir 't' if -d 't';
561e8675
CB
9}
10
9de2a80f 11print "1..188\n";
c9786f60
NC
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;
923be969
RGS
26}
27
c9786f60
NC
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}
f15b33d3
RGS
57
58eval '%@x=0;';
59like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
60
ee95e30c 61# Bug 20010422.005 (#6874)
f15b33d3
RGS
62eval q{{s//${}/; //}};
63like( $@, qr/syntax error/, 'syntax error, used to dump core' );
64
ee95e30c 65# Bug 20010528.007 (#7052)
f15b33d3
RGS
66eval q/"\x{"/;
67like( $@, qr/^Missing right brace on \\x/,
68 'syntax error in string, used to dump core' );
69
fd7808cb
RGS
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
ae9ce25e
KW
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
f15b33d3
RGS
84eval "a.b.c.d.e.f;sub";
85like( $@, qr/^Illegal declaration of anonymous subroutine/,
86 'found by Markov chain stress testing' );
87
ee95e30c 88# Bug 20010831.001 (#7605)
f15b33d3
RGS
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 /,
ee95e30c 99 'undefing constant causes a segfault in 5.6.1 [ID 20010906.019 (#7642)]' );
f15b33d3
RGS
100
101eval 'read($bla, FILE, 1);';
102like( $@, qr/^Can't modify constant item in read /,
ee95e30c 103 'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054 (#7847)]' );
923be969
RGS
104
105# This used to dump core (bug #17920)
106eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } };
f15b33d3 107like( $@, qr/error/, 'lexical block discarded by yacc' );
961ce445
RGS
108
109# bug #18573, used to corrupt memory
110eval q{ "\c" };
111like( $@, qr/^Missing control char name in \\c/, q("\c" string) );
8edd5f42 112
a40a317b
RGS
113eval q{ qq(foo$) };
114like( $@, qr/Final \$ should be \\\$ or \$name/, q($ at end of "" string) );
115
8edd5f42
RGS
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' );
437fd210
AE
130
131{
7df0d042
AE
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//");
2a53d331 140 is(qr/${a}\{/, '(?^:A\{)', "interpolation, qr//");
7df0d042 141 my $c = "A{";
2a53d331 142 $c =~ /${a}\{/;
7df0d042 143 is($&, 'A{', "interpolation, m//");
2a53d331 144 $c =~ s/${a}\{/foo/;
7df0d042
AE
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}{
437fd210 151}
4a202259 152
0f5d0394
AE
153eval q{ sub a(;; &) { } a { } };
154is($@, '', "';&' sub prototype confuses the lexer");
155
4a202259
AE
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});
c9786f60
NC
163$test = $test + 1;
164print "ok $test\n";
abc667d1
DM
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;
c9786f60 182 is($@, '', "eval $eval");
abc667d1
DM
183 is(ref $result, $expect ? 'HASH' : '', $eval);
184}
3cf7b4c4
RGS
185
186# Bug #24212
187{
188 local $SIG{__WARN__} = sub { }; # silence mandatory warning
189 eval q{ my $x = -F 1; };
250d67eb 190 like( $@, qr/(?i:syntax|parse) error .* near "F 1"/, "unknown filetest operators" );
3cf7b4c4
RGS
191 is(
192 eval q{ sub F { 42 } -F 1 },
193 '-42',
194 '-F calls the F function'
195 );
196}
1c03aa9b
RGS
197
198# Bug #24762
199{
200 eval q{ *foo{CODE} ? 1 : 0 };
201 is( $@, '', "glob subscript in conditional" );
202}
500bedb6
DM
203
204# Bug #25824
205{
206 eval q{ sub f { @a=@b=@c; {use} } };
207 like( $@, qr/syntax error/, "use without body" );
208}
e1548254 209
8e742a20
MHM
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}
dbfe47cf 221
917949e3
RGS
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\'' );
a6a8bb49
RGS
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' );
2d997502
BC
231
232eval q{ s/x/#/e };
233is( $@, '', 'comments in s///e' );
2af555bf 234
718a7425 235# these five used to coredump because the op cleanup on parse error could
2af555bf
DM
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,$r);
247 sub { my $z
248];
249like($@, qr/Missing right curly/, 'nested sub syntax error 2' );
250
718a7425
DM
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,$r);
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,$r);
269 @a =~ s/a/b/; # compile-time error
270 use DieDieDie;
271];
272
273like($@, qr/Can't modify/, 'croak cleanup 3' );
274
7e5d8ed2
DM
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' );
44867030 299
0b3da58d
TC
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
c07656ed
FC
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 ];
0b3da58d
TC
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
61bc2258 336 eval qq[ for $xFC ];
0b3da58d 337 like($@, qr/Missing \$ on loop variable/,
61bc2258
H
338 "252 char id ok, but a different error");
339 eval qq[ for $xFD; ];
0b3da58d
TC
340 like($@, qr/Identifier too long/, "too long id in for ctx");
341
342 # the specific case from the ticket
343 my $x = "x" x 257;
344 eval qq[ for $x ];
345 like($@, qr/Identifier too long/, "too long id ticket case");
346}
347
fd909433 348{
c9e0c59b 349 is(exists &zlonk, '', 'sub not present');
fd909433
VP
350 eval qq[ {sub zlonk} ];
351 is($@, '', 'sub declaration followed by a closing curly');
c9e0c59b
NC
352 is(exists &zlonk, 1, 'sub now stubbed');
353 is(defined &zlonk, '', 'but no body defined');
fd909433
VP
354}
355
ee36fb64
FC
356# [perl #113016] CORE::print::foo
357sub CORE'print'foo { 43 } # apostrophes intentional; do not tempt fate
358sub CORE'foo'bar { 43 }
359is CORE::print::foo, 43, 'CORE::print::foo is not CORE::print ::foo';
360is scalar eval "CORE::foo'bar", 43, "CORE::foo'bar is not an error";
361
f0998909
Z
362# bug #71748
363eval q{
364 $_ = "";
365 s/(.)/
366 {
367 #
368 }->{$1};
369 /e;
370 1;
371};
372is($@, "", "multiline whitespace inside substitute expression");
373
a73ef99b
FC
374eval '@A =~ s/a/b/; # compilation error
375 sub tahi {}
376 sub rua;
377 sub toru ($);
378 sub wha :lvalue;
379 sub rima ($%&*$&*\$%\*&$%*&) :method;
380 sub ono :lvalue { die }
381 sub whitu (_) { die }
382 sub waru ($;) :method { die }
383 sub iwa { die }
384 BEGIN { }';
385is $::{tahi}, undef, 'empty sub decl ignored after compilation error';
386is $::{rua}, undef, 'stub decl ignored after compilation error';
387is $::{toru}, undef, 'stub+proto decl ignored after compilation error';
388is $::{wha}, undef, 'stub+attr decl ignored after compilation error';
389is $::{rima}, undef, 'stub+proto+attr ignored after compilation error';
390is $::{ono}, undef, 'sub decl with attr ignored after compilation error';
391is $::{whitu}, undef, 'sub decl w proto ignored after compilation error';
392is $::{waru}, undef, 'sub w attr+proto ignored after compilation error';
393is $::{iwa}, undef, 'non-empty sub decl ignored after compilation error';
394is *BEGIN{CODE}, undef, 'BEGIN leaves no stub after compilation error';
395
583c9d5c
FC
396$test = $test + 1;
397"ok $test - format inside re-eval" =~ /(?{
398 format =
399@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
400$_
401.
402write
403}).*/;
404
4a7239ff
FC
405eval '
406"${;
407
408=pod
409
410=cut
411
412}";
413';
414is $@, "", 'pod inside string in string eval';
415"${;
416
417=pod
418
419=cut
420
421}";
422print "ok ", ++$test, " - pod inside string outside of string eval\n";
423
5097bf9b
FC
424like "blah blah blah\n", qr/${\ <<END
425blah blah blah
426END
427 }/, 'here docs in multiline quoted construct';
428like "blah blah blah\n", eval q|qr/${\ <<END
429blah blah blah
430END
431 }/|, 'here docs in multiline quoted construct in string eval';
432
433# Unterminated here-docs in subst in eval; used to crash
434eval 's/${<<END}//';
435eval 's//${<<END}/';
436print "ok ", ++$test, " - unterminated here-docs in s/// in string eval\n";
437
0484b403
FC
438sub 'Hello'_he_said (_);
439is prototype "Hello::_he_said", '_', 'initial tick in sub declaration';
440
321f1aea
FC
441{
442 my @x = 'string';
443 is(eval q{ "$x[0]->strung" }, 'string->strung',
444 'literal -> after an array subscript within ""');
445 @x = ['string'];
446 # this used to give "string"
92e8e650 447 like("$x[0]-> [0]", qr/^ARRAY\([^)]*\)-> \[0\]\z/,
321f1aea
FC
448 'literal -> [0] after an array subscript within ""');
449}
450
d2691ae2
FC
451eval 'no if $] >= 5.17.4 warnings => "deprecated"';
452is 1,1, ' no crash for "no ... syntax error"';
453
3f33d153
FC
454for my $pkg(()){}
455$pkg = 3;
456is $pkg, 3, '[perl #114942] for my $foo()){} $foo';
d2691ae2 457
a20e6aae
BF
458# Check that format 'Foo still works after removing the hack from
459# force_word
460$test++;
461format 'one =
462ok @<< - format 'foo still works
463$test
464.
465{
466 local $~ = "one";
467 write();
468}
469
1a01716a
NC
470$test++;
471format ::two =
472ok @<< - format ::foo still works
473$test
474.
475{
476 local $~ = "two";
477 write();
478}
479
9dbc968d
FC
480for(__PACKAGE__) {
481 eval '$_=42';
482 is $_, 'main', '__PACKAGE__ is read-only';
483}
484
1311cfc0
FC
485$file = __FILE__;
486BEGIN{ ${"_<".__FILE__} = \1 }
487is __FILE__, $file,
488 'no __FILE__ corruption when setting CopFILESV to a ref';
489
eaaaaa32
FC
490eval 'Fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
491 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
492 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
493 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
494 .'oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo'
495 .'ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo';
496like $@, "^Identifier too long at ", 'ident buffer overflow';
497
61bc2258
H
498eval 'for my a1b $i (1) {}';
499# ng: 'Missing $ on loop variable'
500like $@, "^No such class a1b at ", 'TYPE of my of for statement';
501
b5b6210a
FC
502eval 'method {} {$_,undef}';
503like $@, qq/^Can't call method "method" on unblessed reference at /,
504 'method BLOCK {...} does not try to disambiguate';
505
51a82aa9
FC
506eval '#line 1 maggapom
507 if ($a>3) { $a ++; }
508 else {printf(1/0);}';
509is $@, "Illegal division by zero at maggapom line 2.\n",
510 'else {foo} line number (no space after {) [perl #122695]';
511
1553b1d3
FC
512# parentheses needed for this to fail an assertion in S_maybe_multideref
513is +(${[{a=>214}]}[0])->{a}, 214, '($array[...])->{...}';
514
4245fea4
FC
515# This used to fail an assertion because of the OPf_SPECIAL flag on an
516# OP_GV that started out as an OP_CONST. No test output is necessary, as
517# successful parsing is sufficient.
518sub FILE1 () { 1 }
519sub dummy { tell FILE1 }
520
b39c1059
FC
521# More potential multideref assertion failures
522# OPf_PARENS on OP_RV2SV in subscript
523$x[($_)];
db7bc125
FC
524# OPf_SPECIAL on OP_GV in subscript
525$x[FILE1->[0]];
b39c1059 526
cc5af377 527# Used to crash [perl #123542]
08b999a9
FC
528eval 's /${<>{}) //';
529
2f465e08
FC
530# Also used to crash [perl #123652]
531eval{$1=eval{a:}};
532
fb0c7c3c
FC
533# Used to fail assertions [perl #123753]
534eval "map+map";
535eval "grep+grep";
536
57db463f
FC
537# ALso failed an assertion [perl #123848]
538{
539 local $SIG{__WARN__} = sub{};
540 eval 'my $_; m// ~~ 0';
541}
542
2b6a5bfb
FC
543# Used to crash [perl #125679]
544eval 'BEGIN {$^H=-1} \eval=time';
545
bdc377e5 546# Used to fail an assertion [perl #129073]
03a1fa1e
FC
547{
548 local $SIG{__WARN__} = sub{};
549 eval '${p{};sub p}()';
550}
bdc377e5 551
82269f56
DM
552# RT #124207 syntax error during stringify can leave stringify op
553# with multiple children and assertion failures
554
555eval 'qq{@{0]}${}},{})';
556is(1, 1, "RT #124207");
557
397c43d8
LM
558# RT #127993 version control conflict markers
559" this should keep working
560<<<<<<<
561" =~ /
562>>>>>>>
563/;
564for my $marker (qw(
565<<<<<<<
566=======
567>>>>>>>
568)) {
569 eval "$marker";
9c88bb56 570 like $@, qr/^Version control conflict marker at \(eval \d+\) line 1, near "$marker"/, "VCS marker '$marker' at beginning";
397c43d8 571 eval "\$_\n$marker";
9c88bb56 572 like $@, qr/^Version control conflict marker at \(eval \d+\) line 2, near "$marker"/, "VCS marker '$marker' after value";
397c43d8 573 eval "\n\$_ =\n$marker";
9c88bb56 574 like $@, qr/^Version control conflict marker at \(eval \d+\) line 3, near "$marker"/, "VCS marker '$marker' after operator";
397c43d8
LM
575}
576
e4fc7082
FC
577# keys assignments in weird contexts (mentioned in perl #128260)
578eval 'keys(%h) .= "00"';
579is $@, "", 'keys .=';
580eval 'sub { read $fh, keys %h, 0 }';
581is $@, "", 'read into keys';
582eval 'substr keys(%h),0,=3';
583is $@, "", 'substr keys assignment';
82269f56 584
e487ff5e
DM
585# very large utf8 char in error message was overflowing buffer
586{
587
588 no warnings;
589 eval "q" . chr(100000000064);
590 like $@, qr/Can't find string terminator "." anywhere before EOF/,
591 'RT 128952';
592}
593
df13534a
DM
594# RT #130311: many parser shifts before a reduce
595
596{
597 eval '[' . ('{' x 300);
598 like $@, qr/Missing right curly or square bracket/, 'RT #130311';
599}
600
e5c165a0
AC
601# RT #130815: crash in ck_return for malformed code
602{
603 eval 'm(@{if(0){sub d{]]])}return';
604 like $@, qr/^syntax error at \(eval \d+\) line 1, near "\{\]"/,
605 'RT #130815: null pointer deref';
606}
df13534a 607
2e4e39b1
FC
608# Add new tests HERE (above this line)
609
d7425188
FC
610# bug #74022: Loop on characters in \p{OtherIDContinue}
611# This test hangs if it fails.
561e8675 612eval chr 0x387; # forces loading of utf8.pm
d7425188
FC
613is(1,1, '[perl #74022] Parser looping on OtherIDContinue chars');
614
44867030
NC
615# More awkward tests for #line. Keep these at the end, as they will screw
616# with sane line reporting for any other test failures
617
618sub check ($$$) {
619 my ($file, $line, $name) = @_;
620 my (undef, $got_file, $got_line) = caller;
621 like ($got_file, $file, "file of $name");
44867030
NC
622 is ($got_line, $line, "line of $name");
623}
624
c9de86d5 625my $this_file = qr/parser\.t(?:\.[bl]eb?)?$/;
44867030 626#line 3
bf1b738b
FC
6271 unless
6281;
629check($this_file, 5, "[perl #118931]");
630
631#line 3
c9de86d5 632check($this_file, 3, "bare line");
44867030
NC
633
634# line 5
c9de86d5 635check($this_file, 5, "bare line with leading space");
44867030
NC
636
637#line 7
c9de86d5 638check($this_file, 7, "trailing space still valid");
44867030
NC
639
640# line 11
c9de86d5 641check($this_file, 11, "leading and trailing");
44867030
NC
642
643# line 13
c9de86d5 644check($this_file, 13, "leading tab");
44867030
NC
645
646#line 17
c9de86d5 647check($this_file, 17, "middle tab");
44867030
NC
648
649#line 19
c9de86d5 650check($this_file, 19, "loadsaspaces");
44867030
NC
651
652#line 23 KASHPRITZA
653check(qr/^KASHPRITZA$/, 23, "bare filename");
654
655#line 29 "KAHEEEE"
656check(qr/^KAHEEEE$/, 29, "filename in quotes");
657
658#line 31 "CLINK CLOINK BZZT"
659check(qr/^CLINK CLOINK BZZT$/, 31, "filename with spaces in quotes");
660
661#line 37 "THOOM THOOM"
662check(qr/^THOOM THOOM$/, 37, "filename with tabs in quotes");
663
664#line 41 "GLINK PLINK GLUNK DINK"
665check(qr/^GLINK PLINK GLUNK DINK$/, 41, "a space after the quotes");
666
667#line 43 "BBFRPRAFPGHPP
668check(qr/^"BBFRPRAFPGHPP$/, 43, "actually missing a quote is still valid");
669
670#line 47 bang eth
671check(qr/^"BBFRPRAFPGHPP$/, 46, "but spaces aren't allowed without quotes");
672
26b6dc3f
RGS
673#line 77sevenseven
674check(qr/^"BBFRPRAFPGHPP$/, 49, "need a space after the line number");
675
44867030
NC
676eval <<'EOSTANZA'; die $@ if $@;
677#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."
678check(qr/^With.*down\.$/, 51, "Overflow the second small buffer check");
679EOSTANZA
680
681# And now, turn on the debugger flag for long names
682$^P = 0x100;
683
684#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."
685check(qr/^For we.*must die\.$/, 53, "Our long line is set up");
686
687eval <<'EOT'; die $@ if $@;
688#line 59 " "
689check(qr/^ $/, 59, "Overflow the first small buffer check only");
690EOT
691
692eval <<'EOSTANZA'; die $@ if $@;
693#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."
694check(qr/^Great hail!.*no more\.$/, 61, "Overflow both small buffer checks");
695EOSTANZA
696
cbf45e84
FC
697sub check_line ($$) {
698 my ($line, $name) = @_;
699 my (undef, undef, $got_line) = caller;
700 is ($got_line, $line, $name);
701}
702
83944c01 703#line 531 parser.t
cbf45e84 704<<EOU; check_line(531, 'on same line as heredoc');
83944c01
FC
705EOU
706s//<<EOV/e if 0;
707EOV
cbf45e84 708check_line(535, 'after here-doc in quotes');
6ddcf93b 709<<EOW; <<EOX;
cbf45e84
FC
710${check_line(537, 'first line of interp in here-doc');;
711 check_line(538, 'second line of interp in here-doc');}
78a635de 712EOW
6ddcf93b
FC
713${check_line(540, 'first line of interp in second here-doc on same line');;
714 check_line(541, 'second line of interp in second heredoc on same line');}
715EOX
716eval <<'EVAL';
717#line 545
718"${<<EOY; <<EOZ}";
719${check_line(546, 'first line of interp in here-doc in quotes in eval');;
720 check_line(547, 'second line of interp in here-doc in quotes in eval');}
721EOY
722${check_line(549, '1st line of interp in 2nd hd, same line in q in eval');;
723 check_line(550, '2nd line of interp in 2nd hd, same line in q in eval');}
724EOZ
725EVAL
83944c01 726
9cf27252
FC
727time
728#line 42
cbf45e84 729;check_line(42, 'line number after "nullary\n#line"');
9cf27252 730
ffdb8b16
FC
731"${
732#line 53
733_}";
cbf45e84 734check_line(54, 'line number after qq"${#line}"');
ffdb8b16
FC
735
736#line 24
737"
cbf45e84 738${check_line(25, 'line number inside qq/<newline>${...}/')}";
9cf27252 739
b42366d4
FC
740<<"END";
741${;
742#line 625
743}
744END
745check_line(627, 'line number after heredoc containing #line');
746
8c29fccb
FC
747#line 638
748<<ENE . ${
749
750ENE
751"bar"};
752check_line(642, 'line number after ${expr} surrounding heredoc body');
753
754
44867030 755__END__
82269f56 756# Don't add new tests HERE. See "Add new tests HERE" above.