This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Serialise changes to %^H onto the current COP. Return the compile time
authorNicholas Clark <nick@ccl4.org>
Fri, 31 Mar 2006 13:45:57 +0000 (13:45 +0000)
committerNicholas Clark <nick@ccl4.org>
Fri, 31 Mar 2006 13:45:57 +0000 (13:45 +0000)
state of %^H as an eleventh value from caller. This allows users to
write pragmas.

p4raw-id: //depot/perl@27643

20 files changed:
cop.h
dump.c
embed.fnc
embed.h
gv.c
hv.c
hv.h
makedef.pl
mg.c
op.c
perl.c
perl.h
pod/perlfunc.pod
pod/perlintern.pod
pp_ctl.c
proto.h
scope.c
scope.h
sv.c
t/op/caller.t

diff --git a/cop.h b/cop.h
index 81712fa..8ce6b3e 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -148,6 +148,9 @@ struct cop {
     line_t      cop_line;       /* line # of this command */
     SV *       cop_warnings;   /* lexical warnings bitmask */
     SV *       cop_io;         /* lexical IO defaults */
+    /* compile time state of %^H.  See the comment in op.c for how this is
+       used to recreate a hash to return from caller.  */
+    struct refcounted_he * cop_hints;
 };
 
 #ifdef USE_ITHREADS
@@ -805,3 +808,13 @@ See L<perlcall/Lightweight Callbacks>.
        CATCH_SET(multicall_oldcatch);                                  \
        LEAVE;                                                          \
     } STMT_END
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/dump.c b/dump.c
index c86d3e5..c8406a1 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -959,6 +959,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
        { PERL_MAGIC_bm,             "bm(B)" },
        { PERL_MAGIC_regdata,        "regdata(D)" },
        { PERL_MAGIC_env,            "env(E)" },
+       { PERL_MAGIC_hints,          "hints(H)" },
        { PERL_MAGIC_isa,            "isa(I)" },
        { PERL_MAGIC_dbfile,         "dbfile(L)" },
        { PERL_MAGIC_shared,         "shared(N)" },
@@ -971,6 +972,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
        { PERL_MAGIC_envelem,        "envelem(e)" },
        { PERL_MAGIC_fm,             "fm(f)" },
        { PERL_MAGIC_regex_global,   "regex_global(g)" },
+       { PERL_MAGIC_hintselem,      "hintselem(h)" },
        { PERL_MAGIC_isaelem,        "isaelem(i)" },
        { PERL_MAGIC_nkeys,          "nkeys(k)" },
        { PERL_MAGIC_dbline,         "dbline(l)" },
@@ -1030,6 +1032,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
            else if (v == &PL_vtbl_backref)    s = "backref";
            else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
+            else if (v == &PL_vtbl_hintselem)  s = "hintselem";
            if (s)
                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
            else
index 0fdbf20..dfd3d5a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -302,6 +302,16 @@ ApMdR      |HE*    |hv_iternext_flags|NN HV* tb|I32 flags
 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_dup \
+                               |NULLOK const struct refcounted_he *const he \
+                               |NN CLONE_PARAMS* param
+#endif
+dpoM   |HV *   |refcounted_he_chain_2hv|NULLOK const struct refcounted_he *c
+dpoM   |void   |refcounted_he_free|NULLOK struct refcounted_he *he
+dpoM   |struct refcounted_he *|refcounted_he_new \
+                               |NULLOK struct refcounted_he *parent \
+                               |NULLOK SV *key|NULLOK SV *value
 Apd    |SV**   |hv_store       |NULLOK HV* tb|NULLOK const char* key|I32 klen|NULLOK SV* val \
                                |U32 hash
 Apd    |HE*    |hv_store_ent   |NULLOK HV* tb|NULLOK SV* key|NULLOK SV* val|U32 hash
@@ -401,6 +411,7 @@ ApdR        |bool   |grok_numeric_radix|NN const char **sp|NN const char *send
 Apd    |UV     |grok_oct       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
 p      |int    |magic_clearenv |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clear_all_env|NN SV* sv|NN MAGIC* mg
