/* MGS is typedef'ed to struct magic_state in perl.h */
STATIC void
-S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
+S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
{
dVAR;
MGS* mgs;
bool bumped = FALSE;
- PERL_ARGS_ASSERT_SAVE_MAGIC;
+ PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
assert(SvMAGICAL(sv));
bumped = TRUE;
}
- /* Turning READONLY off for a copy-on-write scalar (including shared
- hash keys) is a bad idea. */
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-
SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
mgs->mgs_bumped = bumped;
- SvMAGICAL_off(sv);
+ SvFLAGS(sv) &= ~flags;
SvREADONLY_off(sv);
}
+#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
+
/*
=for apidoc mg_magical
/*
=for apidoc mg_get
-Do magic before a value is retrieved from the SV. See C<sv_magic>.
+Do magic before a value is retrieved from the SV. The type of SV must
+be >= SVt_PVMG. See C<sv_magic>.
=cut
*/
if (PL_localizing == 2 && sv == DEFSV) return 0;
- save_magic(mgs_ix, sv);
+ save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
for (mg = SvMAGIC(sv); mg; mg = nextmg) {
const MGVTBL* vtbl = mg->mg_virtual;
/*
=for apidoc mg_length
-This function is deprecated.
-
-It reports on the SV's length in bytes, calling length magic if available,
+Reports on the SV's length in bytes, calling length magic if available,
but does not set the UTF8 flag on the sv. It will fall back to 'get'
magic if there is no 'length' magic, but with no indication as to
whether it called 'get' magic. It assumes the sv is a PVMG or
if (sv) {
MAGIC *mg;
+ assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
return mg;
return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
}
+MAGIC *
+Perl_mg_find_mglob(pTHX_ SV *sv)
+{
+ PERL_ARGS_ASSERT_MG_FIND_MGLOB;
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+ /* This sv is only a delegate. //g magic must be attached to
+ its target. */
+ vivify_defelem(sv);
+ sv = LvTARG(sv);
+ }
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
+ return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
+ return NULL;
+}
+
/*
=for apidoc mg_copy
mg->mg_ptr, mg->mg_len);
/* container types should remain read-only across localization */
- if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
+ SvFLAGS(nsv) |= SvREADONLY(sv);
}
if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
NORETURN_FUNCTION_END;
}
#endif
}
else if (strEQ(remaining, "AINT"))
- sv_setiv(sv, PL_tainting
- ? (PL_taint_warn || PL_unsafe ? -1 : 1)
+ sv_setiv(sv, TAINTING_get
+ ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
: 0);
break;
case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
sv_setpv(sv, os2error(Perl_rc));
else
#endif
- sv_setpv(sv, errno ? Strerror(errno) : "");
+ if (! errno) {
+ sv_setpvs(sv, "");
+ }
+ else {
+
+ /* Strerror can return NULL on some platforms, which will result in
+ * 'sv' not being considered SvOK. The SvNOK_on() below will cause
+ * just the number part to be valid */
+ sv_setpv(sv, Strerror(errno));
+
+ /* In some locales the error string may come back as UTF-8, in
+ * which case we should turn on that flag. This didn't use to
+ * happen, and to avoid any possible backward compatibility issues,
+ * we don't turn on the flag unless we have to. So the flag stays
+ * off for an entirely ASCII string. We assume that if the string
+ * looks like UTF-8, it really is UTF-8: "text in any other
+ * encoding that uses bytes with the high bit set is extremely
+ * unlikely to pass a UTF-8 validity test"
+ * (http://en.wikipedia.org/wiki/Charset_detection). There is a
+ * potential that we will get it wrong however, especially on short
+ * error message text. (If it turns out to be necessary, we could
+ * also keep track if the current LC_MESSAGES locale is UTF-8) */
+ if (SvOK(sv) /* It could be that Strerror returned invalid */
+ && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
+ && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
+ {
+ SvUTF8_on(sv);
+ }
+ }
RESTORE_ERRNO;
}
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '<':
- sv_setiv(sv, (IV)PerlProc_getuid());
+ sv_setuid(sv, PerlProc_getuid());
break;
case '>':
- sv_setiv(sv, (IV)PerlProc_geteuid());
+ sv_setuid(sv, PerlProc_geteuid());
break;
case '(':
- sv_setiv(sv, (IV)PerlProc_getgid());
+ sv_setgid(sv, PerlProc_getgid());
goto add_groups;
case ')':
- sv_setiv(sv, (IV)PerlProc_getegid());
+ sv_setgid(sv, PerlProc_getegid());
add_groups:
#ifdef HAS_GETGROUPS
{
dVAR;
STRLEN len = 0, klen;
const char * const key = MgPV_const(mg,klen);
- const char *s = NULL;
+ const char *s = "";
PERL_ARGS_ASSERT_MAGIC_SETENV;
#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
/* And you'll never guess what the dog had */
/* in its mouth... */
- if (PL_tainting) {
+ if (TAINTING_get) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
*/
SV*
-Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
+Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
U32 argc, ...)
{
dVAR;
}
PUTBACK;
if (flags & G_DISCARD) {
- call_method(meth, G_SCALAR|G_DISCARD);
+ call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
}
else {
- if (call_method(meth, G_SCALAR))
+ if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
ret = *PL_stack_sp--;
}
POPSTACK;
return ret;
}
-
/* wrapper for magic_methcall that creates the first arg */
STATIC SV*
-S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
+S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
int n, SV *val)
{
dVAR;
}
STATIC int
-S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
+S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
{
dVAR;
SV* ret;
if (mg->mg_type == PERL_MAGIC_tiedelem)
mg->mg_flags |= MGf_GSKIP;
- magic_methpack(sv,mg,"FETCH");
+ magic_methpack(sv,mg,SV_CONST(FETCH));
return 0;
}
* fake up a temporary tainted value (this is easier than temporarily
* re-enabling magic on sv). */
- if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
+ if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
&& (tmg->mg_len & 1))
{
val = sv_mortalcopy(sv);
else
val = sv;
- magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
+ magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
return 0;
}
PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
- return magic_methpack(sv,mg,"DELETE");
+ return magic_methpack(sv,mg,SV_CONST(DELETE));
}
PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
- retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
+ retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
if (retsv) {
retval = SvIV(retsv)-1;
if (retval < -1)
PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
- Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
+ Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
return 0;
}
PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
- ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
- : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
+ ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
+ : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
if (ret)
sv_setsv(key,ret);
return 0;
{
PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
- return magic_methpack(sv,mg,"EXISTS");
+ return magic_methpack(sv,mg,SV_CONST(EXISTS));
}
SV *
}
/* there is a SCALAR method that we can call */
- retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
+ retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
if (!retval)
retval = &PL_sv_undef;
return retval;
{
dVAR;
SV* const lsv = LvTARG(sv);
+ MAGIC * const found = mg_find_mglob(lsv);
PERL_ARGS_ASSERT_MAGIC_GETPOS;
PERL_UNUSED_ARG(mg);
- if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
- MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
- if (found && found->mg_len >= 0) {
- I32 i = found->mg_len;
+ if (found && found->mg_len != -1) {
+ STRLEN i = found->mg_len;
if (DO_UTF8(lsv))
- sv_pos_b2u(lsv, &i);
- sv_setiv(sv, i);
+ i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
+ sv_setuv(sv, i);
return 0;
- }
}
SvOK_off(sv);
return 0;
PERL_ARGS_ASSERT_MAGIC_SETPOS;
PERL_UNUSED_ARG(mg);
- if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
- found = mg_find(lsv, PERL_MAGIC_regex_global);
- else
- found = NULL;
+ found = mg_find_mglob(lsv);
if (!found) {
if (!SvOK(sv))
return 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
- if (SvIsCOW(lsv))
- sv_force_normal_flags(lsv, 0);
-#endif
- found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
- NULL, 0);
+ found = sv_magicext_mglob(lsv);
}
else if (!SvOK(sv)) {
found->mg_len = -1;
dVAR;
STRLEN len, lsv_len, oldtarglen, newtarglen;
const char * const tmps = SvPV_const(sv, len);
- const char *targs;
SV * const lsv = LvTARG(sv);
STRLEN lvoff = LvTARGOFF(sv);
STRLEN lvlen = LvTARGLEN(sv);
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr"
);
- targs = SvPV_nomg(lsv,lsv_len);
- if (SvUTF8(lsv)) lsv_len = sv_or_pv_len_utf8(lsv,targs,lsv_len);
+ SvPV_force_nomg(lsv,lsv_len);
+ if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
if (!translate_substr_offsets(
lsv_len,
negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
sv_utf8_upgrade_nomg(lsv);
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
- newtarglen = sv_len_utf8(sv);
+ newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
SvUTF8_on(lsv);
}
- else if (lsv && SvUTF8(lsv)) {
+ else if (SvUTF8(lsv)) {
const char *utf8;
lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
newtarglen = len;
PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_ARG(mg);
+#endif
TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
PERL_UNUSED_ARG(sv);
/* update taint status */
- if (PL_tainted)
+ if (TAINT_get)
mg->mg_len |= 1;
else
mg->mg_len &= ~1;
return 0;
}
-int
-Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
+SV *
+Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
SV *targ = NULL;
-
- PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
-
+ PERL_ARGS_ASSERT_DEFELEM_TARGET;
+ if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
+ assert(mg);
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
SV * const ahv = LvTARG(sv);
mg->mg_obj = NULL;
mg->mg_flags &= ~MGf_REFCOUNTED;
}
+ return targ;
}
else
- targ = LvTARG(sv);
- sv_setsv(sv, targ ? targ : &PL_sv_undef);
+ return LvTARG(sv);
+}
+
+int
+Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
+
+ sv_setsv(sv, defelem_target(sv, mg));
return 0;
}
*/
croakparen:
if (!PL_localizing) {
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
break;
}
}
/* mg_set() has temporarily made sv non-magical */
- if (PL_tainting) {
+ if (TAINTING_get) {
if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
SvTAINTED_on(PL_bodytarget);
else
PL_compiling.cop_warnings = pWARN_NONE;
}
/* Yuck. I can't see how to abstract this: */
- else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
- WARN_ALL) && !any_fatals) {
+ else if (isWARN_on(
+ ((STRLEN *)SvPV_nolen_const(sv)) - 1,
+ WARN_ALL)
+ && !any_fatals)
+ {
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL;
break;
case '<':
{
- const IV new_uid = SvIV(sv);
+ const Uid_t new_uid = SvUID(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)new_uid);
+ (void)setruid(new_uid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)new_uid, (Uid_t)-1);
+ (void)setreuid(new_uid, (Uid_t)-1);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
+ (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
#ifdef PERL_DARWIN
}
case '>':
{
- const UV new_euid = SvIV(sv);
+ const Uid_t new_euid = SvUID(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)new_euid);
+ (void)seteuid(new_euid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1, (Uid_t)new_euid);
+ (void)setreuid((Uid_t)-1, new_euid);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
+ (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
PerlProc_setuid(new_euid);
}
case '(':
{
- const UV new_gid = SvIV(sv);
+ const Gid_t new_gid = SvGID(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)new_gid);
+ (void)setrgid(new_gid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)new_gid, (Gid_t)-1);
+ (void)setregid(new_gid, (Gid_t)-1);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
+ (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
(void)PerlProc_setgid(new_gid);
}
case ')':
{
- UV new_egid;
+ Gid_t new_egid;
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(sv, len);
while (isSPACE(*p))
++p;
- new_egid = Atol(p);
+ new_egid = (Gid_t)Atol(p);
for (i = 0; i < maxgrp; ++i) {
while (*p && !isSPACE(*p))
++p;
Newx(gary, i + 1, Groups_t);
else
Renew(gary, i + 1, Groups_t);
- gary[i] = Atol(p);
+ gary[i] = (Groups_t)Atol(p);
}
if (i)
(void)setgroups(i, gary);
Safefree(gary);
}
#else /* HAS_SETGROUPS */
- new_egid = SvIV(sv);
+ new_egid = SvGID(sv);
#endif /* HAS_SETGROUPS */
PL_delaymagic_egid = new_egid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- (void)setegid((Gid_t)new_egid);
+ (void)setegid(new_egid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1, (Gid_t)new_egid);
+ (void)setregid((Gid_t)-1, new_egid);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
+ (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
(void)PerlProc_setgid(new_egid);
call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
POPSTACK;
- if (SvTRUE(ERRSV)) {
- SvREFCNT_dec(errsv_save);
+ {
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(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
*/
#ifdef HAS_SIGPROCMASK
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- if (sip || uap)
+ if (sip || uap)
#endif
- {
- sigset_t set;
- sigemptyset(&set);
- sigaddset(&set,sig);
- sigprocmask(SIG_UNBLOCK, &set, NULL);
- }
+ {
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set,sig);
+ sigprocmask(SIG_UNBLOCK, &set, NULL);
+ }
#else
- /* Not clear if this will work */
- (void)rsignal(sig, SIG_IGN);
- (void)rsignal(sig, PL_csighandlerp);
+ /* Not clear if this will work */
+ (void)rsignal(sig, SIG_IGN);
+ (void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- die_sv(ERRSV);
- }
- else {
- sv_setsv(ERRSV, errsv_save);
- SvREFCNT_dec(errsv_save);
+ 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 (flags & 8)
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
PL_op = myop; /* Apparently not needed... */
PL_Sv = tSv; /* Restore global temporaries. */
SvTEMP_off(sv);
}
else
- SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
+ SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
}
}
https://perl5.git.perl.org / perl5.git / blobdiff