X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8298454cd9bef3c23473ec307d99840429f2df55..d821b3b405f821ddbb82e38fa5bebf5c53658301:/mg.c diff --git a/mg.c b/mg.c index 172127c..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); @@ -556,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); @@ -594,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. @@ -607,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) { @@ -638,8 +675,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - UV uv= (UV)mg->mg_obj; - if (uv == '+') { /* @+ */ + const SSize_t n = (SSize_t)mg->mg_obj; + if (n == '+') { /* @+ */ /* return the number possible */ return RX_NPARENS(rx); } else { /* @- @^CAPTURE @{^CAPTURE} */ @@ -650,7 +687,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) && (RX_OFFS(rx)[paren].start == -1 || RX_OFFS(rx)[paren].end == -1) ) paren--; - if (uv == '-') { + if (n == '-') { /* @- */ return (U32)paren; } else { @@ -674,10 +711,10 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - const UV uv= (UV)mg->mg_obj; + 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 - + (uv == '\003' ? 1 : 0); + + (n == '\003' ? 1 : 0); SSize_t s; SSize_t t; if (paren < 0) @@ -688,9 +725,9 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { SSize_t i; - if (uv == '+') /* @+ */ + if (n == '+') /* @+ */ i = t; - else if (uv == '-') /* @- */ + else if (n == '-') /* @- */ i = s; else { /* @^CAPTURE @{^CAPTURE} */ CALLREG_NUMBUF_FETCH(rx,paren,sv); @@ -710,7 +747,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) } } } - sv_setsv(sv, NULL); + sv_set_undef(sv); return 0; } @@ -782,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 @@ -849,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; } @@ -900,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 '!': { @@ -918,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; } @@ -935,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")) { @@ -944,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); @@ -960,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 */ @@ -976,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) @@ -984,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') { @@ -1017,14 +1124,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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), @@ -1138,9 +1238,9 @@ 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++) @@ -1378,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. */ @@ -1398,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; @@ -1423,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 @@ -1505,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; @@ -1656,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) @@ -1825,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); @@ -2061,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; } @@ -2090,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; } @@ -2139,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; } @@ -2149,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; @@ -2171,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; } @@ -2198,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); @@ -2230,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); @@ -2306,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; } @@ -2428,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; @@ -2679,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++; } @@ -2712,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) { - deprecate_fatal_in("5.28", - "${^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); @@ -2808,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 ; @@ -2905,10 +3057,9 @@ 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); + 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 @@ -2917,23 +3068,21 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) * 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. This will be fatal in Perl 5.28", - 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 '\\': @@ -2972,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 @@ -2992,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 '>': @@ -3025,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 $> = $< */ @@ -3038,8 +3181,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "seteuid() not implemented"); } #endif -#endif -#endif break; } case '(': @@ -3053,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 $( = $) */ @@ -3066,8 +3205,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setrgid() not implemented"); } #endif -#endif -#endif break; } case ')': @@ -3084,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); @@ -3107,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) @@ -3136,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 $) = $( */ @@ -3149,8 +3286,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setegid() not implemented"); } #endif -#endif -#endif break; } case ':': @@ -3215,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); @@ -3293,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); @@ -3346,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 { @@ -3482,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; } @@ -3506,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; } @@ -3524,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; }