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");