/* mg.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * "Sam sat on the ground and put his head in his hands. 'I wish I had never
- * come here, and I don't want to see no more magic,' he said, and fell silent."
+ * Sam sat on the ground and put his head in his hands. 'I wish I had never
+ * come here, and I don't want to see no more magic,' he said, and fell silent.
+ *
+ * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
*/
/*
{
dVAR;
MGS* mgs;
+
+ PERL_ARGS_ASSERT_SAVE_MAGIC;
+
assert(SvMAGICAL(sv));
/* Turning READONLY off for a copy-on-write scalar (including shared
hash keys) is a bad idea. */
Perl_mg_magical(pTHX_ SV *sv)
{
const MAGIC* mg;
+ PERL_ARGS_ASSERT_MG_MAGICAL;
PERL_UNUSED_CONTEXT;
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- const MGVTBL* const vtbl = mg->mg_virtual;
- if (vtbl) {
- if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
- SvGMAGICAL_on(sv);
- if (vtbl->svt_set)
- SvSMAGICAL_on(sv);
- if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
- SvRMAGICAL_on(sv);
- }
+ if ((mg = SvMAGIC(sv))) {
+ SvRMAGICAL_off(sv);
+ do {
+ const MGVTBL* const vtbl = mg->mg_virtual;
+ if (vtbl) {
+ if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
+ SvGMAGICAL_on(sv);
+ if (vtbl->svt_set)
+ SvSMAGICAL_on(sv);
+ if (vtbl->svt_clear)
+ SvRMAGICAL_on(sv);
+ }
+ } while ((mg = mg->mg_moremagic));
+ if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
+ SvRMAGICAL_on(sv);
}
}
STATIC bool
S_is_container_magic(const MAGIC *mg)
{
+ assert(mg);
switch (mg->mg_type) {
case PERL_MAGIC_bm:
case PERL_MAGIC_fm:
/* 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.
MAGIC* mg;
MAGIC* nextmg;
+ PERL_ARGS_ASSERT_MG_SET;
+
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = nextmg) {
MAGIC* mg;
STRLEN len;
+ PERL_ARGS_ASSERT_MG_LENGTH;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL * const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
}
}
- if (DO_UTF8(sv)) {
+ {
+ /* You can't know whether it's UTF-8 until you get the string again...
+ */
const U8 *s = (U8*)SvPV_const(sv, len);
- len = utf8_length(s, s + len);
+
+ if (DO_UTF8(sv)) {
+ len = utf8_length(s, s + len);
+ }
}
- else
- (void)SvPV_const(sv, len);
return len;
}
{
MAGIC* mg;
+ PERL_ARGS_ASSERT_MG_SIZE;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
switch(SvTYPE(sv)) {
case SVt_PVAV:
- return AvFILLp((AV *) sv); /* Fallback to non-tied array */
+ return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
case SVt_PVHV:
/* FIXME */
default:
{
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);
}
{
int count = 0;
MAGIC* mg;
+
+ PERL_ARGS_ASSERT_MG_COPY;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
/*
=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).
+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).
+
+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'),
+and that will handle the magic.
=cut
*/
void
-Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
+Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
{
dVAR;
MAGIC *mg;
+
+ PERL_ARGS_ASSERT_MG_LOCALIZE;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if (!S_is_container_magic(mg))
if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
SvFLAGS(nsv) |= SvMAGICAL(sv);
- PL_localizing = 1;
- SvSETMAGIC(nsv);
- PL_localizing = 0;
+ if (setmagic) {
+ PL_localizing = 1;
+ SvSETMAGIC(nsv);
+ PL_localizing = 0;
+ }
}
}
{
MAGIC* mg;
MAGIC* moremagic;
+
+ PERL_ARGS_ASSERT_MG_FREE;
+
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
moremagic = mg->mg_moremagic;
if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
- SvREFCNT_dec((SV*)mg->mg_ptr);
+ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
}
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
SvMAGIC_set(sv, moremagic);
}
SvMAGIC_set(sv, NULL);
+ SvMAGICAL_off(sv);
return 0;
}
dVAR;
PERL_UNUSED_ARG(sv);
+ PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
+
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
+
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
NORETURN_FUNCTION_END;
}
register const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;
+ PERL_ARGS_ASSERT_MAGIC_LEN;
+
switch (*mg->mg_ptr) {
case '\020':
if (*remaining == '\0') { /* ^P */
void
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);
else {
const char * const remaining = mg->mg_ptr + 1;
const char nextchar = *remaining;
+ PERL_ARGS_ASSERT_MAGIC_GET;
+
switch (*mg->mg_ptr) {
case '\001': /* ^A */
sv_setsv(sv, PL_bodytarget);
break;
case '\005': /* ^E */
if (nextchar == '\0') {
-#if defined(MACOS_TRADITIONAL)
- {
- char msg[256];
-
- sv_setnv(sv,(double)gMacPerl_OSErr);
- sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
- }
-#elif defined(VMS)
+#if defined(VMS)
{
# include <descrip.h>
# include <starlet.h>
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_setpvn(sv,"",0);
+ sv_setpvs(sv,"");
}
#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
PerlProc_GetOSError(sv, dwErr);
}
else
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
SetLastError(dwErr);
}
#else
{
- const int saveerrno = errno;
+ dSAVE_ERRNO;
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
- errno = saveerrno;
+ RESTORE_ERRNO;
}
#endif
SvRTRIM(sv);
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", FALSE);
+ HV * const bits=get_hv("warnings::Bits", 0);
if (bits) {
SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
if (bits_all)
case '5': case '6': case '7': case '8': case '9': case '&':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
/*
- * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
+ * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
* XXX Does the new way break anything?
*/
paren = atoi(mg->mg_ptr); /* $& is in [0] */
{
sv_setiv(sv, (IV)STATUS_CURRENT);
#ifdef COMPLEX_STATUS
+ SvUPGRADE(sv, SVt_PVLV);
LvTARGOFF(sv) = PL_statusvalue;
LvTARGLEN(sv) = PL_statusvalue_vms;
#endif
if (GvIOp(PL_defoutgv))
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
break;
- case ',':
- break;
case '\\':
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
sv_setpv(sv, errno ? Strerror(errno) : "");
#else
{
- const int saveerrno = errno;
+ dSAVE_ERRNO;
sv_setnv(sv, (NV)errno);
#ifdef OS2
if (errno == errno_isOS2 || errno == errno_isOS2_set)
else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
- errno = saveerrno;
+ RESTORE_ERRNO;
}
#endif
SvRTRIM(sv);
(void)SvIOK_on(sv); /* what a wonderful hack! */
#endif
break;
-#ifndef MACOS_TRADITIONAL
case '0':
break;
-#endif
}
return 0;
}
{
struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ PERL_ARGS_ASSERT_MAGIC_GETUVAR;
+
if (uf && uf->uf_val)
(*uf->uf_val)(aTHX_ uf->uf_index, sv);
return 0;
const char * const ptr = MgPV_const(mg,klen);
my_setenv(ptr, s);
+ PERL_ARGS_ASSERT_MAGIC_SETENV;
+
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
int
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_CLEARENV;
PERL_UNUSED_ARG(sv);
my_setenv(MgPV_nolen_const(mg),NULL);
return 0;
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
PERL_UNUSED_ARG(mg);
#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
if (PL_localizing) {
HE* entry;
my_clearenv();
- hv_iterinit((HV*)sv);
- while ((entry = hv_iternext((HV*)sv))) {
+ hv_iterinit(MUTABLE_HV(sv));
+ while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
I32 keylen;
my_setenv(hv_iterkey(entry, &keylen),
- SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
+ SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
}
}
#endif
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
#if defined(VMS)
{
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]);
int
Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
{
- /* XXX Some of this code was copied from Perl_magic_setsig. A little
- * refactoring might be in order.
- */
- dVAR;
- register const char * const s = MgPV_nolen_const(mg);
+ PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
PERL_UNUSED_ARG(sv);
- if (*s == '_') {
- SV** svp = NULL;
- if (strEQ(s,"__DIE__"))
- svp = &PL_diehook;
- else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
- svp = &PL_warnhook;
- if (svp && *svp) {
- SV *const to_dec = *svp;
- *svp = NULL;
- SvREFCNT_dec(to_dec);
- }
- }
- else {
- /* Are we clearing a signal entry? */
- const I32 i = whichsig(s);
- if (i > 0) {
-#ifdef HAS_SIGPROCMASK
- sigset_t set, save;
- SV* save_sv;
- /* Avoid having the signal arrive at a bad time, if possible. */
- sigemptyset(&set);
- sigaddset(&set,i);
- sigprocmask(SIG_BLOCK, &set, &save);
- ENTER;
- save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
- SAVEFREESV(save_sv);
- SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
-#endif
- PERL_ASYNC_CHECK();
-#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
- if (!PL_sig_handlers_initted) Perl_csighandler_init();
-#endif
-#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- PL_sig_defaulting[i] = 1;
- (void)rsignal(i, PL_csighandlerp);
-#else
- (void)rsignal(i, (Sighandler_t) SIG_DFL);
-#endif
- if(PL_psig_name[i]) {
- SvREFCNT_dec(PL_psig_name[i]);
- PL_psig_name[i]=0;
- }
- if(PL_psig_ptr[i]) {
- SV * const to_dec=PL_psig_ptr[i];
- PL_psig_ptr[i]=0;
- LEAVE;
- SvREFCNT_dec(to_dec);
- }
- else
- LEAVE;
- }
- }
- return 0;
-}
-
-/*
- * The signal handling nomenclature has gotten a bit confusing since the advent of
- * safe signals. S_raise_signal only raises signals by analogy with what the
- * underlying system's signal mechanism does. It might be more proper to say that
- * it defers signals that have already been raised and caught.
- *
- * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
- * in the sense of being on the system's signal queue in between raising and delivery.
- * They are only pending on Perl's deferral list, i.e., they track deferred signals
- * awaiting delivery after the current Perl opcode completes and say nothing about
- * signals raised but not yet caught in the underlying signal implementation.
- */
-#ifndef SIG_PENDING_DIE_COUNT
-# define SIG_PENDING_DIE_COUNT 120
-#endif
-
-static void
-S_raise_signal(pTHX_ int sig)
-{
- dVAR;
- /* Set a flag to say this signal is pending */
- PL_psig_pend[sig]++;
- /* And 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);
+ magic_setsig(NULL, mg);
+ return sv_unmagic(sv, mg->mg_type);
}
Signal_t
#else
dTHX;
#endif
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
if (PL_sig_ignoring[sig]) return;
exit(1);
#endif
#endif
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-#endif
- if (
+ if (
#ifdef SIGILL
sig == SIGILL ||
#endif
#else
(*PL_sighandlerp)(sig);
#endif
- else
- S_raise_signal(aTHX_ sig);
+ else {
+ /* 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 */
+ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
+ Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
+ (unsigned long)SIG_PENDING_DIE_COUNT);
+ }
}
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
}
}
+/* sv of NULL signifies that we're acting as magic_clearsig. */
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
sigset_t set, save;
SV* save_sv;
#endif
-
register const char *s = MgPV_const(mg,len);
+
+ PERL_ARGS_ASSERT_MAGIC_SETSIG;
+
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
- else if (strEQ(s,"__WARN__"))
+ else if (strEQ(s,"__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
+ (hence we always change the warnings handler)
+ For magic_clearsig, we don't change the warnings handler if it's
+ set to the &PL_warnhook. */
svp = &PL_warnhook;
- else
+ } else if (sv)
Perl_croak(aTHX_ "No such hook: %s", s);
i = 0;
- if (*svp) {
+ if (svp && *svp) {
if (*svp != PERL_WARNHOOK_FATAL)
to_dec = *svp;
*svp = NULL;
}
}
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 (ckWARN(WARN_SIGNAL))
+ if (sv && ckWARN(WARN_SIGNAL))
Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
return 0;
}
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 0;
#endif
- SvREFCNT_dec(PL_psig_name[i]);
to_dec = PL_psig_ptr[i];
- 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]);
+ if (sv) {
+ PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
+ SvTEMP_off(sv); /* Make sure it doesn't go away on us */
+
+ /* 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 (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
+ 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;
- }
- s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
- if (strEQ(s,"IGNORE")) {
- if (i) {
+ } else {
+ 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 (strEQ(s,"DEFAULT") || !*s) {
- 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(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
- if (i)
- (void)rsignal(i, PL_csighandlerp);
- else
- *svp = SvREFCNT_inc_simple_NN(sv);
- }
+
#ifdef HAS_SIGPROCMASK
if(i)
LEAVE;
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;
+ 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)
+{
+ dVAR;
+ HV* stash;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARISA;
+
+ /* Bail out if destruction is going on */
+ if(PL_dirty) return 0;
+
+ 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
calls this same magic */
stash = GvSTASH(
SvTYPE(mg->mg_obj) == SVt_PVGV
- ? (GV*)mg->mg_obj
- : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
+ ? (const GV *)mg->mg_obj
+ : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
);
- mro_isa_changed_in(stash);
+ if (stash)
+ mro_isa_changed_in(stash);
return 0;
}
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
PL_amagic_generation++;
int
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
- HV * const hv = (HV*)LvTARG(sv);
+ HV * const hv = MUTABLE_HV(LvTARG(sv));
I32 i = 0;
+
+ PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
PERL_UNUSED_ARG(mg);
if (hv) {
(void) hv_iterinit(hv);
- if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
+ if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
i = HvKEYS(hv);
else {
while (hv_iternext(hv))
int
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
PERL_UNUSED_ARG(mg);
if (LvTARG(sv)) {
- hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
+ hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
}
return 0;
}
dVAR;
dSP;
+ PERL_ARGS_ASSERT_MAGIC_METHCALL;
+
PUSHMARK(SP);
EXTEND(SP, n);
PUSHs(SvTIED_obj(sv, mg));
if (mg->mg_len >= 0)
mPUSHp(mg->mg_ptr, mg->mg_len);
else if (mg->mg_len == HEf_SVKEY)
- PUSHs((SV*)mg->mg_ptr);
+ PUSHs(MUTABLE_SV(mg->mg_ptr));
}
else if (mg->mg_type == PERL_MAGIC_tiedelem) {
mPUSHi(mg->mg_len);
{
dVAR; dSP;
+ PERL_ARGS_ASSERT_MAGIC_METHPACK;
+
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
int
Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_GETPACK;
+
if (mg->mg_ptr)
mg->mg_flags |= MGf_GSKIP;
magic_methpack(sv,mg,"FETCH");
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
dVAR; dSP;
+
+ PERL_ARGS_ASSERT_MAGIC_SETPACK;
+
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
int
Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
+
return magic_methpack(sv,mg,"DELETE");
}
dVAR; dSP;
I32 retval = 0;
+ PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
+
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
{
dVAR; dSP;
+ PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
+
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
dVAR; dSP;
const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
+ PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
+
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
int
Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
+
return magic_methpack(sv,mg,"EXISTS");
}
{
dVAR; dSP;
SV *retval;
- SV * const tied = SvTIED_obj((SV*)hv, mg);
- HV * const pkg = SvSTASH((SV*)SvRV(tied));
+ SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
+ HV * const pkg = SvSTASH((const SV *)SvRV(tied));
+ PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
+
if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
SV *key;
if (HvEITER_get(hv))
return &PL_sv_yes;
/* no xhv_eiter so now use FIRSTKEY */
key = sv_newmortal();
- magic_nextpack((SV*)hv, mg, key);
+ magic_nextpack(MUTABLE_SV(hv), mg, key);
HvEITER_set(hv, NULL); /* need to reset iterator */
return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
}
const I32 i = SvTRUE(sv);
SV ** const svp = av_fetch(GvAV(gv),
atoi(MgPV_nolen_const(mg)), FALSE);
+
+ PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
+
if (svp && SvIOKp(*svp)) {
OP * const o = INT2PTR(OP*,SvIVX(*svp));
if (o) {
Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
{
dVAR;
- const AV * const obj = (AV*)mg->mg_obj;
+ AV * const obj = MUTABLE_AV(mg->mg_obj);
+
+ PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
+
if (obj) {
sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
} else {
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- AV * const obj = (AV*)mg->mg_obj;
+ AV * const obj = MUTABLE_AV(mg->mg_obj);
+
+ PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
+
if (obj) {
av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
} else {
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
PERL_UNUSED_ARG(sv);
+
/* during global destruction, mg_obj may already have been freed */
if (PL_in_clean_all)
return 0;
{
dVAR;
SV* const lsv = LvTARG(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETPOS;
PERL_UNUSED_ARG(mg);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
STRLEN ulen = 0;
MAGIC* found;
+ PERL_ARGS_ASSERT_MAGIC_SETPOS;
PERL_UNUSED_ARG(mg);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
const char * const tmps = SvPV_const(lsv,len);
I32 offs = LvTARGOFF(sv);
I32 rem = LvTARGLEN(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
if (SvUTF8(lsv))
SV * const lsv = LvTARG(sv);
I32 lvoff = LvTARGOFF(sv);
I32 lvlen = LvTARGLEN(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
if (DO_UTF8(sv)) {
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
+
TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
}
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_SETTAINT;
PERL_UNUSED_ARG(sv);
+
/* update taint status */
if (PL_tainted)
mg->mg_len |= 1;
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
if (lsv)
int
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETVEC;
PERL_UNUSED_ARG(mg);
do_vecset(sv); /* XXX slurp this routine */
return 0;
{
dVAR;
SV *targ = NULL;
+
+ PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
+
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
SV * const ahv = LvTARG(sv);
- HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
+ HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
if (he)
targ = HeVAL(he);
}
else {
- AV* const av = (AV*)LvTARG(sv);
+ AV *const av = MUTABLE_AV(LvTARG(sv));
if ((I32)LvTARGOFF(sv) <= AvFILL(av))
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
int
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
PERL_UNUSED_ARG(mg);
if (LvTARGLEN(sv))
vivify_defelem(sv);
MAGIC *mg;
SV *value = NULL;
+ PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
+
if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
SV * const ahv = LvTARG(sv);
- HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
+ HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
if (he)
value = HeVAL(he);
if (!value || value == &PL_sv_undef)
Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
}
else {
- AV* const av = (AV*)LvTARG(sv);
+ AV *const av = MUTABLE_AV(LvTARG(sv));
if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
LvTARG(sv) = NULL; /* array can't be extended */
else {
int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
- return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
+ PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
+ return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
}
int
Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
PERL_UNUSED_CONTEXT;
mg->mg_len = -1;
SvSCREAM_off(sv);
{
const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ PERL_ARGS_ASSERT_MAGIC_SETUVAR;
+
if (uf && uf->uf_set)
(*uf->uf_set)(aTHX_ uf->uf_index, sv);
return 0;
Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
{
const char type = mg->mg_type;
+
+ PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
+
if (type == PERL_MAGIC_qr) {
} else if (type == PERL_MAGIC_bm) {
SvTAIL_off(sv);
int
Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
+
/*
* RenE<eacute> Descartes said "I think not."
* and vanished with a faint plop.
int
Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETUTF8;
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
I32 i;
STRLEN len;
+ PERL_ARGS_ASSERT_MAGIC_SET;
+
switch (*mg->mg_ptr) {
case '\015': /* $^MATCH */
if (strEQ(remaining, "ATCH"))
* set without a previous pattern match. Unless it's C<local $1>
*/
if (!PL_localizing) {
- Perl_croak(aTHX_ PL_no_modify);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
}
}
case '\001': /* ^A */
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
-#ifdef MACOS_TRADITIONAL
- gMacPerl_OSErr = SvIV(sv);
-#else
-# ifdef VMS
+#ifdef VMS
set_vaxc_errno(SvIV(sv));
-# else
-# ifdef WIN32
+#else
+# ifdef WIN32
SetLastError( SvIV(sv) );
-# else
-# ifdef OS2
+# else
+# ifdef OS2
os2_setsyserrno(SvIV(sv));
-# else
+# else
/* will anyone ever use this? */
SETERRNO(SvIV(sv), 4);
-# endif
# endif
# endif
#endif
ensure that hints for input are sooner on linked list. */
tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
SVs_TEMP | SvUTF8(sv))
- : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
+ : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
tmp_he
= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
PL_ors_sv = NULL;
}
break;
- case ',':
- if (PL_ofs_sv)
- SvREFCNT_dec(PL_ofs_sv);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
- PL_ofs_sv = newSVsv(sv);
- }
- else {
- PL_ofs_sv = NULL;
- }
- break;
case '[':
CopARYBASE_set(&PL_compiling, SvIV(sv));
break;
case '?':
#ifdef COMPLEX_STATUS
if (PL_localizing == 2) {
+ SvUPGRADE(sv, SVt_PVLV);
PL_statusvalue = LvTARGOFF(sv);
PL_statusvalue_vms = LvTARGLEN(sv);
}
case ':':
PL_chopset = SvPV_force(sv,len);
break;
-#ifndef MACOS_TRADITIONAL
case '0':
LOCK_DOLLARZERO_MUTEX;
#ifdef HAS_SETPROCTITLE
#endif
UNLOCK_DOLLARZERO_MUTEX;
break;
-#endif
}
return 0;
}
Perl_whichsig(pTHX_ const char *sig)
{
register char* const* sigv;
+
+ PERL_ARGS_ASSERT_WHICHSIG;
PERL_UNUSED_CONTEXT;
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
if (flags & 16)
PL_scopestack_ix += 1;
/* sv_2cv is too complicated, try a simpler variant first: */
- if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
+ if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
|| SvTYPE(cv) != SVt_PVCV) {
HV *st;
cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
if (sip) {
HV *sih = newHV();
- SV *rv = newRV_noinc((SV*)sih);
+ 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));
hv_stores(sih, "band", newSViv(sip->si_band));
#endif
EXTEND(SP, 2);
- PUSHs((SV*)rv);
- PUSHs(newSVpvn((char *)sip, sizeof(*sip)));
+ PUSHs(rv);
+ mPUSHp((char *)sip, sizeof(*sip));
}
}
#endif
PUTBACK;
- call_sv((SV*)cv, G_DISCARD|G_EVAL);
+ call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
POPSTACK;
if (SvTRUE(ERRSV)) {
dVAR;
const U32 flags = *(const U32*)p;
+ PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
+
if (flags & 1)
PL_savestack_ix -= 5; /* Unprotect save in progress. */
#if !defined(PERL_IMPLICIT_CONTEXT)
Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
+ SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
: newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
+ PERL_ARGS_ASSERT_MAGIC_SETHINT;
+
/* mg->mg_obj isn't being used. If needed, it would be possible to store
an alternative leaf in there, with PL_compiling.cop_hints being used if
it's NULL. If needed for threads, the alternative could lock a mutex,
}
/*
-=for apidoc magic_sethint
+=for apidoc magic_clearhint
Triggered by a delete from %^H, records the key to
C<PL_compiling.cop_hints_hash>.
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
assert(mg->mg_len == HEf_SVKEY);
PL_hints |= HINT_LOCALIZE_HH;
PL_compiling.cop_hints_hash
= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
- (SV *)mg->mg_ptr, &PL_sv_placeholder);
+ MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
return 0;
}
https://perl5.git.perl.org / perl5.git / blobdiff