[perl5.git] / t / uni / overload.t

#!perl -w

BEGIN {
    if ($ENV{'PERL_CORE'}){
        chdir 't';
        @INC = '../lib';
    }
}

use Test::More tests => 208;

package UTF8Toggle;
use strict;

use overload '""' => 'stringify', fallback => 1;

sub new {
    my $class = shift;
    my $value = shift;
    my $state = shift||0;
    return bless [$value, $state], $class;
}

sub stringify {
    my $self = shift;
    $self->[1] = ! $self->[1];
    if ($self->[1]) {
	utf8::downgrade($self->[0]);
    } else {
	utf8::upgrade($self->[0]);
    }
    $self->[0];
}

package main;

# Bug 34297
foreach my $t ("ASCII", "B\366se") {
    my $length = length $t;

    my $u = UTF8Toggle->new($t);
    is (length $u, $length, "length of '$t'");
    is (length $u, $length, "length of '$t'");
    is (length $u, $length, "length of '$t'");
    is (length $u, $length, "length of '$t'");
}

my $u = UTF8Toggle->new("\311");
my $lc = lc $u;
is (length $lc, 1);
is ($lc, "\311", "E acute -> e acute");
$lc = lc $u;
is (length $lc, 1);
is ($lc, "\351", "E acute -> e acute");
$lc = lc $u;
is (length $lc, 1);
is ($lc, "\311", "E acute -> e acute");

$u = UTF8Toggle->new("\351");
my $uc = uc $u;
is (length $uc, 1);
is ($uc, "\351", "e acute -> E acute");
$uc = uc $u;
is (length $uc, 1);
is ($uc, "\311", "e acute -> E acute");
$uc = uc $u;
is (length $uc, 1);
is ($uc, "\351", "e acute -> E acute");

$u = UTF8Toggle->new("\311");
$lc = lcfirst $u;
is (length $lc, 1);
is ($lc, "\311", "E acute -> e acute");
$lc = lcfirst $u;
is (length $lc, 1);
is ($lc, "\351", "E acute -> e acute");
$lc = lcfirst $u;
is (length $lc, 1);
is ($lc, "\311", "E acute -> e acute");

$u = UTF8Toggle->new("\351");
$uc = ucfirst $u;
is (length $uc, 1);
is ($uc, "\351", "e acute -> E acute");
$uc = ucfirst $u;
is (length $uc, 1);
is ($uc, "\311", "e acute -> E acute");
$uc = ucfirst $u;
is (length $uc, 1);
is ($uc, "\351", "e acute -> E acute");

my $have_setlocale = 0;
eval {
    require POSIX;
    import POSIX ':locale_h';
    $have_setlocale++;
};

SKIP: {
    if (!$have_setlocale) {
	skip "No setlocale", 24;
    } elsif (!setlocale(&POSIX::LC_ALL, "en_GB.ISO8859-1")) {
	skip "Could not setlocale to en_GB.ISO8859-1", 24;
    } elsif ($^O eq 'dec_osf' || $^O eq 'VMS') {
	skip "$^O has broken en_GB.ISO8859-1 locale", 24;
    } else {
	use locale;
	my $u = UTF8Toggle->new("\311");
	my $lc = lc $u;
	is (length $lc, 1);
	is ($lc, "\351", "E acute -> e acute");
	$lc = lc $u;
	is (length $lc, 1);
	is ($lc, "\351", "E acute -> e acute");
	$lc = lc $u;
	is (length $lc, 1);
	is ($lc, "\351", "E acute -> e acute");

	$u = UTF8Toggle->new("\351");
	my $uc = uc $u;
	is (length $uc, 1);
	is ($uc, "\311", "e acute -> E acute");
	$uc = uc $u;
	is (length $uc, 1);
	is ($uc, "\311", "e acute -> E acute");
	$uc = uc $u;
	is (length $uc, 1);
	is ($uc, "\311", "e acute -> E acute");

	$u = UTF8Toggle->new("\311");
	$lc = lcfirst $u;
	is (length $lc, 1);
	is ($lc, "\351", "E acute -> e acute");
	$lc = lcfirst $u;
	is (length $lc, 1);
	is ($lc, "\351", "E acute -> e acute");
	$lc = lcfirst $u;
	is (length $lc, 1);
	is ($lc, "\351", "E acute -> e acute");

	$u = UTF8Toggle->new("\351");
	$uc = ucfirst $u;
	is (length $uc, 1);
	is ($uc, "\311", "e acute -> E acute");
	$uc = ucfirst $u;
	is (length $uc, 1);
	is ($uc, "\311", "e acute -> E acute");
	$uc = ucfirst $u;
	is (length $uc, 1);
	is ($uc, "\311", "e acute -> E acute");
    }
}

my $tmpfile = 'overload.tmp';

foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off',
		      'syswrite len off') {
    foreach my $layer ('', ':utf8') {
	open my $fh, "+>$layer", $tmpfile or die $!;
	my $pad = $operator =~ /\boff\b/ ? "\243" : "";
	my $trail = $operator =~ /\blen\b/ ? "!" : "";
	my $u = UTF8Toggle->new("$pad\311\n$trail");
	my $l = UTF8Toggle->new("$pad\351\n$trail", 1);
	if ($operator eq 'print') {
	    no warnings 'utf8';
	    print $fh $u;
	    print $fh $u;
	    print $fh $u;
	    print $fh $l;
	    print $fh $l;
	    print $fh $l;
	} elsif ($operator eq 'syswrite') {
	    syswrite $fh, $u;
	    syswrite $fh, $u;
	    syswrite $fh, $u;
	    syswrite $fh, $l;
	    syswrite $fh, $l;
	    syswrite $fh, $l;
	} elsif ($operator eq 'syswrite len') {
	    syswrite $fh, $u, 2;
	    syswrite $fh, $u, 2;
	    syswrite $fh, $u, 2;
	    syswrite $fh, $l, 2;
	    syswrite $fh, $l, 2;
	    syswrite $fh, $l, 2;
	} elsif ($operator eq 'syswrite off'
		 || $operator eq 'syswrite len off') {
	    syswrite $fh, $u, 2, 1;
	    syswrite $fh, $u, 2, 1;
	    syswrite $fh, $u, 2, 1;
	    syswrite $fh, $l, 2, 1;
	    syswrite $fh, $l, 2, 1;
	    syswrite $fh, $l, 2, 1;
	} else {
	    die $operator;
	}

	seek $fh, 0, 0 or die $!;
	my $line;
	chomp ($line = <$fh>);
	is ($line, "\311", "$operator $layer");
	chomp ($line = <$fh>);
	is ($line, "\311", "$operator $layer");
	chomp ($line = <$fh>);
	is ($line, "\311", "$operator $layer");
	chomp ($line = <$fh>);
	is ($line, "\351", "$operator $layer");
	chomp ($line = <$fh>);
	is ($line, "\351", "$operator $layer");
	chomp ($line = <$fh>);
	is ($line, "\351", "$operator $layer");

	close $fh or die $!;
	unlink $tmpfile or die $!;
    }
}

my $little = "\243\243";
my $big = " \243 $little ! $little ! $little \243 ";
my $right = rindex $big, $little;
my $right1 = rindex $big, $little, 11;
my $left = index $big, $little;
my $left1 = index $big, $little, 4;

cmp_ok ($right, ">", $right1, "Sanity check our rindex tests");
cmp_ok ($left, "<", $left1, "Sanity check our index tests");

foreach my $b ($big, UTF8Toggle->new($big)) {
    foreach my $l ($little, UTF8Toggle->new($little),
		   UTF8Toggle->new($little, 1)) {
	is (rindex ($b, $l), $right, "rindex");
	is (rindex ($b, $l), $right, "rindex");
	is (rindex ($b, $l), $right, "rindex");

	is (rindex ($b, $l, 11), $right1, "rindex 11");
	is (rindex ($b, $l, 11), $right1, "rindex 11");
	is (rindex ($b, $l, 11), $right1, "rindex 11");

	is (index ($b, $l), $left, "index");
	is (index ($b, $l), $left, "index");
	is (index ($b, $l), $left, "index");

	is (index ($b, $l, 4), $left1, "index 4");
	is (index ($b, $l, 4), $left1, "index 4");
	is (index ($b, $l, 4), $left1, "index 4");
    }
}

my $bits = "\311";
foreach my $pieces ($bits, UTF8Toggle->new($bits)) {
    like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
    like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
    like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");

    like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
    like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
    like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
}

foreach my $value ("\243", UTF8Toggle->new("\243")) {
    is (pack ("A/A", $value), pack ("A/A", "\243"),
	"pack copes with overloading");
    is (pack ("A/A", $value), pack ("A/A", "\243"));
    is (pack ("A/A", $value), pack ("A/A", "\243"));
}

END {
    1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!";
}
Commit	Line	Data
92331800 NC	1	#!perl -w
	2
	3	BEGIN {
	4	if ($ENV{'PERL_CORE'}){
	5	chdir 't';
	6	@INC = '../lib';
	7	}
	8	}
	9
ce399ba6	10	use Test::More tests => 208;
92331800	11
ec9af7d4	12	package UTF8Toggle;
92331800 NC	13	use strict;
92331800 NC	14
12abf4f0	15	use overload '""' => 'stringify', fallback => 1;
92331800 NC	16
	17	sub new {
	18	my $class = shift;
676f44e7 NC	19	my $value = shift;
	20	my $state = shift\|\|0;
	21	return bless [$value, $state], $class;
92331800 NC	22	}
	23
	24	sub stringify {
	25	my $self = shift;
	26	$self->[1] = ! $self->[1];
	27	if ($self->[1]) {
	28	utf8::downgrade($self->[0]);
	29	} else {
	30	utf8::upgrade($self->[0]);
	31	}
	32	$self->[0];
	33	}
	34
	35	package main;
	36
	37	# Bug 34297
	38	foreach my $t ("ASCII", "B\366se") {
	39	my $length = length $t;
	40
ec9af7d4	41	my $u = UTF8Toggle->new($t);
92331800 NC	42	is (length $u, $length, "length of '$t'");
	43	is (length $u, $length, "length of '$t'");
	44	is (length $u, $length, "length of '$t'");
	45	is (length $u, $length, "length of '$t'");
	46	}
ec9af7d4	47
6e08b83d NC	48	my $u = UTF8Toggle->new("\311");
	49	my $lc = lc $u;
	50	is (length $lc, 1);
bce8aa37	51	is ($lc, "\311", "E acute -> e acute");
6e08b83d NC	52	$lc = lc $u;
6e08b83d NC	53	is (length $lc, 1);
bce8aa37	54	is ($lc, "\351", "E acute -> e acute");
6e08b83d NC	55	$lc = lc $u;
6e08b83d NC	56	is (length $lc, 1);
bce8aa37	57	is ($lc, "\311", "E acute -> e acute");
6e08b83d NC	58
	59	$u = UTF8Toggle->new("\351");
	60	my $uc = uc $u;
	61	is (length $uc, 1);
bce8aa37	62	is ($uc, "\351", "e acute -> E acute");
6e08b83d NC	63	$uc = uc $u;
6e08b83d NC	64	is (length $uc, 1);
bce8aa37	65	is ($uc, "\311", "e acute -> E acute");
6e08b83d NC	66	$uc = uc $u;
6e08b83d NC	67	is (length $uc, 1);
bce8aa37	68	is ($uc, "\351", "e acute -> E acute");
6e08b83d NC	69
	70	$u = UTF8Toggle->new("\311");
	71	$lc = lcfirst $u;
	72	is (length $lc, 1);
bce8aa37	73	is ($lc, "\311", "E acute -> e acute");
6e08b83d NC	74	$lc = lcfirst $u;
6e08b83d NC	75	is (length $lc, 1);
bce8aa37	76	is ($lc, "\351", "E acute -> e acute");
6e08b83d NC	77	$lc = lcfirst $u;
6e08b83d NC	78	is (length $lc, 1);
bce8aa37	79	is ($lc, "\311", "E acute -> e acute");
6e08b83d NC	80
	81	$u = UTF8Toggle->new("\351");
	82	$uc = ucfirst $u;
	83	is (length $uc, 1);
bce8aa37	84	is ($uc, "\351", "e acute -> E acute");
6e08b83d NC	85	$uc = ucfirst $u;
6e08b83d NC	86	is (length $uc, 1);
bce8aa37	87	is ($uc, "\311", "e acute -> E acute");
6e08b83d NC	88	$uc = ucfirst $u;
6e08b83d NC	89	is (length $uc, 1);
bce8aa37	90	is ($uc, "\351", "e acute -> E acute");
6e08b83d	91
ec9af7d4 NC	92	my $have_setlocale = 0;
	93	eval {
	94	require POSIX;
	95	import POSIX ':locale_h';
	96	$have_setlocale++;
	97	};
	98
	99	SKIP: {
	100	if (!$have_setlocale) {
6e08b83d	101	skip "No setlocale", 24;
ec9af7d4	102	} elsif (!setlocale(&POSIX::LC_ALL, "en_GB.ISO8859-1")) {
6e08b83d	103	skip "Could not setlocale to en_GB.ISO8859-1", 24;
23ae3dfb	104	} elsif ($^O eq 'dec_osf' \|\| $^O eq 'VMS') {
bce8aa37	105	skip "$^O has broken en_GB.ISO8859-1 locale", 24;
ec9af7d4 NC	106	} else {
	107	use locale;
	108	my $u = UTF8Toggle->new("\311");
	109	my $lc = lc $u;
	110	is (length $lc, 1);
bce8aa37	111	is ($lc, "\351", "E acute -> e acute");
ec9af7d4 NC	112	$lc = lc $u;
ec9af7d4 NC	113	is (length $lc, 1);
bce8aa37	114	is ($lc, "\351", "E acute -> e acute");
6e08b83d NC	115	$lc = lc $u;
6e08b83d NC	116	is (length $lc, 1);
bce8aa37	117	is ($lc, "\351", "E acute -> e acute");
67306194 NC	118
	119	$u = UTF8Toggle->new("\351");
	120	my $uc = uc $u;
	121	is (length $uc, 1);
bce8aa37	122	is ($uc, "\311", "e acute -> E acute");
67306194 NC	123	$uc = uc $u;
67306194 NC	124	is (length $uc, 1);
bce8aa37	125	is ($uc, "\311", "e acute -> E acute");
6e08b83d NC	126	$uc = uc $u;
6e08b83d NC	127	is (length $uc, 1);
bce8aa37	128	is ($uc, "\311", "e acute -> E acute");
d54190f6 NC	129
	130	$u = UTF8Toggle->new("\311");
	131	$lc = lcfirst $u;
	132	is (length $lc, 1);
bce8aa37	133	is ($lc, "\351", "E acute -> e acute");
d54190f6 NC	134	$lc = lcfirst $u;
d54190f6 NC	135	is (length $lc, 1);
bce8aa37	136	is ($lc, "\351", "E acute -> e acute");
6e08b83d NC	137	$lc = lcfirst $u;
6e08b83d NC	138	is (length $lc, 1);
bce8aa37	139	is ($lc, "\351", "E acute -> e acute");
d54190f6 NC	140
	141	$u = UTF8Toggle->new("\351");
	142	$uc = ucfirst $u;
	143	is (length $uc, 1);
bce8aa37	144	is ($uc, "\311", "e acute -> E acute");
d54190f6 NC	145	$uc = ucfirst $u;
d54190f6 NC	146	is (length $uc, 1);
bce8aa37	147	is ($uc, "\311", "e acute -> E acute");
6e08b83d NC	148	$uc = ucfirst $u;
6e08b83d NC	149	is (length $uc, 1);
bce8aa37	150	is ($uc, "\311", "e acute -> E acute");
ec9af7d4 NC	151	}
ec9af7d4 NC	152	}
676f44e7 NC	153
	154	my $tmpfile = 'overload.tmp';
	155
