*/
/*
- * "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"]
*/
/*
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:
/*
=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;
+ }
}
}
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);
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;
}
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] */
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);
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
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)
/* Bail out if destruction is going on */
if(PL_dirty) return 0;
- av_clear((AV*)sv);
+ av_clear(MUTABLE_AV(sv));
/* XXX see comments in magic_setisa */
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)
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;
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))
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;
}
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;
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;
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;
}
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;
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 (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)];
}
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 {
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
- return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
+ return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
}
int
* 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 */
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;
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(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)) {
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;
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;
}