#!./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
#
#
-plan tests => 31;
+plan tests => 143;
{
# bug id 20001009.001
{
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}
my $charsubst = $char;
$charsubst =~ s/(.)/ord ($1) . ','/ge;
chop $charsubst;
- push @char, [$_, $char, $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];
}
- foreach (
+ # Now we've done all the UTF8 munching hopefully we're safe
+ my @tests = (
['check our detection program works',
- '@a = ("'.chr(60).'\x2A", ""); display @a', qr/^>60,42<><$/],
+ 'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
['check literal 8 bit input',
- '$a = "' . chr (173) . '"; display $a', qr/^>173<$/],
+ '$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
['check no utf8; makes no change',
- 'no utf8; $a = "' . chr (173) . '"; display $a', qr/^>173<$/],
+ '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]"; display \$a), qr/^>$_->[2]<$/],
+ qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
["no utf8; for the utf8 sequence for chr $_->[0]",
- qq(no utf8; \$a = "$_->[1]"; display \$a), qr/^>$_->[2]<$/],
+ qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
["use utf8; for the utf8 sequence for chr $_->[0]",
- qq(use utf8; \$a = "$_->[1]"; display \$a), qr/^>$_->[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
use utf8; %a = ("\xE1\xA0"=>"sterling");
print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
BANG
- qr/^Malformed UTF-8 character \(2 bytes, need 3\).*start\d+,end$/s
+ 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': $!";
- print P q(
- sub display {
- print '>' . join (',', map {ord} split //, $_) . '<'
- foreach @_;
- }
- );
- print P $prog;
+ 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";
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");
+ 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");
+ 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");
+ ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
+ ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
}
https://perl5.git.perl.org / perl5.git / blobdiff