t/uni/parser.t

   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 { *ｍａｉｎ::method }->();
  19
  20 is *ｍａｉｎ::method, "*ｍａｉｎ::method", "glob stringy works";
  21 is "" . *ｍａｉｎ::method, "*ｍａｉｎ::method", "glob stringify-through-concat works";
  22 is $glob_by_sub, "*ｍａｉｎ::method", "glob stringy works";
  23 is "" . $glob_by_sub, "*ｍａｉｎ::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 "$_ Ｆｏｏ $x = 1;";
 160         like $@, qr/No such class Ｆｏｏ/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{ Ｆｏｏ::$bar };
 187 like( $@, qr/Bad name after Ｆｏｏ::/, 'Bad name after Ｆｏｏ::' );
 188 eval q{ Ｆｏｏ''bar };
 189 like( $@, qr/Bad name after Ｆｏｏ'/, 'Bad name after Ｆｏｏ\'' );
 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 }