+dp     |int    |magic_clearhint|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clearpack|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clearsig |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_existspack|NN SV* sv|NN MAGIC* mg
@@ -431,6 +442,7 @@ p   |int    |magic_setdbline|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setdefelem|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setenv   |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setfm    |NN SV* sv|NN MAGIC* mg
+dp     |int    |magic_sethint  |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setisa   |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setglob  |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setmglob |NN SV* sv|NN MAGIC* mg
@@ -1075,6 +1087,7 @@ sM        |SV*    |hv_delete_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key
                |STRLEN klen|int k_flags|I32 d_flags|U32 hash
 sM     |HE*    |hv_fetch_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key \
                |STRLEN klen|int flags|int action|NULLOK SV* val|U32 hash
+sM     |void   |clear_placeholders     |NN HV* hb|U32 items
 #endif
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 53d6043..b8c279f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define hv_iternext_flags      Perl_hv_iternext_flags
 #define hv_iterval             Perl_hv_iterval
 #define hv_ksplit              Perl_hv_ksplit
+#ifdef USE_ITHREADS
+#endif
 #define hv_store               Perl_hv_store
 #define hv_store_ent           Perl_hv_store_ent
 #define hv_store_flags         Perl_hv_store_flags
 #ifdef PERL_CORE
 #define magic_clearenv         Perl_magic_clearenv
 #define magic_clear_all_env    Perl_magic_clear_all_env
+#define magic_clearhint                Perl_magic_clearhint
 #define magic_clearpack                Perl_magic_clearpack
 #define magic_clearsig         Perl_magic_clearsig
 #define magic_existspack       Perl_magic_existspack
 #define magic_setdefelem       Perl_magic_setdefelem
 #define magic_setenv           Perl_magic_setenv
 #define magic_setfm            Perl_magic_setfm
+#define magic_sethint          Perl_magic_sethint
 #define magic_setisa           Perl_magic_setisa
 #define magic_setglob          Perl_magic_setglob
 #define magic_setmglob         Perl_magic_setmglob
 #define hv_auxinit             S_hv_auxinit
 #define hv_delete_common       S_hv_delete_common
 #define hv_fetch_common                S_hv_fetch_common
+#define clear_placeholders     S_clear_placeholders
 #endif
 #endif
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
 #define hv_iternext_flags(a,b) Perl_hv_iternext_flags(aTHX_ a,b)
 #define hv_iterval(a,b)                Perl_hv_iterval(aTHX_ a,b)
 #define hv_ksplit(a,b)         Perl_hv_ksplit(aTHX_ a,b)
+#ifdef USE_ITHREADS
+#ifdef PERL_CORE
+#endif
+#endif
+#ifdef PERL_CORE
+#endif
 #define hv_store(a,b,c,d,e)    Perl_hv_store(aTHX_ a,b,c,d,e)
 #define hv_store_ent(a,b,c,d)  Perl_hv_store_ent(aTHX_ a,b,c,d)
 #define hv_store_flags(a,b,c,d,e,f)    Perl_hv_store_flags(aTHX_ a,b,c,d,e,f)
 #ifdef PERL_CORE
 #define magic_clearenv(a,b)    Perl_magic_clearenv(aTHX_ a,b)
 #define magic_clear_all_env(a,b)       Perl_magic_clear_all_env(aTHX_ a,b)
+#define magic_clearhint(a,b)   Perl_magic_clearhint(aTHX_ a,b)
 #define magic_clearpack(a,b)   Perl_magic_clearpack(aTHX_ a,b)
 #define magic_clearsig(a,b)    Perl_magic_clearsig(aTHX_ a,b)
 #define magic_existspack(a,b)  Perl_magic_existspack(aTHX_ a,b)
 #define magic_setdefelem(a,b)  Perl_magic_setdefelem(aTHX_ a,b)
 #define magic_setenv(a,b)      Perl_magic_setenv(aTHX_ a,b)
 #define magic_setfm(a,b)       Perl_magic_setfm(aTHX_ a,b)
+#define magic_sethint(a,b)     Perl_magic_sethint(aTHX_ a,b)
 #define magic_setisa(a,b)      Perl_magic_setisa(aTHX_ a,b)
 #define magic_setglob(a,b)     Perl_magic_setglob(aTHX_ a,b)
 #define magic_setmglob(a,b)    Perl_magic_setmglob(aTHX_ a,b)
 #define hv_auxinit             S_hv_auxinit
 #define hv_delete_common(a,b,c,d,e,f,g)        S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
 #define hv_fetch_common(a,b,c,d,e,f,g,h)       S_hv_fetch_common(aTHX_ a,b,c,d,e,f,g,h)
+#define clear_placeholders(a,b)        S_clear_placeholders(aTHX_ a,b)
 #endif
 #endif
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/gv.c b/gv.c
index 090d667..83f3ed8 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1156,6 +1156,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
            goto magicalize;
 
+       case '\010':    /* $^H */
+           {
+               HV *const hv = GvHVn(gv);
+               hv_magic(hv, NULL, PERL_MAGIC_hints);
+           }
+           goto magicalize;
+
        case '+':
        {
            AV* const av = GvAVn(gv);
@@ -1194,7 +1201,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        case '\004':    /* $^D */
        case '\005':    /* $^E */
        case '\006':    /* $^F */
-       case '\010':    /* $^H */
        case '\011':    /* $^I, NOT \t in EBCDIC */
        case '\016':    /* $^N */
        case '\017':    /* $^O */
diff --git a/hv.c b/hv.c
index fab0e6a..8227eca 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1606,7 +1606,16 @@ void
 Perl_hv_clear_placeholders(pTHX_ HV *hv)
 {
     dVAR;
-    I32 items = (I32)HvPLACEHOLDERS_get(hv);
+    const U32 items = (U32)HvPLACEHOLDERS_get(hv);
+
+    if (items)
+       clear_placeholders(hv, items);
+}
+
+static void
+S_clear_placeholders(pTHX_ HV *hv, U32 items)
+{
+    dVAR;
     I32 i;
 
     if (items == 0)
@@ -2515,6 +2524,180 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
 }
 
 /*
+=for apidoc refcounted_he_chain_2hv
+
+Generates an returns a C<HV *> by walking up the tree starting at the passed
+in C<struct refcounted_he *>.
+
+=cut
+*/
+HV *
+Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
+{
+    HV *hv = newHV();
+    U32 placeholders = 0;
+    /* We could chase the chain once to get an idea of the number of keys,
+       and call ksplit.  But for now we'll make a potentially inefficient
+       hash with only 8 entries in its array.  */
+    const U32 max = HvMAX(hv);
+
+    if (!HvARRAY(hv)) {
+       char *array;
+       Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
+       HvARRAY(hv) = (HE**)array;
+    }
+
+    while (chain) {
+       const U32 hash = HEK_HASH(chain->refcounted_he_he.hent_hek);
+       HE **oentry = &((HvARRAY(hv))[hash & max]);
+       HE *entry = *oentry;
+
+       for (; entry; entry = HeNEXT(entry)) {
+           if (HeHASH(entry) == hash) {
+               goto next_please;
+           }
+       }
+       assert (!entry);
+       entry = new_HE();
+
+       HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_he.hent_hek);
+
+       HeVAL(entry) = chain->refcounted_he_he.he_valu.hent_val;
+       if (HeVAL(entry) == &PL_sv_placeholder)
+           placeholders++;
+       SvREFCNT_inc_void_NN(HeVAL(entry));
+
+       /* Link it into the chain.  */
+       HeNEXT(entry) = *oentry;
+       if (!HeNEXT(entry)) {
+           /* initial entry.   */
+           HvFILL(hv)++;
+       }
+       *oentry = entry;
+
+       HvTOTALKEYS(hv)++;
+
+    next_please:
+       chain = (struct refcounted_he *) chain->refcounted_he_he.hent_next;
+    }
+
+    if (placeholders) {
+       clear_placeholders(hv, placeholders);
+       HvTOTALKEYS(hv) -= placeholders;
+    }
+
+    /* We could check in the loop to see if we encounter any keys with key
+       flags, but it's probably not worth it, as this per-hash flag is only
+       really meant as an optimisation for things like Storable.  */
+    HvHASKFLAGS_on(hv);
+#ifdef DEBUGGING
+    Perl_hv_assert(aTHX_ hv);
+#endif
+
+    return hv;
+}
+
+/*
+=for apidoc refcounted_he_new
+
+Creates a new C<struct refcounted_he>. Assumes ownership of one reference
+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.
+
+=cut
+*/
+
+struct refcounted_he *
+Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
+                      SV *const key, SV *const value) {
+    struct refcounted_he *he;
+    U32 hash;
+    STRLEN len;
+    const char *p = SvPV_const(key, len);
+
+    PERL_HASH(hash, p, len);
+
+    Newx(he, 1, struct refcounted_he);
+
+    he->refcounted_he_he.hent_next = (HE *)parent;
+    he->refcounted_he_he.he_valu.hent_val = value;
+    he->refcounted_he_he.hent_hek
+       = share_hek(p, SvUTF8(key) ? -(I32)len : len, hash);
+    he->refcounted_he_refcnt = 1;
+
+    return he;
+}
+
+/*
+=for apidoc refcounted_he_free
+
+Decrements the reference count of the passed in C<struct refcounted_he *>
+by one. If the reference count reaches zero the structure's memory is freed,
+and C<refcounted_he_free> iterates onto the parent node.
+
+=cut
+*/
+
+void
+Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+    while (he) {
+       struct refcounted_he *copy;
+
+       if (--he->refcounted_he_refcnt)
+           return;
+
+       unshare_hek_or_pvn (he->refcounted_he_he.hent_hek, 0, 0, 0);
+       SvREFCNT_dec(he->refcounted_he_he.he_valu.hent_val);
+       copy = he;
+       he = (struct refcounted_he *) he->refcounted_he_he.hent_next;
+       Safefree(copy);
+    }
+}
+
+
+/*
+=for apidoc refcounted_he_dup
+
+Duplicates the C<struct refcounted_he *> for a new thread.
+
+=cut
+*/
+
+#if defined(USE_ITHREADS)
+struct refcounted_he *
+Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he,
+                       CLONE_PARAMS* param)
+{
+    struct refcounted_he *copy;
+
+    if (!he)
+       return NULL;
+
+    /* look for it in the table first */
+    copy = (struct refcounted_he *)ptr_table_fetch(PL_ptr_table, he);
+    if (copy)
+       return copy;
+
+    /* create anew and remember what it is */
+    Newx(copy, 1, struct refcounted_he);
+    ptr_table_store(PL_ptr_table, he, copy);
+
+    copy->refcounted_he_he.hent_next
+       = (HE *)Perl_refcounted_he_dup(aTHX_
+                                      (struct refcounted_he *)
+                                      he->refcounted_he_he.hent_next,
+                                      param);
+    copy->refcounted_he_he.he_valu.hent_val
+       = SvREFCNT_inc(sv_dup(he->refcounted_he_he.he_valu.hent_val, param));
+    copy->refcounted_he_he.hent_hek
+       = hek_dup(he->refcounted_he_he.hent_hek, param);
+    copy->refcounted_he_refcnt = he->refcounted_he_refcnt;
+    return copy;
+}
+#endif
+
+/*
 =for apidoc hv_assert
 
 Check that a hash is in an internally consistent state.
diff --git a/hv.h b/hv.h
index efba2b9..dfb0d25 100644 (file)
--- a/hv.h
+++ b/hv.h
@@ -36,6 +36,11 @@ struct shared_he {
     struct hek shared_he_hek;
 };
 
+struct refcounted_he {
+    struct he refcounted_he_he;
+    U32 refcounted_he_refcnt;
+};
+
 /* Subject to change.
    Don't access this directly.
 */
