#!./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 => 16;
+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 $progfile}
- open P, ">$progfile" or die "Can't open '$progfile': $!";
- # 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.
- print P <<"BANG";
+ 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";
+ print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
BANG
- print "# Possible delay...\n";
- my $result = runperl ( verbose => 1, stderr => 1, progfile => $progfile );
- like ($result,
- 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': $!";
+ 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");
+ 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