/* 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 * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * Then he heard Merry change the note, and up went the Horn-cry of Buckland, * shaking the air. * * Awake! Awake! Fear, Fire, Foes! Awake! * Fire, Foes! Awake! */ /* This file contains 'hot' pp ("push/pop") functions that * execute the opcodes that make up a perl program. A typical pp function * expects to find its arguments on the stack, and usually pushes its * results onto the stack, hence the 'pp' terminology. Each OP structure * contains a pointer to the relevant pp_foo() function. * * By 'hot', we mean common ops whose execution speed is critical. * By gathering them together into a single file, we encourage * CPU cache hits on hot code. Also it could be taken as a warning not to * change any code in this file unless you're sure it won't affect * performance. */ #include "EXTERN.h" #define PERL_IN_PP_HOT_C #include "perl.h" /* Hot code. */ PP(pp_const) 74615042 { 74615042 dSP; 74615042 XPUSHs(cSVOP_sv); 74615042 RETURN; } PP(pp_nextstate) 146965206 { 146965206 PL_curcop = (COP*)PL_op; 146965206 TAINT_NOT; /* Each statement is presumed innocent */ 146965206 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 146965206 FREETMPS; 146965206 return NORMAL; } PP(pp_gvsv) 53779192 { 53779192 dSP; 53779192 EXTEND(SP,1); 53779192 if (PL_op->op_private & OPpLVAL_INTRO) 18551779 PUSHs(save_scalar(cGVOP_gv)); else 35227413 PUSHs(GvSVn(cGVOP_gv)); 53779191 RETURN; } PP(pp_null) 304734 { 304734 return NORMAL; } PP(pp_setstate) ###### { ###### PL_curcop = (COP*)PL_op; ###### return NORMAL; } PP(pp_pushmark) 54708710 { 54708710 PUSHMARK(PL_stack_sp); 54708710 return NORMAL; } PP(pp_stringify) 485372 { 485372 dSP; dTARGET; 485372 sv_copypv(TARG,TOPs); 485372 SETTARG; 485372 RETURN; } PP(pp_gv) 37906259 { 37906259 dSP; 37906259 XPUSHs((SV*)cGVOP_gv); 37906259 RETURN; } PP(pp_and) 71153862 { 71153862 dSP; 71153862 if (!SvTRUE(TOPs)) 23239777 RETURN; else { 47914083 --SP; 47914083 RETURNOP(cLOGOP->op_other); } } PP(pp_sassign) 42853134 { 42853134 dSP; dPOPTOPssrl; 42853134 if (PL_op->op_private & OPpASSIGN_BACKWARDS) { 1156266 SV *temp; 1156266 temp = left; left = right; right = temp; } 42853134 if (PL_tainting && PL_tainted && !SvTAINTED(left)) 36 TAINT_NOT; 42853134 SvSetMagicSV(right, left); 42853093 SETs(right); 42853093 RETURN; } PP(pp_cond_expr) 8428917 { 8428917 dSP; 8428917 if (SvTRUEx(POPs)) 4338070 RETURNOP(cLOGOP->op_other); else 4090847 RETURNOP(cLOGOP->op_next); } PP(pp_unstack) 35867605 { 35867605 I32 oldsave; 35867605 TAINT_NOT; /* Each statement is presumed innocent */ 35867605 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; 35867605 FREETMPS; 35867605 oldsave = PL_scopestack[PL_scopestack_ix - 1]; 35867605 LEAVE_SCOPE(oldsave); 35867605 return NORMAL; } PP(pp_concat) 5708454 { 5708454 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { 5708449 dPOPTOPssrl; 5708449 bool lbyte; 5708449 STRLEN rlen; 5708449 const char *rpv = SvPV_const(right, rlen); /* mg_get(right) happens here */ 5708447 const bool rbyte = !DO_UTF8(right); 5708447 bool rcopied = FALSE; 5708447 if (TARG == right && right != left) { 73806 right = sv_2mortal(newSVpvn(rpv, rlen)); 73806 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ 73806 rcopied = TRUE; } 5708447 if (TARG != left) { 2294007 STRLEN llen; 2294007 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */ 2294007 lbyte = !DO_UTF8(left); 2294007 sv_setpvn(TARG, lpv, llen); 2294007 if (!lbyte) 18060 SvUTF8_on(TARG); else 2275947 SvUTF8_off(TARG); } else { /* TARG == left */ 3414440 STRLEN llen; 3414440 if (SvGMAGICAL(left)) 2741 mg_get(left); /* or mg_get(left) may happen here */ 3414439 if (!SvOK(TARG)) 19334 sv_setpvn(left, "", 0); 3414439 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */ 3414439 lbyte = !DO_UTF8(left); 3414439 if (IN_BYTES) 123 SvUTF8_off(TARG); } 5708446 if (lbyte != rbyte) { 64584 if (lbyte) 9429 sv_utf8_upgrade_nomg(TARG); else { 55155 if (!rcopied) 55153 right = sv_2mortal(newSVpvn(rpv, rlen)); 55155 sv_utf8_upgrade_nomg(right); 55155 rpv = SvPV_const(right, rlen); } } 5708444 sv_catpvn_nomg(TARG, rpv, rlen); 5708444 SETTARG; 5708444 RETURN; } } PP(pp_padsv) 205715463 { 205715463 dSP; dTARGET; 205715463 XPUSHs(TARG); 205715463 if (PL_op->op_flags & OPf_MOD) { 93990570 if (PL_op->op_private & OPpLVAL_INTRO) 44819659 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 93990570 if (PL_op->op_private & OPpDEREF) { 16691812 PUTBACK; 16691812 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF); 16691812 SPAGAIN; } } 205715463 RETURN; } PP(pp_readline) 859432 { 859432 tryAMAGICunTARGET(iter, 0); 859432 PL_last_in_gv = (GV*)(*PL_stack_sp--); 859432 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) { 599476 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) 567737 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv); else { 31739 dSP; 31739 XPUSHs((SV*)PL_last_in_gv); 31739 PUTBACK; 31739 pp_rv2gv(); 31739 PL_last_in_gv = (GV*)(*PL_stack_sp--); } } 859432 return do_readline(); } PP(pp_eq) 5455924 { 5455924 dSP; tryAMAGICbinSET(eq,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); RETURN; } #endif #ifdef PERL_PRESERVE_IVUV 5454236 SvIV_please(TOPs); 5454236 if (SvIOK(TOPs)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ 4799810 SvIV_please(TOPm1s); 4799808 if (SvIOK(TOPm1s)) { 4787821 bool auvok = SvUOK(TOPm1s); 4787821 bool buvok = SvUOK(TOPs); 4787821 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ /* Casting IV to UV before comparison isn't going to matter on 2s complement. On 1s complement or sign&magnitude (if we have any of them) it could to make negative zero differ from normal zero. As I understand it. (Need to check - is negative zero implementation defined behaviour anyway?). NWC */ 4787711 UV buv = SvUVX(POPs); 4787711 UV auv = SvUVX(TOPs); 4787711 SETs(boolSV(auv == buv)); 4787711 RETURN; } { /* ## Mixed IV,UV ## */ 110 SV *ivp, *uvp; 110 IV iv; /* == is commutative so doesn't matter which is left or right */ 110 if (auvok) { /* top of stack (b) is the iv */ 38 ivp = *SP; 38 uvp = *--SP; } else { 72 uvp = *SP; 72 ivp = *--SP; } 110 iv = SvIVX(ivp); 110 if (iv < 0) { /* As uv is a UV, it's >0, so it cannot be == */ 16 SETs(&PL_sv_no); 16 RETURN; } /* we know iv is >= 0 */ 94 SETs(boolSV((UV)iv == SvUVX(uvp))); 94 RETURN; } } } #endif { 666413 dPOPnv; 666413 SETs(boolSV(TOPn == value)); 666413 RETURN; } } PP(pp_preinc) 23715869 { 23715869 dSP; 23715869 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) ###### DIE(aTHX_ PL_no_modify); 23715869 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { 23302719 SvIV_set(TOPs, SvIVX(TOPs) + 1); 23302719 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ 413150 sv_inc(TOPs); 23715864 SvSETMAGIC(TOPs); 23715864 return NORMAL; } PP(pp_or) 10738585 { 10738585 dSP; 10738585 if (SvTRUE(TOPs)) 5895466 RETURN; else { 4843119 --SP; 4843119 RETURNOP(cLOGOP->op_other); } } PP(pp_dor) 22 { /* Most of this is lifted straight from pp_defined */ 22 dSP; 22 register SV* const sv = TOPs; 22 if (!sv || !SvANY(sv)) { 6 --SP; 6 RETURNOP(cLOGOP->op_other); } 16 switch (SvTYPE(sv)) { case SVt_PVAV: ###### if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) ###### RETURN; ###### break; case SVt_PVHV: ###### if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) ###### RETURN; ###### break; case SVt_PVCV: ###### if (CvROOT(sv) || CvXSUB(sv)) ###### RETURN; 16 break; default: 16 if (SvGMAGICAL(sv)) ###### mg_get(sv); 16 if (SvOK(sv)) 13 RETURN; } 3 --SP; 3 RETURNOP(cLOGOP->op_other); } PP(pp_add) 8326176 { 8326176 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN); 8324206 useleft = USE_LEFT(TOPm1s); #ifdef PERL_PRESERVE_IVUV /* We must see if we can perform the addition with integers if possible, as the integer code detects overflow while the NV code doesn't. If either argument hasn't had a numeric conversion yet attempt to get the IV. It's important to do this now, rather than just assuming that it's not IOK as a PV of "9223372036854775806" may not take well to NV addition, and an SV which is NOK, NV=6.0 ought to be coerced to integer in case the second argument is IV=9223372036854775806 We can (now) rely on sv_2iv to do the right thing, only setting the public IOK flag if the value in the NV (or PV) slot is truly integer. A side effect is that this also aggressively prefers integer maths over fp maths for integer values. How to detect overflow? C 99 section 6.2.6.1 says The range of nonnegative values of a signed integer type is a subrange of the corresponding unsigned integer type, and the representation of the same value in each type is the same. A computation involving unsigned operands can never overflow, because a result that cannot be represented by the resulting unsigned integer type is reduced modulo the number that is one greater than the largest value that can be represented by the resulting type. (the 9th paragraph) which I read as "unsigned ints wrap." signed integer overflow seems to be classed as "exception condition" If an exceptional condition occurs during the evaluation of an expression (that is, if the result is not mathematically defined or not in the range of representable values for its type), the behavior is undefined. (6.5, the 5th paragraph) I had assumed that on 2s complement machines signed arithmetic would wrap, hence coded pp_add and pp_subtract on the assumption that everything perl builds on would be happy. After much wailing and gnashing of teeth it would seem that irix64 knows its ANSI spec well, knows that it doesn't need to, and doesn't. Bah. Anyway, the all- unsigned code below is actually shorter than the old code. :-) */ 8324206 SvIV_please(TOPs); 8324206 if (SvIOK(TOPs)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ 8298019 register UV auv = 0; 8298019 bool auvok = FALSE; 8298019 bool a_valid = 0; 8298019 if (!useleft) { 42180 auv = 0; 42180 a_valid = auvok = 1; /* left operand is undef, treat as zero. + 0 is identity, Could SETi or SETu right now, but space optimise by not adding lots of code to speed up what is probably a rarish case. */ } else { /* Left operand is defined, so is it IV? */ 8255839 SvIV_please(TOPm1s); 8255839 if (SvIOK(TOPm1s)) { 7657234 if ((auvok = SvUOK(TOPm1s))) 19251 auv = SvUVX(TOPm1s); else { 7637983 register const IV aiv = SvIVX(TOPm1s); 7637983 if (aiv >= 0) { 7506834 auv = aiv; 7506834 auvok = 1; /* Now acting as a sign flag. */ } else { /* 2s complement assumption for IV_MIN */ 131149 auv = (UV)-aiv; } } 7657234 a_valid = 1; } } 8298019 if (a_valid) { 7699414 bool result_good = 0; 7699414 UV result; 7699414 register UV buv; 7699414 bool buvok = SvUOK(TOPs); 7699414 if (buvok) 8503 buv = SvUVX(TOPs); else { 7690911 register const IV biv = SvIVX(TOPs); 7690911 if (biv >= 0) { 7676448 buv = biv; 7676448 buvok = 1; } else 14463 buv = (UV)-biv; } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. if a, b represents positive, A, B negative, a maps to -A etc a + b => (a + b) A + b => -(a - b) a + B => (a - b) A + B => -(a + b) all UV maths. negate result if A negative. add if signs same, subtract if signs differ. */ 7699414 if (auvok ^ buvok) { /* Signs differ. */ 143732 if (auv >= buv) { 42239 result = auv - buv; /* Must get smaller */ 42239 if (result <= auv) 42239 result_good = 1; } else { 101493 result = buv - auv; 101493 if (result <= buv) { /* result really should be -(auv-buv). as its negation of true value, need to swap our result flag */ 101493 auvok = !auvok; 101493 result_good = 1; } } } else { /* Signs same */ 7555682 result = auv + buv; 7555682 if (result >= auv) 7548774 result_good = 1; } 7699414 if (result_good) { 7692506 SP--; 7692506 if (auvok) 7651247 SETu( result ); else { /* Negate result */ 41259 if (result <= (UV)IV_MIN) 41241 SETi( -(IV)result ); else { /* result valid, but out of range for IV. */ 18 SETn( -(NV)result ); } } 7692506 RETURN; } /* Overflow, drop through to NVs. */ } } #endif { 631700 dPOPnv; 631700 if (!useleft) { /* left operand is undef, treat as zero. + 0.0 is identity. */ 10 SETn(value); 10 RETURN; } 631690 SETn( value + TOPn ); 631690 RETURN; } } PP(pp_aelemfast) 2212391 { 2212391 dSP; 2212391 AV *av = PL_op->op_flags & OPf_SPECIAL ? 2212391 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv); 2212391 const U32 lval = PL_op->op_flags & OPf_MOD; 2212391 SV** svp = av_fetch(av, PL_op->op_private, lval); 2212391 SV *sv = (svp ? *svp : &PL_sv_undef); 2212391 EXTEND(SP, 1); 2212391 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ 8397 sv = sv_mortalcopy(sv); 2212391 PUSHs(sv); 2212391 RETURN; } PP(pp_join) 790350 { 790350 dSP; dMARK; dTARGET; 790350 MARK++; 790350 do_join(TARG, *MARK, MARK, SP); 790350 SP = MARK; 790350 SETs(TARG); 790350 RETURN; } PP(pp_pushre) 453249 { 453249 dSP; #ifdef DEBUGGING /* * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs * will be enough to hold an OP*. */ 453249 SV* sv = sv_newmortal(); 453249 sv_upgrade(sv, SVt_PVLV); 453249 LvTYPE(sv) = '/'; 453249 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*); 453249 XPUSHs(sv); #else XPUSHs((SV*)PL_op); #endif 453249 RETURN; } /* Oversized hot code. */ PP(pp_print) 723835 { 723835 dVAR; dSP; dMARK; dORIGMARK; 723835 GV *gv; 723835 IO *io; 723835 register PerlIO *fp; 723835 MAGIC *mg; 723835 if (PL_op->op_flags & OPf_STACKED) 554561 gv = (GV*)*++MARK; else 169274 gv = PL_defoutgv; 723835 if (gv && (io = GvIO(gv)) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { had_magic: 39861 if (MARK == ORIGMARK) { /* If using default handle then we need to make space to * pass object as 1st arg, so move other args up ... */ 38357 MEXTEND(SP, 1); 38357 ++MARK; 38357 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); 38357 ++SP; } 39861 PUSHMARK(MARK - 1); 39861 *MARK = SvTIED_obj((SV*)io, mg); 39861 PUTBACK; 39861 ENTER; 39861 call_method("PRINT", G_SCALAR); 39860 LEAVE; 39860 SPAGAIN; 39860 MARK = ORIGMARK + 1; 39860 *MARK = *SP; 39860 SP = MARK; 39860 RETURN; } 683974 if (!(io = GvIO(gv))) { 6 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv))) && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) ###### goto had_magic; 6 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 2 report_evil_fh(gv, io, PL_op->op_type); 6 SETERRNO(EBADF,RMS_IFI); 6 goto just_say_no; } 683968 else if (!(fp = IoOFP(io))) { 28 if (ckWARN2(WARN_CLOSED, WARN_IO)) { 18 if (IoIFP(io)) 4 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY); 14 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 14 report_evil_fh(gv, io, PL_op->op_type); } 28 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); 28 goto just_say_no; } else { 683940 MARK++; 683940 if (PL_ofs_sv && SvOK(PL_ofs_sv)) { 36513 while (MARK <= SP) { 18263 if (!do_print(*MARK, fp)) ###### break; 18263 MARK++; 18263 if (MARK <= SP) { 14 if (!do_print(PL_ofs_sv, fp)) { /* $, */ ###### MARK--; ###### break; } } } } else { 1589765 while (MARK <= SP) { 924077 if (!do_print(*MARK, fp)) ###### break; 924075 MARK++; } } 683938 if (MARK <= SP) ###### goto just_say_no; else { 683938 if (PL_ors_sv && SvOK(PL_ors_sv)) 16623 if (!do_print(PL_ors_sv, fp)) /* $\ */ ###### goto just_say_no; 683938 if (IoFLAGS(io) & IOf_FLUSH) 90747 if (PerlIO_flush(fp) == EOF) ###### goto just_say_no; } } 683938 SP = ORIGMARK; 683938 PUSHs(&PL_sv_yes); 683938 RETURN; just_say_no: 34 SP = ORIGMARK; 34 PUSHs(&PL_sv_undef); 34 RETURN; } PP(pp_rv2av) 30370765 { 30370765 dSP; dTOPss; 30370765 AV *av; 30370765 if (SvROK(sv)) { wasref: 9622880 tryAMAGICunDEREF(to_av); 9622880 av = (AV*)SvRV(sv); 9622880 if (SvTYPE(av) != SVt_PVAV) 1 DIE(aTHX_ "Not an ARRAY reference"); 9622879 if (PL_op->op_flags & OPf_REF) { 8062967 SETs((SV*)av); 8062967 RETURN; } 1559912 else if (LVRET) { ###### if (GIMME == G_SCALAR) ###### Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); ###### SETs((SV*)av); ###### RETURN; } 1559912 else if (PL_op->op_flags & OPf_MOD && PL_op->op_private & OPpLVAL_INTRO) 7 Perl_croak(aTHX_ PL_no_localize_ref); } else { 20747885 if (SvTYPE(sv) == SVt_PVAV) { 33972 av = (AV*)sv; 33972 if (PL_op->op_flags & OPf_REF) { 8 SETs((SV*)av); 8 RETURN; } 33964 else if (LVRET) { ###### if (GIMME == G_SCALAR) ###### Perl_croak(aTHX_ "Can't return array to lvalue" " scalar context"); ###### SETs((SV*)av); ###### RETURN; } } else { 20713913 GV *gv; 20713913 if (SvTYPE(sv) != SVt_PVGV) { 79253 if (SvGMAGICAL(sv)) { 54 mg_get(sv); 54 if (SvROK(sv)) ###### goto wasref; } 79253 if (!SvOK(sv)) { 199 if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) 1 DIE(aTHX_ PL_no_usym, "an ARRAY"); 198 if (ckWARN(WARN_UNINITIALIZED)) 3 report_uninit(sv); 198 if (GIMME == G_ARRAY) { 98 (void)POPs; 98 RETURN; } 100 RETSETUNDEF; } 79054 if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { 217 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV); 217 if (!gv && (!is_gv_magical_sv(sv,0) || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV)))) { 142 RETSETUNDEF; } } else { 78837 if (PL_op->op_private & HINT_STRICT_REFS) ###### DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY"); 78837 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV); } } else { 20634660 gv = (GV*)sv; } 20713572 av = GvAVn(gv); 20713572 if (PL_op->op_private & OPpLVAL_INTRO) 3010 av = save_ary(gv); 20713572 if (PL_op->op_flags & OPf_REF) { 17387175 SETs((SV*)av); 17387175 RETURN; } 3326397 else if (LVRET) { 4 if (GIMME == G_SCALAR) ###### Perl_croak(aTHX_ "Can't return array to lvalue" " scalar context"); 4 SETs((SV*)av); 4 RETURN; } } } 4920262 if (GIMME == G_ARRAY) { 3884164 const I32 maxarg = AvFILL(av) + 1; 3884164 (void)POPs; /* XXXX May be optimized away? */ 3884164 EXTEND(SP, maxarg); 3884164 if (SvRMAGICAL(av)) { 5470 U32 i; 57879 for (i=0; i < (U32)maxarg; i++) { 52409 SV **svp = av_fetch(av, i, FALSE); /* See note in pp_helem, and bug id #27839 */ 52409 SP[i+1] = svp ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp : &PL_sv_undef; } } else { 3878694 Copy(AvARRAY(av), SP+1, maxarg, SV*); } 3884164 SP += maxarg; } 1036098 else if (GIMME_V == G_SCALAR) { 1028325 dTARGET; 1028325 const I32 maxarg = AvFILL(av) + 1; 1028325 SETi(maxarg); } 4920262 RETURN; } PP(pp_rv2hv) 13690334 { 13690334 dSP; dTOPss; 13690334 HV *hv; 13690334 const I32 gimme = GIMME_V; 13690334 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context"; 13690334 if (SvROK(sv)) { wasref: 12772972 tryAMAGICunDEREF(to_hv); 12772971 hv = (HV*)SvRV(sv); 12772971 if (SvTYPE(hv) != SVt_PVHV) 43 DIE(aTHX_ "Not a HASH reference"); 12772928 if (PL_op->op_flags & OPf_REF) { 12746623 SETs((SV*)hv); 12746623 RETURN; } 26305 else if (LVRET) { ###### if (gimme != G_ARRAY) ###### Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); ###### SETs((SV*)hv); ###### RETURN; } 26305 else if (PL_op->op_flags & OPf_MOD && PL_op->op_private & OPpLVAL_INTRO) 7 Perl_croak(aTHX_ PL_no_localize_ref); } else { 917362 if (SvTYPE(sv) == SVt_PVHV) { 38 hv = (HV*)sv; 38 if (PL_op->op_flags & OPf_REF) { 38 SETs((SV*)hv); 38 RETURN; } ###### else if (LVRET) { ###### if (gimme != G_ARRAY) ###### Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); ###### SETs((SV*)hv); ###### RETURN; } } else { 917324 GV *gv; 917324 if (SvTYPE(sv) != SVt_PVGV) { 5776 if (SvGMAGICAL(sv)) { ###### mg_get(sv); ###### if (SvROK(sv)) ###### goto wasref; } 5776 if (!SvOK(sv)) { 5 if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) 1 DIE(aTHX_ PL_no_usym, "a HASH"); 4 if (ckWARN(WARN_UNINITIALIZED)) 3 report_uninit(sv); 4 if (gimme == G_ARRAY) { 2 SP--; 2 RETURN; } 2 RETSETUNDEF; } 5771 if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { 58 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV); 58 if (!gv && (!is_gv_magical_sv(sv,0) || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV)))) { 30 RETSETUNDEF; } } else { 5713 if (PL_op->op_private & HINT_STRICT_REFS) 5 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH"); 5708 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV); } } else { 911548 gv = (GV*)sv; } 917284 hv = GvHVn(gv); 917284 if (PL_op->op_private & OPpLVAL_INTRO) 2903 hv = save_hash(gv); 917284 if (PL_op->op_flags & OPf_REF) { 908357 SETs((SV*)hv); 908357 RETURN; } 8927 else if (LVRET) { 1 if (gimme != G_ARRAY) ###### Perl_croak(aTHX_ return_hash_to_lvalue_scalar ); 1 SETs((SV*)hv); 1 RETURN; } } } 35224 if (gimme == G_ARRAY) { /* array wanted */ 24020 *PL_stack_sp = (SV*)hv; 24020 return do_kv(); } 11204 else if (gimme == G_SCALAR) { 5989 dTARGET; 5989 TARG = Perl_hv_scalar(aTHX_ hv); 5989 SETTARG; } 11204 RETURN; } STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) 10 { 10 if (*relem) { 10 SV *tmpstr; 10 const HE *didstore; 10 if (ckWARN(WARN_MISC)) { 8 const char *err; 8 if (relem == firstrelem && SvROK(*relem) && (SvTYPE(SvRV(*relem)) == SVt_PVAV || SvTYPE(SvRV(*relem)) == SVt_PVHV)) { 3 err = "Reference found where even-sized list expected"; } else 5 err = "Odd number of elements in hash assignment"; 8 Perl_warner(aTHX_ packWARN(WARN_MISC), err); } 10 tmpstr = NEWSV(29,0); 10 didstore = hv_store_ent(hash,*relem,tmpstr,0); 10 if (SvMAGICAL(hash)) { 1 if (SvSMAGICAL(tmpstr)) ###### mg_set(tmpstr); 1 if (!didstore) ###### sv_2mortal(tmpstr); } 10 TAINT_NOT; } } PP(pp_aassign) 5751394 { 5751394 dVAR; dSP; 5751394 SV **lastlelem = PL_stack_sp; 5751394 SV **lastrelem = PL_stack_base + POPMARK; 5751394 SV **firstrelem = PL_stack_base + POPMARK + 1; 5751394 SV **firstlelem = lastrelem + 1; 5751394 register SV **relem; 5751394 register SV **lelem; 5751394 register SV *sv; 5751394 register AV *ary; 5751394 I32 gimme; 5751394 HV *hash; 5751394 I32 i; 5751394 int magic; 5751394 int duplicates = 0; 5751394 SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */ 5751394 PL_delaymagic = DM_DELAY; /* catch simultaneous items */ 5751394 gimme = GIMME_V; /* If there's a common identifier on both sides we have to take * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ 5751394 if (PL_op->op_private & (OPpASSIGN_COMMON)) { 314426 EXTEND_MORTAL(lastrelem - firstrelem + 1); 1111757 for (relem = firstrelem; relem <= lastrelem; relem++) { 797331 if ((sv = *relem)) { 797331 TAINT_NOT; /* Each item is independent */ 797331 *relem = sv_mortalcopy(sv); } } } 5751394 relem = firstrelem; 5751394 lelem = firstlelem; 5751394 ary = Null(AV*); 5751394 hash = Null(HV*); 23251551 while (lelem <= lastlelem) { 17500162 TAINT_NOT; /* Each item stands on its own, taintwise. */ 17500162 sv = *lelem++; 17500162 switch (SvTYPE(sv)) { case SVt_PVAV: 1201775 ary = (AV*)sv; 1201775 magic = SvMAGICAL(ary) != 0; 1201775 av_clear(ary); 1201773 av_extend(ary, lastrelem - relem); 1201773 i = 0; 4317238 while (relem <= lastrelem) { /* gobble up all the rest */ 3115465 SV **didstore; 3115465 assert(*relem); 3115465 sv = newSVsv(*relem); 3115465 *(relem++) = sv; 3115465 didstore = av_store(ary,i++,sv); 3115465 if (magic) { 143777 if (SvSMAGICAL(sv)) 14927 mg_set(sv); 143777 if (!didstore) 519 sv_2mortal(sv); } 3115465 TAINT_NOT; } 103811 break; case SVt_PVHV: { /* normal hash */ 103811 SV *tmpstr; 103811 hash = (HV*)sv; 103811 magic = SvMAGICAL(hash) != 0; 103811 hv_clear(hash); 103809 firsthashrelem = relem; 818818 while (relem < lastrelem) { /* gobble up all the rest */ 715010 HE *didstore; 715010 if (*relem) 715010 sv = *(relem++); else ###### sv = &PL_sv_no, relem++; 715010 tmpstr = NEWSV(29,0); 715010 if (*relem) 715010 sv_setsv(tmpstr,*relem); /* value */ 715010 *(relem++) = tmpstr; 715010 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0)) /* key overwrites an existing entry */ 15 duplicates += 2; 715010 didstore = hv_store_ent(hash,sv,tmpstr,0); 715009 if (magic) { 842 if (SvSMAGICAL(tmpstr)) 842 mg_set(tmpstr); 842 if (!didstore) 4 sv_2mortal(tmpstr); } 715009 TAINT_NOT; } 103808 if (relem == lastrelem) { 10 do_oddball(hash, relem, firstrelem); 10 relem++; } } 10 break; default: 16194576 if (SvIMMORTAL(sv)) { 30407 if (relem <= lastrelem) 2425 relem++; 2425 break; } 16164169 if (relem <= lastrelem) { 15435149 sv_setsv(sv, *relem); 15435149 *(relem++) = sv; } else 729020 sv_setsv(sv, &PL_sv_undef); 16164169 SvSETMAGIC(sv); 623537 break; } } 5751389 if (PL_delaymagic & ~DM_DELAY) { ###### if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID ###### (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1, (Uid_t)-1); #else # ifdef HAS_SETREUID (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1, (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1); # else # ifdef HAS_SETRUID if ((PL_delaymagic & DM_UID) == DM_RUID) { (void)setruid(PL_uid); PL_delaymagic &= ~DM_RUID; } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID if ((PL_delaymagic & DM_UID) == DM_EUID) { (void)seteuid(PL_euid); PL_delaymagic &= ~DM_EUID; } # endif /* HAS_SETEUID */ if (PL_delaymagic & DM_UID) { if (PL_uid != PL_euid) DIE(aTHX_ "No setreuid available"); (void)PerlProc_setuid(PL_uid); } # endif /* HAS_SETREUID */ #endif /* HAS_SETRESUID */ ###### PL_uid = PerlProc_getuid(); ###### PL_euid = PerlProc_geteuid(); } ###### if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID ###### (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1, (Gid_t)-1); #else # ifdef HAS_SETREGID (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1, (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1); # else # ifdef HAS_SETRGID if ((PL_delaymagic & DM_GID) == DM_RGID) { (void)setrgid(PL_gid); PL_delaymagic &= ~DM_RGID; } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID if ((PL_delaymagic & DM_GID) == DM_EGID) { (void)setegid(PL_egid); PL_delaymagic &= ~DM_EGID; } # endif /* HAS_SETEGID */ if (PL_delaymagic & DM_GID) { if (PL_gid != PL_egid) DIE(aTHX_ "No setregid available"); (void)PerlProc_setgid(PL_gid); } # endif /* HAS_SETREGID */ #endif /* HAS_SETRESGID */ ###### PL_gid = PerlProc_getgid(); ###### PL_egid = PerlProc_getegid(); } ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); } 5751389 PL_delaymagic = 0; 5751389 if (gimme == G_VOID) 5164619 SP = firstrelem - 1; 586770 else if (gimme == G_SCALAR) { 583907 dTARGET; 583907 SP = firstrelem; 583907 SETi(lastrelem - firstrelem + 1 - duplicates); } else { 2863 if (ary) 1303 SP = lastrelem; 1560 else if (hash) { 1487 if (duplicates) { /* Removes from the stack the entries which ended up as * duplicated keys in the hash (fix for [perl #24380]) */ Move(firsthashrelem + duplicates, 3 firsthashrelem, duplicates, SV**); 3 lastrelem -= duplicates; } 1487 SP = lastrelem; } else 73 SP = firstrelem + (lastlelem - firstlelem); 2863 lelem = firstlelem + (relem - firstrelem); 2865 while (relem <= SP) 2 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef; } 5751389 RETURN; } PP(pp_qr) 31484 { 31484 dSP; 31484 register PMOP *pm = cPMOP; 31484 SV *rv = sv_newmortal(); 31484 SV *sv = newSVrv(rv, "Regexp"); 31484 if (pm->op_pmdynflags & PMdf_TAINTED) 3 SvTAINTED_on(rv); 31484 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); 31484 RETURNX(PUSHs(rv)); } PP(pp_match) 11390360 { 11390360 dSP; dTARG; 11390360 register PMOP *pm = cPMOP; 11390360 PMOP *dynpm = pm; 11390360 const register char *t; 11390360 const register char *s; 11390360 const char *strend; 11390360 I32 global; 11390360 I32 r_flags = REXEC_CHECKED; 11390360 const char *truebase; /* Start of string */ 11390360 register REGEXP *rx = PM_GETRE(pm); 11390360 bool rxtainted; 11390360 const I32 gimme = GIMME; 11390360 STRLEN len; 11390360 I32 minmatch = 0; 11390360 const I32 oldsave = PL_savestack_ix; 11390360 I32 update_minmatch = 1; 11390360 I32 had_zerolen = 0; 11390360 if (PL_op->op_flags & OPf_STACKED) 7302732 TARG = POPs; 4087628 else if (PL_op->op_private & OPpTARGET_MY) 14 GETTARGET; else { 4087614 TARG = DEFSV; 4087614 EXTEND(SP,1); } 11390360 PUTBACK; /* EVAL blocks need stack_sp. */ 11390360 s = SvPV_const(TARG, len); 11390359 strend = s + len; 11390359 if (!s) ###### DIE(aTHX_ "panic: pp_match"); 11390359 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); 11390359 TAINT_NOT; 11390359 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); /* PMdf_USED is set after a ?? matches once */ 11390359 if (pm->op_pmdynflags & PMdf_USED) { failure: 598835 if (gimme == G_ARRAY) 43689 RETURN; 555146 RETPUSHNO; } /* empty pattern special-cased to use last successful pattern if possible */ 11390356 if (!rx->prelen && PL_curpm) { 30 pm = PL_curpm; 30 rx = PM_GETRE(pm); } 11390356 if (rx->minlen > (I32)len) 598832 goto failure; 10791524 truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ 10791524 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { 2060895 rx->startp[0] = -1; 2060895 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { 1457411 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); 1457411 if (mg && mg->mg_len >= 0) { 1449752 if (!(rx->reganch & ROPT_GPOS_SEEN)) 475207 rx->endp[0] = rx->startp[0] = mg->mg_len; 974545 else if (rx->reganch & ROPT_ANCH_GPOS) { 974524 r_flags |= REXEC_IGNOREPOS; 974524 rx->endp[0] = rx->startp[0] = mg->mg_len; } 1449752 minmatch = (mg->mg_flags & MGf_MINMATCH); 1449752 update_minmatch = 0; } } } 10791524 if ((!global && rx->nparens) || SvTEMP(TARG) || PL_sawampersand) 5655687 r_flags |= REXEC_COPY_STR; 10791524 if (SvSCREAM(TARG)) 16 r_flags |= REXEC_SCREAM; play_it_again: 10928949 if (global && rx->startp[0] != -1) { 1587156 t = s = rx->endp[0] + truebase; 1587156 if ((s + rx->minlen) > strend) 582187 goto nope; 1004969 if (update_minmatch++) 93225 minmatch = had_zerolen; } 10346762 if (rx->reganch & RE_USE_INTUIT && DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) { /* FIXME - can PL_bostr be made const char *? */ 2517896 PL_bostr = (char *)truebase; 2517896 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL); 2517896 if (!s) 1655280 goto nope; 862616 if ( (rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM))) && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */ 16115 goto yup; } 8675367 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags)) { 5419579 PL_curpm = pm; 5419579 if (dynpm->op_pmflags & PMf_ONCE) 3 dynpm->op_pmdynflags |= PMdf_USED; goto gotcha; } else 5423585 goto ret_no; /*NOTREACHED*/ gotcha: 5423585 if (rxtainted) 848237 RX_MATCH_TAINTED_on(rx); 5423585 TAINT_IF(RX_MATCH_TAINTED(rx)); 5423585 if (gimme == G_ARRAY) { 578741 const I32 nparens = rx->nparens; 578741 I32 i = (global && !nparens) ? 1 : 0; 578741 SPAGAIN; /* EVAL blocks could move the stack. */ 578741 EXTEND(SP, nparens + i); 578741 EXTEND_MORTAL(nparens + i); 1991738 for (i = !i; i <= nparens; i++) { 1412997 PUSHs(sv_newmortal()); 1412997 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { 1295624 const I32 len = rx->endp[i] - rx->startp[i]; 1295624 s = rx->startp[i] + truebase; 1295624 if (rx->endp[i] < 0 || rx->startp[i] < 0 || len < 0 || len > strend - s) ###### DIE(aTHX_ "panic: pp_match start/end pointers"); 1295624 sv_setpvn(*SP, s, len); 1295624 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) 74 SvUTF8_on(*SP); } } 578741 if (global) { 137425 if (dynpm->op_pmflags & PMf_CONTINUE) { 4 MAGIC* mg = 0; 4 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) 4 mg = mg_find(TARG, PERL_MAGIC_regex_global); 4 if (!mg) { ###### sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); ###### mg = mg_find(TARG, PERL_MAGIC_regex_global); } 4 if (rx->startp[0] != -1) { 4 mg->mg_len = rx->endp[0]; 4 if (rx->startp[0] == rx->endp[0]) ###### mg->mg_flags |= MGf_MINMATCH; else 4 mg->mg_flags &= ~MGf_MINMATCH; } } 137425 had_zerolen = (rx->startp[0] != -1 && rx->startp[0] == rx->endp[0]); 137425 PUTBACK; /* EVAL blocks may use stack */ 137425 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; 137425 goto play_it_again; } 441316 else if (!nparens) 72 XPUSHs(&PL_sv_yes); 441316 LEAVE_SCOPE(oldsave); 441316 RETURN; } else { 4844844 if (global) { 1330173 MAGIC* mg = 0; 1330173 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) 792569 mg = mg_find(TARG, PERL_MAGIC_regex_global); 1330173 if (!mg) { 537611 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); 537611 mg = mg_find(TARG, PERL_MAGIC_regex_global); } 1330173 if (rx->startp[0] != -1) { 1330173 mg->mg_len = rx->endp[0]; 1330173 if (rx->startp[0] == rx->endp[0]) 13026 mg->mg_flags |= MGf_MINMATCH; else 1317147 mg->mg_flags &= ~MGf_MINMATCH; } } 4844844 LEAVE_SCOPE(oldsave); 4844844 RETPUSHYES; } yup: /* Confirmed by INTUIT */ 16115 if (rxtainted) ###### RX_MATCH_TAINTED_on(rx); 16115 TAINT_IF(RX_MATCH_TAINTED(rx)); 16115 PL_curpm = pm; 16115 if (dynpm->op_pmflags & PMf_ONCE) ###### dynpm->op_pmdynflags |= PMdf_USED; 16115 if (RX_MATCH_COPIED(rx)) ###### Safefree(rx->subbeg); 16115 RX_MATCH_COPIED_off(rx); 16115 rx->subbeg = Nullch; 16115 if (global) { /* FIXME - should rx->subbeg be const char *? */ 4006 rx->subbeg = (char *) truebase; 4006 rx->startp[0] = s - truebase; 4006 if (RX_MATCH_UTF8(rx)) { ###### char *t = (char*)utf8_hop((U8*)s, rx->minlen); ###### rx->endp[0] = t - truebase; } else { 4006 rx->endp[0] = s - truebase + rx->minlen; } 4006 rx->sublen = strend - truebase; 4006 goto gotcha; } 12109 if (PL_sawampersand) { ###### 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)(t-truebase)); } rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG); rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase); assert (SvPOKp(rx->saved_copy)); } else #endif { ###### rx->subbeg = savepvn(t, strend - t); #ifdef PERL_OLD_COPY_ON_WRITE rx->saved_copy = Nullsv; #endif } ###### rx->sublen = strend - t; ###### RX_MATCH_COPIED_on(rx); ###### off = rx->startp[0] = s - t; ###### rx->endp[0] = off + rx->minlen; } else { /* startp/endp are used by @- @+. */ 12109 rx->startp[0] = s - truebase; 12109 rx->endp[0] = s - truebase + rx->minlen; } 12109 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */ 12109 LEAVE_SCOPE(oldsave); 12109 RETPUSHYES; nope: ret_no: 5493254 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { 650614 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { 584735 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); 584735 if (mg) 584728 mg->mg_len = -1; } } 5493254 LEAVE_SCOPE(oldsave); 5493254 if (gimme == G_ARRAY) 125261 RETURN; 5367993 RETPUSHNO; } OP * Perl_do_readline(pTHX) 859600 { 859600 dVAR; dSP; dTARGETSTACKED; 859600 register SV *sv; 859600 STRLEN tmplen = 0; 859600 STRLEN offset; 859600 PerlIO *fp; 859600 register IO * const io = GvIO(PL_last_in_gv); 859600 register const I32 type = PL_op->op_type; 859600 const I32 gimme = GIMME_V; 859600 MAGIC *mg; 859600 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { 547 PUSHMARK(SP); 547 XPUSHs(SvTIED_obj((SV*)io, mg)); 547 PUTBACK; 547 ENTER; 547 call_method("READLINE", gimme); 547 LEAVE; 547 SPAGAIN; 547 if (gimme == G_SCALAR) { 544 SV* result = POPs; 544 SvSetSV_nosteal(TARG, result); 544 PUSHTARG; } 547 RETURN; } 859053 fp = Nullfp; 859053 if (io) { 859052 fp = IoIFP(io); 859052 if (!fp) { 56 if (IoFLAGS(io) & IOf_ARGV) { 39 if (IoFLAGS(io) & IOf_START) { 39 IoLINES(io) = 0; 39 if (av_len(GvAVn(PL_last_in_gv)) < 0) { 17 IoFLAGS(io) &= ~IOf_START; 17 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp); 17 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1); 17 SvSETMAGIC(GvSV(PL_last_in_gv)); 17 fp = IoIFP(io); 17 goto have_fp; } } 22 fp = nextargv(PL_last_in_gv); 22 if (!fp) { /* Note: fp != IoIFP(io) */ 3 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } } 17 else if (type == OP_GLOB) 3 fp = Perl_start_glob(aTHX_ POPs, io); } 858996 else if (type == OP_GLOB) ###### SP--; 858996 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) { 4 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY); } } 859036 if (!fp) { 18 if (ckWARN2(WARN_GLOB, WARN_CLOSED) && (!io || !(IoFLAGS(io) & IOf_START))) { 3 if (type == OP_GLOB) ###### Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", Strerror(errno)); else 3 report_evil_fh(PL_last_in_gv, io, PL_op->op_type); } 18 if (gimme == G_SCALAR) { /* undef TARG, and push that undefined value */ 16 if (type != OP_RCATLINE) { 14 SV_CHECK_THINKFIRST_COW_DROP(TARG); 13 SvOK_off(TARG); } 15 PUSHTARG; } 17 RETURN; } have_fp: 859035 if (gimme == G_SCALAR) { 858483 sv = TARG; 858483 if (SvROK(sv)) ###### sv_unref(sv); 858483 SvUPGRADE(sv, SVt_PV); 858483 tmplen = SvLEN(sv); /* remember if already alloced */ 858483 if (!tmplen && !SvREADONLY(sv)) 1759 Sv_Grow(sv, 80); /* try short-buffering it */ 858483 offset = 0; 858483 if (type == OP_RCATLINE && SvOK(sv)) { 98 if (!SvPOK(sv)) { 1 SvPV_force_nolen(sv); } 98 offset = SvCUR(sv); } } else { 552 sv = sv_2mortal(NEWSV(57, 80)); 552 offset = 0; } /* This should not be marked tainted if the fp is marked clean */ #define MAYBE_TAINT_LINE(io, sv) \ if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ TAINT; \ SvTAINTED_on(sv); \ } /* delay EOF state for a snarfed empty file */ #define SNARF_EOF(gimme,rs,io,sv) \ (gimme != G_SCALAR || SvCUR(sv) \ || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) 1753469 for (;;) { 893870 PUTBACK; 893870 if (!sv_gets(sv, fp, offset) && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv) || PerlIO_error(fp))) { 3094 PerlIO_clearerr(fp); 3094 if (IoFLAGS(io) & IOf_ARGV) { 49 fp = nextargv(PL_last_in_gv); 49 if (fp) 16 continue; 33 (void)do_close(PL_last_in_gv, FALSE); } 3045 else if (type == OP_GLOB) { 2 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { ###### Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (child exited with status %d%s)", (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } 3078 if (gimme == G_SCALAR) { 2647 if (type != OP_RCATLINE) { 2646 SV_CHECK_THINKFIRST_COW_DROP(TARG); 2646 SvOK_off(TARG); } 2647 SPAGAIN; 2647 PUSHTARG; } 3078 MAYBE_TAINT_LINE(io, sv); 3078 RETURN; } 890776 MAYBE_TAINT_LINE(io, sv); 890776 IoLINES(io)++; 890776 IoFLAGS(io) |= IOf_NOLINE; 890776 SvSETMAGIC(sv); 890776 SPAGAIN; 890776 XPUSHs(sv); 890776 if (type == OP_GLOB) { 12 char *tmps; 12 const char *t1; 12 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { 12 tmps = SvEND(sv) - 1; 12 if (*tmps == *SvPVX_const(PL_rs)) { 9 *tmps = '\0'; 9 SvCUR_set(sv, SvCUR(sv) - 1); } } 167 for (t1 = SvPVX_const(sv); *t1; t1++) 155 if (!isALPHA(*t1) && !isDIGIT(*t1) && strchr("$&*(){}[]'\";\\|?<>~`", *t1)) ###### break; 12 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) { ###### (void)POPs; /* Unmatched wildcard? Chuck it... */ ###### continue; } 890764 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ 10032 const U8 *s = (const U8*)SvPVX_const(sv) + offset; 10032 const STRLEN len = SvCUR(sv) - offset; 10032 const U8 *f; 10032 if (ckWARN(WARN_UTF8) && !Perl_is_utf8_string_loc(aTHX_ s, len, &f)) /* Emulate :encoding(utf8) warning in the same case. */ 2 Perl_warner(aTHX_ packWARN(WARN_UTF8), "utf8 \"\\x%02X\" does not map to Unicode", f < (U8*)SvEND(sv) ? *f : 0); } 890776 if (gimme == G_ARRAY) { 34819 if (SvLEN(sv) - SvCUR(sv) > 20) { 30793 SvPV_shrink_to_cur(sv); } 34819 sv = sv_2mortal(NEWSV(58, 80)); 34819 continue; } 855957 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ const STRLEN new_len 672 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ 672 SvPV_renew(sv, new_len); } 855957 RETURN; } } PP(pp_enter) 7395509 { 7395509 dVAR; dSP; 7395509 register PERL_CONTEXT *cx; 7395509 I32 gimme = OP_GIMME(PL_op, -1); 7395509 if (gimme == -1) { 236970 if (cxstack_ix >= 0) 232707 gimme = cxstack[cxstack_ix].blk_gimme; else 4263 gimme = G_SCALAR; } 7395509 ENTER; 7395509 SAVETMPS; 7395509 PUSHBLOCK(cx, CXt_BLOCK, SP); 7395509 RETURN; } PP(pp_helem) 16205562 { 16205562 dSP; 16205562 HE* he; 16205562 SV **svp; 16205562 SV *keysv = POPs; 16205562 HV *hv = (HV*)POPs; 16205562 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 16205562 const U32 defer = PL_op->op_private & OPpLVAL_DEFER; 16205562 SV *sv; 16205562 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0; 16205562 I32 preeminent = 0; 16205562 if (SvTYPE(hv) == SVt_PVHV) { 16205562 if (PL_op->op_private & OPpLVAL_INTRO) { 21658 MAGIC *mg; 21658 HV *stash; /* does the element we're localizing already exist? */ 21658 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; } 16205562 he = hv_fetch_ent(hv, keysv, lval && !defer, hash); 16205530 svp = he ? &HeVAL(he) : 0; } else { ###### RETPUSHUNDEF; } 16205530 if (lval) { 8886398 if (!svp || *svp == &PL_sv_undef) { 2247 SV* lv; 2247 SV* key2; 2247 if (!defer) { ###### DIE(aTHX_ PL_no_helem_sv, keysv); } 2247 lv = sv_newmortal(); 2247 sv_upgrade(lv, SVt_PVLV); 2247 LvTYPE(lv) = 'y'; 2247 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0); 2247 SvREFCNT_dec(key2); /* sv_magic() increments refcount */ 2247 LvTARG(lv) = SvREFCNT_inc(hv); 2247 LvTARGLEN(lv) = 1; 2247 PUSHs(lv); 2247 RETURN; } 8884151 if (PL_op->op_private & OPpLVAL_INTRO) { 21658 if (HvNAME_get(hv) && isGV(*svp)) 1 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL)); else { 21657 if (!preeminent) { 390 STRLEN keylen; 390 const char * const key = SvPV_const(keysv, keylen); 390 SAVEDELETE(hv, savepvn(key,keylen), keylen); } else 21267 save_helem(hv, keysv, svp); } } 8862493 else if (PL_op->op_private & OPpDEREF) 2454241 vivify_ref(*svp, PL_op->op_private & OPpDEREF); } 16203283 sv = (svp ? *svp : &PL_sv_undef); /* This makes C possible. * Pushing the magical RHS on to the stack is useless, since * that magic is soon destined to be misled by the local(), * and thus the later pp_sassign() will fail to mg_get() the * old value. This should also cure problems with delayed * mg_get()s. GSAR 98-07-03 */ 16203283 if (!lval && SvGMAGICAL(sv)) 10182 sv = sv_mortalcopy(sv); 16203281 PUSHs(sv); 16203281 RETURN; } PP(pp_leave) 6451190 { 6451190 dVAR; dSP; 6451190 register PERL_CONTEXT *cx; 6451190 SV **newsp; 6451190 PMOP *newpm; 6451190 I32 gimme; 6451190 if (PL_op->op_flags & OPf_SPECIAL) { 128554 cx = &cxstack[cxstack_ix]; 128554 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ } 6451190 POPBLOCK(cx,newpm); 6451190 gimme = OP_GIMME(PL_op, -1); 6451190 if (gimme == -1) { 175350 if (cxstack_ix >= 0) 175350 gimme = cxstack[cxstack_ix].blk_gimme; else ###### gimme = G_SCALAR; } 6451190 TAINT_NOT; 6451190 if (gimme == G_VOID) 5573517 SP = newsp; 877673 else if (gimme == G_SCALAR) { 378923 register SV **mark; 378923 MARK = newsp + 1; 378923 if (MARK <= SP) { 378923 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) 14860 *MARK = TOPs; else 364063 *MARK = sv_mortalcopy(TOPs); } else { ###### MEXTEND(mark,0); ###### *MARK = &PL_sv_undef; } 378923 SP = MARK; } 498750 else if (gimme == G_ARRAY) { /* in case LEAVE wipes old return values */ 498750 register SV **mark; 1047647 for (mark = newsp + 1; mark <= SP; mark++) { 548897 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { 65362 *mark = sv_mortalcopy(*mark); 65362 TAINT_NOT; /* Each item is independent */ } } } 6451190 PL_curpm = newpm; /* Don't pop $1 et al till now */ 6451190 LEAVE; 6451190 RETURN; } PP(pp_iter) 27612691 { 27612691 dSP; 27612691 register PERL_CONTEXT *cx; 27612691 SV *sv, *oldsv; 27612691 AV* av; 27612691 SV **itersvp; 27612691 EXTEND(SP, 1); 27612691 cx = &cxstack[cxstack_ix]; 27612691 if (CxTYPE(cx) != CXt_LOOP) ###### DIE(aTHX_ "panic: pp_iter"); 27612691 itersvp = CxITERVAR(cx); 27612691 av = cx->blk_loop.iterary; 27612691 if (SvTYPE(av) != SVt_PVAV) { /* iterate ($min .. $max) */ 22470852 if (cx->blk_loop.iterlval) { /* string increment */ 106 register SV* cur = cx->blk_loop.iterlval; 106 STRLEN maxlen = 0; 106 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : ""; 106 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { 99 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ 90 sv_setsv(*itersvp, cur); } else { /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as * they used to */ 9 oldsv = *itersvp; 9 *itersvp = newSVsv(cur); 9 SvREFCNT_dec(oldsv); } 99 if (strEQ(SvPVX_const(cur), max)) 2 sv_setiv(cur, 0); /* terminate next time */ else 97 sv_inc(cur); 99 RETPUSHYES; } 7 RETPUSHNO; } /* integer increment */ 22470746 if (cx->blk_loop.iterix > cx->blk_loop.itermax) 17902 RETPUSHNO; /* don't risk potential race */ 22452844 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ 22435784 sv_setiv(*itersvp, cx->blk_loop.iterix++); } else { /* we need a fresh SV every time so that loop body sees a * completely new SV for closures/references to work as they * used to */ 17060 oldsv = *itersvp; 17060 *itersvp = newSViv(cx->blk_loop.iterix++); 17060 SvREFCNT_dec(oldsv); } 22452844 RETPUSHYES; } /* iterate array */ 5141839 if (PL_op->op_private & OPpITER_REVERSED) { /* In reverse, use itermax as the min :-) */ 14650 if (cx->blk_loop.iterix <= cx->blk_loop.itermax) 2738 RETPUSHNO; 11912 if (SvMAGICAL(av) || AvREIFY(av)) { 11642 SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE); 11642 if (svp) 11642 sv = *svp; else ###### sv = Nullsv; } else { 270 sv = AvARRAY(av)[cx->blk_loop.iterix--]; } } else { 5127189 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av))) 774782 RETPUSHNO; 4352407 if (SvMAGICAL(av) || AvREIFY(av)) { 187599 SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE); 187599 if (svp) 187588 sv = *svp; else 11 sv = Nullsv; } else { 4164808 sv = AvARRAY(av)[++cx->blk_loop.iterix]; } } 4364319 if (sv && SvREFCNT(sv) == 0) { 1 *itersvp = Nullsv; 1 Perl_croak(aTHX_ "Use of freed value in iteration"); } 4364318 if (sv) 4364307 SvTEMP_off(sv); else 11 sv = &PL_sv_undef; 4364318 if (av != PL_curstack && sv == &PL_sv_undef) { 14 SV *lv = cx->blk_loop.iterlval; 14 if (lv && SvREFCNT(lv) > 1) { 10 SvREFCNT_dec(lv); 10 lv = Nullsv; } 14 if (lv) ###### SvREFCNT_dec(LvTARG(lv)); else { 14 lv = cx->blk_loop.iterlval = NEWSV(26, 0); 14 sv_upgrade(lv, SVt_PVLV); 14 LvTYPE(lv) = 'y'; 14 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); } 14 LvTARG(lv) = SvREFCNT_inc(av); 14 LvTARGOFF(lv) = cx->blk_loop.iterix; 14 LvTARGLEN(lv) = (STRLEN)UV_MAX; 14 sv = (SV*)lv; } 4364318 oldsv = *itersvp; 4364318 *itersvp = SvREFCNT_inc(sv); 4364318 SvREFCNT_dec(oldsv); 4364318 RETPUSHYES; } PP(pp_subst) 1957258 { 1957258 dSP; dTARG; 1957258 register PMOP *pm = cPMOP; 1957258 PMOP *rpm = pm; 1957258 register SV *dstr; 1957258 register char *s; 1957258 char *strend; 1957258 register char *m; 1957258 const char *c; 1957258 register char *d; 1957258 STRLEN clen; 1957258 I32 iters = 0; 1957258 I32 maxiters; 1957258 register I32 i; 1957258 bool once; 1957258 bool rxtainted; 1957258 char *orig; 1957258 I32 r_flags; 1957258 register REGEXP *rx = PM_GETRE(pm); 1957258 STRLEN len; 1957258 int force_on_match = 0; 1957258 I32 oldsave = PL_savestack_ix; 1957258 STRLEN slen; 1957258 bool doutf8 = FALSE; #ifdef PERL_OLD_COPY_ON_WRITE bool is_cow; #endif 1957258 SV *nsv = Nullsv; /* known replacement string? */ 1957258 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; 1957258 if (PL_op->op_flags & OPf_STACKED) 1308933 TARG = POPs; 648325 else if (PL_op->op_private & OPpTARGET_MY) 5 GETTARGET; else { 648320 TARG = DEFSV; 648320 EXTEND(SP,1); } #ifdef PERL_OLD_COPY_ON_WRITE /* Awooga. Awooga. "bool" types that are actually char are dangerous, because they make integers such as 256 "false". */ is_cow = SvIsCOW(TARG) ? TRUE : FALSE; #else 1957258 if (SvIsCOW(TARG)) 4016 sv_force_normal_flags(TARG,0); #endif 1957258 if ( #ifdef PERL_OLD_COPY_ON_WRITE !is_cow && #endif (SvREADONLY(TARG) || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV) && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) 1 DIE(aTHX_ PL_no_modify); 1957257 PUTBACK; 1957257 s = SvPV_mutable(TARG, len); 1957257 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) 239 force_on_match = 1; 1957257 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) || (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); 1957257 if (PL_tainted) 1683 rxtainted |= 2; 1957257 TAINT_NOT; 1957257 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); force_it: 1957323 if (!pm || !s) ###### DIE(aTHX_ "panic: pp_subst"); 1957323 strend = s + len; 1957323 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len; 1957323 maxiters = 2 * slen + 10; /* We can match twice at each position, once with zero-length, second time with non-zero. */ 1957323 if (!rx->prelen && PL_curpm) { 23 pm = PL_curpm; 23 rx = PM_GETRE(pm); } 1957323 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) ? REXEC_COPY_STR : 0; 1957323 if (SvSCREAM(TARG)) 2 r_flags |= REXEC_SCREAM; 1957323 orig = m = s; 1957323 if (rx->reganch & RE_USE_INTUIT) { 1334719 PL_bostr = orig; 1334719 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL); 1334719 if (!s) 656145 goto nope; /* How to do it in subst? */ /* if ( (rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand && ((rx->reganch & ROPT_NOSCAN) || !((rx->reganch & RE_INTUIT_TAIL) && (r_flags & REXEC_SCREAM)))) goto yup; */ } /* only replace once? */ 1301178 once = !(rpm->op_pmflags & PMf_GLOBAL); /* known replacement string? */ 1301178 if (dstr) { /* replacement needing upgrading? */ 996879 if (DO_UTF8(TARG) && !doutf8) { 62937 nsv = sv_newmortal(); 62937 SvSetSV(nsv, dstr); 62937 if (PL_encoding) 27 sv_recode_to_utf8(nsv, PL_encoding); else 62910 sv_utf8_upgrade(nsv); 62937 c = SvPV_const(nsv, clen); 62937 doutf8 = TRUE; } else { 933942 c = SvPV_const(dstr, clen); 933942 doutf8 = DO_UTF8(dstr); } } else { 304299 c = Nullch; 304299 doutf8 = FALSE; } /* can do inplace substitution? */ 1301178 if (c #ifdef PERL_OLD_COPY_ON_WRITE && !is_cow #endif && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN) && (!doutf8 || SvUTF8(TARG))) { 974225 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { 220961 SPAGAIN; 220961 PUSHs(&PL_sv_no); 220961 LEAVE_SCOPE(oldsave); 220961 RETURN; } #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(TARG)) { assert (!force_on_match); goto have_a_cow; } #endif 753264 if (force_on_match) { 5 force_on_match = 0; 5 s = SvPV_force(TARG, len); 5 goto force_it; } 753259 d = s; 753259 PL_curpm = pm; 753259 SvSCREAM_off(TARG); /* disable possible screamer */ 753259 if (once) { 682131 rxtainted |= RX_MATCH_TAINTED(rx); 682131 m = orig + rx->startp[0]; 682131 d = orig + rx->endp[0]; 682131 s = orig; 682131 if (m - s > strend - d) { /* faster to shorten from end */ 347398 if (clen) { 2794 Copy(c, m, clen, char); 2794 m += clen; } 347398 i = strend - d; 347398 if (i > 0) { 267446 Move(d, m, i, char); 267446 m += i; } 347398 *m = '\0'; 347398 SvCUR_set(TARG, m - s); } 334733 else if ((i = m - s)) { /* faster from front */ 678 d -= clen; 678 m = d; 678 sv_chop(TARG, d-i); 678 s += i; 2672 while (i--) 1994 *--d = *--s; 678 if (clen) 34 Copy(c, m, clen, char); } 334055 else if (clen) { 1663 d -= clen; 1663 sv_chop(TARG, d); 1663 Copy(c, d, clen, char); } else { 332392 sv_chop(TARG, d); } 682131 TAINT_IF(rxtainted & 1); 682131 SPAGAIN; 682131 PUSHs(&PL_sv_yes); } else { 158639 do { 158639 if (iters++ > maxiters) ###### DIE(aTHX_ "Substitution loop"); 158639 rxtainted |= RX_MATCH_TAINTED(rx); 158639 m = rx->startp[0] + orig; 158639 if ((i = m - s)) { 129127 if (s != d) 13518 Move(s, d, i, char); 129127 d += i; } 158639 if (clen) { 130839 Copy(c, d, clen, char); 130839 d += clen; } 158639 s = rx->endp[0] + orig; 158639 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, /* don't match same null twice */ REXEC_NOT_FIRST|REXEC_IGNOREPOS)); 71128 if (s != d) { 18812 i = strend - s; 18812 SvCUR_set(TARG, d - SvPVX_const(TARG) + i); 18812 Move(s, d, i+1, char); /* include the NUL */ } 71128 TAINT_IF(rxtainted & 1); 71128 SPAGAIN; 71128 PUSHs(sv_2mortal(newSViv((I32)iters))); } 753259 (void)SvPOK_only_UTF8(TARG); 753259 TAINT_IF(rxtainted); 753259 if (SvSMAGICAL(TARG)) { 74199 PUTBACK; 74199 mg_set(TARG); 74199 SPAGAIN; } 753259 SvTAINT(TARG); 753259 if (doutf8) 32445 SvUTF8_on(TARG); 753259 LEAVE_SCOPE(oldsave); 753259 RETURN; } 326953 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { 227776 if (force_on_match) { 61 force_on_match = 0; 61 s = SvPV_force(TARG, len); 61 goto force_it; } #ifdef PERL_OLD_COPY_ON_WRITE have_a_cow: #endif 227715 rxtainted |= RX_MATCH_TAINTED(rx); 227715 dstr = newSVpvn(m, s-m); 227715 if (DO_UTF8(TARG)) 134 SvUTF8_on(dstr); 227715 PL_curpm = pm; 227715 if (!c) { 216048 register PERL_CONTEXT *cx; 216048 SPAGAIN; 216048 (void)ReREFCNT_inc(rx); 216048 PUSHSUBST(cx); 216048 RETURNOP(cPMOP->op_pmreplroot); } 11667 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; 26538 do { 26538 if (iters++ > maxiters) ###### DIE(aTHX_ "Substitution loop"); 26538 rxtainted |= RX_MATCH_TAINTED(rx); 26538 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 4651 m = s; 4651 s = orig; 4651 orig = rx->subbeg; 4651 s = orig + (m - s); 4651 strend = s + (strend - m); } 26538 m = rx->startp[0] + orig; 26538 if (doutf8 && !SvUTF8(dstr)) 14 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); else 26524 sv_catpvn(dstr, s, m-s); 26538 s = rx->endp[0] + orig; 26538 if (clen) 24384 sv_catpvn(dstr, c, clen); 26538 if (once) 2630 break; 23908 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); 11667 if (doutf8 && !DO_UTF8(TARG)) 14 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv); else 11653 sv_catpvn(dstr, s, strend - s); #ifdef PERL_OLD_COPY_ON_WRITE /* The match may make the string COW. If so, brilliant, because that's just saved us one malloc, copy and free - the regexp has donated the old buffer, and we malloc an entirely new one, rather than the regexp malloc()ing a buffer and copying our original, only for us to throw it away here during the substitution. */ if (SvIsCOW(TARG)) { sv_force_normal_flags(TARG, SV_COW_DROP_PV); } else #endif { 11667 SvPV_free(TARG); } 11667 SvPV_set(TARG, SvPVX(dstr)); 11667 SvCUR_set(TARG, SvCUR(dstr)); 11667 SvLEN_set(TARG, SvLEN(dstr)); 11667 doutf8 |= DO_UTF8(dstr); 11667 SvPV_set(dstr, (char*)0); 11667 sv_free(dstr); 11667 TAINT_IF(rxtainted & 1); 11667 SPAGAIN; 11667 PUSHs(sv_2mortal(newSViv((I32)iters))); 11667 (void)SvPOK_only(TARG); 11667 if (doutf8) 61 SvUTF8_on(TARG); 11667 TAINT_IF(rxtainted); 11667 SvSETMAGIC(TARG); 11667 SvTAINT(TARG); 11667 LEAVE_SCOPE(oldsave); 11667 RETURN; } 755322 goto ret_no; nope: ret_no: 755322 SPAGAIN; 755322 PUSHs(&PL_sv_no); 755322 LEAVE_SCOPE(oldsave); 755322 RETURN; } PP(pp_grepwhile) 951229 { 951229 dVAR; dSP; 951229 if (SvTRUEx(POPs)) 376844 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; 951229 ++*PL_markstack_ptr; 951229 LEAVE; /* exit inner scope */ /* All done yet? */ 951229 if (PL_stack_base + *PL_markstack_ptr > SP) { 46355 I32 items; 46355 I32 gimme = GIMME_V; 46355 LEAVE; /* exit outer scope */ 46355 (void)POPMARK; /* pop src */ 46355 items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; 46355 (void)POPMARK; /* pop dst */ 46355 SP = PL_stack_base + POPMARK; /* pop original mark */ 46355 if (gimme == G_SCALAR) { 7424 if (PL_op->op_private & OPpGREP_LEX) { 1 SV* sv = sv_newmortal(); 1 sv_setiv(sv, items); 1 PUSHs(sv); } else { 7423 dTARGET; 7423 XPUSHi(items); } } 38931 else if (gimme == G_ARRAY) 38055 SP += items; 46355 RETURN; } else { 904874 SV *src; 904874 ENTER; /* enter inner scope */ 904874 SAVEVPTR(PL_curpm); 904874 src = PL_stack_base[*PL_markstack_ptr]; 904874 SvTEMP_off(src); 904874 if (PL_op->op_private & OPpGREP_LEX) 3 PAD_SVl(PL_op->op_targ) = src; else 904871 DEFSV = src; 904874 RETURNOP(cLOGOP->op_other); } } PP(pp_leavesub) 10802945 { 10802945 dVAR; dSP; 10802945 SV **mark; 10802945 SV **newsp; 10802945 PMOP *newpm; 10802945 I32 gimme; 10802945 register PERL_CONTEXT *cx; 10802945 SV *sv; 10802945 POPBLOCK(cx,newpm); 10802945 cxstack_ix++; /* temporarily protect top context */ 10802945 TAINT_NOT; 10802945 if (gimme == G_SCALAR) { 7640785 MARK = newsp + 1; 7640785 if (MARK <= SP) { 7629544 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { 5364819 if (SvTEMP(TOPs)) { 606 *MARK = SvREFCNT_inc(TOPs); 606 FREETMPS; 606 sv_2mortal(*MARK); } else { 5364213 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ 5364213 FREETMPS; 5364213 *MARK = sv_mortalcopy(sv); 5364213 SvREFCNT_dec(sv); } } else 2264725 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); } else { 11241 MEXTEND(MARK, 0); 11241 *MARK = &PL_sv_undef; } 7640785 SP = MARK; } 3162160 else if (gimme == G_ARRAY) { 2052628 for (MARK = newsp + 1; MARK <= SP; MARK++) { 1119906 if (!SvTEMP(*MARK)) { 947947 *MARK = sv_mortalcopy(*MARK); 947947 TAINT_NOT; /* Each item is independent */ } } } 10802945 PUTBACK; 10802945 LEAVE; 10802945 cxstack_ix--; 10802945 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ 10802945 PL_curpm = newpm; /* ... and pop $1 et al */ 10802945 LEAVESUB(sv); 10802945 return cx->blk_sub.retop; } /* This duplicates the above code because the above code must not * get any slower by more conditions */ PP(pp_leavesublv) 91 { 91 dVAR; dSP; 91 SV **mark; 91 SV **newsp; 91 PMOP *newpm; 91 I32 gimme; 91 register PERL_CONTEXT *cx; 91 SV *sv; 91 POPBLOCK(cx,newpm); 91 cxstack_ix++; /* temporarily protect top context */ 91 TAINT_NOT; 91 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) { /* We are an argument to a function or grep(). * This kind of lvalueness was legal before lvalue * subroutines too, so be backward compatible: * cannot report errors. */ /* Scalar context *is* possible, on the LHS of -> only, * as in f()->meth(). But this is not an lvalue. */ 28 if (gimme == G_SCALAR) 1 goto temporise; 27 if (gimme == G_ARRAY) { 27 if (!CvLVALUE(cx->blk_sub.cv)) ###### goto temporise_array; 27 EXTEND_MORTAL(SP - newsp); 54 for (mark = newsp + 1; mark <= SP; mark++) { 27 if (SvTEMP(*mark)) /* empty */ ; 27 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY)) 2 *mark = sv_mortalcopy(*mark); else { /* Can be a localized value subject to deletion. */ 25 PL_tmps_stack[++PL_tmps_ix] = *mark; 25 (void)SvREFCNT_inc(*mark); } } } } 63 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */ /* Here we go for robustness, not for speed, so we change all * the refcounts so the caller gets a live guy. Cannot set * TEMP, so sv_2mortal is out of question. */ 51 if (!CvLVALUE(cx->blk_sub.cv)) { ###### LEAVE; ###### cxstack_ix--; ###### POPSUB(cx,sv); ###### PL_curpm = newpm; ###### LEAVESUB(sv); ###### DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } 51 if (gimme == G_SCALAR) { 33 MARK = newsp + 1; 33 EXTEND_MORTAL(1); 33 if (MARK == SP) { 33 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { 2 LEAVE; 2 cxstack_ix--; 2 POPSUB(cx,sv); 2 PL_curpm = newpm; 2 LEAVESUB(sv); 2 DIE(aTHX_ "Can't return %s from lvalue subroutine", SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" : "a readonly value" : "a temporary"); } else { /* Can be a localized value * subject to deletion. */ 31 PL_tmps_stack[++PL_tmps_ix] = *mark; 31 (void)SvREFCNT_inc(*mark); } } else { /* Should not happen? */ ###### LEAVE; ###### cxstack_ix--; ###### POPSUB(cx,sv); ###### PL_curpm = newpm; ###### LEAVESUB(sv); ###### DIE(aTHX_ "%s returned from lvalue subroutine in scalar context", (MARK > SP ? "Empty array" : "Array")); } 31 SP = MARK; } 18 else if (gimme == G_ARRAY) { 17 EXTEND_MORTAL(SP - newsp); 34 for (mark = newsp + 1; mark <= SP; mark++) { 19 if (*mark != &PL_sv_undef && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ 2 PUTBACK; 2 LEAVE; 2 cxstack_ix--; 2 POPSUB(cx,sv); 2 PL_curpm = newpm; 2 LEAVESUB(sv); 2 DIE(aTHX_ "Can't return a %s from lvalue subroutine", SvREADONLY(TOPs) ? "readonly value" : "temporary"); } else { /* Can be a localized value subject to deletion. */ 17 PL_tmps_stack[++PL_tmps_ix] = *mark; 17 (void)SvREFCNT_inc(*mark); } } } } else { 12 if (gimme == G_SCALAR) { temporise: 2 MARK = newsp + 1; 2 if (MARK <= SP) { 2 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { ###### if (SvTEMP(TOPs)) { ###### *MARK = SvREFCNT_inc(TOPs); ###### FREETMPS; ###### sv_2mortal(*MARK); } else { ###### sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ ###### FREETMPS; ###### *MARK = sv_mortalcopy(sv); ###### SvREFCNT_dec(sv); } } else 2 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); } else { ###### MEXTEND(MARK, 0); ###### *MARK = &PL_sv_undef; } 2 SP = MARK; } 11 else if (gimme == G_ARRAY) { temporise_array: 8 for (MARK = newsp + 1; MARK <= SP; MARK++) { 4 if (!SvTEMP(*MARK)) { 4 *MARK = sv_mortalcopy(*MARK); 4 TAINT_NOT; /* Each item is independent */ } } } } 87 PUTBACK; 87 LEAVE; 87 cxstack_ix--; 87 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */ 87 PL_curpm = newpm; /* ... and pop $1 et al */ 87 LEAVESUB(sv); 87 return cx->blk_sub.retop; } STATIC CV * S_get_db_sub(pTHX_ SV **svp, CV *cv) 80067 { 80067 SV *dbsv = GvSVn(PL_DBsub); 80067 save_item(dbsv); 80067 if (!PERLDB_SUB_NN) { 1 GV *gv = CvGV(cv); 1 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 *tmp = newRV((SV*)cv); ###### sv_setsv(dbsv, tmp); ###### SvREFCNT_dec(tmp); } else { 1 gv_efullname3(dbsv, gv, Nullch); } } else { 80066 const int type = SvTYPE(dbsv); 80066 if (type < SVt_PVIV && type != SVt_IV) 80034 sv_upgrade(dbsv, SVt_PVIV); 80066 (void)SvIOK_on(dbsv); 80066 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } 80067 if (CvXSUB(cv)) 9 PL_curcopdb = PL_curcop; 80067 cv = GvCV(PL_DBsub); 80067 return cv; } PP(pp_entersub) 21787302 { 21787302 dVAR; dSP; dPOPss; 21787302 GV *gv; 21787302 HV *stash; 21787302 register CV *cv; 21787302 register PERL_CONTEXT *cx; 21787302 I32 gimme; 21787302 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0; 21787302 if (!sv) ###### DIE(aTHX_ "Not a CODE reference"); 21787302 switch (SvTYPE(sv)) { /* This is overwhelming the most common case: */ case SVt_PVGV: 14693504 if (!(cv = GvCVu((GV*)sv))) 1091 cv = sv_2cv(sv, &stash, &gv, FALSE); 14693504 if (!cv) { 1091 ENTER; 1091 SAVETMPS; 1091 goto try_autoload; } 338303 break; default: 338303 if (!SvROK(sv)) { 9488 const char *sym; 9488 if (sv == &PL_sv_yes) { /* unfound import, ignore */ 2692 if (hasargs) 2692 SP = PL_stack_base + POPMARK; 2692 RETURN; } 6796 if (SvGMAGICAL(sv)) { ###### mg_get(sv); ###### if (SvROK(sv)) ###### goto got_rv; ###### sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch; } else { 6796 sym = SvPV_nolen_const(sv); } 6796 if (!sym) ###### DIE(aTHX_ PL_no_usym, "a subroutine"); 6796 if (PL_op->op_private & HINT_STRICT_REFS) ###### DIE(aTHX_ PL_no_symref, sym, "a subroutine"); 6796 cv = get_cv(sym, TRUE); 6796 break; } got_rv: { 328815 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ 328815 tryAMAGICunDEREF(to_cv); } 328815 cv = (CV*)SvRV(sv); 328815 if (SvTYPE(cv) == SVt_PVCV) 328815 break; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: ###### DIE(aTHX_ "Not a CODE reference"); /* This is the second most common case: */ case SVt_PVCV: 6755495 cv = (CV*)sv; 21783519 break; } 21783519 ENTER; 21783519 SAVETMPS; retry: 21839837 if (!CvROOT(cv) && !CvXSUB(cv)) { 55236 goto fooey; } 21784601 gimme = GIMME_V; 21784601 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { 80067 if (CvASSERTION(cv) && PL_DBassertion) ###### sv_setiv(PL_DBassertion, 1); 80067 cv = get_db_sub(&sv, cv); 80067 if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) ###### DIE(aTHX_ "No DB::sub routine defined"); } 21784601 if (!(CvXSUB(cv))) { /* This path taken at least 75% of the time */ 19820170 dMARK; 19820170 register I32 items = SP - MARK; 19820170 AV* padlist = CvPADLIST(cv); 19820170 PUSHBLOCK(cx, CXt_SUB, MARK); 19820170 PUSHSUB(cx); 19820170 cx->blk_sub.retop = PL_op->op_next; 19820170 CvDEPTH(cv)++; /* XXX This would be a natural place to set C so * that eval'' ops within this sub know the correct lexical space. * Owing the speed considerations, we choose instead to search for * the cv using find_runcv() when calling doeval(). */ 19820170 if (CvDEPTH(cv) >= 2) { 10943263 PERL_STACK_OVERFLOW_CHECK(); 10943263 pad_push(padlist, CvDEPTH(cv)); } 19820170 SAVECOMPPAD(); 19820170 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); 19820170 if (hasargs) { 19809089 AV* av; #if 0 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p entersub preparing @_\n", thr)); #endif 19809089 av = (AV*)PAD_SVl(0); 19809089 if (AvREAL(av)) { /* @_ is normally not REAL--this should only ever * happen when DB::sub() calls things that modify @_ */ ###### av_clear(av); ###### AvREAL_off(av); ###### AvREIFY_on(av); } 19809089 cx->blk_sub.savearray = GvAV(PL_defgv); 19809089 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); 19809089 CX_CURPAD_SAVE(cx->blk_sub); 19809089 cx->blk_sub.argarray = av; 19809089 ++MARK; 19809089 if (items > AvMAX(av) + 1) { 5235 SV **ary = AvALLOC(av); 5235 if (AvARRAY(av) != ary) { ###### AvMAX(av) += AvARRAY(av) - AvALLOC(av); ###### SvPV_set(av, (char*)ary); } 5235 if (items > AvMAX(av) + 1) { 5235 AvMAX(av) = items - 1; 5235 Renew(ary,items,SV*); 5235 AvALLOC(av) = ary; 5235 SvPV_set(av, (char*)ary); } } 19809089 Copy(MARK,AvARRAY(av),items,SV*); 19809089 AvFILLp(av) = items - 1; 46849971 while (items--) { 27040882 if (*MARK) 27040794 SvTEMP_off(*MARK); 27040882 MARK++; } } /* warning must come *after* we fully set up the context * stuff so that __WARN__ handlers can safely dounwind() * if they want to */ 19820170 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) && !(PERLDB_SUB && cv == GvCV(PL_DBsub))) 3 sub_crush_depth(cv); #if 0 DEBUG_S(PerlIO_printf(Perl_debug_log, "%p entersub returning %p\n", thr, CvSTART(cv))); #endif 19820169 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 */ { 1964431 I32 markix = TOPMARK; 1964431 PUTBACK; 1964431 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 */ 1027 AV * const av = GvAV(PL_defgv); 1027 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ 1027 if (items) { /* Mark is at the end of the stack. */ 1010 EXTEND(SP, items); 1010 Copy(AvARRAY(av), SP + 1, items, SV*); 1010 SP += items; 1010 PUTBACK ; } } /* We assume first XSUB in &DB::sub is the called one. */ 1964431 if (PL_curcopdb) { 9 SAVEVPTR(PL_curcop); 9 PL_curcop = PL_curcopdb; 9 PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ 1964431 (void)(*CvXSUB(cv))(aTHX_ cv); /* Enforce some sanity in scalar context. */ 1964203 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { 301 if (markix > PL_stack_sp - PL_stack_base) 300 *(PL_stack_base + markix) = &PL_sv_undef; else 1 *(PL_stack_base + markix) = *PL_stack_sp; 301 PL_stack_sp = PL_stack_base + markix; } } 1964203 LEAVE; 1964203 return NORMAL; } /*NOTREACHED*/ 55236 assert (0); /* Cannot get here. */ /* This is deliberately moved here as spaghetti code to keep it out of the hot path. */ { 55236 GV* autogv; 55236 SV* sub_name; fooey: /* anonymous or undef'd function leaves us no recourse */ 55236 if (CvANON(cv) || !(gv = CvGV(cv))) ###### DIE(aTHX_ "Undefined subroutine called"); /* autoloaded stub? */ 55236 if (cv != GvCV(gv)) { 53242 cv = GvCV(gv); } /* should call AUTOLOAD now? */ else { try_autoload: 3085 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) { 3076 cv = GvCV(autogv); } /* sorry */ else { 9 sub_name = sv_newmortal(); 9 gv_efullname3(sub_name, gv, Nullch); 9 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name); } } 56318 if (!cv) ###### DIE(aTHX_ "Not a CODE reference"); 21787064 goto retry; } } void Perl_sub_crush_depth(pTHX_ CV *cv) 3 { 3 if (CvANON(cv)) 1 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { 2 SV* tmpstr = sv_newmortal(); 2 gv_efullname3(tmpstr, CvGV(cv), Nullch); 2 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", tmpstr); } } PP(pp_aelem) 9117820 { 9117820 dSP; 9117820 SV** svp; 9117820 SV* const elemsv = POPs; 9117820 IV elem = SvIV(elemsv); 9117820 AV* av = (AV*)POPs; 9117820 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; 9117820 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av)); 9117820 SV *sv; 9117820 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) 2 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv); 9117820 if (elem > 0) 5235922 elem -= PL_curcop->cop_arybase; 9117820 if (SvTYPE(av) != SVt_PVAV) ###### RETPUSHUNDEF; 9117820 svp = av_fetch(av, elem, lval && !defer); 9117820 if (lval) { #ifdef PERL_MALLOC_WRAP 4369186 if (SvUOK(elemsv)) { ###### const UV uv = SvUV(elemsv); ###### elem = uv > IV_MAX ? IV_MAX : uv; } 4369186 else if (SvNOK(elemsv)) 9517 elem = (IV)SvNV(elemsv); 4369186 if (elem > 0) { static const char oom_array_extend[] = 2678394 "Out of memory during array extend"; /* Duplicated in av.c */ 2678394 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend); } #endif 4369186 if (!svp || *svp == &PL_sv_undef) { 17 SV* lv; 17 if (!defer) 2 DIE(aTHX_ PL_no_aelem, elem); 15 lv = sv_newmortal(); 15 sv_upgrade(lv, SVt_PVLV); 15 LvTYPE(lv) = 'y'; 15 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0); 15 LvTARG(lv) = SvREFCNT_inc(av); 15 LvTARGOFF(lv) = elem; 15 LvTARGLEN(lv) = 1; 15 PUSHs(lv); 15 RETURN; } 4369169 if (PL_op->op_private & OPpLVAL_INTRO) 11 save_aelem(av, elem, svp); 4369158 else if (PL_op->op_private & OPpDEREF) 886478 vivify_ref(*svp, PL_op->op_private & OPpDEREF); } 9117803 sv = (svp ? *svp : &PL_sv_undef); 9117803 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */ 412 sv = sv_mortalcopy(sv); 9117803 PUSHs(sv); 9117803 RETURN; } void Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) 20965107 { 20965107 if (SvGMAGICAL(sv)) 68 mg_get(sv); 20965107 if (!SvOK(sv)) { 35256 if (SvREADONLY(sv)) ###### Perl_croak(aTHX_ PL_no_modify); 35256 if (SvTYPE(sv) < SVt_RV) 32810 sv_upgrade(sv, SVt_RV); 2446 else if (SvTYPE(sv) >= SVt_PV) { 2 SvPV_free(sv); 2 SvLEN_set(sv, 0); 2 SvCUR_set(sv, 0); } 35256 switch (to_what) { case OPpDEREF_SV: 2 SvRV_set(sv, NEWSV(355,0)); 2 break; case OPpDEREF_AV: 6054 SvRV_set(sv, (SV*)newAV()); 6054 break; case OPpDEREF_HV: 29200 SvRV_set(sv, (SV*)newHV()); break; } 35256 SvROK_on(sv); 35256 SvSETMAGIC(sv); } } PP(pp_method) 503357 { 503357 dSP; 503357 SV* sv = TOPs; 503357 if (SvROK(sv)) { 39 SV* rsv = SvRV(sv); 39 if (SvTYPE(rsv) == SVt_PVCV) { 39 SETs(rsv); 39 RETURN; } } 503318 SETs(method_common(sv, Null(U32*))); 503307 RETURN; } PP(pp_method_named) 5805532 { 5805532 dSP; 5805532 SV* sv = cSVOP_sv; 5805532 U32 hash = SvSHARED_HASH(sv); 5805532 XPUSHs(method_common(sv, &hash)); 5805406 RETURN; } STATIC SV * S_method_common(pTHX_ SV* meth, U32* hashp) 6308850 { 6308850 SV* sv; 6308850 SV* ob; 6308850 GV* gv; 6308850 HV* stash; 6308850 STRLEN namelen; 6308850 const char* packname = 0; 6308850 SV *packsv = Nullsv; 6308850 STRLEN packlen; 6308850 const char *name = SvPV_const(meth, namelen); 6308850 sv = *(PL_stack_base + TOPMARK + 1); 6308850 if (!sv) ###### Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); 6308850 if (SvGMAGICAL(sv)) 8 mg_get(sv); 6308850 if (SvROK(sv)) 5328509 ob = (SV*)SvRV(sv); else { 980341 GV* iogv; /* this isn't a reference */ 980341 packname = Nullch; 980341 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) { 980338 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0); 980338 if (he) { 937858 stash = INT2PTR(HV*,SvIV(HeVAL(he))); 937858 goto fetch; } } 42483 if (!SvOK(sv) || !(packname) || !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { /* this isn't the name of a filehandle either */ 42476 if (!packname || ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) : !isIDFIRST(*packname) )) { 4 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name, SvOK(sv) ? "without a package or object reference" : "on an undefined value"); } /* assume it's a package name */ 42472 stash = gv_stashpvn(packname, packlen, FALSE); 42472 if (!stash) 24 packsv = sv; else { 42448 SV* ref = newSViv(PTR2IV(stash)); 42448 hv_store(PL_stashcache, packname, packlen, ref, 0); } 42448 goto fetch; } /* it _is_ a filehandle name -- replace with a reference */ 7 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } /* if we got here, ob should be a reference or a glob */ 5328516 if (!ob || !(SvOBJECT(ob) || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) && SvOBJECT(ob)))) { 90 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference", name); } 5328426 stash = SvSTASH(ob); fetch: /* NOTE: stash may be null, hope hv_fetch_ent and gv_fetchmethod can cope (it seems they can) */ /* shortcut for simple names */ 6308756 if (hashp) { 5805439 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp); 5805439 if (he) { 5781126 gv = (GV*)HeVAL(he); 5781126 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation)) 5753787 return (SV*)GvCV(gv); } } 554969 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name); 554968 if (!gv) { /* This code tries to figure out just what went wrong with gv_fetchmethod. It therefore needs to duplicate a lot of the internals of that function. We can't move it inside Perl_gv_fetchmethod_autoload(), however, since that would cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we don't want that. */ 42 const char* leaf = name; 42 const char* sep = Nullch; 42 const char* p; 261 for (p = name; *p; p++) { 219 if (*p == '\'') ###### sep = p, leaf = p + 1; 219 else if (*p == ':' && *(p + 1) == ':') 8 sep = p, leaf = p + 2; } 42 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { /* the method name is unqualified or starts with SUPER:: */ 38 bool need_strlen = 1; 38 if (sep) { ###### packname = CopSTASHPV(PL_curcop); } 38 else if (stash) { 34 HEK *packhek = HvNAME_HEK(stash); 34 if (packhek) { 34 packname = HEK_KEY(packhek); 34 packlen = HEK_LEN(packhek); 34 need_strlen = 0; } else { 38 goto croak; } } 38 if (!packname) { croak: ###### Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); } 38 else if (need_strlen) 4 packlen = strlen(packname); } else { /* the method name is qualified */ 4 packname = name; 4 packlen = sep - name; } /* we're relying on gv_fetchmethod not autovivifying the stash */ 42 if (gv_stashpvn(packname, packlen, FALSE)) { 36 Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", leaf, (int)packlen, packname); } else { 6 Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"" " (perhaps you forgot to load \"%.*s\"?)", leaf, (int)packlen, packname, (int)packlen, packname); } } 554926 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */