X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Futf8.t;h=223bb1d8254edf13615f27a79c326c8e829d8b1b;hb=a901eef84aae580e80c0351bb32ee5bca0f349f7;hp=1cc0cf177ab2e4c89899598e4dc5c55e0f47423f;hpb=435e7af634196f39217ad53bdbf04b5bbf203ce1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/utf8.t b/lib/utf8.t index 1cc0cf1..223bb1d 100644 --- a/lib/utf8.t +++ b/lib/utf8.t @@ -1,11 +1,20 @@ #!./perl +my $has_perlio; + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; + unless ($has_perlio = find PerlIO::Layer 'perlio') { + print < 31; +plan tests => 99; { # bug id 20001009.001 @@ -103,6 +112,18 @@ plan tests => 31; { 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} @@ -117,23 +138,27 @@ plan tests => 31; 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 @@ -143,18 +168,15 @@ plan tests => 31; 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"; @@ -164,4 +186,149 @@ BANG 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]");}; }