3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
69 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
76 /* This is sometimes called directly by pp_coreargs, pp_grepstart and
80 PUSHMARK(PL_stack_sp);
91 /* no PUTBACK, SETs doesn't inc/dec SP */
98 XPUSHs(MUTABLE_SV(cGVOP_gv));
103 /* also used for: pp_andassign() */
109 /* SP is not used to remove a variable that is saved across the
110 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
111 register or load/store vs direct mem ops macro is introduced, this
112 should be a define block between direct PL_stack_sp and dSP operations,
113 presently, using PL_stack_sp is bias towards CISC cpus */
114 SV * const sv = *PL_stack_sp;
118 if (PL_op->op_type == OP_AND)
120 return cLOGOP->op_other;
128 /* sassign keeps its args in the optree traditionally backwards.
129 So we pop them differently.
131 SV *left = POPs; SV *right = TOPs;
133 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
134 SV * const temp = left;
135 left = right; right = temp;
137 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
139 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
141 SV * const cv = SvRV(right);
142 const U32 cv_type = SvTYPE(cv);
143 const bool is_gv = isGV_with_GP(left);
144 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
150 /* Can do the optimisation if left (LVALUE) is not a typeglob,
151 right (RVALUE) is a reference to something, and we're in void
153 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
154 /* Is the target symbol table currently empty? */
155 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
156 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
157 /* Good. Create a new proxy constant subroutine in the target.
158 The gv becomes a(nother) reference to the constant. */
159 SV *const value = SvRV(cv);
161 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
162 SvPCS_IMPORTED_on(gv);
164 SvREFCNT_inc_simple_void(value);
170 /* Need to fix things up. */
172 /* Need to fix GV. */
173 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
177 /* We've been returned a constant rather than a full subroutine,
178 but they expect a subroutine reference to apply. */
180 ENTER_with_name("sassign_coderef");
181 SvREFCNT_inc_void(SvRV(cv));
182 /* newCONSTSUB takes a reference count on the passed in SV
183 from us. We set the name to NULL, otherwise we get into
184 all sorts of fun as the reference to our new sub is
185 donated to the GV that we're about to assign to.
187 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
190 LEAVE_with_name("sassign_coderef");
192 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
194 First: ops for \&{"BONK"}; return us the constant in the
196 Second: ops for *{"BONK"} cause that symbol table entry
197 (and our reference to it) to be upgraded from RV
199 Thirdly: We get here. cv is actually PVGV now, and its
200 GvCV() is actually the subroutine we're looking for
202 So change the reference so that it points to the subroutine
203 of that typeglob, as that's what they were after all along.
205 GV *const upgraded = MUTABLE_GV(cv);
206 CV *const source = GvCV(upgraded);
209 assert(CvFLAGS(source) & CVf_CONST);
211 SvREFCNT_inc_void(source);
212 SvREFCNT_dec_NN(upgraded);
213 SvRV_set(right, MUTABLE_SV(source));
219 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
220 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
223 packWARN(WARN_MISC), "Useless assignment to a temporary"
225 SvSetMagicSV(left, right);
235 RETURNOP(cLOGOP->op_other);
237 RETURNOP(cLOGOP->op_next);
243 TAINT_NOT; /* Each statement is presumed innocent */
244 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
246 if (!(PL_op->op_flags & OPf_SPECIAL)) {
247 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
248 LEAVE_SCOPE(oldsave);
255 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
260 const char *rpv = NULL;
262 bool rcopied = FALSE;
264 if (TARG == right && right != left) { /* $r = $l.$r */
265 rpv = SvPV_nomg_const(right, rlen);
266 rbyte = !DO_UTF8(right);
267 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
268 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
272 if (TARG != left) { /* not $l .= $r */
274 const char* const lpv = SvPV_nomg_const(left, llen);
275 lbyte = !DO_UTF8(left);
276 sv_setpvn(TARG, lpv, llen);
282 else { /* $l .= $r and left == TARG */
284 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
285 report_uninit(right);
289 SvPV_force_nomg_nolen(left);
291 lbyte = !DO_UTF8(left);
297 rpv = SvPV_nomg_const(right, rlen);
298 rbyte = !DO_UTF8(right);
300 if (lbyte != rbyte) {
302 sv_utf8_upgrade_nomg(TARG);
305 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
306 sv_utf8_upgrade_nomg(right);
307 rpv = SvPV_nomg_const(right, rlen);
310 sv_catpvn_nomg(TARG, rpv, rlen);
317 /* push the elements of av onto the stack.
318 * XXX Note that padav has similar code but without the mg_get().
319 * I suspect that the mg_get is no longer needed, but while padav
320 * differs, it can't share this function */
323 S_pushav(pTHX_ AV* const av)
326 const SSize_t maxarg = AvFILL(av) + 1;
328 if (UNLIKELY(SvRMAGICAL(av))) {
330 for (i=0; i < (PADOFFSET)maxarg; i++) {
331 SV ** const svp = av_fetch(av, i, FALSE);
332 /* See note in pp_helem, and bug id #27839 */
334 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
340 for (i=0; i < (PADOFFSET)maxarg; i++) {
341 SV * const sv = AvARRAY(av)[i];
342 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
350 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
355 PADOFFSET base = PL_op->op_targ;
356 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
358 if (PL_op->op_flags & OPf_SPECIAL) {
359 /* fake the RHS of my ($x,$y,..) = @_ */
361 S_pushav(aTHX_ GvAVn(PL_defgv));
365 /* note, this is only skipped for compile-time-known void cxt */
366 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
369 for (i = 0; i <count; i++)
370 *++SP = PAD_SV(base+i);
372 if (PL_op->op_private & OPpLVAL_INTRO) {
373 SV **svp = &(PAD_SVl(base));
374 const UV payload = (UV)(
375 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
376 | (count << SAVE_TIGHT_SHIFT)
377 | SAVEt_CLEARPADRANGE);
378 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
379 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
386 for (i = 0; i <count; i++)
387 SvPADSTALE_off(*svp++); /* mark lexical as active */
398 OP * const op = PL_op;
399 /* access PL_curpad once */
400 SV ** const padentry = &(PAD_SVl(op->op_targ));
405 PUTBACK; /* no pop/push after this, TOPs ok */
407 if (op->op_flags & OPf_MOD) {
408 if (op->op_private & OPpLVAL_INTRO)
409 if (!(op->op_private & OPpPAD_STATE))
410 save_clearsv(padentry);
411 if (op->op_private & OPpDEREF) {
412 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
413 than TARG reduces the scope of TARG, so it does not
414 span the call to save_clearsv, resulting in smaller
416 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
428 tryAMAGICunTARGETlist(iter_amg, 0);
429 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
431 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
432 if (!isGV_with_GP(PL_last_in_gv)) {
433 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
434 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
437 XPUSHs(MUTABLE_SV(PL_last_in_gv));
440 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
441 if (PL_last_in_gv == (GV *)&PL_sv_undef)
442 PL_last_in_gv = NULL;
444 assert(isGV_with_GP(PL_last_in_gv));
447 return do_readline();
455 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
459 (SvIOK_notUV(left) && SvIOK_notUV(right))
460 ? (SvIVX(left) == SvIVX(right))
461 : ( do_ncmp(left, right) == 0)
467 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
473 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
474 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
475 Perl_croak_no_modify();
476 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
477 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
479 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
480 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
482 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
483 if (inc) sv_inc(TOPs);
490 /* also used for: pp_orassign() */
499 if (PL_op->op_type == OP_OR)
501 RETURNOP(cLOGOP->op_other);
506 /* also used for: pp_dor() pp_dorassign() */
513 const int op_type = PL_op->op_type;
514 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
519 if (UNLIKELY(!sv || !SvANY(sv))) {
520 if (op_type == OP_DOR)
522 RETURNOP(cLOGOP->op_other);
528 if (UNLIKELY(!sv || !SvANY(sv)))
533 switch (SvTYPE(sv)) {
535 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
539 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
543 if (CvROOT(sv) || CvXSUB(sv))
556 if(op_type == OP_DOR)
558 RETURNOP(cLOGOP->op_other);
560 /* assuming OP_DEFINED */
568 dSP; dATARGET; bool useleft; SV *svl, *svr;
569 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
573 useleft = USE_LEFT(svl);
574 #ifdef PERL_PRESERVE_IVUV
575 /* We must see if we can perform the addition with integers if possible,
576 as the integer code detects overflow while the NV code doesn't.
577 If either argument hasn't had a numeric conversion yet attempt to get
578 the IV. It's important to do this now, rather than just assuming that
579 it's not IOK as a PV of "9223372036854775806" may not take well to NV
580 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
581 integer in case the second argument is IV=9223372036854775806
582 We can (now) rely on sv_2iv to do the right thing, only setting the
583 public IOK flag if the value in the NV (or PV) slot is truly integer.
585 A side effect is that this also aggressively prefers integer maths over
586 fp maths for integer values.
588 How to detect overflow?
590 C 99 section 6.2.6.1 says
592 The range of nonnegative values of a signed integer type is a subrange
593 of the corresponding unsigned integer type, and the representation of
594 the same value in each type is the same. A computation involving
595 unsigned operands can never overflow, because a result that cannot be
596 represented by the resulting unsigned integer type is reduced modulo
597 the number that is one greater than the largest value that can be
598 represented by the resulting type.
602 which I read as "unsigned ints wrap."
604 signed integer overflow seems to be classed as "exception condition"
606 If an exceptional condition occurs during the evaluation of an
607 expression (that is, if the result is not mathematically defined or not
608 in the range of representable values for its type), the behavior is
611 (6.5, the 5th paragraph)
613 I had assumed that on 2s complement machines signed arithmetic would
614 wrap, hence coded pp_add and pp_subtract on the assumption that
615 everything perl builds on would be happy. After much wailing and
616 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
617 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
618 unsigned code below is actually shorter than the old code. :-)
621 if (SvIV_please_nomg(svr)) {
622 /* Unless the left argument is integer in range we are going to have to
623 use NV maths. Hence only attempt to coerce the right argument if
624 we know the left is integer. */
632 /* left operand is undef, treat as zero. + 0 is identity,
633 Could SETi or SETu right now, but space optimise by not adding
634 lots of code to speed up what is probably a rarish case. */
636 /* Left operand is defined, so is it IV? */
637 if (SvIV_please_nomg(svl)) {
638 if ((auvok = SvUOK(svl)))
641 const IV aiv = SvIVX(svl);
644 auvok = 1; /* Now acting as a sign flag. */
646 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
653 bool result_good = 0;
656 bool buvok = SvUOK(svr);
661 const IV biv = SvIVX(svr);
666 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
668 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
669 else "IV" now, independent of how it came in.
670 if a, b represents positive, A, B negative, a maps to -A etc
675 all UV maths. negate result if A negative.
676 add if signs same, subtract if signs differ. */
682 /* Must get smaller */
688 /* result really should be -(auv-buv). as its negation
689 of true value, need to swap our result flag */
706 if (result <= (UV)IV_MIN)
707 SETi(result == (UV)IV_MIN
708 ? IV_MIN : -(IV)result);
710 /* result valid, but out of range for IV. */
715 } /* Overflow, drop through to NVs. */
720 NV value = SvNV_nomg(svr);
723 /* left operand is undef, treat as zero. + 0.0 is identity. */
727 SETn( value + SvNV_nomg(svl) );
733 /* also used for: pp_aelemfast_lex() */
738 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
739 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
740 const U32 lval = PL_op->op_flags & OPf_MOD;
741 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
742 SV *sv = (svp ? *svp : &PL_sv_undef);
744 if (UNLIKELY(!svp && lval))
745 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
748 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
758 do_join(TARG, *MARK, MARK, SP);
769 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
770 * will be enough to hold an OP*.
772 SV* const sv = sv_newmortal();
773 sv_upgrade(sv, SVt_PVLV);
775 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
778 XPUSHs(MUTABLE_SV(PL_op));
783 /* Oversized hot code. */
785 /* also used for: pp_say() */
789 dSP; dMARK; dORIGMARK;
793 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
797 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
800 if (MARK == ORIGMARK) {
801 /* If using default handle then we need to make space to
802 * pass object as 1st arg, so move other args up ...
806 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
809 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
811 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
812 | (PL_op->op_type == OP_SAY
813 ? TIED_METHOD_SAY : 0)), sp - mark);
816 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
817 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
820 SETERRNO(EBADF,RMS_IFI);
823 else if (!(fp = IoOFP(io))) {
825 report_wrongway_fh(gv, '<');
828 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
832 SV * const ofs = GvSV(PL_ofsgv); /* $, */
834 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
836 if (!do_print(*MARK, fp))
840 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
841 if (!do_print(GvSV(PL_ofsgv), fp)) {
850 if (!do_print(*MARK, fp))
858 if (PL_op->op_type == OP_SAY) {
859 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
862 else if (PL_ors_sv && SvOK(PL_ors_sv))
863 if (!do_print(PL_ors_sv, fp)) /* $\ */
866 if (IoFLAGS(io) & IOf_FLUSH)
867 if (PerlIO_flush(fp) == EOF)
877 XPUSHs(&PL_sv_undef);
882 /* also used for: pp_rv2hv() */
883 /* also called directly by pp_lvavref */
888 const I32 gimme = GIMME_V;
889 static const char an_array[] = "an ARRAY";
890 static const char a_hash[] = "a HASH";
891 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
892 || PL_op->op_type == OP_LVAVREF;
893 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
897 if (UNLIKELY(SvAMAGIC(sv))) {
898 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
901 if (UNLIKELY(SvTYPE(sv) != type))
902 /* diag_listed_as: Not an ARRAY reference */
903 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
904 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
905 && PL_op->op_private & OPpLVAL_INTRO))
906 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
908 else if (UNLIKELY(SvTYPE(sv) != type)) {
911 if (!isGV_with_GP(sv)) {
912 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
920 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
921 if (PL_op->op_private & OPpLVAL_INTRO)
922 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
924 if (PL_op->op_flags & OPf_REF) {
928 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
929 const I32 flags = is_lvalue_sub();
930 if (flags && !(flags & OPpENTERSUB_INARGS)) {
931 if (gimme != G_ARRAY)
932 goto croak_cant_return;
939 AV *const av = MUTABLE_AV(sv);
940 /* The guts of pp_rv2av */
941 if (gimme == G_ARRAY) {
947 else if (gimme == G_SCALAR) {
949 const SSize_t maxarg = AvFILL(av) + 1;
953 /* The guts of pp_rv2hv */
954 if (gimme == G_ARRAY) { /* array wanted */
956 return Perl_do_kv(aTHX);
958 else if ((PL_op->op_private & OPpTRUEBOOL
959 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
960 && block_gimme() == G_VOID ))
961 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
962 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
963 else if (gimme == G_SCALAR) {
965 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
972 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
973 is_pp_rv2av ? "array" : "hash");
978 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
980 PERL_ARGS_ASSERT_DO_ODDBALL;
983 if (ckWARN(WARN_MISC)) {
985 if (oddkey == firstkey &&
987 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
988 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
990 err = "Reference found where even-sized list expected";
993 err = "Odd number of elements in hash assignment";
994 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1001 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1002 * are common to both the LHS and RHS of an aassign, and replace them
1003 * with copies. All these copies are made before the actual list assign is
1006 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1007 * element ($b) to the first LH element ($a), modifies $a; when the
1008 * second assignment is done, the second RH element now has the wrong
1009 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1010 * Note that we don't need to make a mortal copy of $b.
1012 * The algorithm below works by, for every RHS element, mark the
1013 * corresponding LHS target element with SVf_BREAK. Then if the RHS
1014 * element is found with SVf_BREAK set, it means it would have been
1015 * modified, so make a copy.
1016 * Note that by scanning both LHS and RHS in lockstep, we avoid
1017 * unnecessary copies (like $b above) compared with a naive
1018 * "mark all LHS; copy all marked RHS; unmark all LHS".
1020 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1021 * it can't be common and can be skipped.
1023 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1024 * that we thought we didn't need to call S_aassign_copy_common(), but we
1025 * have anyway for sanity checking. If we find we need to copy, then panic.
1028 PERL_STATIC_INLINE void
1029 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1030 SV **firstrelem, SV **lastrelem
1039 SSize_t lcount = lastlelem - firstlelem + 1;
1040 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1041 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1043 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1044 assert(firstlelem < lastlelem); /* at least 2 LH elements */
1045 assert(firstrelem < lastrelem); /* at least 2 RH elements */
1049 /* we never have to copy the first RH element; it can't be corrupted
1050 * by assigning something to the corresponding first LH element.
1051 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1053 relem = firstrelem + 1;
1055 for (; relem <= lastrelem; relem++) {
1058 /* mark next LH element */
1060 if (--lcount >= 0) {
1063 if (UNLIKELY(!svl)) {/* skip AV alias marker */
1064 assert (lelem <= lastlelem);
1070 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1073 /* this LH element will consume all further args;
1074 * no need to mark any further LH elements (if any).
1075 * But we still need to scan any remaining RHS elements;
1076 * set lcount negative to distinguish from lcount == 0,
1077 * so the loop condition continues being true
1080 lelem--; /* no need to unmark this element */
1082 else if (!(do_rc1 && SvREFCNT(svl) == 1) && svl != &PL_sv_undef) {
1083 assert(!SvIMMORTAL(svl));
1084 SvFLAGS(svl) |= SVf_BREAK;
1088 /* don't check RH element if no SVf_BREAK flags set yet */
1095 /* see if corresponding RH element needs copying */
1101 if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
1105 /* op_dump(PL_op); */
1107 "panic: aassign skipped needed copy of common RH elem %"
1108 UVuf, (UV)(relem - firstrelem));
1112 TAINT_NOT; /* Each item is independent */
1114 /* Dear TODO test in t/op/sort.t, I love you.
1115 (It's relying on a panic, not a "semi-panic" from newSVsv()
1116 and then an assertion failure below.) */
1117 if (UNLIKELY(SvIS_FREED(svr))) {
1118 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1121 /* avoid break flag while copying; otherwise COW etc
1123 SvFLAGS(svr) &= ~SVf_BREAK;
1124 /* Not newSVsv(), as it does not allow copy-on-write,
1125 resulting in wasteful copies.
1126 Also, we use SV_NOSTEAL in case the SV is used more than
1127 once, e.g. (...) = (f())[0,0]
1128 Where the same SV appears twice on the RHS without a ref
1129 count bump. (Although I suspect that the SV won't be
1130 stealable here anyway - DAPM).
1132 *relem = sv_mortalcopy_flags(svr,
1133 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1134 /* ... but restore afterwards in case it's needed again,
1135 * e.g. ($a,$b,$c) = (1,$a,$a)
1137 SvFLAGS(svr) |= SVf_BREAK;
1149 while (lelem > firstlelem) {
1150 SV * const svl = *(--lelem);
1152 SvFLAGS(svl) &= ~SVf_BREAK;
1161 SV **lastlelem = PL_stack_sp;
1162 SV **lastrelem = PL_stack_base + POPMARK;
1163 SV **firstrelem = PL_stack_base + POPMARK + 1;
1164 SV **firstlelem = lastrelem + 1;
1181 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1183 /* If there's a common identifier on both sides we have to take
1184 * special care that assigning the identifier on the left doesn't
1185 * clobber a value on the right that's used later in the list.
1188 if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
1189 /* at least 2 LH and RH elements, or commonality isn't an issue */
1190 && (firstlelem < lastlelem && firstrelem < lastrelem)
1192 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1193 /* skip the scan if all scalars have a ref count of 1 */
1194 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1196 if (!sv || SvREFCNT(sv) == 1)
1198 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1205 S_aassign_copy_common(aTHX_
1206 firstlelem, lastlelem, firstrelem, lastrelem
1215 /* on debugging builds, do the scan even if we've concluded we
1216 * don't need to, then panic if we find commonality. Note that the
1217 * scanner assumes at least 2 elements */
1218 if (firstlelem < lastlelem && firstrelem < lastrelem) {
1226 lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1233 while (LIKELY(lelem <= lastlelem)) {
1235 TAINT_NOT; /* Each item stands on its own, taintwise. */
1237 if (UNLIKELY(!sv)) {
1240 ASSUME(SvTYPE(sv) == SVt_PVAV);
1242 switch (SvTYPE(sv)) {
1244 bool already_copied = FALSE;
1245 ary = MUTABLE_AV(sv);
1246 magic = SvMAGICAL(ary) != 0;
1248 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1250 /* We need to clear ary. The is a danger that if we do this,
1251 * elements on the RHS may be prematurely freed, e.g.
1253 * In the case of possible commonality, make a copy of each
1254 * RHS SV *before* clearing the array, and add a reference
1255 * from the tmps stack, so that it doesn't leak on death.
1256 * Otherwise, make a copy of each RHS SV only as we're storing
1257 * it into the array - that way we don't have to worry about
1258 * it being leaked if we die, but don't incur the cost of
1259 * mortalising everything.
1262 if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1263 && (relem <= lastrelem)
1264 && (magic || AvFILL(ary) != -1))
1267 EXTEND_MORTAL(lastrelem - relem + 1);
1268 for (svp = relem; svp <= lastrelem; svp++) {
1269 /* see comment in S_aassign_copy_common about SV_NOSTEAL */
1270 *svp = sv_mortalcopy_flags(*svp,
1271 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1274 already_copied = TRUE;
1278 if (relem <= lastrelem)
1279 av_extend(ary, lastrelem - relem);
1282 while (relem <= lastrelem) { /* gobble up all the rest */
1284 if (LIKELY(!alias)) {
1289 /* before newSV, in case it dies */
1292 /* see comment in S_aassign_copy_common about
1294 sv_setsv_flags(sv, *relem,
1295 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1300 if (!already_copied)
1303 DIE(aTHX_ "Assigned value is not a reference");
1304 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1305 /* diag_listed_as: Assigned value is not %s reference */
1307 "Assigned value is not a SCALAR reference");
1308 if (lval && !already_copied)
1309 *relem = sv_mortalcopy(*relem);
1310 /* XXX else check for weak refs? */
1311 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1315 SvREFCNT_inc_simple_NN(sv); /* undo mortal free */
1316 didstore = av_store(ary,i++,sv);
1325 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1326 SvSETMAGIC(MUTABLE_SV(ary));
1331 case SVt_PVHV: { /* normal hash */
1335 SV** topelem = relem;
1336 SV **firsthashrelem = relem;
1337 bool already_copied = FALSE;
1339 hash = MUTABLE_HV(sv);
1340 magic = SvMAGICAL(hash) != 0;
1342 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1343 if (UNLIKELY(odd)) {
1344 do_oddball(lastrelem, firsthashrelem);
1345 /* we have firstlelem to reuse, it's not needed anymore
1347 *(lastrelem+1) = &PL_sv_undef;
1351 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1353 /* We need to clear hash. The is a danger that if we do this,
1354 * elements on the RHS may be prematurely freed, e.g.
1355 * %h = (foo => $h{bar});
1356 * In the case of possible commonality, make a copy of each
1357 * RHS SV *before* clearing the hash, and add a reference
1358 * from the tmps stack, so that it doesn't leak on death.
1361 if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1362 && (relem <= lastrelem)
1363 && (magic || HvUSEDKEYS(hash)))
1366 EXTEND_MORTAL(lastrelem - relem + 1);
1367 for (svp = relem; svp <= lastrelem; svp++) {
1368 *svp = sv_mortalcopy_flags(*svp,
1369 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1372 already_copied = TRUE;
1377 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1380 /* Copy the key if aassign is called in lvalue context,
1381 to avoid having the next op modify our rhs. Copy
1382 it also if it is gmagical, lest it make the
1383 hv_store_ent call below croak, leaking the value. */
1384 sv = (lval || SvGMAGICAL(*relem)) && !already_copied
1385 ? sv_mortalcopy(*relem)
1394 sv_setsv_nomg(tmpstr,*relem++); /* value */
1397 if (gimme == G_ARRAY) {
1398 if (hv_exists_ent(hash, sv, 0))
1399 /* key overwrites an existing entry */
1402 /* copy element back: possibly to an earlier
1403 * stack location if we encountered dups earlier,
1404 * possibly to a later stack location if odd */
1406 *topelem++ = tmpstr;
1410 SvREFCNT_inc_simple_NN(tmpstr); /* undo mortal free */
1411 didstore = hv_store_ent(hash,sv,tmpstr,0);
1413 if (!didstore) sv_2mortal(tmpstr);
1419 if (duplicates && gimme == G_ARRAY) {
1420 /* at this point we have removed the duplicate key/value
1421 * pairs from the stack, but the remaining values may be
1422 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1423 * the (a 2), but the stack now probably contains
1424 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1425 * obliterates the earlier key. So refresh all values. */
1426 lastrelem -= duplicates;
1427 relem = firsthashrelem;
1428 while (relem < lastrelem+odd) {
1430 he = hv_fetch_ent(hash, *relem++, 0, 0);
1431 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1434 if (odd && gimme == G_ARRAY) lastrelem++;
1438 if (SvIMMORTAL(sv)) {
1439 if (relem <= lastrelem)
1443 if (relem <= lastrelem) {
1445 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1446 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1449 packWARN(WARN_MISC),
1450 "Useless assignment to a temporary"
1452 sv_setsv(sv, *relem);
1456 sv_setsv(sv, &PL_sv_undef);
1461 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1462 /* Will be used to set PL_tainting below */
1463 Uid_t tmp_uid = PerlProc_getuid();
1464 Uid_t tmp_euid = PerlProc_geteuid();
1465 Gid_t tmp_gid = PerlProc_getgid();
1466 Gid_t tmp_egid = PerlProc_getegid();
1468 /* XXX $> et al currently silently ignore failures */
1469 if (PL_delaymagic & DM_UID) {
1470 #ifdef HAS_SETRESUID
1472 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1473 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1476 # ifdef HAS_SETREUID
1478 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1479 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1482 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1483 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1484 PL_delaymagic &= ~DM_RUID;
1486 # endif /* HAS_SETRUID */
1488 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1489 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1490 PL_delaymagic &= ~DM_EUID;
1492 # endif /* HAS_SETEUID */
1493 if (PL_delaymagic & DM_UID) {
1494 if (PL_delaymagic_uid != PL_delaymagic_euid)
1495 DIE(aTHX_ "No setreuid available");
1496 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1498 # endif /* HAS_SETREUID */
1499 #endif /* HAS_SETRESUID */
1501 tmp_uid = PerlProc_getuid();
1502 tmp_euid = PerlProc_geteuid();
1504 /* XXX $> et al currently silently ignore failures */
1505 if (PL_delaymagic & DM_GID) {
1506 #ifdef HAS_SETRESGID
1508 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1509 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1512 # ifdef HAS_SETREGID
1514 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1515 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1518 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1519 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1520 PL_delaymagic &= ~DM_RGID;
1522 # endif /* HAS_SETRGID */
1524 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1525 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1526 PL_delaymagic &= ~DM_EGID;
1528 # endif /* HAS_SETEGID */
1529 if (PL_delaymagic & DM_GID) {
1530 if (PL_delaymagic_gid != PL_delaymagic_egid)
1531 DIE(aTHX_ "No setregid available");
1532 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1534 # endif /* HAS_SETREGID */
1535 #endif /* HAS_SETRESGID */
1537 tmp_gid = PerlProc_getgid();
1538 tmp_egid = PerlProc_getegid();
1540 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1541 #ifdef NO_TAINT_SUPPORT
1542 PERL_UNUSED_VAR(tmp_uid);
1543 PERL_UNUSED_VAR(tmp_euid);
1544 PERL_UNUSED_VAR(tmp_gid);
1545 PERL_UNUSED_VAR(tmp_egid);
1550 if (gimme == G_VOID)
1551 SP = firstrelem - 1;
1552 else if (gimme == G_SCALAR) {
1555 SETi(lastrelem - firstrelem + 1);
1559 /* note that in this case *firstlelem may have been overwritten
1560 by sv_undef in the odd hash case */
1563 SP = firstrelem + (lastlelem - firstlelem);
1564 lelem = firstlelem + (relem - firstrelem);
1566 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1576 PMOP * const pm = cPMOP;
1577 REGEXP * rx = PM_GETRE(pm);
1578 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1579 SV * const rv = sv_newmortal();
1583 SvUPGRADE(rv, SVt_IV);
1584 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1585 loathe to use it here, but it seems to be the right fix. Or close.
1586 The key part appears to be that it's essential for pp_qr to return a new
1587 object (SV), which implies that there needs to be an effective way to
1588 generate a new SV from the existing SV that is pre-compiled in the
1590 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1593 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1594 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1595 *cvp = cv_clone(cv);
1596 SvREFCNT_dec_NN(cv);
1600 HV *const stash = gv_stashsv(pkg, GV_ADD);
1601 SvREFCNT_dec_NN(pkg);
1602 (void)sv_bless(rv, stash);
1605 if (UNLIKELY(RX_ISTAINTED(rx))) {
1607 SvTAINTED_on(SvRV(rv));
1620 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1623 const char *truebase; /* Start of string */
1624 REGEXP *rx = PM_GETRE(pm);
1626 const I32 gimme = GIMME_V;
1628 const I32 oldsave = PL_savestack_ix;
1629 I32 had_zerolen = 0;
1632 if (PL_op->op_flags & OPf_STACKED)
1641 PUTBACK; /* EVAL blocks need stack_sp. */
1642 /* Skip get-magic if this is a qr// clone, because regcomp has
1644 truebase = ReANY(rx)->mother_re
1645 ? SvPV_nomg_const(TARG, len)
1646 : SvPV_const(TARG, len);
1648 DIE(aTHX_ "panic: pp_match");
1649 strend = truebase + len;
1650 rxtainted = (RX_ISTAINTED(rx) ||
1651 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1654 /* We need to know this in case we fail out early - pos() must be reset */
1655 global = dynpm->op_pmflags & PMf_GLOBAL;
1657 /* PMdf_USED is set after a ?? matches once */
1660 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1662 pm->op_pmflags & PMf_USED
1665 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1669 /* empty pattern special-cased to use last successful pattern if
1670 possible, except for qr// */
1671 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1677 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1678 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1679 UVuf" < %"IVdf")\n",
1680 (UV)len, (IV)RX_MINLEN(rx)));
1684 /* get pos() if //g */
1686 mg = mg_find_mglob(TARG);
1687 if (mg && mg->mg_len >= 0) {
1688 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1689 /* last time pos() was set, it was zero-length match */
1690 if (mg->mg_flags & MGf_MINMATCH)
1695 #ifdef PERL_SAWAMPERSAND
1698 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1699 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1703 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1704 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1705 * only on the first iteration. Therefore we need to copy $' as well
1706 * as $&, to make the rest of the string available for captures in
1707 * subsequent iterations */
1708 if (! (global && gimme == G_ARRAY))
1709 r_flags |= REXEC_COPY_SKIP_POST;
1711 #ifdef PERL_SAWAMPERSAND
1712 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1713 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1714 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1721 s = truebase + curpos;
1723 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1724 had_zerolen, TARG, NULL, r_flags))
1728 if (dynpm->op_pmflags & PMf_ONCE)
1730 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1732 dynpm->op_pmflags |= PMf_USED;
1736 RX_MATCH_TAINTED_on(rx);
1737 TAINT_IF(RX_MATCH_TAINTED(rx));
1741 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1743 mg = sv_magicext_mglob(TARG);
1744 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1745 if (RX_ZERO_LEN(rx))
1746 mg->mg_flags |= MGf_MINMATCH;
1748 mg->mg_flags &= ~MGf_MINMATCH;
1751 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1752 LEAVE_SCOPE(oldsave);
1756 /* push captures on stack */
1759 const I32 nparens = RX_NPARENS(rx);
1760 I32 i = (global && !nparens) ? 1 : 0;
1762 SPAGAIN; /* EVAL blocks could move the stack. */
1763 EXTEND(SP, nparens + i);
1764 EXTEND_MORTAL(nparens + i);
1765 for (i = !i; i <= nparens; i++) {
1766 PUSHs(sv_newmortal());
1767 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1768 && RX_OFFS(rx)[i].end != -1 ))
1770 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1771 const char * const s = RX_OFFS(rx)[i].start + truebase;
1772 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1773 || len < 0 || len > strend - s))
1774 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1775 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1776 (long) i, (long) RX_OFFS(rx)[i].start,
1777 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1778 sv_setpvn(*SP, s, len);
1779 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1784 curpos = (UV)RX_OFFS(rx)[0].end;
1785 had_zerolen = RX_ZERO_LEN(rx);
1786 PUTBACK; /* EVAL blocks may use stack */
1787 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1790 LEAVE_SCOPE(oldsave);
1793 NOT_REACHED; /* NOTREACHED */
1796 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1798 mg = mg_find_mglob(TARG);
1802 LEAVE_SCOPE(oldsave);
1803 if (gimme == G_ARRAY)
1809 Perl_do_readline(pTHX)
1811 dSP; dTARGETSTACKED;
1816 IO * const io = GvIO(PL_last_in_gv);
1817 const I32 type = PL_op->op_type;
1818 const I32 gimme = GIMME_V;
1821 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1823 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1824 if (gimme == G_SCALAR) {
1826 SvSetSV_nosteal(TARG, TOPs);
1836 if (IoFLAGS(io) & IOf_ARGV) {
1837 if (IoFLAGS(io) & IOf_START) {
1839 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1840 IoFLAGS(io) &= ~IOf_START;
1841 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1842 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1843 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1844 SvSETMAGIC(GvSV(PL_last_in_gv));
1849 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1850 if (!fp) { /* Note: fp != IoIFP(io) */
1851 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1854 else if (type == OP_GLOB)
1855 fp = Perl_start_glob(aTHX_ POPs, io);
1857 else if (type == OP_GLOB)
1859 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1860 report_wrongway_fh(PL_last_in_gv, '>');
1864 if ((!io || !(IoFLAGS(io) & IOf_START))
1865 && ckWARN(WARN_CLOSED)
1868 report_evil_fh(PL_last_in_gv);
1870 if (gimme == G_SCALAR) {
1871 /* undef TARG, and push that undefined value */
1872 if (type != OP_RCATLINE) {
1873 sv_setsv(TARG,NULL);
1880 if (gimme == G_SCALAR) {
1882 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1885 if (type == OP_RCATLINE)
1886 SvPV_force_nomg_nolen(sv);
1890 else if (isGV_with_GP(sv)) {
1891 SvPV_force_nomg_nolen(sv);
1893 SvUPGRADE(sv, SVt_PV);
1894 tmplen = SvLEN(sv); /* remember if already alloced */
1895 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1896 /* try short-buffering it. Please update t/op/readline.t
1897 * if you change the growth length.
1902 if (type == OP_RCATLINE && SvOK(sv)) {
1904 SvPV_force_nomg_nolen(sv);
1910 sv = sv_2mortal(newSV(80));
1914 /* This should not be marked tainted if the fp is marked clean */
1915 #define MAYBE_TAINT_LINE(io, sv) \
1916 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1921 /* delay EOF state for a snarfed empty file */
1922 #define SNARF_EOF(gimme,rs,io,sv) \
1923 (gimme != G_SCALAR || SvCUR(sv) \
1924 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1928 if (!sv_gets(sv, fp, offset)
1930 || SNARF_EOF(gimme, PL_rs, io, sv)
1931 || PerlIO_error(fp)))
1933 PerlIO_clearerr(fp);
1934 if (IoFLAGS(io) & IOf_ARGV) {
1935 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1938 (void)do_close(PL_last_in_gv, FALSE);
1940 else if (type == OP_GLOB) {
1941 if (!do_close(PL_last_in_gv, FALSE)) {
1942 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1943 "glob failed (child exited with status %d%s)",
1944 (int)(STATUS_CURRENT >> 8),
1945 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1948 if (gimme == G_SCALAR) {
1949 if (type != OP_RCATLINE) {
1950 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1956 MAYBE_TAINT_LINE(io, sv);
1959 MAYBE_TAINT_LINE(io, sv);
1961 IoFLAGS(io) |= IOf_NOLINE;
1965 if (type == OP_GLOB) {
1969 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1970 char * const tmps = SvEND(sv) - 1;
1971 if (*tmps == *SvPVX_const(PL_rs)) {
1973 SvCUR_set(sv, SvCUR(sv) - 1);
1976 for (t1 = SvPVX_const(sv); *t1; t1++)
1978 if (strchr("*%?", *t1))
1980 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1983 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
1984 (void)POPs; /* Unmatched wildcard? Chuck it... */
1987 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1988 if (ckWARN(WARN_UTF8)) {
1989 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1990 const STRLEN len = SvCUR(sv) - offset;
1993 if (!is_utf8_string_loc(s, len, &f))
1994 /* Emulate :encoding(utf8) warning in the same case. */
1995 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1996 "utf8 \"\\x%02X\" does not map to Unicode",
1997 f < (U8*)SvEND(sv) ? *f : 0);
2000 if (gimme == G_ARRAY) {
2001 if (SvLEN(sv) - SvCUR(sv) > 20) {
2002 SvPV_shrink_to_cur(sv);
2004 sv = sv_2mortal(newSV(80));
2007 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2008 /* try to reclaim a bit of scalar space (only on 1st alloc) */
2009 const STRLEN new_len
2010 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2011 SvPV_renew(sv, new_len);
2022 SV * const keysv = POPs;
2023 HV * const hv = MUTABLE_HV(POPs);
2024 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2025 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2027 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2028 bool preeminent = TRUE;
2030 if (SvTYPE(hv) != SVt_PVHV)
2037 /* If we can determine whether the element exist,
2038 * Try to preserve the existenceness of a tied hash
2039 * element by using EXISTS and DELETE if possible.
2040 * Fallback to FETCH and STORE otherwise. */
2041 if (SvCANEXISTDELETE(hv))
2042 preeminent = hv_exists_ent(hv, keysv, 0);
2045 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2046 svp = he ? &HeVAL(he) : NULL;
2048 if (!svp || !*svp || *svp == &PL_sv_undef) {
2052 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2054 lv = sv_newmortal();
2055 sv_upgrade(lv, SVt_PVLV);
2057 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2058 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
2059 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2065 if (HvNAME_get(hv) && isGV(*svp))
2066 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2067 else if (preeminent)
2068 save_helem_flags(hv, keysv, svp,
2069 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2071 SAVEHDELETE(hv, keysv);
2073 else if (PL_op->op_private & OPpDEREF) {
2074 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2078 sv = (svp && *svp ? *svp : &PL_sv_undef);
2079 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2080 * was to make C<local $tied{foo} = $tied{foo}> possible.
2081 * However, it seems no longer to be needed for that purpose, and
2082 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2083 * would loop endlessly since the pos magic is getting set on the
2084 * mortal copy and lost. However, the copy has the effect of
2085 * triggering the get magic, and losing it altogether made things like
2086 * c<$tied{foo};> in void context no longer do get magic, which some
2087 * code relied on. Also, delayed triggering of magic on @+ and friends
2088 * meant the original regex may be out of scope by now. So as a
2089 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2090 * being called too many times). */
2091 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2098 /* a stripped-down version of Perl_softref2xv() for use by
2099 * pp_multideref(), which doesn't use PL_op->op_flags */
2102 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2105 if (PL_op->op_private & HINT_STRICT_REFS) {
2107 Perl_die(aTHX_ PL_no_symref_sv, sv,
2108 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2110 Perl_die(aTHX_ PL_no_usym, what);
2113 Perl_die(aTHX_ PL_no_usym, what);
2114 return gv_fetchsv_nomg(sv, GV_ADD, type);
2118 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2119 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
2121 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2122 * Each of these either contains a set of actions, or an argument, such as
2123 * an IV to use as an array index, or a lexical var to retrieve.
2124 * Several actions re stored per UV; we keep shifting new actions off the
2125 * one UV, and only reload when it becomes zero.
2130 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2131 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2132 UV actions = items->uv;
2135 /* this tells find_uninit_var() where we're up to */
2136 PL_multideref_pc = items;
2139 /* there are three main classes of action; the first retrieve
2140 * the initial AV or HV from a variable or the stack; the second
2141 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2142 * the third an unrolled (/DREFHV, rv2hv, helem).
2144 switch (actions & MDEREF_ACTION_MASK) {
2147 actions = (++items)->uv;
2150 case MDEREF_AV_padav_aelem: /* $lex[...] */
2151 sv = PAD_SVl((++items)->pad_offset);
2154 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
2155 sv = UNOP_AUX_item_sv(++items);
2156 assert(isGV_with_GP(sv));
2157 sv = (SV*)GvAVn((GV*)sv);
2160 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
2165 goto do_AV_rv2av_aelem;
2168 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
2169 sv = UNOP_AUX_item_sv(++items);
2170 assert(isGV_with_GP(sv));
2171 sv = GvSVn((GV*)sv);
2172 goto do_AV_vivify_rv2av_aelem;
2174 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
2175 sv = PAD_SVl((++items)->pad_offset);
2178 do_AV_vivify_rv2av_aelem:
2179 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
2180 /* this is the OPpDEREF action normally found at the end of
2181 * ops like aelem, helem, rv2sv */
2182 sv = vivify_ref(sv, OPpDEREF_AV);
2186 /* this is basically a copy of pp_rv2av when it just has the
2189 if (LIKELY(SvROK(sv))) {
2190 if (UNLIKELY(SvAMAGIC(sv))) {
2191 sv = amagic_deref_call(sv, to_av_amg);
2194 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2195 DIE(aTHX_ "Not an ARRAY reference");
2197 else if (SvTYPE(sv) != SVt_PVAV) {
2198 if (!isGV_with_GP(sv))
2199 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2200 sv = MUTABLE_SV(GvAVn((GV*)sv));
2206 /* retrieve the key; this may be either a lexical or package
2207 * var (whose index/ptr is stored as an item) or a signed
2208 * integer constant stored as an item.
2211 IV elem = 0; /* to shut up stupid compiler warnings */
2214 assert(SvTYPE(sv) == SVt_PVAV);
2216 switch (actions & MDEREF_INDEX_MASK) {
2217 case MDEREF_INDEX_none:
2219 case MDEREF_INDEX_const:
2220 elem = (++items)->iv;
2222 case MDEREF_INDEX_padsv:
2223 elemsv = PAD_SVl((++items)->pad_offset);
2225 case MDEREF_INDEX_gvsv:
2226 elemsv = UNOP_AUX_item_sv(++items);
2227 assert(isGV_with_GP(elemsv));
2228 elemsv = GvSVn((GV*)elemsv);
2230 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2231 && ckWARN(WARN_MISC)))
2232 Perl_warner(aTHX_ packWARN(WARN_MISC),
2233 "Use of reference \"%"SVf"\" as array index",
2235 /* the only time that S_find_uninit_var() needs this
2236 * is to determine which index value triggered the
2237 * undef warning. So just update it here. Note that
2238 * since we don't save and restore this var (e.g. for
2239 * tie or overload execution), its value will be
2240 * meaningless apart from just here */
2241 PL_multideref_pc = items;
2242 elem = SvIV(elemsv);
2247 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2249 if (!(actions & MDEREF_FLAG_last)) {
2250 SV** svp = av_fetch((AV*)sv, elem, 1);
2251 if (!svp || ! (sv=*svp))
2252 DIE(aTHX_ PL_no_aelem, elem);
2256 if (PL_op->op_private &
2257 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2259 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2260 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2263 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2264 sv = av_delete((AV*)sv, elem, discard);
2272 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2273 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2274 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2275 bool preeminent = TRUE;
2276 AV *const av = (AV*)sv;
2279 if (UNLIKELY(localizing)) {
2283 /* If we can determine whether the element exist,
2284 * Try to preserve the existenceness of a tied array
2285 * element by using EXISTS and DELETE if possible.
2286 * Fallback to FETCH and STORE otherwise. */
2287 if (SvCANEXISTDELETE(av))
2288 preeminent = av_exists(av, elem);
2291 svp = av_fetch(av, elem, lval && !defer);
2294 if (!svp || !(sv = *svp)) {
2297 DIE(aTHX_ PL_no_aelem, elem);
2298 len = av_tindex(av);
2299 sv = sv_2mortal(newSVavdefelem(av,
2300 /* Resolve a negative index now, unless it points
2301 * before the beginning of the array, in which
2302 * case record it for error reporting in
2303 * magic_setdefelem. */
2304 elem < 0 && len + elem >= 0
2305 ? len + elem : elem, 1));
2308 if (UNLIKELY(localizing)) {
2310 save_aelem(av, elem, svp);
2311 sv = *svp; /* may have changed */
2314 SAVEADELETE(av, elem);
2319 sv = (svp ? *svp : &PL_sv_undef);
2320 /* see note in pp_helem() */
2321 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2338 case MDEREF_HV_padhv_helem: /* $lex{...} */
2339 sv = PAD_SVl((++items)->pad_offset);
2342 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2343 sv = UNOP_AUX_item_sv(++items);
2344 assert(isGV_with_GP(sv));
2345 sv = (SV*)GvHVn((GV*)sv);
2348 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2353 goto do_HV_rv2hv_helem;
2356 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2357 sv = UNOP_AUX_item_sv(++items);
2358 assert(isGV_with_GP(sv));
2359 sv = GvSVn((GV*)sv);
2360 goto do_HV_vivify_rv2hv_helem;
2362 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2363 sv = PAD_SVl((++items)->pad_offset);
2366 do_HV_vivify_rv2hv_helem:
2367 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2368 /* this is the OPpDEREF action normally found at the end of
2369 * ops like aelem, helem, rv2sv */
2370 sv = vivify_ref(sv, OPpDEREF_HV);
2374 /* this is basically a copy of pp_rv2hv when it just has the
2375 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2378 if (LIKELY(SvROK(sv))) {
2379 if (UNLIKELY(SvAMAGIC(sv))) {
2380 sv = amagic_deref_call(sv, to_hv_amg);
2383 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2384 DIE(aTHX_ "Not a HASH reference");
2386 else if (SvTYPE(sv) != SVt_PVHV) {
2387 if (!isGV_with_GP(sv))
2388 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2389 sv = MUTABLE_SV(GvHVn((GV*)sv));
2395 /* retrieve the key; this may be either a lexical / package
2396 * var or a string constant, whose index/ptr is stored as an
2399 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2401 assert(SvTYPE(sv) == SVt_PVHV);
2403 switch (actions & MDEREF_INDEX_MASK) {
2404 case MDEREF_INDEX_none:
2407 case MDEREF_INDEX_const:
2408 keysv = UNOP_AUX_item_sv(++items);
2411 case MDEREF_INDEX_padsv:
2412 keysv = PAD_SVl((++items)->pad_offset);
2415 case MDEREF_INDEX_gvsv:
2416 keysv = UNOP_AUX_item_sv(++items);
2417 keysv = GvSVn((GV*)keysv);
2421 /* see comment above about setting this var */
2422 PL_multideref_pc = items;
2425 /* ensure that candidate CONSTs have been HEKified */
2426 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2427 || SvTYPE(keysv) >= SVt_PVMG
2430 || SvIsCOW_shared_hash(keysv));
2432 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2434 if (!(actions & MDEREF_FLAG_last)) {
2435 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2436 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2437 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2441 if (PL_op->op_private &
2442 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2444 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2445 sv = hv_exists_ent((HV*)sv, keysv, 0)
2446 ? &PL_sv_yes : &PL_sv_no;
2449 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2450 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2458 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2459 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2460 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2461 bool preeminent = TRUE;
2463 HV * const hv = (HV*)sv;
2466 if (UNLIKELY(localizing)) {
2470 /* If we can determine whether the element exist,
2471 * Try to preserve the existenceness of a tied hash
2472 * element by using EXISTS and DELETE if possible.
2473 * Fallback to FETCH and STORE otherwise. */
2474 if (SvCANEXISTDELETE(hv))
2475 preeminent = hv_exists_ent(hv, keysv, 0);
2478 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2479 svp = he ? &HeVAL(he) : NULL;
2483 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2487 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2488 lv = sv_newmortal();
2489 sv_upgrade(lv, SVt_PVLV);
2491 sv_magic(lv, key2 = newSVsv(keysv),
2492 PERL_MAGIC_defelem, NULL, 0);
2493 /* sv_magic() increments refcount */
2494 SvREFCNT_dec_NN(key2);
2495 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2501 if (HvNAME_get(hv) && isGV(sv))
2502 save_gp(MUTABLE_GV(sv),
2503 !(PL_op->op_flags & OPf_SPECIAL));
2504 else if (preeminent) {
2505 save_helem_flags(hv, keysv, svp,
2506 (PL_op->op_flags & OPf_SPECIAL)
2507 ? 0 : SAVEf_SETMAGIC);
2508 sv = *svp; /* may have changed */
2511 SAVEHDELETE(hv, keysv);
2516 sv = (svp && *svp ? *svp : &PL_sv_undef);
2517 /* see note in pp_helem() */
2518 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2527 actions >>= MDEREF_SHIFT;
2541 cx = &cxstack[cxstack_ix];
2542 itersvp = CxITERVAR(cx);
2544 switch (CxTYPE(cx)) {
2546 case CXt_LOOP_LAZYSV: /* string increment */
2548 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2549 SV *end = cx->blk_loop.state_u.lazysv.end;
2550 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2551 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2553 const char *max = SvPV_const(end, maxlen);
2554 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2558 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2559 /* safe to reuse old SV */
2560 sv_setsv(oldsv, cur);
2564 /* we need a fresh SV every time so that loop body sees a
2565 * completely new SV for closures/references to work as
2567 *itersvp = newSVsv(cur);
2568 SvREFCNT_dec_NN(oldsv);
2570 if (strEQ(SvPVX_const(cur), max))
2571 sv_setiv(cur, 0); /* terminate next time */
2577 case CXt_LOOP_LAZYIV: /* integer increment */
2579 IV cur = cx->blk_loop.state_u.lazyiv.cur;
2580 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2584 /* don't risk potential race */
2585 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2586 /* safe to reuse old SV */
2587 sv_setiv(oldsv, cur);
2591 /* we need a fresh SV every time so that loop body sees a
2592 * completely new SV for closures/references to work as they
2594 *itersvp = newSViv(cur);
2595 SvREFCNT_dec_NN(oldsv);
2598 if (UNLIKELY(cur == IV_MAX)) {
2599 /* Handle end of range at IV_MAX */
2600 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2602 ++cx->blk_loop.state_u.lazyiv.cur;
2606 case CXt_LOOP_FOR: /* iterate array */
2609 AV *av = cx->blk_loop.state_u.ary.ary;
2611 bool av_is_stack = FALSE;
2618 if (PL_op->op_private & OPpITER_REVERSED) {
2619 ix = --cx->blk_loop.state_u.ary.ix;
2620 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2624 ix = ++cx->blk_loop.state_u.ary.ix;
2625 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2629 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2630 SV * const * const svp = av_fetch(av, ix, FALSE);
2631 sv = svp ? *svp : NULL;
2634 sv = AvARRAY(av)[ix];
2637 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2638 SvSetMagicSV(*itersvp, sv);
2643 if (UNLIKELY(SvIS_FREED(sv))) {
2645 Perl_croak(aTHX_ "Use of freed value in iteration");
2652 SvREFCNT_inc_simple_void_NN(sv);
2655 else if (!av_is_stack) {
2656 sv = newSVavdefelem(av, ix, 0);
2663 SvREFCNT_dec(oldsv);
2668 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2674 A description of how taint works in pattern matching and substitution.
2676 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2677 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2679 While the pattern is being assembled/concatenated and then compiled,
2680 PL_tainted will get set (via TAINT_set) if any component of the pattern
2681 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2682 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2683 TAINT_get). It will also be set if any component of the pattern matches
2684 based on locale-dependent behavior.
2686 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2687 the pattern is marked as tainted. This means that subsequent usage, such
2688 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2689 on the new pattern too.
2691 RXf_TAINTED_SEEN is used post-execution by the get magic code
2692 of $1 et al to indicate whether the returned value should be tainted.
2693 It is the responsibility of the caller of the pattern (i.e. pp_match,
2694 pp_subst etc) to set this flag for any other circumstances where $1 needs
2697 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2699 There are three possible sources of taint
2701 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2702 * the replacement string (or expression under /e)
2704 There are four destinations of taint and they are affected by the sources
2705 according to the rules below:
2707 * the return value (not including /r):
2708 tainted by the source string and pattern, but only for the
2709 number-of-iterations case; boolean returns aren't tainted;
2710 * the modified string (or modified copy under /r):
2711 tainted by the source string, pattern, and replacement strings;
2713 tainted by the pattern, and under 'use re "taint"', by the source
2715 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2716 should always be unset before executing subsequent code.
2718 The overall action of pp_subst is:
2720 * at the start, set bits in rxtainted indicating the taint status of
2721 the various sources.
2723 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2724 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2725 pattern has subsequently become tainted via locale ops.
2727 * If control is being passed to pp_substcont to execute a /e block,
2728 save rxtainted in the CXt_SUBST block, for future use by
2731 * Whenever control is being returned to perl code (either by falling
2732 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2733 use the flag bits in rxtainted to make all the appropriate types of
2734 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2735 et al will appear tainted.
2737 pp_match is just a simpler version of the above.
2753 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2754 See "how taint works" above */
2757 REGEXP *rx = PM_GETRE(pm);
2759 int force_on_match = 0;
2760 const I32 oldsave = PL_savestack_ix;
2762 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2767 /* known replacement string? */
2768 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2772 if (PL_op->op_flags & OPf_STACKED)
2781 SvGETMAGIC(TARG); /* must come before cow check */
2783 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2784 because they make integers such as 256 "false". */
2785 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2788 sv_force_normal_flags(TARG,0);
2790 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2791 && (SvREADONLY(TARG)
2792 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2793 || SvTYPE(TARG) > SVt_PVLV)
2794 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2795 Perl_croak_no_modify();
2798 orig = SvPV_nomg(TARG, len);
2799 /* note we don't (yet) force the var into being a string; if we fail
2800 * to match, we leave as-is; on successful match howeverm, we *will*
2801 * coerce into a string, then repeat the match */
2802 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2805 /* only replace once? */
2806 once = !(rpm->op_pmflags & PMf_GLOBAL);
2808 /* See "how taint works" above */
2811 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2812 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2813 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2814 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2815 ? SUBST_TAINT_BOOLRET : 0));
2821 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2823 strend = orig + len;
2824 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2825 maxiters = 2 * slen + 10; /* We can match twice at each
2826 position, once with zero-length,
2827 second time with non-zero. */
2829 if (!RX_PRELEN(rx) && PL_curpm
2830 && !ReANY(rx)->mother_re) {
2835 #ifdef PERL_SAWAMPERSAND
2836 r_flags = ( RX_NPARENS(rx)
2838 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2839 || (rpm->op_pmflags & PMf_KEEPCOPY)
2844 r_flags = REXEC_COPY_STR;
2847 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2850 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2851 LEAVE_SCOPE(oldsave);
2856 /* known replacement string? */
2858 /* replacement needing upgrading? */
2859 if (DO_UTF8(TARG) && !doutf8) {
2860 nsv = sv_newmortal();
2863 sv_recode_to_utf8(nsv, _get_encoding());
2865 sv_utf8_upgrade(nsv);
2866 c = SvPV_const(nsv, clen);
2870 c = SvPV_const(dstr, clen);
2871 doutf8 = DO_UTF8(dstr);
2874 if (SvTAINTED(dstr))
2875 rxtainted |= SUBST_TAINT_REPL;
2882 /* can do inplace substitution? */
2887 && (I32)clen <= RX_MINLENRET(rx)
2889 || !(r_flags & REXEC_COPY_STR)
2890 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2892 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2893 && (!doutf8 || SvUTF8(TARG))
2894 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2898 if (SvIsCOW(TARG)) {
2899 if (!force_on_match)
2901 assert(SvVOK(TARG));
2904 if (force_on_match) {
2905 /* redo the first match, this time with the orig var
2906 * forced into being a string */
2908 orig = SvPV_force_nomg(TARG, len);
2914 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2915 rxtainted |= SUBST_TAINT_PAT;
2916 m = orig + RX_OFFS(rx)[0].start;
2917 d = orig + RX_OFFS(rx)[0].end;
2919 if (m - s > strend - d) { /* faster to shorten from end */
2922 Copy(c, m, clen, char);
2927 Move(d, m, i, char);
2931 SvCUR_set(TARG, m - s);
2933 else { /* faster from front */
2937 Move(s, d - i, i, char);
2940 Copy(c, d, clen, char);
2947 d = s = RX_OFFS(rx)[0].start + orig;
2950 if (UNLIKELY(iters++ > maxiters))
2951 DIE(aTHX_ "Substitution loop");
2952 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2953 rxtainted |= SUBST_TAINT_PAT;
2954 m = RX_OFFS(rx)[0].start + orig;
2957 Move(s, d, i, char);
2961 Copy(c, d, clen, char);
2964 s = RX_OFFS(rx)[0].end + orig;
2965 } while (CALLREGEXEC(rx, s, strend, orig,
2966 s == m, /* don't match same null twice */
2968 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2971 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2972 Move(s, d, i+1, char); /* include the NUL */
2982 if (force_on_match) {
2983 /* redo the first match, this time with the orig var
2984 * forced into being a string */
2986 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2987 /* I feel that it should be possible to avoid this mortal copy
2988 given that the code below copies into a new destination.
2989 However, I suspect it isn't worth the complexity of
2990 unravelling the C<goto force_it> for the small number of
2991 cases where it would be viable to drop into the copy code. */
2992 TARG = sv_2mortal(newSVsv(TARG));
2994 orig = SvPV_force_nomg(TARG, len);
3000 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3001 rxtainted |= SUBST_TAINT_PAT;
3003 s = RX_OFFS(rx)[0].start + orig;
3004 dstr = newSVpvn_flags(orig, s-orig,
3005 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3010 /* note that a whole bunch of local vars are saved here for
3011 * use by pp_substcont: here's a list of them in case you're
3012 * searching for places in this sub that uses a particular var:
3013 * iters maxiters r_flags oldsave rxtainted orig dstr targ
3014 * s m strend rx once */
3016 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3020 if (UNLIKELY(iters++ > maxiters))
3021 DIE(aTHX_ "Substitution loop");
3022 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3023 rxtainted |= SUBST_TAINT_PAT;
3024 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3026 char *old_orig = orig;
3027 assert(RX_SUBOFFSET(rx) == 0);
3029 orig = RX_SUBBEG(rx);
3030 s = orig + (old_s - old_orig);
3031 strend = s + (strend - old_s);
3033 m = RX_OFFS(rx)[0].start + orig;
3034 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3035 s = RX_OFFS(rx)[0].end + orig;
3037 /* replacement already stringified */
3039 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3044 if (!nsv) nsv = sv_newmortal();
3045 sv_copypv(nsv, repl);
3046 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
3047 sv_catsv(dstr, nsv);
3049 else sv_catsv(dstr, repl);
3050 if (UNLIKELY(SvTAINTED(repl)))
3051 rxtainted |= SUBST_TAINT_REPL;
3055 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
3057 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3058 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3060 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3061 /* From here on down we're using the copy, and leaving the original
3068 /* The match may make the string COW. If so, brilliant, because
3069 that's just saved us one malloc, copy and free - the regexp has
3070 donated the old buffer, and we malloc an entirely new one, rather
3071 than the regexp malloc()ing a buffer and copying our original,
3072 only for us to throw it away here during the substitution. */
3073 if (SvIsCOW(TARG)) {
3074 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3080 SvPV_set(TARG, SvPVX(dstr));
3081 SvCUR_set(TARG, SvCUR(dstr));
3082 SvLEN_set(TARG, SvLEN(dstr));
3083 SvFLAGS(TARG) |= SvUTF8(dstr);
3084 SvPV_set(dstr, NULL);
3091 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3092 (void)SvPOK_only_UTF8(TARG);
3095 /* See "how taint works" above */
3097 if ((rxtainted & SUBST_TAINT_PAT) ||
3098 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3099 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3101 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3103 if (!(rxtainted & SUBST_TAINT_BOOLRET)
3104 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3106 SvTAINTED_on(TOPs); /* taint return value */
3108 SvTAINTED_off(TOPs); /* may have got tainted earlier */
3110 /* needed for mg_set below */
3112 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3116 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3118 LEAVE_SCOPE(oldsave);
3127 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3128 ++*PL_markstack_ptr;
3130 LEAVE_with_name("grep_item"); /* exit inner scope */
3133 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3135 const I32 gimme = GIMME_V;
3137 LEAVE_with_name("grep"); /* exit outer scope */
3138 (void)POPMARK; /* pop src */
3139 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3140 (void)POPMARK; /* pop dst */
3141 SP = PL_stack_base + POPMARK; /* pop original mark */
3142 if (gimme == G_SCALAR) {
3146 else if (gimme == G_ARRAY)
3153 ENTER_with_name("grep_item"); /* enter inner scope */
3156 src = PL_stack_base[*PL_markstack_ptr];
3157 if (SvPADTMP(src)) {
3158 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
3164 RETURNOP(cLOGOP->op_other);
3178 if (CxMULTICALL(&cxstack[cxstack_ix])) {
3179 /* entry zero of a stack is always PL_sv_undef, which
3180 * simplifies converting a '()' return into undef in scalar context */
3181 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3186 cxstack_ix++; /* temporarily protect top context */
3189 if (gimme == G_SCALAR) {
3191 if (LIKELY(MARK <= SP)) {
3192 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3193 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3194 && !SvMAGICAL(TOPs)) {
3195 *MARK = SvREFCNT_inc(TOPs);
3200 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
3202 *MARK = sv_mortalcopy(sv);
3203 SvREFCNT_dec_NN(sv);
3206 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3207 && !SvMAGICAL(TOPs)) {
3211 *MARK = sv_mortalcopy(TOPs);
3215 *MARK = &PL_sv_undef;
3219 else if (gimme == G_ARRAY) {
3220 for (MARK = newsp + 1; MARK <= SP; MARK++) {
3221 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
3222 || SvMAGICAL(*MARK)) {
3223 *MARK = sv_mortalcopy(*MARK);
3224 TAINT_NOT; /* Each item is independent */
3231 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3233 PL_curpm = newpm; /* ... and pop $1 et al */
3236 return cx->blk_sub.retop;
3246 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3249 DIE(aTHX_ "Not a CODE reference");
3250 /* This is overwhelmingly the most common case: */
3251 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3252 switch (SvTYPE(sv)) {
3255 if (!(cv = GvCVu((const GV *)sv))) {
3257 cv = sv_2cv(sv, &stash, &gv, 0);
3266 if(isGV_with_GP(sv)) goto we_have_a_glob;
3269 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3271 SP = PL_stack_base + POPMARK;
3279 sv = amagic_deref_call(sv, to_cv_amg);
3280 /* Don't SPAGAIN here. */
3287 DIE(aTHX_ PL_no_usym, "a subroutine");
3288 sym = SvPV_nomg_const(sv, len);
3289 if (PL_op->op_private & HINT_STRICT_REFS)
3290 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3291 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3294 cv = MUTABLE_CV(SvRV(sv));
3295 if (SvTYPE(cv) == SVt_PVCV)
3300 DIE(aTHX_ "Not a CODE reference");
3301 /* This is the second most common case: */
3303 cv = MUTABLE_CV(sv);
3311 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3312 DIE(aTHX_ "Closure prototype called");
3313 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3317 /* anonymous or undef'd function leaves us no recourse */
3318 if (CvLEXICAL(cv) && CvHASGV(cv))
3319 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3320 SVfARG(cv_name(cv, NULL, 0)));
3321 if (CvANON(cv) || !CvHASGV(cv)) {
3322 DIE(aTHX_ "Undefined subroutine called");
3325 /* autoloaded stub? */
3326 if (cv != GvCV(gv = CvGV(cv))) {
3329 /* should call AUTOLOAD now? */
3332 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3333 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3339 sub_name = sv_newmortal();
3340 gv_efullname3(sub_name, gv, NULL);
3341 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3349 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3352 Perl_get_db_sub(aTHX_ &sv, cv);
3354 PL_curcopdb = PL_curcop;
3356 /* check for lsub that handles lvalue subroutines */
3357 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3358 /* if lsub not found then fall back to DB::sub */
3359 if (!cv) cv = GvCV(PL_DBsub);
3361 cv = GvCV(PL_DBsub);
3364 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3365 DIE(aTHX_ "No DB::sub routine defined");
3370 if (!(CvISXSUB(cv))) {
3371 /* This path taken at least 75% of the time */
3373 PADLIST * const padlist = CvPADLIST(cv);
3376 PUSHBLOCK(cx, CXt_SUB, MARK);
3378 cx->blk_sub.retop = PL_op->op_next;
3379 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3380 PERL_STACK_OVERFLOW_CHECK();
3381 pad_push(padlist, depth);
3384 PAD_SET_CUR_NOSAVE(padlist, depth);
3385 if (LIKELY(hasargs)) {
3386 AV *const av = MUTABLE_AV(PAD_SVl(0));
3390 if (UNLIKELY(AvREAL(av))) {
3391 /* @_ is normally not REAL--this should only ever
3392 * happen when DB::sub() calls things that modify @_ */
3397 defavp = &GvAV(PL_defgv);
3398 cx->blk_sub.savearray = *defavp;
3399 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3400 CX_CURPAD_SAVE(cx->blk_sub);
3401 cx->blk_sub.argarray = av;
3404 if (UNLIKELY(items - 1 > AvMAX(av))) {
3405 SV **ary = AvALLOC(av);
3406 AvMAX(av) = items - 1;
3407 Renew(ary, items, SV*);
3412 Copy(MARK+1,AvARRAY(av),items,SV*);
3413 AvFILLp(av) = items - 1;
3419 if (SvPADTMP(*MARK)) {
3420 *MARK = sv_mortalcopy(*MARK);
3428 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3430 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3431 SVfARG(cv_name(cv, NULL, 0)));
3432 /* warning must come *after* we fully set up the context
3433 * stuff so that __WARN__ handlers can safely dounwind()
3436 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3437 && ckWARN(WARN_RECURSION)
3438 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3439 sub_crush_depth(cv);
3440 RETURNOP(CvSTART(cv));
3443 SSize_t markix = TOPMARK;
3448 if (UNLIKELY(((PL_op->op_private
3449 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3450 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3452 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3453 SVfARG(cv_name(cv, NULL, 0)));
3455 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3456 /* Need to copy @_ to stack. Alternative may be to
3457 * switch stack to @_, and copy return values
3458 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3459 AV * const av = GvAV(PL_defgv);
3460 const SSize_t items = AvFILL(av) + 1;
3464 const bool m = cBOOL(SvRMAGICAL(av));
3465 /* Mark is at the end of the stack. */
3467 for (; i < items; ++i)
3471 SV ** const svp = av_fetch(av, i, 0);
3472 sv = svp ? *svp : NULL;
3474 else sv = AvARRAY(av)[i];
3475 if (sv) SP[i+1] = sv;
3477 SP[i+1] = newSVavdefelem(av, i, 1);
3485 SV **mark = PL_stack_base + markix;
3486 SSize_t items = SP - mark;
3489 if (*mark && SvPADTMP(*mark)) {
3490 *mark = sv_mortalcopy(*mark);
3494 /* We assume first XSUB in &DB::sub is the called one. */
3495 if (UNLIKELY(PL_curcopdb)) {
3496 SAVEVPTR(PL_curcop);
3497 PL_curcop = PL_curcopdb;
3500 /* Do we need to open block here? XXXX */
3502 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3504 CvXSUB(cv)(aTHX_ cv);
3506 /* Enforce some sanity in scalar context. */
3507 if (gimme == G_SCALAR) {
3508 SV **svp = PL_stack_base + markix + 1;
3509 if (svp != PL_stack_sp) {
3510 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3520 Perl_sub_crush_depth(pTHX_ CV *cv)
3522 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3525 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3527 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3528 SVfARG(cv_name(cv,NULL,0)));
3536 SV* const elemsv = POPs;
3537 IV elem = SvIV(elemsv);
3538 AV *const av = MUTABLE_AV(POPs);
3539 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3540 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3541 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3542 bool preeminent = TRUE;
3545 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3546 Perl_warner(aTHX_ packWARN(WARN_MISC),
3547 "Use of reference \"%"SVf"\" as array index",
3549 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3552 if (UNLIKELY(localizing)) {
3556 /* If we can determine whether the element exist,
3557 * Try to preserve the existenceness of a tied array
3558 * element by using EXISTS and DELETE if possible.
3559 * Fallback to FETCH and STORE otherwise. */
3560 if (SvCANEXISTDELETE(av))
3561 preeminent = av_exists(av, elem);
3564 svp = av_fetch(av, elem, lval && !defer);
3566 #ifdef PERL_MALLOC_WRAP
3567 if (SvUOK(elemsv)) {
3568 const UV uv = SvUV(elemsv);
3569 elem = uv > IV_MAX ? IV_MAX : uv;
3571 else if (SvNOK(elemsv))
3572 elem = (IV)SvNV(elemsv);
3574 static const char oom_array_extend[] =
3575 "Out of memory during array extend"; /* Duplicated in av.c */
3576 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3579 if (!svp || !*svp) {
3582 DIE(aTHX_ PL_no_aelem, elem);
3583 len = av_tindex(av);
3584 mPUSHs(newSVavdefelem(av,
3585 /* Resolve a negative index now, unless it points before the
3586 beginning of the array, in which case record it for error
3587 reporting in magic_setdefelem. */
3588 elem < 0 && len + elem >= 0 ? len + elem : elem,
3592 if (UNLIKELY(localizing)) {
3594 save_aelem(av, elem, svp);
3596 SAVEADELETE(av, elem);
3598 else if (PL_op->op_private & OPpDEREF) {
3599 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3603 sv = (svp ? *svp : &PL_sv_undef);
3604 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3611 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3613 PERL_ARGS_ASSERT_VIVIFY_REF;
3618 Perl_croak_no_modify();
3619 prepare_SV_for_RV(sv);
3622 SvRV_set(sv, newSV(0));
3625 SvRV_set(sv, MUTABLE_SV(newAV()));
3628 SvRV_set(sv, MUTABLE_SV(newHV()));
3635 if (SvGMAGICAL(sv)) {
3636 /* copy the sv without magic to prevent magic from being
3638 SV* msv = sv_newmortal();
3639 sv_setsv_nomg(msv, sv);
3645 PERL_STATIC_INLINE HV *
3646 S_opmethod_stash(pTHX_ SV* meth)
3651 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3652 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3653 "package or object reference", SVfARG(meth)),
3655 : *(PL_stack_base + TOPMARK + 1);
3657 PERL_ARGS_ASSERT_OPMETHOD_STASH;
3661 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3664 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3665 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3666 stash = gv_stashsv(sv, GV_CACHE_ONLY);
3667 if (stash) return stash;
3671 ob = MUTABLE_SV(SvRV(sv));
3672 else if (!SvOK(sv)) goto undefined;
3673 else if (isGV_with_GP(sv)) {
3675 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3676 "without a package or object reference",
3679 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3680 assert(!LvTARGLEN(ob));
3684 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3687 /* this isn't a reference */
3690 const char * const packname = SvPV_nomg_const(sv, packlen);
3691 const U32 packname_utf8 = SvUTF8(sv);
3692 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3693 if (stash) return stash;
3695 if (!(iogv = gv_fetchpvn_flags(
3696 packname, packlen, packname_utf8, SVt_PVIO
3698 !(ob=MUTABLE_SV(GvIO(iogv))))
3700 /* this isn't the name of a filehandle either */
3703 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3704 "without a package or object reference",
3707 /* assume it's a package name */
3708 stash = gv_stashpvn(packname, packlen, packname_utf8);
3709 if (stash) return stash;
3710 else return MUTABLE_HV(sv);
3712 /* it _is_ a filehandle name -- replace with a reference */
3713 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3716 /* if we got here, ob should be an object or a glob */
3717 if (!ob || !(SvOBJECT(ob)
3718 || (isGV_with_GP(ob)
3719 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3722 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3723 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3724 ? newSVpvs_flags("DOES", SVs_TEMP)
3736 SV* const meth = TOPs;
3739 SV* const rmeth = SvRV(meth);
3740 if (SvTYPE(rmeth) == SVt_PVCV) {
3746 stash = opmethod_stash(meth);
3748 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3751 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3755 #define METHOD_CHECK_CACHE(stash,cache,meth) \
3756 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
3758 gv = MUTABLE_GV(HeVAL(he)); \
3759 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
3760 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
3762 XPUSHs(MUTABLE_SV(GvCV(gv))); \
3771 SV* const meth = cMETHOPx_meth(PL_op);
3772 HV* const stash = opmethod_stash(meth);
3774 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3775 METHOD_CHECK_CACHE(stash, stash, meth);
3778 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3781 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3790 SV* const meth = cMETHOPx_meth(PL_op);
3791 HV* const stash = CopSTASH(PL_curcop);
3792 /* Actually, SUPER doesn't need real object's (or class') stash at all,
3793 * as it uses CopSTASH. However, we must ensure that object(class) is
3794 * correct (this check is done by S_opmethod_stash) */
3795 opmethod_stash(meth);
3797 if ((cache = HvMROMETA(stash)->super)) {
3798 METHOD_CHECK_CACHE(stash, cache, meth);
3801 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3804 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3812 SV* const meth = cMETHOPx_meth(PL_op);
3813 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3814 opmethod_stash(meth); /* not used but needed for error checks */
3816 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3817 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3819 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3822 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3826 PP(pp_method_redir_super)
3831 SV* const meth = cMETHOPx_meth(PL_op);
3832 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3833 opmethod_stash(meth); /* not used but needed for error checks */
3835 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3836 else if ((cache = HvMROMETA(stash)->super)) {
3837 METHOD_CHECK_CACHE(stash, cache, meth);
3840 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3843 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3848 * ex: set ts=8 sts=4 sw=4 et: