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
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     @INC = () unless is_miniperl();
7     unshift @INC, '../lib';
8 }
9
10 plan (tests => 41);
11
12 print "not " unless length("")    == 0;
13 print "ok 1\n";
14
15 print "not " unless length("abc") == 3;
16 print "ok 2\n";
17
18 $_ = "foobar";
19 print "not " unless length()      == 6;
20 print "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 {
38     my $a = pack("U", 0xFF);
39
40     print "not " unless length($a) == 1;
41     print "ok 6\n";
42     $test++;
43
44     use bytes;
45     if (ord('A') == 193)
46      {
47       printf "#%vx for 0xFF\n",$a;
48       print "not " unless $a eq "\x8b\x73" && length($a) == 2;
49      }
50     else
51      {
52       print "not " unless $a eq "\xc3\xbf" && length($a) == 2;
53      }
54     print "ok 7\n";
55     $test++;
56 }
57
58 {
59     my $a = "\x{100}";
60
61     print "not " unless length($a) == 1;
62     print "ok 8\n";
63     $test++;
64
65     use bytes;
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      }
75     print "ok 9\n";
76     $test++;
77 }
78
79 {
80     my $a = "\x{100}\x{80}";
81
82     print "not " unless length($a) == 2;
83     print "ok 10\n";
84     $test++;
85
86     use bytes;
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      }
96     print "ok 11\n";
97     $test++;
98 }
99
100 {
101     my $a = "\x{80}\x{100}";
102
103     print "not " unless length($a) == 2;
104     print "ok 12\n";
105     $test++;
106
107     use bytes;
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      }
117     print "ok 13\n";
118     $test++;
119 }
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 }
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 }
153
154 curr_test(21);
155
156 require Tie::Scalar;
157
158 $u = "ASCII";
159
160 tie $u, 'Tie::StdScalar', chr 256;
161
162 is(length $u, 1, "Length of a UTF-8 scalar returned from tie");
163 is(length $u, 1, "Again! Again!");
164
165 $^W = 1;
166
167 my $warnings = 0;
168
169 $SIG{__WARN__} = sub {
170     $warnings++;
171     warn @_;
172 };
173
174 is(length(undef), undef, "Length of literal undef");
175
176 my $u;
177
178 is(length($u), undef, "Length of regular scalar");
179
180 $u = "Gotcha!";
181
182 tie $u, 'Tie::StdScalar';
183
184 is(length($u), undef, "Length of tied scalar (MAGIC)");
185
186 is($u, undef);
187
188 {
189     package U;
190     use overload '""' => sub {return undef;};
191 }
192
193 my $uo = bless [], 'U';
194
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 }
201
202 my $ul = 3;
203 is(($ul = length(undef)), undef, 
204                     "Returned length of undef with result in TARG");
205 is($ul, undef, "Assigned length of undef with result in TARG");
206
207 $ul = 3;
208 is(($ul = length($u)), undef,
209                 "Returned length of tied undef with result in TARG");
210 is($ul, undef, "Assigned length of tied undef with result in TARG");
211
212 $ul = 3;
213 {
214     my $w;
215     local $SIG{__WARN__} = sub { $w = shift };
216     is(($ul = length($uo)), 0,
217                 "Returned length of overloaded undef with result in TARG");
218     like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
219 }    
220 is($ul, 0, "Assigned length of overloaded undef with result in TARG");
221
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 }
228
229 {
230     local $SIG{__WARN__} = sub {
231         pass("'print length undef' warned");
232     };
233     print length undef;
234 }
235
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
243 # length could be fooled by UTF8ness of non-magical variables changing with
244 # stringification.
245 my $ref = [];
246 bless $ref, "\x{100}";
247 is length $ref, length "$ref", 'length on reference blessed to utf8 class';
248
249 is($warnings, 0, "There were no other warnings");