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

#!perl -w

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

use Test::More tests => 190;

package UTF8Toggle;
use strict;

use overload '""' => 'stringify';

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 accute -> e accute");
$lc = lc $u;
is (length $lc, 1);
is ($lc, "\351", "E accute -> e accute");
$lc = lc $u;
is (length $lc, 1);
is ($lc, "\311", "E accute -> e accute");

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

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

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

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;
    } else {
	use locale;
	my $u = UTF8Toggle->new("\311");
	my $lc = lc $u;
	is (length $lc, 1);
	is ($lc, "\351", "E accute -> e accute");
	$lc = lc $u;
	is (length $lc, 1);
	is ($lc, "\351", "E accute -> e accute");
	$lc = lc $u;
	is (length $lc, 1);
	is ($lc, "\351", "E accute -> e accute");

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

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

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

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");
    }
}

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
73ee8be2	10	use Test::More tests => 190;
92331800	11
ec9af7d4	12	package UTF8Toggle;
92331800 NC	13	use strict;
	14
	15	use overload '""' => 'stringify';
	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);
	51	is ($lc, "\311", "E accute -> e accute");
	52	$lc = lc $u;
	53	is (length $lc, 1);
	54	is ($lc, "\351", "E accute -> e accute");
	55	$lc = lc $u;
	56	is (length $lc, 1);
	57	is ($lc, "\311", "E accute -> e accute");
	58
	59	$u = UTF8Toggle->new("\351");
	60	my $uc = uc $u;
	61	is (length $uc, 1);
	62	is ($uc, "\351", "e accute -> E accute");
	63	$uc = uc $u;
	64	is (length $uc, 1);
	65	is ($uc, "\311", "e accute -> E accute");
	66	$uc = uc $u;
	67	is (length $uc, 1);
	68	is ($uc, "\351", "e accute -> E accute");
	69
	70	$u = UTF8Toggle->new("\311");
	71	$lc = lcfirst $u;
	72	is (length $lc, 1);
	73	is ($lc, "\311", "E accute -> e accute");
	74	$lc = lcfirst $u;
	75	is (length $lc, 1);
	76	is ($lc, "\351", "E accute -> e accute");
	77	$lc = lcfirst $u;
	78	is (length $lc, 1);
	79	is ($lc, "\311", "E accute -> e accute");
	80
	81	$u = UTF8Toggle->new("\351");
	82	$uc = ucfirst $u;
	83	is (length $uc, 1);
	84	is ($uc, "\351", "e accute -> E accute");
	85	$uc = ucfirst $u;
	86	is (length $uc, 1);
	87	is ($uc, "\311", "e accute -> E accute");
	88	$uc = ucfirst $u;
	89	is (length $uc, 1);
	90	is ($uc, "\351", "e accute -> E accute");
	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;
ec9af7d4 NC	104	} else {
	105	use locale;
	106	my $u = UTF8Toggle->new("\311");
	107	my $lc = lc $u;
	108	is (length $lc, 1);
	109	is ($lc, "\351", "E accute -> e accute");
	110	$lc = lc $u;
	111	is (length $lc, 1);
	112	is ($lc, "\351", "E accute -> e accute");
6e08b83d NC	113	$lc = lc $u;
	114	is (length $lc, 1);
	115	is ($lc, "\351", "E accute -> e accute");
67306194 NC	116
	117	$u = UTF8Toggle->new("\351");
	118	my $uc = uc $u;
	119	is (length $uc, 1);
	120	is ($uc, "\311", "e accute -> E accute");
	121	$uc = uc $u;
	122	is (length $uc, 1);
	123	is ($uc, "\311", "e accute -> E accute");
6e08b83d NC	124	$uc = uc $u;
	125	is (length $uc, 1);
	126	is ($uc, "\311", "e accute -> E accute");
d54190f6 NC	127
	128	$u = UTF8Toggle->new("\311");
	129	$lc = lcfirst $u;
	130	is (length $lc, 1);
	131	is ($lc, "\351", "E accute -> e accute");
	132	$lc = lcfirst $u;
	133	is (length $lc, 1);
	134	is ($lc, "\351", "E accute -> e accute");
6e08b83d NC	135	$lc = lcfirst $u;
	136	is (length $lc, 1);
	137	is ($lc, "\351", "E accute -> e accute");
d54190f6 NC	138
	139	$u = UTF8Toggle->new("\351");
	140	$uc = ucfirst $u;
	141	is (length $uc, 1);
	142	is ($uc, "\311", "e accute -> E accute");
	143	$uc = ucfirst $u;
	144	is (length $uc, 1);
	145	is ($uc, "\311", "e accute -> E accute");
6e08b83d NC	146	$uc = ucfirst $u;
	147	is (length $uc, 1);
	148	is ($uc, "\311", "e accute -> E accute");
ec9af7d4 NC	149	}
ec9af7d4 NC	150	}
676f44e7 NC	151
	152	my $tmpfile = 'overload.tmp';
	153
