t/op/length.t

   1 #!./perl
   2 use warnings;
   3 use strict;
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     require './test.pl';
   8     require './charset_tools.pl';
   9     set_up_inc('../lib');
  10 }
  11
  12 plan (tests => 46 + 3 * $::IS_ASCII);
  13
  14 is(length(""), 0);
  15 is(length("abc"), 3);
  16 $_ = "foobar";
  17 is(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
  30 if ($::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
 109 require Tie::Scalar;
 110
 111 my $u = "ASCII";
 112
 113 tie $u, 'Tie::StdScalar', chr 256;
 114
 115 is(length $u, 1, "Length of a UTF-8 scalar returned from tie");
 116 is(length $u, 1, "Again! Again!");
 117
 118 $^W = 1;
 119
 120 my $warnings = 0;
 121
 122 $SIG{__WARN__} = sub {
 123     $warnings++;
 124     warn @_;
 125 };
 126
 127 is(length(undef), undef, "Length of literal undef");
 128
 129 undef $u;
 130
 131 is(length($u), undef, "Length of regular scalar");
 132
 133 $u = "Gotcha!";
 134
 135 tie $u, 'Tie::StdScalar';
 136
 137 is(length($u), undef, "Length of tied scalar (MAGIC)");
 138
 139 is($u, undef);
 140
 141 {
 142     package U;
 143     use overload '""' => sub {return undef;};
 144 }
 145
 146 my $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
 155 my $ul = 3;
 156 is(($ul = length(undef)), undef,
 157                     "Returned length of undef with result in TARG");
 158 is($ul, undef, "Assigned length of undef with result in TARG");
 159
 160 $ul = 3;
 161 is(($ul = length($u)), undef,
 162                 "Returned length of tied undef with result in TARG");
 163 is($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 }
 173 is($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.
 198 my $ref = [];
 199 bless $ref, "\x{100}";
 200 is length $ref, length "$ref", 'length on reference blessed to utf8 class';
 201
 202 is($warnings, 0, "There were no other warnings");