return NORMAL;
}
-/* This is sometimes called directly by pp_coreargs. */
+/* This is sometimes called directly by pp_coreargs and pp_grepstart. */
PP(pp_pushmark)
{
dVAR;
PP(pp_sassign)
{
- dVAR; dSP; dPOPTOPssrl;
+ dVAR; dSP;
+ /* sassign keeps its args in the optree traditionally backwards.
+ So we pop them differently.
+ */
+ SV *left = POPs; SV *right = TOPs;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
SV * const temp = left;
left = right; right = temp;
}
- if (PL_tainting && PL_tainted && !SvTAINTED(left))
+ if (PL_tainting && PL_tainted && !SvTAINTED(right))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
- SV * const cv = SvRV(left);
+ SV * const cv = SvRV(right);
const U32 cv_type = SvTYPE(cv);
- const bool is_gv = isGV_with_GP(right);
+ const bool is_gv = isGV_with_GP(left);
const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
assert(SvROK(cv));
}
- /* Can do the optimisation if right (LVALUE) is not a typeglob,
- left (RVALUE) is a reference to something, and we're in void
+ /* Can do the optimisation if left (LVALUE) is not a typeglob,
+ right (RVALUE) is a reference to something, and we're in void
context. */
if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
/* Is the target symbol table currently empty? */
- GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
+ GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
/* Good. Create a new proxy constant subroutine in the target.
The gv becomes a(nother) reference to the constant. */
SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
- SETs(right);
+ SETs(left);
RETURN;
}
}
/* Need to fix things up. */
if (!is_gv) {
/* Need to fix GV. */
- right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
+ left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
}
if (!got_coderef) {
all sorts of fun as the reference to our new sub is
donated to the GV that we're about to assign to.
*/
- SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
+ SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
SvRV(cv))));
SvREFCNT_dec(cv);
LEAVE_with_name("sassign_coderef");
SvREFCNT_inc_void(source);
SvREFCNT_dec(upgraded);
- SvRV_set(left, MUTABLE_SV(source));
+ SvRV_set(right, MUTABLE_SV(source));
}
}
}
if (
- SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
- (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
+ SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
+ (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
)
Perl_warner(aTHX_
packWARN(WARN_MISC), "Useless assignment to a temporary"
);
- SvSetMagicSV(right, left);
- SETs(right);
+ SvSetMagicSV(left, right);
+ SETs(left);
RETURN;
}
dSP;
if (TOPs) {
SvGETMAGIC(TOPs);
- tryAMAGICunTARGET(iter_amg, 0, 0);
+ tryAMAGICunTARGETlist(iter_amg, 0, 0);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
}
else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
Perl_croak_no_modify(aTHX);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
PP(pp_defined)
{
dVAR; dSP;
- register SV* sv;
+ SV* sv;
bool defined;
const int op_type = PL_op->op_type;
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please_nomg(svr);
-
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
- register UV auv = 0;
+ UV auv = 0;
bool auvok = FALSE;
bool a_valid = 0;
lots of code to speed up what is probably a rarish case. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
else {
- register const IV aiv = SvIVX(svl);
+ const IV aiv = SvIVX(svl);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
if (a_valid) {
bool result_good = 0;
UV result;
- register UV buv;
+ UV buv;
bool buvok = SvUOK(svr);
if (buvok)
buv = SvUVX(svr);
else {
- register const IV biv = SvIVX(svr);
+ const IV biv = SvIVX(svr);
if (biv >= 0) {
buv = biv;
buvok = 1;
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- register PerlIO *fp;
+ PerlIO *fp;
MAGIC *mg;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
}
sv = SvRV(sv);
if (SvTYPE(sv) != type)
+ /* diag_listed_as: Not an ARRAY reference */
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
- if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
- }
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
- }
else if (PL_op->op_flags & OPf_MOD
&& PL_op->op_private & OPpLVAL_INTRO)
Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
- else {
- if (SvTYPE(sv) == type) {
- if (PL_op->op_flags & OPf_REF) {
- SETs(sv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- goto croak_cant_return;
- SETs(sv);
- RETURN;
- }
- }
- else {
+ else if (SvTYPE(sv) != type) {
GV *gv;
if (!isGV_with_GP(sv)) {
sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
if (PL_op->op_private & OPpLVAL_INTRO)
sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
- if (PL_op->op_flags & OPf_REF) {
+ }
+ if (PL_op->op_flags & OPf_REF) {
SETs(sv);
RETURN;
- }
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ }
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
SETs(sv);
RETURN;
}
- }
- }
}
if (is_pp_rv2av) {
*PL_stack_sp = sv;
return Perl_do_kv(aTHX);
}
+ else if ((PL_op->op_private & OPpTRUEBOOL
+ || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
+ && block_gimme() == G_VOID ))
+ && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
+ SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
else if (gimme == G_SCALAR) {
dTARGET;
TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
SV **firstrelem = PL_stack_base + POPMARK + 1;
SV **firstlelem = lastrelem + 1;
- register SV **relem;
- register SV **lelem;
+ SV **relem;
+ SV **lelem;
- register SV *sv;
- register AV *ary;
+ SV *sv;
+ AV *ary;
I32 gimme;
HV *hash;
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
(void*)sv);
}
- /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
- and we need a second copy of a temp here. */
- *relem = sv_2mortal(newSVsv(sv));
+ /* Not newSVsv(), as it does not allow copy-on-write,
+ resulting in wasteful copies. We need a second copy of
+ a temp here, hence the SV_NOSTEAL. */
+ *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
+ |SV_NOSTEAL);
}
}
}
case SVt_PVAV:
ary = MUTABLE_AV(sv);
magic = SvMAGICAL(ary) != 0;
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
av_clear(ary);
av_extend(ary, lastrelem - relem);
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
assert(*relem);
+ SvGETMAGIC(*relem); /* before newSV, in case it dies */
sv = newSV(0);
- sv_setsv(sv, *relem);
+ sv_setsv_nomg(sv, *relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- if (SvSMAGICAL(sv))
- mg_set(sv);
if (!didstore)
sv_2mortal(sv);
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
}
TAINT_NOT;
}
if (PL_delaymagic & DM_ARRAY_ISA)
SvSETMAGIC(MUTABLE_SV(ary));
+ LEAVE;
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
+ ENTER;
+ SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
hv_clear(hash);
firsthashrelem = relem;
HE *didstore;
sv = *relem ? *relem : &PL_sv_no;
relem++;
- tmpstr = newSV(0);
+ tmpstr = sv_newmortal();
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
relem++;
}
}
didstore = hv_store_ent(hash,sv,tmpstr,0);
+ if (didstore) SvREFCNT_inc_simple_void_NN(tmpstr);
if (magic) {
if (SvSMAGICAL(tmpstr))
mg_set(tmpstr);
- if (!didstore)
- sv_2mortal(tmpstr);
}
TAINT_NOT;
}
do_oddball(hash, relem, firstrelem);
relem++;
}
+ LEAVE;
}
break;
default:
}
}
if (PL_delaymagic & ~DM_DELAY) {
+ /* Will be used to set PL_tainting below */
+ UV tmp_uid = PerlProc_getuid();
+ UV tmp_euid = PerlProc_geteuid();
+ UV tmp_gid = PerlProc_getgid();
+ UV tmp_egid = PerlProc_getegid();
+
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+ (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
(Uid_t)-1);
#else
# ifdef HAS_SETREUID
- (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
+ (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(PL_uid);
+ (void)setruid(PL_delaymagic_uid);
PL_delaymagic &= ~DM_RUID;
}
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_euid);
+ (void)seteuid(PL_delaymagic_euid);
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
- if (PL_uid != PL_euid)
+ if (PL_delaymagic_uid != PL_delaymagic_euid)
DIE(aTHX_ "No setreuid available");
- (void)PerlProc_setuid(PL_uid);
+ (void)PerlProc_setuid(PL_delaymagic_uid);
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
- PL_uid = PerlProc_getuid();
- PL_euid = PerlProc_geteuid();
+ tmp_uid = PerlProc_getuid();
+ tmp_euid = PerlProc_geteuid();
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+ (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
(Gid_t)-1);
#else
# ifdef HAS_SETREGID
- (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
+ (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(PL_gid);
+ (void)setrgid(PL_delaymagic_gid);
PL_delaymagic &= ~DM_RGID;
}
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_egid);
+ (void)setegid(PL_delaymagic_egid);
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
- if (PL_gid != PL_egid)
+ if (PL_delaymagic_gid != PL_delaymagic_egid)
DIE(aTHX_ "No setregid available");
- (void)PerlProc_setgid(PL_gid);
+ (void)PerlProc_setgid(PL_delaymagic_gid);
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
- PL_gid = PerlProc_getgid();
- PL_egid = PerlProc_getegid();
+ tmp_gid = PerlProc_getgid();
+ tmp_egid = PerlProc_getegid();
}
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
}
PL_delaymagic = 0;
PP(pp_qr)
{
dVAR; dSP;
- register PMOP * const pm = cPMOP;
+ PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
SV * const rv = sv_newmortal();
+ CV **cvp;
+ CV *cv;
SvUPGRADE(rv, SVt_IV);
/* For a subroutine describing itself as "This is a hacky workaround" I'm
SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
+ cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
+ if ((cv = *cvp) && CvCLONE(*cvp)) {
+ *cvp = cv_clone(cv);
+ SvREFCNT_dec(cv);
+ }
+
if (pkg) {
HV *const stash = gv_stashsv(pkg, GV_ADD);
SvREFCNT_dec(pkg);
PP(pp_match)
{
dVAR; dSP; dTARG;
- register PMOP *pm = cPMOP;
+ PMOP *pm = cPMOP;
PMOP *dynpm = pm;
- register const char *t;
- register const char *s;
+ const char *t;
+ const char *s;
const char *strend;
I32 global;
U8 r_flags = REXEC_CHECKED;
const char *truebase; /* Start of string */
- register REGEXP *rx = PM_GETRE(pm);
+ REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
const I32 gimme = GIMME;
STRLEN len;
PUTBACK; /* EVAL blocks need stack_sp. */
/* Skip get-magic if this is a qr// clone, because regcomp has
already done it. */
- s = ((struct regexp *)SvANY(rx))->mother_re
+ s = ReANY(rx)->mother_re
? SvPV_nomg_const(TARG, len)
: SvPV_const(TARG, len);
if (!s)
pm->op_pmflags & PMf_USED
#endif
) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
failure:
+
if (gimme == G_ARRAY)
RETURN;
RETPUSHNO;
- /* empty pattern special-cased to use last successful pattern if possible */
- if (!RX_PRELEN(rx) && PL_curpm) {
+ /* empty pattern special-cased to use last successful pattern if
+ possible, except for qr// */
+ if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
+ && PL_curpm) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- if (RX_MINLEN(rx) > (I32)len)
+ if (RX_MINLEN(rx) > (I32)len) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
goto failure;
+ }
truebase = t = s;
}
}
}
- /* XXX: comment out !global get safe $1 vars after a
- match, BUT be aware that this leads to dramatic slowdowns on
- /g matches against large strings. So far a solution to this problem
- appears to be quite tricky.
- Test for the unsafe vars are TODO for now. */
- if ( (!global && RX_NPARENS(rx))
- || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
- || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
- r_flags |= REXEC_COPY_STR;
- if (SvSCREAM(TARG))
- r_flags |= REXEC_SCREAM;
+ if ( RX_NPARENS(rx)
+ || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+ ) {
+ r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
+ /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
+ * only on the first iteration. Therefore we need to copy $' as well
+ * as $&, to make the rest of the string available for captures in
+ * subsequent iterations */
+ if (! (global && gimme == G_ARRAY))
+ r_flags |= REXEC_COPY_SKIP_POST;
+ };
play_it_again:
if (global && RX_OFFS(rx)[0].start != -1) {
t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
- if ((s + RX_MINLEN(rx)) > strend || s < truebase)
+ if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
goto nope;
+ }
if (update_minmatch++)
minmatch = had_zerolen;
}
if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
&& !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
- && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
- || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
- && (r_flags & REXEC_SCREAM)))
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
}
s = RX_OFFS(rx)[i].start + truebase;
if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
len < 0 || len > strend - s)
- DIE(aTHX_ "panic: pp_match start/end pointers");
+ DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
+ "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
+ (long) i, (long) RX_OFFS(rx)[i].start,
+ (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
sv_setpvn(*SP, s, len);
if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
if (global) {
/* FIXME - should rx->subbeg be const char *? */
RX_SUBBEG(rx) = (char *) truebase;
+ RX_SUBOFFSET(rx) = 0;
+ RX_SUBCOFFSET(rx) = 0;
RX_OFFS(rx)[0].start = s - truebase;
if (RX_MATCH_UTF8(rx)) {
char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
#endif
}
RX_SUBLEN(rx) = strend - t;
+ RX_SUBOFFSET(rx) = 0;
+ RX_SUBCOFFSET(rx) = 0;
RX_MATCH_COPIED_on(rx);
off = RX_OFFS(rx)[0].start = s - t;
RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
RX_OFFS(rx)[0].start = s - truebase;
RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
}
- /* including RX_NPARENS(rx) in the below code seems highly suspicious.
- -dmq */
- RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
+ /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
+ assert(!RX_NPARENS(rx));
+ RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
LEAVE_SCOPE(oldsave);
RETPUSHYES;
Perl_do_readline(pTHX)
{
dVAR; dSP; dTARGETSTACKED;
- register SV *sv;
+ SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
- register IO * const io = GvIO(PL_last_in_gv);
- register const I32 type = PL_op->op_type;
+ IO * const io = GvIO(PL_last_in_gv);
+ const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
if (io) {
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
+ SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
sv_setpvs(GvSVn(PL_last_in_gv), "-");
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
&& ckWARN2(WARN_GLOB, WARN_CLOSED))
{
if (type == OP_GLOB)
- Perl_warner(aTHX_ packWARN(WARN_GLOB),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
}
}
for (t1 = SvPVX_const(sv); *t1; t1++)
- if (!isALPHA(*t1) && !isDIGIT(*t1) &&
+ if (!isALNUMC(*t1) &&
strchr("$&*(){}[]'\";\\|?<>~`", *t1))
break;
if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
- const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
* Try to preserve the existenceness of a tied hash
* element by using EXISTS and DELETE if possible.
* Fallback to FETCH and STORE otherwise. */
- if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ if (SvCANEXISTDELETE(hv))
preeminent = hv_exists_ent(hv, keysv, 0);
}
- he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
svp = he ? &HeVAL(he) : NULL;
if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
SV* lv;
SV* key2;
if (!defer) {
RETURN;
}
}
- sv = (svp ? *svp : &PL_sv_undef);
+ sv = (svp && *svp ? *svp : &PL_sv_undef);
/* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
* was to make C<local $tied{foo} = $tied{foo}> possible.
* However, it seems no longer to be needed for that purpose, and
PP(pp_iter)
{
dVAR; dSP;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv, *oldsv;
SV **itersvp;
AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
if (!CxTYPE_is_LOOP(cx))
- DIE(aTHX_ "panic: pp_iter");
+ DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
itersvp = CxITERVAR(cx);
if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
/* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
+ sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
}
else
{
* completely new SV for closures/references to work as they
* used to */
oldsv = *itersvp;
- *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
+ *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
SvREFCNT_dec(oldsv);
}
- /* Handle end of range at IV_MAX */
- if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
- (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
- {
- cx->blk_loop.state_u.lazyiv.cur++;
- cx->blk_loop.state_u.lazyiv.end++;
- }
+ if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
+ /* Handle end of range at IV_MAX */
+ cx->blk_loop.state_u.lazyiv.end = IV_MIN;
+ } else
+ ++cx->blk_loop.state_u.lazyiv.cur;
RETPUSHYES;
}
PP(pp_subst)
{
dVAR; dSP; dTARG;
- register PMOP *pm = cPMOP;
+ PMOP *pm = cPMOP;
PMOP *rpm = pm;
- register char *s;
+ char *s;
char *strend;
- register char *m;
+ char *m;
const char *c;
- register char *d;
+ char *d;
STRLEN clen;
I32 iters = 0;
I32 maxiters;
- register I32 i;
+ I32 i;
bool once;
U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
See "how taint works" above */
char *orig;
U8 r_flags;
- register REGEXP *rx = PM_GETRE(pm);
+ REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
- bool doutf8 = FALSE;
+ bool doutf8 = FALSE; /* whether replacement is in utf8 */
#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
SV *nsv = NULL;
/* known replacement string? */
- register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+ SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
PERL_ASYNC_CHECK();
EXTEND(SP,1);
}
+ SvGETMAGIC(TARG); /* must come before cow check */
#ifdef PERL_OLD_COPY_ON_WRITE
/* Awooga. Awooga. "bool" types that are actually char are dangerous,
because they make integers such as 256 "false". */
Perl_croak_no_modify(aTHX);
PUTBACK;
- setup_match:
- s = SvPV_mutable(TARG, len);
- if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
+ s = SvPV_nomg(TARG, len);
+ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
force_on_match = 1;
/* only replace once? */
force_it:
if (!pm || !s)
- DIE(aTHX_ "panic: pp_subst");
+ DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
strend = s + len;
slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
position, once with zero-length,
second time with non-zero. */
- if (!RX_PRELEN(rx) && PL_curpm) {
+ if (!RX_PRELEN(rx) && PL_curpm
+ && !ReANY(rx)->mother_re) {
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
- || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
- ? REXEC_COPY_STR : 0;
- if (SvSCREAM(TARG))
- r_flags |= REXEC_SCREAM;
+
+ r_flags = ( RX_NPARENS(rx)
+ || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
+ )
+ ? REXEC_COPY_STR
+ : 0;
orig = m = s;
if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
/* How to do it in subst? */
/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
- && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
- && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
- || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
- && (r_flags & REXEC_SCREAM))))
+ && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
goto yup;
*/
}
RETURN;
}
+ PL_curpm = pm;
+
/* known replacement string? */
if (dstr) {
- if (SvTAINTED(dstr))
- rxtainted |= SUBST_TAINT_REPL;
-
- /* Upgrade the source if the replacement is utf8 but the source is not,
- * but only if it matched; see
- * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
- */
- if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
- char * const orig_pvx = SvPVX(TARG);
- const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
-
- /* If the lengths are the same, the pattern contains only
- * invariants, can keep going; otherwise, various internal markers
- * could be off, so redo */
- if (new_len != len || orig_pvx != SvPVX(TARG)) {
- goto setup_match;
- }
- }
-
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
c = SvPV_const(dstr, clen);
doutf8 = DO_UTF8(dstr);
}
+
+ if (SvTAINTED(dstr))
+ rxtainted |= SUBST_TAINT_REPL;
}
else {
c = NULL;
#ifdef PERL_OLD_COPY_ON_WRITE
&& !is_cow
#endif
- && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
- && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
+ && (I32)clen <= RX_MINLENRET(rx)
+ && (once || !(r_flags & REXEC_COPY_STR))
+ && !(RX_EXTFLAGS(rx) & (RXf_LOOKBEHIND_SEEN|RXf_MODIFIES_VARS))
&& (!doutf8 || SvUTF8(TARG))
&& !(rpm->op_pmflags & PMf_NONDESTRUCT))
{
#endif
if (force_on_match) {
force_on_match = 0;
- s = SvPV_force(TARG, len);
+ s = SvPV_force_nomg(TARG, len);
goto force_it;
}
d = s;
- PL_curpm = pm;
- SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
}
}
else {
+ bool first;
+ SV *repl;
if (force_on_match) {
force_on_match = 0;
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
cases where it would be viable to drop into the copy code. */
TARG = sv_2mortal(newSVsv(TARG));
}
- s = SvPV_force(TARG, len);
+ s = SvPV_force_nomg(TARG, len);
goto force_it;
}
#ifdef PERL_OLD_COPY_ON_WRITE
#endif
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
+ repl = dstr;
dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
- PL_curpm = pm;
if (!c) {
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SPAGAIN;
/* note that a whole bunch of local vars are saved here for
* use by pp_substcont: here's a list of them in case you're
RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
+ first = TRUE;
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
+ assert(RX_SUBOFFSET(rx) == 0);
orig = RX_SUBBEG(rx);
s = orig + (m - s);
strend = s + (strend - m);
}
m = RX_OFFS(rx)[0].start + orig;
- if (doutf8 && !SvUTF8(dstr))
- sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
- else
- sv_catpvn(dstr, s, m-s);
+ sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
s = RX_OFFS(rx)[0].end + orig;
- if (clen)
- sv_catpvn(dstr, c, clen);
+ if (first) {
+ /* replacement already stringified */
+ if (clen)
+ sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
+ first = FALSE;
+ }
+ else {
+ if (PL_encoding) {
+ if (!nsv) nsv = sv_newmortal();
+ sv_copypv(nsv, repl);
+ if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
+ sv_catsv(dstr, nsv);
+ }
+ else sv_catsv(dstr, repl);
+ if (SvTAINTED(repl))
+ rxtainted |= SUBST_TAINT_REPL;
+ }
if (once)
break;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL, r_flags));
- if (doutf8 && !DO_UTF8(TARG))
- sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
- else
- sv_catpvn(dstr, s, strend - s);
+ sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
/* From here on down we're using the copy, and leaving the original
SvPV_set(TARG, SvPVX(dstr));
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
- doutf8 |= DO_UTF8(dstr);
+ SvFLAGS(TARG) |= SvUTF8(dstr);
SvPV_set(dstr, NULL);
SPAGAIN;
if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
(void)SvPOK_only_UTF8(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
}
/* See "how taint works" above */
SV **newsp;
PMOP *newpm;
I32 gimme;
- register PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV *sv;
if (CxMULTICALL(&cxstack[cxstack_ix]))
MARK = newsp + 1;
if (MARK <= SP) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
+ && !SvMAGICAL(TOPs)) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
SvREFCNT_dec(sv);
}
}
- else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
+ else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
+ && !SvMAGICAL(TOPs)) {
*MARK = TOPs;
}
else
}
else if (gimme == G_ARRAY) {
for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
+ if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
+ || SvMAGICAL(*MARK)) {
*MARK = sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
{
dVAR; dSP; dPOPss;
GV *gv;
- register CV *cv;
- register PERL_CONTEXT *cx;
+ CV *cv;
+ PERL_CONTEXT *cx;
I32 gimme;
const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
else {
const char *sym;
STRLEN len;
- sym = SvPV_nomg_const(sv, len);
- if (!sym)
+ if (!SvOK(sv))
DIE(aTHX_ PL_no_usym, "a subroutine");
+ sym = SvPV_nomg_const(sv, len);
if (PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
SV* sub_name;
/* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv)))
+ if (CvANON(cv) || !(gv = CvGV(cv))) {
+ if (CvNAMED(cv))
+ DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
+ HEKfARG(CvNAME_HEK(cv)));
DIE(aTHX_ "Undefined subroutine called");
+ }
/* autoloaded stub? */
if (cv != GvCV(gv)) {
{
cv = GvCV(autogv);
}
- /* sorry */
else {
+ sorry:
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, NULL);
DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
}
}
if (!cv)
- DIE(aTHX_ "Not a CODE reference");
+ goto sorry;
goto retry;
}
if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
- register I32 items = SP - MARK;
- AV* const padlist = CvPADLIST(cv);
+ I32 items = SP - MARK;
+ PADLIST * const padlist = CvPADLIST(cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
- /* XXX This would be a natural place to set C<PL_compcv = cv> so
- * that eval'' ops within this sub know the correct lexical space.
- * Owing the speed considerations, we choose instead to search for
- * the cv using find_runcv() when calling doeval().
- */
if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, CvDEPTH(cv));
MARK++;
}
}
+ if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv))
+ DIE(aTHX_ "Can't modify non-lvalue subroutine call");
/* warning must come *after* we fully set up the context
* stuff so that __WARN__ handlers can safely dounwind()
* if they want to
}
SvROK_on(sv);
SvSETMAGIC(sv);
+ SvGETMAGIC(sv);
}
if (SvGMAGICAL(sv)) {
/* copy the sv without magic to prevent magic from being
GV* gv;
HV* stash;
SV *packsv = NULL;
- SV * const sv = *(PL_stack_base + TOPMARK + 1);
+ SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
+ ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
+ "package or object reference", SVfARG(meth)),
+ (SV *)NULL)
+ : *(PL_stack_base + TOPMARK + 1);
PERL_ARGS_ASSERT_METHOD_COMMON;
if (!sv)
+ undefined:
Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
SVfARG(meth));
SvGETMAGIC(sv);
if (SvROK(sv))
ob = MUTABLE_SV(SvRV(sv));
+ else if (!SvOK(sv)) goto undefined;
else {
+ /* this isn't a reference */
GV* iogv;
STRLEN packlen;
- const char * packname = NULL;
- bool packname_is_utf8 = FALSE;
-
- /* this isn't a reference */
- if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
- const HE* const he =
- (const HE *)hv_common_key_len(
- PL_stashcache, packname,
- packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
+ const char * const packname = SvPV_nomg_const(sv, packlen);
+ const bool packname_is_utf8 = !!SvUTF8(sv);
+ const HE* const he =
+ (const HE *)hv_common(
+ PL_stashcache, NULL, packname, packlen,
+ packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
);
- if (he) {
+ if (he) {
stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
+ stash, sv));
goto fetch;
- }
}
- if (!SvOK(sv) ||
- !(packname) ||
- !(iogv = gv_fetchpvn_flags(
+ if (!(iogv = gv_fetchpvn_flags(
packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
)) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
/* this isn't the name of a filehandle either */
- if (!packname ||
- ((UTF8_IS_START(*packname) && DO_UTF8(sv))
- ? !isIDFIRST_utf8((U8*)packname)
- : !isIDFIRST_L1((U8)*packname)
- ))
+ if (!packlen)
{
- Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
- SVfARG(meth),
- SvOK(sv) ? "without a package or object reference"
- : "on an undefined value");
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
+ "without a package or object reference",
+ SVfARG(meth));
}
/* assume it's a package name */
stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
SV* const ref = newSViv(PTR2IV(stash));
(void)hv_store(PL_stashcache, packname,
packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
+ stash, sv));
}
goto fetch;
}
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/