[p5sagit/p5-mst-13.2.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') {
	    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	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	13	use strict;
92331800	14
12abf4f0	15	use overload '""' => 'stringify', fallback => 1;
92331800	16
	17	sub new {
	18	my $class = shift;
676f44e7	19	my $value = shift;
	20	my $state = shift\|\|0;
	21	return bless [$value, $state], $class;
92331800	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	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	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	52	$lc = lc $u;
6e08b83d	53	is (length $lc, 1);
bce8aa37	54	is ($lc, "\351", "E acute -> e acute");
6e08b83d	55	$lc = lc $u;
6e08b83d	56	is (length $lc, 1);
bce8aa37	57	is ($lc, "\311", "E acute -> e acute");
6e08b83d	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	63	$uc = uc $u;
6e08b83d	64	is (length $uc, 1);
bce8aa37	65	is ($uc, "\311", "e acute -> E acute");
6e08b83d	66	$uc = uc $u;
6e08b83d	67	is (length $uc, 1);
bce8aa37	68	is ($uc, "\351", "e acute -> E acute");
6e08b83d	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	74	$lc = lcfirst $u;
6e08b83d	75	is (length $lc, 1);
bce8aa37	76	is ($lc, "\351", "E acute -> e acute");
6e08b83d	77	$lc = lcfirst $u;
6e08b83d	78	is (length $lc, 1);
bce8aa37	79	is ($lc, "\311", "E acute -> e acute");
6e08b83d	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	85	$uc = ucfirst $u;
6e08b83d	86	is (length $uc, 1);
bce8aa37	87	is ($uc, "\311", "e acute -> E acute");
6e08b83d	88	$uc = ucfirst $u;
6e08b83d	89	is (length $uc, 1);
bce8aa37	90	is ($uc, "\351", "e acute -> E acute");
6e08b83d	91
ec9af7d4	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;
c1289dd7	104	} elsif ($^O eq 'dec_osf' \|\| $^O eq 'VMS') {
bce8aa37	105	skip "$^O has broken en_GB.ISO8859-1 locale", 24;
ec9af7d4	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	112	$lc = lc $u;
ec9af7d4	113	is (length $lc, 1);
bce8aa37	114	is ($lc, "\351", "E acute -> e acute");
6e08b83d	115	$lc = lc $u;
6e08b83d	116	is (length $lc, 1);
bce8aa37	117	is ($lc, "\351", "E acute -> e acute");
67306194	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	123	$uc = uc $u;
67306194	124	is (length $uc, 1);
bce8aa37	125	is ($uc, "\311", "e acute -> E acute");
6e08b83d	126	$uc = uc $u;
6e08b83d	127	is (length $uc, 1);
bce8aa37	128	is ($uc, "\311", "e acute -> E acute");
d54190f6	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	134	$lc = lcfirst $u;
d54190f6	135	is (length $lc, 1);
bce8aa37	136	is ($lc, "\351", "E acute -> e acute");
6e08b83d	137	$lc = lcfirst $u;
6e08b83d	138	is (length $lc, 1);
bce8aa37	139	is ($lc, "\351", "E acute -> e acute");
d54190f6	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	145	$uc = ucfirst $u;
d54190f6	146	is (length $uc, 1);
bce8aa37	147	is ($uc, "\311", "e acute -> E acute");
6e08b83d	148	$uc = ucfirst $u;
6e08b83d	149	is (length $uc, 1);
bce8aa37	150	is ($uc, "\311", "e acute -> E acute");
ec9af7d4	151	}
ec9af7d4	152	}
676f44e7	153
	154	my $tmpfile = 'overload.tmp';
	155
