Re: [PATCH] 4-arg substr update for perl5.004_68

	Message-ID: <m3iulpubis.fsf@furu.g.aas.no>

p4raw-id: //depot/perl@1242

diff --git a/op.c b/op.c
index 530c29d..6d3a6d3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -782,6 +782,10 @@ scalarvoid(OP *o)
     case OP_REPEAT:
        if (o->op_flags & OPf_STACKED)
            break;
+       goto func_ops;
+    case OP_SUBSTR:
+       if (o->op_private == 4)
+           break;
        /* FALL THROUGH */
     case OP_GVSV:
     case OP_WANTARRAY:
@@ -798,7 +802,6 @@ scalarvoid(OP *o)
     case OP_HEX:
     case OP_OCT:
     case OP_LENGTH:
-    case OP_SUBSTR:
     case OP_VEC:
     case OP_INDEX:
     case OP_RINDEX:
@@ -851,6 +854,7 @@ scalarvoid(OP *o)
     case OP_GGRNAM:
     case OP_GGRGID:
     case OP_GETLOGIN:
+      func_ops:
        if (!(o->op_private & OPpLVAL_INTRO))
            useless = op_desc[o->op_type];
        break;
@@ -1206,10 +1210,14 @@ mod(OP *o, I32 type)
     case OP_KEYS:
        if (type != OP_SASSIGN)
            goto nomod;
+       goto lvalue_func;
+    case OP_SUBSTR:
+       if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
+           goto nomod;
        /* FALL THROUGH */
     case OP_POS:
     case OP_VEC:
-    case OP_SUBSTR:
+      lvalue_func:
        pad_free(o->op_targ);
        o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
        assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 089bd48..03e2b9d 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3713,8 +3713,6 @@ using sprintf().
 An alternative to using substr() as an lvalue is to specify the
 replacement string as the 4th argument.  This allows you to replace
 parts of the EXPR and return what was there before in one operation.
-In this case LEN can be C<undef> if you want to affect everything to
-the end of the string.
 
 =item symlink OLDFILE,NEWFILE
 

diff --git a/pp.c b/pp.c
index 6cc98fd..3d7638e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1795,7 +1795,6 @@ PP(pp_substr)
     djSP; dTARGET;
     SV *sv;
     I32 len;
-    I32 len_ok = 0;
     STRLEN curlen;
     I32 pos;
     I32 rem;
@@ -1807,21 +1806,13 @@ PP(pp_substr)
     STRLEN repl_len;
 
     SvTAINTED_off(TARG);                       /* decontaminate */
-    if (MAXARG > 3) {
-       /* pop off replacement string */
-       sv = POPs;
-       repl = SvPV(sv, repl_len);
-       /* pop off length */
-       sv = POPs;
-       if (SvOK(sv)) {
-           len = SvIV(sv);
-           len_ok++;
+    if (MAXARG > 2) {
+       if (MAXARG > 3) {
+           sv = POPs;
+           repl = SvPV(sv, repl_len);
        }
-    } else if (MAXARG == 3) {
        len = POPi;
-       len_ok++;
-    }  
-
+    }
     pos = POPi;
     sv = POPs;
     PUTBACK;
@@ -1830,34 +1821,34 @@ PP(pp_substr)
        pos -= arybase;
        rem = curlen-pos;
        fail = rem;
-        if (len_ok) {
-            if (len < 0) {
-               rem += len;
-                if (rem < 0)
-                    rem = 0;
-            }
-            else if (rem > len)
-                     rem = len;
-        }
+       if (MAXARG > 2) {
+           if (len < 0) {
+               rem += len;
+               if (rem < 0)
+                   rem = 0;
+           }
+           else if (rem > len)
+                    rem = len;
+       }
     }
     else {
-        pos += curlen;
-        if (!len_ok)
-            rem = curlen;
-        else if (len >= 0) {
-            rem = pos+len;
-            if (rem > (I32)curlen)
-                rem = curlen;
-        }
-        else {
-            rem = curlen+len;
-            if (rem < pos)
-                rem = pos;
-        }
-        if (pos < 0)
-            pos = 0;
-        fail = rem;
-        rem -= pos;
+       pos += curlen;
+       if (MAXARG < 3)
+           rem = curlen;
+       else if (len >= 0) {
+           rem = pos+len;
+           if (rem > (I32)curlen)
+               rem = curlen;
+       }
+       else {
+           rem = curlen+len;
+           if (rem < pos)
+               rem = pos;
+       }
+       if (pos < 0)
+           pos = 0;
+       fail = rem;
+       rem -= pos;
     }
     if (fail < 0) {
        if (dowarn || lvalue || repl)
@@ -1894,7 +1885,7 @@ PP(pp_substr)
            LvTARGOFF(TARG) = pos;
            LvTARGLEN(TARG) = rem;
        }
-        else if (repl)
+       else if (repl)
            sv_insert(sv, pos, rem, repl, repl_len);
     }
     SPAGAIN;

diff --git a/t/op/substr.t b/t/op/substr.t
index 967016a..87efcb4 100755 (executable)
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..100\n";
+print "1..106\n";
 
 #P = start of string  Q = start of substr  R = end of substr  S = end of string
 
@@ -12,8 +12,10 @@ $SIG{__WARN__} = sub {
           $w++;
      } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) {
           $w += 2;
+     } elsif ($_[0] =~ /^Use of uninitialized value/) {
+          $w += 3;
      } else {
-          warn @_;
+          warn $_[0];
      }
 };
 
@@ -177,12 +179,33 @@ for (0,1) {
 # check no spurious warnings
 print $w ? "not ok 97\n" : "ok 97\n";
 
-# check new replacement syntax
+# check new 4 arg replacement syntax
 $a = "abcxyz";
+$w = 0;
 print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz";
 print "ok 98\n";
 print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz";
 print "ok 99\n";
-print "not " unless substr($a, 3, undef, "") eq "xyz" && $a eq "abc";
+print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz";
 print "ok 100\n";
 
+print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz"
+                 && $w == 3;
+print "ok 101\n";
+$w = 0;
+
+print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc";
+print "ok 102\n";
+print "not " unless fail(substr($a, -99, 0, ""));
+print "ok 103\n";
+print "not " unless fail(substr($a, 99, 3, ""));
+print "ok 104\n";
+
+substr($a, 0, length($a), "foo");
+print "not " unless $a eq "foo" && !$w;
+print "ok 105\n";
+
+# using 4 arg substr as lvalue is a compile time error
+eval 'substr($a,0,0,"") = "abc"';
+print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo";
+print "ok 106\n";