#!./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 => 94;
{
# 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 sucessfully 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);
+ }
}
https://perl5.git.perl.org / perl5.git / blobdiff