xref: /openbsd-src/gnu/usr.bin/perl/cpan/Encode/t/utf32warnings.t (revision fc405d53b73a2d73393cb97f684863d17b583e38) 
1use strict;
2use warnings;
3
4my $script = quotemeta $0;
5
6use Encode;
7use Test::More tests => 38;
8
9my $valid   = "\x61\x00\x00\x00";
10my $invalid = "\x78\x56\x34\x12";
11
12our $warn;
13$SIG{__WARN__} = sub { $warn = $_[0] };
14
15my $enc = find_encoding("UTF32-LE");
16
17{
18    local $warn;
19    my $ret = $enc->encode( "a", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
20    is($warn, undef, "Calling encode on UTF32-LE encode object with valid string produces no warnings");
21    is($ret, $valid, "Calling encode on UTF32-LE encode object with valid string returns correct output");
22}
23
24
25{
26    local $warn;
27    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
28    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling encode on UTF32-LE encode object with invalid string warns");
29}
30
31{
32    local $warn;
33    no warnings 'utf8';
34    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
35    is($warn, undef, "Warning from encode method of UTF32-LE encode object can be silenced via no warnings 'utf8'");
36}
37
38{
39    local $warn;
40    no warnings;
41    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
42    is($warn, undef, "Warning from encode method of UTF32-LE encode object can be silenced via no warnings");
43}
44
45{
46    local $warn;
47    no warnings 'utf8';
48    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
49    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from encode method of UTF32-LE encode object cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
50}
51
52{
53    local $warn;
54    no warnings;
55    $enc->encode( "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
56    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from encode method of UTF32-LE encode object cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
57}
58
59
60{
61    local $warn;
62    my $ret = Encode::encode( $enc, "a", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
63    is($warn, undef, "Calling Encode::encode for UTF32-LE with valid string produces no warnings");
64    is($ret, $valid, "Calling Encode::encode for UTF32-LE with valid string returns correct output");
65}
66
67
68{
69    local $warn;
70    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
71    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling Encode::encode for UTF32-LE with invalid string warns");
72}
73
74
75{
76    local $warn;
77    no warnings 'utf8';
78    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
79    is($warn, undef, "Warning from Encode::encode for UTF32-LE can be silenced via no warnings 'utf8'");
80}
81
82{
83    local $warn;
84    no warnings;
85    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
86    is($warn, undef, "Warning from Encode::encode for UTF32-LE can be silenced via no warnings");
87}
88
89{
90    local $warn;
91    no warnings 'utf8';
92    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
93    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from Encode::encode for UTF32-LE cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
94}
95
96{
97    local $warn;
98    no warnings;
99    Encode::encode( $enc, "\x{D800}", Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
100    like($warn, qr/UTF-16 surrogate.* at $script line /, "Warning from Encode::encode for UTF32-LE cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
101}
102
103
104{
105    local $warn;
106    my $ret = $enc->decode( $valid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
107    is($warn, undef, "Calling decode on UTF32-LE encode object with valid string produces no warnings");
108    is($ret, "a", "Calling decode on UTF32-LE encode object with valid string returns correct output");
109}
110
111
112{
113    local $warn;
114    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
115    like($warn, qr/may not be portable.* at $script line /, "Calling decode on UTF32-LE encode object with invalid string warns");
116}
117
118{
119    local $warn;
120    no warnings 'utf8';
121    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
122    is($warn, undef, "Warning from decode method of UTF32-LE encode object can be silenced via no warnings 'utf8'");
123}
124
125{
126    local $warn;
127    no warnings;
128    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
129    is($warn, undef, "Warning from decode method of UTF32-LE encode object can be silenced via no warnings");
130}
131
132{
133    local $warn;
134    no warnings 'utf8';
135    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
136    like($warn, qr/may not be portable.* at $script line /, "Warning from decode method of UTF32-LE encode object cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
137}
138
139{
140    local $warn;
141    no warnings;
142    $enc->decode( $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
143    like($warn, qr/may not be portable.* at $script line /, "Warning from decode method of UTF32-LE encode object cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
144}
145
146
147{
148    local $warn;
149    my $ret = Encode::decode( $enc, $valid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
150    is($warn, undef, "Calling Encode::decode for UTF32-LE with valid string produces no warnings");
151    is($ret, "a", "Calling Encode::decode for UTF32-LE with valid string returns correct output");
152}
153
154
155{
156    local $warn;
157    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
158    like($warn, qr/may not be portable.* at $script line /, "Calling Encode::decode for UTF32-LE with invalid string warns");
159}
160
161{
162    local $warn;
163    no warnings 'utf8';
164    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
165    is($warn, undef, "Warning from Encode::decode for UTF32-LE can be silenced via no warnings 'utf8'");
166}
167
168{
169    local $warn;
170    no warnings;
171    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::ONLY_PRAGMA_WARNINGS | Encode::LEAVE_SRC );
172    is($warn, undef, "Warning from Encode::decode for UTF32-LE can be silenced via no warnings");
173}
174
175{
176    local $warn;
177    no warnings 'utf8';
178    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
179    like($warn, qr/may not be portable.* at $script line /, "Warning from Encode::decode for UTF32-LE cannot be silenced via no warnings 'utf8' when ONLY_PRAGMA_WARNINGS is not used");
180}
181
182{
183    local $warn;
184    no warnings;
185    Encode::decode( $enc, $invalid, Encode::WARN_ON_ERR | Encode::LEAVE_SRC );
186    like($warn, qr/may not be portable.* at $script line /, "Warning from Encode::decode for UTF32-LE cannot be silenced via no warnings when ONLY_PRAGMA_WARNINGS is not used");
187}
188
189
190use PerlIO::encoding;
191$PerlIO::encoding::fallback |= Encode::ONLY_PRAGMA_WARNINGS;
192
193{
194    local $warn;
195    my $tmp = $valid;
196    $tmp .= ''; # de-COW
197    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
198    my $str = <$fh>;
199    close $fh;
200    is($warn, undef, "Calling PerlIO :encoding on valid string produces no warnings");
201    is($str, "a", "PerlIO decodes string correctly");
202}
203
204
205{
206    local $warn;
207    my $tmp = $invalid;
208    use Devel::Peek;
209    $tmp .= ''; # de-COW
210    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
211    my $str = <$fh>;
212    close $fh;
213    like($warn, qr/may not be portable.* at $script line /, "Calling PerlIO :encoding on invalid string warns");
214}
215
216{
217    local $warn;
218    my $tmp = $invalid;
219    $tmp .= ''; # de-COW
220    no warnings 'utf8';
221    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
222    my $str = <$fh>;
223    close $fh;
224    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings 'utf8'");
225}
226
227{
228    local $warn;
229    my $tmp = $invalid;
230    $tmp .= ''; # de-COW
231    no warnings;
232    open my $fh, '<:encoding(UTF32-LE)', \$tmp or die;
233    my $str = <$fh>;
234    close $fh;
235    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings");
236}
237
238
239{
240    local $warn;
241    my $str;
242    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
243    print $fh "a";
244    close $fh;
245    is($warn, undef, "Calling PerlIO :encoding on valid string produces no warnings");
246    is($str, $valid, "PerlIO encodes string correctly");
247}
248
249
250{
251    local $warn;
252    my $str;
253    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
254    print $fh "\x{D800}";
255    close $fh;
256    like($warn, qr/UTF-16 surrogate.* at $script line /, "Calling PerlIO :encoding on invalid string warns");
257}
258
259{
260    local $warn;
261    my $str;
262    no warnings 'utf8';
263    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
264    print $fh "\x{D800}";
265    close $fh;
266    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings 'utf8'");
267}
268
269{
270    local $warn;
271    my $str;
272    no warnings;
273    open my $fh, '>:encoding(UTF32-LE)', \$str or die;
274    print $fh "\x{D800}";
275    close $fh;
276    is($warn, undef, "Warning from PerlIO :encoding can be silenced via no warnings");
277}
278