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