X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=e29b1c68040088658f67520b98d39c04b3f154d1;hb=80008eb3e450496f17610b8bfc820f627a758a13;hp=c6f483e8b304d8ef98c591d851762bc20f6270bc;hpb=41cb7b2bbf3884f70e9310a33e435deda35b8c46;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index c6f483e..e29b1c6 100644 --- a/mg.c +++ b/mg.c @@ -57,6 +57,10 @@ tie. # include #endif +#ifdef HAS_PRCTL_SET_NAME +# include +#endif + #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) Signal_t Perl_csighandler(int sig, siginfo_t *, void *); #else @@ -77,8 +81,9 @@ void setegid(uid_t id); struct magic_state { SV* mgs_sv; - U32 mgs_flags; I32 mgs_ss_ix; + U32 mgs_magical; + bool mgs_readonly; }; /* MGS is typedef'ed to struct magic_state in perl.h */ @@ -100,7 +105,8 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; - mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); + mgs->mgs_magical = SvMAGICAL(sv); + mgs->mgs_readonly = SvREADONLY(sv) != 0; mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ SvMAGICAL_off(sv); @@ -125,8 +131,9 @@ Perl_mg_magical(pTHX_ SV *sv) const MAGIC* mg; PERL_ARGS_ASSERT_MG_MAGICAL; PERL_UNUSED_CONTEXT; + + SvMAGICAL_off(sv); if ((mg = SvMAGIC(sv))) { - SvRMAGICAL_off(sv); do { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl) { @@ -190,8 +197,8 @@ Perl_mg_get(pTHX_ SV *sv) { dVAR; const I32 mgs_ix = SSNEW(sizeof(MGS)); - const bool was_temp = (bool)SvTEMP(sv); - int have_new = 0; + const bool was_temp = cBOOL(SvTEMP(sv)); + bool have_new = 0; MAGIC *newmg, *head, *cur, *mg; /* guard against sv having being freed midway by holding a private reference. */ @@ -216,21 +223,24 @@ Perl_mg_get(pTHX_ SV *sv) newmg = cur = head = mg = SvMAGIC(sv); while (mg) { const MGVTBL * const vtbl = mg->mg_virtual; + MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); /* guard against magic having been deleted - eg FETCH calling * untie */ - if (!SvMAGIC(sv)) + if (!SvMAGIC(sv)) { + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ break; + } - /* Don't restore the flags for this entry if it was deleted. */ + /* recalculate flags if this entry was deleted. */ if (mg->mg_flags & MGf_GSKIP) - (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; } - mg = mg->mg_moremagic; + mg = nextmg; if (have_new) { /* Have we finished with the new entries we saw? Start again @@ -247,6 +257,7 @@ Perl_mg_get(pTHX_ SV *sv) have_new = 1; cur = mg; mg = newmg; + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ } } @@ -285,7 +296,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_flags = 0; + (SSPTR(mgs_ix, MGS*))->mgs_magical = 0; } if (PL_localizing == 2 && !S_is_container_magic(mg)) continue; @@ -984,8 +995,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '^': - if (GvIOp(PL_defoutgv)) - s = IoTOP_NAME(GvIOp(PL_defoutgv)); + if (!isGV_with_GP(PL_defoutgv)) + s = ""; + else if (GvIOp(PL_defoutgv)) + s = IoTOP_NAME(GvIOp(PL_defoutgv)); if (s) sv_setpv(sv,s); else { @@ -994,22 +1007,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '~': - if (GvIOp(PL_defoutgv)) + if (!isGV_with_GP(PL_defoutgv)) + s = ""; + else if (GvIOp(PL_defoutgv)) s = IoFMT_NAME(GvIOp(PL_defoutgv)); if (!s) s = GvENAME(PL_defoutgv); sv_setpv(sv,s); break; case '=': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); break; case '-': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); break; case '%': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; case ':': @@ -1020,7 +1035,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)); break; case '|': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; case '\\': @@ -1028,22 +1043,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_copypv(sv, PL_ors_sv); break; case '!': + { + dSAVE_ERRNO; #ifdef VMS sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); - sv_setpv(sv, errno ? Strerror(errno) : ""); #else - { - dSAVE_ERRNO; sv_setnv(sv, (NV)errno); +#endif #ifdef OS2 if (errno == errno_isOS2 || errno == errno_isOS2_set) sv_setpv(sv, os2error(Perl_rc)); else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); + if (SvPOKp(sv)) + SvPOK_on(sv); /* may have got removed during taint processing */ RESTORE_ERRNO; } -#endif + SvRTRIM(sv); SvNOK_on(sv); /* what a wonderful hack! */ break; @@ -1316,13 +1333,14 @@ Perl_csighandler(int sig) #endif (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) /* Call the perl level handler now-- - * with risk we may be in malloc() etc. */ + * with risk we may be in malloc() or being destructed etc. */ #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) (*PL_sighandlerp)(sig, NULL, NULL); #else (*PL_sighandlerp)(sig); #endif else { + if (!PL_psig_pend) return; /* Set a flag to say this signal is pending, that is awaiting delivery after * the current Perl opcode completes */ PL_psig_pend[sig]++; @@ -1330,7 +1348,7 @@ Perl_csighandler(int sig) #ifndef SIG_PENDING_DIE_COUNT # define SIG_PENDING_DIE_COUNT 120 #endif - /* And one to say _a_ signal is pending */ + /* Add one to say _a_ signal is pending */ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", (unsigned long)SIG_PENDING_DIE_COUNT); @@ -1423,11 +1441,12 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) else { i = (I16)mg->mg_private; if (!i) { - mg->mg_private = i = whichsig(s); /* ...no, a brick */ + i = whichsig(s); /* ...no, a brick */ + mg->mg_private = (U16)i; } if (i <= 0) { - if (sv && ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); + if (sv) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); return 0; } #ifdef HAS_SIGPROCMASK @@ -1523,8 +1542,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if(i) LEAVE; #endif - if(to_dec) - SvREFCNT_dec(to_dec); + SvREFCNT_dec(to_dec); return 0; } #endif /* !PERL_MICRO */ @@ -1624,55 +1642,109 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) return 0; } -/* caller is responsible for stack switching/cleanup */ -STATIC int -S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) +/* +=for apidoc magic_methcall + +Invoke a magic method (like FETCH). + +* sv and mg are the tied thinggy and the tie magic; +* meth is the name of the method to call; +* n, arg1, arg2 are the number of args (in addition to $self) to pass to + the method, and the args themselves (negative n is special-cased); +* flags: + G_DISCARD: invoke method with G_DISCARD flag and don't return a value + +Returns the SV (if any) returned by the method, or NULL on failure. + + +=cut +*/ + +SV* +Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, + int n, SV *arg1, SV *arg2) { dVAR; dSP; + SV* ret = NULL; PERL_ARGS_ASSERT_MAGIC_METHCALL; + ENTER; + PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP, n); - PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { - if (mg->mg_ptr) { - if (mg->mg_len >= 0) - mPUSHp(mg->mg_ptr, mg->mg_len); - else if (mg->mg_len == HEf_SVKEY) - PUSHs(MUTABLE_SV(mg->mg_ptr)); - } - else if (mg->mg_type == PERL_MAGIC_tiedelem) { - mPUSHi(mg->mg_len); + + if (n < 0) { + /* special case for UNSHIFT */ + EXTEND(SP,-n+1); + PUSHs(SvTIED_obj(sv, mg)); + while (n++ < 0) { + PUSHs(&PL_sv_undef); } } - if (n > 2) { - PUSHs(val); + else { + EXTEND(SP,n+1); + PUSHs(SvTIED_obj(sv, mg)); + if (n > 0) { + PUSHs(arg1); + if (n > 1) PUSHs(arg2); + assert(n <= 2); + } } PUTBACK; + if (flags & G_DISCARD) { + call_method(meth, G_SCALAR|G_DISCARD); + } + else { + if (call_method(meth, G_SCALAR)) + ret = *PL_stack_sp--; + } + POPSTACK; + LEAVE; + return ret; +} + + +/* wrapper for magic_methcall that creates the first arg */ - return call_method(meth, flags); +STATIC SV* +S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, + int n, SV *val) +{ + dVAR; + SV* arg1 = NULL; + + PERL_ARGS_ASSERT_MAGIC_METHCALL1; + + if (mg->mg_ptr) { + if (mg->mg_len >= 0) { + arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + } + else if (mg->mg_len == HEf_SVKEY) + arg1 = MUTABLE_SV(mg->mg_ptr); + } + else if (mg->mg_type == PERL_MAGIC_tiedelem) { + arg1 = newSViv((IV)(mg->mg_len)); + sv_2mortal(arg1); + } + if (!arg1) { + arg1 = val; + n--; + } + return magic_methcall(sv, mg, meth, flags, n, arg1, val); } STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) { - dVAR; dSP; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_METHPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - - if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { - sv_setsv(sv, *PL_stack_sp--); - } - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); + if (ret) + sv_setsv(sv, ret); return 0; } @@ -1681,7 +1753,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_GETPACK; - if (mg->mg_ptr) + if (mg->mg_type == PERL_MAGIC_tiedelem) mg->mg_flags |= MGf_GSKIP; magic_methpack(sv,mg,"FETCH"); return 0; @@ -1690,15 +1762,32 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; + MAGIC *tmg; + SV *val; PERL_ARGS_ASSERT_MAGIC_SETPACK; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); - POPSTACK; - LEAVE; + /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to + * STORE() is not $val, but rather a PVLV (the sv in this call), whose + * public flags indicate its value based on copying from $val. Doing + * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us. + * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes + * wrong if $val happened to be tainted, as sv hasn't got magic + * enabled, even though taint magic is in the chain. In which case, + * fake up a temporary tainted value (this is easier than temporarily + * re-enabling magic on sv). */ + + if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint)) + && (tmg->mg_len & 1)) + { + val = sv_mortalcopy(sv); + SvTAINTED_on(val); + } + else + val = sv; + + magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val); return 0; } @@ -1714,69 +1803,46 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; I32 retval = 0; + SV* retsv; PERL_ARGS_ASSERT_MAGIC_SIZEPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { - sv = *PL_stack_sp--; - retval = SvIV(sv)-1; + retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL); + if (retsv) { + retval = SvIV(retsv)-1; if (retval < -1) Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); } - POPSTACK; - FREETMPS; - LEAVE; return (U32) retval; } int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; PERL_ARGS_ASSERT_MAGIC_WIPEPACK; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(sv, mg)); - PUTBACK; - call_method("CLEAR", G_SCALAR|G_DISCARD); - POPSTACK; - LEAVE; - + magic_methcall(sv, mg, "CLEAR", G_DISCARD, 0, NULL, NULL); return 0; } int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { - dVAR; dSP; - const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_NEXTPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(SvTIED_obj(sv, mg)); - if (SvOK(key)) - PUSHs(key); - PUTBACK; - - if (call_method(meth, G_SCALAR)) - sv_setsv(key, *PL_stack_sp--); - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall(sv, mg, + (SvOK(key) ? "NEXTKEY" : "FIRSTKEY"), + 0, + (SvOK(key) ? 1 : 0), key, NULL); + if (ret) + sv_setsv(key,ret); return 0; } @@ -1791,7 +1857,7 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { - dVAR; dSP; + dVAR; SV *retval; SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); HV * const pkg = SvSTASH((const SV *)SvRV(tied)); @@ -1811,19 +1877,9 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) } /* there is a SCALAR method that we can call */ - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 1); - PUSHs(tied); - PUTBACK; - - if (call_method("SCALAR", G_SCALAR)) - retval = *PL_stack_sp--; - else + retval = magic_methcall(MUTABLE_SV(hv), mg, "SCALAR", 0, 0, NULL, NULL); + if (!retval) retval = &PL_sv_undef; - POPSTACK; - LEAVE; return retval; } @@ -1878,9 +1934,8 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) if (obj) { av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop)); } else { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Attempt to set length of freed array"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Attempt to set length of freed array"); } return 0; } @@ -2000,19 +2055,19 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) STRLEN len; SV * const lsv = LvTARG(sv); const char * const tmps = SvPV_const(lsv,len); - I32 offs = LvTARGOFF(sv); - I32 rem = LvTARGLEN(sv); + STRLEN offs = LvTARGOFF(sv); + STRLEN rem = LvTARGLEN(sv); PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; PERL_UNUSED_ARG(mg); if (SvUTF8(lsv)) - sv_pos_u2b(lsv, &offs, &rem); - if (offs > (I32)len) + offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN); + if (offs > len) offs = len; - if (rem + offs > (I32)len) + if (rem > len - offs) rem = len - offs; - sv_setpvn(sv, tmps + offs, (STRLEN)rem); + sv_setpvn(sv, tmps + offs, rem); if (SvUTF8(lsv)) SvUTF8_on(sv); return 0; @@ -2025,22 +2080,22 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) STRLEN len; const char * const tmps = SvPV_const(sv, len); SV * const lsv = LvTARG(sv); - I32 lvoff = LvTARGOFF(sv); - I32 lvlen = LvTARGLEN(sv); + STRLEN lvoff = LvTARGOFF(sv); + STRLEN lvlen = LvTARGLEN(sv); PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; PERL_UNUSED_ARG(mg); if (DO_UTF8(sv)) { sv_utf8_upgrade(lsv); - sv_pos_u2b(lsv, &lvoff, &lvlen); + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); sv_insert(lsv, lvoff, lvlen, tmps, len); LvTARGLEN(sv) = sv_len_utf8(sv); SvUTF8_on(lsv); } else if (lsv && SvUTF8(lsv)) { const char *utf8; - sv_pos_u2b(lsv, &lvoff, &lvlen); + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); LvTARGLEN(sv) = len; utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); sv_insert(lsv, lvoff, lvlen, utf8, len); @@ -2051,7 +2106,6 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) LvTARGLEN(sv) = len; } - return 0; } @@ -2209,7 +2263,8 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETMGLOB; PERL_UNUSED_CONTEXT; mg->mg_len = -1; - SvSCREAM_off(sv); + if (!isGV_with_GP(sv)) + SvSCREAM_off(sv); return 0; } @@ -2325,14 +2380,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) sv_setsv(PL_bodytarget, sv); break; case '\003': /* ^C */ - PL_minus_c = (bool)SvIV(sv); + PL_minus_c = cBOOL(SvIV(sv)); break; case '\004': /* ^D */ #ifdef DEBUGGING s = SvPV_nolen_const(sv); PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; - DEBUG_x(dump_all()); + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); #else PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; #endif @@ -2355,8 +2411,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(mg->mg_ptr+1, "NCODING")) { - if (PL_encoding) - SvREFCNT_dec(PL_encoding); + SvREFCNT_dec(PL_encoding); if (SvOK(sv) || SvGMAGICAL(sv)) { PL_encoding = newSVsv(sv); } @@ -2389,31 +2444,23 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char *const start = SvPV(sv, len); const char *out = (const char*)memchr(start, '\0', len); SV *tmp; - struct refcounted_he *tmp_he; PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - PL_hints - |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; /* Opening for input is more common than opening for output, so ensure that hints for input are sooner on linked list. */ tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, - SVs_TEMP | SvUTF8(sv)) - : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv)); - - tmp_he - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, - newSVpvs_flags("open>", SVs_TEMP), - tmp); - - /* The UTF-8 setting is carried over */ - sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len); + SvUTF8(sv)) + : newSVpvs_flags("", SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); + mg_set(tmp); - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ tmp_he, - newSVpvs_flags("open<", SVs_TEMP), - tmp); + tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, + SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); + mg_set(tmp); } break; case '\020': /* ^P */ @@ -2501,29 +2548,37 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); break; case '^': - Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + if (isGV_with_GP(PL_defoutgv)) { + Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); + s = 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_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + if (isGV_with_GP(PL_defoutgv)) { + Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); + s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + } break; case '=': - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (isGV_with_GP(PL_defoutgv)) + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '-': - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); - if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) - IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; + if (isGV_with_GP(PL_defoutgv)) { + IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) + IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; + } break; case '%': - IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (isGV_with_GP(PL_defoutgv)) + IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '|': { - IO * const io = GvIOp(PL_defoutgv); + IO * const io = GvIO(PL_defoutgv); if(!io) break; if ((SvIV(sv)) == 0) @@ -2543,8 +2598,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_rs = newSVsv(sv); break; case '\\': - if (PL_ors_sv) - SvREFCNT_dec(PL_ors_sv); + SvREFCNT_dec(PL_ors_sv); if (SvOK(sv) || SvGMAGICAL(sv)) { PL_ors_sv = newSVsv(sv); } @@ -2612,7 +2666,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_uid = PerlProc_getuid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '>': PL_euid = SvIV(sv); @@ -2639,7 +2692,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_euid = PerlProc_geteuid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '(': PL_gid = SvIV(sv); @@ -2666,18 +2718,25 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_gid = PerlProc_getgid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ')': #ifdef HAS_SETGROUPS { const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; +#ifdef _SC_NGROUPS_MAX + int maxgrp = sysconf(_SC_NGROUPS_MAX); + + if (maxgrp < 0) + maxgrp = NGROUPS; +#else + int maxgrp = NGROUPS; +#endif while (isSPACE(*p)) ++p; PL_egid = Atol(p); - for (i = 0; i < NGROUPS; ++i) { + for (i = 0; i < maxgrp; ++i) { while (*p && !isSPACE(*p)) ++p; while (isSPACE(*p)) @@ -2720,7 +2779,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_egid = PerlProc_getegid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ':': PL_chopset = SvPV_force(sv,len); @@ -2786,6 +2844,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 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 UNLOCK_DOLLARZERO_MUTEX; @@ -2868,12 +2933,11 @@ Perl_sighandler(int sig) } if (!cv || !CvROOT(cv)) { - if (ckWARN(WARN_SIGNAL)) - Perl_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__"))); + 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__"))); goto cleanup; } @@ -2979,8 +3043,10 @@ S_restore_magic(pTHX_ const void *p) sv_force_normal_flags(sv, 0); #endif - if (mgs->mgs_flags) - SvFLAGS(sv) |= mgs->mgs_flags; + if (mgs->mgs_readonly) + SvREADONLY_on(sv); + if (mgs->mgs_magical) + SvFLAGS(sv) |= mgs->mgs_magical; else mg_magical(sv); if (SvGMAGICAL(sv)) { @@ -3094,6 +3160,26 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) } /* +=for apidoc magic_clearhints + +Triggered by clearing %^H, resets C. + +=cut +*/ +int +Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(mg); + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; + } + return 0; +} + +/* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4