c9cb0f41 NC	154	foreach my $operator ('print', 'syswrite', 'syswrite len', 'syswrite off',
c9cb0f41 NC	155	'syswrite len off') {
676f44e7 NC	156	foreach my $layer ('', ':utf8') {
676f44e7 NC	157	open my $fh, "+>$layer", $tmpfile or die $!;
c9cb0f41 NC	158	my $pad = $operator =~ /\boff\b/ ? "\243" : "";
	159	my $trail = $operator =~ /\blen\b/ ? "!" : "";
	160	my $u = UTF8Toggle->new("$pad\311\n$trail");
	161	my $l = UTF8Toggle->new("$pad\351\n$trail", 1);
	162	if ($operator eq 'print') {
	163	print $fh $u;
	164	print $fh $u;
	165	print $fh $u;
	166	print $fh $l;
	167	print $fh $l;
	168	print $fh $l;
	169	} elsif ($operator eq 'syswrite') {
	170	syswrite $fh, $u;
	171	syswrite $fh, $u;
	172	syswrite $fh, $u;
	173	syswrite $fh, $l;
	174	syswrite $fh, $l;
	175	syswrite $fh, $l;
	176	} elsif ($operator eq 'syswrite len') {
	177	syswrite $fh, $u, 2;
	178	syswrite $fh, $u, 2;
	179	syswrite $fh, $u, 2;
	180	syswrite $fh, $l, 2;
	181	syswrite $fh, $l, 2;
	182	syswrite $fh, $l, 2;
	183	} elsif ($operator eq 'syswrite off'
	184	\|\| $operator eq 'syswrite len off') {
	185	syswrite $fh, $u, 2, 1;
	186	syswrite $fh, $u, 2, 1;
	187	syswrite $fh, $u, 2, 1;
	188	syswrite $fh, $l, 2, 1;
	189	syswrite $fh, $l, 2, 1;
	190	syswrite $fh, $l, 2, 1;
	191	} else {
	192	die $operator;
	193	}
676f44e7 NC	194
	195	seek $fh, 0, 0 or die $!;
	196	my $line;
	197	chomp ($line = <$fh>);
	198	is ($line, "\311", "$operator $layer");
	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, "\351", "$operator $layer");
	205	chomp ($line = <$fh>);
	206	is ($line, "\351", "$operator $layer");
	207	chomp ($line = <$fh>);
	208	is ($line, "\351", "$operator $layer");
	209
	210	close $fh or die $!;
	211	unlink $tmpfile or die $!;
	212	}
	213	}
	214
73ee8be2 NC	215	my $little = "\243\243";
	216	my $big = " \243 $little ! $little ! $little \243 ";
	217	my $right = rindex $big, $little;
	218	my $right1 = rindex $big, $little, 11;
	219	my $left = index $big, $little;
	220	my $left1 = index $big, $little, 4;
	221
	222	cmp_ok ($right, ">", $right1, "Sanity check our rindex tests");
	223	cmp_ok ($left, "<", $left1, "Sanity check our index tests");
	224
	225	foreach my $b ($big, UTF8Toggle->new($big)) {
	226	foreach my $l ($little, UTF8Toggle->new($little),
	227	UTF8Toggle->new($little, 1)) {
	228	is (rindex ($b, $l), $right, "rindex");
	229	is (rindex ($b, $l), $right, "rindex");
	230	is (rindex ($b, $l), $right, "rindex");
	231
	232	is (rindex ($b, $l, 11), $right1, "rindex 11");
	233	is (rindex ($b, $l, 11), $right1, "rindex 11");
	234	is (rindex ($b, $l, 11), $right1, "rindex 11");
	235
	236	is (index ($b, $l), $left, "index");
	237	is (index ($b, $l), $left, "index");
	238	is (index ($b, $l), $left, "index");
	239
	240	is (index ($b, $l, 4), $left1, "index 4");
	241	is (index ($b, $l, 4), $left1, "index 4");
	242	is (index ($b, $l, 4), $left1, "index 4");
	243	}
	244	}
676f44e7 NC	245
	246	END {
	247	1 while -f $tmpfile and unlink $tmpfile \|\| die "unlink '$tmpfile': $!";
	248	}