[perl5.git] / lib / utf8.t

#!./perl 

my $has_perlio;

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
    unless ($has_perlio = find PerlIO::Layer 'perlio') {
	print <<EOF;
# Since you don't have perlio you might get failures with UTF-8 locales.
EOF
    }
}

no utf8; # Ironic, no?

# NOTE!
#
# Think carefully before adding tests here.  In general this should be
# used only for about three categories of tests:
#
# (1) tests that absolutely require 'use utf8', and since that in general
#     shouldn't be needed as the utf8 is being obsoleted, this should
#     have rather few tests.  If you want to test Unicode and regexes,
#     you probably want to go to op/regexp or op/pat; if you want to test
#     split, go to op/split; pack, op/pack; appending or joining,
#     op/append or op/join, and so forth
#
# (2) tests that have to do with Unicode tokenizing (though it's likely
#     that all the other Unicode tests sprinkled around the t/**/*.t are
#     going to catch that)
#
# (3) complicated tests that simultaneously stress so many Unicode features
#     that deciding into which other test script the tests should go to
#     is hard -- maybe consider breaking up the complicated test
#
#

plan tests => 150;

{
    # bug id 20001009.001

    my ($a, $b);

    { use bytes; $a = "\xc3\xa4" }
    { use utf8;  $b = "\xe4"     }

    my $test = 68;

    ok($a ne $b);

    { use utf8; ok($a ne $b) }
}


{
    # bug id 20000730.004

    my $smiley = "\x{263a}";

    for my $s ("\x{263a}",
	       $smiley,
		
	       "" . $smiley,
	       "" . "\x{263a}",

	       $smiley    . "",
	       "\x{263a}" . "",
	       ) {
	my $length_chars = length($s);
	my $length_bytes;
	{ use bytes; $length_bytes = length($s) }
	my @regex_chars = $s =~ m/(.)/g;
	my $regex_chars = @regex_chars;
	my @split_chars = split //, $s;
	my $split_chars = @split_chars;
	ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
	   "1/1/1/3");
    }

    for my $s ("\x{263a}" . "\x{263a}",
	       $smiley    . $smiley,

	       "\x{263a}\x{263a}",
	       "$smiley$smiley",
	       
	       "\x{263a}" x 2,
	       $smiley    x 2,
	       ) {
	my $length_chars = length($s);
	my $length_bytes;
	{ use bytes; $length_bytes = length($s) }
	my @regex_chars = $s =~ m/(.)/g;
	my $regex_chars = @regex_chars;
	my @split_chars = split //, $s;
	my $split_chars = @split_chars;
	ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
	   "2/2/2/6");
    }
}


{
    my $w = 0;
    local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
    my $x = eval q/"\\/ . "\x{100}" . q/"/;;
   
    ok($w == 0 && $x eq "\x{100}");
}

{
    use warnings;
    use strict;

    my $show = q(
                 sub show {
                   my $result;
                   $result .= '>' . join (',', map {ord} split //, $_) . '<'
                     foreach @_;
                   $result;
                 }
                 1;
                );
    eval $show or die $@; # We don't expect this sub definition to fail.
    my $progfile = 'utf' . $$;
    END {unlink_all $progfile}

    # If I'm right 60 is '>' in ASCII, ' ' in EBCDIC
    # 173 is not punctuation in either ASCII or EBCDIC
    my (@char);
    foreach (60, 173, 257, 65532) {
      my $char = chr $_;
      utf8::encode($char);
      # I don't want to use map {ord} and I've no need to hardcode the UTF
      # version
      my $charsubst = $char;
      $charsubst =~ s/(.)/ord ($1) . ','/ge;
      chop $charsubst;
      # Not testing this one against map {ord}
      my $char_as_ord
          = join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
      push @char, [$_, $char, $charsubst, $char_as_ord];
    }
    # Now we've done all the UTF8 munching hopefully we're safe
    my @tests = (
             ['check our detection program works',
              'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
             ['check literal 8 bit input',
              '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
             ['check no utf8; makes no change',
              'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
             # Now we do the real byte sequences that are valid UTF8
             (map {
               ["the utf8 sequence for chr $_->[0]",
                qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
               ["no utf8; for the utf8 sequence for chr $_->[0]",
                qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
               ["use utf8; for the utf8 sequence for chr $_->[0]",
                qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
              } @char),
             # Interpolation of hex characters needs to take place now, as we're
             # testing feeding malformed utf8 into perl. Bug now fixed was an
             # "out of memory" error. We really need the "" [rather than qq()
             # or q()] to get the best explosion.
             ["!Feed malformed utf8 into perl.", <<"BANG",
    use utf8; %a = ("\xE1\xA0"=>"sterling");
    print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
BANG
	      qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm
	     ],
            );
    foreach (@tests) {
        my ($why, $prog, $expect) = @$_;
        open P, ">$progfile" or die "Can't open '$progfile': $!";
        binmode(P, ":bytes") if $has_perlio;
	print P $show, $prog, '; print $b'
            or die "Print to 'progfile' failed: $!";
        close P or die "Can't close '$progfile': $!";
        if ($why =~ s/^!//) {
            print "# Possible delay...\n";
        } else {
            print "# $prog\n";
        }
        my $result = runperl ( stderr => 1, progfile => $progfile );
        like ($result, $expect, $why);
    }
    print
        "# Again! Again! [but this time as eval, and not the explosive one]\n";
    # and now we've safely done them all as separate files, check that the
    # evals do the same thing. Hopefully doing it later successfully decouples
    # the previous tests from anything messy that may go wrong with the evals.
    foreach (@tests) {
        my ($why, $prog, $expect) = @$_;
        next if $why =~ m/^!/; # Goes bang.
        my $result = eval $prog;
        if ($@) {
            print "# prog is $prog\n";
            print "# \$\@=", _qq($@), "\n";
        }
        like ($result, $expect, $why);
    }

    # See what the tokeniser does with hash keys.
    print "# What does the tokeniser do with utf8 hash keys?\n";
    @tests = (map {
        # This is the control - I don't expect it to fail
        ["assign utf8 for chr $_->[0] to a hash",
         qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["no utf8; assign utf8 for chr $_->[0] to a hash",
         qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["use utf8; assign utf8 for chr $_->[0] to a hash",
         qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
            my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
         qr/^>$_->[0]<$/],
        # Now check literal $h{"x"} constructions.
        ["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
         qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
         qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
         qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
            my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
         qr/^>$_->[0]<$/],
        # Now check "x" => constructions.
        ["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
         qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
         qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
         qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
            my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
         qr/^>$_->[0]<$/],
        # Check copies of hashes made from literal utf8 keys
        ["assign utf8 for chr $_->[0] to a hash, then copy it",
         qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
         qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i;
            my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
         qr/^>$_->[2]<$/],
        ["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
         qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
            my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
         qr/^>$_->[0]<$/],
     } @char);
    foreach (@tests) {
        my ($why, $prog, $expect) = @$_;
        # print "# $prog\n";
        my $result = eval $prog;
        like ($result, $expect, $why);
    }
}

#
# 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("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
    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
}

{
    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("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
    use utf8;
    eval qq{is(q \xc3\xbc test \xc3\xbc, qq\xc2\xb7 test \xc2\xb7,
	       "utf8 quote delimiters [perl #16823]");};
}

# Test the "internals".

{
    my $a = "A";
    my $b = chr(0x0FF);
    my $c = chr(0x100);

    ok( utf8::valid($a), "utf8::valid basic");
    ok( utf8::valid($b), "utf8::valid beyond");
    ok( utf8::valid($c), "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 unicode");

    is(utf8::upgrade($a), 1, "utf8::upgrade basic");
    if (ord('A') == 193) { # 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 unicode");

    is($a, "A",       "basic");
    is($b, "\xFF",    "beyond");
    is($c, "\x{100}", "unicode");

    ok( utf8::valid($a), "utf8::valid basic");
    ok( utf8::valid($b), "utf8::valid beyond");
    ok( utf8::valid($c), "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 unicode");

    is(utf8::downgrade($a), 1, "utf8::downgrade basic");
    is(utf8::downgrade($b), 1, "utf8::downgrade beyond");

    is($a, "A",       "basic");
    is($b, "\xFF",    "beyond");

    ok( utf8::valid($a), "utf8::valid basic");
    ok( utf8::valid($b), "utf8::valid beyond");

    ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
    ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");

    utf8::encode($a);
    utf8::encode($b);
    utf8::encode($c);

    is($a, "A",       "basic");
    if (ord('A') == 193) { # EBCDIC.
	is(length($b), 1, "beyond length");
    } else {
	is(length($b), 2, "beyond length");
    }
    is(length($c), 2, "unicode length");

    ok(utf8::valid($a), "utf8::valid basic");
    ok(utf8::valid($b), "utf8::valid beyond");
    ok(utf8::valid($c), "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 unicode");

    utf8::decode($a);
    utf8::decode($b);
    utf8::decode($c);

    is($a, "A",       "basic");
    is($b, "\xFF",    "beyond");
    is($c, "\x{100}", "unicode");

    ok(utf8::valid($a), "!utf8::valid basic");
    ok(utf8::valid($b), "!utf8::valid beyond");
    ok(utf8::valid($c), " utf8::valid unicode");

    ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
    if (ord('A') == 193) { # 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 unicode");
}

{
    eval {utf8::encode("£")};
    like($@, qr/^Modification of a read-only value attempted/,
	 "utf8::encode should refuse to touch read-only values");
}

{
    my $a = "456\xb6";
    utf8::upgrade($a);

    my $b = "123456\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");
}
Commit	Line	Data
f96ec2a2 GS	1	#!./perl
f96ec2a2 GS	2
47520729 JH	3	my $has_perlio;
47520729 JH	4
f96ec2a2 GS	5	BEGIN {
f96ec2a2 GS	6	chdir 't' if -d 't';
20822f61	7	@INC = '../lib';
8ae6c9f9	8	require './test.pl';
47520729 JH	9	unless ($has_perlio = find PerlIO::Layer 'perlio') {
	10	print <<EOF;
	11	# Since you don't have perlio you might get failures with UTF-8 locales.
	12	EOF
	13	}
f96ec2a2 GS	14	}
f96ec2a2 GS	15
e9f01ab9 JH	16	no utf8; # Ironic, no?
e9f01ab9 JH	17
4765795a JH	18	# NOTE!
	19	#
	20	# Think carefully before adding tests here. In general this should be
	21	# used only for about three categories of tests:
	22	#
	23	# (1) tests that absolutely require 'use utf8', and since that in general
	24	# shouldn't be needed as the utf8 is being obsoleted, this should
	25	# have rather few tests. If you want to test Unicode and regexes,
	26	# you probably want to go to op/regexp or op/pat; if you want to test
	27	# split, go to op/split; pack, op/pack; appending or joining,
	28	# op/append or op/join, and so forth
	29	#
	30	# (2) tests that have to do with Unicode tokenizing (though it's likely
	31	# that all the other Unicode tests sprinkled around the t/*/.t are
	32	# going to catch that)
	33	#
	34	# (3) complicated tests that simultaneously stress so many Unicode features
	35	# that deciding into which other test script the tests should go to
	36	# is hard -- maybe consider breaking up the complicated test
	37	#
	38	#
	39
77263263	40	plan tests => 150;
31067593	41
7bbb0251	42	{
da450f52 JH	43	# bug id 20001009.001
da450f52 JH	44
89491803 SC	45	my ($a, $b);
	46
	47	{ use bytes; $a = "\xc3\xa4" }
4765795a	48	{ use utf8; $b = "\xe4" }
89491803	49
4765795a	50	my $test = 68;
31067593	51
4765795a	52	ok($a ne $b);
da450f52	53
4765795a	54	{ use utf8; ok($a ne $b) }
da450f52 JH	55	}
da450f52 JH	56
60ff4832 JH	57
	58	{
	59	# bug id 20000730.004
	60
60ff4832 JH	61	my $smiley = "\x{263a}";
60ff4832 JH	62
4765795a JH	63	for my $s ("\x{263a}",
4765795a JH	64	$smiley,
60ff4832	65
4765795a JH	66	"" . $smiley,
4765795a JH	67	"" . "\x{263a}",
60ff4832	68
4765795a JH	69	$smiley . "",
4765795a JH	70	"\x{263a}" . "",
60ff4832 JH	71	) {
	72	my $length_chars = length($s);
	73	my $length_bytes;
	74	{ use bytes; $length_bytes = length($s) }
	75	my @regex_chars = $s =~ m/(.)/g;
	76	my $regex_chars = @regex_chars;
	77	my @split_chars = split //, $s;
	78	my $split_chars = @split_chars;
4765795a JH	79	ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
4765795a JH	80	"1/1/1/3");
60ff4832 JH	81	}
60ff4832 JH	82
4765795a JH	83	for my $s ("\x{263a}" . "\x{263a}",
4765795a JH	84	$smiley . $smiley,
60ff4832	85
4765795a JH	86	"\x{263a}\x{263a}",
4765795a JH	87	"$smiley$smiley",
60ff4832	88
4765795a JH	89	"\x{263a}" x 2,
4765795a JH	90	$smiley x 2,
60ff4832 JH	91	) {
	92	my $length_chars = length($s);
	93	my $length_bytes;
	94	{ use bytes; $length_bytes = length($s) }
	95	my @regex_chars = $s =~ m/(.)/g;
	96	my $regex_chars = @regex_chars;
	97	my @split_chars = split //, $s;
	98	my $split_chars = @split_chars;
4765795a JH	99	ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
4765795a JH	100	"2/2/2/6");
60ff4832 JH	101	}
60ff4832 JH	102	}
ffc61ed2	103
ffc61ed2 JH	104
ffc61ed2 JH	105	{
f9a63242 JH	106	my $w = 0;
	107	local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
	108	my $x = eval q/"\\/ . "\x{100}" . q/"/;;
	109
4765795a	110	ok($w == 0 && $x eq "\x{100}");
f9a63242 JH	111	}
f9a63242 JH	112
8ae6c9f9	113	{
435e7af6	114	use warnings;
4c26891c NC	115	use strict;
	116
	117	my $show = q(
	118	sub show {
	119	my $result;
	120	$result .= '>' . join (',', map {ord} split //, $_) . '<'
	121	foreach @_;
	122	$result;
	123	}
	124	1;
	125	);
	126	eval $show or die $@; # We don't expect this sub definition to fail.
8ae6c9f9	127	my $progfile = 'utf' . $$;
435e7af6 NC	128	END {unlink_all $progfile}
	129
	130	# If I'm right 60 is '>' in ASCII, ' ' in EBCDIC
	131	# 173 is not punctuation in either ASCII or EBCDIC
	132	my (@char);
	133	foreach (60, 173, 257, 65532) {
	134	my $char = chr $_;
	135	utf8::encode($char);
	136	# I don't want to use map {ord} and I've no need to hardcode the UTF
	137	# version
	138	my $charsubst = $char;
	139	$charsubst =~ s/(.)/ord ($1) . ','/ge;
	140	chop $charsubst;
4c26891c NC	141	# Not testing this one against map {ord}
	142	my $char_as_ord
	143	= join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
	144	push @char, [$_, $char, $charsubst, $char_as_ord];
435e7af6	145	}
4c26891c NC	146	# Now we've done all the UTF8 munching hopefully we're safe
4c26891c NC	147	my @tests = (
435e7af6	148	['check our detection program works',
4c26891c	149	'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
435e7af6	150	['check literal 8 bit input',
4c26891c	151	'$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
435e7af6	152	['check no utf8; makes no change',
4c26891c	153	'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
435e7af6 NC	154	# Now we do the real byte sequences that are valid UTF8
	155	(map {
	156	["the utf8 sequence for chr $_->[0]",
347a2837	157	qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
435e7af6	158	["no utf8; for the utf8 sequence for chr $_->[0]",
4c26891c	159	qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
435e7af6	160	["use utf8; for the utf8 sequence for chr $_->[0]",
4c26891c	161	qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
435e7af6 NC	162	} @char),
	163	# Interpolation of hex characters needs to take place now, as we're
	164	# testing feeding malformed utf8 into perl. Bug now fixed was an
	165	# "out of memory" error. We really need the "" [rather than qq()
	166	# or q()] to get the best explosion.
	167	["!Feed malformed utf8 into perl.", <<"BANG",
8ae6c9f9	168	use utf8; %a = ("\xE1\xA0"=>"sterling");
435e7af6	169	print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
8ae6c9f9	170	BANG
746b446a	171	qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm
435e7af6	172	],
4c26891c NC	173	);
4c26891c NC	174	foreach (@tests) {
435e7af6 NC	175	my ($why, $prog, $expect) = @$_;
435e7af6 NC	176	open P, ">$progfile" or die "Can't open '$progfile': $!";
47520729	177	binmode(P, ":bytes") if $has_perlio;
4c26891c NC	178	print P $show, $prog, '; print $b'
4c26891c NC	179	or die "Print to 'progfile' failed: $!";
435e7af6 NC	180	close P or die "Can't close '$progfile': $!";
	181	if ($why =~ s/^!//) {
	182	print "# Possible delay...\n";
	183	} else {
	184	print "# $prog\n";
	185	}
	186	my $result = runperl ( stderr => 1, progfile => $progfile );
	187	like ($result, $expect, $why);
	188	}
4c26891c NC	189	print
	190	"# Again! Again! [but this time as eval, and not the explosive one]\n";
	191	# and now we've safely done them all as separate files, check that the
a6d05634	192	# evals do the same thing. Hopefully doing it later successfully decouples
4c26891c NC	193	# the previous tests from anything messy that may go wrong with the evals.
	194	foreach (@tests) {
	195	my ($why, $prog, $expect) = @$_;
	196	next if $why =~ m/^!/; # Goes bang.
	197	my $result = eval $prog;
	198	if ($@) {
	199	print "# prog is $prog\n";
	200	print "# \$\@=", _qq($@), "\n";
	201	}
	202	like ($result, $expect, $why);
	203	}
	204
	205	# See what the tokeniser does with hash keys.
	206	print "# What does the tokeniser do with utf8 hash keys?\n";
	207	@tests = (map {
	208	# This is the control - I don't expect it to fail
	209	["assign utf8 for chr $_->[0] to a hash",
	210	qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
	211	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	212	qr/^>$_->[2]<$/],
	213	["no utf8; assign utf8 for chr $_->[0] to a hash",
	214	qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
	215	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	216	qr/^>$_->[2]<$/],
	217	["use utf8; assign utf8 for chr $_->[0] to a hash",
	218	qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
	219	my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
	220	qr/^>$_->[0]<$/],
	221	# Now check literal $h{"x"} constructions.
	222	["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
	223	qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
	224	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	225	qr/^>$_->[2]<$/],
	226	["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
	227	qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
	228	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	229	qr/^>$_->[2]<$/],
	230	["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
	231	qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
	232	my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
	233	qr/^>$_->[0]<$/],
	234	# Now check "x" => constructions.
	235	["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
	236	qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
	237	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	238	qr/^>$_->[2]<$/],
	239	["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
	240	qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
	241	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	242	qr/^>$_->[2]<$/],
	243	["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
	244	qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
	245	my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
	246	qr/^>$_->[0]<$/],
	247	# Check copies of hashes made from literal utf8 keys
	248	["assign utf8 for chr $_->[0] to a hash, then copy it",
	249	qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
	250	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	251	qr/^>$_->[2]<$/],
	252	["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
	253	qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i;
	254	my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
	255	qr/^>$_->[2]<$/],
	256	["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
257	qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
258	my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
259	qr/^>$_->[0]<$/],
260	} @char);
261	foreach (@tests) {
262	my ($why, $prog, $expect) = @$_;
263	# print "# $prog\n";
264	my $result = eval $prog;
265	like ($result, $expect, $why);
266	}
8ae6c9f9	267	}
107c2363 MP	268
	269	#
	270	# bug fixed by change #17928
	271	# separate perl used because we rely on 'strict' not yet loaded;
	272	# before the patch, the eval died with an error like:
	273	# "my" variable $strict::VERSION can't be in a package
	274	#
a901eef8 JH	275	SKIP: {
	276	skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
	277	ok('' eq runperl(prog => <<'CODE'), "change #17928");
	278	my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
107c2363 MP	279	{
	280	use utf8;
	281	eval $code;
	282	print $@ if $@;
	283	}
	284	CODE
a901eef8	285	}
a5b510f2 AE	286
	287	{
	288	use utf8;
	289	$a = <<'END';
	290	0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
	291	END
	292	my (@i, $s);
	293
	294	@i = ();
	295	push @i, $s = index($a, '6'); # 60
	296	push @i, $s = index($a, '.', $s); # next . after 60 is 62
	297	push @i, $s = index($a, '5'); # 50
	298	push @i, $s = index($a, '.', $s); # next . after 52 is 52
	299	push @i, $s = index($a, '7'); # 70
	300	push @i, $s = index($a, '.', $s); # next . after 70 is 72
	301	push @i, $s = index($a, '4'); # 40
	302	push @i, $s = index($a, '.', $s); # next . after 40 is 42
	303	is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
	304
	305	@i = ();
	306	push @i, $s = rindex($a, '6'); # 60
	307	push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
	308	push @i, $s = rindex($a, '5'); # 50
	309	push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
	310	push @i, $s = rindex($a, '7'); # 70
	311	push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
	312	push @i, $s = rindex($a, '4'); # 40
	313	push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
	314	is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
	315
	316	@i = ();
	317	push @i, $s = index($a, '6'); # 60
	318	push @i, index($a, '.', $s); # next . after 60 is 62
	319	push @i, rindex($a, '.', $s); # previous . before 60 is 58
	320	push @i, $s = rindex($a, '5'); # 60
	321	push @i, index($a, '.', $s); # next . after 50 is 52
	322	push @i, rindex($a, '.', $s); # previous . before 50 is 48
	323	push @i, $s = index($a, '7', $s); # 70
	324	push @i, index($a, '.', $s); # next . after 70 is 72
	325	push @i, rindex($a, '.', $s); # previous . before 70 is 68
	326	is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
	327	}
	328
a901eef8 JH	329	SKIP: {
a901eef8 JH	330	skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
220e2d4e IH	331	use utf8;
	332	eval qq{is(q \xc3\xbc test \xc3\xbc, qq\xc2\xb7 test \xc2\xb7,
	333	"utf8 quote delimiters [perl #16823]");};
	334	}
6e37fd2a JH	335
	336	# Test the "internals".
	337
	338	{
	339	my $a = "A";
	340	my $b = chr(0x0FF);
	341	my $c = chr(0x100);
	342
	343	ok( utf8::valid($a), "utf8::valid basic");
	344	ok( utf8::valid($b), "utf8::valid beyond");
	345	ok( utf8::valid($c), "utf8::valid unicode");
	346
	347	ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
	348	ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
	349	ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
	350
	351	is(utf8::upgrade($a), 1, "utf8::upgrade basic");
2f3efc97 JH	352	if (ord('A') == 193) { # EBCDIC.
	353	is(utf8::upgrade($b), 1, "utf8::upgrade beyond");
	354	} else {
	355	is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
	356	}
6e37fd2a JH	357	is(utf8::upgrade($c), 2, "utf8::upgrade unicode");
	358
	359	is($a, "A", "basic");
	360	is($b, "\xFF", "beyond");
	361	is($c, "\x{100}", "unicode");
	362
	363	ok( utf8::valid($a), "utf8::valid basic");
	364	ok( utf8::valid($b), "utf8::valid beyond");
	365	ok( utf8::valid($c), "utf8::valid unicode");
	366
	367	ok( utf8::is_utf8($a), "utf8::is_utf8 basic");
	368	ok( utf8::is_utf8($b), "utf8::is_utf8 beyond");
	369	ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
	370
	371	is(utf8::downgrade($a), 1, "utf8::downgrade basic");
	372	is(utf8::downgrade($b), 1, "utf8::downgrade beyond");
	373
	374	is($a, "A", "basic");
	375	is($b, "\xFF", "beyond");
	376
	377	ok( utf8::valid($a), "utf8::valid basic");
	378	ok( utf8::valid($b), "utf8::valid beyond");
	379
	380	ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
	381	ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
	382
	383	utf8::encode($a);
	384	utf8::encode($b);
	385	utf8::encode($c);
	386
	387	is($a, "A", "basic");
2f3efc97 JH	388	if (ord('A') == 193) { # EBCDIC.
	389	is(length($b), 1, "beyond length");
	390	} else {
	391	is(length($b), 2, "beyond length");
	392	}
6e37fd2a JH	393	is(length($c), 2, "unicode length");
	394
	395	ok(utf8::valid($a), "utf8::valid basic");
	396	ok(utf8::valid($b), "utf8::valid beyond");
	397	ok(utf8::valid($c), "utf8::valid unicode");
	398
	399	# encode() clears the UTF-8 flag (unlike upgrade()).
	400	ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
	401	ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
	402	ok(!utf8::is_utf8($c), "!utf8::is_utf8 unicode");
	403
	404	utf8::decode($a);
	405	utf8::decode($b);
	406	utf8::decode($c);
	407
	408	is($a, "A", "basic");
	409	is($b, "\xFF", "beyond");
	410	is($c, "\x{100}", "unicode");
	411
	412	ok(utf8::valid($a), "!utf8::valid basic");
	413	ok(utf8::valid($b), "!utf8::valid beyond");
	414	ok(utf8::valid($c), " utf8::valid unicode");
	415
	416	ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
2f3efc97 JH	417	if (ord('A') == 193) { # EBCDIC.
	418	ok( utf8::is_utf8(pack('U',0x0ff)), " utf8::is_utf8 beyond");
	419	} else {
	420	ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
	421	}
6e37fd2a JH	422	ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
6e37fd2a JH	423	}
5fec3b1d NC	424
	425	{
	426	eval {utf8::encode("£")};
	427	like($@, qr/^Modification of a read-only value attempted/,
	428	"utf8::encode should refuse to touch read-only values");
	429	}
06a45632 TS	430
06a45632 TS	431	{
ccc73c2d	432	my $a = "456\xb6";
06a45632 TS	433	utf8::upgrade($a);
06a45632 TS	434
ccc73c2d RGS	435	my $b = "123456\xb6";
ccc73c2d RGS	436	$b =~ s/^...//;
06a45632 TS	437	utf8::upgrade($b);
	438	is($b, $a, "utf8::upgrade OffsetOK");
	439	}
bd7017d3 NC	440
	441	{
	442	fresh_perl_like ('use utf8; utf8::moo()',
	443	qr/Undefined subroutine utf8::moo/, {stderr=>1},
	444	"Check Carp is loaded for AUTOLOADing errors")
	445	}
77263263 TS	446
	447	{
	448	# failure of is_utf8_char() without NATIVE_TO_UTF on EBCDIC (0260..027F)
	449	ok(utf8::valid(chr(0x250)), "0x250");
	450	ok(utf8::valid(chr(0x260)), "0x260");
	451	ok(utf8::valid(chr(0x270)), "0x270");
	452	ok(utf8::valid(chr(0x280)), "0x280");
	453	}