*/
/*
- * "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"]
*/
/*
{
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);
}
/*
=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;
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;
+ }
}
}
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;
}
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>
}
#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;
}
{
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;
+
+ magic_setsig(NULL, mg);
+ return sv_unmagic(sv, mg->mg_type);
}
Signal_t
#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);
}
}
+/* sv of NULL signifies that we're acting as magic_clearsig. */
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
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 (isGV_with_GP(sv) || 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_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;
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
- ? (GV*)mg->mg_obj
- : (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 see comments in magic_setisa */
+ /* 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
- ? (GV*)mg->mg_obj
- : (GV*)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
+ ? (const GV *)mg->mg_obj
+ : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
);
if (stash)
* 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
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;
}
https://perl5.git.perl.org / perl5.git / blobdiff