Propagate cop_hints inside string evals. For the unthreaded case this

is easy. For the threaded case it's not, because the current OP may
be shared with another thread, so solve this by copying the hints
chain.

p4raw-id: //depot/perl@27659

diff --git a/embed.fnc b/embed.fnc
index 1e3c562..af21a14 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -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

diff --git a/hv.c b/hv.c
index 8227eca..118439a 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -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 6c82701..77fced8 100644 (file)
--- 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

diff --git a/pp_ctl.c b/pp_ctl.c
index 72caef3..1fcbbac 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.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

diff --git a/proto.h b/proto.h
index 9a7ab7f..2be599e 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -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 6e8bfdc..082f595 100644 (file)
--- 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
+}