| Commit | Line | Data |
|---|
| 92331800 |
1 | #!perl -w |
| 2 | |
| 3 | BEGIN { |
| 4 | if ($ENV{'PERL_CORE'}){ |
| 5 | chdir 't'; |
| 6 | @INC = '../lib'; |
| 7 | } |
| 8 | } |
| 9 | |
| 676f44e7 |
10 | use Test::More tests => 68; |
| 92331800 |
11 | |
| ec9af7d4 |
12 | package UTF8Toggle; |
| 92331800 |
13 | use strict; |
| 14 | |
| 15 | use overload '""' => 'stringify'; |
| 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); |
| 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 |
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 |
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 |
113 | $lc = lc $u; |
| 114 | is (length $lc, 1); |
| 115 | is ($lc, "\351", "E accute -> e accute"); |
| 67306194 |
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 |
124 | $uc = uc $u; |
| 125 | is (length $uc, 1); |
| 126 | is ($uc, "\311", "e accute -> E accute"); |
| d54190f6 |
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 |
135 | $lc = lcfirst $u; |
| 136 | is (length $lc, 1); |
| 137 | is ($lc, "\351", "E accute -> e accute"); |
| d54190f6 |
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 |
146 | $uc = ucfirst $u; |
| 147 | is (length $uc, 1); |
| 148 | is ($uc, "\311", "e accute -> E accute"); |
| ec9af7d4 |
149 | } |
| 150 | } |
| 676f44e7 |
151 | |
| 152 | my $tmpfile = 'overload.tmp'; |
| 153 | |
| 154 | foreach 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 | |
| 187 | END { |
| 188 | 1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!"; |
| 189 | } |
projects / p5sagit/p5-mst-13.2.git / blame