c9cb0f41	156	foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off',
c9cb0f41	157	'syswrite len off') {
676f44e7	158	foreach my $layer ('', ':utf8') {
676f44e7	159	open my $fh, "+>$layer", $tmpfile or die $!;
c9cb0f41	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') {
	165	print $fh $u;
	166	print $fh $u;
	167	print $fh $u;
	168	print $fh $l;
	169	print $fh $l;
	170	print $fh $l;
	171	} elsif ($operator eq 'syswrite') {
	172	syswrite $fh, $u;
	173	syswrite $fh, $u;
	174	syswrite $fh, $u;
	175	syswrite $fh, $l;
	176	syswrite $fh, $l;
	177	syswrite $fh, $l;
	178	} elsif ($operator eq 'syswrite len') {
	179	syswrite $fh, $u, 2;
	180	syswrite $fh, $u, 2;
	181	syswrite $fh, $u, 2;
	182	syswrite $fh, $l, 2;
	183	syswrite $fh, $l, 2;
	184	syswrite $fh, $l, 2;
	185	} elsif ($operator eq 'syswrite off'
	186	\|\| $operator eq 'syswrite len off') {
	187	syswrite $fh, $u, 2, 1;
	188	syswrite $fh, $u, 2, 1;
	189	syswrite $fh, $u, 2, 1;
	190	syswrite $fh, $l, 2, 1;
	191	syswrite $fh, $l, 2, 1;
	192	syswrite $fh, $l, 2, 1;
	193	} else {
	194	die $operator;
	195	}
676f44e7	196
	197	seek $fh, 0, 0 or die $!;
	198	my $line;
	199	chomp ($line = <$fh>);
	200	is ($line, "\311", "$operator $layer");
	201	chomp ($line = <$fh>);
	202	is ($line, "\311", "$operator $layer");
	203	chomp ($line = <$fh>);
	204	is ($line, "\311", "$operator $layer");
	205	chomp ($line = <$fh>);
	206	is ($line, "\351", "$operator $layer");
	207	chomp ($line = <$fh>);
	208	is ($line, "\351", "$operator $layer");
	209	chomp ($line = <$fh>);
	210	is ($line, "\351", "$operator $layer");
	211
	212	close $fh or die $!;
	213	unlink $tmpfile or die $!;
	214	}
	215	}
	216
73ee8be2	217	my $little = "\243\243";
	218	my $big = " \243 $little ! $little ! $little \243 ";
	219	my $right = rindex $big, $little;
	220	my $right1 = rindex $big, $little, 11;
	221	my $left = index $big, $little;
	222	my $left1 = index $big, $little, 4;
	223
	224	cmp_ok ($right, ">", $right1, "Sanity check our rindex tests");
	225	cmp_ok ($left, "<", $left1, "Sanity check our index tests");
	226
	227	foreach my $b ($big, UTF8Toggle->new($big)) {
	228	foreach my $l ($little, UTF8Toggle->new($little),
	229	UTF8Toggle->new($little, 1)) {
	230	is (rindex ($b, $l), $right, "rindex");
	231	is (rindex ($b, $l), $right, "rindex");
	232	is (rindex ($b, $l), $right, "rindex");
	233
	234	is (rindex ($b, $l, 11), $right1, "rindex 11");
	235	is (rindex ($b, $l, 11), $right1, "rindex 11");
	236	is (rindex ($b, $l, 11), $right1, "rindex 11");
	237
	238	is (index ($b, $l), $left, "index");
	239	is (index ($b, $l), $left, "index");
	240	is (index ($b, $l), $left, "index");
	241
	242	is (index ($b, $l, 4), $left1, "index 4");
	243	is (index ($b, $l, 4), $left1, "index 4");
	244	is (index ($b, $l, 4), $left1, "index 4");
	245	}
	246	}
676f44e7	247
12abf4f0	248	my $bits = "\311";
	249	foreach my $pieces ($bits, UTF8Toggle->new($bits)) {
	250	like ($bits ^ $pieces, qr/\A\0+\z/, "something xor itself is zeros");
	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
	254	like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
	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	}
	258
ce399ba6	259	foreach my $value ("\243", UTF8Toggle->new("\243")) {
	260	is (pack ("A/A", $value), pack ("A/A", "\243"),
	261	"pack copes with overloading");
	262	is (pack ("A/A", $value), pack ("A/A", "\243"));
	263	is (pack ("A/A", $value), pack ("A/A", "\243"));
	264	}
	265
676f44e7	266	END {
	267	1 while -f $tmpfile and unlink $tmpfile \|\| die "unlink '$tmpfile': $!";
	268	}