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_simple_void_NN(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;
1177 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1178 * only need to save locally, not on the save stack */
1179 U16 old_delaymagic = PL_delaymagic;
1184 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1186 /* If there's a common identifier on both sides we have to take
1187 * special care that assigning the identifier on the left doesn't
1188 * clobber a value on the right that's used later in the list.
1191 if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
1192 /* at least 2 LH and RH elements, or commonality isn't an issue */
1193 && (firstlelem < lastlelem && firstrelem < lastrelem)
1195 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1196 /* skip the scan if all scalars have a ref count of 1 */
1197 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1199 if (!sv || SvREFCNT(sv) == 1)
1201 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1208 S_aassign_copy_common(aTHX_
1209 firstlelem, lastlelem, firstrelem, lastrelem
1218 /* on debugging builds, do the scan even if we've concluded we
1219 * don't need to, then panic if we find commonality. Note that the
1220 * scanner assumes at least 2 elements */
1221 if (firstlelem < lastlelem && firstrelem < lastrelem) {
1229 lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1236 while (LIKELY(lelem <= lastlelem)) {
1238 TAINT_NOT; /* Each item stands on its own, taintwise. */
1240 if (UNLIKELY(!sv)) {
1243 ASSUME(SvTYPE(sv) == SVt_PVAV);
1245 switch (SvTYPE(sv)) {
1247 bool already_copied = FALSE;
1248 ary = MUTABLE_AV(sv);
1249 magic = SvMAGICAL(ary) != 0;
1251 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1253 /* We need to clear ary. The is a danger that if we do this,
1254 * elements on the RHS may be prematurely freed, e.g.
1256 * In the case of possible commonality, make a copy of each
1257 * RHS SV *before* clearing the array, and add a reference
1258 * from the tmps stack, so that it doesn't leak on death.
1259 * Otherwise, make a copy of each RHS SV only as we're storing
1260 * it into the array - that way we don't have to worry about
1261 * it being leaked if we die, but don't incur the cost of
1262 * mortalising everything.
1265 if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1266 && (relem <= lastrelem)
1267 && (magic || AvFILL(ary) != -1))
1270 EXTEND_MORTAL(lastrelem - relem + 1);
1271 for (svp = relem; svp <= lastrelem; svp++) {
1272 /* see comment in S_aassign_copy_common about SV_NOSTEAL */
1273 *svp = sv_mortalcopy_flags(*svp,
1274 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1277 already_copied = TRUE;
1281 if (relem <= lastrelem)
1282 av_extend(ary, lastrelem - relem);
1285 while (relem <= lastrelem) { /* gobble up all the rest */
1287 if (LIKELY(!alias)) {
1292 /* before newSV, in case it dies */
1295 /* see comment in S_aassign_copy_common about
1297 sv_setsv_flags(sv, *relem,
1298 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1303 if (!already_copied)
1306 DIE(aTHX_ "Assigned value is not a reference");
1307 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1308 /* diag_listed_as: Assigned value is not %s reference */
1310 "Assigned value is not a SCALAR reference");
1311 if (lval && !already_copied)
1312 *relem = sv_mortalcopy(*relem);
1313 /* XXX else check for weak refs? */
1314 sv = SvREFCNT_inc_NN(SvRV(*relem));
1318 SvREFCNT_inc_simple_void_NN(sv); /* undo mortal free */
1319 didstore = av_store(ary,i++,sv);
1328 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1329 SvSETMAGIC(MUTABLE_SV(ary));
1334 case SVt_PVHV: { /* normal hash */
1338 SV** topelem = relem;
1339 SV **firsthashrelem = relem;
1340 bool already_copied = FALSE;
1342 hash = MUTABLE_HV(sv);
1343 magic = SvMAGICAL(hash) != 0;
1345 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1346 if (UNLIKELY(odd)) {
1347 do_oddball(lastrelem, firsthashrelem);
1348 /* we have firstlelem to reuse, it's not needed anymore
1350 *(lastrelem+1) = &PL_sv_undef;
1354 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1356 /* We need to clear hash. The is a danger that if we do this,
1357 * elements on the RHS may be prematurely freed, e.g.
1358 * %h = (foo => $h{bar});
1359 * In the case of possible commonality, make a copy of each
1360 * RHS SV *before* clearing the hash, and add a reference
1361 * from the tmps stack, so that it doesn't leak on death.
1364 if ( (PL_op->op_private & OPpASSIGN_COMMON_AGG)
1365 && (relem <= lastrelem)
1366 && (magic || HvUSEDKEYS(hash)))
1369 EXTEND_MORTAL(lastrelem - relem + 1);
1370 for (svp = relem; svp <= lastrelem; svp++) {
1371 *svp = sv_mortalcopy_flags(*svp,
1372 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1375 already_copied = TRUE;
1380 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1383 /* Copy the key if aassign is called in lvalue context,
1384 to avoid having the next op modify our rhs. Copy
1385 it also if it is gmagical, lest it make the
1386 hv_store_ent call below croak, leaking the value. */
1387 sv = (lval || SvGMAGICAL(*relem)) && !already_copied
1388 ? sv_mortalcopy(*relem)
1397 sv_setsv_nomg(tmpstr,*relem++); /* value */
1400 if (gimme == G_ARRAY) {
1401 if (hv_exists_ent(hash, sv, 0))
1402 /* key overwrites an existing entry */
1405 /* copy element back: possibly to an earlier
1406 * stack location if we encountered dups earlier,
1407 * possibly to a later stack location if odd */
1409 *topelem++ = tmpstr;
1413 SvREFCNT_inc_simple_void_NN(tmpstr); /* undo mortal free */
1414 didstore = hv_store_ent(hash,sv,tmpstr,0);
1416 if (!didstore) sv_2mortal(tmpstr);
1422 if (duplicates && gimme == G_ARRAY) {
1423 /* at this point we have removed the duplicate key/value
1424 * pairs from the stack, but the remaining values may be
1425 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1426 * the (a 2), but the stack now probably contains
1427 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1428 * obliterates the earlier key. So refresh all values. */
1429 lastrelem -= duplicates;
1430 relem = firsthashrelem;
1431 while (relem < lastrelem+odd) {
1433 he = hv_fetch_ent(hash, *relem++, 0, 0);
1434 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1437 if (odd && gimme == G_ARRAY) lastrelem++;
1441 if (SvIMMORTAL(sv)) {
1442 if (relem <= lastrelem)
1446 if (relem <= lastrelem) {
1448 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1449 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1452 packWARN(WARN_MISC),
1453 "Useless assignment to a temporary"
1455 sv_setsv(sv, *relem);
1459 sv_setsv(sv, &PL_sv_undef);
1464 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1465 /* Will be used to set PL_tainting below */
1466 Uid_t tmp_uid = PerlProc_getuid();
1467 Uid_t tmp_euid = PerlProc_geteuid();
1468 Gid_t tmp_gid = PerlProc_getgid();
1469 Gid_t tmp_egid = PerlProc_getegid();
1471 /* XXX $> et al currently silently ignore failures */
1472 if (PL_delaymagic & DM_UID) {
1473 #ifdef HAS_SETRESUID
1475 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1476 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1479 # ifdef HAS_SETREUID
1481 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1482 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1485 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1486 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1487 PL_delaymagic &= ~DM_RUID;
1489 # endif /* HAS_SETRUID */
1491 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1492 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1493 PL_delaymagic &= ~DM_EUID;
1495 # endif /* HAS_SETEUID */
1496 if (PL_delaymagic & DM_UID) {
1497 if (PL_delaymagic_uid != PL_delaymagic_euid)
1498 DIE(aTHX_ "No setreuid available");
1499 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1501 # endif /* HAS_SETREUID */
1502 #endif /* HAS_SETRESUID */
1504 tmp_uid = PerlProc_getuid();
1505 tmp_euid = PerlProc_geteuid();
1507 /* XXX $> et al currently silently ignore failures */
1508 if (PL_delaymagic & DM_GID) {
1509 #ifdef HAS_SETRESGID
1511 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1512 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1515 # ifdef HAS_SETREGID
1517 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1518 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1521 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1522 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1523 PL_delaymagic &= ~DM_RGID;
1525 # endif /* HAS_SETRGID */
1527 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1528 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1529 PL_delaymagic &= ~DM_EGID;
1531 # endif /* HAS_SETEGID */
1532 if (PL_delaymagic & DM_GID) {
1533 if (PL_delaymagic_gid != PL_delaymagic_egid)
1534 DIE(aTHX_ "No setregid available");
1535 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1537 # endif /* HAS_SETREGID */
1538 #endif /* HAS_SETRESGID */
1540 tmp_gid = PerlProc_getgid();
1541 tmp_egid = PerlProc_getegid();
1543 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1544 #ifdef NO_TAINT_SUPPORT
1545 PERL_UNUSED_VAR(tmp_uid);
1546 PERL_UNUSED_VAR(tmp_euid);
1547 PERL_UNUSED_VAR(tmp_gid);
1548 PERL_UNUSED_VAR(tmp_egid);
1551 PL_delaymagic = old_delaymagic;
1553 if (gimme == G_VOID)
1554 SP = firstrelem - 1;
1555 else if (gimme == G_SCALAR) {
1558 SETi(lastrelem - firstrelem + 1);
1562 /* note that in this case *firstlelem may have been overwritten
1563 by sv_undef in the odd hash case */
1566 SP = firstrelem + (lastlelem - firstlelem);
1567 lelem = firstlelem + (relem - firstrelem);
1569 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1579 PMOP * const pm = cPMOP;
1580 REGEXP * rx = PM_GETRE(pm);
1581 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1582 SV * const rv = sv_newmortal();
1586 SvUPGRADE(rv, SVt_IV);
1587 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1588 loathe to use it here, but it seems to be the right fix. Or close.
1589 The key part appears to be that it's essential for pp_qr to return a new
1590 object (SV), which implies that there needs to be an effective way to
1591 generate a new SV from the existing SV that is pre-compiled in the
1593 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1596 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1597 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1598 *cvp = cv_clone(cv);
1599 SvREFCNT_dec_NN(cv);
1603 HV *const stash = gv_stashsv(pkg, GV_ADD);
1604 SvREFCNT_dec_NN(pkg);
1605 (void)sv_bless(rv, stash);
1608 if (UNLIKELY(RX_ISTAINTED(rx))) {
1610 SvTAINTED_on(SvRV(rv));
1623 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1626 const char *truebase; /* Start of string */
1627 REGEXP *rx = PM_GETRE(pm);
1629 const I32 gimme = GIMME_V;
1631 const I32 oldsave = PL_savestack_ix;
1632 I32 had_zerolen = 0;
1635 if (PL_op->op_flags & OPf_STACKED)
1644 PUTBACK; /* EVAL blocks need stack_sp. */
1645 /* Skip get-magic if this is a qr// clone, because regcomp has
1647 truebase = ReANY(rx)->mother_re
1648 ? SvPV_nomg_const(TARG, len)
1649 : SvPV_const(TARG, len);
1651 DIE(aTHX_ "panic: pp_match");
1652 strend = truebase + len;
1653 rxtainted = (RX_ISTAINTED(rx) ||
1654 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1657 /* We need to know this in case we fail out early - pos() must be reset */
1658 global = dynpm->op_pmflags & PMf_GLOBAL;
1660 /* PMdf_USED is set after a ?? matches once */
1663 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1665 pm->op_pmflags & PMf_USED
1668 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1672 /* empty pattern special-cased to use last successful pattern if
1673 possible, except for qr// */
1674 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1680 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1681 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1682 UVuf" < %"IVdf")\n",
1683 (UV)len, (IV)RX_MINLEN(rx)));
1687 /* get pos() if //g */
1689 mg = mg_find_mglob(TARG);
1690 if (mg && mg->mg_len >= 0) {
1691 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1692 /* last time pos() was set, it was zero-length match */
1693 if (mg->mg_flags & MGf_MINMATCH)
1698 #ifdef PERL_SAWAMPERSAND
1701 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1702 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1706 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1707 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1708 * only on the first iteration. Therefore we need to copy $' as well
1709 * as $&, to make the rest of the string available for captures in
1710 * subsequent iterations */
1711 if (! (global && gimme == G_ARRAY))
1712 r_flags |= REXEC_COPY_SKIP_POST;
1714 #ifdef PERL_SAWAMPERSAND
1715 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1716 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1717 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1724 s = truebase + curpos;
1726 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1727 had_zerolen, TARG, NULL, r_flags))
1731 if (dynpm->op_pmflags & PMf_ONCE)
1733 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1735 dynpm->op_pmflags |= PMf_USED;
1739 RX_MATCH_TAINTED_on(rx);
1740 TAINT_IF(RX_MATCH_TAINTED(rx));
1744 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1746 mg = sv_magicext_mglob(TARG);
1747 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1748 if (RX_ZERO_LEN(rx))
1749 mg->mg_flags |= MGf_MINMATCH;
1751 mg->mg_flags &= ~MGf_MINMATCH;
1754 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1755 LEAVE_SCOPE(oldsave);
1759 /* push captures on stack */
1762 const I32 nparens = RX_NPARENS(rx);
1763 I32 i = (global && !nparens) ? 1 : 0;
1765 SPAGAIN; /* EVAL blocks could move the stack. */
1766 EXTEND(SP, nparens + i);
1767 EXTEND_MORTAL(nparens + i);
1768 for (i = !i; i <= nparens; i++) {
1769 PUSHs(sv_newmortal());
1770 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1771 && RX_OFFS(rx)[i].end != -1 ))
1773 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1774 const char * const s = RX_OFFS(rx)[i].start + truebase;
1775 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1776 || len < 0 || len > strend - s))
1777 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1778 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1779 (long) i, (long) RX_OFFS(rx)[i].start,
1780 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1781 sv_setpvn(*SP, s, len);
1782 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1787 curpos = (UV)RX_OFFS(rx)[0].end;
1788 had_zerolen = RX_ZERO_LEN(rx);
1789 PUTBACK; /* EVAL blocks may use stack */
1790 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1793 LEAVE_SCOPE(oldsave);
1796 NOT_REACHED; /* NOTREACHED */
1799 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1801 mg = mg_find_mglob(TARG);
1805 LEAVE_SCOPE(oldsave);
1806 if (gimme == G_ARRAY)
1812 Perl_do_readline(pTHX)
1814 dSP; dTARGETSTACKED;
1819 IO * const io = GvIO(PL_last_in_gv);
1820 const I32 type = PL_op->op_type;
1821 const I32 gimme = GIMME_V;
1824 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1826 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1827 if (gimme == G_SCALAR) {
1829 SvSetSV_nosteal(TARG, TOPs);
1839 if (IoFLAGS(io) & IOf_ARGV) {
1840 if (IoFLAGS(io) & IOf_START) {
1842 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1843 IoFLAGS(io) &= ~IOf_START;
1844 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1845 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1846 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1847 SvSETMAGIC(GvSV(PL_last_in_gv));
1852 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1853 if (!fp) { /* Note: fp != IoIFP(io) */
1854 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1857 else if (type == OP_GLOB)
1858 fp = Perl_start_glob(aTHX_ POPs, io);
1860 else if (type == OP_GLOB)
1862 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1863 report_wrongway_fh(PL_last_in_gv, '>');
1867 if ((!io || !(IoFLAGS(io) & IOf_START))
1868 && ckWARN(WARN_CLOSED)
1871 report_evil_fh(PL_last_in_gv);
1873 if (gimme == G_SCALAR) {
1874 /* undef TARG, and push that undefined value */
1875 if (type != OP_RCATLINE) {
1876 sv_setsv(TARG,NULL);
1883 if (gimme == G_SCALAR) {
1885 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1888 if (type == OP_RCATLINE)
1889 SvPV_force_nomg_nolen(sv);
1893 else if (isGV_with_GP(sv)) {
1894 SvPV_force_nomg_nolen(sv);
1896 SvUPGRADE(sv, SVt_PV);
1897 tmplen = SvLEN(sv); /* remember if already alloced */
1898 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1899 /* try short-buffering it. Please update t/op/readline.t
1900 * if you change the growth length.
1905 if (type == OP_RCATLINE && SvOK(sv)) {
1907 SvPV_force_nomg_nolen(sv);
1913 sv = sv_2mortal(newSV(80));
1917 /* This should not be marked tainted if the fp is marked clean */
1918 #define MAYBE_TAINT_LINE(io, sv) \
1919 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1924 /* delay EOF state for a snarfed empty file */
1925 #define SNARF_EOF(gimme,rs,io,sv) \
1926 (gimme != G_SCALAR || SvCUR(sv) \
1927 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1931 if (!sv_gets(sv, fp, offset)
1933 || SNARF_EOF(gimme, PL_rs, io, sv)
1934 || PerlIO_error(fp)))
1936 PerlIO_clearerr(fp);
1937 if (IoFLAGS(io) & IOf_ARGV) {
1938 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1941 (void)do_close(PL_last_in_gv, FALSE);
1943 else if (type == OP_GLOB) {
1944 if (!do_close(PL_last_in_gv, FALSE)) {
1945 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1946 "glob failed (child exited with status %d%s)",
1947 (int)(STATUS_CURRENT >> 8),
1948 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1951 if (gimme == G_SCALAR) {
1952 if (type != OP_RCATLINE) {
1953 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1959 MAYBE_TAINT_LINE(io, sv);
1962 MAYBE_TAINT_LINE(io, sv);
1964 IoFLAGS(io) |= IOf_NOLINE;
1968 if (type == OP_GLOB) {
1972 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1973 char * const tmps = SvEND(sv) - 1;
1974 if (*tmps == *SvPVX_const(PL_rs)) {
1976 SvCUR_set(sv, SvCUR(sv) - 1);
1979 for (t1 = SvPVX_const(sv); *t1; t1++)
1981 if (strchr("*%?", *t1))
1983 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1986 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
1987 (void)POPs; /* Unmatched wildcard? Chuck it... */
1990 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1991 if (ckWARN(WARN_UTF8)) {
1992 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1993 const STRLEN len = SvCUR(sv) - offset;
1996 if (!is_utf8_string_loc(s, len, &f))
1997 /* Emulate :encoding(utf8) warning in the same case. */
1998 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1999 "utf8 \"\\x%02X\" does not map to Unicode",
2000 f < (U8*)SvEND(sv) ? *f : 0);
2003 if (gimme == G_ARRAY) {
2004 if (SvLEN(sv) - SvCUR(sv) > 20) {
2005 SvPV_shrink_to_cur(sv);
2007 sv = sv_2mortal(newSV(80));
2010 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2011 /* try to reclaim a bit of scalar space (only on 1st alloc) */
2012 const STRLEN new_len
2013 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2014 SvPV_renew(sv, new_len);
2025 SV * const keysv = POPs;
2026 HV * const hv = MUTABLE_HV(POPs);
2027 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2028 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2030 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2031 bool preeminent = TRUE;
2033 if (SvTYPE(hv) != SVt_PVHV)
2040 /* If we can determine whether the element exist,
2041 * Try to preserve the existenceness of a tied hash
2042 * element by using EXISTS and DELETE if possible.
2043 * Fallback to FETCH and STORE otherwise. */
2044 if (SvCANEXISTDELETE(hv))
2045 preeminent = hv_exists_ent(hv, keysv, 0);
2048 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2049 svp = he ? &HeVAL(he) : NULL;
2051 if (!svp || !*svp || *svp == &PL_sv_undef) {
2055 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2057 lv = sv_newmortal();
2058 sv_upgrade(lv, SVt_PVLV);
2060 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2061 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
2062 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2068 if (HvNAME_get(hv) && isGV(*svp))
2069 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2070 else if (preeminent)
2071 save_helem_flags(hv, keysv, svp,
2072 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2074 SAVEHDELETE(hv, keysv);
2076 else if (PL_op->op_private & OPpDEREF) {
2077 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2081 sv = (svp && *svp ? *svp : &PL_sv_undef);
2082 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2083 * was to make C<local $tied{foo} = $tied{foo}> possible.
2084 * However, it seems no longer to be needed for that purpose, and
2085 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2086 * would loop endlessly since the pos magic is getting set on the
2087 * mortal copy and lost. However, the copy has the effect of
2088 * triggering the get magic, and losing it altogether made things like
2089 * c<$tied{foo};> in void context no longer do get magic, which some
2090 * code relied on. Also, delayed triggering of magic on @+ and friends
2091 * meant the original regex may be out of scope by now. So as a
2092 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2093 * being called too many times). */
2094 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2101 /* a stripped-down version of Perl_softref2xv() for use by
2102 * pp_multideref(), which doesn't use PL_op->op_flags */
2105 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2108 if (PL_op->op_private & HINT_STRICT_REFS) {
2110 Perl_die(aTHX_ PL_no_symref_sv, sv,
2111 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2113 Perl_die(aTHX_ PL_no_usym, what);
2116 Perl_die(aTHX_ PL_no_usym, what);
2117 return gv_fetchsv_nomg(sv, GV_ADD, type);
2121 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2122 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
2124 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2125 * Each of these either contains a set of actions, or an argument, such as
2126 * an IV to use as an array index, or a lexical var to retrieve.
2127 * Several actions re stored per UV; we keep shifting new actions off the
2128 * one UV, and only reload when it becomes zero.
2133 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2134 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2135 UV actions = items->uv;
2138 /* this tells find_uninit_var() where we're up to */
2139 PL_multideref_pc = items;
2142 /* there are three main classes of action; the first retrieve
2143 * the initial AV or HV from a variable or the stack; the second
2144 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2145 * the third an unrolled (/DREFHV, rv2hv, helem).
2147 switch (actions & MDEREF_ACTION_MASK) {
2150 actions = (++items)->uv;
2153 case MDEREF_AV_padav_aelem: /* $lex[...] */
2154 sv = PAD_SVl((++items)->pad_offset);
2157 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
2158 sv = UNOP_AUX_item_sv(++items);
2159 assert(isGV_with_GP(sv));
2160 sv = (SV*)GvAVn((GV*)sv);
2163 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
2168 goto do_AV_rv2av_aelem;
2171 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
2172 sv = UNOP_AUX_item_sv(++items);
2173 assert(isGV_with_GP(sv));
2174 sv = GvSVn((GV*)sv);
2175 goto do_AV_vivify_rv2av_aelem;
2177 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
2178 sv = PAD_SVl((++items)->pad_offset);
2181 do_AV_vivify_rv2av_aelem:
2182 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
2183 /* this is the OPpDEREF action normally found at the end of
2184 * ops like aelem, helem, rv2sv */
2185 sv = vivify_ref(sv, OPpDEREF_AV);
2189 /* this is basically a copy of pp_rv2av when it just has the
2192 if (LIKELY(SvROK(sv))) {
2193 if (UNLIKELY(SvAMAGIC(sv))) {
2194 sv = amagic_deref_call(sv, to_av_amg);
2197 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2198 DIE(aTHX_ "Not an ARRAY reference");
2200 else if (SvTYPE(sv) != SVt_PVAV) {
2201 if (!isGV_with_GP(sv))
2202 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2203 sv = MUTABLE_SV(GvAVn((GV*)sv));
2209 /* retrieve the key; this may be either a lexical or package
2210 * var (whose index/ptr is stored as an item) or a signed
2211 * integer constant stored as an item.
2214 IV elem = 0; /* to shut up stupid compiler warnings */
2217 assert(SvTYPE(sv) == SVt_PVAV);
2219 switch (actions & MDEREF_INDEX_MASK) {
2220 case MDEREF_INDEX_none:
2222 case MDEREF_INDEX_const:
2223 elem = (++items)->iv;
2225 case MDEREF_INDEX_padsv:
2226 elemsv = PAD_SVl((++items)->pad_offset);
2228 case MDEREF_INDEX_gvsv:
2229 elemsv = UNOP_AUX_item_sv(++items);
2230 assert(isGV_with_GP(elemsv));
2231 elemsv = GvSVn((GV*)elemsv);
2233 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2234 && ckWARN(WARN_MISC)))
2235 Perl_warner(aTHX_ packWARN(WARN_MISC),
2236 "Use of reference \"%"SVf"\" as array index",
2238 /* the only time that S_find_uninit_var() needs this
2239 * is to determine which index value triggered the
2240 * undef warning. So just update it here. Note that
2241 * since we don't save and restore this var (e.g. for
2242 * tie or overload execution), its value will be
2243 * meaningless apart from just here */
2244 PL_multideref_pc = items;
2245 elem = SvIV(elemsv);
2250 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2252 if (!(actions & MDEREF_FLAG_last)) {
2253 SV** svp = av_fetch((AV*)sv, elem, 1);
2254 if (!svp || ! (sv=*svp))
2255 DIE(aTHX_ PL_no_aelem, elem);
2259 if (PL_op->op_private &
2260 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2262 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2263 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2266 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2267 sv = av_delete((AV*)sv, elem, discard);
2275 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2276 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2277 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2278 bool preeminent = TRUE;
2279 AV *const av = (AV*)sv;
2282 if (UNLIKELY(localizing)) {
2286 /* If we can determine whether the element exist,
2287 * Try to preserve the existenceness of a tied array
2288 * element by using EXISTS and DELETE if possible.
2289 * Fallback to FETCH and STORE otherwise. */
2290 if (SvCANEXISTDELETE(av))
2291 preeminent = av_exists(av, elem);
2294 svp = av_fetch(av, elem, lval && !defer);
2297 if (!svp || !(sv = *svp)) {
2300 DIE(aTHX_ PL_no_aelem, elem);
2301 len = av_tindex(av);
2302 sv = sv_2mortal(newSVavdefelem(av,
2303 /* Resolve a negative index now, unless it points
2304 * before the beginning of the array, in which
2305 * case record it for error reporting in
2306 * magic_setdefelem. */
2307 elem < 0 && len + elem >= 0
2308 ? len + elem : elem, 1));
2311 if (UNLIKELY(localizing)) {
2313 save_aelem(av, elem, svp);
2314 sv = *svp; /* may have changed */
2317 SAVEADELETE(av, elem);
2322 sv = (svp ? *svp : &PL_sv_undef);
2323 /* see note in pp_helem() */
2324 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2341 case MDEREF_HV_padhv_helem: /* $lex{...} */
2342 sv = PAD_SVl((++items)->pad_offset);
2345 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2346 sv = UNOP_AUX_item_sv(++items);
2347 assert(isGV_with_GP(sv));
2348 sv = (SV*)GvHVn((GV*)sv);
2351 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2356 goto do_HV_rv2hv_helem;
2359 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2360 sv = UNOP_AUX_item_sv(++items);
2361 assert(isGV_with_GP(sv));
2362 sv = GvSVn((GV*)sv);
2363 goto do_HV_vivify_rv2hv_helem;
2365 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2366 sv = PAD_SVl((++items)->pad_offset);
2369 do_HV_vivify_rv2hv_helem:
2370 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2371 /* this is the OPpDEREF action normally found at the end of
2372 * ops like aelem, helem, rv2sv */
2373 sv = vivify_ref(sv, OPpDEREF_HV);
2377 /* this is basically a copy of pp_rv2hv when it just has the
2378 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2381 if (LIKELY(SvROK(sv))) {
2382 if (UNLIKELY(SvAMAGIC(sv))) {
2383 sv = amagic_deref_call(sv, to_hv_amg);
2386 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2387 DIE(aTHX_ "Not a HASH reference");
2389 else if (SvTYPE(sv) != SVt_PVHV) {
2390 if (!isGV_with_GP(sv))
2391 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2392 sv = MUTABLE_SV(GvHVn((GV*)sv));
2398 /* retrieve the key; this may be either a lexical / package
2399 * var or a string constant, whose index/ptr is stored as an
2402 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2404 assert(SvTYPE(sv) == SVt_PVHV);
2406 switch (actions & MDEREF_INDEX_MASK) {
2407 case MDEREF_INDEX_none:
2410 case MDEREF_INDEX_const:
2411 keysv = UNOP_AUX_item_sv(++items);
2414 case MDEREF_INDEX_padsv:
2415 keysv = PAD_SVl((++items)->pad_offset);
2418 case MDEREF_INDEX_gvsv:
2419 keysv = UNOP_AUX_item_sv(++items);
2420 keysv = GvSVn((GV*)keysv);
2424 /* see comment above about setting this var */
2425 PL_multideref_pc = items;
2428 /* ensure that candidate CONSTs have been HEKified */
2429 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2430 || SvTYPE(keysv) >= SVt_PVMG
2433 || SvIsCOW_shared_hash(keysv));
2435 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2437 if (!(actions & MDEREF_FLAG_last)) {
2438 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2439 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2440 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2444 if (PL_op->op_private &
2445 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2447 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2448 sv = hv_exists_ent((HV*)sv, keysv, 0)
2449 ? &PL_sv_yes : &PL_sv_no;
2452 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2453 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2461 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2462 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2463 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2464 bool preeminent = TRUE;
2466 HV * const hv = (HV*)sv;
2469 if (UNLIKELY(localizing)) {
2473 /* If we can determine whether the element exist,
2474 * Try to preserve the existenceness of a tied hash
2475 * element by using EXISTS and DELETE if possible.
2476 * Fallback to FETCH and STORE otherwise. */
2477 if (SvCANEXISTDELETE(hv))
2478 preeminent = hv_exists_ent(hv, keysv, 0);
2481 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2482 svp = he ? &HeVAL(he) : NULL;
2486 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2490 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2491 lv = sv_newmortal();
2492 sv_upgrade(lv, SVt_PVLV);
2494 sv_magic(lv, key2 = newSVsv(keysv),
2495 PERL_MAGIC_defelem, NULL, 0);
2496 /* sv_magic() increments refcount */
2497 SvREFCNT_dec_NN(key2);
2498 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2504 if (HvNAME_get(hv) && isGV(sv))
2505 save_gp(MUTABLE_GV(sv),
2506 !(PL_op->op_flags & OPf_SPECIAL));
2507 else if (preeminent) {
2508 save_helem_flags(hv, keysv, svp,
2509 (PL_op->op_flags & OPf_SPECIAL)
2510 ? 0 : SAVEf_SETMAGIC);
2511 sv = *svp; /* may have changed */
2514 SAVEHDELETE(hv, keysv);
2519 sv = (svp && *svp ? *svp : &PL_sv_undef);
2520 /* see note in pp_helem() */
2521 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2530 actions >>= MDEREF_SHIFT;
2544 cx = &cxstack[cxstack_ix];
2545 itersvp = CxITERVAR(cx);
2547 switch (CxTYPE(cx)) {
2549 case CXt_LOOP_LAZYSV: /* string increment */
2551 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2552 SV *end = cx->blk_loop.state_u.lazysv.end;
2553 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2554 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2556 const char *max = SvPV_const(end, maxlen);
2557 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2561 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2562 /* safe to reuse old SV */
2563 sv_setsv(oldsv, cur);
2567 /* we need a fresh SV every time so that loop body sees a
2568 * completely new SV for closures/references to work as
2570 *itersvp = newSVsv(cur);
2571 SvREFCNT_dec_NN(oldsv);
2573 if (strEQ(SvPVX_const(cur), max))
2574 sv_setiv(cur, 0); /* terminate next time */
2580 case CXt_LOOP_LAZYIV: /* integer increment */
2582 IV cur = cx->blk_loop.state_u.lazyiv.cur;
2583 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2587 /* don't risk potential race */
2588 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2589 /* safe to reuse old SV */
2590 sv_setiv(oldsv, cur);
2594 /* we need a fresh SV every time so that loop body sees a
2595 * completely new SV for closures/references to work as they
2597 *itersvp = newSViv(cur);
2598 SvREFCNT_dec_NN(oldsv);
2601 if (UNLIKELY(cur == IV_MAX)) {
2602 /* Handle end of range at IV_MAX */
2603 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2605 ++cx->blk_loop.state_u.lazyiv.cur;
2609 case CXt_LOOP_FOR: /* iterate array */
2612 AV *av = cx->blk_loop.state_u.ary.ary;
2614 bool av_is_stack = FALSE;
2621 if (PL_op->op_private & OPpITER_REVERSED) {
2622 ix = --cx->blk_loop.state_u.ary.ix;
2623 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2627 ix = ++cx->blk_loop.state_u.ary.ix;
2628 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2632 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2633 SV * const * const svp = av_fetch(av, ix, FALSE);
2634 sv = svp ? *svp : NULL;
2637 sv = AvARRAY(av)[ix];
2640 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2641 SvSetMagicSV(*itersvp, sv);
2646 if (UNLIKELY(SvIS_FREED(sv))) {
2648 Perl_croak(aTHX_ "Use of freed value in iteration");
2655 SvREFCNT_inc_simple_void_NN(sv);
2658 else if (!av_is_stack) {
2659 sv = newSVavdefelem(av, ix, 0);
2666 SvREFCNT_dec(oldsv);
2671 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2677 A description of how taint works in pattern matching and substitution.
2679 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2680 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2682 While the pattern is being assembled/concatenated and then compiled,
2683 PL_tainted will get set (via TAINT_set) if any component of the pattern
2684 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2685 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2686 TAINT_get). It will also be set if any component of the pattern matches
2687 based on locale-dependent behavior.
2689 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2690 the pattern is marked as tainted. This means that subsequent usage, such
2691 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2692 on the new pattern too.
2694 RXf_TAINTED_SEEN is used post-execution by the get magic code
2695 of $1 et al to indicate whether the returned value should be tainted.
2696 It is the responsibility of the caller of the pattern (i.e. pp_match,
2697 pp_subst etc) to set this flag for any other circumstances where $1 needs
2700 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2702 There are three possible sources of taint
2704 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2705 * the replacement string (or expression under /e)
2707 There are four destinations of taint and they are affected by the sources
2708 according to the rules below:
2710 * the return value (not including /r):
2711 tainted by the source string and pattern, but only for the
2712 number-of-iterations case; boolean returns aren't tainted;
2713 * the modified string (or modified copy under /r):
2714 tainted by the source string, pattern, and replacement strings;
2716 tainted by the pattern, and under 'use re "taint"', by the source
2718 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2719 should always be unset before executing subsequent code.
2721 The overall action of pp_subst is:
2723 * at the start, set bits in rxtainted indicating the taint status of
2724 the various sources.
2726 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2727 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2728 pattern has subsequently become tainted via locale ops.
2730 * If control is being passed to pp_substcont to execute a /e block,
2731 save rxtainted in the CXt_SUBST block, for future use by
2734 * Whenever control is being returned to perl code (either by falling
2735 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2736 use the flag bits in rxtainted to make all the appropriate types of
2737 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2738 et al will appear tainted.
2740 pp_match is just a simpler version of the above.
2756 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2757 See "how taint works" above */
2760 REGEXP *rx = PM_GETRE(pm);
2762 int force_on_match = 0;
2763 const I32 oldsave = PL_savestack_ix;
2765 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2770 /* known replacement string? */
2771 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2775 if (PL_op->op_flags & OPf_STACKED)
2784 SvGETMAGIC(TARG); /* must come before cow check */
2786 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2787 because they make integers such as 256 "false". */
2788 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2791 sv_force_normal_flags(TARG,0);
2793 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2794 && (SvREADONLY(TARG)
2795 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2796 || SvTYPE(TARG) > SVt_PVLV)
2797 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2798 Perl_croak_no_modify();
2801 orig = SvPV_nomg(TARG, len);
2802 /* note we don't (yet) force the var into being a string; if we fail
2803 * to match, we leave as-is; on successful match howeverm, we *will*
2804 * coerce into a string, then repeat the match */
2805 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2808 /* only replace once? */
2809 once = !(rpm->op_pmflags & PMf_GLOBAL);
2811 /* See "how taint works" above */
2814 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2815 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2816 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2817 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2818 ? SUBST_TAINT_BOOLRET : 0));
2824 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2826 strend = orig + len;
2827 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2828 maxiters = 2 * slen + 10; /* We can match twice at each
2829 position, once with zero-length,
2830 second time with non-zero. */
2832 if (!RX_PRELEN(rx) && PL_curpm
2833 && !ReANY(rx)->mother_re) {
2838 #ifdef PERL_SAWAMPERSAND
2839 r_flags = ( RX_NPARENS(rx)
2841 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2842 || (rpm->op_pmflags & PMf_KEEPCOPY)
2847 r_flags = REXEC_COPY_STR;
2850 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2853 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2854 LEAVE_SCOPE(oldsave);
2859 /* known replacement string? */
2861 /* replacement needing upgrading? */
2862 if (DO_UTF8(TARG) && !doutf8) {
2863 nsv = sv_newmortal();
2866 sv_recode_to_utf8(nsv, _get_encoding());
2868 sv_utf8_upgrade(nsv);
2869 c = SvPV_const(nsv, clen);
2873 c = SvPV_const(dstr, clen);
2874 doutf8 = DO_UTF8(dstr);
2877 if (SvTAINTED(dstr))
2878 rxtainted |= SUBST_TAINT_REPL;
2885 /* can do inplace substitution? */
2890 && (I32)clen <= RX_MINLENRET(rx)
2892 || !(r_flags & REXEC_COPY_STR)
2893 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2895 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2896 && (!doutf8 || SvUTF8(TARG))
2897 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2901 if (SvIsCOW(TARG)) {
2902 if (!force_on_match)
2904 assert(SvVOK(TARG));
2907 if (force_on_match) {
2908 /* redo the first match, this time with the orig var
2909 * forced into being a string */
2911 orig = SvPV_force_nomg(TARG, len);
2917 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2918 rxtainted |= SUBST_TAINT_PAT;
2919 m = orig + RX_OFFS(rx)[0].start;
2920 d = orig + RX_OFFS(rx)[0].end;
2922 if (m - s > strend - d) { /* faster to shorten from end */
2925 Copy(c, m, clen, char);
2930 Move(d, m, i, char);
2934 SvCUR_set(TARG, m - s);
2936 else { /* faster from front */
2940 Move(s, d - i, i, char);
2943 Copy(c, d, clen, char);
2950 d = s = RX_OFFS(rx)[0].start + orig;
2953 if (UNLIKELY(iters++ > maxiters))
2954 DIE(aTHX_ "Substitution loop");
2955 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2956 rxtainted |= SUBST_TAINT_PAT;
2957 m = RX_OFFS(rx)[0].start + orig;
2960 Move(s, d, i, char);
2964 Copy(c, d, clen, char);
2967 s = RX_OFFS(rx)[0].end + orig;
2968 } while (CALLREGEXEC(rx, s, strend, orig,
2969 s == m, /* don't match same null twice */
2971 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2974 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2975 Move(s, d, i+1, char); /* include the NUL */
2985 if (force_on_match) {
2986 /* redo the first match, this time with the orig var
2987 * forced into being a string */
2989 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2990 /* I feel that it should be possible to avoid this mortal copy
2991 given that the code below copies into a new destination.
2992 However, I suspect it isn't worth the complexity of
2993 unravelling the C<goto force_it> for the small number of
2994 cases where it would be viable to drop into the copy code. */
2995 TARG = sv_2mortal(newSVsv(TARG));
2997 orig = SvPV_force_nomg(TARG, len);
3003 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3004 rxtainted |= SUBST_TAINT_PAT;
3006 s = RX_OFFS(rx)[0].start + orig;
3007 dstr = newSVpvn_flags(orig, s-orig,
3008 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3013 /* note that a whole bunch of local vars are saved here for
3014 * use by pp_substcont: here's a list of them in case you're
3015 * searching for places in this sub that uses a particular var:
3016 * iters maxiters r_flags oldsave rxtainted orig dstr targ
3017 * s m strend rx once */
3019 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3023 if (UNLIKELY(iters++ > maxiters))
3024 DIE(aTHX_ "Substitution loop");
3025 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3026 rxtainted |= SUBST_TAINT_PAT;
3027 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3029 char *old_orig = orig;
3030 assert(RX_SUBOFFSET(rx) == 0);
3032 orig = RX_SUBBEG(rx);
3033 s = orig + (old_s - old_orig);
3034 strend = s + (strend - old_s);
3036 m = RX_OFFS(rx)[0].start + orig;
3037 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3038 s = RX_OFFS(rx)[0].end + orig;
3040 /* replacement already stringified */
3042 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3047 if (!nsv) nsv = sv_newmortal();
3048 sv_copypv(nsv, repl);
3049 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
3050 sv_catsv(dstr, nsv);
3052 else sv_catsv(dstr, repl);
3053 if (UNLIKELY(SvTAINTED(repl)))
3054 rxtainted |= SUBST_TAINT_REPL;
3058 } while (CALLREGEXEC(rx, s, strend, orig,
3059 s == m, /* Yields minend of 0 or 1 */
3061 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3062 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3064 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3065 /* From here on down we're using the copy, and leaving the original
3072 /* The match may make the string COW. If so, brilliant, because
3073 that's just saved us one malloc, copy and free - the regexp has
3074 donated the old buffer, and we malloc an entirely new one, rather
3075 than the regexp malloc()ing a buffer and copying our original,
3076 only for us to throw it away here during the substitution. */
3077 if (SvIsCOW(TARG)) {
3078 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3084 SvPV_set(TARG, SvPVX(dstr));
3085 SvCUR_set(TARG, SvCUR(dstr));
3086 SvLEN_set(TARG, SvLEN(dstr));
3087 SvFLAGS(TARG) |= SvUTF8(dstr);
3088 SvPV_set(dstr, NULL);
3095 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3096 (void)SvPOK_only_UTF8(TARG);
3099 /* See "how taint works" above */
3101 if ((rxtainted & SUBST_TAINT_PAT) ||
3102 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3103 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3105 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3107 if (!(rxtainted & SUBST_TAINT_BOOLRET)
3108 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3110 SvTAINTED_on(TOPs); /* taint return value */
3112 SvTAINTED_off(TOPs); /* may have got tainted earlier */
3114 /* needed for mg_set below */
3116 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3120 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3122 LEAVE_SCOPE(oldsave);
3131 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3132 ++*PL_markstack_ptr;
3134 LEAVE_with_name("grep_item"); /* exit inner scope */
3137 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3139 const I32 gimme = GIMME_V;
3141 LEAVE_with_name("grep"); /* exit outer scope */
3142 (void)POPMARK; /* pop src */
3143 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3144 (void)POPMARK; /* pop dst */
3145 SP = PL_stack_base + POPMARK; /* pop original mark */
3146 if (gimme == G_SCALAR) {
3150 else if (gimme == G_ARRAY)
3157 ENTER_with_name("grep_item"); /* enter inner scope */
3160 src = PL_stack_base[TOPMARK];
3161 if (SvPADTMP(src)) {
3162 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
3168 RETURNOP(cLOGOP->op_other);
3182 if (CxMULTICALL(&cxstack[cxstack_ix])) {
3183 /* entry zero of a stack is always PL_sv_undef, which
3184 * simplifies converting a '()' return into undef in scalar context */
3185 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3190 cxstack_ix++; /* temporarily protect top context */
3193 if (gimme == G_SCALAR) {
3195 if (LIKELY(MARK <= SP)) {
3196 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
3197 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3198 && !SvMAGICAL(TOPs)) {
3199 *MARK = SvREFCNT_inc(TOPs);
3204 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
3206 *MARK = sv_mortalcopy(sv);
3207 SvREFCNT_dec_NN(sv);
3210 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
3211 && !SvMAGICAL(TOPs)) {
3215 *MARK = sv_mortalcopy(TOPs);
3219 *MARK = &PL_sv_undef;
3223 else if (gimme == G_ARRAY) {
3224 for (MARK = newsp + 1; MARK <= SP; MARK++) {
3225 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
3226 || SvMAGICAL(*MARK)) {
3227 *MARK = sv_mortalcopy(*MARK);
3228 TAINT_NOT; /* Each item is independent */
3235 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3237 PL_curpm = newpm; /* ... and pop $1 et al */
3240 return cx->blk_sub.retop;
3250 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3253 DIE(aTHX_ "Not a CODE reference");
3254 /* This is overwhelmingly the most common case: */
3255 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3256 switch (SvTYPE(sv)) {
3259 if (!(cv = GvCVu((const GV *)sv))) {
3261 cv = sv_2cv(sv, &stash, &gv, 0);
3270 if(isGV_with_GP(sv)) goto we_have_a_glob;
3273 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3275 SP = PL_stack_base + POPMARK;
3283 sv = amagic_deref_call(sv, to_cv_amg);
3284 /* Don't SPAGAIN here. */
3291 DIE(aTHX_ PL_no_usym, "a subroutine");
3292 sym = SvPV_nomg_const(sv, len);
3293 if (PL_op->op_private & HINT_STRICT_REFS)
3294 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3295 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3298 cv = MUTABLE_CV(SvRV(sv));
3299 if (SvTYPE(cv) == SVt_PVCV)
3304 DIE(aTHX_ "Not a CODE reference");
3305 /* This is the second most common case: */
3307 cv = MUTABLE_CV(sv);
3315 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3316 DIE(aTHX_ "Closure prototype called");
3317 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3321 /* anonymous or undef'd function leaves us no recourse */
3322 if (CvLEXICAL(cv) && CvHASGV(cv))
3323 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3324 SVfARG(cv_name(cv, NULL, 0)));
3325 if (CvANON(cv) || !CvHASGV(cv)) {
3326 DIE(aTHX_ "Undefined subroutine called");
3329 /* autoloaded stub? */
3330 if (cv != GvCV(gv = CvGV(cv))) {
3333 /* should call AUTOLOAD now? */
3336 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3337 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3343 sub_name = sv_newmortal();
3344 gv_efullname3(sub_name, gv, NULL);
3345 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3353 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3356 Perl_get_db_sub(aTHX_ &sv, cv);
3358 PL_curcopdb = PL_curcop;
3360 /* check for lsub that handles lvalue subroutines */
3361 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3362 /* if lsub not found then fall back to DB::sub */
3363 if (!cv) cv = GvCV(PL_DBsub);
3365 cv = GvCV(PL_DBsub);
3368 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3369 DIE(aTHX_ "No DB::sub routine defined");
3374 if (!(CvISXSUB(cv))) {
3375 /* This path taken at least 75% of the time */
3377 PADLIST * const padlist = CvPADLIST(cv);
3380 PUSHBLOCK(cx, CXt_SUB, MARK);
3382 cx->blk_sub.retop = PL_op->op_next;
3383 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3384 PERL_STACK_OVERFLOW_CHECK();
3385 pad_push(padlist, depth);
3388 PAD_SET_CUR_NOSAVE(padlist, depth);
3389 if (LIKELY(hasargs)) {
3390 AV *const av = MUTABLE_AV(PAD_SVl(0));
3394 if (UNLIKELY(AvREAL(av))) {
3395 /* @_ is normally not REAL--this should only ever
3396 * happen when DB::sub() calls things that modify @_ */
3401 defavp = &GvAV(PL_defgv);
3402 cx->blk_sub.savearray = *defavp;
3403 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3404 CX_CURPAD_SAVE(cx->blk_sub);
3405 cx->blk_sub.argarray = av;
3408 if (UNLIKELY(items - 1 > AvMAX(av))) {
3409 SV **ary = AvALLOC(av);
3410 AvMAX(av) = items - 1;
3411 Renew(ary, items, SV*);
3416 Copy(MARK+1,AvARRAY(av),items,SV*);
3417 AvFILLp(av) = items - 1;
3423 if (SvPADTMP(*MARK)) {
3424 *MARK = sv_mortalcopy(*MARK);
3432 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3434 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3435 SVfARG(cv_name(cv, NULL, 0)));
3436 /* warning must come *after* we fully set up the context
3437 * stuff so that __WARN__ handlers can safely dounwind()
3440 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3441 && ckWARN(WARN_RECURSION)
3442 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3443 sub_crush_depth(cv);
3444 RETURNOP(CvSTART(cv));
3447 SSize_t markix = TOPMARK;
3452 if (UNLIKELY(((PL_op->op_private
3453 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3454 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3456 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
3457 SVfARG(cv_name(cv, NULL, 0)));
3459 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3460 /* Need to copy @_ to stack. Alternative may be to
3461 * switch stack to @_, and copy return values
3462 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3463 AV * const av = GvAV(PL_defgv);
3464 const SSize_t items = AvFILL(av) + 1;
3468 const bool m = cBOOL(SvRMAGICAL(av));
3469 /* Mark is at the end of the stack. */
3471 for (; i < items; ++i)
3475 SV ** const svp = av_fetch(av, i, 0);
3476 sv = svp ? *svp : NULL;
3478 else sv = AvARRAY(av)[i];
3479 if (sv) SP[i+1] = sv;
3481 SP[i+1] = newSVavdefelem(av, i, 1);
3489 SV **mark = PL_stack_base + markix;
3490 SSize_t items = SP - mark;
3493 if (*mark && SvPADTMP(*mark)) {
3494 *mark = sv_mortalcopy(*mark);
3498 /* We assume first XSUB in &DB::sub is the called one. */
3499 if (UNLIKELY(PL_curcopdb)) {
3500 SAVEVPTR(PL_curcop);
3501 PL_curcop = PL_curcopdb;
3504 /* Do we need to open block here? XXXX */
3506 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3508 CvXSUB(cv)(aTHX_ cv);
3510 /* Enforce some sanity in scalar context. */
3511 if (gimme == G_SCALAR) {
3512 SV **svp = PL_stack_base + markix + 1;
3513 if (svp != PL_stack_sp) {
3514 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3524 Perl_sub_crush_depth(pTHX_ CV *cv)
3526 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3529 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3531 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3532 SVfARG(cv_name(cv,NULL,0)));
3540 SV* const elemsv = POPs;
3541 IV elem = SvIV(elemsv);
3542 AV *const av = MUTABLE_AV(POPs);
3543 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3544 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3545 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3546 bool preeminent = TRUE;
3549 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3550 Perl_warner(aTHX_ packWARN(WARN_MISC),
3551 "Use of reference \"%"SVf"\" as array index",
3553 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3556 if (UNLIKELY(localizing)) {
3560 /* If we can determine whether the element exist,
3561 * Try to preserve the existenceness of a tied array
3562 * element by using EXISTS and DELETE if possible.
3563 * Fallback to FETCH and STORE otherwise. */
3564 if (SvCANEXISTDELETE(av))
3565 preeminent = av_exists(av, elem);
3568 svp = av_fetch(av, elem, lval && !defer);
3570 #ifdef PERL_MALLOC_WRAP
3571 if (SvUOK(elemsv)) {
3572 const UV uv = SvUV(elemsv);
3573 elem = uv > IV_MAX ? IV_MAX : uv;
3575 else if (SvNOK(elemsv))
3576 elem = (IV)SvNV(elemsv);
3578 static const char oom_array_extend[] =
3579 "Out of memory during array extend"; /* Duplicated in av.c */
3580 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3583 if (!svp || !*svp) {
3586 DIE(aTHX_ PL_no_aelem, elem);
3587 len = av_tindex(av);
3588 mPUSHs(newSVavdefelem(av,
3589 /* Resolve a negative index now, unless it points before the
3590 beginning of the array, in which case record it for error
3591 reporting in magic_setdefelem. */
3592 elem < 0 && len + elem >= 0 ? len + elem : elem,
3596 if (UNLIKELY(localizing)) {
3598 save_aelem(av, elem, svp);
3600 SAVEADELETE(av, elem);
3602 else if (PL_op->op_private & OPpDEREF) {
3603 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3607 sv = (svp ? *svp : &PL_sv_undef);
3608 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3615 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3617 PERL_ARGS_ASSERT_VIVIFY_REF;
3622 Perl_croak_no_modify();
3623 prepare_SV_for_RV(sv);
3626 SvRV_set(sv, newSV(0));
3629 SvRV_set(sv, MUTABLE_SV(newAV()));
3632 SvRV_set(sv, MUTABLE_SV(newHV()));
3639 if (SvGMAGICAL(sv)) {
3640 /* copy the sv without magic to prevent magic from being
3642 SV* msv = sv_newmortal();
3643 sv_setsv_nomg(msv, sv);
3649 PERL_STATIC_INLINE HV *
3650 S_opmethod_stash(pTHX_ SV* meth)
3655 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3656 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3657 "package or object reference", SVfARG(meth)),
3659 : *(PL_stack_base + TOPMARK + 1);
3661 PERL_ARGS_ASSERT_OPMETHOD_STASH;
3665 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3668 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3669 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3670 stash = gv_stashsv(sv, GV_CACHE_ONLY);
3671 if (stash) return stash;
3675 ob = MUTABLE_SV(SvRV(sv));
3676 else if (!SvOK(sv)) goto undefined;
3677 else if (isGV_with_GP(sv)) {
3679 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3680 "without a package or object reference",
3683 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3684 assert(!LvTARGLEN(ob));
3688 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3691 /* this isn't a reference */
3694 const char * const packname = SvPV_nomg_const(sv, packlen);
3695 const U32 packname_utf8 = SvUTF8(sv);
3696 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3697 if (stash) return stash;
3699 if (!(iogv = gv_fetchpvn_flags(
3700 packname, packlen, packname_utf8, SVt_PVIO
3702 !(ob=MUTABLE_SV(GvIO(iogv))))
3704 /* this isn't the name of a filehandle either */
3707 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3708 "without a package or object reference",
3711 /* assume it's a package name */
3712 stash = gv_stashpvn(packname, packlen, packname_utf8);
3713 if (stash) return stash;
3714 else return MUTABLE_HV(sv);
3716 /* it _is_ a filehandle name -- replace with a reference */
3717 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3720 /* if we got here, ob should be an object or a glob */
3721 if (!ob || !(SvOBJECT(ob)
3722 || (isGV_with_GP(ob)
3723 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3726 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3727 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3728 ? newSVpvs_flags("DOES", SVs_TEMP)
3740 SV* const meth = TOPs;
3743 SV* const rmeth = SvRV(meth);
3744 if (SvTYPE(rmeth) == SVt_PVCV) {
3750 stash = opmethod_stash(meth);
3752 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3755 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3759 #define METHOD_CHECK_CACHE(stash,cache,meth) \
3760 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
3762 gv = MUTABLE_GV(HeVAL(he)); \
3763 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
3764 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
3766 XPUSHs(MUTABLE_SV(GvCV(gv))); \
3775 SV* const meth = cMETHOPx_meth(PL_op);
3776 HV* const stash = opmethod_stash(meth);
3778 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3779 METHOD_CHECK_CACHE(stash, stash, meth);
3782 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3785 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3794 SV* const meth = cMETHOPx_meth(PL_op);
3795 HV* const stash = CopSTASH(PL_curcop);
3796 /* Actually, SUPER doesn't need real object's (or class') stash at all,
3797 * as it uses CopSTASH. However, we must ensure that object(class) is
3798 * correct (this check is done by S_opmethod_stash) */
3799 opmethod_stash(meth);
3801 if ((cache = HvMROMETA(stash)->super)) {
3802 METHOD_CHECK_CACHE(stash, cache, meth);
3805 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3808 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3816 SV* const meth = cMETHOPx_meth(PL_op);
3817 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3818 opmethod_stash(meth); /* not used but needed for error checks */
3820 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3821 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3823 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3826 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3830 PP(pp_method_redir_super)
3835 SV* const meth = cMETHOPx_meth(PL_op);
3836 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3837 opmethod_stash(meth); /* not used but needed for error checks */
3839 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3840 else if ((cache = HvMROMETA(stash)->super)) {
3841 METHOD_CHECK_CACHE(stash, cache, meth);
3844 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3847 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3852 * ex: set ts=8 sts=4 sw=4 et: