+
+#
+# bug fixed by change #17928
+# separate perl used because we rely on 'strict' not yet loaded;
+# before the patch, the eval died with an error like:
+# "my" variable $strict::VERSION can't be in a package
+#
+SKIP: {
+ skip("Haven't bothered to port this to EBCDIC non-1047", 1) if $::IS_EBCDIC
+ && ord '^' != 95;
+ if ($::IS_ASCII) {
+ ok('' eq runperl(prog => <<'CODE'), "change #17928");
+ my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
+ {
+ use utf8;
+ eval $code;
+ print $@ if $@;
+ }
+CODE
+ }
+ else {
+ ok('' eq runperl(prog => <<'CODE'), "change #17928");
+ my $code = qq{ my \$\xCE\x47\x64\xCE\x48\x70 = 5; };
+ {
+ use utf8;
+ eval $code;
+ print $@ if $@;
+ }
+CODE
+ }
+}
+
+{
+ use utf8;
+ $a = <<'END';
+0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
+END
+ my (@i, $s);
+
+ @i = ();
+ push @i, $s = index($a, '6'); # 60
+ push @i, $s = index($a, '.', $s); # next . after 60 is 62
+ push @i, $s = index($a, '5'); # 50
+ push @i, $s = index($a, '.', $s); # next . after 52 is 52
+ push @i, $s = index($a, '7'); # 70
+ push @i, $s = index($a, '.', $s); # next . after 70 is 72
+ push @i, $s = index($a, '4'); # 40
+ push @i, $s = index($a, '.', $s); # next . after 40 is 42
+ is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
+
+ @i = ();
+ push @i, $s = rindex($a, '6'); # 60
+ push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
+ push @i, $s = rindex($a, '5'); # 50
+ push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
+ push @i, $s = rindex($a, '7'); # 70
+ push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
+ push @i, $s = rindex($a, '4'); # 40
+ push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
+ is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
+
+ @i = ();
+ push @i, $s = index($a, '6'); # 60
+ push @i, index($a, '.', $s); # next . after 60 is 62
+ push @i, rindex($a, '.', $s); # previous . before 60 is 58
+ push @i, $s = rindex($a, '5'); # 60
+ push @i, index($a, '.', $s); # next . after 50 is 52
+ push @i, rindex($a, '.', $s); # previous . before 50 is 48
+ push @i, $s = index($a, '7', $s); # 70
+ push @i, index($a, '.', $s); # next . after 70 is 72
+ push @i, rindex($a, '.', $s); # previous . before 70 is 68
+ is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
+}
+
+SKIP: {
+ skip("Haven't bothered to port this to EBCDIC non-1047", 1) if $::IS_EBCDIC
+ && ord '^' != 95;
+ use utf8;
+ if ($::IS_ASCII) {
+ is eval qq{q \xc3\xbc test \xc3\xbc . qq\xc2\xb7 test \xc2\xb7},
+ ' test test ',
+ "utf8 quote delimiters [perl #16823]";
+ }
+ else {
+ is eval qq{q \x8B\x70 test \x8B\x70 . qq\x80\x66 test \x80\x66},
+ ' test test ',
+ "utf8 quote delimiters [perl #16823]";
+ }
+}
+
+# Test the "internals".
+
+{
+ my $a = "A";
+ my $b = chr(0x0FF);
+ my $c = chr(0x0DF); # FF is invariant in many EBCDIC pages, so is not a
+ # fair test of 'beyond'; but DF is variant (in all
+ # supported EBCDIC pages so far), so make 2 'beyond'
+ # tests
+ my $d = chr(0x100);
+
+ ok( utf8::valid($a), "utf8::valid basic");
+ ok( utf8::valid($b), "utf8::valid beyond");
+ ok( utf8::valid($c), "utf8::valid beyond");
+ ok( utf8::valid($d), "utf8::valid unicode");
+
+ ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
+ ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
+ ok(!utf8::is_utf8($c), "!utf8::is_utf8 beyond");
+ ok( utf8::is_utf8($d), "utf8::is_utf8 unicode");
+
+ is(utf8::upgrade($a), 1, "utf8::upgrade basic");
+ if ($::IS_EBCDIC) { # EBCDIC.
+ is(utf8::upgrade($b), 1, "utf8::upgrade beyond");
+ } else {
+ is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
+ }
+ is(utf8::upgrade($c), 2, "utf8::upgrade beyond");
+ is(utf8::upgrade($d), 2, "utf8::upgrade unicode");
+
+ is($a, "A", "basic");
+ is($b, "\xFF", "beyond");
+ is($c, "\xDF", "beyond");
+ is($d, "\x{100}", "unicode");
+
+ ok( utf8::valid($a), "utf8::valid basic");
+ ok( utf8::valid($b), "utf8::valid beyond");
+ ok( utf8::valid($c), "utf8::valid beyond");
+ ok( utf8::valid($d), "utf8::valid unicode");
+
+ ok( utf8::is_utf8($a), "utf8::is_utf8 basic");
+ ok( utf8::is_utf8($b), "utf8::is_utf8 beyond");
+ ok( utf8::is_utf8($c), "utf8::is_utf8 beyond");
+ ok( utf8::is_utf8($d), "utf8::is_utf8 unicode");
+
+ is(utf8::downgrade($a), 1, "utf8::downgrade basic");
+ is(utf8::downgrade($b), 1, "utf8::downgrade beyond");
+ is(utf8::downgrade($c), 1, "utf8::downgrade beyond");
+
+ is($a, "A", "basic");
+ is($b, "\xFF", "beyond");
+ is($c, "\xDF", "beyond");
+
+ ok( utf8::valid($a), "utf8::valid basic");
+ ok( utf8::valid($b), "utf8::valid beyond");
+ ok( utf8::valid($c), "utf8::valid beyond");
+
+ ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
+ ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
+ ok(!utf8::is_utf8($c), "!utf8::is_utf8 beyond");
+
+ utf8::encode($a);
+ utf8::encode($b);
+ utf8::encode($c);
+ utf8::encode($d);
+
+ is($a, "A", "basic");
+ if ($::IS_EBCDIC) { # EBCDIC.
+ is(length($b), 1, "beyond length");
+ } else {
+ is(length($b), 2, "beyond length");
+ }
+ is(length($c), 2, "beyond length");
+ is(length($d), 2, "unicode length");
+
+ ok(utf8::valid($a), "utf8::valid basic");
+ ok(utf8::valid($b), "utf8::valid beyond");
+ ok(utf8::valid($c), "utf8::valid beyond");
+ ok(utf8::valid($d), "utf8::valid unicode");
+
+ # encode() clears the UTF-8 flag (unlike upgrade()).
+ ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
+ ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
+ ok(!utf8::is_utf8($c), "!utf8::is_utf8 beyond");
+ ok(!utf8::is_utf8($d), "!utf8::is_utf8 unicode");
+
+ utf8::decode($a);
+ utf8::decode($b);
+ utf8::decode($c);
+ utf8::decode($d);
+
+ is($a, "A", "basic");
+ is($b, "\xFF", "beyond");
+ is($c, "\xDF", "beyond");
+ is($d, "\x{100}", "unicode");
+
+ ok(utf8::valid($a), "!utf8::valid basic");
+ ok(utf8::valid($b), "!utf8::valid beyond");
+ ok(utf8::valid($c), "!utf8::valid beyond");
+ ok(utf8::valid($d), " utf8::valid unicode");
+
+ ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
+ if ($::IS_EBCDIC) { # EBCDIC.
+ ok( utf8::is_utf8(pack('U',0x0ff)), " utf8::is_utf8 beyond");
+ } else {
+ ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
+ }
+ ok( utf8::is_utf8($c), " utf8::is_utf8 beyond"); # $c stays in UTF-8.
+ ok( utf8::is_utf8($d), " utf8::is_utf8 unicode");
+}
+
+{
+ eval {utf8::encode("£")};
+ like($@, qr/^Modification of a read-only value attempted/,
+ "utf8::encode should refuse to touch read-only values");
+}
+
+{
+ # Make sure utf8::decode respects copy-on-write [perl #91834].
+ # Hash keys are the easiest way to test this.
+ my $name = byte_utf8a_to_utf8n("\x{c3}\x{b3}");
+ my ($k1) = keys %{ { $name=>undef } };
+ my $k2 = $name;
+ utf8::decode($k1);
+ utf8::decode($k2);
+ my $h = { $k1 => 1, $k2 => 2 };
+ is join('', keys %$h), $k2, 'utf8::decode respects copy-on-write';
+}
+
+{
+ # Make sure utf8::decode does not modify read-only scalars
+ # [perl #91850].
+
+ my $name = byte_utf8a_to_utf8n("\x{c3}\x{b3}");
+ Internals::SvREADONLY($name, 1);
+ eval { utf8::decode($name) };
+ like $@, qr/^Modification of a read-only/,
+ 'utf8::decode respects readonliness';
+}
+
+{
+ # utf8::decode should stringify refs [perl #91852].
+
+ package eieifg { use overload '""' => sub { main::byte_utf8a_to_utf8n("\x{c3}\x{b3}") },
+ fallback => 1 }
+
+ my $name = bless[], eieifg::;
+ utf8::decode($name);
+ is $name, uni_to_native("\xf3"), 'utf8::decode flattens references';
+}
+
+{
+ # What do the utf8::* functions do when given a reference? A test
+ # for a behavior change that made this start dying as of
+ # v5.15.6-407-gc710240 due to a fix for [perl #91852]:
+ #
+ # ./miniperl -Ilib -wle 'use strict; print $]; my $s = shift; my $s_ref = \$s; utf8::decode($s_ref); print $$s_ref' hlagh
+ my %expected = (
+ 'utf8::is_utf8' => { returns => "hlagh" },
+ 'utf8::valid' => { returns => "hlagh" },
+ 'utf8::encode' => { error => qr/Can't use string .*? as a SCALAR ref/},
+ 'utf8::decode' => { error => qr/Can't use string .*? as a SCALAR ref/},
+ 'utf8::upgrade' => { error => qr/Can't use string .*? as a SCALAR ref/ },
+ 'utf8::downgrade' => { returns => "hlagh" },
+ 'utf8::native_to_unicode' => { returns => "hlagh" },
+ 'utf8::unicode_to_native' => { returns => "hlagh" },
+ );
+ for my $func (sort keys %expected) { # sort just so it's deterministic wrt diffing *.t output
+ my $code = sprintf q[
+ use strict;
+ my $s = "hlagh";
+ my $r = \$s;
+ my $dummy = %s($r);
+ $$r;
+ ], $func;
+ my $ret = eval $code or my $error = $@;
+ if (my $error_rx = $expected{$func}->{error}) {
+ if (defined $error) {
+ like $error, $error_rx, "The $func function should die with an error matching $error_rx";
+ } else {
+ fail("We were expecting an error when calling the $func function but got a value of '$ret' instead");
+ }
+ } elsif (my $returns = $expected{$func}->{returns}) {
+ is($ret, $returns, "The $func function lives and returns '$returns' as expected");
+ } else {
+ die "PANIC: Internal Error"
+ }
+ }
+}
+
+{
+ my $a = "456" . uni_to_native("\xb6");
+ utf8::upgrade($a);
+
+ my $b = "123456" . uni_to_native("\xb6");
+ $b =~ s/^...//;
+ utf8::upgrade($b);
+ is($b, $a, "utf8::upgrade OffsetOK");
+}
+
+{
+ fresh_perl_like ('use utf8; utf8::moo()',
+ qr/Undefined subroutine utf8::moo/, {stderr=>1},
+ "Check Carp is loaded for AUTOLOADing errors")
+}
+
+{
+ # failure of is_utf8_char() without NATIVE_TO_UTF on EBCDIC (0260..027F)
+ ok(utf8::valid(chr(0x250)), "0x250");
+ ok(utf8::valid(chr(0x260)), "0x260");
+ ok(utf8::valid(chr(0x270)), "0x270");
+ ok(utf8::valid(chr(0x280)), "0x280");
+}
+
+{
+ use utf8;
+ ok( !utf8::is_utf8( "asd" ), "Wasteful format - qq{}" );
+ ok( !utf8::is_utf8( 'asd' ), "Wasteful format - q{}" );
+ ok( !utf8::is_utf8( qw(asd) ), "Wasteful format - qw{}" );
+ ok( !utf8::is_utf8( (asd => 1)[0] ), "Wasteful format - =>" );
+ ok( !utf8::is_utf8( -asd ), "Wasteful format - -word" );
+ no warnings 'bareword';
+ ok( !utf8::is_utf8( asd:: ), "Wasteful format - word::" );
+ no warnings 'reserved';
+ no strict 'subs';
+ ok( !utf8::is_utf8( asd ), "Wasteful format - bareword" );
+}
+
+{
+ my @highest =
+ (undef, 0x7F, 0x7FF, 0xFFFF, 0x1FFFFF, 0x3FFFFFF, 0x7FFFFFFF);
+ my @step =
+ (undef, undef, 0x40, 0x1000, 0x40000, 0x1000000, 0x40000000);
+
+ foreach my $length (6, 5, 4, 3, 2) {
+ my $high = $highest[$length];
+ while ($high > $highest[$length - 1]) {
+ my $low = $high - $step[$length] + 1;
+ $low = $highest[$length - 1] + 1 if $low <= $highest[$length - 1];
+ ok(utf8::valid(do {no warnings 'utf8'; chr $low}),
+ sprintf "chr %x, length $length is valid", $low);
+ ok(utf8::valid(do {no warnings 'utf8'; chr $high}),
+ sprintf "chr %x, length $length is valid", $high);
+ $high -= $step[$length];
+ }
+ }
+}
+
+# #80190 update pos, and cached length/position-mapping after
+# utf8 upgrade/downgrade, encode/decode
+
+for my $pos (0..5) {
+
+ my $p;
+ my $utf8_bytes = byte_utf8a_to_utf8n("\xc8\x81\xe3\xbf\xbf");
+ my $s = "A$utf8_bytes\x{100}";
+ chop($s);
+
+ pos($s) = $pos;
+ # also sets cache
+ is(length($s), 6, "(pos $pos) len before utf8::downgrade");
+ is(pos($s), $pos, "(pos $pos) pos before utf8::downgrade");
+ utf8::downgrade($s);
+ is(length($s), 6, "(pos $pos) len after utf8::downgrade");
+ is(pos($s), $pos, "(pos $pos) pos after utf8::downgrade");
+ is($s, "A$utf8_bytes","(pos $pos) str after utf8::downgrade");
+ utf8::decode($s);
+ is(length($s), 3, "(pos $pos) len after D; utf8::decode");
+ is(pos($s), undef, "(pos $pos) pos after D; utf8::decode");
+ is($s, "A\x{201}\x{3fff}", "(pos $pos) str after D; utf8::decode");
+ utf8::encode($s);
+ is(length($s), 6, "(pos $pos) len after D; utf8::encode");
+ is(pos($s), undef, "(pos $pos) pos after D; utf8::encode");
+ is($s, "A$utf8_bytes","(pos $pos) str after D; utf8::encode");
+
+ $s = "A$utf8_bytes";
+
+ pos($s) = $pos;
+ is(length($s), 6, "(pos $pos) len before utf8::upgrade");
+ is(pos($s), $pos, "(pos $pos) pos before utf8::upgrade");
+ utf8::upgrade($s);
+ is(length($s), 6, "(pos $pos) len after utf8::upgrade");
+ is(pos($s), $pos, "(pos $pos) pos after utf8::upgrade");
+ is($s, "A$utf8_bytes","(pos $pos) str after utf8::upgrade");
+ utf8::decode($s);
+ is(length($s), 3, "(pos $pos) len after U; utf8::decode");
+ is(pos($s), undef, "(pos $pos) pos after U; utf8::decode");
+ is($s, "A\x{201}\x{3fff}", "(pos $pos) str after U; utf8::decode");
+ utf8::encode($s);
+ is(length($s), 6, "(pos $pos) len after U; utf8::encode");
+ is(pos($s), undef, "(pos $pos) pos after U; utf8::encode");
+ is($s, "A$utf8_bytes","(pos $pos) str after U; utf8::encode");
+}
+
+SKIP: {
+ skip("Test only valid on ASCII platform", 1) unless $::IS_ASCII;
+ require Config;
+ skip("Test needs a B module, which is lacking in this Perl", 1)
+ if $Config::Config{'extensions'} !~ /\bB\b/;
+
+ my $out = runperl ( switches => ["-XMO=Concise"],
+ prog => 'utf8::unicode_to_native(0x41);
+ utf8::native_to_unicode(0x42)',
+ stderr => 1 );
+ unlike($out, qr/entersub/,
+ "utf8::unicode_to_native() and native_to_unicode() optimized out");
+}
+
+
+# [perl #119043] utf8::upgrade should not croak on read-only COWs
+for(__PACKAGE__) {
+ eval { utf8::upgrade($_) };
+ is $@, "", 'no error with utf8::upgrade on read-only COW';
+}
+# This one croaks, but not because the scalar is read-only
+eval "package \x{100};\n" . <<'END'
+ for(__PACKAGE__) {
+ eval { utf8::downgrade($_) };
+ ::like $@, qr/^Wide character/,
+ 'right error with utf8::downgrade on read-only COW';
+ }
+ 1
+END
+or die $@;
+
+done_testing();