Get length.t working under miniperl

[perl5.git] / t / op / length.t

diff --git a/t/op/length.t b/t/op/length.t
index ceb005e..e7be3aa 100644 (file)
--- a/t/op/length.t
+++ b/t/op/length.t
@@ -2,10 +2,12 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
+    require './test.pl';
+    @INC = () unless is_miniperl();
+    unshift @INC, '../lib';
 }
 
-print "1..13\n";
+plan (tests => 41);
 
 print "not " unless length("")    == 0;
 print "ok 1\n";
@@ -33,53 +35,215 @@ print "ok 3\n";
 }
 
 {
-    my $a = "\x{80}";
-    
+    my $a = pack("U", 0xFF);
+
     print "not " unless length($a) == 1;
     print "ok 6\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc2\x80" && length($a) == 2;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0xFF\n",$a;
+      print "not " unless $a eq "\x8b\x73" && length($a) == 2;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc3\xbf" && length($a) == 2;
+     }
     print "ok 7\n";
     $test++;
 }
 
 {
     my $a = "\x{100}";
-    
+
     print "not " unless length($a) == 1;
     print "ok 8\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc4\x80" && length($a) == 2;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0x100\n",$a;
+      print "not " unless $a eq "\x8c\x41" && length($a) == 2;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc4\x80" && length($a) == 2;
+     }
     print "ok 9\n";
     $test++;
 }
 
 {
     my $a = "\x{100}\x{80}";
-    
+
     print "not " unless length($a) == 2;
     print "ok 10\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0x100 0x80\n",$a;
+      print "not " unless $a eq "\x8c\x41\x8a\x67" && length($a) == 4;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
+     }
     print "ok 11\n";
     $test++;
 }
 
 {
     my $a = "\x{80}\x{100}";
-    
+
     print "not " unless length($a) == 2;
     print "ok 12\n";
     $test++;
-    
+
     use bytes;
-    print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
+    if (ord('A') == 193)
+     {
+      printf "#%vx for 0x80 0x100\n",$a;
+      print "not " unless $a eq "\x8a\x67\x8c\x41" && length($a) == 4;
+     }
+    else
+     {
+      print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
+     }
     print "ok 13\n";
     $test++;
 }
+
+# Now for Unicode with magical vtbls
+
+{
+    require Tie::Scalar;
+    my $a;
+    tie $a, 'Tie::StdScalar';  # makes $a magical
+    $a = "\x{263A}";
+    
+    print "not " unless length($a) == 1;
+    print "ok 14\n";
+    $test++;
+
+    use bytes;
+    print "not " unless length($a) == 3;
+    print "ok 15\n";
+    $test++;
+}
+
+{
+    # Play around with Unicode strings,
+    # give a little workout to the UTF-8 length cache.
+    my $a = chr(256) x 100;
+    print length $a == 100 ? "ok 16\n" : "not ok 16\n";
+    chop $a;
+    print length $a ==  99 ? "ok 17\n" : "not ok 17\n";
+    $a .= $a;
+    print length $a == 198 ? "ok 18\n" : "not ok 18\n";
+    $a = chr(256) x 999;
+    print length $a == 999 ? "ok 19\n" : "not ok 19\n";
+    substr($a, 0, 1) = '';
+    print length $a == 998 ? "ok 20\n" : "not ok 20\n";
+}
+
+curr_test(21);
+
+require Tie::Scalar;
+
+$u = "ASCII";
+
+tie $u, 'Tie::StdScalar', chr 256;
+
+is(length $u, 1, "Length of a UTF-8 scalar returned from tie");
+is(length $u, 1, "Again! Again!");
+
+$^W = 1;
+
+my $warnings = 0;
+
+$SIG{__WARN__} = sub {
+    $warnings++;
+    warn @_;
+};
+
+is(length(undef), undef, "Length of literal undef");
+
+my $u;
+
+is(length($u), undef, "Length of regular scalar");
+
+$u = "Gotcha!";
+
+tie $u, 'Tie::StdScalar';
+
+is(length($u), undef, "Length of tied scalar (MAGIC)");
+
+is($u, undef);
+
+{
+    package U;
+    use overload '""' => sub {return undef;};
+}
+
+my $uo = bless [], 'U';
+
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w = shift };
+    is(length($uo), 0, "Length of overloaded reference");
+    like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
+}
+
+my $ul = 3;
+is(($ul = length(undef)), undef, 
+                    "Returned length of undef with result in TARG");
+is($ul, undef, "Assigned length of undef with result in TARG");
+
+$ul = 3;
+is(($ul = length($u)), undef,
+                "Returned length of tied undef with result in TARG");
+is($ul, undef, "Assigned length of tied undef with result in TARG");
+
+$ul = 3;
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w = shift };
+    is(($ul = length($uo)), 0,
+                "Returned length of overloaded undef with result in TARG");
+    like $w, qr/uninitialized/, 'uninit warning for stringifying as undef';
+}    
+is($ul, 0, "Assigned length of overloaded undef with result in TARG");
+
+{
+    my $y = "\x{100}BC";
+    is(index($y, "B"), 1, 'adds an intermediate position to the offset cache');
+    is(length $y, 3,
+       'Check that sv_len_utf8() can take advantage of the offset cache');
+}
+
+{
+    local $SIG{__WARN__} = sub {
+        pass("'print length undef' warned");
+    };
+    print length undef;
+}
+
+{
+    local $SIG{__WARN__} = sub {
+       pass '[perl #106726] no crash with length @lexical warning'
+    };
+    eval ' sub { length my @forecasts } ';
+}
+
+# length could be fooled by UTF8ness of non-magical variables changing with
+# stringification.
+my $ref = [];
+bless $ref, "\x{100}";
+is length $ref, length "$ref", 'length on reference blessed to utf8 class';
+
+is($warnings, 0, "There were no other warnings");