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_sv = sv;
mgs->mgs_magical = SvMAGICAL(sv);
- mgs->mgs_readonly = SvREADONLY(sv) != 0;
+ mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv);
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
mgs->mgs_bumped = bumped;
SvMAGICAL_off(sv);
- SvREADONLY_off(sv);
+ /* Turning READONLY off for a copy-on-write scalar (including shared
+ hash keys) is a bad idea. */
+ if (!SvIsCOW(sv)) SvREADONLY_off(sv);
}
/*
/*
=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;
/*
=for apidoc mg_length
-Report on the SV's length. See C<sv_magic>.
+This function is deprecated.
+
+It 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;
}
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;
+ 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 /* @- */
if (i > 0 && 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);
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)));
dVAR;
STRLEN len = 0, klen;
const char * const key = MgPV_const(mg,klen);
- const char *s = "";
+ const char *s = NULL;
PERL_ARGS_ASSERT_MAGIC_SETENV;
+ SvGETMAGIC(sv);
if (SvOK(sv)) {
- s = SvPV_const(sv,len);
- SvPOK_only(sv); /* environment variables are strings, period */
+ /* 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 */
#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;
* 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);
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;
STRLEN len;
STRLEN ulen = 0;
MAGIC* found;
+ const char *s;
PERL_ARGS_ASSERT_MAGIC_SETPOS;
PERL_UNUSED_ARG(mg);
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;
}
pos = len;
if (ulen) {
- I32 p = pos;
- sv_pos_u2b(lsv, &p, 0);
- pos = p;
+ pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
}
found->mg_len = pos;
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_UNUSED_ARG(sv);
/* update taint status */
- if (PL_tainted)
+ if (TAINT_get)
mg->mg_len |= 1;
else
mg->mg_len &= ~1;
}
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;
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
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: