This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Backport UTF8_IS_INVARIANT, UVCHR_IS_INVARIANT
[perl5.git] / dist / Devel-PPPort / t / utf8.t
1 ################################################################################
2 #
3 #            !!!!!   Do NOT edit this file directly!   !!!!!
4 #
5 #            Edit mktests.PL and/or parts/inc/utf8 instead.
6 #
7 #  This file was automatically generated from the definition files in the
8 #  parts/inc/ subdirectory by mktests.PL. To learn more about how all this
9 #  works, please read the F<HACKERS> file that came with this distribution.
10 #
11 ################################################################################
12
13 BEGIN {
14   if ($ENV{'PERL_CORE'}) {
15     chdir 't' if -d 't';
16     @INC = ('../lib', '../ext/Devel-PPPort/t') if -d '../lib' && -d '../ext';
17     require Config; import Config;
18     use vars '%Config';
19     if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) {
20       print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
21       exit 0;
22     }
23   }
24   else {
25     unshift @INC, 't';
26   }
27
28   sub load {
29     eval "use Test";
30     require 'testutil.pl' if $@;
31   }
32
33   if (84) {
34     load();
35     plan(tests => 84);
36   }
37 }
38
39 use Devel::PPPort;
40 use strict;
41 BEGIN { $^W = 1; }
42
43 package Devel::PPPort;
44 use vars '@ISA';
45 require DynaLoader;
46 @ISA = qw(DynaLoader);
47 bootstrap Devel::PPPort;
48
49 package main;
50
51 BEGIN { require warnings if "$]" > '5.006' }
52
53 # skip tests on 5.6.0 and earlier, plus 7.0
54 if ("$]" <= '5.006' || "$]" == '5.007' ) {
55     for (1..84) {
56         skip 'skip: broken utf8 support', 0;
57     }
58     exit;
59 }
60
61 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
62 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
63
64 ok(&Devel::PPPort::isUTF8_CHAR("A", -1), 0);
65 ok(&Devel::PPPort::isUTF8_CHAR("A",  0), 1);
66 ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  -1), 0);
67 ok(&Devel::PPPort::isUTF8_CHAR("\x{100}",  0), 2);
68
69 ok(&Devel::PPPort::UVCHR_IS_INVARIANT(ord("A")), 1);
70 ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0xb6));
71 ok(! &Devel::PPPort::UVCHR_IS_INVARIANT(0x100));
72
73 if ("$]" < '5.008') {
74     for (1 ..3) {
75         ok(1, 1)
76     }
77 }
78 else {
79     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{101}", 3, 1), 1);
80     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "a\x{102}", 3, 1), 0);
81     ok(&Devel::PPPort::foldEQ_utf8("A\x{100}", 3, 1, "b\x{101}", 3, 1), 0);
82 }
83
84 my $ret = &Devel::PPPort::utf8_to_uvchr("A");
85 ok($ret->[0], ord("A"));
86 ok($ret->[1], 1);
87
88 $ret = &Devel::PPPort::utf8_to_uvchr("\0");
89 ok($ret->[0], 0);
90 ok($ret->[1], 1);
91
92 $ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
93 ok($ret->[0], ord("A"));
94 ok($ret->[1], 1);
95
96 $ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
97 ok($ret->[0], 0);
98 ok($ret->[1], 1);
99
100 if (ord("A") != 65) {   # tests not valid for EBCDIC
101     for (1 .. (2 + 4 + (7 * 5))) {
102         ok(1, 1);
103     }
104 }
105 else {
106     $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
107     ok($ret->[0], 0x100);
108     ok($ret->[1], 2);
109
110     my @warnings;
111     local $SIG{__WARN__} = sub { push @warnings, @_; };
112
113     {
114         BEGIN { 'warnings'->import('utf8') if "$]" > '5.006' }
115         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
116         ok($ret->[0], 0);
117         ok($ret->[1], -1);
118
119         BEGIN { 'warnings'->unimport() if "$]" > '5.006' }
120         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
121         ok($ret->[0], 0xFFFD);
122         ok($ret->[1], 1);
123     }
124
125     my @buf_tests = (
126         {
127             input      => "A",
128             adjustment => -1,
129             warning    => eval "qr/empty/",
130             no_warnings_returned_length => 0,
131         },
132         {
133             input      => "\xc4\xc5",
134             adjustment => 0,
135             warning    => eval "qr/non-continuation/",
136             no_warnings_returned_length => 1,
137         },
138         {
139             input      => "\xc4\x80",
140             adjustment => -1,
141             warning    => eval "qr/short|1 byte, need 2/",
142             no_warnings_returned_length => 1,
143         },
144         {
145             input      => "\xc0\x81",
146             adjustment => 0,
147             warning    => eval "qr/overlong|2 bytes, need 1/",
148             no_warnings_returned_length => 2,
149         },
150         {
151             input      => "\xe0\x80\x81",
152             adjustment => 0,
153             warning    => eval "qr/overlong|3 bytes, need 1/",
154             no_warnings_returned_length => 3,
155         },
156         {
157             input      => "\xf0\x80\x80\x81",
158             adjustment => 0,
159             warning    => eval "qr/overlong|4 bytes, need 1/",
160             no_warnings_returned_length => 4,
161         },
162         {                 # Old algorithm failed to detect this
163             input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
164             adjustment => 0,
165             warning    => eval "qr/overflow/",
166             no_warnings_returned_length => 13,
167         },
168     );
169
170     # An empty input is an assertion failure on debugging builds.  It is
171     # deliberately the first test.
172     require Config; import Config;
173     use vars '%Config';
174     if ($Config{ccflags} =~ /-DDEBUGGING/) {
175         shift @buf_tests;
176         for (1..5) {
177             ok(1, 1);
178         }
179     }
180
181     my $test;
182     for $test (@buf_tests) {
183         my $input = $test->{'input'};
184         my $adjustment = $test->{'adjustment'};
185         my $display = 'utf8_to_uvchr_buf("';
186         my $i;
187         for ($i = 0; $i < length($input) + $adjustment; $i++) {
188             $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
189         }
190
191         $display .= '")';
192         my $warning = $test->{'warning'};
193
194         undef @warnings;
195         BEGIN { 'warnings'->import('utf8') if "$]" > '5.006' }
196         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
197         ok($ret->[0], 0,  "returned value $display; warnings enabled");
198         ok($ret->[1], -1, "returned length $display; warnings enabled");
199         my $all_warnings = join "; ", @warnings;
200         my $contains = grep { $_ =~ $warning } $all_warnings;
201         ok($contains, 1, $display
202                     . "; Got: '$all_warnings', which should contain '$warning'");
203
204         undef @warnings;
205         BEGIN { 'warnings'->unimport('utf8') if "$]" > '5.006' }
206         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
207         ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
208         ok($ret->[1], $test->{'no_warnings_returned_length'},
209                       "returned length $display; warnings disabled");
210     }
211 }
212
213 if ("$]" ge '5.008') {
214     BEGIN { if ("$]" ge '5.008') { require utf8; "utf8"->import() } }
215
216     ok(Devel::PPPort::sv_len_utf8("aščť"), 4);
217     ok(Devel::PPPort::sv_len_utf8_nomg("aščť"), 4);
218
219     my $str = "áíé";
220     utf8::downgrade($str);
221     ok(Devel::PPPort::sv_len_utf8($str), 3);
222     utf8::downgrade($str);
223     ok(Devel::PPPort::sv_len_utf8_nomg($str), 3);
224     utf8::upgrade($str);
225     ok(Devel::PPPort::sv_len_utf8($str), 3);
226     utf8::upgrade($str);
227     ok(Devel::PPPort::sv_len_utf8_nomg($str), 3);
228
229     tie my $scalar, 'TieScalarCounter', "é";
230
231     ok(tied($scalar)->{fetch}, 0);
232     ok(tied($scalar)->{store}, 0);
233     ok(Devel::PPPort::sv_len_utf8($scalar), 2);
234     ok(tied($scalar)->{fetch}, 1);
235     ok(tied($scalar)->{store}, 0);
236     ok(Devel::PPPort::sv_len_utf8($scalar), 3);
237     ok(tied($scalar)->{fetch}, 2);
238     ok(tied($scalar)->{store}, 0);
239     ok(Devel::PPPort::sv_len_utf8($scalar), 4);
240     ok(tied($scalar)->{fetch}, 3);
241     ok(tied($scalar)->{store}, 0);
242     ok(Devel::PPPort::sv_len_utf8_nomg($scalar), 4);
243     ok(tied($scalar)->{fetch}, 3);
244     ok(tied($scalar)->{store}, 0);
245     ok(Devel::PPPort::sv_len_utf8_nomg($scalar), 4);
246     ok(tied($scalar)->{fetch}, 3);
247     ok(tied($scalar)->{store}, 0);
248 } else {
249     for (1..23) {
250         skip 'skip: no SV_NOSTEAL support', 0;
251     }
252 }
253
254 package TieScalarCounter;
255
256 sub TIESCALAR {
257     my ($class, $value) = @_;
258     return bless { fetch => 0, store => 0, value => $value }, $class;
259 }
260
261 sub FETCH {
262     BEGIN { if ("$]" ge '5.008') { require utf8; "utf8"->import() } }
263     my ($self) = @_;
264     $self->{fetch}++;
265     return $self->{value} .= "é";
266 }
267
268 sub STORE {
269     my ($self, $value) = @_;
270     $self->{store}++;
271     $self->{value} = $value;
272 }
273