index 3745e19..f203601 100644 (file)
@@ -747,6 +747,7 @@ unless ($define{'USE_ITHREADS'}) {
                    Perl_sharedsv_thrcnt_inc
                    Perl_sharedsv_unlock
                    Perl_stashpv_hvname_match
+                   Perl_refcounted_he_dup
                    )];
 }
 
diff --git a/mg.c b/mg.c
index 210d681..b7e2e56 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2838,6 +2838,46 @@ S_unwind_handler_stack(pTHX_ const void *p)
 }
 
 /*
+=for apidoc magic_sethint
+
+Triggered by a store to %^H, records the key/value pair to
+C<PL_compiling.cop_hints>.  It is assumed that hints aren't storing anything
+that would need a deep copy.  Maybe we should warn if we find a reference.
+
+=cut
+*/
+int
+Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+    assert(mg->mg_len == HEf_SVKEY);
+
+    PL_compiling.cop_hints
+       = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
+                                (SV *)mg->mg_ptr, newSVsv(sv));
+    return 0;
+}
+
+/*
+=for apidoc magic_sethint
+
+Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
+
+=cut
+*/
+int
+Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+    assert(mg->mg_len == HEf_SVKEY);
+
+    PL_compiling.cop_hints
+       = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
+                                (SV *)mg->mg_ptr, &PL_sv_placeholder);
+    return 0;
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
diff --git a/op.c b/op.c
index 5187f3b..bc49fb5 100644 (file)
--- a/op.c
+++ b/op.c
@@ -73,6 +73,28 @@ into peep() to do that code's portion of the 3rd pass.  It has to be
 recursive, but it's recursive on basic blocks, not on tree nodes.
 */
 
+/* To implement user lexical pragams, there needs to be a way at run time to
+   get the compile time state of %^H for that block.  Storing %^H in every
+   block (or even COP) would be very expensive, so a different approach is
+   taken.  The (running) state of %^H is serialised into a tree of HE-like
+   structs.  Stores into %^H are chained onto the current leaf as a struct
+   refcounted_he * with the key and the value.  Deletes from %^H are saved
+   with a value of PL_sv_placeholder.  The state of %^H at any point can be
+   turned back into a regular HV by walking back up the tree from that point's
+   leaf, ignoring any key you've already seen (placeholder or now), storing
+   the rest into the HV structure, then removing the placeholders. Hence
+   memory is only used to store the %^H deltas from the enclosing COP, rather
+   than the entire %^H on each COP.
+
+   To cause actions on %^H to write out the serialisation records, it has
+   magic type 'H'. This magic (itself) does nothing, but its presence causes
+   the values to gain magic type 'h', which has entries for set and clear.
+   C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
+   record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+   saves the current C<PL_compiling.cop_hints> on the save stack, so that it
+   will be correctly restored when any inner compiling scope is exited.
+*/
+
 #include "EXTERN.h"
 #define PERL_IN_OP_C
 #include "perl.h"
@@ -492,6 +514,7 @@ S_cop_free(pTHX_ COP* cop)
        SvREFCNT_dec(cop->cop_io);
 #endif
     }
+    Perl_refcounted_he_free(aTHX_ cop->cop_hints);
 }
 
 void
@@ -3928,7 +3951,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
         cop->cop_io = PL_curcop->cop_io;
     else
         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-
+    cop->cop_hints = PL_curcop->cop_hints;
+    if (cop->cop_hints) {
+       cop->cop_hints->refcounted_he_refcnt++;
+    }
 
     if (PL_copline == NOLINE)
         CopLINE_set(cop, CopLINE(PL_curcop));
diff --git a/perl.c b/perl.c
index 2b4d1b2..15fc64b 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1039,6 +1039,8 @@ perl_destruct(pTHXx)
     if (!specialCopIO(PL_compiling.cop_io))
        SvREFCNT_dec(PL_compiling.cop_io);
     PL_compiling.cop_io = NULL;
+    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
+    PL_compiling.cop_hints = NULL;
     CopFILE_free(&PL_compiling);
     CopSTASH_free(&PL_compiling);
 
