| 1 | #!./perl |
| 2 | |
| 3 | # Checks if the parser behaves correctly in edge cases |
| 4 | # (including weird syntax errors) |
| 5 | |
| 6 | BEGIN { |
| 7 | chdir 't' if -d 't'; |
| 8 | require './test.pl'; |
| 9 | skip_all_without_unicode_tables(); |
| 10 | } |
| 11 | |
| 12 | plan (tests => 52); |
| 13 | |
| 14 | use utf8; |
| 15 | use open qw( :utf8 :std ); |
| 16 | |
| 17 | is *tèst, "*main::tèst", "sanity check."; |
| 18 | ok $::{"tèst"}, "gets the right glob in the stash."; |
| 19 | |
| 20 | my $glob_by_sub = sub { *main::method }->(); |
| 21 | |
| 22 | is *main::method, "*main::method", "glob stringy works"; |
| 23 | is "" . *main::method, "*main::method", "glob stringify-through-concat works"; |
| 24 | is $glob_by_sub, "*main::method", "glob stringy works"; |
| 25 | is "" . $glob_by_sub, "*main::method", ""; |
| 26 | |
| 27 | sub gimme_glob { |
| 28 | no strict 'refs'; |
| 29 | is *{$_[0]}, "*main::$_[0]"; |
| 30 | *{$_[0]}; |
| 31 | } |
| 32 | |
| 33 | is "" . gimme_glob("下郎"), "*main::下郎"; |
| 34 | $a = *下郎; |
| 35 | is "" . $a, "*main::下郎"; |
| 36 | |
| 37 | *{gimme_glob("下郎")} = sub {}; |
| 38 | |
| 39 | { |
| 40 | ok defined *{"下郎"}{CODE}; |
| 41 | ok !defined *{"\344\270\213\351\203\216"}{CODE}; |
| 42 | } |
| 43 | |
| 44 | $Lèon = 1; |
| 45 | is ${*Lèon{SCALAR}}, 1, "scalar define in the right glob,"; |
| 46 | ok !${*{"L\303\250on"}{SCALAR}}, "..and nothing in the wrong one."; |
| 47 | |
| 48 | my $a = "foo" . chr(190); |
| 49 | my $b = $a . chr(256); |
| 50 | chop $b; # $b is $a with utf8 on |
| 51 | |
| 52 | is $a, $b, '$a equals $b'; |
| 53 | |
| 54 | *$b = sub { 5 }; |
| 55 | |
| 56 | is eval { main->$a }, 5, q!$a can call $b's sub!; |
| 57 | ok !$@, "..and there's no error."; |
| 58 | |
| 59 | my $c = $b; |
| 60 | utf8::encode($c); |
| 61 | ok $b ne $c, '$b unequal $c'; |
| 62 | eval { main->$c }; |
| 63 | ok $@, q!$c can't call $b's sub.!; |
| 64 | |
| 65 | # Now define another sub under the downgraded name: |
| 66 | *$a = sub { 6 }; |
| 67 | # Call it: |
| 68 | is eval { main->$a }, 6, "Adding a new sub to *a and calling it works,"; |
| 69 | ok !$@, "..without errors."; |
| 70 | eval { main->$c }; |
| 71 | ok $@, "but it's still unreachable through *c"; |
| 72 | |
| 73 | *$b = \10; |
| 74 | is ${*$a{SCALAR}}, 10; |
| 75 | is ${*$b{SCALAR}}, 10; |
| 76 | is ${*$c{SCALAR}}, undef; |
| 77 | |
| 78 | opendir FÒÒ, "."; |
| 79 | closedir FÒÒ; |
| 80 | ::ok($::{"FÒÒ"}, "Bareword generates the right glob."); |
| 81 | ::ok(!$::{"F\303\222\303\222"}); |
| 82 | |
| 83 | sub участники { 1 } |
| 84 | |
| 85 | ok $::{"участники"}, "non-const sub declarations generate the right glob"; |
| 86 | is $::{"участники"}->(), 1; |
| 87 | |
| 88 | sub 原 () { 1 } |
| 89 | |
| 90 | is grep({ $_ eq "\x{539f}" } keys %::), 1, "Constant subs generate the right glob."; |
| 91 | is grep({ $_ eq "\345\216\237" } keys %::), 0; |
| 92 | |
| 93 | #These should probably go elsewhere. |
| 94 | eval q{ sub wròng1 (_$); wròng1(1,2) }; |
| 95 | like( $@, qr/Malformed prototype for main::wròng1/, 'Malformed prototype croak is clean.' ); |
| 96 | |
| 97 | eval q{ sub ча::ики ($__); ча::ики(1,2) }; |
| 98 | like( $@, qr/Malformed prototype for ча::ики/ ); |
| 99 | |
| 100 | our $問 = 10; |
| 101 | is $問, 10, "our works"; |
| 102 | is $main::問, 10, "...as does getting the same variable through the fully qualified name"; |
| 103 | is ${"main::\345\225\217"}, undef, "..and using the encoded form doesn't"; |
| 104 | |
| 105 | { |
| 106 | use charnames qw( :full ); |
| 107 | |
| 108 | eval qq! my \$\x{30cb} \N{DROMEDARY CAMEL} !; |
| 109 | $@ =~ s/eval \d+/eval 11/; |
| 110 | is $@, 'Unrecognized character \x{1f42a}; marked by <-- HERE after my $ニ <-- HERE near column 8 at (eval 11) line 1. |
| 111 | ', "'Unrecognized character' croak is UTF-8 clean"; |
| 112 | |
| 113 | eval "q\0foobar\0 \x{FFFF}+1"; |
| 114 | $@ =~ s/eval \d+/eval 11/; |
| 115 | is( |
| 116 | $@, |
| 117 | "Unrecognized character \\x{ffff}; marked by <-- HERE after q\0foobar\0 <-- HERE near column 11 at (eval 11) line 1.\n", |
| 118 | "...and nul-clean" |
| 119 | ); |
| 120 | |
| 121 | { |
| 122 | use re 'eval'; |
| 123 | my $f = qq{(?{\$ネ+ 1; \x{1F42A} })}; |
| 124 | eval { "a" =~ /^a$f/ }; |
| 125 | my $e = $@; |
| 126 | $e =~ s/eval \d+/eval 11/; |
| 127 | is( |
| 128 | $e, |
| 129 | "Unrecognized character \\x{1f42a}; marked by <-- HERE after (?{\$ネ+ 1; <-- HERE near column 13 at (eval 11) line 1.\n", |
| 130 | "Messages from a re-eval are UTF-8 clean" |
| 131 | ); |
| 132 | |
| 133 | $f = qq{(?{q\0foobar\0 \x{FFFF}+1 })}; |
| 134 | eval { "a" =~ /^a$f/ }; |
| 135 | my $e = $@; |
| 136 | $e =~ s/eval \d+/eval 11/; |
| 137 | is( |
| 138 | $e, |
| 139 | "Unrecognized character \\x{ffff}; marked by <-- HERE after q\x{0}foobar\x{0} <-- HERE near column 16 at (eval 11) line 1.\n", |
| 140 | "...and nul-clean" |
| 141 | ); |
| 142 | } |
| 143 | |
| 144 | { |
| 145 | eval qq{\$ネ+ 1; \x{1F42A}}; |
| 146 | $@ =~ s/eval \d+/eval 11/; |
| 147 | is( |
| 148 | $@, |
| 149 | "Unrecognized character \\x{1f42a}; marked by <-- HERE after \$ネ+ 1; <-- HERE near column 8 at (eval 11) line 1.\n", |
| 150 | "Unrecognized character error doesn't cut off in the middle of characters" |
| 151 | ) |
| 152 | } |
| 153 | |
| 154 | } |
| 155 | |
| 156 | { |
| 157 | use feature 'state'; |
| 158 | for ( qw( my state our ) ) { |
| 159 | local $@; |
| 160 | eval "$_ Foo $x = 1;"; |
| 161 | like $@, qr/No such class Foo/u, "'No such class' warning for $_ is UTF-8 clean"; |
| 162 | } |
| 163 | } |
| 164 | |
| 165 | { |
| 166 | local $@; |
| 167 | eval "our \$main::\x{30cb};"; |
| 168 | like $@, qr!No package name allowed for variable \$main::\x{30cb} in "our"!, "'No such package name allowed for variable' is UTF-8 clean"; |
| 169 | } |
| 170 | |
| 171 | { |
| 172 | use feature 'state'; |
| 173 | local $@; |
| 174 | for ( qw( my state ) ) { |
| 175 | eval "$_ \$::\x{30cb};"; |
| 176 | like $@, qr!"$_" variable \$::\x{30cb} can't be in a package!, qq!'"$_" variable %s can't be in a package' is UTF-8 clean!; |
| 177 | } |
| 178 | } |
| 179 | |
| 180 | { |
| 181 | local $@; |
| 182 | eval qq!print \x{30cb}, "comma""!; |
| 183 | like $@, qr/No comma allowed after filehandle/, "No comma allowed after filehandle triggers correctly for UTF-8 filehandles."; |
| 184 | } |
| 185 | |
| 186 | # tests for "Bad name" |
| 187 | eval q{ Foo::$bar }; |
| 188 | like( $@, qr/Bad name after Foo::/, 'Bad name after Foo::' ); |
| 189 | eval q{ Foo''bar }; |
| 190 | like( $@, qr/Bad name after Foo'/, 'Bad name after Foo\'' ); |
| 191 | |
| 192 | { |
| 193 | no warnings 'utf8'; |
| 194 | my $malformed_to_be = ($::IS_EBCDIC) # Overlong sequence |
| 195 | ? "\x{74}\x{41}" |
| 196 | : "\x{c0}\x{a0}"; |
| 197 | CORE::evalbytes "use charnames ':full'; use utf8; my \$x = \"\\N{abc$malformed_to_be}\""; |
| 198 | like( $@, qr/Malformed UTF-8 character immediately after '\\N\{abc' at .* within string/, 'Malformed UTF-8 input to \N{}'); |
| 199 | } |
| 200 | |
| 201 | # RT# 124216: Perl_sv_clear: Assertion |
| 202 | # If a parsing error occurred during a forced token within an interpolated |
| 203 | # context, the stack unwinding failed to restore PL_lex_defer and so after |
| 204 | # error recovery the state restored after the forced token was processed |
| 205 | # was the wrong one, resulting in the lexer thinking we're still inside a |
| 206 | # quoted string and things getting freed multiple times. |
| 207 | # |
| 208 | # The \x{3030} char isn't a legal var name, and this triggers the error. |
| 209 | # |
| 210 | # NB: this only failed if the closing quote of the interpolated string is |
| 211 | # the last char of the file (i.e. no trailing \n). |
| 212 | |
| 213 | { |
| 214 | my $bad = "\x{3030}"; |
| 215 | # Write out the individual utf8 bytes making up \x{3030}. This |
| 216 | # avoids 'Wide char in print' warnings from test.pl. (We may still |
| 217 | # get that warning when compiling the prog itself, since the |
| 218 | # error it prints to stderr contains a wide char.) |
| 219 | utf8::encode($bad); |
| 220 | |
| 221 | fresh_perl_like(qq{use utf8; "\$$bad"}, |
| 222 | qr/ |
| 223 | \A |
| 224 | ( \QWide character in print at - line 1.\E\n )? |
| 225 | \Qsyntax error at - line 1, near \E"\$.*"\n |
| 226 | \QExecution of - aborted due to compilation errors.\E\z |
| 227 | /xm, |
| 228 | |
| 229 | {stderr => 1}, "RT# 124216"); |
| 230 | } |