{
MGS* mgs;
assert(SvMAGICAL(sv));
+#ifdef PERL_COPY_ON_WRITE
+ /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
+ if (SvIsCOW(sv))
+ sv_force_normal(sv);
+#endif
SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
}
- if (mg->mg_flags & MGf_REFCOUNTED) {
- SV *obj = mg->mg_obj;
- if (mg->mg_type == PERL_MAGIC_tiedscalar && SvROK(obj) &&
- (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO *) sv)) {
- /* We are already free'ing the self-tied thing
- so must not SvREFCNT_dec.
- */
- SvROK_off(obj);
- } else
- SvREFCNT_dec(obj);
- }
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
}
SvMAGIC(sv) = 0;
getrx:
if (i >= 0) {
- bool was_tainted = FALSE;
- if (PL_tainting) {
- was_tainted = PL_tainted;
- PL_tainted = FALSE;
- }
sv_setpvn(sv, s, i);
- if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i))
+ if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i))
SvUTF8_on(sv);
else
SvUTF8_off(sv);
- if (PL_tainting)
- PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx));
+ if (PL_tainting) {
+ if (RX_MATCH_TAINTED(rx)) {
+ MAGIC* mg = SvMAGIC(sv);
+ MAGIC* mgt;
+ PL_tainted = 1;
+ SvMAGIC(sv) = mg->mg_moremagic;
+ SvTAINT(sv);
+ if ((mgt = SvMAGIC(sv))) {
+ mg->mg_moremagic = mgt;
+ SvMAGIC(sv) = mg;
+ }
+ } else
+ SvTAINTED_off(sv);
+ }
break;
}
}
case '0':
break;
#endif
-#ifdef USE_5005THREADS
- case '@':
- sv_setsv(sv, thr->errsv);
- break;
-#endif /* USE_5005THREADS */
}
return 0;
}
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
- if (SvTYPE(ahv) == SVt_PVHV) {
- HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
- if (he)
- targ = HeVAL(he);
- }
- else {
- SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
- if (svp)
- targ = *svp;
- }
+ HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
+ if (he)
+ targ = HeVAL(he);
}
else {
AV* av = (AV*)LvTARG(sv);
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
STRLEN n_a;
- if (SvTYPE(ahv) == SVt_PVHV) {
- HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
- if (he)
- value = HeVAL(he);
- }
- else {
- SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
- if (svp)
- value = *svp;
- }
+ HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
+ if (he)
+ value = HeVAL(he);
if (!value || value == &PL_sv_undef)
Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
}
DEBUG_x(dump_all());
break;
case '\005': /* ^E */
- if (*(mg->mg_ptr+1) == '\0') {
+ if (*(mg->mg_ptr+1) == '\0') {
#ifdef MACOS_TRADITIONAL
- gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
#else
# ifdef VMS
- set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
# else
# ifdef WIN32
- SetLastError( SvIV(sv) );
+ SetLastError( SvIV(sv) );
# else
# ifdef OS2
- os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
# else
- /* will anyone ever use this? */
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
+ /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
# endif
# endif
# endif
#endif
- }
- else if (strEQ(mg->mg_ptr+1, "NCODING")) {
- if (PL_encoding)
- sv_setsv(PL_encoding, sv);
- else
- PL_encoding = newSVsv(sv);
- }
+ }
+ else if (strEQ(mg->mg_ptr+1, "NCODING")) {
+ if (PL_encoding)
+ SvREFCNT_dec(PL_encoding);
+ if (SvOK(sv) || SvGMAGICAL(sv)) {
+ PL_encoding = newSVsv(sv);
+ }
+ else {
+ PL_encoding = Nullsv;
+ }
+ }
+ break;
case '\006': /* ^F */
PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '!':
+ {
+#ifdef VMS
+# define PERL_VMS_BANG vaxc$errno
+#else
+# define PERL_VMS_BANG 0
+#endif
SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
- (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
+ (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
+ }
break;
case '<':
PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
}
break;
#endif
-#ifdef USE_5005THREADS
- case '@':
- sv_setsv(thr->errsv, sv);
- break;
-#endif /* USE_5005THREADS */
}
return 0;
}
-#ifdef USE_5005THREADS
-int
-Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
-{
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(sv)));
- if (MgOWNER(mg))
- Perl_croak(aTHX_ "panic: magic_mutexfree");
- MUTEX_DESTROY(MgMUTEXP(mg));
- COND_DESTROY(MgCONDP(mg));
- return 0;
-}
-#endif /* USE_5005THREADS */
-
I32
Perl_whichsig(pTHX_ char *sig)
{