This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0d27f8725c6bed83893372038cfe828aa527966b
[perl5.git] / dist / Devel-PPPort / t / uv.t
1 ################################################################################
2 #
3 #            !!!!!   Do NOT edit this file directly!   !!!!!
4 #
5 #            Edit mktests.PL and/or parts/inc/uv 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 (11) {
34     load();
35     plan(tests => 11);
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 "$]" gt '5.006' }
52
53 ok(&Devel::PPPort::sv_setuv(42), 42);
54 ok(&Devel::PPPort::newSVuv(123), 123);
55 ok(&Devel::PPPort::sv_2uv("4711"), 4711);
56 ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559);
57 ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559);
58 ok(&Devel::PPPort::SvUVx(1735928559), 1735928559);
59 ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef);
60 ok(&Devel::PPPort::XSRETURN_UV(), 42);
61 ok(&Devel::PPPort::PUSHu(), 42);
62 ok(&Devel::PPPort::XPUSHu(), 43);
63 ok(&Devel::PPPort::my_strnlen("abc\0def", 7), 3);
64
65 # skip tests on 5.6.0 and earlier
66 if ("$]" le '5.006') {
67     skip 'skip: broken utf8 support', 0 for 1..51;
68     exit;
69 }
70
71 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", 0), 1);
72 ok(&Devel::PPPort::UTF8_SAFE_SKIP("A", -1), 0);
73
74 my $ret = &Devel::PPPort::utf8_to_uvchr("A");
75 ok($ret->[0], ord("A"));
76 ok($ret->[1], 1);
77
78 $ret = &Devel::PPPort::utf8_to_uvchr("\0");
79 ok($ret->[0], 0);
80 ok($ret->[1], 1);
81
82 $ret = &Devel::PPPort::utf8_to_uvchr_buf("A", 0);
83 ok($ret->[0], ord("A"));
84 ok($ret->[1], 1);
85
86 $ret = &Devel::PPPort::utf8_to_uvchr_buf("\0", 0);
87 ok($ret->[0], 0);
88 ok($ret->[1], 1);
89
90 if (ord("A") != 65) {   # tests not valid for EBCDIC
91     ok(1, 1) for 1 .. (2 + 4 + (7 * 5));
92 }
93 else {
94     $ret = &Devel::PPPort::utf8_to_uvchr_buf("\xc4\x80", 0);
95     ok($ret->[0], 0x100);
96     ok($ret->[1], 2);
97
98     my @warnings;
99     local $SIG{__WARN__} = sub { push @warnings, @_; };
100
101     {
102         BEGIN { 'warnings'->import('utf8') if "$]" gt '5.006' }
103         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
104         ok($ret->[0], 0);
105         ok($ret->[1], -1);
106
107         BEGIN { 'warnings'->unimport() if "$]" gt '5.006' }
108         $ret = &Devel::PPPort::utf8_to_uvchr("\xe0\0\x80");
109         ok($ret->[0], 0xFFFD);
110         ok($ret->[1], 1);
111     }
112
113     my @buf_tests = (
114         {
115             input      => "A",
116             adjustment => -1,
117             warning    => qr/empty/,
118             no_warnings_returned_length => 0,
119         },
120         {
121             input      => "\xc4\xc5",
122             adjustment => 0,
123             warning    => qr/non-continuation/,
124             no_warnings_returned_length => 1,
125         },
126         {
127             input      => "\xc4\x80",
128             adjustment => -1,
129             warning    => qr/short|1 byte, need 2/,
130             no_warnings_returned_length => 1,
131         },
132         {
133             input      => "\xc0\x81",
134             adjustment => 0,
135             warning    => qr/overlong|2 bytes, need 1/,
136             no_warnings_returned_length => 2,
137         },
138         {
139             input      => "\xe0\x80\x81",
140             adjustment => 0,
141             warning    => qr/overlong|3 bytes, need 1/,
142             no_warnings_returned_length => 3,
143         },
144         {
145             input      => "\xf0\x80\x80\x81",
146             adjustment => 0,
147             warning    => qr/overlong|4 bytes, need 1/,
148             no_warnings_returned_length => 4,
149         },
150         {                 # Old algorithm failed to detect this
151             input      => "\xff\x80\x90\x90\x90\xbf\xbf\xbf\xbf\xbf\xbf\xbf\xbf",
152             adjustment => 0,
153             warning    => qr/overflow/,
154             no_warnings_returned_length => 13,
155         },
156     );
157
158     # An empty input is an assertion failure on debugging builds.  It is
159     # deliberately the first test.
160     require Config; import Config;
161     use vars '%Config';
162     if ($Config{ccflags} =~ /-DDEBUGGING/
163         || $^O eq 'VMS' && $Config{usedebugging_perl} eq 'Y') {
164         shift @buf_tests;
165         ok(1, 1) for 1..5;
166     }
167
168     for my $test (@buf_tests) {
169         my $input = $test->{'input'};
170         my $adjustment = $test->{'adjustment'};
171         my $display = 'utf8_to_uvchr_buf("';
172         for (my $i = 0; $i < length($input) + $adjustment; $i++) {
173             $display .= sprintf "\\x%02x", ord substr($input, $i, 1);
174         }
175
176         $display .= '")';
177         my $warning = $test->{'warning'};
178
179         undef @warnings;
180         BEGIN { 'warnings'->import('utf8') if "$]" gt '5.006' }
181         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
182         ok($ret->[0], 0,  "returned value $display; warnings enabled");
183         ok($ret->[1], -1, "returned length $display; warnings enabled");
184         my $all_warnings = join "; ", @warnings;
185         my $contains = grep { $_ =~ $warning } $all_warnings;
186         ok($contains, 1, $display
187                     . "; Got: '$all_warnings', which should contain '$warning'");
188
189         undef @warnings;
190         BEGIN { 'warnings'->unimport('utf8') if "$]" gt '5.006' }
191         $ret = &Devel::PPPort::utf8_to_uvchr_buf($input, $adjustment);
192         ok($ret->[0], 0xFFFD,  "returned value $display; warnings disabled");
193         ok($ret->[1], $test->{'no_warnings_returned_length'},
194                       "returned length $display; warnings disabled");
195     }
196 }
197