This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #77814] Make defelems propagate pos
authorFather Chrysostomos <sprout@cpan.org>
Tue, 16 Jul 2013 01:57:01 +0000 (18:57 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Tue, 16 Jul 2013 02:14:23 +0000 (19:14 -0700)
When elements of @_ refer to nonexistent hash or array elements, then
the magic scalar in $_[0] delegates all set/get actions to the element
in represents, vivifying it if needed.

pos($_[0]), however, was not delegating the value to the element, but
storing it on the magical â€˜deferred element’ scalar.

embed.fnc
embed.h
mg.c
pp.c
pp_ctl.c
pp_hot.c
proto.h
regexec.c
sv.c
t/op/pos.t

index af6119b..5cbcc08 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -842,6 +842,8 @@ Apd |int    |mg_copy        |NN SV *sv|NN SV *nsv|NULLOK const char *key \
 pd     |void   |mg_localize    |NN SV* sv|NN SV* nsv|bool setmagic
 ApdR   |MAGIC* |mg_find        |NULLOK const SV* sv|int type
 ApdR   |MAGIC* |mg_findext     |NULLOK const SV* sv|int type|NULLOK const MGVTBL *vtbl
+: exported for re.pm
+EpR    |MAGIC* |mg_find_mglob  |NN SV* sv
 Apd    |int    |mg_free        |NN SV* sv
 Apd    |void   |mg_free_type   |NN SV* sv|int how
 Apd    |int    |mg_get         |NN SV* sv
@@ -1360,6 +1362,8 @@ Apd       |void   |sv_magic       |NN SV *const sv|NULLOK SV *const obj|const int how \
 Apd    |MAGIC *|sv_magicext    |NN SV *const sv|NULLOK SV *const obj|const int how \
                                |NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \
                                |const I32 namlen
+: exported for re.pm
+Ep     |MAGIC *|sv_magicext_mglob|NN SV *sv
 ApdbamR        |SV*    |sv_mortalcopy  |NULLOK SV *const oldsv
 XpaR   |SV*    |sv_mortalcopy_flags|NULLOK SV *const oldsv|U32 flags
 ApdR   |SV*    |sv_newmortal
diff --git a/embed.h b/embed.h
index 528f0b0..1550817 100644 (file)
--- a/embed.h
+++ b/embed.h
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define av_reify(a)            Perl_av_reify(aTHX_ a)
 #define current_re_engine()    Perl_current_re_engine(aTHX)
+#define mg_find_mglob(a)       Perl_mg_find_mglob(aTHX_ a)
 #define op_clear(a)            Perl_op_clear(aTHX_ a)
 #define qerror(a)              Perl_qerror(aTHX_ a)
 #define reg_named_buff(a,b,c,d)        Perl_reg_named_buff(aTHX_ a,b,c,d)
 #define reg_temp_copy(a,b)     Perl_reg_temp_copy(aTHX_ a,b)
 #define regprop(a,b,c)         Perl_regprop(aTHX_ a,b,c)
 #define report_uninit(a)       Perl_report_uninit(aTHX_ a)
+#define sv_magicext_mglob(a)   Perl_sv_magicext_mglob(aTHX_ a)
 #define validate_proto(a,b,c)  Perl_validate_proto(aTHX_ a,b,c)
 #define vivify_defelem(a)      Perl_vivify_defelem(aTHX_ a)
 #define yylex()                        Perl_yylex(aTHX)
diff --git a/mg.c b/mg.c
index e56f53d..99169cc 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -436,6 +436,21 @@ Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
     return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
 }
 
