This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
More tests for syswrite with UTF-8 data.
[perl5.git] / t / uni / overload.t
CommitLineData
92331800
NC
1#!perl -w
2
3BEGIN {
4 if ($ENV{'PERL_CORE'}){
5 chdir 't';
6 @INC = '../lib';
7 }
8}
9
676f44e7 10use Test::More tests => 68;
92331800 11
ec9af7d4 12package UTF8Toggle;
92331800
NC
13use strict;
14
15use overload '""' => 'stringify';
16
17sub 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
24sub 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
35package main;
36
37# Bug 34297
38foreach 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
48my $u = UTF8Toggle->new("\311");
49my $lc = lc $u;
50is (length $lc, 1);
51is ($lc, "\311", "E accute -> e accute");
52$lc = lc $u;
53is (length $lc, 1);
54is ($lc, "\351", "E accute -> e accute");
55$lc = lc $u;
56is (length $lc, 1);
57is ($lc, "\311", "E accute -> e accute");
58
59$u = UTF8Toggle->new("\351");
60my $uc = uc $u;
61is (length $uc, 1);
62is ($uc, "\351", "e accute -> E accute");
63$uc = uc $u;
64is (length $uc, 1);
65is ($uc, "\311", "e accute -> E accute");
66$uc = uc $u;
67is (length $uc, 1);
68is ($uc, "\351", "e accute -> E accute");
69
70$u = UTF8Toggle->new("\311");
71$lc = lcfirst $u;
72is (length $lc, 1);
73is ($lc, "\311", "E accute -> e accute");
74$lc = lcfirst $u;
75is (length $lc, 1);
76is ($lc, "\351", "E accute -> e accute");
77$lc = lcfirst $u;
78is (length $lc, 1);
79is ($lc, "\311", "E accute -> e accute");
80
81$u = UTF8Toggle->new("\351");
82$uc = ucfirst $u;
83is (length $uc, 1);
84is ($uc, "\351", "e accute -> E accute");
85$uc = ucfirst $u;
86is (length $uc, 1);
87is ($uc, "\311", "e accute -> E accute");
88$uc = ucfirst $u;
89is (length $uc, 1);
90is ($uc, "\351", "e accute -> E accute");
91
ec9af7d4
NC
92my $have_setlocale = 0;
93eval {
94 require POSIX;
95 import POSIX ':locale_h';
96 $have_setlocale++;
97};
98
99SKIP: {
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 }
150}
676f44e7
NC
151
152my $tmpfile = 'overload.tmp';
153
154foreach my $operator (qw (print)) {
155 foreach my $layer ('', ':utf8') {
156 open my $fh, "+>$layer", $tmpfile or die $!;
157 my $u = UTF8Toggle->new("\311\n");
158 print $fh $u;
159 print $fh $u;
160 print $fh $u;
161 my $l = UTF8Toggle->new("\351\n", 1);
162 print $fh $l;
163 print $fh $l;
164 print $fh $l;
165
166 seek $fh, 0, 0 or die $!;
167 my $line;
168 chomp ($line = <$fh>);
169 is ($line, "\311", "$operator $layer");
170 chomp ($line = <$fh>);
171 is ($line, "\311", "$operator $layer");
172 chomp ($line = <$fh>);
173 is ($line, "\311", "$operator $layer");
174 chomp ($line = <$fh>);
175 is ($line, "\351", "$operator $layer");
176 chomp ($line = <$fh>);
177 is ($line, "\351", "$operator $layer");
178 chomp ($line = <$fh>);
179 is ($line, "\351", "$operator $layer");
180
181 close $fh or die $!;
182 unlink $tmpfile or die $!;
183 }
184}
185
186
187END {
188 1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!";
189}