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 */
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);
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) {
dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
const bool was_temp = (bool)SvTEMP(sv);
- int have_new = 0;
+ bool have_new = 0;
MAGIC *newmg, *head, *cur, *mg;
/* guard against sv having being freed midway by holding a private
reference. */
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
have_new = 1;
cur = mg;
mg = newmg;
+ (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
}
}
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;
{
const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
+ MAGIC *nextmg;
PERL_ARGS_ASSERT_MG_CLEAR;
save_magic(mgs_ix, sv);
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ for (mg = SvMAGIC(sv); mg; mg = nextmg) {
const MGVTBL* const vtbl = mg->mg_virtual;
/* omit GSKIP -- never set here */
+ nextmg = mg->mg_moremagic; /* it may delete itself */
+
if (vtbl && vtbl->svt_clear)
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
{
sv_setiv(sv, (IV)STATUS_CURRENT);
#ifdef COMPLEX_STATUS
+ SvUPGRADE(sv, SVt_PVLV);
LvTARGOFF(sv) = PL_statusvalue;
LvTARGLEN(sv) = PL_statusvalue_vms;
#endif
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;
{
dVAR;
/* Are we fetching a signal entry? */
- const I32 i = whichsig(MgPV_nolen_const(mg));
+ int i = (I16)mg->mg_private;
PERL_ARGS_ASSERT_MAGIC_GETSIG;
+ if (!i) {
+ mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
+ }
+
if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
#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]++;
#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);
}
}
else {
- i = whichsig(s); /* ...no, a brick */
+ i = (I16)mg->mg_private;
+ if (!i) {
+ 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
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 0;
#endif
- SvREFCNT_dec(PL_psig_name[i]);
to_dec = PL_psig_ptr[i];
if (sv) {
PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
SvTEMP_off(sv); /* Make sure it doesn't go away on us */
- PL_psig_name[i] = newSVpvn(s, len);
- SvREADONLY_on(PL_psig_name[i]);
+
+ /* Signals don't change name during the program's execution, so once
+ they're cached in the appropriate slot of PL_psig_name, they can
+ stay there.
+
+ Ideally we'd find some way of making SVs at (C) compile time, or
+ at least, doing most of the work. */
+ if (!PL_psig_name[i]) {
+ PL_psig_name[i] = newSVpvn(s, len);
+ SvREADONLY_on(PL_psig_name[i]);
+ }
} else {
+ SvREFCNT_dec(PL_psig_name[i]);
PL_psig_name[i] = NULL;
PL_psig_ptr[i] = NULL;
}
if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
if (i) {
(void)rsignal(i, PL_csighandlerp);
-#ifdef HAS_SIGPROCMASK
- LEAVE;
-#endif
}
else
*svp = SvREFCNT_inc_simple_NN(sv);
- if(to_dec)
- SvREFCNT_dec(to_dec);
- return 0;
- }
- if (sv && SvOK(sv)) {
- s = SvPV_force(sv, len);
} else {
- sv = NULL;
- }
- if (sv && strEQ(s,"IGNORE")) {
- if (i) {
+ if (sv && SvOK(sv)) {
+ s = SvPV_force(sv, len);
+ } else {
+ sv = NULL;
+ }
+ if (sv && strEQ(s,"IGNORE")) {
+ if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- PL_sig_ignoring[i] = 1;
- (void)rsignal(i, PL_csighandlerp);
+ PL_sig_ignoring[i] = 1;
+ (void)rsignal(i, PL_csighandlerp);
#else
- (void)rsignal(i, (Sighandler_t) SIG_IGN);
+ (void)rsignal(i, (Sighandler_t) SIG_IGN);
#endif
+ }
}
- }
- else if (!sv || strEQ(s,"DEFAULT") || !len) {
- if (i) {
+ else if (!sv || strEQ(s,"DEFAULT") || !len) {
+ if (i) {
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- PL_sig_defaulting[i] = 1;
- (void)rsignal(i, PL_csighandlerp);
+ PL_sig_defaulting[i] = 1;
+ (void)rsignal(i, PL_csighandlerp);
#else
- (void)rsignal(i, (Sighandler_t) SIG_DFL);
+ (void)rsignal(i, (Sighandler_t) SIG_DFL);
#endif
+ }
+ }
+ else {
+ /*
+ * We should warn if HINT_STRICT_REFS, but without
+ * 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,'\''))
+ Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
+ SV_GMAGIC);
+ if (i)
+ (void)rsignal(i, PL_csighandlerp);
+ else
+ *svp = SvREFCNT_inc_simple_NN(sv);
}
}
- else {
- /*
- * We should warn if HINT_STRICT_REFS, but without
- * 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,'\''))
- Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
- SV_GMAGIC);
- if (i)
- (void)rsignal(i, PL_csighandlerp);
- else
- *svp = SvREFCNT_inc_simple_NN(sv);
- }
+
#ifdef HAS_SIGPROCMASK
if(i)
LEAVE;
#endif
- if(to_dec)
- SvREFCNT_dec(to_dec);
+ SvREFCNT_dec(to_dec);
return 0;
}
#endif /* !PERL_MICRO */
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- HV* stash;
-
PERL_ARGS_ASSERT_MAGIC_SETISA;
PERL_UNUSED_ARG(sv);
- /* Bail out if destruction is going on */
- if(PL_dirty) return 0;
-
/* Skip _isaelem because _isa will handle it shortly */
if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
return 0;
- /* XXX Once it's possible, we need to
- detect that our @ISA is aliased in
- other stashes, and act on the stashes
- of all of the aliases */
-
- /* The first case occurs via setisa,
- the second via setisa_elem, which
- calls this same magic */
- stash = GvSTASH(
- SvTYPE(mg->mg_obj) == SVt_PVGV
- ? (const GV *)mg->mg_obj
- : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
- );
-
- if (stash)
- mro_isa_changed_in(stash);
-
- return 0;
+ return magic_clearisa(NULL, mg);
}
+/* sv of NULL signifies that we're acting as magic_setisa. */
int
Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
{
/* Bail out if destruction is going on */
if(PL_dirty) return 0;
- av_clear(MUTABLE_AV(sv));
+ if (sv)
+ av_clear(MUTABLE_AV(sv));
+
+ /* XXX Once it's possible, we need to
+ detect that our @ISA is aliased in
+ other stashes, and act on the stashes
+ of all of the aliases */
- /* XXX see comments in magic_setisa */
+ /* The first case occurs via setisa,
+ the second via setisa_elem, which
+ calls this same magic */
stash = GvSTASH(
SvTYPE(mg->mg_obj) == SVt_PVGV
? (const GV *)mg->mg_obj
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;
}
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;
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);
LvTARGLEN(sv) = len;
}
-
return 0;
}
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;
}
#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
#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);
}
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);
+ SvUTF8(sv))
+ : newSVpvs_flags("", SvUTF8(sv));
+ (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
+ mg_set(tmp);
- /* The UTF-8 setting is carried over */
- sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
-
- 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 */
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);
}
case '?':
#ifdef COMPLEX_STATUS
if (PL_localizing == 2) {
+ SvUPGRADE(sv, SVt_PVLV);
PL_statusvalue = LvTARGOFF(sv);
PL_statusvalue_vms = LvTARGLEN(sv);
}
{
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))
}
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;
}
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)) {
}
/*
+=for apidoc magic_clearhints
+
+Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+
+=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
https://perl5.git.perl.org / perl5.git / blobdiff