+MAGIC *
+Perl_mg_find_mglob(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_MG_FIND_MGLOB;
+    if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+        /* This sv is only a delegate.  //g magic must be attached to
+           its target. */
+        vivify_defelem(sv);
+        sv = LvTARG(sv);
+    }
+    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
+        return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
+    return NULL;
+}
+
 /*
 =for apidoc mg_copy
 
@@ -2076,19 +2091,17 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
     SV* const lsv = LvTARG(sv);
+    MAGIC * const found = mg_find_mglob(lsv);
 
     PERL_ARGS_ASSERT_MAGIC_GETPOS;
     PERL_UNUSED_ARG(mg);
 
-    if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
-       MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
-       if (found && found->mg_len >= 0) {
+    if (found && found->mg_len >= 0) {
            I32 i = found->mg_len;
            if (DO_UTF8(lsv))
                sv_pos_b2u(lsv, &i);
            sv_setiv(sv, i);
            return 0;
-       }
     }
     SvOK_off(sv);
     return 0;
@@ -2108,19 +2121,11 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
     PERL_ARGS_ASSERT_MAGIC_SETPOS;
     PERL_UNUSED_ARG(mg);
 
-    if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
-       found = mg_find(lsv, PERL_MAGIC_regex_global);
-    else
-       found = NULL;
+    found = mg_find_mglob(lsv);
     if (!found) {
        if (!SvOK(sv))
            return 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
-    if (SvIsCOW(lsv))
-        sv_force_normal_flags(lsv, 0);
-#endif
-       found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
-                           NULL, 0);
+       found = sv_magicext_mglob(lsv);
     }
     else if (!SvOK(sv)) {
        found->mg_len = -1;
diff --git a/pp.c b/pp.c
index e7e06ff..1aaeefc 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -438,8 +438,7 @@ PP(pp_pos)
        RETURN;
     }
     else {
-       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
-           const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
+           const MAGIC * const mg = mg_find_mglob(sv);
            if (mg && mg->mg_len >= 0) {
                dTARGET;
                I32 i = mg->mg_len;
@@ -448,8 +447,7 @@ PP(pp_pos)
                PUSHi(i);
                RETURN;
            }
-       }
-       RETPUSHUNDEF;
+           RETPUSHUNDEF;
     }
 }
 
index d8f63b7..d611c4c 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -325,14 +325,8 @@ PP(pp_substcont)
        SV * const sv
            = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
        MAGIC *mg;
-       SvUPGRADE(sv, SVt_PVMG);
-       if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
-#ifdef PERL_OLD_COPY_ON_WRITE
-           if (SvIsCOW(sv))
-               sv_force_normal_flags(sv, 0);
-#endif
-           mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
-                            NULL, 0);
+       if (!(mg = mg_find_mglob(sv))) {
+           mg = sv_magicext_mglob(sv);
        }
        mg->mg_len = m - orig;
     }
index 084f4a2..914a9d7 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1390,10 +1390,9 @@ PP(pp_match)
 
     /* XXXX What part of this is needed with true \G-support? */
     if (global) {
+       MAGIC * const mg = mg_find_mglob(TARG);
        RX_OFFS(rx)[0].start = -1;
-       if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
-           MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
-           if (mg && mg->mg_len >= 0) {
+       if (mg && mg->mg_len >= 0) {
                if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
                    RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
                else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
@@ -1405,7 +1404,6 @@ PP(pp_match)
                    RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
                minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
                update_minmatch = 0;
-           }
        }
     }
 #ifdef PERL_SAWAMPERSAND
@@ -1491,16 +1489,9 @@ PP(pp_match)
        }
        if (global) {
            if (dynpm->op_pmflags & PMf_CONTINUE) {
-               MAGIC* mg = NULL;
-               if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
-                   mg = mg_find(TARG, PERL_MAGIC_regex_global);
+               MAGIC *mg = mg_find_mglob(TARG);
                if (!mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
-                   if (SvIsCOW(TARG))
-                       sv_force_normal_flags(TARG, 0);
-#endif
-                   mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
-                                    &PL_vtbl_mglob, NULL, 0);
+                   mg = sv_magicext_mglob(TARG);
                }
                if (RX_OFFS(rx)[0].start != -1) {
                    mg->mg_len = RX_OFFS(rx)[0].end;
@@ -1524,18 +1515,9 @@ PP(pp_match)
     }
     else {
        if (global) {
-           MAGIC* mg;
-           if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
-               mg = mg_find(TARG, PERL_MAGIC_regex_global);
-           else
-               mg = NULL;
+           MAGIC *mg = mg_find_mglob(TARG);
            if (!mg) {
-#ifdef PERL_OLD_COPY_ON_WRITE
-               if (SvIsCOW(TARG))
-                   sv_force_normal_flags(TARG, 0);
-#endif
-               mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
-                                &PL_vtbl_mglob, NULL, 0);
+               mg = sv_magicext_mglob(TARG);
            }
            if (RX_OFFS(rx)[0].start != -1) {
                mg->mg_len = RX_OFFS(rx)[0].end;
@@ -1631,11 +1613,9 @@ yup:                                     /* Confirmed by INTUIT */
 nope:
 ret_no:
     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
-       if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
-           MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
+           MAGIC* const mg = mg_find_mglob(TARG);
            if (mg)
                mg->mg_len = -1;
-       }
     }
     LEAVE_SCOPE(oldsave);
     if (gimme == G_ARRAY)
diff --git a/proto.h b/proto.h
index 63d1c9c..cbb8664 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2468,6 +2468,12 @@ PERL_CALLCONV int        Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 PERL_CALLCONV MAGIC*   Perl_mg_find(pTHX_ const SV* sv, int type)
                        __attribute__warn_unused_result__;
 
+PERL_CALLCONV MAGIC*   Perl_mg_find_mglob(pTHX_ SV* sv)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MG_FIND_MGLOB \
+       assert(sv)
+
 PERL_CALLCONV MAGIC*   Perl_mg_findext(pTHX_ const SV* sv, int type, const MGVTBL *vtbl)
                        __attribute__warn_unused_result__;
 
@@ -4115,6 +4121,11 @@ PERL_CALLCONV MAGIC *    Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const
 #define PERL_ARGS_ASSERT_SV_MAGICEXT   \
        assert(sv)
 
+PERL_CALLCONV MAGIC *  Perl_sv_magicext_mglob(pTHX_ SV *sv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB     \
+       assert(sv)
+
 /* PERL_CALLCONV SV*   Perl_sv_mortalcopy(pTHX_ SV *const oldsv)
                        __attribute__malloc__
                        __attribute__warn_unused_result__; */
index 6367e2e..3869d04 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2194,9 +2194,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
            reginfo->ganch = startpos + prog->gofs;
            DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
              "GPOS IGNOREPOS: reginfo->ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
-       } else if (sv && SvTYPE(sv) >= SVt_PVMG
-                 && SvMAGIC(sv)
-                 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
+       } else if (sv && (mg = mg_find_mglob(sv))
                  && mg->mg_len >= 0) {
            reginfo->ganch = strbeg + mg->mg_len;       /* Defined pos() */
            DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
@@ -7533,15 +7531,9 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo)
             DEFSV_set(reginfo->sv);
         }
 
