/* pp_hot.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
PP(pp_const)
{
+ dVAR;
dSP;
XPUSHs(cSVOP_sv);
RETURN;
PP(pp_nextstate)
{
+ dVAR;
PL_curcop = (COP*)PL_op;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
PP(pp_gvsv)
{
+ dVAR;
dSP;
EXTEND(SP,1);
if (PL_op->op_private & OPpLVAL_INTRO)
PP(pp_null)
{
+ dVAR;
return NORMAL;
}
PP(pp_setstate)
{
+ dVAR;
PL_curcop = (COP*)PL_op;
return NORMAL;
}
PP(pp_pushmark)
{
+ dVAR;
PUSHMARK(PL_stack_sp);
return NORMAL;
}
PP(pp_stringify)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
sv_copypv(TARG,TOPs);
SETTARG;
RETURN;
PP(pp_gv)
{
- dSP;
+ dVAR; dSP;
XPUSHs((SV*)cGVOP_gv);
RETURN;
}
PP(pp_and)
{
- dSP;
+ dVAR; dSP;
if (!SvTRUE(TOPs))
RETURN;
else {
PP(pp_sassign)
{
- dSP; dPOPTOPssrl;
+ dVAR; dSP; dPOPTOPssrl;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
- SV *temp;
- temp = left; left = right; right = temp;
+ 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 * const cv = SvRV(left);
+ const U32 cv_type = SvTYPE(cv);
+ const U32 gv_type = SvTYPE(right);
+ 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
+ context. */
+ if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
+ /* Is the target symbol table currently empty? */
+ 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);
+ SvRV_set(gv, value);
+ SvREFCNT_inc_simple_void(value);
+ SETs(right);
+ RETURN;
+ }
+ }
+
+ /* Need to fix things up. */
+ if (gv_type != SVt_PVGV) {
+ /* Need to fix GV. */
+ right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
+ }
+
+ if (!got_coderef) {
+ /* We've been returned a constant rather than a full subroutine,
+ but they expect a subroutine reference to apply. */
+ ENTER;
+ 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
+ donated to the GV that we're about to assign to.
+ */
+ SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
+ SvRV(cv)));
+ SvREFCNT_dec(cv);
+ LEAVE;
+ }
+
+ if (strEQ(GvNAME(right),"isa")) {
+ GvCVGEN(right) = 0;
+ ++PL_sub_generation;
+ }
+ }
SvSetMagicSV(right, left);
SETs(right);
RETURN;
PP(pp_cond_expr)
{
- dSP;
+ dVAR; dSP;
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
else
PP(pp_unstack)
{
+ dVAR;
I32 oldsave;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
PP(pp_concat)
{
- dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
bool lbyte;
STRLEN rlen;
- const char *rpv;
- bool rbyte;
+ const char *rpv = NULL;
+ bool rbyte = FALSE;
bool rcopied = FALSE;
if (TARG == right && right != left) {
PP(pp_padsv)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
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);
PP(pp_readline)
{
+ dVAR;
tryAMAGICunTARGET(iter, 0);
PL_last_in_gv = (GV*)(*PL_stack_sp--);
if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
PP(pp_eq)
{
- dSP; tryAMAGICbinSET(eq,0);
+ dVAR; dSP; tryAMAGICbinSET(eq,0);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
right argument if we know the left is integer. */
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
+ const bool auvok = SvUOK(TOPm1s);
+ const bool buvok = SvUOK(TOPs);
if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
/* Casting IV to UV before comparison isn't going to matter
differ from normal zero. As I understand it. (Need to
check - is negative zero implementation defined behaviour
anyway?). NWC */
- UV buv = SvUVX(POPs);
- UV auv = SvUVX(TOPs);
+ const UV buv = SvUVX(POPs);
+ const UV auv = SvUVX(TOPs);
SETs(boolSV(auv == buv));
RETURN;
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_preinc)
{
- dSP;
+ dVAR; dSP;
if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
PP(pp_or)
{
- dSP;
+ dVAR; dSP;
if (SvTRUE(TOPs))
RETURN;
else {
PP(pp_defined)
{
- dSP;
- register SV* sv = NULL;
- bool defined = FALSE;
+ dVAR; dSP;
+ 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)
PP(pp_add)
{
- dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
+ dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
useleft = USE_LEFT(TOPm1s);
#ifdef PERL_PRESERVE_IVUV
/* We must see if we can perform the addition with integers if possible,
PP(pp_aelemfast)
{
- dSP;
- AV *av = PL_op->op_flags & OPf_SPECIAL ?
+ dVAR; dSP;
+ AV * const av = PL_op->op_flags & OPf_SPECIAL ?
(AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
- SV** svp = av_fetch(av, PL_op->op_private, lval);
+ SV** const svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
EXTEND(SP, 1);
if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
PP(pp_join)
{
- dSP; dMARK; dTARGET;
+ dVAR; dSP; dMARK; dTARGET;
MARK++;
do_join(TARG, *MARK, MARK, SP);
SP = MARK;
PP(pp_pushre)
{
- dSP;
+ dVAR; dSP;
#ifdef DEBUGGING
/*
* We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- GV *gv;
IO *io;
register PerlIO *fp;
MAGIC *mg;
-
- if (PL_op->op_flags & OPf_STACKED)
- gv = (GV*)*++MARK;
- else
- gv = PL_defoutgv;
+ GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
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)
{
- dSP; dTOPss;
+ dVAR; dSP; dTOPss;
AV *av;
if (SvROK(sv)) {
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
+ gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
if (!gv
&& (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
+ || !(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, TRUE, SVt_PVAV);
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
}
}
else {
PP(pp_rv2hv)
{
- dSP; dTOPss;
+ 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 ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
+ gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
if (!gv
&& (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
+ || !(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, TRUE, SVt_PVHV);
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
}
}
else {
STATIC void
S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
{
+ dVAR;
if (*relem) {
SV *tmpstr;
const HE *didstore;
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))
I32 i;
int magic;
int duplicates = 0;
- SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
+ SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
}
}
}
+ 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;
PP(pp_qr)
{
- dSP;
+ dVAR; dSP;
register PMOP * const pm = cPMOP;
SV * const rv = sv_newmortal();
SV * const sv = newSVrv(rv, "Regexp");
PP(pp_match)
{
- dSP; dTARG;
+ dVAR; dSP; dTARG;
register PMOP *pm = cPMOP;
PMOP *dynpm = pm;
register const char *t;
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 ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
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 >= 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))
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)
+ && ((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 {
if (global) {
- MAGIC* mg = 0;
+ MAGIC* mg;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ 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;
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;
}
rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
LEAVE_SCOPE(oldsave);
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 *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) {
PP(pp_helem)
{
- dSP;
+ dVAR; dSP;
HE* he;
SV **svp;
- SV *keysv = POPs;
- HV *hv = (HV*)POPs;
+ SV * const keysv = POPs;
+ HV * const hv = (HV*)POPs;
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;
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;
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);
}
PP(pp_iter)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
SV *sv, *oldsv;
AV* av;
/* 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 */
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV ** const svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
- sv = svp ? *svp : Nullsv;
+ SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
+ sv = svp ? *svp : NULL;
}
else {
- sv = AvARRAY(av)[cx->blk_loop.iterix--];
+ sv = AvARRAY(av)[--cx->blk_loop.iterix];
}
}
else {
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
- sv = svp ? *svp : Nullsv;
+ SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ 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);
+ lv = cx->blk_loop.iterlval = newSV(0);
sv_upgrade(lv, 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;
PP(pp_subst)
{
- dSP; dTARG;
+ 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)
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))
? 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)
+ && ((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)
-{
- 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;
GV *gv;
- HV *stash;
register CV *cv;
register PERL_CONTEXT *cx;
I32 gimme;
switch (SvTYPE(sv)) {
/* This is overwhelming the most common case: */
case SVt_PVGV:
- if (!(cv = GvCVu((GV*)sv)))
- cv = sv_2cv(sv, &stash, &gv, FALSE);
+ if (!(cv = GvCVu((GV*)sv))) {
+ HV *stash;
+ cv = sv_2cv(sv, &stash, &gv, 0);
+ }
if (!cv) {
ENTER;
SAVETMPS;
mg_get(sv);
if (SvROK(sv))
goto got_rv;
- sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
+ sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
}
else {
sym = SvPV_nolen_const(sv);
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
- goto fooey;
+ GV* autogv;
+ SV* sub_name;
+
+ /* anonymous or undef'd function leaves us no recourse */
+ if (CvANON(cv) || !(gv = CvGV(cv)))
+ DIE(aTHX_ "Undefined subroutine called");
+
+ /* autoloaded stub? */
+ if (cv != GvCV(gv)) {
+ cv = GvCV(gv);
+ }
+ /* should call AUTOLOAD now? */
+ else {
+try_autoload:
+ if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ FALSE)))
+ {
+ cv = GvCV(autogv);
+ }
+ /* sorry */
+ else {
+ sub_name = sv_newmortal();
+ gv_efullname3(sub_name, gv, NULL);
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
+ }
+ }
+ if (!cv)
+ DIE(aTHX_ "Not a CODE reference");
+ goto retry;
}
gimme = GIMME_V;
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*);
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;
}
-
- /*NOTREACHED*/
- assert (0); /* Cannot get here. */
- /* This is deliberately moved here as spaghetti code to keep it out of the
- hot path. */
- {
- GV* autogv;
- SV* sub_name;
-
- fooey:
- /* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv)))
- DIE(aTHX_ "Undefined subroutine called");
-
- /* autoloaded stub? */
- if (cv != GvCV(gv)) {
- cv = GvCV(gv);
- }
- /* should call AUTOLOAD now? */
- else {
-try_autoload:
- if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
- FALSE)))
- {
- cv = GvCV(autogv);
- }
- /* sorry */
- else {
- sub_name = sv_newmortal();
- gv_efullname3(sub_name, gv, Nullch);
- DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
- }
- }
- if (!cv)
- DIE(aTHX_ "Not a CODE reference");
- goto retry;
- }
}
void
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);
+ (void*)tmpstr);
}
}
PP(pp_aelem)
{
- dSP;
+ dVAR; dSP;
SV** svp;
SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
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",
+ (void*)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());
PP(pp_method)
{
- dSP;
+ dVAR; dSP;
SV* const sv = TOPs;
if (SvROK(sv)) {
}
}
- SETs(method_common(sv, Null(U32*)));
+ SETs(method_common(sv, NULL));
RETURN;
}
PP(pp_method_named)
{
- dSP;
+ dVAR; dSP;
SV* const sv = cSVOP_sv;
U32 hash = SvSHARED_HASH(sv);
STATIC SV *
S_method_common(pTHX_ SV* meth, U32* hashp)
{
+ dVAR;
SV* ob;
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);
if (!SvOK(sv) ||
!(packname) ||
- !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
+ !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
/* this isn't the name of a filehandle either */
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++) {
https://perl5.git.perl.org / perl5.git / blobdiff