X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d28a9254e445aee7212523d9a7ff62ae0a743fec..a5c7cb08f7954af4accf63bfffaab1bd61f1dd68:/mg.c diff --git a/mg.c b/mg.c index 01fa6b4..d0d3b9d 100644 --- a/mg.c +++ b/mg.c @@ -84,8 +84,7 @@ void setegid(uid_t id); struct magic_state { SV* mgs_sv; I32 mgs_ss_ix; - U32 mgs_magical; - bool mgs_readonly; + U32 mgs_flags; bool mgs_bumped; }; /* MGS is typedef'ed to struct magic_state in perl.h */ @@ -115,8 +114,7 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; - mgs->mgs_magical = SvMAGICAL(sv); - mgs->mgs_readonly = SvREADONLY(sv) != 0; + mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ mgs->mgs_bumped = bumped; @@ -129,7 +127,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 */ @@ -162,7 +160,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 */ @@ -201,13 +199,15 @@ Perl_mg_get(pTHX_ SV *sv) /* guard against magic having been deleted - eg FETCH calling * untie */ if (!SvMAGIC(sv)) { - (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); break; } /* recalculate flags if this entry was deleted. */ if (mg->mg_flags & MGf_GSKIP) - (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; + (SSPTR(mgs_ix, MGS *))->mgs_flags &= + ~(SVs_GMG|SVs_SMG|SVs_RMG); } else if (vtbl == &PL_vtbl_utf8) { /* get-magic can reallocate the PV */ @@ -231,7 +231,8 @@ Perl_mg_get(pTHX_ SV *sv) have_new = 1; cur = mg; mg = newmg; - (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); } } @@ -244,7 +245,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 */ @@ -267,7 +268,7 @@ Perl_mg_set(pTHX_ SV *sv) nextmg = mg->mg_moremagic; /* it may delete itself */ if (mg->mg_flags & MGf_GSKIP) { mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - (SSPTR(mgs_ix, MGS*))->mgs_magical = 0; + (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); } if (PL_localizing == 2 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) @@ -284,10 +285,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 */ @@ -351,7 +352,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 */ @@ -389,8 +390,6 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) if (sv) { MAGIC *mg; - assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { return mg; @@ -404,7 +403,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 */ @@ -419,7 +418,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 */ @@ -448,7 +447,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 */ @@ -472,9 +471,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++; } @@ -487,12 +484,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 @@ -554,7 +551,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 */ @@ -580,7 +577,7 @@ Perl_mg_free(pTHX_ SV *sv) /* =for apidoc Am|void|mg_free_type|SV *sv|int how -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 */ @@ -620,12 +617,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) { /* @+ */ + UV uv= (UV)mg->mg_obj; + if (uv == '+') { /* @+ */ /* return the number possible */ return RX_NPARENS(rx); - } else { /* @- */ + } else { /* @- @^CAPTURE @{^CAPTURE} */ I32 paren = RX_LASTPAREN(rx); /* return the last filled */ @@ -633,8 +631,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 (uv == '-') { + /* @- */ + return (U32)paren; + } else { + /* @^CAPTURE @{^CAPTURE} */ + return paren >= 0 ? (U32)(paren-1) : (U32)-1; + } + } } } @@ -649,9 +653,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 UV uv= (UV)mg->mg_obj; + /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ + const I32 paren = mg->mg_len + + (uv == '\003' ? 1 : 0); SSize_t s; SSize_t t; if (paren < 0) @@ -661,10 +668,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 (uv == '+') /* @+ */ i = t; - else /* @- */ + else if (uv == '-') /* @- */ 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); @@ -715,7 +727,7 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) sv_setsv(sv, &PL_sv_undef); 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,15 +762,16 @@ S_fixup_errno_string(pTHX_ SV* sv) * case we should turn on that flag. This didn't use to happen, and to * 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 ASCII 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" (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) */ + * 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" + * (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_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv)) + && ! is_utf8_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))) { SvUTF8_on(sv); @@ -816,7 +829,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\005': /* ^E */ if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) - sv_setsv(sv, PL_encoding); + sv_setsv(sv, NULL); break; } @@ -829,7 +842,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 */ @@ -856,7 +869,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) fixup_errno_string(sv); } else - sv_setpvs(sv, ""); + SvPVCLEAR(sv); SetLastError(dwErr); } # else @@ -882,7 +895,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else #endif if (! errno) { - sv_setpvs(sv, ""); + SvPVCLEAR(sv); } else { @@ -999,6 +1012,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) *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))) { @@ -1061,7 +1079,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; case ':': - break; case '/': break; case '[': @@ -1169,13 +1186,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; @@ -1201,24 +1218,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 @@ -1229,7 +1251,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; } @@ -1347,12 +1369,14 @@ Perl_csighandler(int sig) #else dTHX; #endif +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) #if defined(__cplusplus) && defined(__GNUC__) /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap * parameters would be warned about. */ PERL_UNUSED_ARG(sip); PERL_UNUSED_ARG(uap); #endif +#endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); if (PL_sig_ignoring[sig]) return; @@ -1739,7 +1763,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 @@ -1759,6 +1783,7 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, if (flags & G_WRITING_TO_STDERR) { SAVETMPS; + save_re_context(); SAVESPTR(PL_stderrgv); PL_stderrgv = NULL; } @@ -1766,7 +1791,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--) { @@ -2416,13 +2443,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); } @@ -2461,12 +2484,148 @@ Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) } int -Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) +Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) +{ + const char *bad = NULL; + PERL_ARGS_ASSERT_MAGIC_SETLVREF; + if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference"); + switch (mg->mg_private & OPpLVREF_TYPE) { + case OPpLVREF_SV: + if (SvTYPE(SvRV(sv)) > SVt_PVLV) + bad = " SCALAR"; + break; + case OPpLVREF_AV: + if (SvTYPE(SvRV(sv)) != SVt_PVAV) + bad = "n ARRAY"; + break; + case OPpLVREF_HV: + if (SvTYPE(SvRV(sv)) != SVt_PVHV) + bad = " HASH"; + break; + case OPpLVREF_CV: + if (SvTYPE(SvRV(sv)) != SVt_PVCV) + bad = " CODE"; + } + if (bad) + /* diag_listed_as: Assigned value is not %s reference */ + Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); + switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) { + case 0: + { + SV * const old = PAD_SV(mg->mg_len); + PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); + SvREFCNT_dec(old); + break; + } + case SVt_PVGV: + gv_setref(mg->mg_obj, sv); + SvSETMAGIC(mg->mg_obj); + break; + case SVt_PVAV: + av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), + SvREFCNT_inc_simple_NN(SvRV(sv))); + break; + case SVt_PVHV: + (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, + SvREFCNT_inc_simple_NN(SvRV(sv)), 0); + } + if (mg->mg_flags & MGf_PERSIST) + NOOP; /* This sv is in use as an iterator var and will be reused, + so we must leave the magic. */ + else + /* This sv could be returned by the assignment op, so clear the + magic, as lvrefs are an implementation detail that must not be + leaked to the user. */ + sv_unmagic(sv, PERL_MAGIC_lvref); + 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 + /* 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 I32 paren; const REGEXP * rx; I32 i; @@ -2518,10 +2677,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 @@ -2543,15 +2704,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # endif #endif } - else if (strEQ(mg->mg_ptr+1, "NCODING")) { - SvREFCNT_dec(PL_encoding); - if (SvOK(sv) || SvGMAGICAL(sv)) { - PL_encoding = newSVsv(sv); - } - else { - PL_encoding = NULL; - } - } + 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"); + } + } break; case '\006': /* ^F */ PL_maxsysfd = SvIV(sv); @@ -2671,6 +2830,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) { @@ -2682,12 +2846,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 '=': @@ -2733,12 +2897,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) IV val= SvIV(referent); if (val <= 0) { tmpsv= &PL_sv_undef; - Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + 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" ); } } else { + sv_setsv(sv, PL_rs); /* diag_listed_as: Setting $/ to %s reference is forbidden */ Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden", *reftype == 'A' ? "n" : "", reftype); @@ -2884,6 +3049,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } case ')': { +/* (hv) best guess: maybe we'll need configure probes to do a better job, + * but you can override it if you need to. + */ +#ifndef INVALID_GID +#define INVALID_GID ((Gid_t)-1) +#endif /* XXX $) currently silently ignores failures */ Gid_t new_egid; #ifdef HAS_SETGROUPS @@ -2891,6 +3062,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; const char* endptr; + UV uv; #ifdef _SC_NGROUPS_MAX int maxgrp = sysconf(_SC_NGROUPS_MAX); @@ -2902,7 +3074,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) while (isSPACE(*p)) ++p; - new_egid = (Gid_t)grok_atou(p, &endptr); + if (grok_atoUV(p, &uv, &endptr)) + new_egid = (Gid_t)uv; + else { + new_egid = INVALID_GID; + endptr = NULL; + } for (i = 0; i < maxgrp; ++i) { if (endptr == NULL) break; @@ -2915,7 +3092,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Newx(gary, i + 1, Groups_t); else Renew(gary, i + 1, Groups_t); - gary[i] = (Groups_t)grok_atou(p, &endptr); + if (grok_atoUV(p, &uv, &endptr)) + gary[i] = (Groups_t)uv; + else { + gary[i] = INVALID_GID; + endptr = NULL; + } } if (i) PERL_UNUSED_RESULT(setgroups(i, gary)); @@ -2964,74 +3146,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; } @@ -3124,11 +3239,19 @@ Perl_sighandler(int sig) } if (!cv || !CvROOT(cv)) { - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", - PL_sig_name[sig], (gv ? GvENAME(gv) - : ((cv && CvGV(cv)) - ? GvENAME(CvGV(cv)) - : "__ANON__"))); + const HEK * const hek = gv + ? GvENAME_HEK(gv) + : cv && CvNAMED(cv) + ? CvNAME_HEK(cv) + : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; + if (hek) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "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), + "SIG%s handler \"__ANON__\" not defined.\n", + PL_sig_name[sig]); goto cleanup; } @@ -3159,13 +3282,27 @@ Perl_sighandler(int sig) * 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)); +#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); @@ -3215,7 +3352,7 @@ Perl_sighandler(int sig) } } -cleanup: + cleanup: /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ PL_savestack_ix = old_ss_ix; if (flags & 8) @@ -3240,16 +3377,8 @@ 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_readonly) - SvREADONLY_on(sv); - if (mgs->mgs_magical) - SvFLAGS(sv) |= mgs->mgs_magical; + if (mgs->mgs_flags) + SvFLAGS(sv) |= mgs->mgs_flags; else mg_magical(sv); } @@ -3304,7 +3433,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. @@ -3336,7 +3465,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) /* =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 @@ -3360,7 +3489,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) /* =for apidoc magic_clearhints -Triggered by clearing %^H, resets C. +Triggered by clearing C<%^H>, resets C. =cut */ @@ -3396,12 +3525,33 @@ Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, return 1; } +int +Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR; + +#if DBVARMG_SINGLE != 0 + assert(mg->mg_private >= DBVARMG_SINGLE); +#endif + assert(mg->mg_private < DBVARMG_COUNT); + + PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv); + + return 1; +} + +int +Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR; + +#if DBVARMG_SINGLE != 0 + assert(mg->mg_private >= DBVARMG_SINGLE); +#endif + assert(mg->mg_private < DBVARMG_COUNT); + sv_setiv(sv, PL_DBcontrol[mg->mg_private]); + + return 0; +} + /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */