This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Get length.t working under miniperl
[perl5.git] / t / op / length.t
CommitLineData
9dc04555
JH
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
d0644529 5 require './test.pl';
811fe5dc
FC
6 @INC = () unless is_miniperl();
7 unshift @INC, '../lib';
9dc04555
JH
8}
9
0f43fd57 10plan (tests => 41);
9dc04555
JH
11
12print "not " unless length("") == 0;
13print "ok 1\n";
14
15print "not " unless length("abc") == 3;
16print "ok 2\n";
17
18$_ = "foobar";
19print "not " unless length() == 6;
20print "ok 3\n";
21
22# Okay, so that wasn't very challenging. Let's go Unicode.
23
24{
25 my $a = "\x{41}";
26
27 print "not " unless length($a) == 1;
28 print "ok 4\n";
29 $test++;
30
31 use bytes;
32 print "not " unless $a eq "\x41" && length($a) == 1;
33 print "ok 5\n";
34 $test++;
35}
36
37{
6c8584ec 38 my $a = pack("U", 0xFF);
c4d5f83a 39
9dc04555
JH
40 print "not " unless length($a) == 1;
41 print "ok 6\n";
42 $test++;
c4d5f83a 43
9dc04555 44 use bytes;
c4d5f83a
NIS
45 if (ord('A') == 193)
46 {
6c8584ec 47 printf "#%vx for 0xFF\n",$a;
e87322b2 48 print "not " unless $a eq "\x8b\x73" && length($a) == 2;
c4d5f83a
NIS
49 }
50 else
51 {
6c8584ec 52 print "not " unless $a eq "\xc3\xbf" && length($a) == 2;
c4d5f83a 53 }
9dc04555
JH
54 print "ok 7\n";
55 $test++;
56}
57
58{
59 my $a = "\x{100}";
c4d5f83a 60
9dc04555
JH
61 print "not " unless length($a) == 1;
62 print "ok 8\n";
63 $test++;
c4d5f83a 64
9dc04555 65 use bytes;
c4d5f83a
NIS
66 if (ord('A') == 193)
67 {
68 printf "#%vx for 0x100\n",$a;
69 print "not " unless $a eq "\x8c\x41" && length($a) == 2;
70 }
71 else
72 {
73 print "not " unless $a eq "\xc4\x80" && length($a) == 2;
74 }
9dc04555
JH
75 print "ok 9\n";
76 $test++;
77}
78
79{
80 my $a = "\x{100}\x{80}";
c4d5f83a 81
9dc04555
JH
82 print "not " unless length($a) == 2;
83 print "ok 10\n";
84 $test++;
c4d5f83a 85
9dc04555 86 use bytes;
c4d5f83a
NIS
87 if (ord('A') == 193)
88 {
89 printf "#%vx for 0x100 0x80\n",$a;
90 print "not " unless $a eq "\x8c\x41\x8a\x67" && length($a) == 4;
91 }
92 else
93 {
94 print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
95 }
9dc04555
JH
96 print "ok 11\n";
97 $test++;
98}
99
100{
101 my $a = "\x{80}\x{100}";
c4d5f83a 102
9dc04555
JH
103 print "not " unless length($a) == 2;
104 print "ok 12\n";
105 $test++;
c4d5f83a 106
9dc04555 107 use bytes;
c4d5f83a
NIS
108 if (ord('A') == 193)
109 {
110 printf "#%vx for 0x80 0x100\n",$a;
111 print "not " unless $a eq "\x8a\x67\x8c\x41" && length($a) == 4;
112 }
113 else
114 {
115 print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
116 }
9dc04555
JH
117 print "ok 13\n";
118 $test++;
119}
5636d518
DB
120
121# Now for Unicode with magical vtbls
122
123{
124 require Tie::Scalar;
125 my $a;
126 tie $a, 'Tie::StdScalar'; # makes $a magical
127 $a = "\x{263A}";
128
129 print "not " unless length($a) == 1;
130 print "ok 14\n";
131 $test++;
132
133 use bytes;
134 print "not " unless length($a) == 3;
135 print "ok 15\n";
136 $test++;
137}
54f923ef
JH
138
139{
140 # Play around with Unicode strings,
141 # give a little workout to the UTF-8 length cache.
142 my $a = chr(256) x 100;
143 print length $a == 100 ? "ok 16\n" : "not ok 16\n";
144 chop $a;
145 print length $a == 99 ? "ok 17\n" : "not ok 17\n";
146 $a .= $a;
147 print length $a == 198 ? "ok 18\n" : "not ok 18\n";
148 $a = chr(256) x 999;
149 print length $a == 999 ? "ok 19\n" : "not ok 19\n";
150 substr($a, 0, 1) = '';
151 print length $a == 998 ? "ok 20\n" : "not ok 20\n";
152}
d0644529
NC
153
154curr_test(21);
155
156require Tie::Scalar;
157
158$u = "ASCII";
159
160tie $u, 'Tie::StdScalar', chr 256;
161
162is(length $u, 1, "Length of a UTF-8 scalar returned from tie");
163is(length $u, 1, "Again! Again!");
164
9f621bb0
NC
165$^W = 1;
166
167my $warnings = 0;
168
169$SIG{__WARN__} = sub {
170 $warnings++;
171 warn @_;
172};
173
174is(length(undef), undef, "Length of literal undef");
175
176my $u;
177
178is(length($u), undef, "Length of regular scalar");
179
180$u = "Gotcha!";
181
182tie $u, 'Tie::StdScalar';
183
184is(length($u), undef, "Length of tied scalar (MAGIC)");
185
186is($u, undef);
187
188{
189 package U;
190 use overload '""' => sub {return undef;};
191}
192
193my $uo = bless [], 'U';
194
0f43fd57
FC
195{
196 my $w;
197 local $SIG{__WARN__} = sub { $w = shift };
198 is(length($uo), 0, "Length of overloaded reference");
199 like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
200}
9f621bb0 201
d88e091f
BM
202my $ul = 3;
203is(($ul = length(undef)), undef,
204 "Returned length of undef with result in TARG");
205is($ul, undef, "Assigned length of undef with result in TARG");
206
207$ul = 3;
208is(($ul = length($u)), undef,
209 "Returned length of tied undef with result in TARG");
210is($ul, undef, "Assigned length of tied undef with result in TARG");
211
212$ul = 3;
0f43fd57
FC
213{
214 my $w;
215 local $SIG{__WARN__} = sub { $w = shift };
216 is(($ul = length($uo)), 0,
d88e091f 217 "Returned length of overloaded undef with result in TARG");
0f43fd57
FC
218 like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
219}
220is($ul, 0, "Assigned length of overloaded undef with result in TARG");
9f621bb0 221
6ef2ab89
NC
222{
223 my $y = "\x{100}BC";
224 is(index($y, "B"), 1, 'adds an intermediate position to the offset cache');
225 is(length $y, 3,
226 'Check that sv_len_utf8() can take advantage of the offset cache');
227}
9407f9c1
DL
228
229{
230 local $SIG{__WARN__} = sub {
231 pass("'print length undef' warned");
232 };
233 print length undef;
234}
235
c6fb3f6e
FC
236{
237 local $SIG{__WARN__} = sub {
238 pass '[perl #106726] no crash with length @lexical warning'
239 };
240 eval ' sub { length my @forecasts } ';
241}
242
193059ca
FC
243# length could be fooled by UTF8ness of non-magical variables changing with
244# stringification.
245my $ref = [];
246bless $ref, "\x{100}";
247is length $ref, length "$ref", 'length on reference blessed to utf8 class';
248
9407f9c1 249is($warnings, 0, "There were no other warnings");