&CORE::substr()

This commit makes &CORE::substr callable through references and via
&ampersand syntax.

It’s a bit awkward, as we need a substr op that is flagged as hav-
ing 4 arguments *and* possibly returning an lvalue.   The code in
op_lvalue_flags wasn’t really set up for that, so I needed to flag
the op with OPpMAYBE_LVSUB in coresub_op before it gets passed to
op_lvalue_flags.  It turned out that only that was necessary, as
op_lvalue_flags does an op_private == 4 check (rather than (op_private
& 7) == 4 or some such) when checking for the 4-arg case and croak-
ing.  When the op arrives in op_lvalue_flags, it’s already flagged
OPpMAYBE_LVSUB|4 which != 4.

pp_substr is also modified to check for nulls and, if necessary,
adjust its count of how many arguments were actually passed.)

diff --git a/gv.c b/gv.c
index 50ebea8..25548eb 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1360,7 +1360,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            case KEY_push:
            case KEY_setpgrp: case KEY_shift:
            case KEY_splice:
-           case KEY_stat: case KEY_substr:
+           case KEY_stat:
            case KEY_sysopen:
            case KEY_system:
            case KEY_tell: case KEY_tie: case KEY_tied:
@@ -1400,7 +1400,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                   new ATTRSUB. */
            (void)core_prototype((SV *)cv, name, code, &opnum);
            if (ampable) {
-               if (opnum == OP_VEC || opnum == OP_LOCK) CvLVALUE_on(cv);
+               if (opnum == OP_VEC || opnum == OP_LOCK
+                || opnum == OP_SUBSTR)
+                   CvLVALUE_on(cv);
                newATTRSUB(oldsavestack_ix,
                           newSVOP(
                                 OP_CONST, 0,

diff --git a/op.c b/op.c
index 6d781ba..50a6179 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10397,7 +10397,11 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
                argop->op_private |= OPpCOREARGS_DEREF2;
            if (scalar_mod_type(NULL, opnum))
                argop->op_private |= OPpCOREARGS_SCALARMOD;
-           goto onearg;
+           if (opnum == OP_SUBSTR) {
+               o->op_private |= OPpMAYBE_LVSUB;
+               return o;
+           }
+           else goto onearg;
        }
     }
 }

diff --git a/pp.c b/pp.c
index b761802..630dd12 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3039,19 +3039,23 @@ PP(pp_substr)
     SV *repl_sv = NULL;
     const char *repl = NULL;
     STRLEN repl_len;
-    const int num_args = PL_op->op_private & 7;
+    int num_args = PL_op->op_private & 7;
     bool repl_need_utf8_upgrade = FALSE;
     bool repl_is_utf8 = FALSE;
 
     if (num_args > 2) {
        if (num_args > 3) {
-           repl_sv = POPs;
+         if((repl_sv = POPs)) {
            repl = SvPV_const(repl_sv, repl_len);
            repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
+         }
+         else num_args--;
+       }
+       if ((len_sv = POPs)) {
+           len_iv    = SvIV(len_sv);
+           len_is_uv = SvIOK_UV(len_sv);
        }
-       len_sv    = POPs;
-       len_iv    = SvIV(len_sv);
-       len_is_uv = SvIOK_UV(len_sv);
+       else num_args--;
     }
     pos_sv     = POPs;
     pos1_iv    = SvIV(pos_sv);

diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index b9b946f..3347756 100644 (file)
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -670,6 +670,16 @@ $tests ++;
 &CORE::srand;
 pass '&srand with no args does not crash';
 
+test_proto 'substr';
+$tests += 5;
+$_ = "abc";
+is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr';
+is $_, 'adc', 'what 4-arg &substr does';
+is &mysubstr("abc", 1, 1), 'b', '3-arg &substr';
+is &mysubstr("abc", 1), 'bc', '2-arg &substr';
+&mysubstr($_, 1) = 'long';
+is $_, 'along', 'lvalue &substr';
+
 test_proto 'symlink';
 test_proto 'syscall';
 test_proto 'sysread';