X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f83b46a0147ba6f476add85d17f61a7e7fb00f21..7fc53d04ce15283fbdff3331bf04dc2ad05ec032:/cop.h diff --git a/cop.h b/cop.h index 86a67d0..626feee 100644 --- a/cop.h +++ b/cop.h @@ -92,8 +92,9 @@ typedef struct jmpenv JMPENV; * * The original patches that introduces flexible exceptions were: * - * http://public.activestate.com/cgi-bin/perlbrowse?patch=3386 - * http://public.activestate.com/cgi-bin/perlbrowse?patch=5162 + * http://perl5.git.perl.org/perl.git/commit/312caa8e97f1c7ee342a9895c2f0e749625b4929 + * http://perl5.git.perl.org/perl.git/commit/14dd3ad8c9bf82cf09798a22cc89a9862dfd6d1a + * */ #define dJMPENV JMPENV cur_env @@ -152,6 +153,230 @@ typedef struct jmpenv JMPENV; PL_top_env->je_mustcatch = (v); \ } STMT_END +/* +=head1 COP Hint Hashes +*/ + +typedef struct refcounted_he COPHH; + +#define COPHH_KEY_UTF8 REFCOUNTED_HE_KEY_UTF8 + +/* +=for apidoc Amx|SV *|cophh_fetch_pvn|const COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Look up the entry in the cop hints hash I with the key specified by +I and I. If I has the C bit set, +the key octets are interpreted as UTF-8, otherwise they are interpreted +as Latin-1. I is a precomputed hash of the key string, or zero if +it has not been precomputed. Returns a mortal scalar copy of the value +associated with the key, or C<&PL_sv_placeholder> if there is no value +associated with the key. + +=cut +*/ + +#define cophh_fetch_pvn(cophh, keypv, keylen, hash, flags) \ + Perl_refcounted_he_fetch_pvn(aTHX_ cophh, keypv, keylen, hash, flags) + +/* +=for apidoc Amx|SV *|cophh_fetch_pvs|const COPHH *cophh|const char *key|U32 flags + +Like L, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cophh_fetch_pvs(cophh, key, flags) \ + Perl_refcounted_he_fetch_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, flags) + +/* +=for apidoc Amx|SV *|cophh_fetch_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags + +Like L, but takes a nul-terminated string instead of +a string/length pair. + +=cut +*/ + +#define cophh_fetch_pv(cophh, key, hash, flags) \ + Perl_refcounted_he_fetch_pv(aTHX_ cophh, key, hash, flags) + +/* +=for apidoc Amx|SV *|cophh_fetch_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags + +Like L, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cophh_fetch_sv(cophh, key, hash, flags) \ + Perl_refcounted_he_fetch_sv(aTHX_ cophh, key, hash, flags) + +/* +=for apidoc Amx|HV *|cophh_2hv|const COPHH *cophh|U32 flags + +Generates and returns a standard Perl hash representing the full set of +key/value pairs in the cop hints hash I. I is currently +unused and must be zero. + +=cut +*/ + +#define cophh_2hv(cophh, flags) \ + Perl_refcounted_he_chain_2hv(aTHX_ cophh, flags) + +/* +=for apidoc Amx|COPHH *|cophh_copy|COPHH *cophh + +Make and return a complete copy of the cop hints hash I. + +=cut +*/ + +#define cophh_copy(cophh) Perl_refcounted_he_inc(aTHX_ cophh) + +/* +=for apidoc Amx|void|cophh_free|COPHH *cophh + +Discard the cop hints hash I, freeing all resources associated +with it. + +=cut +*/ + +#define cophh_free(cophh) Perl_refcounted_he_free(aTHX_ cophh) + +/* +=for apidoc Amx|COPHH *|cophh_new_empty + +Generate and return a fresh cop hints hash containing no entries. + +=cut +*/ + +#define cophh_new_empty() ((COPHH *)NULL) + +/* +=for apidoc Amx|COPHH *|cophh_store_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags + +Stores a value, associated with a key, in the cop hints hash I, +and returns the modified hash. The returned hash pointer is in general +not the same as the hash pointer that was passed in. The input hash is +consumed by the function, and the pointer to it must not be subsequently +used. Use L if you need both hashes. + +The key is specified by I and I. If I has the +C bit set, the key octets are interpreted as UTF-8, +otherwise they are interpreted as Latin-1. I is a precomputed +hash of the key string, or zero if it has not been precomputed. + +I is the scalar value to store for this key. I is copied +by this function, which thus does not take ownership of any reference +to it, and later changes to the scalar will not be reflected in the +value visible in the cop hints hash. Complex types of scalar will not +be stored with referential integrity, but will be coerced to strings. + +=cut +*/ + +#define cophh_store_pvn(cophh, keypv, keylen, hash, value, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, value, flags) + +/* +=for apidoc Amx|COPHH *|cophh_store_pvs|const COPHH *cophh|const char *key|SV *value|U32 flags + +Like L, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cophh_store_pvs(cophh, key, value, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, value, flags) + +/* +=for apidoc Amx|COPHH *|cophh_store_pv|const COPHH *cophh|const char *key|U32 hash|SV *value|U32 flags + +Like L, but takes a nul-terminated string instead of +a string/length pair. + +=cut +*/ + +#define cophh_store_pv(cophh, key, hash, value, flags) \ + Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, value, flags) + +/* +=for apidoc Amx|COPHH *|cophh_store_sv|const COPHH *cophh|SV *key|U32 hash|SV *value|U32 flags + +Like L, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cophh_store_sv(cophh, key, hash, value, flags) \ + Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, value, flags) + +/* +=for apidoc Amx|COPHH *|cophh_delete_pvn|COPHH *cophh|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Delete a key and its associated value from the cop hints hash I, +and returns the modified hash. The returned hash pointer is in general +not the same as the hash pointer that was passed in. The input hash is +consumed by the function, and the pointer to it must not be subsequently +used. Use L if you need both hashes. + +The key is specified by I and I. If I has the +C bit set, the key octets are interpreted as UTF-8, +otherwise they are interpreted as Latin-1. I is a precomputed +hash of the key string, or zero if it has not been precomputed. + +=cut +*/ + +#define cophh_delete_pvn(cophh, keypv, keylen, hash, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, keypv, keylen, hash, \ + (SV *)NULL, flags) + +/* +=for apidoc Amx|COPHH *|cophh_delete_pvs|const COPHH *cophh|const char *key|U32 flags + +Like L, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cophh_delete_pvs(cophh, key, flags) \ + Perl_refcounted_he_new_pvn(aTHX_ cophh, STR_WITH_LEN(key), 0, \ + (SV *)NULL, flags) + +/* +=for apidoc Amx|COPHH *|cophh_delete_pv|const COPHH *cophh|const char *key|U32 hash|U32 flags + +Like L, but takes a nul-terminated string instead of +a string/length pair. + +=cut +*/ + +#define cophh_delete_pv(cophh, key, hash, flags) \ + Perl_refcounted_he_new_pv(aTHX_ cophh, key, hash, (SV *)NULL, flags) + +/* +=for apidoc Amx|COPHH *|cophh_delete_sv|const COPHH *cophh|SV *key|U32 hash|U32 flags + +Like L, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cophh_delete_sv(cophh, key, hash, flags) \ + Perl_refcounted_he_new_sv(aTHX_ cophh, key, hash, (SV *)NULL, flags) #include "mydtrace.h" @@ -164,6 +389,7 @@ struct cop { #ifdef USE_ITHREADS char * cop_stashpv; /* package line was compiled in */ char * cop_file; /* file name the following line # is from */ + U32 cop_stashflags; /* currently only SVf_UTF8 */ #else HV * cop_stash; /* package line was compiled in */ GV * cop_filegv; /* file the following line # is from */ @@ -174,7 +400,7 @@ struct cop { STRLEN * cop_warnings; /* lexical warnings bitmask */ /* 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_hash; + COPHH * cop_hints_hash; }; #ifdef USE_ITHREADS @@ -208,9 +434,20 @@ struct cop { # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savesharedpv(pv)) # endif -# define CopSTASH(c) (CopSTASHPV(c) \ - ? gv_stashpv(CopSTASHPV(c),GV_ADD) : NULL) -# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL) +# define CopSTASH_flags(c) ((c)->cop_stashflags) +# define CopSTASH_flags_set(c,flags) ((c)->cop_stashflags = flags) + +# define CopSTASH(c) (CopSTASHPV(c) \ + ? gv_stashpv(CopSTASHPV(c), \ + GV_ADD|(CopSTASH_flags(c) \ + ? CopSTASH_flags(c): 0 )) \ + : NULL) +# define CopSTASH_set(c,hv) (CopSTASHPV_set(c, (hv) ? HvNAME_get(hv) : NULL), \ + CopSTASH_flags_set(c, \ + ((hv) && HvNAME_HEK(hv) && \ + HvNAMEUTF8(hv)) \ + ? SVf_UTF8 \ + : 0)) # define CopSTASH_eq(c,hv) ((hv) && stashpv_hvname_match(c,hv)) # ifdef NETWARE # define CopSTASH_free(c) SAVECOPSTASH_FREE(c) @@ -243,7 +480,81 @@ struct cop { # define CopFILE_free(c) (SvREFCNT_dec(CopFILEGV(c)),(CopFILEGV(c) = NULL)) #endif /* USE_ITHREADS */ -#define CopLABEL(c) Perl_fetch_cop_label(aTHX_ (c), NULL, NULL) + +#define CopHINTHASH_get(c) ((COPHH*)((c)->cop_hints_hash)) +#define CopHINTHASH_set(c,h) ((c)->cop_hints_hash = (h)) + +/* +=head1 COP Hint Reading +*/ + +/* +=for apidoc Am|SV *|cop_hints_fetch_pvn|const COP *cop|const char *keypv|STRLEN keylen|U32 hash|U32 flags + +Look up the hint entry in the cop I with the key specified by +I and I. If I has the C bit set, +the key octets are interpreted as UTF-8, otherwise they are interpreted +as Latin-1. I is a precomputed hash of the key string, or zero if +it has not been precomputed. Returns a mortal scalar copy of the value +associated with the key, or C<&PL_sv_placeholder> if there is no value +associated with the key. + +=cut +*/ + +#define cop_hints_fetch_pvn(cop, keypv, keylen, hash, flags) \ + cophh_fetch_pvn(CopHINTHASH_get(cop), keypv, keylen, hash, flags) + +/* +=for apidoc Am|SV *|cop_hints_fetch_pvs|const COP *cop|const char *key|U32 flags + +Like L, but takes a literal string instead of a +string/length pair, and no precomputed hash. + +=cut +*/ + +#define cop_hints_fetch_pvs(cop, key, flags) \ + cophh_fetch_pvs(CopHINTHASH_get(cop), key, flags) + +/* +=for apidoc Am|SV *|cop_hints_fetch_pv|const COP *cop|const char *key|U32 hash|U32 flags + +Like L, but takes a nul-terminated string instead +of a string/length pair. + +=cut +*/ + +#define cop_hints_fetch_pv(cop, key, hash, flags) \ + cophh_fetch_pv(CopHINTHASH_get(cop), key, hash, flags) + +/* +=for apidoc Am|SV *|cop_hints_fetch_sv|const COP *cop|SV *key|U32 hash|U32 flags + +Like L, but takes a Perl scalar instead of a +string/length pair. + +=cut +*/ + +#define cop_hints_fetch_sv(cop, key, hash, flags) \ + cophh_fetch_sv(CopHINTHASH_get(cop), key, hash, flags) + +/* +=for apidoc Am|HV *|cop_hints_2hv|const COP *cop|U32 flags + +Generates and returns a standard Perl hash representing the full set of +hint entries in the cop I. I is currently unused and must +be zero. + +=cut +*/ + +#define cop_hints_2hv(cop, flags) \ + cophh_2hv(CopHINTHASH_get(cop), flags) + +#define CopLABEL(c) Perl_cop_fetch_label(aTHX_ (c), NULL, NULL) #define CopLABEL_alloc(pv) ((pv)?savepv(pv):NULL) #define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) @@ -255,32 +566,6 @@ struct cop { /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */ #define OutCopFILE(c) CopFILE(c) -/* If $[ is non-zero, it's stored in cop_hints under the key "$[", and - HINT_ARYBASE is set to indicate this. - Setting it is ineficient due to the need to create 2 mortal SVs, but as - using $[ is highly discouraged, no sane Perl code will be using it. */ -#define CopARYBASE_get(c) \ - ((CopHINTS_get(c) & HINT_ARYBASE) \ - ? SvIV(Perl_refcounted_he_fetch(aTHX_ (c)->cop_hints_hash, 0, \ - "$[", 2, 0, 0)) \ - : 0) -#define CopARYBASE_set(c, b) STMT_START { \ - if (b || ((c)->cop_hints & HINT_ARYBASE)) { \ - (c)->cop_hints |= HINT_ARYBASE; \ - if ((c) == &PL_compiling) { \ - SV *val = newSViv(b); \ - (void)hv_stores(GvHV(PL_hintgv), "$[", val); \ - mg_set(val); \ - PL_hints |= HINT_ARYBASE; \ - } else { \ - (c)->cop_hints_hash \ - = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash, \ - newSVpvs_flags("$[", SVs_TEMP), \ - sv_2mortal(newSViv(b))); \ - } \ - } \ - } STMT_END - /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */ #define CopHINTS_get(c) ((c)->cop_hints + 0) #define CopHINTS_set(c, h) STMT_START { \ @@ -321,7 +606,8 @@ struct block_format { #define PUSHSUB_BASE(cx) \ ENTRY_PROBE(GvENAME(CvGV(cv)), \ CopFILE((const COP *)CvSTART(cv)), \ - CopLINE((const COP *)CvSTART(cv))); \ + CopLINE((const COP *)CvSTART(cv)), \ + CopSTASHPV((const COP *)CvSTART(cv))); \ \ cx->blk_sub.cv = cv; \ cx->blk_sub.olddepth = CvDEPTH(cv); \ @@ -335,9 +621,18 @@ struct block_format { #define PUSHSUB(cx) \ + { \ + /* If the context is indeterminate, then only the lvalue */ \ + /* flags that the caller also has are applicable. */ \ + U8 phlags = \ + (PL_op->op_flags & OPf_WANT) \ + ? OPpENTERSUB_LVAL_MASK \ + : !(PL_op->op_private & OPpENTERSUB_LVAL_MASK) \ + ? 0 : Perl_was_lvalue_sub(aTHX); \ PUSHSUB_BASE(cx) \ cx->blk_u16 = PL_op->op_private & \ - (OPpLVAL_INTRO|OPpENTERSUB_INARGS); + (phlags|OPpDEREF); \ + } /* variant for use by OP_DBSTATE, where op_private holds hint bits */ #define PUSHSUB_DB(cx) \ @@ -371,7 +666,8 @@ struct block_format { STMT_START { \ RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)), \ CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ - CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \ + CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)), \ + CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv))); \ \ if (CxHASARGS(cx)) { \ POP_SAVEARRAY(); \ @@ -612,7 +908,6 @@ struct subst { #define sb_maxiters cx_u.cx_subst.sbu_maxiters #define sb_rflags cx_u.cx_subst.sbu_rflags #define sb_oldsave cx_u.cx_subst.sbu_oldsave -#define sb_once cx_u.cx_subst.sbu_once #define sb_rxtainted cx_u.cx_subst.sbu_rxtainted #define sb_orig cx_u.cx_subst.sbu_orig #define sb_dstr cx_u.cx_subst.sbu_dstr @@ -695,9 +990,7 @@ struct context { /* private flags for CXt_LOOP */ #define CXp_FOR_DEF 0x10 /* foreach using $_ */ -#ifdef USE_ITHREADS -# define CxPADLOOP(c) ((c)->blk_loop.my_op->op_targ) -#endif +#define CxPADLOOP(c) ((c)->blk_loop.my_op->op_targ) /* private flags for CXt_SUBST */ #define CXp_ONCE 0x10 /* What was sbu_once in struct subst */ @@ -768,6 +1061,8 @@ L. #define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef A special case for UNSHIFT in Perl_magic_methcall(). */ +#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling + Perl_magic_methcall(). */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ @@ -876,18 +1171,18 @@ typedef struct stackinfo PERL_SI; =head1 Multicall Functions =for apidoc Ams||dMULTICALL -Declare local variables for a multicall. See L. +Declare local variables for a multicall. See L. =for apidoc Ams||PUSH_MULTICALL Opening bracket for a lightweight callback. -See L. +See L. =for apidoc Ams||MULTICALL -Make a lightweight callback. See L. +Make a lightweight callback. See L. =for apidoc Ams||POP_MULTICALL Closing bracket for a lightweight callback. -See L. +See L. =cut */ @@ -930,8 +1225,8 @@ See L. #define POP_MULTICALL \ STMT_START { \ - LEAVESUB(multicall_cv); \ - CvDEPTH(multicall_cv)--; \ + if (! --CvDEPTH(multicall_cv)) \ + LEAVESUB(multicall_cv); \ POPBLOCK(cx,PL_curpm); \ POPSTACK; \ CATCH_SET(multicall_oldcatch); \