From: Nicholas Clark Date: Fri, 31 Mar 2006 13:45:57 +0000 (+0000) Subject: Serialise changes to %^H onto the current COP. Return the compile time X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b3ca2e834c3607fd8aa8736a51aa3a2b8bba1044;p=p5sagit%2Fp5-mst-13.2.git Serialise changes to %^H onto the current COP. Return the compile time state of %^H as an eleventh value from caller. This allows users to write pragmas. p4raw-id: //depot/perl@27643 --- diff --git a/cop.h b/cop.h index 81712fa..8ce6b3e 100644 --- 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. 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 --- 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 diff --git a/embed.fnc b/embed.fnc index 0fdbf20..dfd3d5a 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -287,6 +287,8 @@ #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 @@ -399,6 +401,7 @@ #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 @@ -429,6 +432,7 @@ #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 @@ -1091,6 +1095,7 @@ #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) @@ -2448,6 +2453,12 @@ #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) @@ -2559,6 +2570,7 @@ #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) @@ -2589,6 +2601,7 @@ #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) @@ -3241,6 +3254,7 @@ #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 --- 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 --- 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 by walking up the tree starting at the passed +in C. + +=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. Assumes ownership of one reference +to I. As S is copied into a shared hash key, all references remain +the property of the caller. The C 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 +by one. If the reference count reaches zero the structure's memory is freed, +and C 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 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 --- 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. */ diff --git a/makedef.pl b/makedef.pl index 3745e19..f203601 100644 --- a/makedef.pl +++ b/makedef.pl @@ -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 --- 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. 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. + +=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 --- 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 updates C with a store + record, with deletes written by C. C + saves the current C 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 --- 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 --- 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, diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index e9e22fa..d638cc1 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -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. 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 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. diff --git a/pod/perlintern.pod b/pod/perlintern.pod index 2cc6868..6c82701 100644 --- a/pod/perlintern.pod +++ b/pod/perlintern.pod @@ -470,6 +470,59 @@ Found in file gv.c =back +=head1 Hash Manipulation Functions + +=over 8 + +=item refcounted_he_chain_2hv +X + +Generates an returns a C by walking up the tree starting at the passed +in C. + + HV * refcounted_he_chain_2hv(const struct refcounted_he *c) + +=for hackers +Found in file hv.c + +=item refcounted_he_dup +X + +Duplicates the C 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 + +Decrements the reference count of the passed in C +by one. If the reference count reaches zero the structure's memory is freed, +and C 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 + +Creates a new C. Assumes ownership of one reference +to I. As S is copied into a shared hash key, all references remain +the property of the caller. The C 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 + +Triggered by a delete from %^H, records the key to C. + + int magic_sethint(SV* sv, MAGIC* mg) + +=for hackers +Found in file mg.c + =item mg_localize X diff --git a/pp_ctl.c b/pp_ctl.c index 3844331..72caef3 100644 --- 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 --- 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 --- 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 --- a/scope.h +++ b/scope.h @@ -150,11 +150,15 @@ Closing bracket on a callback. See C and L. #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 --- 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 */ diff --git a/t/op/caller.t b/t/op/caller.t index 578aaaf..1bbd262 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 => 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); +}