diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | hv.c | 33 | ||||
| -rw-r--r-- | pod/perlintern.pod | 12 | ||||
| -rw-r--r-- | pp_ctl.c | 23 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | t/op/caller.t | 26 |
6 files changed, 95 insertions, 2 deletions
@@ -303,6 +303,8 @@ ApdR |SV* |hv_iterval |NN HV* tb|NN HE* entry Ap |void |hv_ksplit |NN HV* hv|IV newmax Apdbm |void |hv_magic |NN HV* hv|NULLOK GV* gv|int how #ifdef USE_ITHREADS +dpoM|struct refcounted_he *|refcounted_he_copy \ + |NULLOK const struct refcounted_he *he dpoM|struct refcounted_he *|refcounted_he_dup \ |NULLOK const struct refcounted_he *const he \ |NN CLONE_PARAMS* param @@ -2695,6 +2695,39 @@ Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he, copy->refcounted_he_refcnt = he->refcounted_he_refcnt; return copy; } + +/* +=for apidoc refcounted_he_copy + +Copies a chain of C<struct refcounted_he *>. Used by C<pp_entereval>. + +=cut +*/ + +struct refcounted_he * +Perl_refcounted_he_copy(pTHX_ const struct refcounted_he * he) +{ + struct refcounted_he *copy; + HEK *hek; + /* This is much easier to express recursively than iteratively. */ + if (!he) + return NULL; + + Newx(copy, 1, struct refcounted_he); + copy->refcounted_he_he.hent_next + = (HE *)Perl_refcounted_he_copy(aTHX_ + (struct refcounted_he *) + he->refcounted_he_he.hent_next); + copy->refcounted_he_he.he_valu.hent_val + = newSVsv(he->refcounted_he_he.he_valu.hent_val); + hek = he->refcounted_he_he.hent_hek; + copy->refcounted_he_he.hent_hek + = share_hek(HEK_KEY(hek), + HEK_UTF8(hek) ? -(I32)HEK_LEN(hek) : HEK_LEN(hek), + HEK_HASH(hek)); + copy->refcounted_he_refcnt = 1; + return copy; +} #endif /* diff --git a/pod/perlintern.pod b/pod/perlintern.pod index 6c82701995..77fced839b 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -485,6 +485,16 @@ in C<struct refcounted_he *>. =for hackers Found in file hv.c +=item refcounted_he_copy +X<refcounted_he_copy> + +Copies a chain of C<struct refcounted_he *>. Used by C<pp_entereval>. + + struct refcounted_he * refcounted_he_copy(const struct refcounted_he *he) + +=for hackers +Found in file hv.c + =item refcounted_he_dup X<refcounted_he_dup> @@ -515,7 +525,7 @@ to I<value>. As S<key> is copied into a shared hash key, all references remain the property of the caller. The C<struct refcounted_he> is returned with a reference count of 1. - struct refcounted_he * refcounted_he_new(struct refcounted_he *parent, SV *key, SV *value) + struct refcounted_he * refcounted_he_new(struct refcounted_he *const parent, SV *key, SV *value) =for hackers Found in file hv.c @@ -3476,6 +3476,29 @@ PP(pp_entereval) PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); SAVEFREESV(PL_compiling.cop_io); } + if (PL_compiling.cop_hints) { + PL_compiling.cop_hints->refcounted_he_refcnt--; + } + PL_compiling.cop_hints = PL_curcop->cop_hints; + if (PL_compiling.cop_hints) { +#ifdef USE_ITHREADS + /* PL_curcop could be pointing to an optree owned by another /.*parent/ + thread. We can't manipulate the reference count of the refcounted he + there (race condition) so we have to do something less than + pleasant to keep it read only. The simplest solution seems to be to + copy their chain. We might want to cache this. + Alternatively we could add a flag to the refcounted he *we* point to + here saying "I don't own a reference count on the thing I point to", + and arrange for Perl_refcounted_he_free() to spot that. If so, we'd + still need to copy the topmost refcounted he so that we could change + its flag. So still not trivial. (Flag bits could be hung from the + shared HEK) */ + PL_compiling.cop_hints + = Perl_refcounted_he_copy(aTHX_ PL_compiling.cop_hints); +#else + PL_compiling.cop_hints->refcounted_he_refcnt++; +#endif + } /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this * allows the debugger to execute code, find lexicals etc, in the @@ -721,6 +721,7 @@ PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV* hv, IV newmax) __attribute__nonnull__(pTHX_1); */ #ifdef USE_ITHREADS +PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_copy(pTHX_ const struct refcounted_he *he); PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he, CLONE_PARAMS* param) __attribute__nonnull__(pTHX_2); diff --git a/t/op/caller.t b/t/op/caller.t index 6e8bfdc05e..082f595380 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 56 ); + plan( tests => 64 ); } my @c; @@ -201,3 +201,27 @@ sub dooot { is(get_dooot(), 6 * 7); is(get_thikoosh(), "SKREECH"); } + +print "# which now works inside evals\n"; + +{ + BEGIN { + $^H{dooot} = 42; + } + is(get_dooot(), 6 * 7); + + eval "is(get_dooot(), 6 * 7); 1" or die $@; + + eval <<'EOE' or die $@; + is(get_dooot(), 6 * 7); + eval "is(get_dooot(), 6 * 7); 1" or die $@; + BEGIN { + $^H{dooot} = 54; + } + is(get_dooot(), 54); + eval "is(get_dooot(), 54); 1" or die $@; + eval 'BEGIN { $^H{dooot} = -1; }; 1' or die $@; + is(get_dooot(), 54); + eval "is(get_dooot(), 54); 1" or die $@; +EOE +} |