/* pp_hot.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
SV * const temp = left;
left = right; right = temp;
}
+ else if (PL_op->op_private & OPpASSIGN_STATE) {
+ if (SvPADSTALE(right))
+ SvPADSTALE_off(right);
+ else
+ RETURN; /* ignore assignment */
+ }
if (PL_tainting && PL_tainted && !SvTAINTED(left))
TAINT_NOT;
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
assert(SvROK(cv));
}
- /* Can do the optimisation if right (LVAUE) is not a typeglob,
+ /* Can do the optimisation if right (LVALUE) is not a typeglob,
left (RVALUE) is a reference to something, and we're in void
context. */
if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
SV *const value = SvRV(cv);
SvUPGRADE((SV *)gv, SVt_RV);
- SvROK_on(gv);
+ SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
SETs(right);
LEAVE;
}
+ if (strEQ(GvNAME(right),"isa")) {
+ GvCVGEN(right) = 0;
+ ++PL_sub_generation;
+ }
}
SvSetMagicSV(right, left);
SETs(right);
XPUSHs(TARG);
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ if (!(PL_op->op_private & OPpPAD_STATE))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_private & OPpDEREF) {
PUTBACK;
vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
register SV* sv;
bool defined;
const int op_type = PL_op->op_type;
- const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
+ const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
if (is_dor) {
sv = TOPs;
if (MARK <= SP)
goto just_say_no;
else {
- if (PL_ors_sv && SvOK(PL_ors_sv))
+ if (PL_op->op_type == OP_SAY) {
+ if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
+ goto just_say_no;
+ }
+ else if (PL_ors_sv && SvOK(PL_ors_sv))
if (!do_print(PL_ors_sv, fp)) /* $\ */
goto just_say_no;
PP(pp_rv2av)
{
dVAR; dSP; dTOPss;
- AV *av;
+ const I32 gimme = GIMME_V;
+ static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
+ static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
+ static const char an_array[] = "an ARRAY";
+ static const char a_hash[] = "a HASH";
+ const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
+ const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
if (SvROK(sv)) {
wasref:
- tryAMAGICunDEREF(to_av);
+ tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
- av = (AV*)SvRV(sv);
- if (SvTYPE(av) != SVt_PVAV)
- DIE(aTHX_ "Not an ARRAY reference");
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != type)
+ DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)av);
+ SETs(sv);
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
- SETs((SV*)av);
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
+ : return_hash_to_lvalue_scalar);
+ SETs(sv);
RETURN;
}
else if (PL_op->op_flags & OPf_MOD
Perl_croak(aTHX_ PL_no_localize_ref);
}
else {
- if (SvTYPE(sv) == SVt_PVAV) {
- av = (AV*)sv;
+ if (SvTYPE(sv) == type) {
if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)av);
+ SETs(sv);
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return array to lvalue"
- " scalar context");
- SETs((SV*)av);
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_
+ is_pp_rv2av ? return_array_to_lvalue_scalar
+ : return_hash_to_lvalue_scalar);
+ SETs(sv);
RETURN;
}
}
if (SvROK(sv))
goto wasref;
}
- if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF ||
- PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "an ARRAY");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- if (GIMME == G_ARRAY) {
- (void)POPs;
- RETURN;
- }
- RETSETUNDEF;
- }
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
- if (!gv
- && (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
- gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
- }
+ gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
+ type, &sp);
+ if (!gv)
+ RETURN;
}
else {
gv = (GV*)sv;
}
- av = GvAVn(gv);
+ sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
if (PL_op->op_private & OPpLVAL_INTRO)
- av = save_ary(gv);
+ sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)av);
+ SETs(sv);
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return array to lvalue"
- " scalar context");
- SETs((SV*)av);
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_
+ is_pp_rv2av ? return_array_to_lvalue_scalar
+ : return_hash_to_lvalue_scalar);
+ SETs(sv);
RETURN;
}
}
}
- if (GIMME == G_ARRAY) {
+ if (is_pp_rv2av) {
+ AV *const av = (AV*)sv;
+ /* The guts of pp_rv2av, with no intenting change to preserve history
+ (until such time as we get tools that can do blame annotation across
+ whitespace changes. */
+ if (gimme == G_ARRAY) {
const I32 maxarg = AvFILL(av) + 1;
(void)POPs; /* XXXX May be optimized away? */
EXTEND(SP, maxarg);
}
SP += maxarg;
}
- else if (GIMME_V == G_SCALAR) {
+ else if (gimme == G_SCALAR) {
dTARGET;
const I32 maxarg = AvFILL(av) + 1;
SETi(maxarg);
}
- RETURN;
-}
-
-PP(pp_rv2hv)
-{
- dVAR; dSP; dTOPss;
- HV *hv;
- const I32 gimme = GIMME_V;
- static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
-
- if (SvROK(sv)) {
- wasref:
- tryAMAGICunDEREF(to_hv);
-
- hv = (HV*)SvRV(sv);
- if (SvTYPE(hv) != SVt_PVHV)
- DIE(aTHX_ "Not a HASH reference");
- if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)hv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
- SETs((SV*)hv);
- RETURN;
- }
- else if (PL_op->op_flags & OPf_MOD
- && PL_op->op_private & OPpLVAL_INTRO)
- Perl_croak(aTHX_ PL_no_localize_ref);
- }
- else {
- if (SvTYPE(sv) == SVt_PVHV) {
- hv = (HV*)sv;
- if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)hv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
- SETs((SV*)hv);
- RETURN;
- }
- }
- else {
- GV *gv;
-
- if (SvTYPE(sv) != SVt_PVGV) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
- if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF ||
- PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "a HASH");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- if (gimme == G_ARRAY) {
- SP--;
- RETURN;
- }
- RETSETUNDEF;
- }
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
- if (!gv
- && (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
- {
- RETSETUNDEF;
- }
- }
- else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
- gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
- }
- }
- else {
- gv = (GV*)sv;
- }
- hv = GvHVn(gv);
- if (PL_op->op_private & OPpLVAL_INTRO)
- hv = save_hash(gv);
- if (PL_op->op_flags & OPf_REF) {
- SETs((SV*)hv);
- RETURN;
- }
- else if (LVRET) {
- if (gimme != G_ARRAY)
- Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
- SETs((SV*)hv);
- RETURN;
- }
- }
- }
-
+ } else {
+ /* The guts of pp_rv2hv */
if (gimme == G_ARRAY) { /* array wanted */
- *PL_stack_sp = (SV*)hv;
+ *PL_stack_sp = sv;
return do_kv();
}
else if (gimme == G_SCALAR) {
dTARGET;
- TARG = Perl_hv_scalar(aTHX_ hv);
+ TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
SETTARG;
}
+ }
RETURN;
}
}
}
}
+ if (PL_op->op_private & OPpASSIGN_STATE) {
+ if (SvPADSTALE(*firstlelem))
+ SvPADSTALE_off(*firstlelem);
+ else
+ RETURN; /* ignore assignment */
+ }
relem = firstrelem;
lelem = firstlelem;
if (pm->op_pmdynflags & PMdf_TAINTED)
SvTAINTED_on(rv);
sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
- RETURNX(PUSHs(rv));
+ XPUSHs(rv);
+ RETURN;
}
PP(pp_match)
const I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
I32 had_zerolen = 0;
+ U32 gpos = 0;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
- if (!(rx->reganch & ROPT_GPOS_SEEN))
+ if (!(rx->extflags & RXf_GPOS_SEEN))
rx->endp[0] = rx->startp[0] = mg->mg_len;
- else if (rx->reganch & ROPT_ANCH_GPOS) {
+ else if (rx->extflags & RXf_ANCH_GPOS) {
r_flags |= REXEC_IGNOREPOS;
rx->endp[0] = rx->startp[0] = mg->mg_len;
- }
- minmatch = (mg->mg_flags & MGf_MINMATCH);
+ } else if (rx->extflags & RXf_GPOS_FLOAT)
+ gpos = mg->mg_len;
+ else
+ rx->endp[0] = rx->startp[0] = mg->mg_len;
+ minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
update_minmatch = 0;
}
}
}
- if ((!global && rx->nparens)
- || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
+ /* remove comment to get faster /g but possibly unsafe $1 vars after a
+ match. Test for the unsafe vars will fail as well*/
+ if (( /* !global && */ rx->nparens)
+ || SvTEMP(TARG) || PL_sawampersand ||
+ (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
play_it_again:
if (global && rx->startp[0] != -1) {
- t = s = rx->endp[0] + truebase;
- if ((s + rx->minlen) > strend)
+ t = s = rx->endp[0] + truebase - rx->gofs;
+ if ((s + rx->minlen) > strend || s < truebase)
goto nope;
if (update_minmatch++)
minmatch = had_zerolen;
}
- if (rx->reganch & RE_USE_INTUIT &&
- DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
+ if (rx->extflags & RXf_USE_INTUIT &&
+ DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
/* FIXME - can PL_bostr be made const char *? */
PL_bostr = (char *)truebase;
- s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
+ s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
if (!s)
goto nope;
- if ( (rx->reganch & ROPT_CHECK_ALL)
+ if ( (rx->extflags & RXf_CHECK_ALL)
&& !PL_sawampersand
- && ((rx->reganch & ROPT_NOSCAN)
- || !((rx->reganch & RE_INTUIT_TAIL)
+ && !(pm->op_pmflags & PMf_KEEPCOPY)
+ && ((rx->extflags & RXf_NOSCAN)
+ || !((rx->extflags & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM)))
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
}
- if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
+ if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
{
PL_curpm = pm;
if (dynpm->op_pmflags & PMf_ONCE)
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
- if (rx->startp[0] == rx->endp[0])
+ if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
}
}
had_zerolen = (rx->startp[0] != -1
- && rx->startp[0] == rx->endp[0]);
+ && rx->startp[0] + rx->gofs == (UV)rx->endp[0]);
PUTBACK; /* EVAL blocks may use stack */
r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
goto play_it_again;
}
if (rx->startp[0] != -1) {
mg->mg_len = rx->endp[0];
- if (rx->startp[0] == rx->endp[0])
+ if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
mg->mg_flags |= MGf_MINMATCH;
else
mg->mg_flags &= ~MGf_MINMATCH;
rx->subbeg = (char *) truebase;
rx->startp[0] = s - truebase;
if (RX_MATCH_UTF8(rx)) {
- char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
+ char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
rx->endp[0] = t - truebase;
}
else {
- rx->endp[0] = s - truebase + rx->minlen;
+ rx->endp[0] = s - truebase + rx->minlenret;
}
rx->sublen = strend - truebase;
goto gotcha;
}
- if (PL_sawampersand) {
+ if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
I32 off;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
- (int) SvTYPE(TARG), truebase, t,
+ (int) SvTYPE(TARG), (void*)truebase, (void*)t,
(int)(t-truebase));
}
rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
rx->sublen = strend - t;
RX_MATCH_COPIED_on(rx);
off = rx->startp[0] = s - t;
- rx->endp[0] = off + rx->minlen;
+ rx->endp[0] = off + rx->minlenret;
}
else { /* startp/endp are used by @- @+. */
rx->startp[0] = s - truebase;
- rx->endp[0] = s - truebase + rx->minlen;
+ rx->endp[0] = s - truebase + rx->minlenret;
}
+ /* including rx->nparens in the below code seems highly suspicious.
+ -dmq */
rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
LEAVE_SCOPE(oldsave);
RETPUSHYES;
have_fp:
if (gimme == G_SCALAR) {
sv = TARG;
- if (SvROK(sv))
- sv_unref(sv);
+ if (type == OP_RCATLINE && SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv)) {
+ if (type == OP_RCATLINE)
+ SvPV_force_nolen(sv);
+ else
+ sv_unref(sv);
+ }
else if (isGV_with_GP(sv)) {
SvPV_force_nolen(sv);
}
SV* lv;
SV* key2;
if (!defer) {
- DIE(aTHX_ PL_no_helem_sv, keysv);
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
SAVEDELETE(hv, savepvn(key,keylen),
- SvUTF8(keysv) ? -(I32)keylen : keylen);
+ SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
} else
save_helem(hv, keysv, svp);
}
/* string increment */
register SV* cur = cx->blk_loop.iterlval;
STRLEN maxlen = 0;
- const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
+ const char *max =
+ SvOK((SV*)av) ?
+ SvPV_const((SV*)av, maxlen) : (const char *)"";
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
if (lv)
SvREFCNT_dec(LvTARG(lv));
else {
- lv = cx->blk_loop.iterlval = newSV(0);
- sv_upgrade(lv, SVt_PVLV);
+ lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
LvTYPE(lv) = 'y';
sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
}
!is_cow &&
#endif
(SvREADONLY(TARG)
- || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
+ || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+ || SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
DIE(aTHX_ PL_no_modify);
PUTBACK;
rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
- || (pm->op_pmflags & PMf_EVAL))
+ || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
orig = m = s;
- if (rx->reganch & RE_USE_INTUIT) {
+ if (rx->extflags & RXf_USE_INTUIT) {
PL_bostr = orig;
- s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
+ s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
if (!s)
goto nope;
/* How to do it in subst? */
-/* if ( (rx->reganch & ROPT_CHECK_ALL)
+/* if ( (rx->extflags & RXf_CHECK_ALL)
&& !PL_sawampersand
- && ((rx->reganch & ROPT_NOSCAN)
- || !((rx->reganch & RE_INTUIT_TAIL)
+ && !(pm->op_pmflags & PMf_KEEPCOPY)
+ && ((rx->extflags & RXf_NOSCAN)
+ || !((rx->extflags & RXf_INTUIT_TAIL)
&& (r_flags & REXEC_SCREAM))))
goto yup;
*/
#ifdef PERL_OLD_COPY_ON_WRITE
&& !is_cow
#endif
- && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
- && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
+ && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
+ && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
&& (!doutf8 || SvUTF8(TARG))) {
- if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
{
SPAGAIN;
d += clen;
}
s = rx->endp[0] + orig;
- } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
+ } while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL,
/* don't match same null twice */
REXEC_NOT_FIRST|REXEC_IGNOREPOS));
RETURN;
}
- if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
+ if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
{
if (force_on_match) {
#endif
rxtainted |= RX_MATCH_TAINTED(rx);
dstr = newSVpvn(m, s-m);
+ SAVEFREESV(dstr);
if (DO_UTF8(TARG))
SvUTF8_on(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
- (void)ReREFCNT_inc(rx);
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
sv_catpvn(dstr, c, clen);
if (once)
break;
- } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
+ } 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);
SvLEN_set(TARG, SvLEN(dstr));
doutf8 |= DO_UTF8(dstr);
SvPV_set(dstr, NULL);
- sv_free(dstr);
TAINT_IF(rxtainted & 1);
SPAGAIN;
return cx->blk_sub.retop;
}
-
-STATIC CV *
-S_get_db_sub(pTHX_ SV **svp, CV *cv)
-{
- dVAR;
- SV * const dbsv = GvSVn(PL_DBsub);
-
- save_item(dbsv);
- if (!PERLDB_SUB_NN) {
- GV * const gv = CvGV(cv);
-
- if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
- || strEQ(GvNAME(gv), "END")
- || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
- !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
- /* Use GV from the stack as a fallback. */
- /* GV is potentially non-unique, or contain different CV. */
- SV * const tmp = newRV((SV*)cv);
- sv_setsv(dbsv, tmp);
- SvREFCNT_dec(tmp);
- }
- else {
- gv_efullname3(dbsv, gv, NULL);
- }
- }
- else {
- const int type = SvTYPE(dbsv);
- if (type < SVt_PVIV && type != SVt_IV)
- sv_upgrade(dbsv, SVt_PVIV);
- (void)SvIOK_on(dbsv);
- SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
- }
-
- if (CvISXSUB(cv))
- PL_curcopdb = PL_curcop;
- cv = GvCV(PL_DBsub);
- return cv;
-}
-
PP(pp_entersub)
{
dVAR; dSP; dPOPss;
default:
if (!SvROK(sv)) {
const char *sym;
+ STRLEN len;
if (sv == &PL_sv_yes) { /* unfound import, ignore */
if (hasargs)
SP = PL_stack_base + POPMARK;
mg_get(sv);
if (SvROK(sv))
goto got_rv;
- sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
+ if (SvPOKp(sv)) {
+ sym = SvPVX_const(sv);
+ len = SvCUR(sv);
+ } else {
+ sym = NULL;
+ len = 0;
+ }
}
else {
- sym = SvPV_nolen_const(sv);
+ sym = SvPV_const(sv, len);
}
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_symref, sym, "a subroutine");
- cv = get_cv(sym, TRUE);
+ cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
got_rv:
else {
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, NULL);
- DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
}
}
if (!cv)
if (CvASSERTION(cv) && PL_DBassertion)
sv_setiv(PL_DBassertion, 1);
- cv = get_db_sub(&sv, cv);
+ Perl_get_db_sub(aTHX_ &sv, cv);
+ if (CvISXSUB(cv))
+ PL_curcopdb = PL_curcop;
+ cv = GvCV(PL_DBsub);
+
if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
DIE(aTHX_ "No DB::sub routine defined");
}
}
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (hasargs)
- {
+ if (hasargs) {
AV* const av = (AV*)PAD_SVl(0);
if (AvREAL(av)) {
/* @_ is normally not REAL--this should only ever
SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
if (items > AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items,SV*);
AvALLOC(av) = ary;
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
}
Copy(MARK,AvARRAY(av),items,SV*);
sub_crush_depth(cv);
#if 0
DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p entersub returning %p\n", thr, CvSTART(cv)));
+ "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
#endif
RETURNOP(CvSTART(cv));
}
else {
- I32 markix = TOPMARK;
+ I32 markix = TOPMARK;
- PUTBACK;
+ PUTBACK;
- if (!hasargs) {
- /* Need to copy @_ to stack. Alternative may be to
- * switch stack to @_, and copy return values
- * back. This would allow popping @_ in XSUB, e.g.. XXXX */
- AV * const av = GvAV(PL_defgv);
- const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
-
- if (items) {
- /* Mark is at the end of the stack. */
- EXTEND(SP, items);
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SP += items;
- PUTBACK ;
- }
- }
- /* We assume first XSUB in &DB::sub is the called one. */
- if (PL_curcopdb) {
- SAVEVPTR(PL_curcop);
- PL_curcop = PL_curcopdb;
- PL_curcopdb = NULL;
- }
- /* Do we need to open block here? XXXX */
+ if (!hasargs) {
+ /* Need to copy @_ to stack. Alternative may be to
+ * switch stack to @_, and copy return values
+ * back. This would allow popping @_ in XSUB, e.g.. XXXX */
+ AV * const av = GvAV(PL_defgv);
+ const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
+
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(SP, items);
+ Copy(AvARRAY(av), SP + 1, items, SV*);
+ SP += items;
+ PUTBACK ;
+ }
+ }
+ /* We assume first XSUB in &DB::sub is the called one. */
+ if (PL_curcopdb) {
+ SAVEVPTR(PL_curcop);
+ PL_curcop = PL_curcopdb;
+ PL_curcopdb = NULL;
+ }
+ /* Do we need to open block here? XXXX */
+ if (CvXSUB(cv)) /* XXX this is supposed to be true */
(void)(*CvXSUB(cv))(aTHX_ cv);
- /* Enforce some sanity in scalar context. */
- if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
- if (markix > PL_stack_sp - PL_stack_base)
- *(PL_stack_base + markix) = &PL_sv_undef;
- else
- *(PL_stack_base + markix) = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + markix;
- }
+ /* Enforce some sanity in scalar context. */
+ if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
+ if (markix > PL_stack_sp - PL_stack_base)
+ *(PL_stack_base + markix) = &PL_sv_undef;
+ else
+ *(PL_stack_base + markix) = *PL_stack_sp;
+ PL_stack_sp = PL_stack_base + markix;
+ }
LEAVE;
return NORMAL;
}
SV* const tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), NULL);
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
- tmpstr);
+ SVfARG(tmpstr));
}
}
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Use of reference \"%"SVf"\" as array index",
+ SVfARG(elemsv));
if (elem > 0)
elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
: "on an undefined value");
}
/* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, FALSE);
+ stash = gv_stashpvn(packname, packlen, 0);
if (!stash)
packsv = sv;
else {
}
/* we're relying on gv_fetchmethod not autovivifying the stash */
- if (gv_stashpvn(packname, packlen, FALSE)) {
+ if (gv_stashpvn(packname, packlen, 0)) {
Perl_croak(aTHX_
"Can't locate object method \"%s\" via package \"%.*s\"",
leaf, (int)packlen, packname);
https://perl5.git.perl.org / perl5.git / blobdiff