diff --git a/perl.h b/perl.h
index 27d01ed..1e83f50 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3105,9 +3105,9 @@ struct nexttoken {
 #include "cv.h"
 #include "opnames.h"
 #include "op.h"
+#include "hv.h"
 #include "cop.h"
 #include "av.h"
-#include "hv.h"
 #include "mg.h"
 #include "scope.h"
 #include "warnings.h"
@@ -3509,6 +3509,8 @@ Gid_t getegid (void);
 #define PERL_MAGIC_envelem       'e' /* %ENV hash element */
 #define PERL_MAGIC_fm            'f' /* Formline ('compiled' format) */
 #define PERL_MAGIC_regex_global          'g' /* m//g target / study()ed string */
+#define PERL_MAGIC_hints         'H' /* %^H hash */
+#define PERL_MAGIC_hintselem     'h' /* %^H hash element */
 #define PERL_MAGIC_isa           'I' /* @ISA array */
 #define PERL_MAGIC_isaelem       'i' /* @ISA array element */
 #define PERL_MAGIC_nkeys         'k' /* scalar(keys()) lvalue */
@@ -4161,7 +4163,8 @@ enum {            /* pass one of these to get_vtbl */
     want_vtbl_backref,
     want_vtbl_utf8,
     want_vtbl_symtab,
-    want_vtbl_arylen_p
+    want_vtbl_arylen_p,
+    want_vtbl_hintselem
 };
 
                                /* Note: the lowest 8 bits are reserved for
@@ -4441,6 +4444,7 @@ MGVTBL_SET(
     NULL
 );
 
+/* For now, hints magic will also use vtbl_sig, because it is all NULL  */
 MGVTBL_SET(
     PL_vtbl_sig,
     NULL,
@@ -4793,6 +4797,18 @@ MGVTBL_SET(
 );
 #endif
 
+MGVTBL_SET(
+    PL_vtbl_hintselem,
+    NULL,
+    MEMBER_TO_FPTR(Perl_magic_sethint),
+    NULL,
+    MEMBER_TO_FPTR(Perl_magic_clearhint),
+    NULL,
+    NULL,
+    NULL,
+    NULL
+);
+
 
 enum {
   fallback_amg,        abs_amg,
index e9e22fa..d638cc1 100644 (file)
@@ -623,7 +623,8 @@ print a stack trace.  The value of EXPR indicates how many call frames
 to go back before the current one.
 
     ($package, $filename, $line, $subroutine, $hasargs,
-    $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i);
+    $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
+        = caller($i);
 
 Here $subroutine may be C<(eval)> if the frame is not a subroutine
 call, but an C<eval>.  In such a case additional elements $evaltext and
@@ -639,6 +640,10 @@ C<$hints> and C<$bitmask> contain pragmatic hints that the caller was
 compiled with.  The C<$hints> and C<$bitmask> values are subject to change
 between versions of Perl, and are not meant for external use.
 
+C<$hinthash> is a reference to a hash containing the value of C<%^H> when the
+caller was compiled, or C<undef> if C<%^H> was empty. Do not modify the values
+of this hash, as they are the actual values stored in the optree.
+
 Furthermore, when called from within the DB package, caller returns more
 detailed information: it sets the list variable C<@DB::args> to be the
 arguments with which the subroutine was invoked.
index 2cc6868..6c82701 100644 (file)
@@ -470,6 +470,59 @@ Found in file gv.c
 
 =back
 
+=head1 Hash Manipulation Functions
+
+=over 8
+
+=item refcounted_he_chain_2hv
+X<refcounted_he_chain_2hv>
+
+Generates an returns a C<HV *> by walking up the tree starting at the passed
+in C<struct refcounted_he *>.
+
+       HV *    refcounted_he_chain_2hv(const struct refcounted_he *c)
+
+=for hackers
+Found in file hv.c
+
+=item refcounted_he_dup
+X<refcounted_he_dup>
+
+Duplicates the C<struct refcounted_he *> for a new thread.
+
+       struct refcounted_he *  refcounted_he_dup(const struct refcounted_he *const he, CLONE_PARAMS* param)
+
+=for hackers
+Found in file hv.c
+
+=item refcounted_he_free
+X<refcounted_he_free>
+
+Decrements the reference count of the passed in C<struct refcounted_he *>
+by one. If the reference count reaches zero the structure's memory is freed,
+and C<refcounted_he_free> iterates onto the parent node.
+
+       void    refcounted_he_free(struct refcounted_he *he)
+
+=for hackers
+Found in file hv.c
+
+=item refcounted_he_new
+X<refcounted_he_new>
+
+Creates a new C<struct refcounted_he>. Assumes ownership of one reference
+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)
+
+=for hackers
+Found in file hv.c
+
+
+=back
+
 =head1 IO Functions
 
 =over 8
@@ -494,6 +547,16 @@ Found in file doio.c
 
 =over 8
 
+=item magic_sethint
+X<magic_sethint>
+
+Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
+
+       int     magic_sethint(SV* sv, MAGIC* mg)
+
+=for hackers
+Found in file mg.c
+
 =item mg_localize
 X<mg_localize>
 
index 3844331..72caef3 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1620,7 +1620,7 @@ PP(pp_caller)
        RETURN;
     }
 
-    EXTEND(SP, 10);
+    EXTEND(SP, 11);
 
     if (!stashname)
        PUSHs(&PL_sv_undef);
@@ -1721,6 +1721,12 @@ PP(pp_caller)
             mask = newSVsv(old_warnings);
         PUSHs(sv_2mortal(mask));
     }
