/* 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) {
- SV *cv = SvRV(left);
+ SV * const cv = SvRV(left);
const U32 cv_type = SvTYPE(cv);
const U32 gv_type = SvTYPE(right);
- bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
+ const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
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) {
/* Is the target symbol table currently empty? */
- GV *gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
+ GV * const gv = gv_fetchsv(right, 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. */
SV *const value = SvRV(cv);
SvUPGRADE((SV *)gv, SVt_RV);
- SvROK_on(gv);
+ SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
- SvREFCNT_inc(value);
+ SvREFCNT_inc_simple_void(value);
SETs(right);
RETURN;
}
/* We've been returned a constant rather than a full subroutine,
but they expect a subroutine reference to apply. */
ENTER;
- SvREFCNT_inc(SvRV(cv));
+ SvREFCNT_inc_void(SvRV(cv));
/* newCONSTSUB takes a reference count on the passed in SV
from us. We set the name to NULL, otherwise we get into
all sorts of fun as the reference to our new sub is
LEAVE;
}
+ if (strEQ(GvNAME(right),"isa")) {
+ GvCVGEN(right) = 0;
+ ++PL_sub_generation;
+ }
}
SvSetMagicSV(right, left);
SETs(right);
dPOPTOPssrl;
bool lbyte;
STRLEN rlen;
- const char *rpv = 0;
+ const char *rpv = NULL;
bool rbyte = FALSE;
bool rcopied = FALSE;
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);
ivp = *--SP;
}
iv = SvIVX(ivp);
- if (iv < 0) {
+ if (iv < 0)
/* As uv is a UV, it's >0, so it cannot be == */
SETs(&PL_sv_no);
- RETURN;
- }
- /* we know iv is >= 0 */
- SETs(boolSV((UV)iv == SvUVX(uvp)));
+ else
+ /* we know iv is >= 0 */
+ SETs(boolSV((UV)iv == SvUVX(uvp)));
RETURN;
}
}
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left == right));
+#else
dPOPnv;
SETs(boolSV(TOPn == value));
+#endif
RETURN;
}
}
PP(pp_defined)
{
dVAR; dSP;
- register SV* sv = NULL;
- bool defined = FALSE;
+ register SV* sv;
+ bool defined;
const int op_type = PL_op->op_type;
+ const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
- if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
+ if (is_dor) {
sv = TOPs;
if (!sv || !SvANY(sv)) {
if (op_type == OP_DOR)
} else
DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
+ defined = FALSE;
switch (SvTYPE(sv)) {
case SVt_PVAV:
if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
SvGETMAGIC(sv);
if (SvOK(sv))
defined = TRUE;
+ break;
}
-
- if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
+
+ if (is_dor) {
if(defined)
RETURN;
if(op_type == OP_DOR)
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 U32 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;
}
Perl_warner(aTHX_ packWARN(WARN_MISC), err);
}
- tmpstr = NEWSV(29,0);
+ tmpstr = newSV(0);
didstore = hv_store_ent(hash,*relem,tmpstr,0);
if (SvMAGICAL(hash)) {
if (SvSMAGICAL(tmpstr))
}
}
}
+ if (PL_op->op_private & OPpASSIGN_STATE) {
+ if (SvPADSTALE(*firstlelem))
+ SvPADSTALE_off(*firstlelem);
+ else
+ RETURN; /* ignore assignment */
+ }
relem = firstrelem;
lelem = firstlelem;
- ary = Null(AV*);
- hash = Null(HV*);
+ ary = NULL;
+ hash = NULL;
while (lelem <= lastlelem) {
TAINT_NOT; /* Each item stands on its own, taintwise. */
while (relem < lastrelem) { /* gobble up all the rest */
HE *didstore;
- if (*relem)
- sv = *(relem++);
- else
- sv = &PL_sv_no, relem++;
- tmpstr = NEWSV(29,0);
+ sv = *relem ? *relem : &PL_sv_no;
+ relem++;
+ tmpstr = newSV(0);
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
*(relem++) = tmpstr;
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)
+ /* 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 (global) {
if (dynpm->op_pmflags & PMf_CONTINUE) {
- MAGIC* mg = 0;
+ MAGIC* mg = NULL;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (!mg) {
- sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG, 0);
+#endif
+ mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
+ &PL_vtbl_mglob, NULL, 0);
}
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;
else
mg = NULL;
if (!mg) {
- sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
- mg = mg_find(TARG, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(TARG))
+ sv_force_normal_flags(TARG, 0);
+#endif
+ mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
+ &PL_vtbl_mglob, NULL, 0);
}
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;
if (RX_MATCH_COPIED(rx))
Safefree(rx->subbeg);
RX_MATCH_COPIED_off(rx);
- rx->subbeg = Nullch;
+ rx->subbeg = NULL;
if (global) {
/* FIXME - should rx->subbeg be const char *? */
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->subbeg = savepvn(t, strend - t);
#ifdef PERL_OLD_COPY_ON_WRITE
- rx->saved_copy = Nullsv;
+ rx->saved_copy = NULL;
#endif
}
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;
ret_no:
if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg)
mg->mg_len = -1;
}
register IO * const io = GvIO(PL_last_in_gv);
register const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
- MAGIC *mg;
- if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- PUTBACK;
- ENTER;
- call_method("READLINE", gimme);
- LEAVE;
- SPAGAIN;
- if (gimme == G_SCALAR) {
- SV* result = POPs;
- SvSetSV_nosteal(TARG, result);
- PUSHTARG;
+ if (io) {
+ MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
+ if (mg) {
+ PUSHMARK(SP);
+ XPUSHs(SvTIED_obj((SV*)io, mg));
+ PUTBACK;
+ ENTER;
+ call_method("READLINE", gimme);
+ LEAVE;
+ SPAGAIN;
+ if (gimme == G_SCALAR) {
+ SV* const result = POPs;
+ SvSetSV_nosteal(TARG, result);
+ PUSHTARG;
+ }
+ RETURN;
}
- RETURN;
}
- fp = Nullfp;
+ fp = NULL;
if (io) {
fp = IoIFP(io);
if (!fp) {
IoLINES(io) = 0;
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
- do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
+ do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
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);
+ }
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen && !SvREADONLY(sv))
}
}
else {
- sv = sv_2mortal(NEWSV(57, 80));
+ sv = sv_2mortal(newSV(80));
offset = 0;
}
SPAGAIN;
XPUSHs(sv);
if (type == OP_GLOB) {
- char *tmps;
const char *t1;
if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
- tmps = SvEND(sv) - 1;
+ char * const tmps = SvEND(sv) - 1;
if (*tmps == *SvPVX_const(PL_rs)) {
*tmps = '\0';
SvCUR_set(sv, SvCUR(sv) - 1);
continue;
}
} else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
- const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
- const STRLEN len = SvCUR(sv) - offset;
- const U8 *f;
-
- if (ckWARN(WARN_UTF8) &&
- !is_utf8_string_loc(s, len, &f))
- /* Emulate :encoding(utf8) warning in the same case. */
- Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "utf8 \"\\x%02X\" does not map to Unicode",
- f < (U8*)SvEND(sv) ? *f : 0);
+ if (ckWARN(WARN_UTF8)) {
+ const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
+ const STRLEN len = SvCUR(sv) - offset;
+ const U8 *f;
+
+ if (!is_utf8_string_loc(s, len, &f))
+ /* Emulate :encoding(utf8) warning in the same case. */
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "utf8 \"\\x%02X\" does not map to Unicode",
+ f < (U8*)SvEND(sv) ? *f : 0);
+ }
}
if (gimme == G_ARRAY) {
if (SvLEN(sv) - SvCUR(sv) > 20) {
SvPV_shrink_to_cur(sv);
}
- sv = sv_2mortal(NEWSV(58, 80));
+ sv = sv_2mortal(newSV(80));
continue;
}
else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
I32 preeminent = 0;
- if (SvTYPE(hv) == SVt_PVHV) {
- if (PL_op->op_private & OPpLVAL_INTRO) {
- MAGIC *mg;
- HV *stash;
- /* does the element we're localizing already exist? */
- preeminent =
- /* can we determine whether it exists? */
- ( !SvRMAGICAL(hv)
- || mg_find((SV*)hv, PERL_MAGIC_env)
- || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
- /* Try to preserve the existenceness of a tied hash
- * element by using EXISTS and DELETE if possible.
- * Fallback to FETCH and STORE otherwise */
- && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
- && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
- && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
- )
- ) ? hv_exists_ent(hv, keysv, 0) : 1;
-
- }
- he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
- svp = he ? &HeVAL(he) : 0;
- }
- else {
+ if (SvTYPE(hv) != SVt_PVHV)
RETPUSHUNDEF;
- }
+
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ MAGIC *mg;
+ HV *stash;
+ /* does the element we're localizing already exist? */
+ preeminent = /* can we determine whether it exists? */
+ ( !SvRMAGICAL(hv)
+ || mg_find((SV*)hv, PERL_MAGIC_env)
+ || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
+ /* Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise */
+ && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
+ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+ && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
+ )
+ ) ? hv_exists_ent(hv, keysv, 0) : 1;
+ }
+ he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
+ svp = he ? &HeVAL(he) : NULL;
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
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);
LvTYPE(lv) = 'y';
- sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
+ sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
SvREFCNT_dec(key2); /* sv_magic() increments refcount */
- LvTARG(lv) = SvREFCNT_inc(hv);
+ LvTARG(lv) = SvREFCNT_inc_simple(hv);
LvTARGLEN(lv) = 1;
PUSHs(lv);
RETURN;
if (!preeminent) {
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
+ SAVEDELETE(hv, savepvn(key,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 (SvMAGICAL(av) || AvREIFY(av)) {
SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
- sv = svp ? *svp : Nullsv;
+ sv = svp ? *svp : NULL;
}
else {
sv = AvARRAY(av)[--cx->blk_loop.iterix];
if (SvMAGICAL(av) || AvREIFY(av)) {
SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
- sv = svp ? *svp : Nullsv;
+ sv = svp ? *svp : NULL;
}
else {
sv = AvARRAY(av)[++cx->blk_loop.iterix];
}
if (sv && SvIS_FREED(sv)) {
- *itersvp = Nullsv;
+ *itersvp = NULL;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
SV *lv = cx->blk_loop.iterlval;
if (lv && SvREFCNT(lv) > 1) {
SvREFCNT_dec(lv);
- lv = Nullsv;
+ lv = NULL;
}
if (lv)
SvREFCNT_dec(LvTARG(lv));
else {
- lv = cx->blk_loop.iterlval = NEWSV(26, 0);
- sv_upgrade(lv, SVt_PVLV);
+ lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
}
- LvTARG(lv) = SvREFCNT_inc(av);
+ LvTARG(lv) = SvREFCNT_inc_simple(av);
LvTARGOFF(lv) = cx->blk_loop.iterix;
LvTARGLEN(lv) = (STRLEN)UV_MAX;
sv = (SV*)lv;
}
oldsv = *itersvp;
- *itersvp = SvREFCNT_inc(sv);
+ *itersvp = SvREFCNT_inc_simple_NN(sv);
SvREFCNT_dec(oldsv);
RETPUSHYES;
dVAR; dSP; dTARG;
register PMOP *pm = cPMOP;
PMOP *rpm = pm;
- register SV *dstr;
register char *s;
char *strend;
register char *m;
#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
- SV *nsv = Nullsv;
+ SV *nsv = NULL;
/* known replacement string? */
- dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
+ register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
else if (PL_op->op_private & OPpTARGET_MY)
!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;
pm = PL_curpm;
rx = PM_GETRE(pm);
}
- r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
+ r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
+ || (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;
*/
}
}
else {
- c = Nullch;
+ c = NULL;
doutf8 = FALSE;
}
#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);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
doutf8 |= DO_UTF8(dstr);
- SvPV_set(dstr, (char*)0);
- sv_free(dstr);
+ SvPV_set(dstr, NULL);
TAINT_IF(rxtainted & 1);
SPAGAIN;
EXTEND_MORTAL(SP - newsp);
for (mark = newsp + 1; mark <= SP; mark++) {
if (SvTEMP(*mark))
- /* empty */ ;
+ NOOP;
else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
*mark = sv_mortalcopy(*mark);
else {
/* Can be a localized value subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
- (void)SvREFCNT_inc(*mark);
+ SvREFCNT_inc_void(*mark);
}
}
}
else { /* Can be a localized value
* subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
- (void)SvREFCNT_inc(*mark);
+ SvREFCNT_inc_void(*mark);
}
}
else { /* Should not happen? */
else {
/* Can be a localized value subject to deletion. */
PL_tmps_stack[++PL_tmps_ix] = *mark;
- (void)SvREFCNT_inc(*mark);
+ SvREFCNT_inc_void(*mark);
}
}
}
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 *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)
- && (gv = (GV*)*svp) ))) {
- /* 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, Nullch);
- }
- }
- 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 (CvXSUB(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) : Nullch;
+ 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:
/* sorry */
else {
sub_name = sv_newmortal();
- gv_efullname3(sub_name, gv, Nullch);
- DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
+ gv_efullname3(sub_name, gv, NULL);
+ 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");
}
- if (!(CvXSUB(cv))) {
+ if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
register I32 items = SP - MARK;
}
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
AvREIFY_on(av);
}
cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
++MARK;
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 {
-#ifdef PERL_XSUB_OLDSTYLE
- if (CvOLDSTYLE(cv)) {
- I32 (*fp3)(int,int,int);
- dMARK;
- register I32 items = SP - MARK;
- /* We dont worry to copy from @_. */
- while (SP > mark) {
- SP[1] = SP[0];
- SP--;
- }
- PL_stack_sp = mark + 1;
- fp3 = (I32(*)(int,int,int))CvXSUB(cv);
- items = (*fp3)(CvXSUBANY(cv).any_i32,
- MARK - PL_stack_base + 1,
- items);
- PL_stack_sp = PL_stack_base + items;
- }
- else
-#endif /* PERL_XSUB_OLDSTYLE */
- {
- 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;
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
SV* const tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, CvGV(cv), Nullch);
+ 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 -= PL_curcop->cop_arybase;
+ elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
svp = av_fetch(av, elem, lval && !defer);
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
LvTYPE(lv) = 'y';
- sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
- LvTARG(lv) = SvREFCNT_inc(av);
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
+ LvTARG(lv) = SvREFCNT_inc_simple(av);
LvTARGOFF(lv) = elem;
LvTARGLEN(lv) = 1;
PUSHs(lv);
}
switch (to_what) {
case OPpDEREF_SV:
- SvRV_set(sv, NEWSV(355,0));
+ SvRV_set(sv, newSV(0));
break;
case OPpDEREF_AV:
SvRV_set(sv, (SV*)newAV());
}
}
- SETs(method_common(sv, Null(U32*)));
+ SETs(method_common(sv, NULL));
RETURN;
}
GV* gv;
HV* stash;
STRLEN namelen;
- const char* packname = Nullch;
- SV *packsv = Nullsv;
+ const char* packname = NULL;
+ SV *packsv = NULL;
STRLEN packlen;
const char * const name = SvPV_const(meth, namelen);
SV * const sv = *(PL_stack_base + TOPMARK + 1);
: "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 {
- SV* ref = newSViv(PTR2IV(stash));
+ SV* const ref = newSViv(PTR2IV(stash));
hv_store(PL_stashcache, packname, packlen, ref, 0);
}
goto fetch;
don't want that.
*/
const char* leaf = name;
- const char* sep = Nullch;
+ const char* sep = NULL;
const char* p;
for (p = name; *p; p++) {
}
/* 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