/* mg.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005 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.
/*
=head1 Magical Functions
+
+"Magic" is special data attached to SV structures in order to give them
+"magical" properties. When any Perl code tries to read from, or assign to,
+an SV marked as magical, it calls the 'get' or 'set' function associated
+with that SV's magic. A get is called prior to reading an SV, in order to
+give it a chance to update its internal value (get on $. writes the line
+number of the last read filehandle into to the SV's IV slot), while
+set is called after an SV has been written to, in order to allow it to make
+use of its changed value (set on $/ copies the SV's new value to the
+PL_rs global variable).
+
+Magic is implemented as a linked list of MAGIC structures attached to the
+SV. Each MAGIC struct holds the type of the magic, a pointer to an array
+of functions that implement the get(), set(), length() etc functions,
+plus space for some flags and pointers. For example, a tied variable has
+a MAGIC structure that contains a pointer to the object associated with the
+tie.
+
*/
#include "EXTERN.h"
static void restore_magic(pTHX_ void *p);
static void unwind_handler_stack(pTHX_ void *p);
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+void setruid(uid_t id);
+void seteuid(uid_t id);
+void setrgid(uid_t id);
+void setegid(uid_t id);
+#endif
+
/*
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
*/
int new = 0;
MAGIC *newmg, *head, *cur, *mg;
I32 mgs_ix = SSNEW(sizeof(MGS));
+ int was_temp = SvTEMP(sv);
+ /* guard against sv having being freed midway by holding a private
+ reference. */
+
+ /* 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(sv));
+ if (!was_temp) {
+ SvTEMP_off(sv);
+ }
save_magic(mgs_ix, sv);
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
- /* guard against sv having been freed */
- if (SvTYPE(sv) == SVTYPEMASK) {
- Perl_croak(aTHX_ "Tied variable freed while still in use");
- }
+ /* guard against magic having been deleted - eg FETCH calling
+ * untie */
+ if (!SvMAGIC(sv))
+ break;
/* Don't restore the flags for this entry if it was deleted. */
if (mg->mg_flags & MGf_GSKIP)
}
restore_magic(aTHX_ 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;
}
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len > 0)
+ 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);
return 0;
}
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
-#endif
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
}
else {
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
}
}
else {
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
}
return 0;
case '+':
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
register I32 paren;
- register char *s;
+ register char *s = NULL;
register I32 i;
register REGEXP *rx;
case '\004': /* ^D */
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
-#if defined(YYDEBUG) && defined(DEBUGGING)
- PL_yydebug = DEBUG_p_TEST;
-#endif
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
SetLastError(dwErr);
}
#else
- sv_setnv(sv, (NV)errno);
- sv_setpv(sv, errno ? Strerror(errno) : "");
+ {
+ int saveerrno = errno;
+ sv_setnv(sv, (NV)errno);
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+ errno = saveerrno;
+ }
#endif
#endif
#endif
sv_setsv(sv, &PL_sv_undef);
break;
case '\017': /* ^O & ^OPEN */
- if (*(mg->mg_ptr+1) == '\0')
+ if (*(mg->mg_ptr+1) == '\0') {
sv_setpv(sv, PL_osname);
+ SvTAINTED_off(sv);
+ }
else if (strEQ(mg->mg_ptr, "\017PEN")) {
if (!PL_compiling.cop_io)
sv_setsv(sv, &PL_sv_undef);
case '\023': /* ^S */
if (*(mg->mg_ptr+1) == '\0') {
if (PL_lex_state != LEX_NOTPARSING)
- (void)SvOK_off(sv);
+ SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
else
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
- case '\025': /* $^UNICODE */
+ case '\025': /* $^UNICODE, $^UTF8LOCALE */
if (strEQ(mg->mg_ptr, "\025NICODE"))
sv_setuv(sv, (UV) PL_unicode);
+ else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
+ sv_setuv(sv, (UV) PL_utf8locale);
break;
case '\027': /* ^W & $^WARNING_BITS */
if (*(mg->mg_ptr+1) == '\0')
}
break;
case '^':
- s = IoTOP_NAME(GvIOp(PL_defoutgv));
+ if (GvIOp(PL_defoutgv))
+ s = IoTOP_NAME(GvIOp(PL_defoutgv));
if (s)
sv_setpv(sv,s);
else {
}
break;
case '~':
- s = IoFMT_NAME(GvIOp(PL_defoutgv));
+ if (GvIOp(PL_defoutgv))
+ s = IoFMT_NAME(GvIOp(PL_defoutgv));
if (!s)
s = GvENAME(PL_defoutgv);
sv_setpv(sv,s);
break;
#ifndef lint
case '=':
- sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
break;
case '-':
- sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
break;
case '%':
- sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
#endif
case ':':
WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
break;
case '|':
- sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
break;
case ',':
break;
#endif
(void)SvIOK_on(sv); /* what a wonderful hack! */
break;
- case '*':
- break;
#ifndef MACOS_TRADITIONAL
case '0':
break;
int
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
+#ifndef PERL_MICRO
#if defined(VMS) || defined(EPOC)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
# endif
{
# ifndef PERL_USE_SAFE_PUTENV
+ if (!PL_use_safe_putenv) {
I32 i;
if (environ == PL_origenviron)
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
+ }
# endif /* PERL_USE_SAFE_PUTENV */
environ[0] = Nullch;
}
# endif /* USE_ENVIRON_ARRAY */
# endif /* PERL_IMPLICIT_SYS || WIN32 */
-#endif /* VMS || EPC */
+#endif /* VMS || EPOC */
+#endif /* !PERL_MICRO */
return 0;
}
STRLEN n_a;
/* Are we fetching a signal entry? */
i = whichsig(MgPV(mg,n_a));
- if (i) {
+ if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
else {
I32 i;
/* Are we clearing a signal entry? */
i = whichsig(s);
- if (i) {
+ if (i > 0) {
#ifdef HAS_SIGPROCMASK
sigset_t set, save;
SV* save_sv;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
sig_defaulting[i] = 1;
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, SIG_DFL);
#endif
dTHX;
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- (void) rsignal(sig, &Perl_csighandler);
+ (void) rsignal(sig, PL_csighandlerp);
if (sig_ignoring[sig]) return;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
dTHX;
sig_defaulting[sig] = 1;
- (void) rsignal(sig, &Perl_csighandler);
+ (void) rsignal(sig, PL_csighandlerp);
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
sig_ignoring[sig] = 0;
}
else {
i = whichsig(s); /* ...no, a brick */
- if (!i) {
+ if (i < 0) {
if (ckWARN(WARN_SIGNAL))
Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
return 0;
}
if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
if (i) {
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
#ifdef HAS_SIGPROCMASK
LEAVE;
#endif
if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
sig_ignoring[i] = 1;
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, SIG_IGN);
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
{
sig_defaulting[i] = 1;
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
}
#else
(void)rsignal(i, SIG_DFL);
if (!strchr(s,':') && !strchr(s,'\''))
sv_insert(sv, 0, 0, "main::", 6);
if (i)
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
else
*svp = SvREFCNT_inc(sv);
}
int
Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
- magic_methpack(sv,mg,"FETCH");
if (mg->mg_ptr)
mg->mg_flags |= MGf_GSKIP;
+ magic_methpack(sv,mg,"FETCH");
return 0;
}
call_method("CLEAR", G_SCALAR|G_DISCARD);
POPSTACK;
LEAVE;
+
return 0;
}
return magic_methpack(sv,mg,"EXISTS");
}
+SV *
+Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
+{
+ dSP;
+ SV *retval = &PL_sv_undef;
+ SV *tied = SvTIED_obj((SV*)hv, mg);
+ HV *pkg = SvSTASH((SV*)SvRV(tied));
+
+ if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
+ SV *key;
+ if (HvEITER(hv))
+ /* we are in an iteration so the hash cannot be empty */
+ return &PL_sv_yes;
+ /* no xhv_eiter so now use FIRSTKEY */
+ key = sv_newmortal();
+ magic_nextpack((SV*)hv, mg, key);
+ HvEITER(hv) = NULL; /* need to reset iterator */
+ return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
+ }
+
+ /* 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--;
+ POPSTACK;
+ LEAVE;
+ return retval;
+}
+
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
return 0;
}
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
int
Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
GV* gv;
- STRLEN n_a;
-
+
if (!SvOK(sv))
return 0;
- s = SvPV(sv, n_a);
- if (*s == '*' && s[1])
- s++;
- gv = gv_fetchpv(s,TRUE, SVt_PVGV);
+ gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
if (sv == (SV*)gv)
return 0;
if (GvGP(sv))
sv_utf8_upgrade(lsv);
sv_pos_u2b(lsv, &lvoff, &lvlen);
sv_insert(lsv, lvoff, lvlen, tmps, len);
+ LvTARGLEN(sv) = sv_len_utf8(sv);
SvUTF8_on(lsv);
}
else if (lsv && SvUTF8(lsv)) {
sv_pos_u2b(lsv, &lvoff, &lvlen);
+ LvTARGLEN(sv) = len;
tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
sv_insert(lsv, lvoff, lvlen, tmps, len);
Safefree(tmps);
}
- else
- sv_insert(lsv, lvoff, lvlen, tmps, len);
+ else {
+ sv_insert(lsv, lvoff, lvlen, tmps, len);
+ LvTARGLEN(sv) = len;
+ }
+
return 0;
}
SV *lsv = LvTARG(sv);
if (!lsv) {
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
SV **svp = AvARRAY(av);
I32 i = AvFILLp(av);
while (i >= 0) {
- if (svp[i] && svp[i] != &PL_sv_undef) {
+ if (svp[i]) {
if (!SvWEAKREF(svp[i]))
Perl_croak(aTHX_ "panic: magic_killbackrefs");
/* XXX Should we check that it hasn't changed? */
SvRV(svp[i]) = 0;
- (void)SvOK_off(svp[i]);
+ SvOK_off(svp[i]);
SvWEAKREF_off(svp[i]);
- svp[i] = &PL_sv_undef;
+ svp[i] = Nullsv;
}
i--;
}
+ SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
return 0;
}
break;
case '\004': /* ^D */
- PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#ifdef DEBUGGING
+ s = SvPV_nolen(sv);
+ PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
DEBUG_x(dump_all());
+#else
+ PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#endif
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
if (PL_inplace)
Safefree(PL_inplace);
if (SvOK(sv))
- PL_inplace = savepv(SvPV(sv,len));
+ PL_inplace = savesvpv(sv);
else
PL_inplace = Nullch;
break;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
- if (PL_osname)
+ if (PL_osname) {
Safefree(PL_osname);
- if (SvOK(sv))
- PL_osname = savepv(SvPV(sv,len));
- else
PL_osname = Nullch;
+ }
+ if (SvOK(sv)) {
+ TAINT_PROPER("assigning to $^O");
+ PL_osname = savesvpv(sv);
+ }
}
else if (strEQ(mg->mg_ptr, "\017PEN")) {
if (!PL_compiling.cop_io)
break;
case '\020': /* ^P */
PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- if (PL_perldb && !PL_DBsingle)
+ if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
+ && !PL_DBsingle)
init_debugger();
break;
case '\024': /* ^T */
break;
case '^':
Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+ IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savesvpv(sv);
+ IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
break;
case '~':
Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
- IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
- IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+ IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savesvpv(sv);
+ IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
break;
case '=':
IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
}
}
break;
- case '*':
- i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- PL_multiline = (i != 0);
- break;
case '/':
SvREFCNT_dec(PL_rs);
PL_rs = newSVsv(sv);
case '#':
if (PL_ofmt)
Safefree(PL_ofmt);
- PL_ofmt = savepv(SvPV(sv,len));
+ PL_ofmt = savesvpv(sv);
break;
case '[':
PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
#else
- if (PL_uid == PL_euid) /* special case $< = $> */
+ if (PL_uid == PL_euid) { /* special case $< = $> */
+#ifdef PERL_DARWIN
+ /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
+ if (PL_uid != 0 && PerlProc_getuid() == 0)
+ (void)PerlProc_setuid(0);
+#endif
(void)PerlProc_setuid(PL_uid);
- else {
+ } else {
PL_uid = PerlProc_getuid();
Perl_croak(aTHX_ "setruid() not implemented");
}
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
#endif
- if (!PL_origalen) {
- s = PL_origargv[0];
- s += strlen(s);
- /* See if all the arguments are contiguous in memory */
- for (i = 1; i < PL_origargc; i++) {
- if (PL_origargv[i] == s + 1
-#ifdef OS2
- || PL_origargv[i] == s + 2
-#endif
- )
- {
- ++s;
- s += strlen(s); /* this one is ok too */
- }
- else
- break;
- }
- /* can grab env area too? */
- if (PL_origenviron
-#ifdef USE_ITHREADS
- && PL_curinterp == aTHX
-#endif
- && (PL_origenviron[0] == s + 1))
- {
- my_setenv("NoNe SuCh", Nullch);
- /* force copy of environment */
- for (i = 0; PL_origenviron[i]; i++)
- if (PL_origenviron[i] == s + 1) {
- ++s;
- s += strlen(s);
- }
- else
- break;
- }
- PL_origalen = s - PL_origargv[0];
- }
+ /* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
- i = len;
- if (i >= (I32)PL_origalen) {
- i = PL_origalen;
- /* don't allow system to limit $0 seen by script */
- /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
- Copy(s, PL_origargv[0], i, char);
- s = PL_origargv[0]+i;
- *s = '\0';
+ if (len >= (STRLEN)PL_origalen-1) {
+ /* Longer than original, will be truncated. We assume that
+ * PL_origalen bytes are available. */
+ Copy(s, PL_origargv[0], PL_origalen-1, char);
}
else {
- Copy(s, PL_origargv[0], i, char);
- s = PL_origargv[0]+i;
- *s++ = '\0';
- while (++i < (I32)PL_origalen)
- *s++ = '\0';
- for (i = 1; i < PL_origargc; i++)
- PL_origargv[i] = Nullch;
- }
+ /* Shorter than original, will be padded. */
+ Copy(s, PL_origargv[0], len, char);
+ PL_origargv[0][len] = 0;
+ memset(PL_origargv[0] + len + 1,
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ (int)' ',
+ PL_origalen - len - 1);
+ }
+ PL_origargv[0][PL_origalen-1] = 0;
+ for (i = 1; i < PL_origargc; i++)
+ PL_origargv[i] = 0;
UNLOCK_DOLLARZERO_MUTEX;
break;
#endif
{
register char **sigv;
- for (sigv = PL_sig_name+1; *sigv; sigv++)
+ for (sigv = PL_sig_name; *sigv; sigv++)
if (strEQ(sig,*sigv))
return PL_sig_num[sigv - PL_sig_name];
#ifdef SIGCLD
if (strEQ(sig,"CLD"))
return SIGCHLD;
#endif
- return 0;
+ return -1;
}
#if !defined(PERL_IMPLICIT_CONTEXT)
flags |= 1;
if (PL_markstack_ptr < PL_markstack_max - 2)
flags |= 4;
- if (PL_retstack_ix < PL_retstack_max - 2)
- flags |= 8;
if (PL_scopestack_ix < PL_scopestack_max - 3)
flags |= 16;
}
if (flags & 4)
PL_markstack_ptr++; /* Protect mark. */
- if (flags & 8) {
- PL_retstack_ix++;
- PL_retstack[PL_retstack_ix] = NULL;
- }
if (flags & 16)
PL_scopestack_ix += 1;
/* sv_2cv is too complicated, try a simpler variant first: */
#else
/* Not clear if this will work */
(void)rsignal(sig, SIG_IGN);
- (void)rsignal(sig, &Perl_csighandler);
+ (void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- Perl_die(aTHX_ Nullformat);
+ DieNull;
}
cleanup:
if (flags & 1)
PL_savestack_ix -= 8; /* Unprotect save in progress. */
if (flags & 4)
PL_markstack_ptr--;
- if (flags & 8)
- PL_retstack_ix--;
if (flags & 16)
PL_scopestack_ix -= 1;
if (flags & 64)
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
{
+#ifdef PERL_COPY_ON_WRITE
+ /* While magic was saved (and off) sv_setsv may well have seen
+ this SV as a prime candidate for COW. */
+ if (SvIsCOW(sv))
+ sv_force_normal(sv);
+#endif
+
if (mgs->mgs_flags)
SvFLAGS(sv) |= mgs->mgs_flags;
else
https://perl5.git.perl.org / perl5.git / blobdiff