+
+    PUSHs(cx->blk_oldcop->cop_hints ?
+         sv_2mortal(newRV_noinc(
+               (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+                                                 cx->blk_oldcop->cop_hints)))
+         : &PL_sv_undef);
     RETURN;
 }
 
diff --git a/proto.h b/proto.h
index 3f3d526..5bbd521 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -720,6 +720,14 @@ PERL_CALLCONV void Perl_hv_ksplit(pTHX_ HV* hv, IV newmax)
 /* PERL_CALLCONV void  Perl_hv_magic(pTHX_ HV* hv, GV* gv, int how)
                        __attribute__nonnull__(pTHX_1); */
 
+#ifdef USE_ITHREADS
+PERL_CALLCONV struct refcounted_he *   Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he, CLONE_PARAMS* param)
+                       __attribute__nonnull__(pTHX_2);
+
+#endif
+PERL_CALLCONV HV *     Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c);
+PERL_CALLCONV void     Perl_refcounted_he_free(pTHX_ struct refcounted_he *he);
+PERL_CALLCONV struct refcounted_he *   Perl_refcounted_he_new(pTHX_ struct refcounted_he *parent, SV *key, SV *value);
 PERL_CALLCONV SV**     Perl_hv_store(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash);
 PERL_CALLCONV HE*      Perl_hv_store_ent(pTHX_ HV* tb, SV* key, SV* val, U32 hash);
 PERL_CALLCONV SV**     Perl_hv_store_flags(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash, int flags);
@@ -1054,6 +1062,10 @@ PERL_CALLCONV int        Perl_magic_clear_all_env(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 
+PERL_CALLCONV int      Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV int      Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
@@ -1176,6 +1188,10 @@ PERL_CALLCONV int        Perl_magic_setfm(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 
+PERL_CALLCONV int      Perl_magic_sethint(pTHX_ SV* sv, MAGIC* mg)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV int      Perl_magic_setisa(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
@@ -2921,6 +2937,9 @@ STATIC struct xpvhv_aux*  S_hv_auxinit(HV *hv)
 
 STATIC SV*     S_hv_delete_common(pTHX_ HV* tb, SV* keysv, const char* key, STRLEN klen, int k_flags, I32 d_flags, U32 hash);
 STATIC HE*     S_hv_fetch_common(pTHX_ HV* tb, SV* keysv, const char* key, STRLEN klen, int flags, int action, SV* val, U32 hash);
+STATIC void    S_clear_placeholders(pTHX_ HV* hb, U32 items)
+                       __attribute__nonnull__(pTHX_1);
+
 #endif
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/scope.c b/scope.c
index 7b76823..5e4193a 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -890,6 +890,8 @@ Perl_leave_scope(pTHX_ I32 base)
                GvHV(PL_hintgv) = NULL;
            }
            *(I32*)&PL_hints = (I32)SSPOPINT;
+           Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
+           PL_compiling.cop_hints = (struct refcounted_he *) SSPOPPTR;
            if (PL_hints & HINT_LOCALIZE_HH) {
                SvREFCNT_dec((SV*)GvHV(PL_hintgv));
                GvHV(PL_hintgv) = (HV*)SSPOPPTR;
diff --git a/scope.h b/scope.h
index cace246..debae28 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -150,11 +150,15 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 
 #define SAVEHINTS() \
     STMT_START {                                       \
-       SSCHECK(3);                                     \
+       SSCHECK(4);                                     \
        if (PL_hints & HINT_LOCALIZE_HH) {              \
            SSPUSHPTR(GvHV(PL_hintgv));                 \
            GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv)); \
        }                                               \
+       if (PL_compiling.cop_hints) {                   \
+           PL_compiling.cop_hints->refcounted_he_refcnt++;     \
+       }                                               \
+       SSPUSHPTR(PL_compiling.cop_hints);              \
        SSPUSHINT(PL_hints);                            \
        SSPUSHINT(SAVEt_HINTS);                         \
     } STMT_END
diff --git a/sv.c b/sv.c
index ded27c9..d5cc44d 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4489,6 +4489,8 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_qr:
        vtable = &PL_vtbl_regexp;
        break;
+    case PERL_MAGIC_hints:
+       /* As this vtable is all NULL, we can reuse it.  */
     case PERL_MAGIC_sig:
        vtable = &PL_vtbl_sig;
        break;
@@ -4528,6 +4530,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_backref:
        vtable = &PL_vtbl_backref;
        break;
+    case PERL_MAGIC_hintselem:
+       vtable = &PL_vtbl_hintselem;
+       break;
     case PERL_MAGIC_ext:
        /* Reserved for use by extensions not perl internals.           */
        /* Useful for attaching extension internal data to perl vars.   */
@@ -10573,6 +10578,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
        case SAVEt_HINTS:
            i = POPINT(ss,ix);
            TOPINT(nss,ix) = i;
+           ptr = POPPTR(ss,ix);
+           TOPPTR(nss,ix) = Perl_refcounted_he_dup(aTHX_ ptr, param);
+           /* FIXME - either dup the conditionally saved HV, or eliminate
+              it by recreating eval's %^H from the cop  */
            break;
        case SAVEt_COMPPAD:
            av = (AV*)POPPTR(ss,ix);
@@ -10857,6 +10866,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
        PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
     if (!specialCopIO(PL_compiling.cop_io))
        PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
+    PL_compiling.cop_hints
+       = Perl_refcounted_he_dup(aTHX_ PL_compiling.cop_hints, proto_perl);
     PL_curcop          = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
 
     /* pseudo environmental stuff */
index 578aaaf..1bbd262 100644 (file)
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 31 );
+    plan( tests => 48 );
 }
 
 my @c;
