I32 mgs_ss_ix;
U32 mgs_magical;
bool mgs_readonly;
+ bool mgs_bumped;
};
/* MGS is typedef'ed to struct magic_state in perl.h */
{
dVAR;
MGS* mgs;
+ bool bumped = FALSE;
PERL_ARGS_ASSERT_SAVE_MAGIC;
+ /* we shouldn't really be called here with RC==0, but it can sometimes
+ * happen via mg_clear() (which also shouldn't be called when RC==0,
+ * but it can happen). Handle this case gracefully(ish) by not RC++
+ * and thus avoiding the resultant double free */
+ if (SvREFCNT(sv) > 0) {
+ /* guard against sv getting freed midway through the mg clearing,
+ * by holding a private reference for the duration. */
+ SvREFCNT_inc_simple_void_NN(sv);
+ bumped = TRUE;
+ }
+
assert(SvMAGICAL(sv));
/* Turning READONLY off for a copy-on-write scalar (including shared
hash keys) is a bad idea. */
mgs->mgs_magical = SvMAGICAL(sv);
mgs->mgs_readonly = SvREADONLY(sv) != 0;
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
+ mgs->mgs_bumped = bumped;
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
}
}
-
-/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
-
-STATIC bool
-S_is_container_magic(const MAGIC *mg)
-{
- assert(mg);
- switch (mg->mg_type) {
- case PERL_MAGIC_bm:
- case PERL_MAGIC_fm:
- case PERL_MAGIC_regex_global:
- case PERL_MAGIC_nkeys:
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
-#endif
- case PERL_MAGIC_qr:
- case PERL_MAGIC_taint:
- case PERL_MAGIC_vec:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_utf8:
- case PERL_MAGIC_substr:
- case PERL_MAGIC_defelem:
- case PERL_MAGIC_arylen:
- case PERL_MAGIC_pos:
- case PERL_MAGIC_backref:
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
- case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
- case PERL_MAGIC_checkcall:
- return 0;
- default:
- return 1;
- }
-}
-
/*
=for apidoc mg_get
{
dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
- 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. */
PERL_ARGS_ASSERT_MG_GET;
- /* sv_2mortal has this side effect of turning on the TEMP flag, which can
- cause the SV's buffer to get stolen (and maybe other stuff).
- So restore it.
- */
- sv_2mortal(SvREFCNT_inc_simple_NN(sv));
- if (!was_temp) {
- SvTEMP_off(sv);
- }
-
save_magic(mgs_ix, sv);
/* We must call svt_get(sv, mg) for each valid entry in the linked
}
restore_magic(INT2PTR(void *, (IV)mgs_ix));
-
- if (SvREFCNT(sv) == 1) {
- /* We hold the last reference to this SV, which implies that the
- SV was deleted as a side effect of the routines we called. */
- SvOK_off(sv);
- }
return 0;
}
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
(SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
}
- if (PL_localizing == 2 && !S_is_container_magic(mg))
+ if (PL_localizing == 2
+ && (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type) || sv == DEFSV))
continue;
if (vtbl && vtbl->svt_set)
vtbl->svt_set(aTHX_ sv, mg);
return 0;
}
+static MAGIC*
+S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
+{
+ PERL_UNUSED_CONTEXT;
+
+ assert(flags <= 1);
+
+ if (sv) {
+ MAGIC *mg;
+
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
+ return mg;
+ }
+ }
+ }
+
+ return NULL;
+}
+
/*
=for apidoc mg_find
MAGIC*
Perl_mg_find(pTHX_ const SV *sv, int type)
{
- PERL_UNUSED_CONTEXT;
- if (sv) {
- MAGIC *mg;
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- if (mg->mg_type == type)
- return mg;
- }
- }
- return NULL;
+ return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
+}
+
+/*
+=for apidoc mg_findext
+
+Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
+C<sv_magicext>.
+
+=cut
+*/
+
+MAGIC*
+Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
+{
+ return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
}
/*
PERL_ARGS_ASSERT_MG_LOCALIZE;
+ if (nsv == DEFSV)
+ return;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
- if (!S_is_container_magic(mg))
+ if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
continue;
if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
mg->mg_ptr, mg->mg_len);
/* container types should remain read-only across localization */
- SvFLAGS(nsv) |= SvREADONLY(sv);
+ if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
}
if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
switch (*mg->mg_ptr) {
case '\001': /* ^A */
sv_setsv(sv, PL_bodytarget);
+ if (SvTAINTED(PL_bodytarget))
+ SvTAINTED_on(sv);
break;
case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
if (nextchar == '\0') {
case '\006': /* ^F */
sv_setiv(sv, (IV)PL_maxsysfd);
break;
+ case '\007': /* ^GLOBAL_PHASE */
+ if (strEQ(remaining, "LOBAL_PHASE")) {
+ sv_setpvn(sv, PL_phase_names[PL_phase],
+ strlen(PL_phase_names[PL_phase]));
+ }
+ break;
case '\010': /* ^H */
sv_setiv(sv, (IV)PL_hints);
break;
Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
}
break;
- case '\020':
+ case '\020':
if (nextchar == '\0') { /* ^P */
sv_setiv(sv, (IV)PL_perldb);
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
}
break;
case '^':
- if (!isGV_with_GP(PL_defoutgv))
- s = "";
- else if (GvIOp(PL_defoutgv))
+ if (GvIOp(PL_defoutgv))
s = IoTOP_NAME(GvIOp(PL_defoutgv));
if (s)
sv_setpv(sv,s);
}
break;
case '~':
- if (!isGV_with_GP(PL_defoutgv))
- s = "";
- else if (GvIOp(PL_defoutgv))
+ if (GvIOp(PL_defoutgv))
s = IoFMT_NAME(GvIOp(PL_defoutgv));
if (!s)
s = GvENAME(PL_defoutgv);
case '/':
break;
case '[':
- sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, 0);
break;
case '|':
if (GvIO(PL_defoutgv))
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
break;
+ case '$': /* $$ */
+ {
+ IV const pid = (IV)PerlProc_getpid();
+ if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid)
+ /* never set manually, or at least not since last fork */
+ sv_setiv(sv, pid);
+ /* else a value has been assigned manually, so do nothing */
+ }
+ break;
+
case '!':
{
dSAVE_ERRNO;
#ifdef VMS
if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
- Stat_t sbuf;
int i = 0, j = 0;
my_strlcpy(eltbuf, s, sizeof(eltbuf));
PERL_ARGS_ASSERT_MAGIC_GETSIG;
if (!i) {
- mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
+ STRLEN siglen;
+ const char * sig = MgPV_const(mg, siglen);
+ mg->mg_private = i = whichsig_pvn(sig, siglen);
}
if (i > 0) {
Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
- PERL_UNUSED_ARG(sv);
magic_setsig(NULL, mg);
return sv_unmagic(sv, mg->mg_type);
}
#endif
+#if defined HAS_SIGPROCMASK
+static void
+unblock_sigmask(pTHX_ void* newset)
+{
+ sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
+}
+#endif
+
void
Perl_despatch_signals(pTHX)
{
for (sig = 1; sig < SIG_SIZE; sig++) {
if (PL_psig_pend[sig]) {
dSAVE_ERRNO;
- PERL_BLOCKSIG_ADD(set, sig);
+#ifdef HAS_SIGPROCMASK
+ /* From sigaction(2) (FreeBSD man page):
+ * | Signal routines normally execute with the signal that
+ * | caused their invocation blocked, but other signals may
+ * | yet occur.
+ * Emulation of this behavior (from within Perl) is enabled
+ * using sigprocmask
+ */
+ int was_blocked;
+ sigset_t newset, oldset;
+
+ sigemptyset(&newset);
+ sigaddset(&newset, sig);
+ sigprocmask(SIG_BLOCK, &newset, &oldset);
+ was_blocked = sigismember(&oldset, sig);
+ if (!was_blocked) {
+ SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
+ ENTER;
+ SAVEFREESV(save_sv);
+ SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
+ }
+#endif
PL_psig_pend[sig] = 0;
- PERL_BLOCKSIG_BLOCK(set);
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
(*PL_sighandlerp)(sig, NULL, NULL);
#else
(*PL_sighandlerp)(sig);
#endif
- PERL_BLOCKSIG_UNBLOCK(set);
+#ifdef HAS_SIGPROCMASK
+ if (!was_blocked)
+ LEAVE;
+#endif
RESTORE_ERRNO;
}
}
PERL_ARGS_ASSERT_MAGIC_SETSIG;
if (*s == '_') {
- if (strEQ(s,"__DIE__"))
+ if (memEQs(s, len, "__DIE__"))
svp = &PL_diehook;
- else if (strEQ(s,"__WARN__")
+ else if (memEQs(s, len, "__WARN__")
&& (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
/* Merge the existing behaviours, which are as follows:
magic_setsig, we always set svp to &PL_warnhook
For magic_clearsig, we don't change the warnings handler if it's
set to the &PL_warnhook. */
svp = &PL_warnhook;
- } else if (sv)
- Perl_croak(aTHX_ "No such hook: %s", s);
+ } else if (sv) {
+ SV *tmp = sv_newmortal();
+ Perl_croak(aTHX_ "No such hook: %s",
+ pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
+ }
i = 0;
if (svp && *svp) {
if (*svp != PERL_WARNHOOK_FATAL)
else {
i = (I16)mg->mg_private;
if (!i) {
- i = whichsig(s); /* ...no, a brick */
+ i = whichsig_pvn(s, len); /* ...no, a brick */
mg->mg_private = (U16)i;
}
if (i <= 0) {
- if (sv)
- Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
+ if (sv) {
+ SV *tmp = sv_newmortal();
+ Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
+ pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
+ }
return 0;
}
#ifdef HAS_SIGPROCMASK
} else {
sv = NULL;
}
- if (sv && strEQ(s,"IGNORE")) {
+ if (sv && memEQs(s, len,"IGNORE")) {
if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
PL_sig_ignoring[i] = 1;
#endif
}
}
- else if (!sv || strEQ(s,"DEFAULT") || !len) {
+ else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
if (i) {
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 1;
PERL_ARGS_ASSERT_MAGIC_CLEARISA;
/* Bail out if destruction is going on */
- if(PL_dirty) return 0;
+ if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
if (sv)
av_clear(MUTABLE_AV(sv));
if (hv) {
(void) hv_iterinit(hv);
if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
- i = HvKEYS(hv);
+ i = HvUSEDKEYS(hv);
else {
while (hv_iternext(hv))
i++;
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;
-* argc is the number of args (in addition to $self) to pass to the method;
- the args themselves are any values following the argc argument.
-* flags:
- G_DISCARD: invoke method with G_DISCARD flag and don't return a value
- G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
+C<sv> and C<mg> are the tied thingy and the tie magic.
+
+C<meth> is the name of the method to call.
+
+C<argc> is the number of args (in addition to $self) to pass to the method.
+
+The C<flags> can be:
+
+ G_DISCARD invoke method with G_DISCARD flag and don't
+ return a value
+ G_UNDEF_FILL fill the stack with argc pointers to
+ PL_sv_undef
+
+The arguments themselves are any values following the C<flags> argument.
Returns the SV (if any) returned by the method, or NULL on failure.
PERL_ARGS_ASSERT_MAGIC_METHCALL;
ENTER;
+
+ if (flags & G_WRITING_TO_STDERR) {
+ SAVETMPS;
+
+ save_re_context();
+ SAVESPTR(PL_stderrgv);
+ PL_stderrgv = NULL;
+ }
+
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
ret = *PL_stack_sp--;
}
POPSTACK;
+ if (flags & G_WRITING_TO_STDERR)
+ FREETMPS;
LEAVE;
return ret;
}
PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
if (obj) {
- sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, AvFILL(obj));
} else {
SvOK_off(sv);
}
PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
if (obj) {
- av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
+ av_fill(obj, SvIV(sv));
} else {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Attempt to set length of freed array");
I32 i = found->mg_len;
if (DO_UTF8(lsv))
sv_pos_b2u(lsv, &i);
- sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
+ sv_setiv(sv, i);
return 0;
}
}
}
len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
- pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
+ pos = SvIV(sv);
if (DO_UTF8(lsv)) {
ulen = sv_len_utf8(lsv);
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;
PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
+ if (!translate_substr_offsets(
+ SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
+ negoff ? -(IV)offs : (IV)offs, !negoff,
+ 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);
+ return 0;
+ }
+
if (SvUTF8(lsv))
offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
- if (offs > len)
- offs = len;
- if (rem > len - offs)
- rem = len - offs;
sv_setpvn(sv, tmps + offs, rem);
if (SvUTF8(lsv))
SvUTF8_on(sv);
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- STRLEN len;
+ STRLEN len, lsv_len, oldtarglen, newtarglen;
const char * const tmps = SvPV_const(sv, len);
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;
PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
+ SvGETMAGIC(lsv);
+ if (SvROK(lsv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr"
+ );
+ if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
+ else (void)SvPV_nomg(lsv,lsv_len);
+ if (!translate_substr_offsets(
+ lsv_len,
+ negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
+ neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
+ ))
+ Perl_croak(aTHX_ "substr outside of string");
+ oldtarglen = lvlen;
if (DO_UTF8(sv)) {
sv_utf8_upgrade(lsv);
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
- sv_insert(lsv, lvoff, lvlen, tmps, len);
- LvTARGLEN(sv) = sv_len_utf8(sv);
+ sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
+ newtarglen = sv_len_utf8(sv);
SvUTF8_on(lsv);
}
else if (lsv && SvUTF8(lsv)) {
const char *utf8;
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
- LvTARGLEN(sv) = len;
+ newtarglen = len;
utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
- sv_insert(lsv, lvoff, lvlen, utf8, len);
+ sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
Safefree(utf8);
}
else {
- sv_insert(lsv, lvoff, lvlen, tmps, len);
- LvTARGLEN(sv) = len;
+ sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
+ newtarglen = len;
}
+ if (!neglen) LvTARGLEN(sv) = newtarglen;
+ if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
return 0;
}
}
int
+Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
+
+ if (SvPOKp(sv)) {
+ SV * const vecsv = sv_newmortal();
+ scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
+ if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
+ }
+ return sv_unmagic(sv, mg->mg_type);
+}
+
+int
Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
{
PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
PERL_UNUSED_CONTEXT;
+ PERL_UNUSED_ARG(sv);
mg->mg_len = -1;
- if (!isGV_with_GP(sv))
- SvSCREAM_off(sv);
return 0;
}
} else if (type == PERL_MAGIC_bm) {
SvTAIL_off(sv);
SvVALID_off(sv);
+ } else if (type == PERL_MAGIC_study) {
+ if (!isGV_with_GP(sv))
+ SvSCREAM_off(sv);
} else {
assert(type == PERL_MAGIC_fm);
- SvCOMPILED_off(sv);
}
return sv_unmagic(sv, type);
}
const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;
+ MAGIC *tmg;
PERL_ARGS_ASSERT_MAGIC_SET;
break;
case '\001': /* ^A */
sv_setsv(PL_bodytarget, sv);
+ FmLINES(PL_bodytarget) = 0;
+ if (SvPOK(PL_bodytarget)) {
+ char *s = SvPVX(PL_bodytarget);
+ while ( ((s = strchr(s, '\n'))) ) {
+ FmLINES(PL_bodytarget)++;
+ s++;
+ }
+ }
+ /* mg_set() has temporarily made sv non-magical */
+ if (PL_tainting) {
+ if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
+ SvTAINTED_on(PL_bodytarget);
+ else
+ SvTAINTED_off(PL_bodytarget);
+ }
break;
case '\003': /* ^C */
PL_minus_c = cBOOL(SvIV(sv));
IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
break;
case '^':
- 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);
- }
+ 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 '~':
- 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);
- }
+ 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 '=':
- if (isGV_with_GP(PL_defoutgv))
- IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '-':
- 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)) = (SvIV(sv));
+ if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
- }
break;
case '%':
- if (isGV_with_GP(PL_defoutgv))
- IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '|':
{
}
break;
case '[':
- CopARYBASE_set(&PL_compiling, SvIV(sv));
+ if (SvIV(sv) != 0)
+ Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
break;
case '?':
#ifdef COMPLEX_STATUS
(void)setregid((Gid_t)PL_gid, (Gid_t)-1);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
+ (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1);
#else
if (PL_gid == PL_egid) /* special case $( = $) */
(void)PerlProc_setgid(PL_gid);
case ':':
PL_chopset = SvPV_force(sv,len);
break;
+ case '$': /* $$ */
+ /* Store the pid in mg->mg_obj so we can tell when a fork has
+ occurred. mg->mg_obj points to *$ by default, so clear it. */
+ if (isGV(mg->mg_obj)) {
+ if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
+ SvREFCNT_dec(mg->mg_obj);
+ mg->mg_flags |= MGf_REFCOUNTED;
+ mg->mg_obj = newSViv((IV)PerlProc_getpid());
+ }
+ else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
+ break;
case '0':
LOCK_DOLLARZERO_MUTEX;
#ifdef HAS_SETPROCTITLE
}
I32
-Perl_whichsig(pTHX_ const char *sig)
+Perl_whichsig_sv(pTHX_ SV *sigsv)
+{
+ const char *sigpv;
+ STRLEN siglen;
+ PERL_ARGS_ASSERT_WHICHSIG_SV;
+ PERL_UNUSED_CONTEXT;
+ sigpv = SvPV_const(sigsv, siglen);
+ return whichsig_pvn(sigpv, siglen);
+}
+
+I32
+Perl_whichsig_pv(pTHX_ const char *sig)
+{
+ PERL_ARGS_ASSERT_WHICHSIG_PV;
+ PERL_UNUSED_CONTEXT;
+ return whichsig_pvn(sig, strlen(sig));
+}
+
+I32
+Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
{
register char* const* sigv;
- PERL_ARGS_ASSERT_WHICHSIG;
+ PERL_ARGS_ASSERT_WHICHSIG_PVN;
PERL_UNUSED_CONTEXT;
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
- if (strEQ(sig,*sigv))
+ if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
return PL_sig_num[sigv - (char* const*)PL_sig_name];
#ifdef SIGCLD
- if (strEQ(sig,"CHLD"))
+ if (memEQs(sig, len, "CHLD"))
return SIGCLD;
#endif
#ifdef SIGCHLD
- if (strEQ(sig,"CLD"))
+ if (memEQs(sig, len, "CLD"))
return SIGCHLD;
#endif
return -1;
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
+Perl_sighandler(int sig, siginfo_t *sip, void *uap)
#else
Perl_sighandler(int sig)
#endif
exit(sig);
}
- /* Max number of items pushed there is 3*n or 4. We cannot fix
- infinity, so we fix 4 (in fact 5): */
- if (PL_savestack_ix + 15 <= PL_savestack_max) {
- flags |= 1;
- PL_savestack_ix += 5; /* Protect save in progress. */
- SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
- }
- if (PL_markstack_ptr < PL_markstack_max - 2) {
- flags |= 2;
- PL_markstack_ptr++; /* Protect mark. */
- }
- if (PL_scopestack_ix < PL_scopestack_max - 3) {
- flags |= 4;
- PL_scopestack_ix++;
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
+ /* Max number of items pushed there is 3*n or 4. We cannot fix
+ infinity, so we fix 4 (in fact 5): */
+ if (PL_savestack_ix + 15 <= PL_savestack_max) {
+ flags |= 1;
+ PL_savestack_ix += 5; /* Protect save in progress. */
+ SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
+ }
}
/* sv_2cv is too complicated, try a simpler variant first: */
if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
flags |= 8;
SAVEFREESV(sv);
- /* make sure our assumption about the size of the SAVEs are correct:
- * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
- assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
+ /* make sure our assumption about the size of the SAVEs are correct:
+ * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
+ assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
+ }
PUSHSTACKi(PERLSI_SIGNAL);
PUSHMARK(SP);
POPSTACK;
if (SvTRUE(ERRSV)) {
#ifndef PERL_MICRO
-#ifdef HAS_SIGPROCMASK
/* 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.
*/
- sigset_t set;
- sigemptyset(&set);
- sigaddset(&set,sig);
- sigprocmask(SIG_UNBLOCK, &set, NULL);
+#ifdef HAS_SIGPROCMASK
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ if (sip || uap)
+#endif
+ {
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set,sig);
+ sigprocmask(SIG_UNBLOCK, &set, NULL);
+ }
#else
/* Not clear if this will work */
(void)rsignal(sig, SIG_IGN);
cleanup:
/* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
PL_savestack_ix = old_ss_ix;
- if (flags & 2)
- PL_markstack_ptr--;
- if (flags & 4)
- PL_scopestack_ix -= 1;
if (flags & 8)
SvREFCNT_dec(sv);
PL_op = myop; /* Apparently not needed... */
dVAR;
MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
SV* const sv = mgs->mgs_sv;
+ bool bumped;
if (!sv)
return;
}
}
+ bumped = mgs->mgs_bumped;
mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
/* If we're still on top of the stack, pop us off. (That condition
assert((popval & SAVE_MASK) == SAVEt_ALLOC);
PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
}
-
+ if (bumped) {
+ if (SvREFCNT(sv) == 1) {
+ /* We hold the last reference to this SV, which implies that the
+ SV was deleted as a side effect of the routines we called.
+ So artificially keep it alive a bit longer.
+ We avoid turning on the TEMP flag, which can cause the SV's
+ buffer to get stolen (and maybe other stuff). */
+ int was_temp = SvTEMP(sv);
+ sv_2mortal(sv);
+ if (!was_temp) {
+ SvTEMP_off(sv);
+ }
+ SvOK_off(sv);
+ }
+ else
+ SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
+ }
}
/* clean up the mess created by Perl_sighandler().
* Note that this is only called during an exit in a signal handler;
* a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
- * skipped over. This is why we don't need to fix up the markstack and
- * scopestack - they're going to be set to 0 anyway */
+ * skipped over. */
static void
S_unwind_handler_stack(pTHX_ const void *p)
https://perl5.git.perl.org / perl5.git / blobdiff