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