| 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 | |
| 10 | plan (tests => 52); |
| 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 | |
| 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 | |
| 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 | |
| 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"; |
| 103 | |
| 104 | { |
| 105 | use charnames qw( :full ); |
| 106 | |
| 107 | eval qq! my \$\x{30cb} \N{DROMEDARY CAMEL} !; |
| 108 | $@ =~ s/eval \d+/eval 11/; |
| 109 | is $@, 'Unrecognized character \x{1f42a}; marked by <-- HERE after my $ニ <-- HERE near column 8 at (eval 11) line 1. |
| 110 | ', "'Unrecognized character' croak is UTF-8 clean"; |
| 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 | |
| 120 | { |
| 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 | |
| 153 | } |
| 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 | } |
| 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 | } |
| 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 | } |
| 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 | } |
| 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\'' ); |
| 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}\""; |
| 195 | like( $@, qr/Malformed UTF-8 character immediately after '\\N\{abc' at .* within string/, 'Malformed UTF-8 input to \N{}'); |
| 196 | } |