-        if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
-              && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
+        if (!(mg = mg_find_mglob(reginfo->sv))) {
             /* prepare for quick setting of pos */
-#ifdef PERL_OLD_COPY_ON_WRITE
-            if (SvIsCOW(reginfo->sv))
-                sv_force_normal_flags(reginfo->sv, 0);
-#endif
-            mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
-                             &PL_vtbl_mglob, NULL, 0);
+            mg = sv_magicext_mglob(reginfo->sv);
             mg->mg_len = -1;
         }
         eval_state->pos_magic = mg;
diff --git a/sv.c b/sv.c
index 183b60b..e5f60a2 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5410,6 +5410,24 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
     return mg;
 }
 
+MAGIC *
+Perl_sv_magicext_mglob(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
+    if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+       /* This sv is only a delegate.  //g magic must be attached to
+          its target. */
+       vivify_defelem(sv);
+       sv = LvTARG(sv);
+    }
+#ifdef PERL_OLD_COPY_ON_WRITE
+    if (SvIsCOW(sv))
+       sv_force_normal_flags(sv, 0);
+#endif
+    return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
+                      &PL_vtbl_mglob, 0, 0);
+}
+
 /*
 =for apidoc sv_magic
 
index 4c50aa9..4eca3a6 100644 (file)
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 12;
+plan tests => 21;
 
 $x='banana';
 $x=~/.a/g;
@@ -63,3 +63,29 @@ is eval 'pos *a', 1, 'pos *glob works';
 pos($1) = 2;           # set pos; was ignoring UTF8-ness
 "$1";                  # turn on UTF8 flag
 is pos($1), 2, 'pos is not confused about changing UTF8-ness';
+
+sub {
+    $_[0] = "hello";
+    pos $_[0] = 3;
+    is pos $h{k}, 3, 'defelems can propagate pos assignment';
+    $_[0] =~ /./g;
+    is pos $h{k}, 4, 'defelems can propagate implicit pos (via //g)';
+    $_[0] =~ /oentuhoetn/g;
+    is pos $h{k}, undef, 'failed //g sets pos through defelem';
+    $_[1] = "hello";
+    pos $h{l} = 3;
+    is pos $_[1], 3, 'reading pos through a defelem';
+    pos $h{l} = 4;
+    $_[1] =~ /(.)/g;
+    is "$1", 'o', '//g can read pos through a defelem';
+    $_[2] = "hello";
+    () = $_[2] =~ /l/gc;
+    is pos $h{m}, 4, '//gc in list cx can set pos through a defelem';
+    $_[3] = "hello";
+    $_[3] =~
+        s<e><is pos($h{n}), 1, 's///g setting pos through a defelem'>egg;
+    $h{n} = 'hello';
+    $_[3] =~ /e(?{ is pos $h{n},2, 're-evals set pos through defelems' })/;
+    pos $h{n} = 1;
+    ok $_[3] =~ /\Ge/, '\G works with defelem scalars';
+}->($h{k}, $h{l}, $h{m}, $h{n});