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
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:
+ */
{ 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)" },
{ 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)" },
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
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
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
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
|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)
#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)
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);
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 */
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)
}
/*
+=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.
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.
*/
Perl_sharedsv_thrcnt_inc
Perl_sharedsv_unlock
Perl_stashpv_hvname_match
+ Perl_refcounted_he_dup
)];
}
}
/*
+=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
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"
SvREFCNT_dec(cop->cop_io);
#endif
}
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints);
}
void
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));
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);
#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"
#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 */
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
NULL
);
+/* For now, hints magic will also use vtbl_sig, because it is all NULL */
MGVTBL_SET(
PL_vtbl_sig,
NULL,
);
#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,
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
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.
=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
=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>
RETURN;
}
- EXTEND(SP, 10);
+ EXTEND(SP, 11);
if (!stashname)
PUSHs(&PL_sv_undef);
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;
}
/* 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);
__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);
__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);
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)
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;
#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
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;
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. */
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);
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 */
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan( tests => 31 );
+ plan( tests => 48 );
}
my @c;
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" );
$^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);
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff