X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b2aed7751d929c14868a85d0da84e2f09a333507..d821b3b405f821ddbb82e38fa5bebf5c53658301:/mg.c diff --git a/mg.c b/mg.c index 238d847..37d734d 100644 --- a/mg.c +++ b/mg.c @@ -41,6 +41,7 @@ tie. #include "EXTERN.h" #define PERL_IN_MG_C #include "perl.h" +#include "feature.h" #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) # ifdef I_GRP @@ -62,12 +63,6 @@ tie. # include #endif -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -Signal_t Perl_csighandler(int sig, siginfo_t *, void *); -#else -Signal_t Perl_csighandler(int sig); -#endif - #ifdef __Lynx__ /* Missing protos on LynxOS */ void setruid(uid_t id); @@ -171,6 +166,7 @@ Perl_mg_get(pTHX_ SV *sv) const I32 mgs_ix = SSNEW(sizeof(MGS)); bool saved = FALSE; bool have_new = 0; + bool taint_only = TRUE; /* the only get method seen is taint */ MAGIC *newmg, *head, *cur, *mg; PERL_ARGS_ASSERT_MG_GET; @@ -189,10 +185,13 @@ Perl_mg_get(pTHX_ SV *sv) if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { /* taint's mg get is so dumb it doesn't need flag saving */ - if (!saved && mg->mg_type != PERL_MAGIC_taint) { - save_magic(mgs_ix, sv); - saved = TRUE; - } + if (mg->mg_type != PERL_MAGIC_taint) { + taint_only = FALSE; + if (!saved) { + save_magic(mgs_ix, sv); + saved = TRUE; + } + } vtbl->svt_get(aTHX_ sv, mg); @@ -210,8 +209,23 @@ Perl_mg_get(pTHX_ SV *sv) ~(SVs_GMG|SVs_SMG|SVs_RMG); } else if (vtbl == &PL_vtbl_utf8) { - /* get-magic can reallocate the PV */ - magic_setutf8(sv, mg); + /* get-magic can reallocate the PV, unless there's only taint + * magic */ + if (taint_only) { + MAGIC *mg2; + for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) { + if ( mg2->mg_type != PERL_MAGIC_taint + && !(mg2->mg_flags & MGf_GSKIP) + && mg2->mg_virtual + && mg2->mg_virtual->svt_get + ) { + taint_only = FALSE; + break; + } + } + } + if (!taint_only) + magic_setutf8(sv, mg); } mg = nextmg; @@ -471,9 +485,7 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) sv_magic(nsv, (type == PERL_MAGIC_tied) ? SvTIED_obj(sv, mg) - : (type == PERL_MAGIC_regdata && mg->mg_obj) - ? sv - : mg->mg_obj, + : mg->mg_obj, toLOWER(type), key, klen); count++; } @@ -539,12 +551,18 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_free) vtbl->svt_free(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + + if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0) + /* collate magic uses string len not buffer len, so + * free even with mg_len == 0 */ + Safefree(mg->mg_ptr); + else if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); } + if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); @@ -577,7 +595,7 @@ Perl_mg_free(pTHX_ SV *sv) } /* -=for apidoc Am|void|mg_free_type|SV *sv|int how +=for apidoc mg_free_type Remove any magic of type C from the SV C. See L. @@ -590,9 +608,45 @@ Perl_mg_free_type(pTHX_ SV *sv, int how) MAGIC *mg, *prevmg, *moremg; PERL_ARGS_ASSERT_MG_FREE_TYPE; for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { - MAGIC *newhead; moremg = mg->mg_moremagic; if (mg->mg_type == how) { + MAGIC *newhead; + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } + } + mg_magical(sv); +} + +/* +=for apidoc mg_freeext + +Remove any magic of type C using virtual table C from the +SV C. See L. + +C is equivalent to C. + +=cut +*/ + +void +Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl) +{ + MAGIC *mg, *prevmg, *moremg; + PERL_ARGS_ASSERT_MG_FREEEXT; + for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { + MAGIC *newhead; + moremg = mg->mg_moremagic; + if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { /* temporarily move to the head of the magic chain, in case custom free code relies on this historical aspect of mg_free */ if (prevmg) { @@ -619,12 +673,13 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); + REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - if (mg->mg_obj) { /* @+ */ + const SSize_t n = (SSize_t)mg->mg_obj; + if (n == '+') { /* @+ */ /* return the number possible */ return RX_NPARENS(rx); - } else { /* @- */ + } else { /* @- @^CAPTURE @{^CAPTURE} */ I32 paren = RX_LASTPAREN(rx); /* return the last filled */ @@ -632,8 +687,14 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) && (RX_OFFS(rx)[paren].start == -1 || RX_OFFS(rx)[paren].end == -1) ) paren--; - return (U32)paren; - } + if (n == '-') { + /* @- */ + return (U32)paren; + } else { + /* @^CAPTURE @{^CAPTURE} */ + return paren >= 0 ? (U32)(paren-1) : (U32)-1; + } + } } } @@ -648,9 +709,12 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); + REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - const I32 paren = mg->mg_len; + const SSize_t n = (SSize_t)mg->mg_obj; + /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ + const I32 paren = mg->mg_len + + (n == '\003' ? 1 : 0); SSize_t s; SSize_t t; if (paren < 0) @@ -660,10 +724,15 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) (t = RX_OFFS(rx)[paren].end) != -1) { SSize_t i; - if (mg->mg_obj) /* @+ */ + + if (n == '+') /* @+ */ i = t; - else /* @- */ + else if (n == '-') /* @- */ i = s; + else { /* @^CAPTURE @{^CAPTURE} */ + CALLREG_NUMBUF_FETCH(rx,paren,sv); + return 0; + } if (RX_MATCH_UTF8(rx)) { const char * const b = RX_SUBBEG(rx); @@ -678,7 +747,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) } } } - sv_setsv(sv, NULL); + sv_set_undef(sv); return 0; } @@ -712,7 +781,7 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) PERL_ARGS_ASSERT_EMULATE_COP_IO; if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) - sv_setsv(sv, &PL_sv_undef); + sv_set_undef(sv); else { SvPVCLEAR(sv); SvUTF8_off(sv); @@ -750,22 +819,78 @@ S_fixup_errno_string(pTHX_ SV* sv) * avoid as many possible backward compatibility issues as possible, we * don't turn on the flag unless we have to. So the flag stays off for * an entirely invariant string. We assume that if the string looks - * like UTF-8, it really is UTF-8: "text in any other encoding that - * uses bytes with the high bit set is extremely unlikely to pass a - * UTF-8 validity test" + * like UTF-8 in a single script, it really is UTF-8: "text in any + * other encoding that uses bytes with the high bit set is extremely + * unlikely to pass a UTF-8 validity test" * (http://en.wikipedia.org/wiki/Charset_detection). There is a * potential that we will get it wrong however, especially on short - * error message text. (If it turns out to be necessary, we could also - * keep track if the current LC_MESSAGES locale is UTF-8) */ - if (! IN_BYTES /* respect 'use bytes' */ - && ! is_utf8_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) - && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))) - { + * error message text, so do an additional check. */ + if ( ! IN_BYTES /* respect 'use bytes' */ + && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) + +#ifdef USE_LOCALE_MESSAGES + + && _is_cur_LC_category_utf8(LC_MESSAGES) + +#else /* If can't check directly, at least can see if script is consistent, + under UTF-8, which gives us an extra measure of confidence. */ + + && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv), + TRUE) /* Means assume UTF-8 */ +#endif + + ) { SvUTF8_on(sv); } } } +/* +=for apidoc sv_string_from_errnum + +Generates the message string describing an OS error and returns it as +an SV. C must be a value that C could take, identifying +the type of error. + +If C is non-null then the string will be written into that SV +(overwriting existing content) and it will be returned. If C +is a null pointer then the string will be written into a new mortal SV +which will be returned. + +The message will be taken from whatever locale would be used by C<$!>, +and will be encoded in the SV in whatever manner would be used by C<$!>. +The details of this process are subject to future change. Currently, +the message is taken from the C locale by default (usually producing an +English message), and from the currently selected locale when in the scope +of the C pragma. A heuristic attempt is made to decode the +message from the locale's character encoding, but it will only be decoded +as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8 +locale, usually in an ISO-8859-1 locale, and never in any other locale. + +The SV is always returned containing an actual string, and with no other +OK bits set. Unlike C<$!>, a message is even yielded for C zero +(meaning success), and if no useful message is available then a useless +string (currently empty) is returned. + +=cut +*/ + +SV * +Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv) +{ + char const *errstr; + if(!tgtsv) + tgtsv = sv_newmortal(); + errstr = my_strerror(errnum); + if(errstr) { + sv_setpv(tgtsv, errstr); + fixup_errno_string(tgtsv); + } else { + SvPVCLEAR(tgtsv); + } + return tgtsv; +} + #ifdef VMS #include #include @@ -787,9 +912,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { do_numbuf_fetch: CALLREG_NUMBUF_FETCH(rx,paren,sv); - } else { - sv_setsv(sv,&PL_sv_undef); } + else + goto set_undef; return 0; } @@ -797,7 +922,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); - else sv_setsv(sv, &PL_sv_undef); + else + sv_set_undef(sv); if (SvTAINTED(PL_bodytarget)) SvTAINTED_on(sv); break; @@ -816,7 +942,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\005': /* ^E */ if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) - sv_setsv(sv, NULL); + sv_set_undef(sv); break; } @@ -867,6 +993,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; #endif /* End of platforms with special handling for $^E; others just fall through to $! */ + /* FALLTHROUGH */ case '!': { @@ -885,14 +1012,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvPVCLEAR(sv); } else { - - /* Strerror can return NULL on some platforms, which will - * result in 'sv' not being considered SvOK. The SvNOK_on() + sv_string_from_errnum(errno, sv); + /* If no useful string is available, don't + * claim to have a string part. The SvNOK_on() * below will cause just the number part to be valid */ - sv_setpv(sv, my_strerror(errno)); - if (SvOK(sv)) { - fixup_errno_string(sv); - } + if (!SvCUR(sv)) + SvPOK_off(sv); } RESTORE_ERRNO; } @@ -902,7 +1027,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\006': /* ^F */ - sv_setiv(sv, (IV)PL_maxsysfd); + if (nextchar == '\0') { + sv_setiv(sv, (IV)PL_maxsysfd); + } break; case '\007': /* ^GLOBAL_PHASE */ if (strEQ(remaining, "LOBAL_PHASE")) { @@ -911,14 +1038,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '\010': /* ^H */ - sv_setiv(sv, (IV)PL_hints); + sv_setuv(sv, PL_hints); break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ break; case '\014': /* ^LAST_FH */ if (strEQ(remaining, "AST_FH")) { - if (PL_last_in_gv) { + if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { assert(isGV_with_GP(PL_last_in_gv)); SV_CHECK_THINKFIRST_COW_DROP(sv); prepare_SV_for_RV(sv); @@ -927,7 +1054,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvROK_on(sv); sv_rvweaken(sv); } - else sv_setsv_nomg(sv, NULL); + else + sv_set_undef(sv); } break; case '\017': /* ^O & ^OPEN */ @@ -943,7 +1071,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)PL_perldb); break; case '\023': /* ^S */ - { + if (nextchar == '\0') { if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) SvOK_off(sv); else if (PL_in_eval) @@ -951,6 +1079,18 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else sv_setiv(sv, 0); } + else if (strEQ(remaining, "AFE_LOCALES")) { + +#if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE) + + sv_setuv(sv, (UV) 1); + +#else + sv_setuv(sv, (UV) 0); + +#endif + + } break; case '\024': /* ^T */ if (nextchar == '\0') { @@ -975,24 +1115,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\027': /* ^W & $^WARNING_BITS */ if (nextchar == '\0') - sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); + sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); else if (strEQ(remaining, "ARNING_BITS")) { if (PL_compiling.cop_warnings == pWARN_NONE) { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_STD) { - sv_setsv(sv, &PL_sv_undef); - break; + goto set_undef; } else if (PL_compiling.cop_warnings == pWARN_ALL) { - /* Get the bit mask for $warnings::Bits{all}, because - * it could have been extended by warnings::register */ - HV * const bits = get_hv("warnings::Bits", 0); - SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL; - if (bits_all) - sv_copypv(sv, *bits_all); - else - sv_setpvn(sv, WARN_ALLstring, WARNsize); + sv_setpvn(sv, WARN_ALLstring, WARNsize); } else { sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), @@ -1011,16 +1143,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (paren) goto do_numbuf_fetch; } - sv_setsv(sv,&PL_sv_undef); - break; + goto set_undef; case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = RX_LASTCLOSEPAREN(rx); if (paren) goto do_numbuf_fetch; } - sv_setsv(sv,&PL_sv_undef); - break; + goto set_undef; case '.': if (GvIO(PL_last_in_gv)) { sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); @@ -1079,7 +1209,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_ors_sv) sv_copypv(sv, PL_ors_sv); else - sv_setsv(sv, &PL_sv_undef); + goto set_undef; break; case '$': /* $$ */ { @@ -1108,13 +1238,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #ifdef HAS_GETGROUPS { Groups_t *gary = NULL; - I32 i; I32 num_groups = getgroups(0, gary); if (num_groups > 0) { + I32 i; Newx(gary, num_groups, Groups_t); num_groups = getgroups(num_groups, gary); for (i = 0; i < num_groups; i++) - Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]); + Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]); Safefree(gary); } } @@ -1125,6 +1255,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; } return 0; + + set_undef: + sv_set_undef(sv); + return 0; } int @@ -1328,7 +1462,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) if(sigstate == (Sighandler_t) SIG_IGN) sv_setpvs(sv,"IGNORE"); else - sv_setsv(sv,&PL_sv_undef); + sv_set_undef(sv); PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); SvTEMP_off(sv); } @@ -1344,19 +1478,45 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) return sv_unmagic(sv, mg->mg_type); } + +#ifdef PERL_USE_3ARG_SIGHANDLER Signal_t -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) +Perl_csighandler(int sig, Siginfo_t *sip, void *uap) +{ + Perl_csighandler3(sig, sip, uap); +} #else +Signal_t Perl_csighandler(int sig) +{ + Perl_csighandler3(sig, NULL, NULL); +} #endif + +Signal_t +Perl_csighandler1(int sig) +{ + Perl_csighandler3(sig, NULL, NULL); +} + +/* Handler intended to directly handle signal calls from the kernel. + * (Depending on configuration, the kernel may actually call one of the + * wrappers csighandler() or csighandler1() instead.) + * It either queues up the signal or dispatches it immediately depending + * on whether safe signals are enabled and whether the signal is capable + * of being deferred (e.g. SEGV isn't). + */ + +Signal_t +Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) { #ifdef PERL_GET_SIG_CONTEXT dTHXa(PERL_GET_SIG_CONTEXT); #else dTHX; #endif -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) + +#ifdef PERL_USE_3ARG_SIGHANDLER #if defined(__cplusplus) && defined(__GNUC__) /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap * parameters would be warned about. */ @@ -1364,6 +1524,7 @@ Perl_csighandler(int sig) PERL_UNUSED_ARG(uap); #endif #endif + #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); if (PL_sig_ignoring[sig]) return; @@ -1389,11 +1550,20 @@ Perl_csighandler(int sig) (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) /* Call the perl level handler now-- * with risk we may be in malloc() or being destructed etc. */ -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) - (*PL_sighandlerp)(sig, NULL, NULL); + { + if (PL_sighandlerp == Perl_sighandler) + /* default handler, so can call perly_sighandler() directly + * rather than via Perl_sighandler, passing the extra + * 'safe = false' arg + */ + Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */); + else +#ifdef PERL_USE_3ARG_SIGHANDLER + (*PL_sighandlerp)(sig, NULL, NULL); #else - (*PL_sighandlerp)(sig); + (*PL_sighandlerp)(sig); #endif + } else { if (!PL_psig_pend) return; /* Set a flag to say this signal is pending, that is awaiting delivery after @@ -1471,11 +1641,19 @@ Perl_despatch_signals(pTHX) } #endif PL_psig_pend[sig] = 0; -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) - (*PL_sighandlerp)(sig, NULL, NULL); + if (PL_sighandlerp == Perl_sighandler) + /* default handler, so can call perly_sighandler() directly + * rather than via Perl_sighandler, passing the extra + * 'safe = true' arg + */ + Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */); + else +#ifdef PERL_USE_3ARG_SIGHANDLER + (*PL_sighandlerp)(sig, NULL, NULL); #else - (*PL_sighandlerp)(sig); + (*PL_sighandlerp)(sig); #endif + #ifdef HAS_SIGPROCMASK if (!was_blocked) LEAVE; @@ -1622,7 +1800,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) * access to a known hint bit in a known OP, we can't * tell whether HINT_STRICT_REFS is in force or not. */ - if (!strchr(s,':') && !strchr(s,'\'')) + if (!memchr(s, ':', len) && !memchr(s, '\'', len)) Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), SV_GMAGIC); if (i) @@ -1791,8 +1969,8 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, va_start(args, argc); do { - SV *const sv = va_arg(args, SV *); - PUSHs(sv); + SV *const this_sv = va_arg(args, SV *); + PUSHs(this_sv); } while (--argc); va_end(args); @@ -1989,7 +2167,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) /* The magic ptr/len for the debugger's hash should always be an SV. */ if (UNLIKELY(mg->mg_len != HEf_SVKEY)) { - Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'", + Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'", (IV)mg->mg_len, mg->mg_ptr); } @@ -2027,7 +2205,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) if (obj) { sv_setiv(sv, AvFILL(obj)); } else { - sv_setsv(sv, NULL); + sv_set_undef(sv); } return 0; } @@ -2056,12 +2234,12 @@ Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_CONTEXT; /* Reset the iterator when the array is cleared */ -#if IVSIZE == I32SIZE - *((IV *) &(mg->mg_len)) = 0; -#else - if (mg->mg_ptr) - *((IV *) mg->mg_ptr) = 0; -#endif + if (sizeof(IV) == sizeof(SSize_t)) { + *((IV *) &(mg->mg_len)) = 0; + } else { + if (mg->mg_ptr) + *((IV *) mg->mg_ptr) = 0; + } return 0; } @@ -2105,7 +2283,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) sv_setuv(sv, i); return 0; } - sv_setsv(sv,NULL); + sv_set_undef(sv); return 0; } @@ -2115,7 +2293,6 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SV* const lsv = LvTARG(sv); SSize_t pos; STRLEN len; - STRLEN ulen = 0; MAGIC* found; const char *s; @@ -2137,7 +2314,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) pos = SvIV(sv); if (DO_UTF8(lsv)) { - ulen = sv_or_pv_len_utf8(lsv, s, len); + const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len); if (ulen) len = ulen; } @@ -2164,8 +2341,8 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) const char * const tmps = SvPV_const(lsv,len); STRLEN offs = LvTARGOFF(sv); STRLEN rem = LvTARGLEN(sv); - const bool negoff = LvFLAGS(sv) & 1; - const bool negrem = LvFLAGS(sv) & 2; + const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; + const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN; PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; PERL_UNUSED_ARG(mg); @@ -2176,7 +2353,7 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem )) { Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); - sv_setsv_nomg(sv, &PL_sv_undef); + sv_set_undef(sv); return 0; } @@ -2196,8 +2373,8 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) SV * const lsv = LvTARG(sv); STRLEN lvoff = LvTARGOFF(sv); STRLEN lvlen = LvTARGLEN(sv); - const bool negoff = LvFLAGS(sv) & 1; - const bool neglen = LvFLAGS(sv) & 2; + const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; + const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN; PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; PERL_UNUSED_ARG(mg); @@ -2272,11 +2449,14 @@ int Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) { SV * const lsv = LvTARG(sv); + char errflags = LvFLAGS(sv); PERL_ARGS_ASSERT_MAGIC_GETVEC; PERL_UNUSED_ARG(mg); - sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); + /* non-zero errflags implies deferred out-of-range condition */ + assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE))); + sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); return 0; } @@ -2394,6 +2574,15 @@ Perl_vivify_defelem(pTHX_ SV *sv) } int +Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_ARGS_ASSERT_MAGIC_SETNONELEM; + PERL_UNUSED_ARG(mg); + sv_unmagic(sv, PERL_MAGIC_nonelem); + return 0; +} + +int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; @@ -2430,13 +2619,9 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETREGEXP; - if (type == PERL_MAGIC_qr) { - } else if (type == PERL_MAGIC_bm) { - SvTAIL_off(sv); - SvVALID_off(sv); - } else { - assert(type == PERL_MAGIC_fm); - } + assert( type == PERL_MAGIC_fm + || type == PERL_MAGIC_qr + || type == PERL_MAGIC_bm); return sv_unmagic(sv, type); } @@ -2546,7 +2731,7 @@ S_set_dollarzero(pTHX_ SV *sv) * the setproctitle() routine to manipulate that. */ if (PL_origalen != 1) { s = SvPV_const(sv, len); -# if __FreeBSD_version > 410001 +# if __FreeBSD_version > 410001 || defined(__DragonFly__) /* The leading "-" removes the "perl: " prefix, * but not the "(perl) suffix from the ps(1) * output, because that's what ps(1) shows if the @@ -2649,7 +2834,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) FmLINES(PL_bodytarget) = 0; if (SvPOK(PL_bodytarget)) { char *s = SvPVX(PL_bodytarget); - while ( ((s = strchr(s, '\n'))) ) { + char *e = SvEND(PL_bodytarget); + while ( ((s = (char *) memchr(s, '\n', e - s))) ) { FmLINES(PL_bodytarget)++; s++; } @@ -2682,32 +2868,33 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') { #ifdef VMS set_vaxc_errno(SvIV(sv)); -#else -# ifdef WIN32 +#elif defined(WIN32) SetLastError( SvIV(sv) ); -# else -# ifdef OS2 +#elif defined(OS2) os2_setsyserrno(SvIV(sv)); -# else +#else /* will anyone ever use this? */ SETERRNO(SvIV(sv), 4); -# endif -# endif #endif } - else { - if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) - if (PL_localizing != 2) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "${^ENCODING} is no longer supported"); - } - } + else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) + Perl_croak(aTHX_ "${^ENCODING} is no longer supported"); break; case '\006': /* ^F */ - PL_maxsysfd = SvIV(sv); + if (mg->mg_ptr[1] == '\0') { + PL_maxsysfd = SvIV(sv); + } break; case '\010': /* ^H */ - PL_hints = SvIV(sv); + { + U32 save_hints = PL_hints; + PL_hints = SvUV(sv); + + /* If wasn't UTF-8, and now is, notify the parser */ + if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) { + notify_parser_that_changed_to_utf8(); + } + } break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ Safefree(PL_inplace); @@ -2778,30 +2965,25 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { if (!SvPOK(sv)) { + if (!specialWARN(PL_compiling.cop_warnings)) + PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_STD; break; } { STRLEN len, i; - int accumulate = 0 ; - int any_fatals = 0 ; - const char * const ptr = SvPV_const(sv, len) ; + int not_none = 0, not_all = 0; + const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; for (i = 0 ; i < len ; ++i) { - accumulate |= ptr[i] ; - any_fatals |= (ptr[i] & 0xAA) ; + not_none |= ptr[i]; + not_all |= ptr[i] ^ 0x55; } - if (!accumulate) { + if (!not_none) { if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_NONE; - } - /* Yuck. I can't see how to abstract this: */ - else if (isWARN_on( - ((STRLEN *)SvPV_nolen_const(sv)) - 1, - WARN_ALL) - && !any_fatals) - { - if (!specialWARN(PL_compiling.cop_warnings)) + } else if (len >= WARNsize && !not_all) { + if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_ALL; PL_dowarn |= G_WARN_ONCE ; @@ -2875,33 +3057,32 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '/': { - SV *tmpsv= sv; if (SvROK(sv)) { - SV *referent= SvRV(sv); - const char *reftype= sv_reftype(referent, 0); - /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative - * is to copy pretty much the entire sv_reftype() into this routine, or to do - * a full string comparison on the return of sv_reftype() both of which - * make me feel worse! NOTE, do not modify this comment without reviewing the - * corresponding comment in sv_reftype(). - Yves */ + SV *referent = SvRV(sv); + const char *reftype = sv_reftype(referent, 0); + /* XXX: dodgy type check: This leaves me feeling dirty, but + * the alternative is to copy pretty much the entire + * sv_reftype() into this routine, or to do a full string + * comparison on the return of sv_reftype() both of which + * make me feel worse! NOTE, do not modify this comment + * without reviewing the corresponding comment in + * sv_reftype(). - Yves */ if (reftype[0] == 'S' || reftype[0] == 'L') { - IV val= SvIV(referent); + IV val = SvIV(referent); if (val <= 0) { - tmpsv= &PL_sv_undef; - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef", - SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero" - ); + sv_setsv(sv, PL_rs); + Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden", + val < 0 ? "a negative integer" : "zero"); } } else { sv_setsv(sv, PL_rs); - /* diag_listed_as: Setting $/ to %s reference is forbidden */ + /* diag_listed_as: Setting $/ to %s reference is forbidden */ Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden", *reftype == 'A' ? "n" : "", reftype); } } SvREFCNT_dec(PL_rs); - PL_rs = newSVsv(tmpsv); + PL_rs = newSVsv(sv); } break; case '\\': @@ -2940,7 +3121,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #else # define PERL_VMS_BANG 0 #endif -#if defined(WIN32) && ! defined(UNDER_CE) +#if defined(WIN32) SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); #else @@ -2960,26 +3141,22 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETRUID PERL_UNUSED_RESULT(setruid(new_uid)); -#else -#ifdef HAS_SETREUID +#elif defined(HAS_SETREUID) PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1)); -#else -#ifdef HAS_SETRESUID +#elif defined(HAS_SETRESUID) PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1)); #else if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ -#ifdef PERL_DARWIN +# ifdef PERL_DARWIN /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ if (new_uid != 0 && PerlProc_getuid() == 0) PERL_UNUSED_RESULT(PerlProc_setuid(0)); -#endif +# endif PERL_UNUSED_RESULT(PerlProc_setuid(new_uid)); } else { Perl_croak(aTHX_ "setruid() not implemented"); } #endif -#endif -#endif break; } case '>': @@ -2993,11 +3170,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETEUID PERL_UNUSED_RESULT(seteuid(new_euid)); -#else -#ifdef HAS_SETREUID +#elif defined(HAS_SETREUID) PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); -#else -#ifdef HAS_SETRESUID +#elif defined(HAS_SETRESUID) PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); #else if (new_euid == PerlProc_getuid()) /* special case $> = $< */ @@ -3006,8 +3181,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "seteuid() not implemented"); } #endif -#endif -#endif break; } case '(': @@ -3021,11 +3194,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETRGID PERL_UNUSED_RESULT(setrgid(new_gid)); -#else -#ifdef HAS_SETREGID +#elif defined(HAS_SETREGID) PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); -#else -#ifdef HAS_SETRESGID +#elif defined(HAS_SETRESGID) PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1)); #else if (new_gid == PerlProc_getegid()) /* special case $( = $) */ @@ -3034,8 +3205,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setrgid() not implemented"); } #endif -#endif -#endif break; } case ')': @@ -3052,7 +3221,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; - const char* endptr; + const char* p_end = p + len; + const char* endptr = p_end; UV uv; #ifdef _SC_NGROUPS_MAX int maxgrp = sysconf(_SC_NGROUPS_MAX); @@ -3075,6 +3245,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (endptr == NULL) break; p = endptr; + endptr = p_end; while (isSPACE(*p)) ++p; if (!*p) @@ -3104,11 +3275,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } #ifdef HAS_SETEGID PERL_UNUSED_RESULT(setegid(new_egid)); -#else -#ifdef HAS_SETREGID +#elif defined(HAS_SETREGID) PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); -#else -#ifdef HAS_SETRESGID +#elif defined(HAS_SETRESGID) PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); #else if (new_egid == PerlProc_getgid()) /* special case $) = $( */ @@ -3117,8 +3286,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setegid() not implemented"); } #endif -#endif -#endif break; } case ':': @@ -3183,12 +3350,62 @@ Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) return -1; } + +/* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3(): + * these three function are intended to be called by the OS as 'C' level + * signal handler functions in the case where unsafe signals are being + * used - i.e. they immediately invoke Perl_perly_sighandler() to call the + * perl-level sighandler, rather than deferring. + * In fact, the core itself will normally use Perl_csighandler as the + * OS-level handler; that function will then decide whether to queue the + * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these + * functions are more useful for e.g. POSIX.xs when it wants explicit + * control of what's happening. + */ + + +#ifdef PERL_USE_3ARG_SIGHANDLER + Signal_t -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -Perl_sighandler(int sig, siginfo_t *sip, void *uap) +Perl_sighandler(int sig, Siginfo_t *sip, void *uap) +{ + Perl_perly_sighandler(sig, sip, uap, 0); +} + #else + +Signal_t Perl_sighandler(int sig) +{ + Perl_perly_sighandler(sig, NULL, NULL, 0); +} + #endif + +Signal_t +Perl_sighandler1(int sig) +{ + Perl_perly_sighandler(sig, NULL, NULL, 0); +} + +Signal_t +Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) +{ + Perl_perly_sighandler(sig, sip, uap, 0); +} + + +/* Invoke the perl-level signal handler. This function is called either + * directly from one of the C-level signals handlers (Perl_sighandler or + * Perl_csighandler), or for safe signals, later from + * Perl_despatch_signals() at a suitable safe point during execution. + * + * 'safe' is a boolean indicating the latter call path. + */ + +Signal_t +Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, + void *uap PERL_UNUSED_DECL, bool safe) { #ifdef PERL_GET_SIG_CONTEXT dTHXa(PERL_GET_SIG_CONTEXT); @@ -3237,7 +3454,7 @@ Perl_sighandler(int sig) : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; if (hek) Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "SIG%s handler \"%"HEKf"\" not defined.\n", + "SIG%s handler \"%" HEKf "\" not defined.\n", PL_sig_name[sig], HEKfARG(hek)); /* diag_listed_as: SIG%s handler "%s" not defined */ else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), @@ -3261,48 +3478,48 @@ Perl_sighandler(int sig) PUSHSTACKi(PERLSI_SIGNAL); PUSHMARK(SP); PUSHs(sv); + #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) { struct sigaction oact; - if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { - if (sip) { - HV *sih = newHV(); - SV *rv = newRV_noinc(MUTABLE_SV(sih)); - /* The siginfo fields signo, code, errno, pid, uid, - * addr, status, and band are defined by POSIX/SUSv3. */ - (void)hv_stores(sih, "signo", newSViv(sip->si_signo)); - (void)hv_stores(sih, "code", newSViv(sip->si_code)); -#ifdef HAS_SIGINFO_SI_ERRNO - (void)hv_stores(sih, "errno", newSViv(sip->si_errno)); -#endif -#ifdef HAS_SIGINFO_SI_STATUS - (void)hv_stores(sih, "status", newSViv(sip->si_status)); -#endif -#ifdef HAS_SIGINFO_SI_UID - { - SV *uid = newSV(0); - sv_setuid(uid, sip->si_uid); - (void)hv_stores(sih, "uid", uid); - } -#endif -#ifdef HAS_SIGINFO_SI_PID - (void)hv_stores(sih, "pid", newSViv(sip->si_pid)); -#endif -#ifdef HAS_SIGINFO_SI_ADDR - (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr))); -#endif -#ifdef HAS_SIGINFO_SI_BAND - (void)hv_stores(sih, "band", newSViv(sip->si_band)); -#endif - EXTEND(SP, 2); - PUSHs(rv); - mPUSHp((char *)sip, sizeof(*sip)); - } + if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { + HV *sih = newHV(); + SV *rv = newRV_noinc(MUTABLE_SV(sih)); + /* The siginfo fields signo, code, errno, pid, uid, + * addr, status, and band are defined by POSIX/SUSv3. */ + (void)hv_stores(sih, "signo", newSViv(sip->si_signo)); + (void)hv_stores(sih, "code", newSViv(sip->si_code)); +# ifdef HAS_SIGINFO_SI_ERRNO + (void)hv_stores(sih, "errno", newSViv(sip->si_errno)); +# endif +# ifdef HAS_SIGINFO_SI_STATUS + (void)hv_stores(sih, "status", newSViv(sip->si_status)); +# endif +# ifdef HAS_SIGINFO_SI_UID + { + SV *uid = newSV(0); + sv_setuid(uid, sip->si_uid); + (void)hv_stores(sih, "uid", uid); + } +# endif +# ifdef HAS_SIGINFO_SI_PID + (void)hv_stores(sih, "pid", newSViv(sip->si_pid)); +# endif +# ifdef HAS_SIGINFO_SI_ADDR + (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr))); +# endif +# ifdef HAS_SIGINFO_SI_BAND + (void)hv_stores(sih, "band", newSViv(sip->si_band)); +# endif + EXTEND(SP, 2); + PUSHs(rv); + mPUSHp((char *)sip, sizeof(*sip)); } } #endif + PUTBACK; errsv_save = newSVsv(ERRSV); @@ -3314,27 +3531,35 @@ Perl_sighandler(int sig) SV * const errsv = ERRSV; if (SvTRUE_NN(errsv)) { SvREFCNT_dec(errsv_save); + #ifndef PERL_MICRO - /* Handler "died", for example to get out of a restart-able read(). - * Before we re-do that on its behalf re-enable the signal which was - * blocked by the system when we entered. - */ -#ifdef HAS_SIGPROCMASK -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) - if (sip || uap) -#endif - { + /* Handler "died", for example to get out of a restart-able read(). + * Before we re-do that on its behalf re-enable the signal which was + * blocked by the system when we entered. + */ +# ifdef HAS_SIGPROCMASK + if (!safe) { + /* safe signals called via dispatch_signals() set up a + * savestack destructor, unblock_sigmask(), to + * automatically unblock the handler at the end. If + * instead we get here directly, we have to do it + * ourselves + */ sigset_t set; sigemptyset(&set); sigaddset(&set,sig); sigprocmask(SIG_UNBLOCK, &set, NULL); } -#else +# else /* Not clear if this will work */ + /* XXX not clear if this should be protected by 'if (safe)' + * too */ + (void)rsignal(sig, SIG_IGN); (void)rsignal(sig, PL_csighandlerp); -#endif +# endif #endif /* !PERL_MICRO */ + die_sv(errsv); } else { @@ -3450,6 +3675,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); + magic_sethint_feature(key, NULL, 0, sv, 0); return 0; } @@ -3474,6 +3700,10 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) MUTABLE_SV(mg->mg_ptr), 0, 0) : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), mg->mg_ptr, mg->mg_len, 0, 0)); + if (mg->mg_len == HEf_SVKEY) + magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE); + else + magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE); return 0; } @@ -3492,6 +3722,7 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); cophh_free(CopHINTHASH_get(&PL_compiling)); CopHINTHASH_set(&PL_compiling, cophh_new_empty()); + CLEARFEATUREBITS(); return 0; }