#endif
/*
+ * Pre-magic setup and post-magic takedown.
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
*/
PERL_ARGS_ASSERT_SAVE_MAGIC;
+ assert(SvMAGICAL(sv));
+
/* 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++
bumped = TRUE;
}
- assert(SvMAGICAL(sv));
/* Turning READONLY off for a copy-on-write scalar (including shared
hash keys) is a bad idea. */
if (SvIsCOW(sv))
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
- if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
- /* No public flags are set, so promote any private flags to public. */
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- }
}
/*
{
dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
+ bool saved = FALSE;
bool have_new = 0;
MAGIC *newmg, *head, *cur, *mg;
if (PL_localizing == 1 && sv == DEFSV) return 0;
- save_magic(mgs_ix, sv);
-
/* We must call svt_get(sv, mg) for each valid entry in the linked
list of magic. svt_get() may delete the current entry, add new
magic to the head of the list, or upgrade the SV. AMS 20010810 */
MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
+
+ /* taint's mg get is so dumb it doesn't need flag saving */
+ if (!saved && mg->mg_type != PERL_MAGIC_taint) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+
vtbl->svt_get(aTHX_ sv, mg);
/* guard against magic having been deleted - eg FETCH calling
if (mg->mg_flags & MGf_GSKIP)
(SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
}
+ else if (vtbl == &PL_vtbl_utf8) {
+ /* get-magic can reallocate the PV */
+ magic_setutf8(sv, mg);
+ }
mg = nextmg;
}
}
- restore_magic(INT2PTR(void *, (IV)mgs_ix));
+ if (saved)
+ restore_magic(INT2PTR(void *, (IV)mgs_ix));
+
return 0;
}
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
if (PL_curpm) {
- register const REGEXP * const rx = PM_GETRE(PL_curpm);
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
if (mg->mg_obj) { /* @+ */
/* return the number possible */
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
if (PL_curpm) {
- register const REGEXP * const rx = PM_GETRE(PL_curpm);
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- register const I32 paren = mg->mg_len;
- register I32 s;
- register I32 t;
+ const I32 paren = mg->mg_len;
+ I32 s;
+ I32 t;
if (paren < 0)
return 0;
if (paren <= (I32)RX_NPARENS(rx) &&
(s = RX_OFFS(rx)[paren].start) != -1 &&
(t = RX_OFFS(rx)[paren].end) != -1)
{
- register I32 i;
+ I32 i;
if (mg->mg_obj) /* @+ */
i = t;
else /* @- */
Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- register I32 paren;
- register I32 i;
- register const REGEXP * rx;
+ I32 paren;
+ I32 i;
+ const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;
PERL_ARGS_ASSERT_MAGIC_LEN;
}
}
+#ifdef VMS
+#include <descrip.h>
+#include <starlet.h>
+#endif
+
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- register I32 paren;
- register const char *s = NULL;
- register REGEXP *rx;
+ I32 paren;
+ const char *s = NULL;
+ REGEXP *rx;
const char * const remaining = mg->mg_ptr + 1;
const char nextchar = *remaining;
switch (*mg->mg_ptr) {
case '\001': /* ^A */
- sv_setsv(sv, PL_bodytarget);
+ if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
+ else sv_setsv(sv, &PL_sv_undef);
if (SvTAINTED(PL_bodytarget))
SvTAINTED_on(sv);
break;
if (nextchar == '\0') {
#if defined(VMS)
{
-# include <descrip.h>
-# include <starlet.h>
char msg[255];
$DESCRIPTOR(msgdsc,msg);
sv_setnv(sv,(NV) vaxc$errno);
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", 0);
- if (bits) {
- SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
- if (bits_all)
- sv_setsv(sv, *bits_all);
- }
- else {
- sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
- }
+ HV * const bits = get_hv("warnings::Bits", 0);
+ SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
+ if (bits_all)
+ sv_copypv(sv, *bits_all);
+ else
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
*PL_compiling.cop_warnings);
}
- SvPOK_only(sv);
}
break;
case '\015': /* $^MATCH */
case '\\':
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
+ else
+ sv_setsv(sv, &PL_sv_undef);
break;
case '$': /* $$ */
{
IV const pid = (IV)PerlProc_getpid();
- if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid)
+ if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
/* never set manually, or at least not since last fork */
sv_setiv(sv, pid);
+ /* never unsafe, even if reading in a tainted expression */
+ SvTAINTED_off(sv);
+ }
/* else a value has been assigned manually, so do nothing */
}
break;
else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
- if (SvPOKp(sv))
- SvPOK_on(sv); /* may have got removed during taint processing */
RESTORE_ERRNO;
}
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '<':
- sv_setiv(sv, (IV)PL_uid);
+ sv_setiv(sv, (IV)PerlProc_getuid());
break;
case '>':
- sv_setiv(sv, (IV)PL_euid);
+ sv_setiv(sv, (IV)PerlProc_geteuid());
break;
case '(':
- sv_setiv(sv, (IV)PL_gid);
+ sv_setiv(sv, (IV)PerlProc_getgid());
goto add_groups;
case ')':
- sv_setiv(sv, (IV)PL_egid);
+ sv_setiv(sv, (IV)PerlProc_getegid());
add_groups:
#ifdef HAS_GETGROUPS
{
{
dVAR;
STRLEN len = 0, klen;
- const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
- const char * const ptr = MgPV_const(mg,klen);
- my_setenv(ptr, s);
+ const char * const key = MgPV_const(mg,klen);
+ const char *s = NULL;
PERL_ARGS_ASSERT_MAGIC_SETENV;
+ SvGETMAGIC(sv);
+ if (SvOK(sv)) {
+ /* defined environment variables are byte strings; unfortunately
+ there is no SvPVbyte_force_nomg(), so we must do this piecewise */
+ (void)SvPV_force_nomg_nolen(sv);
+ sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
+ if (SvUTF8(sv)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
+ SvUTF8_off(sv);
+ }
+ s = SvPVX(sv);
+ len = SvCUR(sv);
+ }
+ my_setenv(key, s); /* does the deed */
+
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
- SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
+ SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
if (valp)
s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
}
if (PL_tainting) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
- if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
+ if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
int i = 0, j = 0;
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
}
#endif /* VMS */
- if (s && klen == 4 && strEQ(ptr,"PATH")) {
+ if (s && klen == 4 && strEQ(key,"PATH")) {
const char * const strend = s + len;
while (s < strend) {
sigset_t set, save;
SV* save_sv;
#endif
- register const char *s = MgPV_const(mg,len);
+ const char *s = MgPV_const(mg,len);
PERL_ARGS_ASSERT_MAGIC_SETSIG;
}
int
-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++;
-
- return 0;
-}
-
-int
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
HV * const hv = MUTABLE_HV(LvTARG(sv));
if (svp && SvIOKp(*svp)) {
OP * const o = INT2PTR(OP*,SvIVX(*svp));
if (o) {
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_rw(OpSLAB(o));
+#endif
/* set or clear breakpoint in the relevant control op */
if (i)
o->op_flags |= OPf_SPECIAL;
else
o->op_flags &= ~OPf_SPECIAL;
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_ro(OpSLAB(o));
+#endif
}
}
return 0;
}
int
+Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
+ PERL_UNUSED_ARG(sv);
+
+ /* Reset the iterator when the array is cleared */
+#if IVSIZE == I32SIZE
+ *((IV *) &(mg->mg_len)) = 0;
+#else
+ if (mg->mg_ptr)
+ *((IV *) mg->mg_ptr) = 0;
+#endif
+
+ return 0;
+}
+
+int
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
found->mg_len = -1;
return 0;
}
- len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
+ len = SvPOK_nog(lsv) ? SvCUR(lsv) : sv_len(lsv);
pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_len_utf8(lsv);
+ ulen = sv_len_utf8_nomg(lsv);
if (ulen)
len = ulen;
}
pos = len;
if (ulen) {
- I32 p = pos;
- sv_pos_u2b(lsv, &p, 0);
- pos = p;
+ pos = sv_pos_u2b_flags(lsv, pos, 0, 0);
}
found->mg_len = pos;
PERL_UNUSED_ARG(mg);
if (!translate_substr_offsets(
- SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
+ SvUTF8(lsv) ? sv_len_utf8_nomg(lsv) : len,
negoff ? -(IV)offs : (IV)offs, !negoff,
negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
)) {
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr"
);
- if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
+ if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
else (void)SvPV_nomg(lsv,lsv_len);
if (!translate_substr_offsets(
lsv_len,
}
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;
} 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);
}
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- register const char *s;
- register I32 paren;
- register const REGEXP * rx;
+ const char *s;
+ I32 paren;
+ const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;
paren = atoi(mg->mg_ptr);
setparen:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ setparen_got_rx:
CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
} else {
/* Croak with a READONLY error when a numbered match var is
* set without a previous pattern match. Unless it's C<local $1>
*/
+ croakparen:
if (!PL_localizing) {
Perl_croak_no_modify(aTHX);
}
}
break;
case '\001': /* ^A */
- sv_setsv(PL_bodytarget, sv);
+ if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
+ else SvOK_off(PL_bodytarget);
FmLINES(PL_bodytarget) = 0;
if (SvPOK(PL_bodytarget)) {
char *s = SvPVX(PL_bodytarget);
Safefree(PL_inplace);
PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
break;
+ case '\016': /* ^N */
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))
+ && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
+ goto croakparen;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
Safefree(PL_osname);
break;
case '\\':
SvREFCNT_dec(PL_ors_sv);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
+ if (SvOK(sv)) {
PL_ors_sv = newSVsv(sv);
}
else {
}
break;
case '<':
- PL_uid = SvIV(sv);
+ {
+ const IV new_uid = SvIV(sv);
+ PL_delaymagic_uid = new_uid;
if (PL_delaymagic) {
PL_delaymagic |= DM_RUID;
break; /* don't do magic till later */
}
#ifdef HAS_SETRUID
- (void)setruid((Uid_t)PL_uid);
+ (void)setruid((Uid_t)new_uid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
+ (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
+ (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
#else
- if (PL_uid == PL_euid) { /* special case $< = $> */
+ if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
#ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
- if (PL_uid != 0 && PerlProc_getuid() == 0)
+ if (new_uid != 0 && PerlProc_getuid() == 0)
(void)PerlProc_setuid(0);
#endif
- (void)PerlProc_setuid(PL_uid);
+ (void)PerlProc_setuid(new_uid);
} else {
- PL_uid = PerlProc_getuid();
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
#endif
#endif
- PL_uid = PerlProc_getuid();
break;
+ }
case '>':
- PL_euid = SvIV(sv);
+ {
+ const UV new_euid = SvIV(sv);
+ PL_delaymagic_euid = new_euid;
if (PL_delaymagic) {
PL_delaymagic |= DM_EUID;
break; /* don't do magic till later */
}
#ifdef HAS_SETEUID
- (void)seteuid((Uid_t)PL_euid);
+ (void)seteuid((Uid_t)new_euid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
+ (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
+ (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
#else
- if (PL_euid == PL_uid) /* special case $> = $< */
- PerlProc_setuid(PL_euid);
+ if (new_euid == PerlProc_getuid()) /* special case $> = $< */
+ PerlProc_setuid(new_euid);
else {
- PL_euid = PerlProc_geteuid();
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
#endif
#endif
- PL_euid = PerlProc_geteuid();
break;
+ }
case '(':
- PL_gid = SvIV(sv);
+ {
+ const UV new_gid = SvIV(sv);
+ PL_delaymagic_gid = new_gid;
if (PL_delaymagic) {
PL_delaymagic |= DM_RGID;
break; /* don't do magic till later */
}
#ifdef HAS_SETRGID
- (void)setrgid((Gid_t)PL_gid);
+ (void)setrgid((Gid_t)new_gid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
+ (void)setregid((Gid_t)new_gid, (Gid_t)-1);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1);
+ (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
#else
- if (PL_gid == PL_egid) /* special case $( = $) */
- (void)PerlProc_setgid(PL_gid);
+ if (new_gid == PerlProc_getegid()) /* special case $( = $) */
+ (void)PerlProc_setgid(new_gid);
else {
- PL_gid = PerlProc_getgid();
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
#endif
#endif
- PL_gid = PerlProc_getgid();
break;
+ }
case ')':
+ {
+ UV new_egid;
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(sv, len);
while (isSPACE(*p))
++p;
- PL_egid = Atol(p);
+ new_egid = Atol(p);
for (i = 0; i < maxgrp; ++i) {
while (*p && !isSPACE(*p))
++p;
Safefree(gary);
}
#else /* HAS_SETGROUPS */
- PL_egid = SvIV(sv);
+ new_egid = SvIV(sv);
#endif /* HAS_SETGROUPS */
+ PL_delaymagic_egid = new_egid;
if (PL_delaymagic) {
PL_delaymagic |= DM_EGID;
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- (void)setegid((Gid_t)PL_egid);
+ (void)setegid((Gid_t)new_egid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
+ (void)setregid((Gid_t)-1, (Gid_t)new_egid);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
+ (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
#else
- if (PL_egid == PL_gid) /* special case $) = $( */
- (void)PerlProc_setgid(PL_egid);
+ if (new_egid == PerlProc_getgid()) /* special case $) = $( */
+ (void)PerlProc_setgid(new_egid);
else {
- PL_egid = PerlProc_getegid();
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
#endif
#endif
- PL_egid = PerlProc_getegid();
break;
+ }
case ':':
PL_chopset = SvPV_force(sv,len);
break;
I32
Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
{
- register char* const* sigv;
+ char* const* sigv;
PERL_ARGS_ASSERT_WHICHSIG_PVN;
PERL_UNUSED_CONTEXT;
U32 flags = 0;
XPV * const tXpv = PL_Xpv;
I32 old_ss_ix = PL_savestack_ix;
+ SV *errsv_save = NULL;
if (!PL_psig_ptr[sig]) {
#endif
PUTBACK;
+ errsv_save = newSVsv(ERRSV);
+
call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
POPSTACK;
if (SvTRUE(ERRSV)) {
+ SvREFCNT_dec(errsv_save);
#ifndef PERL_MICRO
/* 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
#endif /* !PERL_MICRO */
die_sv(ERRSV);
}
+ else {
+ sv_setsv(ERRSV, errsv_save);
+ SvREFCNT_dec(errsv_save);
+ }
+
cleanup:
/* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
PL_savestack_ix = old_ss_ix;
if (!sv)
return;
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
- {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
#ifdef PERL_OLD_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_flags(sv, 0);
#endif
-
if (mgs->mgs_readonly)
SvREADONLY_on(sv);
if (mgs->mgs_magical)
SvFLAGS(sv) |= mgs->mgs_magical;
else
mg_magical(sv);
- if (SvGMAGICAL(sv)) {
- /* downgrade public flags to private,
- and discard any other private flags */
-
- const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
- if (pubflags) {
- SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
- SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
- }
- }
}
bumped = mgs->mgs_bumped;
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);
+ SvTEMP_off(sv);
}
else
SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
- assert(mg->mg_len == HEf_SVKEY);
-
- PERL_UNUSED_ARG(sv);
-
PL_hints |= HINT_LOCALIZE_HH;
CopHINTHASH_set(&PL_compiling,
- cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
- MUTABLE_SV(mg->mg_ptr), 0, 0));
+ mg->mg_len == HEf_SVKEY
+ ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
+ MUTABLE_SV(mg->mg_ptr), 0, 0)
+ : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
+ mg->mg_ptr, mg->mg_len, 0, 0));
return 0;
}
return 0;
}
+int
+Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
+ const char *name, I32 namlen)
+{
+ MAGIC *nmg;
+
+ PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(name);
+ PERL_UNUSED_ARG(namlen);
+
+ sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
+ nmg = mg_find(nsv, mg->mg_type);
+ if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
+ nmg->mg_ptr = mg->mg_ptr;
+ nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
+ nmg->mg_flags |= MGf_REFCOUNTED;
+ return 1;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff