/* 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 after 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 (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;
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
-Report on the SV's length. See C<sv_magic>.
+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
+higher. Use sv_len() instead.
=cut
*/
}
}
- {
- /* You can't know whether it's UTF-8 until you get the string again...
- */
- const U8 *s = (U8*)SvPV_const(sv, len);
-
- if (DO_UTF8(sv)) {
- len = utf8_length(s, s + len);
- }
- }
+ (void)SvPV_const(sv, len);
return len;
}
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_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 */
return (U32)-1;
}
+/* @-, @+ */
+
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
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;
+ SSize_t s;
+ SSize_t 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;
+ SSize_t i;
if (mg->mg_obj) /* @+ */
i = t;
else /* @- */
i = s;
- if (i > 0 && RX_MATCH_UTF8(rx)) {
+ if (RX_MATCH_UTF8(rx)) {
const char * const b = RX_SUBBEG(rx);
if (b)
- i = utf8_length((U8*)b, (U8*)(b+i));
+ i = RX_SUBCOFFSET(rx) +
+ utf8_length((U8*)b,
+ (U8*)(b-RX_SUBOFFSET(rx)+i));
}
- sv_setiv(sv, i);
+ sv_setuv(sv, i);
+ return 0;
}
}
}
+ sv_setsv(sv, NULL);
return 0;
}
+/* @-, @+ */
+
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
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;
}
-U32
-Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
-{
- dVAR;
- register I32 paren;
- register I32 i;
- register const REGEXP * rx;
- const char * const remaining = mg->mg_ptr + 1;
-
- PERL_ARGS_ASSERT_MAGIC_LEN;
-
- switch (*mg->mg_ptr) {
- case '\020':
- if (*remaining == '\0') { /* ^P */
- break;
- } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
- goto do_prematch;
- } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
- goto do_postmatch;
- }
- break;
- case '\015': /* $^MATCH */
- if (strEQ(remaining, "ATCH")) {
- goto do_match;
- } else {
- break;
- }
- case '`':
- do_prematch:
- paren = RX_BUFF_IDX_PREMATCH;
- goto maybegetparen;
- case '\'':
- do_postmatch:
- paren = RX_BUFF_IDX_POSTMATCH;
- goto maybegetparen;
- case '&':
- do_match:
- paren = RX_BUFF_IDX_FULLMATCH;
- goto maybegetparen;
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- paren = atoi(mg->mg_ptr);
- maybegetparen:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- getparen:
- i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
-
- if (i < 0)
- Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
- return i;
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0;
- }
- case '+':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = RX_LASTPAREN(rx);
- if (paren)
- goto getparen;
- }
- return 0;
- case '\016': /* ^N */
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = RX_LASTCLOSEPAREN(rx);
- if (paren)
- goto getparen;
- }
- return 0;
- }
- magic_get(sv,mg);
- if (!SvPOK(sv) && SvNIOK(sv)) {
- sv_2pv(sv, 0);
- }
- if (SvPOK(sv))
- return SvCUR(sv);
- return 0;
-}
-
#define SvRTRIM(sv) STMT_START { \
if (SvPOK(sv)) { \
STRLEN len = SvCUR(sv); \
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;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
+ case '\014': /* ^LAST_FH */
+ if (strEQ(remaining, "AST_FH")) {
+ if (PL_last_in_gv) {
+ assert(isGV_with_GP(PL_last_in_gv));
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ prepare_SV_for_RV(sv);
+ SvOK_off(sv);
+ SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
+ SvROK_on(sv);
+ sv_rvweaken(sv);
+ }
+ else sv_setsv_nomg(sv, NULL);
+ }
+ break;
case '\017': /* ^O & ^OPEN */
if (nextchar == '\0') {
sv_setpv(sv, PL_osname);
if (nextchar == '\0') { /* ^P */
sv_setiv(sv, (IV)PL_perldb);
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
- goto do_prematch_fetch;
+
+ paren = RX_BUFF_IDX_CARET_PREMATCH;
+ goto do_numbuf_fetch;
} else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
- goto do_postmatch_fetch;
+ paren = RX_BUFF_IDX_CARET_POSTMATCH;
+ goto do_numbuf_fetch;
}
break;
case '\023': /* ^S */
#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 */
break;
case '\015': /* $^MATCH */
if (strEQ(remaining, "ATCH")) {
+ paren = RX_BUFF_IDX_CARET_FULLMATCH;
+ goto do_numbuf_fetch;
+ }
+
case '1': case '2': case '3': case '4':
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((const GV *)mg->mg_obj));
- * XXX Does the new way break anything?
- */
- paren = atoi(mg->mg_ptr); /* $& is in [0] */
- CALLREG_NUMBUF_FETCH(rx,paren,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- }
+ /*
+ * 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] */
+ do_numbuf_fetch:
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ break;
+ }
+ sv_setsv(sv,&PL_sv_undef);
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (RX_LASTPAREN(rx)) {
- CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
- break;
- }
+ paren = RX_LASTPAREN(rx);
+ if (paren)
+ goto do_numbuf_fetch;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (RX_LASTCLOSEPAREN(rx)) {
- CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
- break;
- }
-
+ paren = RX_LASTCLOSEPAREN(rx);
+ if (paren)
+ goto do_numbuf_fetch;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '`':
- do_prematch_fetch:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF_FETCH(rx,-2,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- break;
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto do_numbuf_fetch;
case '\'':
- do_postmatch_fetch:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- CALLREG_NUMBUF_FETCH(rx,-1,sv);
- break;
- }
- sv_setsv(sv,&PL_sv_undef);
- break;
+ paren = RX_BUFF_IDX_POSTMATCH;
+ goto do_numbuf_fetch;
case '.':
if (GvIO(PL_last_in_gv)) {
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
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")) {
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;
*/
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;
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- GV * const gv = PL_DBline;
- const I32 i = SvTRUE(sv);
- SV ** const svp = av_fetch(GvAV(gv),
- atoi(MgPV_nolen_const(mg)), FALSE);
+ SV **svp;
PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
+ /* The magic ptr/len for the debugger's hash should always be an SV. */
+ if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
+ Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
+ mg->mg_len, mg->mg_ptr);
+ }
+
+ /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
+ setting/clearing debugger breakpoints is not a hot path. */
+ svp = av_fetch(GvAV(PL_DBline), sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
+
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)
+ if (SvTRUE(sv))
o->op_flags |= OPf_SPECIAL;
else
o->op_flags &= ~OPf_SPECIAL;
+#ifdef PERL_DEBUG_READONLY_OPS
+ Slab_to_ro(OpSLAB(o));
+#endif
}
}
return 0;
if (obj) {
sv_setiv(sv, AvFILL(obj));
} else {
- SvOK_off(sv);
+ sv_setsv(sv, NULL);
}
return 0;
}
{
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 (DO_UTF8(lsv))
- sv_pos_b2u(lsv, &i);
- sv_setiv(sv, i);
+ if (found && found->mg_len != -1) {
+ STRLEN i = found->mg_len;
+ if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
+ i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
+ sv_setuv(sv, i);
return 0;
- }
}
- SvOK_off(sv);
+ sv_setsv(sv,NULL);
return 0;
}
STRLEN len;
STRLEN ulen = 0;
MAGIC* found;
+ const char *s;
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;
return 0;
}
- len = SvPOK_nog(lsv) ? SvCUR(lsv) : sv_len(lsv);
+ s = SvPV_const(lsv, len);
pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_len_utf8(lsv);
+ ulen = sv_or_pv_len_utf8(lsv, s, len);
if (ulen)
len = ulen;
}
else if (pos > (SSize_t)len)
pos = len;
- if (ulen) {
- I32 p = pos;
- sv_pos_u2b(lsv, &p, 0);
- pos = p;
- }
-
found->mg_len = pos;
- found->mg_flags &= ~MGf_MINMATCH;
+ found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
return 0;
}
PERL_UNUSED_ARG(mg);
if (!translate_substr_offsets(
- SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
+ SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
negoff ? -(IV)offs : (IV)offs, !negoff,
negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
)) {
}
if (SvUTF8(lsv))
- offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
+ offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
sv_setpvn(sv, tmps + offs, rem);
if (SvUTF8(lsv))
SvUTF8_on(sv);
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr"
);
- if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
- else (void)SvPV_nomg(lsv,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,
Perl_croak(aTHX_ "substr outside of string");
oldtarglen = lvlen;
if (DO_UTF8(sv)) {
- sv_utf8_upgrade(lsv);
+ 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;
PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
- if (lsv)
- sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
- else
- SvOK_off(sv);
+ sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
return 0;
}
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);
if (he)
targ = HeVAL(he);
}
- else {
+ else if (LvSTARGOFF(sv) >= 0) {
AV *const av = MUTABLE_AV(LvTARG(sv));
- if ((I32)LvTARGOFF(sv) <= AvFILL(av))
- targ = AvARRAY(av)[LvTARGOFF(sv)];
+ if (LvSTARGOFF(sv) <= AvFILL(av))
+ targ = AvARRAY(av)[LvSTARGOFF(sv)];
}
if (targ && (targ != &PL_sv_undef)) {
/* somebody else defined it for us */
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;
}
if (!value || value == &PL_sv_undef)
Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
}
+ else if (LvSTARGOFF(sv) < 0)
+ Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
else {
AV *const av = MUTABLE_AV(LvTARG(sv));
- if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
+ if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
LvTARG(sv) = NULL; /* array can't be extended */
else {
- SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
- if (!svp || (value = *svp) == &PL_sv_undef)
- Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
+ SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
+ if (!svp || !(value = *svp))
+ Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
}
}
SvREFCNT_inc_simple_void(value);
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;
*/
croakparen:
if (!PL_localizing) {
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
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);
}
}
/* 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);
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;
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