This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
55260d32b8306b159729176ed5c43f726c7b1bb7
[perl5.git] / t / op / length.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     @INC = '../lib';
7 }
8
9 plan (tests => 38);
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 is(length($uo), undef, "Length of overloaded reference");
195
196 my $ul = 3;
197 is(($ul = length(undef)), undef, 
198                     "Returned length of undef with result in TARG");
199 is($ul, undef, "Assigned length of undef with result in TARG");
200
201 $ul = 3;
202 is(($ul = length($u)), undef,
203                 "Returned length of tied undef with result in TARG");
204 is($ul, undef, "Assigned length of tied undef with result in TARG");
205
206 $ul = 3;
207 is(($ul = length($uo)), undef,
208                 "Returned length of overloaded undef with result in TARG");
209 is($ul, undef, "Assigned length of overloaded undef with result in TARG");
210
211 # ok(!defined $uo); Turns you can't test this. FIXME for pp_defined?
212
213 {
214     my $y = "\x{100}BC";
215     is(index($y, "B"), 1, 'adds an intermediate position to the offset cache');
216     is(length $y, 3,
217        'Check that sv_len_utf8() can take advantage of the offset cache');
218 }
219
220 {
221     local $SIG{__WARN__} = sub {
222         pass("'print length undef' warned");
223     };
224     print length undef;
225 }
226
227 {
228     local $SIG{__WARN__} = sub {
229         pass '[perl #106726] no crash with length @lexical warning'
230     };
231     eval ' sub { length my @forecasts } ';
232 }
233
234 is($warnings, 0, "There were no other warnings");