Commit | Line | Data |
---|---|---|
1a96a5b7 BF |
1 | #!./perl |
2 | ||
3 | # Checks if the parser behaves correctly in edge cases | |
4 | # (including weird syntax errors) | |
5 | ||
6 | BEGIN { | |
7 | require './test.pl'; | |
8 | } | |
9 | ||
84051091 | 10 | plan (tests => 52); |
1a96a5b7 BF |
11 | |
12 | use utf8; | |
13 | use open qw( :utf8 :std ); | |
14 | ||
15 | ok *tèst, "*main::tèst", "sanity check."; | |
16 | ok $::{"tèst"}, "gets the right glob in the stash."; | |
17 | ||
18 | my $glob_by_sub = sub { *main::method }->(); | |
19 | ||
20 | is *main::method, "*main::method", "glob stringy works"; | |
21 | is "" . *main::method, "*main::method", "glob stringify-through-concat works"; | |
22 | is $glob_by_sub, "*main::method", "glob stringy works"; | |
23 | is "" . $glob_by_sub, "*main::method", ""; | |
24 | ||
25 | sub gimme_glob { | |
26 | no strict 'refs'; | |
27 | is *{$_[0]}, "*main::$_[0]"; | |
28 | *{$_[0]}; | |
29 | } | |
30 | ||
31 | is "" . gimme_glob("下郎"), "*main::下郎"; | |
32 | $a = *下郎; | |
33 | is "" . $a, "*main::下郎"; | |
34 | ||
35 | *{gimme_glob("下郎")} = sub {}; | |
36 | ||
37 | { | |
38 | ok defined *{"下郎"}{CODE}; | |
39 | ok !defined *{"\344\270\213\351\203\216"}{CODE}; | |
40 | } | |
41 | ||
42 | $Lèon = 1; | |
43 | is ${*Lèon{SCALAR}}, 1, "scalar define in the right glob,"; | |
44 | ok !${*{"L\303\250on"}{SCALAR}}, "..and nothing in the wrong one."; | |
45 | ||
46 | my $a = "foo" . chr(190); | |
47 | my $b = $a . chr(256); | |
48 | chop $b; # $b is $a with utf8 on | |
49 | ||
50 | is $a, $b, '$a equals $b'; | |
51 | ||
52 | *$b = sub { 5 }; | |
53 | ||
54 | is eval { main->$a }, 5, q!$a can call $b's sub!; | |
55 | ok !$@, "..and there's no error."; | |
56 | ||
57 | my $c = $b; | |
58 | utf8::encode($c); | |
59 | ok $b ne $c, '$b unequal $c'; | |
60 | eval { main->$c }; | |
61 | ok $@, q!$c can't call $b's sub.!; | |
62 | ||
63 | # Now define another sub under the downgraded name: | |
64 | *$a = sub { 6 }; | |
65 | # Call it: | |
66 | is eval { main->$a }, 6, "Adding a new sub to *a and calling it works,"; | |
67 | ok !$@, "..without errors."; | |
68 | eval { main->$c }; | |
69 | ok $@, "but it's still unreachable through *c"; | |
70 | ||
71 | *$b = \10; | |
72 | is ${*$a{SCALAR}}, 10; | |
73 | is ${*$b{SCALAR}}, 10; | |
74 | is ${*$c{SCALAR}}, undef; | |
75 | ||
76 | opendir FÒÒ, "."; | |
77 | closedir FÒÒ; | |
78 | ::ok($::{"FÒÒ"}, "Bareword generates the right glob."); | |
79 | ::ok(!$::{"F\303\222\303\222"}); | |
80 | ||
81 | sub участники { 1 } | |
82 | ||
83 | ok $::{"участники"}, "non-const sub declarations generate the right glob"; | |
84 | ok *{$::{"участники"}}{CODE}; | |
85 | is *{$::{"участники"}}{CODE}->(), 1; | |
86 | ||
3453414d BF |
87 | sub 原 () { 1 } |
88 | ||
89 | is grep({ $_ eq "\x{539f}" } keys %::), 1, "Constant subs generate the right glob."; | |
90 | is grep({ $_ eq "\345\216\237" } keys %::), 0; | |
91 | ||
108f32a5 BF |
92 | #These should probably go elsewhere. |
93 | eval q{ sub wròng1 (_$); wròng1(1,2) }; | |
94 | like( $@, qr/Malformed prototype for main::wròng1/, 'Malformed prototype croak is clean.' ); | |
95 | ||
96 | eval q{ sub ча::ики ($__); ча::ики(1,2) }; | |
97 | like( $@, qr/Malformed prototype for ча::ики/ ); | |
98 | ||
23b0eed2 BF |
99 | our $問 = 10; |
100 | is $問, 10, "our works"; | |
101 | is $main::問, 10, "...as does getting the same variable through the fully qualified name"; | |
102 | is ${"main::\345\225\217"}, undef, "..and using the encoded form doesn't"; | |
e2f06df0 BF |
103 | |
104 | { | |
105 | use charnames qw( :full ); | |
106 | ||
107 | eval qq! my \$\x{30cb} \N{DROMEDARY CAMEL} !; | |
055745ba | 108 | $@ =~ s/eval \d+/eval 11/; |
08454bd8 | 109 | is $@, 'Unrecognized character \x{1f42a}; marked by <-- HERE after my $ニ <-- HERE near column 8 at (eval 11) line 1. |
e2f06df0 | 110 | ', "'Unrecognized character' croak is UTF-8 clean"; |
84051091 BF |
111 | |
112 | eval "q\0foobar\0 \x{FFFF}+1"; | |
113 | $@ =~ s/eval \d+/eval 11/; | |
114 | is( | |
115 | $@, | |
116 | "Unrecognized character \\x{ffff}; marked by <-- HERE after q\0foobar\0 <-- HERE near column 11 at (eval 11) line 1.\n", | |
117 | "...and nul-clean" | |
118 | ); | |
119 | ||
ce4bd586 | 120 | { |
84051091 BF |
121 | use re 'eval'; |
122 | my $f = qq{(?{\$ネ+ 1; \x{1F42A} })}; | |
123 | eval { "a" =~ /^a$f/ }; | |
124 | my $e = $@; | |
125 | $e =~ s/eval \d+/eval 11/; | |
126 | is( | |
127 | $e, | |
128 | "Unrecognized character \\x{1f42a}; marked by <-- HERE after (?{\$ネ+ 1; <-- HERE near column 13 at (eval 11) line 1.\n", | |
129 | "Messages from a re-eval are UTF-8 clean" | |
130 | ); | |
131 | ||
132 | $f = qq{(?{q\0foobar\0 \x{FFFF}+1 })}; | |
133 | eval { "a" =~ /^a$f/ }; | |
134 | my $e = $@; | |
135 | $e =~ s/eval \d+/eval 11/; | |
136 | is( | |
137 | $e, | |
138 | "Unrecognized character \\x{ffff}; marked by <-- HERE after q\x{0}foobar\x{0} <-- HERE near column 16 at (eval 11) line 1.\n", | |
139 | "...and nul-clean" | |
140 | ); | |
141 | } | |
142 | ||
143 | { | |
144 | eval qq{\$ネ+ 1; \x{1F42A}}; | |
145 | $@ =~ s/eval \d+/eval 11/; | |
146 | is( | |
147 | $@, | |
148 | "Unrecognized character \\x{1f42a}; marked by <-- HERE after \$ネ+ 1; <-- HERE near column 8 at (eval 11) line 1.\n", | |
149 | "Unrecognized character error doesn't cut off in the middle of characters" | |
150 | ) | |
151 | } | |
152 | ||
e2f06df0 | 153 | } |
3c54b17a BF |
154 | |
155 | { | |
156 | use feature 'state'; | |
157 | for ( qw( my state our ) ) { | |
158 | local $@; | |
159 | eval "$_ Foo $x = 1;"; | |
160 | like $@, qr/No such class Foo/u, "'No such class' warning for $_ is UTF-8 clean"; | |
161 | } | |
4bca4ee0 BF |
162 | } |
163 | ||
164 | { | |
165 | local $@; | |
166 | eval "our \$main::\x{30cb};"; | |
167 | like $@, qr!No package name allowed for variable \$main::\x{30cb} in "our"!, "'No such package name allowed for variable' is UTF-8 clean"; | |
168 | } | |
58576270 BF |
169 | |
170 | { | |
171 | use feature 'state'; | |
172 | local $@; | |
173 | for ( qw( my state ) ) { | |
174 | eval "$_ \$::\x{30cb};"; | |
175 | like $@, qr!"$_" variable \$::\x{30cb} can't be in a package!, qq!'"$_" variable %s can't be in a package' is UTF-8 clean!; | |
176 | } | |
177 | } | |
d0fb66e4 BF |
178 | |
179 | { | |
180 | local $@; | |
181 | eval qq!print \x{30cb}, "comma""!; | |
182 | like $@, qr/No comma allowed after filehandle/, "No comma allowed after filehandle triggers correctly for UTF-8 filehandles."; | |
183 | } | |
86fe3f36 BF |
184 | |
185 | # tests for "Bad name" | |
186 | eval q{ Foo::$bar }; | |
187 | like( $@, qr/Bad name after Foo::/, 'Bad name after Foo::' ); | |
188 | eval q{ Foo''bar }; | |
189 | like( $@, qr/Bad name after Foo'/, 'Bad name after Foo\'' ); | |
107160e2 KW |
190 | |
191 | { | |
192 | no warnings 'utf8'; | |
193 | my $malformed_to_be = "\x{c0}\x{a0}"; # Overlong sequence | |
194 | CORE::evalbytes "use charnames ':full'; use utf8; my \$x = \"\\N{abc$malformed_to_be}\""; | |
be192702 | 195 | like( $@, qr/Malformed UTF-8 character immediately after '\\N\{abc' at .* within string/, 'Malformed UTF-8 input to \N{}'); |
107160e2 | 196 | } |