X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ac892e4a230de5bdb9243ef5c82b0fb5be7f8975..d821b3b405f821ddbb82e38fa5bebf5c53658301:/mg.c diff --git a/mg.c b/mg.c index 054d839..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); @@ -127,7 +122,7 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) /* =for apidoc mg_magical -Turns on the magical status of an SV. See C. +Turns on the magical status of an SV. See C>. =cut */ @@ -160,7 +155,7 @@ Perl_mg_magical(SV *sv) =for apidoc mg_get Do magic before a value is retrieved from the SV. The type of SV must -be >= SVt_PVMG. See C. +be >= C. See C>. =cut */ @@ -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; @@ -245,7 +259,7 @@ Perl_mg_get(pTHX_ SV *sv) /* =for apidoc mg_set -Do magic after a value is assigned to the SV. See C. +Do magic after a value is assigned to the SV. See C>. =cut */ @@ -285,10 +299,10 @@ Perl_mg_set(pTHX_ SV *sv) =for apidoc mg_length Reports on the SV's length in bytes, calling length magic if available, -but does not set the UTF8 flag on the sv. It will fall back to 'get' +but does not set the UTF8 flag on C. It will fall back to 'get' magic if there is no 'length' magic, but with no indication as to -whether it called 'get' magic. It assumes the sv is a PVMG or -higher. Use sv_len() instead. +whether it called 'get' magic. It assumes C is a C or +higher. Use C instead. =cut */ @@ -352,7 +366,7 @@ Perl_mg_size(pTHX_ SV *sv) /* =for apidoc mg_clear -Clear something magical that the SV represents. See C. +Clear something magical that the SV represents. See C>. =cut */ @@ -403,7 +417,7 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) /* =for apidoc mg_find -Finds the magic pointer for type matching the SV. See C. +Finds the magic pointer for C matching the SV. See C>. =cut */ @@ -418,7 +432,7 @@ Perl_mg_find(const SV *sv, int type) =for apidoc mg_findext Finds the magic pointer of C with the given C for the C. See -C. +C>. =cut */ @@ -447,7 +461,7 @@ Perl_mg_find_mglob(pTHX_ SV *sv) /* =for apidoc mg_copy -Copies the magic from one SV to another. See C. +Copies the magic from one SV to another. See C>. =cut */ @@ -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++; } @@ -486,12 +498,12 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) =for apidoc mg_localize Copy some of the magic from an existing SV to new localized version of that -SV. Container magic (eg %ENV, $1, tie) -gets copied, value magic doesn't (eg -taint, pos). +SV. Container magic (I, C<%ENV>, C<$1>, C) +gets copied, value magic doesn't (I, +C, C). -If setmagic is false then no set magic will be called on the new (empty) SV. -This typically means that assignment will soon follow (e.g. 'local $x = $y'), +If C is false then no set magic will be called on the new (empty) SV. +This typically means that assignment will soon follow (e.g. S>), and that will handle the magic. =cut @@ -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); @@ -553,7 +571,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) /* =for apidoc mg_free -Free any magic storage used by the SV. See C. +Free any magic storage used by the SV. See C>. =cut */ @@ -577,9 +595,9 @@ 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 I from the SV I. See L. +Remove any magic of type C from the SV C. See L. =cut */ @@ -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,9 +781,9 @@ 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 { - sv_setpvs(sv, ""); + SvPVCLEAR(sv); SvUTF8_off(sv); if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { SV *const value = cop_hints_fetch_pvs(c, "open<", 0); @@ -750,60 +819,76 @@ 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_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); } } } -SV* -Perl__get_encoding(pTHX) -{ - /* For core Perl use only: Returns the $^ENCODING or 'use encoding' in - * effect; NULL if none. - * - * $^ENCODING maps to PL_encoding, and is the old way to do things, and is - * retained for backwards compatibility. Now, there is a shadow variable - * ${^E_NCODING} set only by the encoding pragma, used to give this pragma - * lexical scope, unlike the global scope it (shudder) used to have. This - * variable maps to PL_lex_encoding. Again for backwards compatibility, - * PL_encoding has precedence over PL_lex_encoding. The hints hash is used - * to determine if PL_lex_encoding is in scope, and hence valid. The hints - * hash only accepts simple values, so we can't put an Encode object into - * it, so we put the object into the global, and put a simple boolean into - * the hints hash giving whether the global is valid or not */ - - dVAR; - SV *is_encoding; - - if (PL_encoding) { - return PL_encoding; - } +/* +=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. - if (! PL_lex_encoding) { - return NULL; - } +=cut +*/ - is_encoding = cop_hints_fetch_pvs(PL_curcop, "encoding", 0); - if ( is_encoding - && is_encoding != &PL_sv_placeholder - && SvIOK(is_encoding) - && SvIV(is_encoding)) /* non-zero mean valid */ - { - return PL_lex_encoding; +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 NULL; + return tgtsv; } #ifdef VMS @@ -827,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; } @@ -837,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; @@ -856,9 +942,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\005': /* ^E */ if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) - sv_setsv(sv, _get_encoding()); - else if (strEQ(remaining, "_NCODING")) - sv_setsv(sv, NULL); + sv_set_undef(sv); break; } @@ -871,7 +955,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); else - sv_setpvs(sv,""); + SvPVCLEAR(sv); } #elif defined(OS2) if (!(_emx_env & 0x200)) { /* Under DOS */ @@ -898,7 +982,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) fixup_errno_string(sv); } else - sv_setpvs(sv, ""); + SvPVCLEAR(sv); SetLastError(dwErr); } # else @@ -909,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 '!': { @@ -924,17 +1009,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else #endif if (! errno) { - sv_setpvs(sv, ""); + 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; } @@ -944,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")) { @@ -953,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); @@ -969,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 */ @@ -985,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) @@ -993,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,30 +1115,27 @@ 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), *PL_compiling.cop_warnings); } } +#ifdef WIN32 + else if (strEQ(remaining, "IN32_SLOPPY_STAT")) { + sv_setiv(sv, w32_sloppystat); + } +#endif break; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { @@ -1048,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))); @@ -1116,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 '$': /* $$ */ { @@ -1145,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); } } @@ -1162,6 +1255,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; } return 0; + + set_undef: + sv_set_undef(sv); + return 0; } int @@ -1210,13 +1307,13 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } #endif -#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) +#if !defined(OS2) && !defined(WIN32) && !defined(MSDOS) /* And you'll never guess what the dog had */ /* in its mouth... */ if (TAINTING_get) { MgTAINTEDDIR_off(mg); #ifdef VMS - if (s && klen == 8 && strEQ(key, "DCL$PATH")) { + if (s && memEQs(key, klen, "DCL$PATH")) { char pathbuf[256], eltbuf[256], *cp, *elt; int i = 0, j = 0; @@ -1242,24 +1339,29 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); } #endif /* VMS */ - if (s && klen == 4 && strEQ(key,"PATH")) { + if (s && memEQs(key, klen, "PATH")) { const char * const strend = s + len; + /* set MGf_TAINTEDDIR if any component of the new path is + * relative or world-writeable */ while (s < strend) { char tmpbuf[256]; Stat_t st; I32 i; -#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */ - const char path_sep = '|'; +#ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */ + const char path_sep = PL_perllib_sep; #else const char path_sep = ':'; #endif - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, + s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, strend, path_sep, &i); s++; if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ -#ifdef VMS - || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */ +#ifdef __VMS + /* no colon thus no device name -- assume relative path */ + || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) + /* Using Unix separator, e.g. under bash, so act line Unix */ + || (PL_perllib_sep == ':' && *tmpbuf != '/') #else || *tmpbuf != '/' /* no starting slash -- assume relative path */ #endif @@ -1270,7 +1372,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } } } -#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ +#endif /* neither OS2 nor WIN32 nor MSDOS */ return 0; } @@ -1360,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); } @@ -1376,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. */ @@ -1396,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; @@ -1421,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 @@ -1503,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; @@ -1654,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) @@ -1782,7 +1928,7 @@ The C can be: The arguments themselves are any values following the C argument. -Returns the SV (if any) returned by the method, or NULL on failure. +Returns the SV (if any) returned by the method, or C on failure. =cut @@ -1810,7 +1956,9 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, argc+1); + /* EXTEND() expects a signed argc; don't wrap when casting */ + assert(argc <= I32_MAX); + EXTEND(SP, (I32)argc+1); PUSHs(SvTIED_obj(sv, mg)); if (flags & G_UNDEF_FILL) { while (argc--) { @@ -1821,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); @@ -2019,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); } @@ -2057,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; } @@ -2086,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; } @@ -2135,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; } @@ -2145,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; @@ -2167,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; } @@ -2194,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); @@ -2206,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; } @@ -2226,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); @@ -2302,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; } @@ -2424,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; @@ -2460,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); } @@ -2561,13 +2716,92 @@ Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) return 0; } +static void +S_set_dollarzero(pTHX_ SV *sv) + PERL_TSA_REQUIRES(PL_dollarzero_mutex) +{ +#ifdef USE_ITHREADS + dVAR; +#endif + const char *s; + STRLEN len; +#ifdef HAS_SETPROCTITLE + /* The BSDs don't show the argv[] in ps(1) output, they + * show a string from the process struct and provide + * the setproctitle() routine to manipulate that. */ + if (PL_origalen != 1) { + s = SvPV_const(sv, len); +# 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 + * argv[] is modified. */ + setproctitle("-%s", s); +# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ + /* This doesn't really work if you assume that + * $0 = 'foobar'; will wipe out 'perl' from the $0 + * because in ps(1) output the result will be like + * sprintf("perl: %s (perl)", s) + * I guess this is a security feature: + * one (a user process) cannot get rid of the original name. + * --jhi */ + setproctitle("%s", s); +# endif + } +#elif defined(__hpux) && defined(PSTAT_SETCMD) + if (PL_origalen != 1) { + union pstun un; + s = SvPV_const(sv, len); + un.pst_command = (char *)s; + pstat(PSTAT_SETCMD, un, len, 0, 0); + } +#else + if (PL_origalen > 1) { + I32 i; + /* PL_origalen is set in perl_parse(). */ + s = SvPV_force(sv,len); + if (len >= (STRLEN)PL_origalen-1) { + /* Longer than original, will be truncated. We assume that + * PL_origalen bytes are available. */ + Copy(s, PL_origargv[0], PL_origalen-1, char); + } + else { + /* Shorter than original, will be padded. */ +#ifdef PERL_DARWIN + /* Special case for Mac OS X: see [perl #38868] */ + const int pad = 0; +#else + /* Is the space counterintuitive? Yes. + * (You were expecting \0?) + * Does it work? Seems to. (In Linux 2.4.20 at least.) + * --jhi */ + const int pad = ' '; +#endif + Copy(s, PL_origargv[0], len, char); + PL_origargv[0][len] = 0; + memset(PL_origargv[0] + len + 1, + pad, PL_origalen - len - 1); + } + PL_origargv[0][PL_origalen-1] = 0; + for (i = 1; i < PL_origargc; i++) + PL_origargv[i] = 0; +#ifdef HAS_PRCTL_SET_NAME + /* Set the legacy process name in addition to the POSIX name on Linux */ + if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { + /* diag_listed_as: SKIPME */ + Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); + } +#endif + } +#endif +} + int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { #ifdef USE_ITHREADS dVAR; #endif - const char *s; I32 paren; const REGEXP * rx; I32 i; @@ -2600,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++; } @@ -2619,10 +2854,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '\004': /* ^D */ #ifdef DEBUGGING - s = SvPV_nolen_const(sv); - PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; - if (DEBUG_x_TEST || DEBUG_B_TEST) - dump_all_perl(!DEBUG_B_TEST); + { + const char *s = SvPV_nolen_const(sv); + PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); + } #else PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; #endif @@ -2631,62 +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 { - unsigned int offset = 1; - bool lex = FALSE; - - /* It may be the shadow variable ${E_NCODING} which has lexical - * scope. See comments at Perl__get_encoding in this file */ - if (*(mg->mg_ptr + 1) == '_') { - if (CopSTASH(PL_curcop) != get_hv("encoding::",0)) - Perl_croak_no_modify(); - lex = TRUE; - offset++; - } - if (strEQ(mg->mg_ptr + offset, "NCODING")) { - if (lex) { /* Use the shadow global */ - SvREFCNT_dec(PL_lex_encoding); - if (SvOK(sv) || SvGMAGICAL(sv)) { - PL_lex_encoding = newSVsv(sv); - } - else { - PL_lex_encoding = NULL; - } - } - else { /* Use the regular global */ - SvREFCNT_dec(PL_encoding); - if (SvOK(sv) || SvGMAGICAL(sv)) { - if (PL_localizing != 2) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Setting ${^ENCODING} is deprecated"); - } - PL_encoding = newSVsv(sv); - } - else { - PL_encoding = NULL; - } - } - } - } + 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); @@ -2757,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 ; @@ -2800,6 +3003,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } } +#ifdef WIN32 + else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) { + w32_sloppystat = (bool)sv_true(sv); + } +#endif break; case '.': if (PL_localizing) { @@ -2811,12 +3019,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '^': Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); break; case '~': Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); break; case '=': @@ -2849,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 '\\': @@ -2914,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 @@ -2934,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 '>': @@ -2967,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 $> = $< */ @@ -2980,8 +3181,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "seteuid() not implemented"); } #endif -#endif -#endif break; } case '(': @@ -2995,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 $( = $) */ @@ -3008,8 +3205,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setrgid() not implemented"); } #endif -#endif -#endif break; } case ')': @@ -3026,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); @@ -3049,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) @@ -3078,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 $) = $( */ @@ -3091,8 +3286,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "setegid() not implemented"); } #endif -#endif -#endif break; } case ':': @@ -3111,74 +3304,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '0': LOCK_DOLLARZERO_MUTEX; -#ifdef HAS_SETPROCTITLE - /* The BSDs don't show the argv[] in ps(1) output, they - * show a string from the process struct and provide - * the setproctitle() routine to manipulate that. */ - if (PL_origalen != 1) { - s = SvPV_const(sv, len); -# if __FreeBSD_version > 410001 - /* 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 - * argv[] is modified. */ - setproctitle("-%s", s); -# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ - /* This doesn't really work if you assume that - * $0 = 'foobar'; will wipe out 'perl' from the $0 - * because in ps(1) output the result will be like - * sprintf("perl: %s (perl)", s) - * I guess this is a security feature: - * one (a user process) cannot get rid of the original name. - * --jhi */ - setproctitle("%s", s); -# endif - } -#elif defined(__hpux) && defined(PSTAT_SETCMD) - if (PL_origalen != 1) { - union pstun un; - s = SvPV_const(sv, len); - un.pst_command = (char *)s; - pstat(PSTAT_SETCMD, un, len, 0, 0); - } -#else - if (PL_origalen > 1) { - /* PL_origalen is set in perl_parse(). */ - s = SvPV_force(sv,len); - if (len >= (STRLEN)PL_origalen-1) { - /* Longer than original, will be truncated. We assume that - * PL_origalen bytes are available. */ - Copy(s, PL_origargv[0], PL_origalen-1, char); - } - else { - /* Shorter than original, will be padded. */ -#ifdef PERL_DARWIN - /* Special case for Mac OS X: see [perl #38868] */ - const int pad = 0; -#else - /* Is the space counterintuitive? Yes. - * (You were expecting \0?) - * Does it work? Seems to. (In Linux 2.4.20 at least.) - * --jhi */ - const int pad = ' '; -#endif - Copy(s, PL_origargv[0], len, char); - PL_origargv[0][len] = 0; - memset(PL_origargv[0] + len + 1, - pad, PL_origalen - len - 1); - } - PL_origargv[0][PL_origalen-1] = 0; - for (i = 1; i < PL_origargc; i++) - PL_origargv[i] = 0; -#ifdef HAS_PRCTL_SET_NAME - /* Set the legacy process name in addition to the POSIX name on Linux */ - if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { - /* diag_listed_as: SKIPME */ - Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); - } -#endif - } -#endif + S_set_dollarzero(aTHX_ sv); UNLOCK_DOLLARZERO_MUTEX; break; } @@ -3224,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); @@ -3278,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), @@ -3302,34 +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)); -#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */ - hv_stores(sih, "errno", newSViv(sip->si_errno)); - hv_stores(sih, "status", newSViv(sip->si_status)); - hv_stores(sih, "uid", newSViv(sip->si_uid)); - hv_stores(sih, "pid", newSViv(sip->si_pid)); - hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr))); - 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); @@ -3341,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 { @@ -3395,12 +3593,6 @@ S_restore_magic(pTHX_ const void *p) if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ -#ifdef PERL_OLD_COPY_ON_WRITE - /* While magic was saved (and off) sv_setsv may well have seen - this SV as a prime candidate for COW. */ - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); -#endif if (mgs->mgs_flags) SvFLAGS(sv) |= mgs->mgs_flags; else @@ -3457,7 +3649,7 @@ S_unwind_handler_stack(pTHX_ const void *p) /* =for apidoc magic_sethint -Triggered by a store to %^H, records the key/value pair to +Triggered by a store to C<%^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. @@ -3483,13 +3675,14 @@ 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; } /* =for apidoc magic_clearhint -Triggered by a delete from %^H, records the key to +Triggered by a delete from C<%^H>, records the key to C. =cut @@ -3507,13 +3700,17 @@ 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; } /* =for apidoc magic_clearhints -Triggered by clearing %^H, resets C. +Triggered by clearing C<%^H>, resets C. =cut */ @@ -3525,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; }