@@ -104,7 +104,7 @@ my $debugger_test =  q<
 sub pb { return (caller(0))[3] }
 
 my $i = eval $debugger_test;
-is( $i, 10, "do not skip over eval (and caller returns 10 elements)" );
+is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
 
 is( eval 'pb()', 'main::pb', "actually return the right function name" );
 
@@ -113,6 +113,73 @@ $^P = 16;
 $^P = $saved_perldb;
 
 $i = eval $debugger_test;
-is( $i, 10, 'do not skip over eval even if $^P had been on at some point' );
+is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
 is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
 
+# caller can now return the compile time state of %^H
+sub get_dooot {
+    my $level = shift;
+    my @results = caller($level||0);
+    $results[10]->{dooot};
+}
+sub get_hash {
+    my $level = shift;
+    my @results = caller($level||0);
+    $results[10];
+}
+sub dooot {
+    is(get_dooot(), undef);
+    my $hash = get_hash();
+    ok(!exists $hash->{dooot});
+    is(get_dooot(1), 54);
+    BEGIN {
+       $^H{dooot} = 42;
+    }
+    is(get_dooot(), 6 * 7);
+    is(get_dooot(1), 54);
+
+    BEGIN {
+       $^H{dooot} = undef;
+    }
+    is(get_dooot(), undef);
+    $hash = get_hash();
+    ok(exists $hash->{dooot});
+
+    BEGIN {
+       delete $^H{dooot};
+    }
+    is(get_dooot(), undef);
+    $hash = get_hash();
+    ok(!exists $hash->{dooot});
+    is(get_dooot(1), 54);
+}
+{
+    is(get_dooot(), undef);
+    BEGIN {
+       $^H{dooot} = 1;
+    }
+       is(get_dooot(), 1);
+
+    BEGIN {
+       $^H{dooot} = 42;
+    }
+    {
+       {
+           BEGIN {
+               $^H{dooot} = 6 * 9;
+           }
+           is(get_dooot(), 54);
+           {
+               BEGIN {
+                   delete $^H{dooot};
+               }
+               is(get_dooot(), undef);
+               my $hash = get_hash();
+               ok(!exists $hash->{dooot});
+           }
+           dooot();
+       }
+       is(get_dooot(), 6 * 7);
+    }
+    is(get_dooot(), 6 * 7);
+}