RMG: fix typo, clarify instructions a bit

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

diff --git a/t/op/substr.t b/t/op/substr.t
index 2673fc7..eae2403 100644 (file)
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -4,7 +4,8 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
+    require './test.pl';
+    set_up_inc('../lib');
 }
 use warnings ;
 
@@ -21,9 +22,7 @@ $SIG{__WARN__} = sub {
      }
 };
 
-BEGIN { require './test.pl'; }
-
-plan(360);
+plan(388);
 
 run_tests() unless caller;
 
@@ -42,6 +41,8 @@ eval{substr($a,999,999) = "" ; };# P R Q S
 like ($@, $FATAL_MSG);
 is(substr($a,0,-6), 'abc');  # P=Q R S
 is(substr($a,-3,1), 'x');    # P Q R S
+sub{$b = shift}->(substr($a,999,999));
+is ($w--, 1, 'boundless lvalue substr only warns on fetch');
 
 substr($a,3,3) = 'XYZ';
 is($a, 'abcXYZxyz' );
@@ -635,6 +636,58 @@ is($x, "\x{100}\x{200}\xFFb");
        is($_, 'YYYY'); 
        is($x, 'aYYYYef');
     }
+    $x = "abcdef";
+    for (substr($x,1)) {
+       is($_, 'bcdef');
+       $_ = 'XX';
+       is($_, 'XX');
+       is($x, 'aXX');
+       $x .= "frompswiggle";
+       is $_, "XXfrompswiggle";
+    }
+    $x = "abcdef";
+    for (substr($x,1,-1)) {
+       is($_, 'bcde');
+       $_ = 'XX';
+       is($_, 'XX');
+       is($x, 'aXXf');
+       $x .= "frompswiggle";
+       is $_, "XXffrompswiggl";
+    }
+    $x = "abcdef";
+    for (substr($x,-5,3)) {
+       is($_, 'bcd');
+       $_ = 'XX';   # now $_ is substr($x, -4, 2)
+       is($_, 'XX');
+       is($x, 'aXXef');
+       $x .= "frompswiggle";
+       is $_, "gg";
+    }
+    $x = "abcdef";
+    for (substr($x,-5)) {
+       is($_, 'bcdef');
+       $_ = 'XX';  # now substr($x, -2)
+       is($_, 'XX');
+       is($x, 'aXX');
+       $x .= "frompswiggle";
+       is $_, "le";
+    }
+    $x = "abcdef";
+    for (substr($x,-5,-1)) {
+       is($_, 'bcde');
+       $_ = 'XX';  # now substr($x, -3, -1)
+       is($_, 'XX');
+       is($x, 'aXXf');
+       $x .= "frompswiggle";
+       is $_, "gl";
+    }
+}
+
+# Also part of perl #24346; scalar(substr...) should not affect lvalueness
+{
+    my $str = "abcdef";
+    sub { $_[0] = 'dea' }->( scalar substr $str, 3, 2 );
+    is $str, 'abcdeaf', 'scalar does not affect lvalueness of substr';
 }
 
 # [perl #24200] string corruption with lvalue sub
@@ -661,6 +714,7 @@ is($x, "\x{100}\x{200}\xFFb");
 # [perl #23765]
 {
     my $a = pack("C", 0xbf);
+    no warnings 'deprecated';
     substr($a, -1) &= chr(0xfeff);
     is($a, "\xbf");
 }
@@ -707,20 +761,6 @@ SKIP: {
     }
 }
 
-}
-
-
-my $destroyed;
-{ package Class; DESTROY { ++$destroyed; } }
-
-$destroyed = 0;
-{
-    my $x = '';
-    substr($x,0,1) = "";
-    $x = bless({}, 'Class');
-}
-is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
-
 # [perl #77692] UTF8 cache not being reset when TARG is reused
 ok eval {
  local ${^UTF8CACHE} = -1;
@@ -732,23 +772,6 @@ ok eval {
 }, 'UTF8 cache is reset when TARG is reused [perl #77692]';
 
 {
-    my $result_3363;
-    sub a_3363 {
-        my ($word, $replace) = @_;
-        my $ref = \substr($word, 0, 1);
-        $$ref = $replace;
-        if ($replace eq "b") {
-            $result_3363 = $word;
-        } else {
-            a_3363($word, "b");
-        }
-    }
-    a_3363($_, "v") for "test";
-
-    is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
-}
-
-{
     use utf8;
     use open qw( :utf8 :std );
     no warnings 'once';
@@ -770,3 +793,79 @@ ok eval {
     $y = \substr *foo, 0, 0;
     is ref \$x, 'REF', '\substr does not coerce its ref arg just yet';
 }
+
+# Test that UTF8-ness of magic var changing does not confuse substr lvalue
+# assignment.
+# We use overloading for our magic var, but a typeglob would work, too.
+package o {
+    use overload '""' => sub { ++our $count; $_[0][0] }
+}
+my $refee = bless ["\x{100}a"], o::;
+my $substr = \substr $refee, -2;       # UTF8 flag still off for $$substr.
+$$substr = "b";                                # UTF8 flag turns on when setsubstr
+is $refee, "b",                                # magic stringifies $$substr.
+     'substr lvalue assignment when stringification turns on UTF8ness';
+
+# Test that changing UTF8-ness does not confuse 4-arg substr.
+$refee = bless [], "\x{100}a";
+# stringify without returning on UTF8 flag on $refee:
+my $string = $refee; $string = "$string";
+substr $refee, 0, 0, "\xff";
+is $refee, "\xff$string",
+  '4-arg substr with target UTF8ness turning on when stringified';
+$refee = bless [], "\x{100}";
+() = "$refee"; # UTF8 flag now on
+bless $refee, "\xff";
+$string = $refee; $string = "$string";
+substr $refee, 0, 0, "\xff";
+is $refee, "\xff$string",
+  '4-arg substr with target UTF8ness turning off when stringified';
+
+# Overload count
+$refee = bless ["foo"], o::;
+$o::count = 0;
+substr $refee, 0, 0, "";
+is $o::count, 1, '4-arg substr calls overloading once on the target';
+$refee = bless ["\x{100}"], o::;
+() = "$refee"; # turn UTF8 flag on
+$o::count = 0;
+() = substr $refee, 0;
+is $o::count, 1, 'rvalue substr calls overloading once on utf8 target';
+$o::count = 0;
+$refee = "";
+${\substr $refee, 0} = bless ["\x{100}"], o::;
+is $o::count, 1, 'assigning utf8 overload to substr lvalue calls ovld 1ce';
+
+# [perl #7678] core dump with substr reference and localisation
+{$b="abcde"; local $k; *k=\substr($b, 2, 1);}
+
+} # sub run_tests - put tests above this line that can run in threads
+
+
+my $destroyed;
+{ package Class; DESTROY { ++$destroyed; } }
+
+$destroyed = 0;
+{
+    my $x = '';
+    substr($x,0,1) = "";
+    $x = bless({}, 'Class');
+}
+is($destroyed, 1, 'Timely scalar destruction with lvalue substr');
+
+{
+    my $result_3363;
+    sub a_3363 {
+        my ($word, $replace) = @_;
+        my $ref = \substr($word, 0, 1);
+        $$ref = $replace;
+        if ($replace eq "b") {
+            $result_3363 = $word;
+        } else {
+            a_3363($word, "b");
+        }
+    }
+    a_3363($_, "v") for "test";
+
+    is($result_3363, "best", "ref-to-substr retains lvalue-ness under recursion [perl #3363]");
+}