c9cb0f41 NC	156	foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off',
c9cb0f41 NC	157	'syswrite len off') {
676f44e7 NC	158	foreach my $layer ('', ':utf8') {
676f44e7 NC	159	open my $fh, "+>$layer", $tmpfile or die $!;
c9cb0f41 NC	160	my $pad = $operator =~ /\boff\b/ ? "\243" : "";
	161	my $trail = $operator =~ /\blen\b/ ? "!" : "";
	162	my $u = UTF8Toggle->new("$pad\311\n$trail");
	163	my $l = UTF8Toggle->new("$pad\351\n$trail", 1);
	164	if ($operator eq 'print') {
b3c6e229	165	no warnings 'utf8';
c9cb0f41 NC	166	print $fh $u;
	167	print $fh $u;
	168	print $fh $u;
	169	print $fh $l;
	170	print $fh $l;
	171	print $fh $l;
	172	} elsif ($operator eq 'syswrite') {
	173	syswrite $fh, $u;
	174	syswrite $fh, $u;
	175	syswrite $fh, $u;
	176	syswrite $fh, $l;
	177	syswrite $fh, $l;
	178	syswrite $fh, $l;
	179	} elsif ($operator eq 'syswrite len') {
	180	syswrite $fh, $u, 2;
	181	syswrite $fh, $u, 2;
	182	syswrite $fh, $u, 2;
	183	syswrite $fh, $l, 2;
	184	syswrite $fh, $l, 2;
	185	syswrite $fh, $l, 2;
	186	} elsif ($operator eq 'syswrite off'
	187	\|\| $operator eq 'syswrite len off') {
	188	syswrite $fh, $u, 2, 1;
	189	syswrite $fh, $u, 2, 1;
	190	syswrite $fh, $u, 2, 1;
	191	syswrite $fh, $l, 2, 1;
	192	syswrite $fh, $l, 2, 1;
	193	syswrite $fh, $l, 2, 1;
	194	} else {
	195	die $operator;
	196	}
676f44e7 NC	197
	198	seek $fh, 0, 0 or die $!;
	199	my $line;
	200	chomp ($line = <$fh>);
	201	is ($line, "\311", "$operator $layer");
	202	chomp ($line = <$fh>);
	203	is ($line, "\311", "$operator $layer");
	204	chomp ($line = <$fh>);
	205	is ($line, "\311", "$operator $layer");
	206	chomp ($line = <$fh>);
	207	is ($line, "\351", "$operator $layer");
	208	chomp ($line = <$fh>);
	209	is ($line, "\351", "$operator $layer");
	210	chomp ($line = <$fh>);
	211	is ($line, "\351", "$operator $layer");
	212
	213	close $fh or die $!;
	214	unlink $tmpfile or die $!;
	215	}
	216	}
	217
73ee8be2 NC	218	my $little = "\243\243";
	219	my $big = " \243 $little ! $little ! $little \243 ";
	220	my $right = rindex $big, $little;
	221	my $right1 = rindex $big, $little, 11;
	222	my $left = index $big, $little;
	223	my $left1 = index $big, $little, 4;
	224
	225	cmp_ok ($right, ">", $right1, "Sanity check our rindex tests");
	226	cmp_ok ($left, "<", $left1, "Sanity check our index tests");
	227
	228	foreach my $b ($big, UTF8Toggle->new($big)) {
	229	foreach my $l ($little, UTF8Toggle->new($little),
	230	UTF8Toggle->new($little, 1)) {
	231	is (rindex ($b, $l), $right, "rindex");
	232	is (rindex ($b, $l), $right, "rindex");
	233	is (rindex ($b, $l), $right, "rindex");
	234
	235	is (rindex ($b, $l, 11), $right1, "rindex 11");
	236	is (rindex ($b, $l, 11), $right1, "rindex 11");
	237	is (rindex ($b, $l, 11), $right1, "rindex 11");
	238
	239	is (index ($b, $l), $left, "index");
	240	is (index ($b, $l), $left, "index");
	241	is (index ($b, $l), $left, "index");
	242
	243	is (index ($b, $l, 4), $left1, "index 4");
	244	is (index ($b, $l, 4), $left1, "index 4");
	245	is (index ($b, $l, 4), $left1, "index 4");
	246	}
	247	}
676f44e7	248
12abf4f0 NC	249	my $bits = "\311";
	250	foreach my $pieces ($bits, UTF8Toggle->new($bits)) {
	251	like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
	252	like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
	253	like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
	254
	255	like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
	256	like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
	257	like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
	258	}
	259
ce399ba6 NC	260	foreach my $value ("\243", UTF8Toggle->new("\243")) {
	261	is (pack ("A/A", $value), pack ("A/A", "\243"),
	262	"pack copes with overloading");
	263	is (pack ("A/A", $value), pack ("A/A", "\243"));
	264	is (pack ("A/A", $value), pack ("A/A", "\243"));
	265	}
	266
676f44e7 NC	267	END {
	268	1 while -f $tmpfile and unlink $tmpfile \|\| die "unlink '$tmpfile': $!";
	269	}