1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
#!./perl
# Checks if the parser behaves correctly in edge cases
# (including weird syntax errors)
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require "./test.pl";
plan( tests => 43 );
eval '%@x=0;';
like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
# Bug 20010422.005
eval q{{s//${}/; //}};
like( $@, qr/syntax error/, 'syntax error, used to dump core' );
# Bug 20010528.007
eval q/"\x{"/;
like( $@, qr/^Missing right brace on \\x/,
'syntax error in string, used to dump core' );
eval "a.b.c.d.e.f;sub";
like( $@, qr/^Illegal declaration of anonymous subroutine/,
'found by Markov chain stress testing' );
# Bug 20010831.001
eval '($a, b) = (1, 2);';
like( $@, qr/^Can't modify constant item in list assignment/,
'bareword in list assignment' );
eval 'tie FOO, "Foo";';
like( $@, qr/^Can't modify constant item in tie /,
'tying a bareword causes a segfault in 5.6.1' );
eval 'undef foo';
like( $@, qr/^Can't modify constant item in undef operator /,
'undefing constant causes a segfault in 5.6.1 [ID 20010906.019]' );
eval 'read($bla, FILE, 1);';
like( $@, qr/^Can't modify constant item in read /,
'read($var, FILE, 1) segfaults on 5.6.1 [ID 20011025.054]' );
# This used to dump core (bug #17920)
eval q{ sub { sub { f1(f2();); my($a,$b,$c) } } };
like( $@, qr/error/, 'lexical block discarded by yacc' );
# bug #18573, used to corrupt memory
eval q{ "\c" };
like( $@, qr/^Missing control char name in \\c/, q("\c" string) );
eval q{ qq(foo$) };
like( $@, qr/Final \$ should be \\\$ or \$name/, q($ at end of "" string) );
# two tests for memory corruption problems in the said variables
# (used to dump core or produce strange results)
is( "\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Q\Qa", "a", "PL_lex_casestack" );
eval {
{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{{
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}}
};
is( $@, '', 'PL_lex_brackstack' );
{
# tests for bug #20716
undef $a;
undef @b;
my $a="A";
is("${a}{", "A{", "interpolation, qq//");
is("${a}[", "A[", "interpolation, qq//");
my @b=("B");
is("@{b}{", "B{", "interpolation, qq//");
is(qr/${a}{/, '(?-xism:A{)', "interpolation, qr//");
my $c = "A{";
$c =~ /${a}{/;
is($&, 'A{', "interpolation, m//");
$c =~ s/${a}{/foo/;
is($c, 'foo', "interpolation, s/...//");
$c =~ s/foo/${a}{/;
is($c, 'A{', "interpolation, s//.../");
is(<<"${a}{", "A{ A[ B{\n", "interpolation, here doc");
${a}{ ${a}[ @{b}{
${a}{
}
eval q{ sub a(;; &) { } a { } };
is($@, '', "';&' sub prototype confuses the lexer");
# Bug #21575
# ensure that the second print statement works, by playing a bit
# with the test output.
my %data = ( foo => "\n" );
print "#";
print(
$data{foo});
pass();
# Bug #21875
# { q.* => ... } should be interpreted as hash, not block
foreach my $line (split /\n/, <<'EOF')
1 { foo => 'bar' }
1 { qoo => 'bar' }
1 { q => 'bar' }
1 { qq => 'bar' }
0 { q,'bar', }
0 { q=bar= }
0 { qq=bar= }
1 { q=bar= => 'bar' }
EOF
{
my ($expect, $eval) = split / /, $line, 2;
my $result = eval $eval;
ok($@ eq '', "eval $eval");
is(ref $result, $expect ? 'HASH' : '', $eval);
}
# Bug #24212
{
local $SIG{__WARN__} = sub { }; # silence mandatory warning
eval q{ my $x = -F 1; };
like( $@, qr/(?:syntax|parse) error .* near "F 1"/, "unknown filetest operators" );
is(
eval q{ sub F { 42 } -F 1 },
'-42',
'-F calls the F function'
);
}
# Bug #24762
{
eval q{ *foo{CODE} ? 1 : 0 };
is( $@, '', "glob subscript in conditional" );
}
# 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
}
|
