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 + CX_CUR()->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) { /* {or,and,dor}assign */
134 SV * const temp = left;
135 left = right; right = temp;
137 assert(TAINTING_get || !TAINT_get);
138 if (UNLIKELY(TAINT_get) && !SvTAINTED(right))
140 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
142 SV * const cv = SvRV(right);
143 const U32 cv_type = SvTYPE(cv);
144 const bool is_gv = isGV_with_GP(left);
145 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
151 /* Can do the optimisation if left (LVALUE) is not a typeglob,
152 right (RVALUE) is a reference to something, and we're in void
154 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
155 /* Is the target symbol table currently empty? */
156 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
157 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
158 /* Good. Create a new proxy constant subroutine in the target.
159 The gv becomes a(nother) reference to the constant. */
160 SV *const value = SvRV(cv);
162 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
163 SvPCS_IMPORTED_on(gv);
165 SvREFCNT_inc_simple_void(value);
171 /* Need to fix things up. */
173 /* Need to fix GV. */
174 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
178 /* We've been returned a constant rather than a full subroutine,
179 but they expect a subroutine reference to apply. */
181 ENTER_with_name("sassign_coderef");
182 SvREFCNT_inc_void(SvRV(cv));
183 /* newCONSTSUB takes a reference count on the passed in SV
184 from us. We set the name to NULL, otherwise we get into
185 all sorts of fun as the reference to our new sub is
186 donated to the GV that we're about to assign to.
188 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
191 LEAVE_with_name("sassign_coderef");
193 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
195 First: ops for \&{"BONK"}; return us the constant in the
197 Second: ops for *{"BONK"} cause that symbol table entry
198 (and our reference to it) to be upgraded from RV
200 Thirdly: We get here. cv is actually PVGV now, and its
201 GvCV() is actually the subroutine we're looking for
203 So change the reference so that it points to the subroutine
204 of that typeglob, as that's what they were after all along.
206 GV *const upgraded = MUTABLE_GV(cv);
207 CV *const source = GvCV(upgraded);
210 assert(CvFLAGS(source) & CVf_CONST);
212 SvREFCNT_inc_simple_void_NN(source);
213 SvREFCNT_dec_NN(upgraded);
214 SvRV_set(right, MUTABLE_SV(source));
220 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
221 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
224 packWARN(WARN_MISC), "Useless assignment to a temporary"
226 SvSetMagicSV(left, right);
236 RETURNOP(cLOGOP->op_other);
238 RETURNOP(cLOGOP->op_next);
245 TAINT_NOT; /* Each statement is presumed innocent */
247 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
249 if (!(PL_op->op_flags & OPf_SPECIAL)) {
250 assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx));
258 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
263 const char *rpv = NULL;
265 bool rcopied = FALSE;
267 if (TARG == right && right != left) { /* $r = $l.$r */
268 rpv = SvPV_nomg_const(right, rlen);
269 rbyte = !DO_UTF8(right);
270 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
271 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
275 if (TARG != left) { /* not $l .= $r */
277 const char* const lpv = SvPV_nomg_const(left, llen);
278 lbyte = !DO_UTF8(left);
279 sv_setpvn(TARG, lpv, llen);
285 else { /* $l .= $r and left == TARG */
287 if ((left == right /* $l .= $l */
288 || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
289 && ckWARN(WARN_UNINITIALIZED)
295 SvPV_force_nomg_nolen(left);
297 lbyte = !DO_UTF8(left);
303 rpv = SvPV_nomg_const(right, rlen);
304 rbyte = !DO_UTF8(right);
306 if (lbyte != rbyte) {
308 sv_utf8_upgrade_nomg(TARG);
311 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
312 sv_utf8_upgrade_nomg(right);
313 rpv = SvPV_nomg_const(right, rlen);
316 sv_catpvn_nomg(TARG, rpv, rlen);
323 /* push the elements of av onto the stack.
324 * XXX Note that padav has similar code but without the mg_get().
325 * I suspect that the mg_get is no longer needed, but while padav
326 * differs, it can't share this function */
329 S_pushav(pTHX_ AV* const av)
332 const SSize_t maxarg = AvFILL(av) + 1;
334 if (UNLIKELY(SvRMAGICAL(av))) {
336 for (i=0; i < (PADOFFSET)maxarg; i++) {
337 SV ** const svp = av_fetch(av, i, FALSE);
338 /* See note in pp_helem, and bug id #27839 */
340 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
346 for (i=0; i < (PADOFFSET)maxarg; i++) {
347 SV * const sv = AvARRAY(av)[i];
348 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
356 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
361 PADOFFSET base = PL_op->op_targ;
362 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
363 if (PL_op->op_flags & OPf_SPECIAL) {
364 /* fake the RHS of my ($x,$y,..) = @_ */
366 S_pushav(aTHX_ GvAVn(PL_defgv));
370 /* note, this is only skipped for compile-time-known void cxt */
371 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
376 for (i = 0; i <count; i++)
377 *++SP = PAD_SV(base+i);
379 if (PL_op->op_private & OPpLVAL_INTRO) {
380 SV **svp = &(PAD_SVl(base));
381 const UV payload = (UV)(
382 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
383 | (count << SAVE_TIGHT_SHIFT)
384 | SAVEt_CLEARPADRANGE);
387 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
388 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
396 for (i = 0; i <count; i++)
397 SvPADSTALE_off(*svp++); /* mark lexical as active */
408 OP * const op = PL_op;
409 /* access PL_curpad once */
410 SV ** const padentry = &(PAD_SVl(op->op_targ));
415 PUTBACK; /* no pop/push after this, TOPs ok */
417 if (op->op_flags & OPf_MOD) {
418 if (op->op_private & OPpLVAL_INTRO)
419 if (!(op->op_private & OPpPAD_STATE))
420 save_clearsv(padentry);
421 if (op->op_private & OPpDEREF) {
422 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
423 than TARG reduces the scope of TARG, so it does not
424 span the call to save_clearsv, resulting in smaller
426 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
438 tryAMAGICunTARGETlist(iter_amg, 0);
439 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
441 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
442 if (!isGV_with_GP(PL_last_in_gv)) {
443 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
444 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
447 XPUSHs(MUTABLE_SV(PL_last_in_gv));
450 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
451 if (PL_last_in_gv == (GV *)&PL_sv_undef)
452 PL_last_in_gv = NULL;
454 assert(isGV_with_GP(PL_last_in_gv));
457 return do_readline();
465 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
469 (SvIOK_notUV(left) && SvIOK_notUV(right))
470 ? (SvIVX(left) == SvIVX(right))
471 : ( do_ncmp(left, right) == 0)
477 /* also used for: pp_i_preinc() */
481 SV *sv = *PL_stack_sp;
483 if (LIKELY(((sv->sv_flags &
484 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
485 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
487 && SvIVX(sv) != IV_MAX)
489 SvIV_set(sv, SvIVX(sv) + 1);
491 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */
498 /* also used for: pp_i_predec() */
502 SV *sv = *PL_stack_sp;
504 if (LIKELY(((sv->sv_flags &
505 (SVf_THINKFIRST|SVs_GMG|SVf_IVisUV|
506 SVf_IOK|SVf_NOK|SVf_POK|SVp_NOK|SVp_POK|SVf_ROK))
508 && SvIVX(sv) != IV_MIN)
510 SvIV_set(sv, SvIVX(sv) - 1);
512 else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */
519 /* also used for: pp_orassign() */
528 if (PL_op->op_type == OP_OR)
530 RETURNOP(cLOGOP->op_other);
535 /* also used for: pp_dor() pp_dorassign() */
542 const int op_type = PL_op->op_type;
543 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
548 if (UNLIKELY(!sv || !SvANY(sv))) {
549 if (op_type == OP_DOR)
551 RETURNOP(cLOGOP->op_other);
557 if (UNLIKELY(!sv || !SvANY(sv)))
562 switch (SvTYPE(sv)) {
564 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
568 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
572 if (CvROOT(sv) || CvXSUB(sv))
585 if(op_type == OP_DOR)
587 RETURNOP(cLOGOP->op_other);
589 /* assuming OP_DEFINED */
599 dSP; dATARGET; bool useleft; SV *svl, *svr;
601 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
605 #ifdef PERL_PRESERVE_IVUV
607 /* special-case some simple common cases */
608 if (!((svl->sv_flags|svr->sv_flags) & (SVf_IVisUV|SVs_GMG))) {
610 U32 flags = (svl->sv_flags & svr->sv_flags);
611 if (flags & SVf_IOK) {
612 /* both args are simple IVs */
617 topl = ((UV)il) >> (UVSIZE * 8 - 2);
618 topr = ((UV)ir) >> (UVSIZE * 8 - 2);
620 /* if both are in a range that can't under/overflow, do a
621 * simple integer add: if the top of both numbers
622 * are 00 or 11, then it's safe */
623 if (!( ((topl+1) | (topr+1)) & 2)) {
625 TARGi(il + ir, 0); /* args not GMG, so can't be tainted */
631 else if (flags & SVf_NOK) {
632 /* both args are NVs */
637 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
638 !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
639 && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
641 nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
644 /* nothing was lost by converting to IVs */
647 TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
655 useleft = USE_LEFT(svl);
656 /* We must see if we can perform the addition with integers if possible,
657 as the integer code detects overflow while the NV code doesn't.
658 If either argument hasn't had a numeric conversion yet attempt to get
659 the IV. It's important to do this now, rather than just assuming that
660 it's not IOK as a PV of "9223372036854775806" may not take well to NV
661 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
662 integer in case the second argument is IV=9223372036854775806
663 We can (now) rely on sv_2iv to do the right thing, only setting the
664 public IOK flag if the value in the NV (or PV) slot is truly integer.
666 A side effect is that this also aggressively prefers integer maths over
667 fp maths for integer values.
669 How to detect overflow?
671 C 99 section 6.2.6.1 says
673 The range of nonnegative values of a signed integer type is a subrange
674 of the corresponding unsigned integer type, and the representation of
675 the same value in each type is the same. A computation involving
676 unsigned operands can never overflow, because a result that cannot be
677 represented by the resulting unsigned integer type is reduced modulo
678 the number that is one greater than the largest value that can be
679 represented by the resulting type.
683 which I read as "unsigned ints wrap."
685 signed integer overflow seems to be classed as "exception condition"
687 If an exceptional condition occurs during the evaluation of an
688 expression (that is, if the result is not mathematically defined or not
689 in the range of representable values for its type), the behavior is
692 (6.5, the 5th paragraph)
694 I had assumed that on 2s complement machines signed arithmetic would
695 wrap, hence coded pp_add and pp_subtract on the assumption that
696 everything perl builds on would be happy. After much wailing and
697 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
698 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
699 unsigned code below is actually shorter than the old code. :-)
702 if (SvIV_please_nomg(svr)) {
703 /* Unless the left argument is integer in range we are going to have to
704 use NV maths. Hence only attempt to coerce the right argument if
705 we know the left is integer. */
713 /* left operand is undef, treat as zero. + 0 is identity,
714 Could SETi or SETu right now, but space optimise by not adding
715 lots of code to speed up what is probably a rarish case. */
717 /* Left operand is defined, so is it IV? */
718 if (SvIV_please_nomg(svl)) {
719 if ((auvok = SvUOK(svl)))
722 const IV aiv = SvIVX(svl);
725 auvok = 1; /* Now acting as a sign flag. */
727 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
734 bool result_good = 0;
737 bool buvok = SvUOK(svr);
742 const IV biv = SvIVX(svr);
747 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
749 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
750 else "IV" now, independent of how it came in.
751 if a, b represents positive, A, B negative, a maps to -A etc
756 all UV maths. negate result if A negative.
757 add if signs same, subtract if signs differ. */
763 /* Must get smaller */
769 /* result really should be -(auv-buv). as its negation
770 of true value, need to swap our result flag */
787 if (result <= (UV)IV_MIN)
788 SETi(result == (UV)IV_MIN
789 ? IV_MIN : -(IV)result);
791 /* result valid, but out of range for IV. */
796 } /* Overflow, drop through to NVs. */
801 useleft = USE_LEFT(svl);
805 NV value = SvNV_nomg(svr);
808 /* left operand is undef, treat as zero. + 0.0 is identity. */
812 SETn( value + SvNV_nomg(svl) );
818 /* also used for: pp_aelemfast_lex() */
823 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
824 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
825 const U32 lval = PL_op->op_flags & OPf_MOD;
826 const I8 key = (I8)PL_op->op_private;
830 assert(SvTYPE(av) == SVt_PVAV);
834 /* inlined av_fetch() for simple cases ... */
835 if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
836 sv = AvARRAY(av)[key];
843 /* ... else do it the hard way */
844 svp = av_fetch(av, key, lval);
845 sv = (svp ? *svp : &PL_sv_undef);
847 if (UNLIKELY(!svp && lval))
848 DIE(aTHX_ PL_no_aelem, (int)key);
850 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
860 do_join(TARG, *MARK, MARK, SP);
866 /* Oversized hot code. */
868 /* also used for: pp_say() */
872 dSP; dMARK; dORIGMARK;
876 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
880 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
883 if (MARK == ORIGMARK) {
884 /* If using default handle then we need to make space to
885 * pass object as 1st arg, so move other args up ...
889 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
892 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
894 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
895 | (PL_op->op_type == OP_SAY
896 ? TIED_METHOD_SAY : 0)), sp - mark);
899 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
900 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
903 SETERRNO(EBADF,RMS_IFI);
906 else if (!(fp = IoOFP(io))) {
908 report_wrongway_fh(gv, '<');
911 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
915 SV * const ofs = GvSV(PL_ofsgv); /* $, */
917 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
919 if (!do_print(*MARK, fp))
923 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
924 if (!do_print(GvSV(PL_ofsgv), fp)) {
933 if (!do_print(*MARK, fp))
941 if (PL_op->op_type == OP_SAY) {
942 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
945 else if (PL_ors_sv && SvOK(PL_ors_sv))
946 if (!do_print(PL_ors_sv, fp)) /* $\ */
949 if (IoFLAGS(io) & IOf_FLUSH)
950 if (PerlIO_flush(fp) == EOF)
960 XPUSHs(&PL_sv_undef);
965 /* also used for: pp_rv2hv() */
966 /* also called directly by pp_lvavref */
971 const U8 gimme = GIMME_V;
972 static const char an_array[] = "an ARRAY";
973 static const char a_hash[] = "a HASH";
974 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
975 || PL_op->op_type == OP_LVAVREF;
976 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
980 if (UNLIKELY(SvAMAGIC(sv))) {
981 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
984 if (UNLIKELY(SvTYPE(sv) != type))
985 /* diag_listed_as: Not an ARRAY reference */
986 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
987 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
988 && PL_op->op_private & OPpLVAL_INTRO))
989 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
991 else if (UNLIKELY(SvTYPE(sv) != type)) {
994 if (!isGV_with_GP(sv)) {
995 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
1001 gv = MUTABLE_GV(sv);
1003 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
1004 if (PL_op->op_private & OPpLVAL_INTRO)
1005 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
1007 if (PL_op->op_flags & OPf_REF) {
1011 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
1012 const I32 flags = is_lvalue_sub();
1013 if (flags && !(flags & OPpENTERSUB_INARGS)) {
1014 if (gimme != G_ARRAY)
1015 goto croak_cant_return;
1022 AV *const av = MUTABLE_AV(sv);
1023 /* The guts of pp_rv2av */
1024 if (gimme == G_ARRAY) {
1030 else if (gimme == G_SCALAR) {
1032 const SSize_t maxarg = AvFILL(av) + 1;
1036 /* The guts of pp_rv2hv */
1037 if (gimme == G_ARRAY) { /* array wanted */
1039 return Perl_do_kv(aTHX);
1041 else if ((PL_op->op_private & OPpTRUEBOOL
1042 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
1043 && block_gimme() == G_VOID ))
1044 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
1045 SETs(HvUSEDKEYS(MUTABLE_HV(sv)) ? &PL_sv_yes : &PL_sv_no);
1046 else if (gimme == G_SCALAR) {
1048 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
1055 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
1056 is_pp_rv2av ? "array" : "hash");
1061 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
1063 PERL_ARGS_ASSERT_DO_ODDBALL;
1066 if (ckWARN(WARN_MISC)) {
1068 if (oddkey == firstkey &&
1070 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
1071 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
1073 err = "Reference found where even-sized list expected";
1076 err = "Odd number of elements in hash assignment";
1077 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1084 /* Do a mark and sweep with the SVf_BREAK flag to detect elements which
1085 * are common to both the LHS and RHS of an aassign, and replace them
1086 * with copies. All these copies are made before the actual list assign is
1089 * For example in ($a,$b) = ($b,$a), assigning the value of the first RHS
1090 * element ($b) to the first LH element ($a), modifies $a; when the
1091 * second assignment is done, the second RH element now has the wrong
1092 * value. So we initially replace the RHS with ($b, mortalcopy($a)).
1093 * Note that we don't need to make a mortal copy of $b.
1095 * The algorithm below works by, for every RHS element, mark the
1096 * corresponding LHS target element with SVf_BREAK. Then if the RHS
1097 * element is found with SVf_BREAK set, it means it would have been
1098 * modified, so make a copy.
1099 * Note that by scanning both LHS and RHS in lockstep, we avoid
1100 * unnecessary copies (like $b above) compared with a naive
1101 * "mark all LHS; copy all marked RHS; unmark all LHS".
1103 * If the LHS element is a 'my' declaration' and has a refcount of 1, then
1104 * it can't be common and can be skipped.
1106 * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
1107 * that we thought we didn't need to call S_aassign_copy_common(), but we
1108 * have anyway for sanity checking. If we find we need to copy, then panic.
1111 PERL_STATIC_INLINE void
1112 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
1113 SV **firstrelem, SV **lastrelem
1122 SSize_t lcount = lastlelem - firstlelem + 1;
1123 bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
1124 bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
1125 bool copy_all = FALSE;
1127 assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
1128 assert(firstlelem < lastlelem); /* at least 2 LH elements */
1129 assert(firstrelem < lastrelem); /* at least 2 RH elements */
1133 /* we never have to copy the first RH element; it can't be corrupted
1134 * by assigning something to the corresponding first LH element.
1135 * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
1137 relem = firstrelem + 1;
1139 for (; relem <= lastrelem; relem++) {
1142 /* mark next LH element */
1144 if (--lcount >= 0) {
1147 if (UNLIKELY(!svl)) {/* skip AV alias marker */
1148 assert (lelem <= lastlelem);
1154 if (SvSMAGICAL(svl)) {
1157 if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
1160 /* this LH element will consume all further args;
1161 * no need to mark any further LH elements (if any).
1162 * But we still need to scan any remaining RHS elements;
1163 * set lcount negative to distinguish from lcount == 0,
1164 * so the loop condition continues being true
1167 lelem--; /* no need to unmark this element */
1169 else if (!(do_rc1 && SvREFCNT(svl) == 1) && !SvIMMORTAL(svl)) {
1170 SvFLAGS(svl) |= SVf_BREAK;
1174 /* don't check RH element if no SVf_BREAK flags set yet */
1181 /* see if corresponding RH element needs copying */
1187 if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
1188 U32 brk = (SvFLAGS(svr) & SVf_BREAK);
1192 /* op_dump(PL_op); */
1194 "panic: aassign skipped needed copy of common RH elem %"
1195 UVuf, (UV)(relem - firstrelem));
1199 TAINT_NOT; /* Each item is independent */
1201 /* Dear TODO test in t/op/sort.t, I love you.
1202 (It's relying on a panic, not a "semi-panic" from newSVsv()
1203 and then an assertion failure below.) */
1204 if (UNLIKELY(SvIS_FREED(svr))) {
1205 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1208 /* avoid break flag while copying; otherwise COW etc
1210 SvFLAGS(svr) &= ~SVf_BREAK;
1211 /* Not newSVsv(), as it does not allow copy-on-write,
1212 resulting in wasteful copies.
1213 Also, we use SV_NOSTEAL in case the SV is used more than
1214 once, e.g. (...) = (f())[0,0]
1215 Where the same SV appears twice on the RHS without a ref
1216 count bump. (Although I suspect that the SV won't be
1217 stealable here anyway - DAPM).
1219 *relem = sv_mortalcopy_flags(svr,
1220 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1221 /* ... but restore afterwards in case it's needed again,
1222 * e.g. ($a,$b,$c) = (1,$a,$a)
1224 SvFLAGS(svr) |= brk;
1236 while (lelem > firstlelem) {
1237 SV * const svl = *(--lelem);
1239 SvFLAGS(svl) &= ~SVf_BREAK;
1248 SV **lastlelem = PL_stack_sp;
1249 SV **lastrelem = PL_stack_base + POPMARK;
1250 SV **firstrelem = PL_stack_base + POPMARK + 1;
1251 SV **firstlelem = lastrelem + 1;
1256 /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
1257 * only need to save locally, not on the save stack */
1258 U16 old_delaymagic = PL_delaymagic;
1263 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1265 /* If there's a common identifier on both sides we have to take
1266 * special care that assigning the identifier on the left doesn't
1267 * clobber a value on the right that's used later in the list.
1270 /* at least 2 LH and RH elements, or commonality isn't an issue */
1271 if (firstlelem < lastlelem && firstrelem < lastrelem) {
1272 for (relem = firstrelem+1; relem <= lastrelem; relem++) {
1273 if (SvGMAGICAL(*relem))
1276 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1277 if (*lelem && SvSMAGICAL(*lelem))
1280 if ( PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
1281 if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
1282 /* skip the scan if all scalars have a ref count of 1 */
1283 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
1285 if (!sv || SvREFCNT(sv) == 1)
1287 if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
1294 S_aassign_copy_common(aTHX_
1295 firstlelem, lastlelem, firstrelem, lastrelem
1305 /* on debugging builds, do the scan even if we've concluded we
1306 * don't need to, then panic if we find commonality. Note that the
1307 * scanner assumes at least 2 elements */
1308 if (firstlelem < lastlelem && firstrelem < lastrelem) {
1319 if (relem > lastrelem)
1322 /* first lelem loop while there are still relems */
1323 while (LIKELY(lelem <= lastlelem)) {
1327 TAINT_NOT; /* Each item stands on its own, taintwise. */
1329 assert(relem <= lastrelem);
1330 if (UNLIKELY(!lsv)) {
1333 ASSUME(SvTYPE(lsv) == SVt_PVAV);
1336 switch (SvTYPE(lsv)) {
1341 SSize_t nelems = lastrelem - relem + 1;
1342 AV *ary = MUTABLE_AV(lsv);
1344 /* Assigning to an aggregate is tricky. First there is the
1345 * issue of commonality, e.g. @a = ($a[0]). Since the
1346 * stack isn't refcounted, clearing @a prior to storing
1347 * elements will free $a[0]. Similarly with
1348 * sub FETCH { $status[$_[1]] } @status = @tied[0,1];
1350 * The way to avoid these issues is to make the copy of each
1351 * SV (and we normally store a *copy* in the array) *before*
1352 * clearing the array. But this has a problem in that
1353 * if the code croaks during copying, the not-yet-stored copies
1354 * could leak. One way to avoid this is to make all the copies
1355 * mortal, but that's quite expensive.
1357 * The current solution to these issues is to use a chunk
1358 * of the tmps stack as a temporary refcounted-stack. SVs
1359 * will be put on there during processing to avoid leaks,
1360 * but will be removed again before the end of this block,
1361 * so free_tmps() is never normally called. Also, the
1362 * sv_refcnt of the SVs doesn't have to be manipulated, since
1363 * the ownership of 1 reference count is transferred directly
1364 * from the tmps stack to the AV when the SV is stored.
1366 * We disarm slots in the temps stack by storing PL_sv_undef
1367 * there: it doesn't matter if that SV's refcount is
1368 * repeatedly decremented during a croak. But usually this is
1369 * only an interim measure. By the end of this code block
1370 * we try where possible to not leave any PL_sv_undef's on the
1371 * tmps stack e.g. by shuffling newer entries down.
1373 * There is one case where we don't copy: non-magical
1374 * SvTEMP(sv)'s with a ref count of 1. The only owner of these
1375 * is on the tmps stack, so its safe to directly steal the SV
1376 * rather than copying. This is common in things like function
1377 * returns, map etc, which all return a list of such SVs.
1379 * Note however something like @a = (f())[0,0], where there is
1380 * a danger of the same SV being shared: this avoided because
1381 * when the SV is stored as $a[0], its ref count gets bumped,
1382 * so the RC==1 test fails and the second element is copied
1385 * We also use one slot in the tmps stack to hold an extra
1386 * ref to the array, to ensure it doesn't get prematurely
1387 * freed. Again, this is removed before the end of this block.
1389 * Note that OPpASSIGN_COMMON_AGG is used to flag a possible
1390 * @a = ($a[0]) case, but the current implementation uses the
1391 * same algorithm regardless, so ignores that flag. (It *is*
1392 * used in the hash branch below, however).
1395 /* Reserve slots for ary, plus the elems we're about to copy,
1396 * then protect ary and temporarily void the remaining slots
1397 * with &PL_sv_undef */
1398 EXTEND_MORTAL(nelems + 1);
1399 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(ary);
1400 tmps_base = PL_tmps_ix + 1;
1401 for (i = 0; i < nelems; i++)
1402 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1403 PL_tmps_ix += nelems;
1405 /* Make a copy of each RHS elem and save on the tmps_stack
1406 * (or pass through where we can optimise away the copy) */
1408 if (UNLIKELY(alias)) {
1409 U32 lval = (gimme == G_ARRAY)
1410 ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
1411 for (svp = relem; svp <= lastrelem; svp++) {
1416 DIE(aTHX_ "Assigned value is not a reference");
1417 if (SvTYPE(SvRV(rsv)) > SVt_PVLV)
1418 /* diag_listed_as: Assigned value is not %s reference */
1420 "Assigned value is not a SCALAR reference");
1422 *svp = rsv = sv_mortalcopy(rsv);
1423 /* XXX else check for weak refs? */
1424 rsv = SvREFCNT_inc_NN(SvRV(rsv));
1425 assert(tmps_base <= PL_tmps_max);
1426 PL_tmps_stack[tmps_base++] = rsv;
1430 for (svp = relem; svp <= lastrelem; svp++) {
1433 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1434 /* can skip the copy */
1435 SvREFCNT_inc_simple_void_NN(rsv);
1440 /* do get before newSV, in case it dies and leaks */
1443 /* see comment in S_aassign_copy_common about
1445 sv_setsv_flags(nsv, rsv,
1446 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1450 assert(tmps_base <= PL_tmps_max);
1451 PL_tmps_stack[tmps_base++] = rsv;
1455 if (SvRMAGICAL(ary) || AvFILLp(ary) >= 0) /* may be non-empty */
1458 /* store in the array, the SVs that are in the tmps stack */
1460 tmps_base -= nelems;
1462 if (SvMAGICAL(ary) || SvREADONLY(ary) || !AvREAL(ary)) {
1463 /* for arrays we can't cheat with, use the official API */
1464 av_extend(ary, nelems - 1);
1465 for (i = 0; i < nelems; i++) {
1466 SV **svp = &(PL_tmps_stack[tmps_base + i]);
1468 /* A tied store won't take ownership of rsv, so keep
1469 * the 1 refcnt on the tmps stack; otherwise disarm
1470 * the tmps stack entry */
1471 if (av_store(ary, i, rsv))
1472 *svp = &PL_sv_undef;
1473 /* av_store() may have added set magic to rsv */;
1476 /* disarm ary refcount: see comments below about leak */
1477 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1480 /* directly access/set the guts of the AV */
1481 SSize_t fill = nelems - 1;
1482 if (fill > AvMAX(ary))
1483 av_extend_guts(ary, fill, &AvMAX(ary), &AvALLOC(ary),
1485 AvFILLp(ary) = fill;
1486 Copy(&(PL_tmps_stack[tmps_base]), AvARRAY(ary), nelems, SV*);
1487 /* Quietly remove all the SVs from the tmps stack slots,
1488 * since ary has now taken ownership of the refcnt.
1489 * Also remove ary: which will now leak if we die before
1490 * the SvREFCNT_dec_NN(ary) below */
1491 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1492 Move(&PL_tmps_stack[tmps_base + nelems],
1493 &PL_tmps_stack[tmps_base - 1],
1494 PL_tmps_ix - (tmps_base + nelems) + 1,
1496 PL_tmps_ix -= (nelems + 1);
1499 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1500 /* its assumed @ISA set magic can't die and leak ary */
1501 SvSETMAGIC(MUTABLE_SV(ary));
1502 SvREFCNT_dec_NN(ary);
1504 relem = lastrelem + 1;
1508 case SVt_PVHV: { /* normal hash */
1514 SSize_t nelems = lastrelem - relem + 1;
1515 HV *hash = MUTABLE_HV(lsv);
1517 if (UNLIKELY(nelems & 1)) {
1518 do_oddball(lastrelem, relem);
1519 /* we have firstlelem to reuse, it's not needed any more */
1520 *++lastrelem = &PL_sv_undef;
1524 /* See the SVt_PVAV branch above for a long description of
1525 * how the following all works. The main difference for hashes
1526 * is that we treat keys and values separately (and have
1527 * separate loops for them): as for arrays, values are always
1528 * copied (except for the SvTEMP optimisation), since they
1529 * need to be stored in the hash; while keys are only
1530 * processed where they might get prematurely freed or
1533 /* tmps stack slots:
1534 * * reserve a slot for the hash keepalive;
1535 * * reserve slots for the hash values we're about to copy;
1536 * * preallocate for the keys we'll possibly copy or refcount bump
1538 * then protect hash and temporarily void the remaining
1539 * value slots with &PL_sv_undef */
1540 EXTEND_MORTAL(nelems + 1);
1542 /* convert to number of key/value pairs */
1545 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hash);
1546 tmps_base = PL_tmps_ix + 1;
1547 for (i = 0; i < nelems; i++)
1548 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1549 PL_tmps_ix += nelems;
1551 /* Make a copy of each RHS hash value and save on the tmps_stack
1552 * (or pass through where we can optimise away the copy) */
1554 for (svp = relem + 1; svp <= lastrelem; svp += 2) {
1557 if (SvTEMP(rsv) && !SvGMAGICAL(rsv) && SvREFCNT(rsv) == 1) {
1558 /* can skip the copy */
1559 SvREFCNT_inc_simple_void_NN(rsv);
1564 /* do get before newSV, in case it dies and leaks */
1567 /* see comment in S_aassign_copy_common about
1569 sv_setsv_flags(nsv, rsv,
1570 (SV_DO_COW_SVSETSV|SV_NOSTEAL));
1574 assert(tmps_base <= PL_tmps_max);
1575 PL_tmps_stack[tmps_base++] = rsv;
1577 tmps_base -= nelems;
1580 /* possibly protect keys */
1582 if (UNLIKELY(gimme == G_ARRAY)) {
1584 * @a = ((%h = ($$r, 1)), $r = "x");
1585 * $_++ for %h = (1,2,3,4);
1587 EXTEND_MORTAL(nelems);
1588 for (svp = relem; svp <= lastrelem; svp += 2)
1589 *svp = sv_mortalcopy_flags(*svp,
1590 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1592 else if (PL_op->op_private & OPpASSIGN_COMMON_AGG) {
1593 /* for possible commonality, e.g.
1595 * avoid premature freeing RHS keys by mortalising
1597 * For a magic element, make a copy so that its magic is
1598 * called *before* the hash is emptied (which may affect
1599 * a tied value for example).
1600 * In theory we should check for magic keys in all
1601 * cases, not just under OPpASSIGN_COMMON_AGG, but in
1602 * practice, !OPpASSIGN_COMMON_AGG implies only
1603 * constants or padtmps on the RHS.
1605 EXTEND_MORTAL(nelems);
1606 for (svp = relem; svp <= lastrelem; svp += 2) {
1608 if (UNLIKELY(SvGMAGICAL(rsv))) {
1610 *svp = sv_mortalcopy_flags(*svp,
1611 SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
1612 /* allow other branch to continue pushing
1613 * onto tmps stack without checking each time */
1614 n = (lastrelem - relem) >> 1;
1618 PL_tmps_stack[++PL_tmps_ix] =
1619 SvREFCNT_inc_simple_NN(rsv);
1623 if (SvRMAGICAL(hash) || HvUSEDKEYS(hash))
1626 /* now assign the keys and values to the hash */
1630 if (UNLIKELY(gimme == G_ARRAY)) {
1631 /* @a = (%h = (...)) etc */
1633 SV **topelem = relem;
1635 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1638 /* remove duplicates from list we return */
1639 if (!hv_exists_ent(hash, key, 0)) {
1640 /* copy key back: possibly to an earlier
1641 * stack location if we encountered dups earlier,
1642 * The values will be updated later
1647 /* A tied store won't take ownership of val, so keep
1648 * the 1 refcnt on the tmps stack; otherwise disarm
1649 * the tmps stack entry */
1650 if (hv_store_ent(hash, key, val, 0))
1651 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1654 /* hv_store_ent() may have added set magic to val */;
1657 if (topelem < svp) {
1658 /* at this point we have removed the duplicate key/value
1659 * pairs from the stack, but the remaining values may be
1660 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1661 * the (a 2), but the stack now probably contains
1662 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1663 * obliterates the earlier key. So refresh all values. */
1664 lastrelem = topelem - 1;
1665 while (relem < lastrelem) {
1667 he = hv_fetch_ent(hash, *relem++, 0, 0);
1668 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1674 for (i = 0, svp = relem; svp <= lastrelem; i++, svp++) {
1677 if (hv_store_ent(hash, key, val, 0))
1678 PL_tmps_stack[tmps_base + i] = &PL_sv_undef;
1681 /* hv_store_ent() may have added set magic to val */;
1687 /* there are still some 'live' recounts on the tmps stack
1688 * - usually caused by storing into a tied hash. So let
1689 * free_tmps() do the proper but slow job later.
1690 * Just disarm hash refcount: see comments below about leak
1692 PL_tmps_stack[tmps_base - 1] = &PL_sv_undef;
1695 /* Quietly remove all the SVs from the tmps stack slots,
1696 * since hash has now taken ownership of the refcnt.
1697 * Also remove hash: which will now leak if we die before
1698 * the SvREFCNT_dec_NN(hash) below */
1699 if (UNLIKELY(PL_tmps_ix >= tmps_base + nelems))
1700 Move(&PL_tmps_stack[tmps_base + nelems],
1701 &PL_tmps_stack[tmps_base - 1],
1702 PL_tmps_ix - (tmps_base + nelems) + 1,
1704 PL_tmps_ix -= (nelems + 1);
1707 SvREFCNT_dec_NN(hash);
1709 relem = lastrelem + 1;
1714 if (!SvIMMORTAL(lsv)) {
1718 SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 &&
1719 (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC)
1722 packWARN(WARN_MISC),
1723 "Useless assignment to a temporary"
1726 /* avoid freeing $$lsv if it might be needed for further
1727 * elements, e.g. ($ref, $foo) = (1, $$ref) */
1729 && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1)
1730 && lelem <= lastlelem
1733 SvREFCNT_inc_simple_void_NN(ref);
1734 /* an unrolled sv_2mortal */
1736 if (UNLIKELY(ix >= PL_tmps_max))
1737 /* speculatively grow enough to cover other
1739 ix = tmps_grow_p(ix + (lastlelem - lelem));
1740 PL_tmps_stack[ix] = ref;
1743 sv_setsv(lsv, *relem);
1747 if (++relem > lastrelem)
1756 /* simplified lelem loop for when there are no relems left */
1757 while (LIKELY(lelem <= lastlelem)) {
1760 TAINT_NOT; /* Each item stands on its own, taintwise. */
1762 if (UNLIKELY(!lsv)) {
1764 ASSUME(SvTYPE(lsv) == SVt_PVAV);
1767 switch (SvTYPE(lsv)) {
1769 if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) {
1771 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1777 if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv))
1782 if (!SvIMMORTAL(lsv)) {
1791 TAINT_NOT; /* result of list assign isn't tainted */
1793 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1794 /* Will be used to set PL_tainting below */
1795 Uid_t tmp_uid = PerlProc_getuid();
1796 Uid_t tmp_euid = PerlProc_geteuid();
1797 Gid_t tmp_gid = PerlProc_getgid();
1798 Gid_t tmp_egid = PerlProc_getegid();
1800 /* XXX $> et al currently silently ignore failures */
1801 if (PL_delaymagic & DM_UID) {
1802 #ifdef HAS_SETRESUID
1804 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1805 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1808 # ifdef HAS_SETREUID
1810 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1811 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1814 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1815 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1816 PL_delaymagic &= ~DM_RUID;
1818 # endif /* HAS_SETRUID */
1820 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1821 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1822 PL_delaymagic &= ~DM_EUID;
1824 # endif /* HAS_SETEUID */
1825 if (PL_delaymagic & DM_UID) {
1826 if (PL_delaymagic_uid != PL_delaymagic_euid)
1827 DIE(aTHX_ "No setreuid available");
1828 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1830 # endif /* HAS_SETREUID */
1831 #endif /* HAS_SETRESUID */
1833 tmp_uid = PerlProc_getuid();
1834 tmp_euid = PerlProc_geteuid();
1836 /* XXX $> et al currently silently ignore failures */
1837 if (PL_delaymagic & DM_GID) {
1838 #ifdef HAS_SETRESGID
1840 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1841 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1844 # ifdef HAS_SETREGID
1846 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1847 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1850 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1851 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1852 PL_delaymagic &= ~DM_RGID;
1854 # endif /* HAS_SETRGID */
1856 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1857 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1858 PL_delaymagic &= ~DM_EGID;
1860 # endif /* HAS_SETEGID */
1861 if (PL_delaymagic & DM_GID) {
1862 if (PL_delaymagic_gid != PL_delaymagic_egid)
1863 DIE(aTHX_ "No setregid available");
1864 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1866 # endif /* HAS_SETREGID */
1867 #endif /* HAS_SETRESGID */
1869 tmp_gid = PerlProc_getgid();
1870 tmp_egid = PerlProc_getegid();
1872 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1873 #ifdef NO_TAINT_SUPPORT
1874 PERL_UNUSED_VAR(tmp_uid);
1875 PERL_UNUSED_VAR(tmp_euid);
1876 PERL_UNUSED_VAR(tmp_gid);
1877 PERL_UNUSED_VAR(tmp_egid);
1880 PL_delaymagic = old_delaymagic;
1882 if (gimme == G_VOID)
1883 SP = firstrelem - 1;
1884 else if (gimme == G_SCALAR) {
1888 SETi(firstlelem - firstrelem);
1899 PMOP * const pm = cPMOP;
1900 REGEXP * rx = PM_GETRE(pm);
1901 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1902 SV * const rv = sv_newmortal();
1906 SvUPGRADE(rv, SVt_IV);
1907 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1908 loathe to use it here, but it seems to be the right fix. Or close.
1909 The key part appears to be that it's essential for pp_qr to return a new
1910 object (SV), which implies that there needs to be an effective way to
1911 generate a new SV from the existing SV that is pre-compiled in the
1913 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1916 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1917 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1918 *cvp = cv_clone(cv);
1919 SvREFCNT_dec_NN(cv);
1923 HV *const stash = gv_stashsv(pkg, GV_ADD);
1924 SvREFCNT_dec_NN(pkg);
1925 (void)sv_bless(rv, stash);
1928 if (UNLIKELY(RX_ISTAINTED(rx))) {
1930 SvTAINTED_on(SvRV(rv));
1943 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1946 const char *truebase; /* Start of string */
1947 REGEXP *rx = PM_GETRE(pm);
1949 const U8 gimme = GIMME_V;
1951 const I32 oldsave = PL_savestack_ix;
1952 I32 had_zerolen = 0;
1955 if (PL_op->op_flags & OPf_STACKED)
1964 PUTBACK; /* EVAL blocks need stack_sp. */
1965 /* Skip get-magic if this is a qr// clone, because regcomp has
1967 truebase = ReANY(rx)->mother_re
1968 ? SvPV_nomg_const(TARG, len)
1969 : SvPV_const(TARG, len);
1971 DIE(aTHX_ "panic: pp_match");
1972 strend = truebase + len;
1973 rxtainted = (RX_ISTAINTED(rx) ||
1974 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1977 /* We need to know this in case we fail out early - pos() must be reset */
1978 global = dynpm->op_pmflags & PMf_GLOBAL;
1980 /* PMdf_USED is set after a ?? matches once */
1983 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1985 pm->op_pmflags & PMf_USED
1988 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1992 /* handle the empty pattern */
1993 if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) {
1994 if (PL_curpm == PL_reg_curpm) {
1995 if (PL_curpm_under) {
1996 if (PL_curpm_under == PL_reg_curpm) {
1997 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
1999 pm = PL_curpm_under;
2008 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
2009 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
2010 UVuf " < %" IVdf ")\n",
2011 (UV)len, (IV)RX_MINLEN(rx)));
2015 /* get pos() if //g */
2017 mg = mg_find_mglob(TARG);
2018 if (mg && mg->mg_len >= 0) {
2019 curpos = MgBYTEPOS(mg, TARG, truebase, len);
2020 /* last time pos() was set, it was zero-length match */
2021 if (mg->mg_flags & MGf_MINMATCH)
2026 #ifdef PERL_SAWAMPERSAND
2029 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2030 || (dynpm->op_pmflags & PMf_KEEPCOPY)
2034 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
2035 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
2036 * only on the first iteration. Therefore we need to copy $' as well
2037 * as $&, to make the rest of the string available for captures in
2038 * subsequent iterations */
2039 if (! (global && gimme == G_ARRAY))
2040 r_flags |= REXEC_COPY_SKIP_POST;
2042 #ifdef PERL_SAWAMPERSAND
2043 if (dynpm->op_pmflags & PMf_KEEPCOPY)
2044 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
2045 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
2052 s = truebase + curpos;
2054 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
2055 had_zerolen, TARG, NULL, r_flags))
2059 if (dynpm->op_pmflags & PMf_ONCE)
2061 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
2063 dynpm->op_pmflags |= PMf_USED;
2067 RX_MATCH_TAINTED_on(rx);
2068 TAINT_IF(RX_MATCH_TAINTED(rx));
2072 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
2074 mg = sv_magicext_mglob(TARG);
2075 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
2076 if (RX_ZERO_LEN(rx))
2077 mg->mg_flags |= MGf_MINMATCH;
2079 mg->mg_flags &= ~MGf_MINMATCH;
2082 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
2083 LEAVE_SCOPE(oldsave);
2087 /* push captures on stack */
2090 const I32 nparens = RX_NPARENS(rx);
2091 I32 i = (global && !nparens) ? 1 : 0;
2093 SPAGAIN; /* EVAL blocks could move the stack. */
2094 EXTEND(SP, nparens + i);
2095 EXTEND_MORTAL(nparens + i);
2096 for (i = !i; i <= nparens; i++) {
2097 PUSHs(sv_newmortal());
2098 if (LIKELY((RX_OFFS(rx)[i].start != -1)
2099 && RX_OFFS(rx)[i].end != -1 ))
2101 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
2102 const char * const s = RX_OFFS(rx)[i].start + truebase;
2103 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
2104 || len < 0 || len > strend - s))
2105 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
2106 "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf,
2107 (long) i, (long) RX_OFFS(rx)[i].start,
2108 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
2109 sv_setpvn(*SP, s, len);
2110 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
2115 curpos = (UV)RX_OFFS(rx)[0].end;
2116 had_zerolen = RX_ZERO_LEN(rx);
2117 PUTBACK; /* EVAL blocks may use stack */
2118 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2121 LEAVE_SCOPE(oldsave);
2124 NOT_REACHED; /* NOTREACHED */
2127 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
2129 mg = mg_find_mglob(TARG);
2133 LEAVE_SCOPE(oldsave);
2134 if (gimme == G_ARRAY)
2140 Perl_do_readline(pTHX)
2142 dSP; dTARGETSTACKED;
2147 IO * const io = GvIO(PL_last_in_gv);
2148 const I32 type = PL_op->op_type;
2149 const U8 gimme = GIMME_V;
2152 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2154 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
2155 if (gimme == G_SCALAR) {
2157 SvSetSV_nosteal(TARG, TOPs);
2167 if (IoFLAGS(io) & IOf_ARGV) {
2168 if (IoFLAGS(io) & IOf_START) {
2170 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
2171 IoFLAGS(io) &= ~IOf_START;
2172 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
2173 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
2174 sv_setpvs(GvSVn(PL_last_in_gv), "-");
2175 SvSETMAGIC(GvSV(PL_last_in_gv));
2180 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2181 if (!fp) { /* Note: fp != IoIFP(io) */
2182 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
2185 else if (type == OP_GLOB)
2186 fp = Perl_start_glob(aTHX_ POPs, io);
2188 else if (type == OP_GLOB)
2190 else if (IoTYPE(io) == IoTYPE_WRONLY) {
2191 report_wrongway_fh(PL_last_in_gv, '>');
2195 if ((!io || !(IoFLAGS(io) & IOf_START))
2196 && ckWARN(WARN_CLOSED)
2199 report_evil_fh(PL_last_in_gv);
2201 if (gimme == G_SCALAR) {
2202 /* undef TARG, and push that undefined value */
2203 if (type != OP_RCATLINE) {
2204 sv_setsv(TARG,NULL);
2211 if (gimme == G_SCALAR) {
2213 if (type == OP_RCATLINE && SvGMAGICAL(sv))
2216 if (type == OP_RCATLINE)
2217 SvPV_force_nomg_nolen(sv);
2221 else if (isGV_with_GP(sv)) {
2222 SvPV_force_nomg_nolen(sv);
2224 SvUPGRADE(sv, SVt_PV);
2225 tmplen = SvLEN(sv); /* remember if already alloced */
2226 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
2227 /* try short-buffering it. Please update t/op/readline.t
2228 * if you change the growth length.
2233 if (type == OP_RCATLINE && SvOK(sv)) {
2235 SvPV_force_nomg_nolen(sv);
2241 sv = sv_2mortal(newSV(80));
2245 /* This should not be marked tainted if the fp is marked clean */
2246 #define MAYBE_TAINT_LINE(io, sv) \
2247 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
2252 /* delay EOF state for a snarfed empty file */
2253 #define SNARF_EOF(gimme,rs,io,sv) \
2254 (gimme != G_SCALAR || SvCUR(sv) \
2255 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
2259 if (!sv_gets(sv, fp, offset)
2261 || SNARF_EOF(gimme, PL_rs, io, sv)
2262 || PerlIO_error(fp)))
2264 PerlIO_clearerr(fp);
2265 if (IoFLAGS(io) & IOf_ARGV) {
2266 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
2269 (void)do_close(PL_last_in_gv, FALSE);
2271 else if (type == OP_GLOB) {
2272 if (!do_close(PL_last_in_gv, FALSE)) {
2273 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
2274 "glob failed (child exited with status %d%s)",
2275 (int)(STATUS_CURRENT >> 8),
2276 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
2279 if (gimme == G_SCALAR) {
2280 if (type != OP_RCATLINE) {
2281 SV_CHECK_THINKFIRST_COW_DROP(TARG);
2287 MAYBE_TAINT_LINE(io, sv);
2290 MAYBE_TAINT_LINE(io, sv);
2292 IoFLAGS(io) |= IOf_NOLINE;
2296 if (type == OP_GLOB) {
2300 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
2301 char * const tmps = SvEND(sv) - 1;
2302 if (*tmps == *SvPVX_const(PL_rs)) {
2304 SvCUR_set(sv, SvCUR(sv) - 1);
2307 for (t1 = SvPVX_const(sv); *t1; t1++)
2309 if (strchr("*%?", *t1))
2311 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
2314 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
2315 (void)POPs; /* Unmatched wildcard? Chuck it... */
2318 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
2319 if (ckWARN(WARN_UTF8)) {
2320 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
2321 const STRLEN len = SvCUR(sv) - offset;
2324 if (!is_utf8_string_loc(s, len, &f))
2325 /* Emulate :encoding(utf8) warning in the same case. */
2326 Perl_warner(aTHX_ packWARN(WARN_UTF8),
2327 "utf8 \"\\x%02X\" does not map to Unicode",
2328 f < (U8*)SvEND(sv) ? *f : 0);
2331 if (gimme == G_ARRAY) {
2332 if (SvLEN(sv) - SvCUR(sv) > 20) {
2333 SvPV_shrink_to_cur(sv);
2335 sv = sv_2mortal(newSV(80));
2338 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
2339 /* try to reclaim a bit of scalar space (only on 1st alloc) */
2340 const STRLEN new_len
2341 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
2342 SvPV_renew(sv, new_len);
2353 SV * const keysv = POPs;
2354 HV * const hv = MUTABLE_HV(POPs);
2355 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2356 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2358 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2359 bool preeminent = TRUE;
2361 if (SvTYPE(hv) != SVt_PVHV)
2368 /* If we can determine whether the element exist,
2369 * Try to preserve the existenceness of a tied hash
2370 * element by using EXISTS and DELETE if possible.
2371 * Fallback to FETCH and STORE otherwise. */
2372 if (SvCANEXISTDELETE(hv))
2373 preeminent = hv_exists_ent(hv, keysv, 0);
2376 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2377 svp = he ? &HeVAL(he) : NULL;
2379 if (!svp || !*svp || *svp == &PL_sv_undef) {
2383 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2385 lv = sv_newmortal();
2386 sv_upgrade(lv, SVt_PVLV);
2388 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
2389 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
2390 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2396 if (HvNAME_get(hv) && isGV(*svp))
2397 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
2398 else if (preeminent)
2399 save_helem_flags(hv, keysv, svp,
2400 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
2402 SAVEHDELETE(hv, keysv);
2404 else if (PL_op->op_private & OPpDEREF) {
2405 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2409 sv = (svp && *svp ? *svp : &PL_sv_undef);
2410 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
2411 * was to make C<local $tied{foo} = $tied{foo}> possible.
2412 * However, it seems no longer to be needed for that purpose, and
2413 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
2414 * would loop endlessly since the pos magic is getting set on the
2415 * mortal copy and lost. However, the copy has the effect of
2416 * triggering the get magic, and losing it altogether made things like
2417 * c<$tied{foo};> in void context no longer do get magic, which some
2418 * code relied on. Also, delayed triggering of magic on @+ and friends
2419 * meant the original regex may be out of scope by now. So as a
2420 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
2421 * being called too many times). */
2422 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
2429 /* a stripped-down version of Perl_softref2xv() for use by
2430 * pp_multideref(), which doesn't use PL_op->op_flags */
2433 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
2436 if (PL_op->op_private & HINT_STRICT_REFS) {
2438 Perl_die(aTHX_ PL_no_symref_sv, sv,
2439 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
2441 Perl_die(aTHX_ PL_no_usym, what);
2444 Perl_die(aTHX_ PL_no_usym, what);
2445 return gv_fetchsv_nomg(sv, GV_ADD, type);
2449 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
2450 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
2452 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
2453 * Each of these either contains a set of actions, or an argument, such as
2454 * an IV to use as an array index, or a lexical var to retrieve.
2455 * Several actions re stored per UV; we keep shifting new actions off the
2456 * one UV, and only reload when it becomes zero.
2461 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
2462 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
2463 UV actions = items->uv;
2466 /* this tells find_uninit_var() where we're up to */
2467 PL_multideref_pc = items;
2470 /* there are three main classes of action; the first retrieve
2471 * the initial AV or HV from a variable or the stack; the second
2472 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
2473 * the third an unrolled (/DREFHV, rv2hv, helem).
2475 switch (actions & MDEREF_ACTION_MASK) {
2478 actions = (++items)->uv;
2481 case MDEREF_AV_padav_aelem: /* $lex[...] */
2482 sv = PAD_SVl((++items)->pad_offset);
2485 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
2486 sv = UNOP_AUX_item_sv(++items);
2487 assert(isGV_with_GP(sv));
2488 sv = (SV*)GvAVn((GV*)sv);
2491 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
2496 goto do_AV_rv2av_aelem;
2499 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
2500 sv = UNOP_AUX_item_sv(++items);
2501 assert(isGV_with_GP(sv));
2502 sv = GvSVn((GV*)sv);
2503 goto do_AV_vivify_rv2av_aelem;
2505 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
2506 sv = PAD_SVl((++items)->pad_offset);
2509 do_AV_vivify_rv2av_aelem:
2510 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
2511 /* this is the OPpDEREF action normally found at the end of
2512 * ops like aelem, helem, rv2sv */
2513 sv = vivify_ref(sv, OPpDEREF_AV);
2517 /* this is basically a copy of pp_rv2av when it just has the
2520 if (LIKELY(SvROK(sv))) {
2521 if (UNLIKELY(SvAMAGIC(sv))) {
2522 sv = amagic_deref_call(sv, to_av_amg);
2525 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
2526 DIE(aTHX_ "Not an ARRAY reference");
2528 else if (SvTYPE(sv) != SVt_PVAV) {
2529 if (!isGV_with_GP(sv))
2530 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
2531 sv = MUTABLE_SV(GvAVn((GV*)sv));
2537 /* retrieve the key; this may be either a lexical or package
2538 * var (whose index/ptr is stored as an item) or a signed
2539 * integer constant stored as an item.
2542 IV elem = 0; /* to shut up stupid compiler warnings */
2545 assert(SvTYPE(sv) == SVt_PVAV);
2547 switch (actions & MDEREF_INDEX_MASK) {
2548 case MDEREF_INDEX_none:
2550 case MDEREF_INDEX_const:
2551 elem = (++items)->iv;
2553 case MDEREF_INDEX_padsv:
2554 elemsv = PAD_SVl((++items)->pad_offset);
2556 case MDEREF_INDEX_gvsv:
2557 elemsv = UNOP_AUX_item_sv(++items);
2558 assert(isGV_with_GP(elemsv));
2559 elemsv = GvSVn((GV*)elemsv);
2561 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
2562 && ckWARN(WARN_MISC)))
2563 Perl_warner(aTHX_ packWARN(WARN_MISC),
2564 "Use of reference \"%" SVf "\" as array index",
2566 /* the only time that S_find_uninit_var() needs this
2567 * is to determine which index value triggered the
2568 * undef warning. So just update it here. Note that
2569 * since we don't save and restore this var (e.g. for
2570 * tie or overload execution), its value will be
2571 * meaningless apart from just here */
2572 PL_multideref_pc = items;
2573 elem = SvIV(elemsv);
2578 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2580 if (!(actions & MDEREF_FLAG_last)) {
2581 SV** svp = av_fetch((AV*)sv, elem, 1);
2582 if (!svp || ! (sv=*svp))
2583 DIE(aTHX_ PL_no_aelem, elem);
2587 if (PL_op->op_private &
2588 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2590 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2591 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2594 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2595 sv = av_delete((AV*)sv, elem, discard);
2603 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2604 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2605 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2606 bool preeminent = TRUE;
2607 AV *const av = (AV*)sv;
2610 if (UNLIKELY(localizing)) {
2614 /* If we can determine whether the element exist,
2615 * Try to preserve the existenceness of a tied array
2616 * element by using EXISTS and DELETE if possible.
2617 * Fallback to FETCH and STORE otherwise. */
2618 if (SvCANEXISTDELETE(av))
2619 preeminent = av_exists(av, elem);
2622 svp = av_fetch(av, elem, lval && !defer);
2625 if (!svp || !(sv = *svp)) {
2628 DIE(aTHX_ PL_no_aelem, elem);
2629 len = av_tindex(av);
2630 sv = sv_2mortal(newSVavdefelem(av,
2631 /* Resolve a negative index now, unless it points
2632 * before the beginning of the array, in which
2633 * case record it for error reporting in
2634 * magic_setdefelem. */
2635 elem < 0 && len + elem >= 0
2636 ? len + elem : elem, 1));
2639 if (UNLIKELY(localizing)) {
2641 save_aelem(av, elem, svp);
2642 sv = *svp; /* may have changed */
2645 SAVEADELETE(av, elem);
2650 sv = (svp ? *svp : &PL_sv_undef);
2651 /* see note in pp_helem() */
2652 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2669 case MDEREF_HV_padhv_helem: /* $lex{...} */
2670 sv = PAD_SVl((++items)->pad_offset);
2673 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2674 sv = UNOP_AUX_item_sv(++items);
2675 assert(isGV_with_GP(sv));
2676 sv = (SV*)GvHVn((GV*)sv);
2679 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2684 goto do_HV_rv2hv_helem;
2687 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2688 sv = UNOP_AUX_item_sv(++items);
2689 assert(isGV_with_GP(sv));
2690 sv = GvSVn((GV*)sv);
2691 goto do_HV_vivify_rv2hv_helem;
2693 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2694 sv = PAD_SVl((++items)->pad_offset);
2697 do_HV_vivify_rv2hv_helem:
2698 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2699 /* this is the OPpDEREF action normally found at the end of
2700 * ops like aelem, helem, rv2sv */
2701 sv = vivify_ref(sv, OPpDEREF_HV);
2705 /* this is basically a copy of pp_rv2hv when it just has the
2706 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2709 if (LIKELY(SvROK(sv))) {
2710 if (UNLIKELY(SvAMAGIC(sv))) {
2711 sv = amagic_deref_call(sv, to_hv_amg);
2714 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2715 DIE(aTHX_ "Not a HASH reference");
2717 else if (SvTYPE(sv) != SVt_PVHV) {
2718 if (!isGV_with_GP(sv))
2719 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2720 sv = MUTABLE_SV(GvHVn((GV*)sv));
2726 /* retrieve the key; this may be either a lexical / package
2727 * var or a string constant, whose index/ptr is stored as an
2730 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2732 assert(SvTYPE(sv) == SVt_PVHV);
2734 switch (actions & MDEREF_INDEX_MASK) {
2735 case MDEREF_INDEX_none:
2738 case MDEREF_INDEX_const:
2739 keysv = UNOP_AUX_item_sv(++items);
2742 case MDEREF_INDEX_padsv:
2743 keysv = PAD_SVl((++items)->pad_offset);
2746 case MDEREF_INDEX_gvsv:
2747 keysv = UNOP_AUX_item_sv(++items);
2748 keysv = GvSVn((GV*)keysv);
2752 /* see comment above about setting this var */
2753 PL_multideref_pc = items;
2756 /* ensure that candidate CONSTs have been HEKified */
2757 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2758 || SvTYPE(keysv) >= SVt_PVMG
2761 || SvIsCOW_shared_hash(keysv));
2763 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2765 if (!(actions & MDEREF_FLAG_last)) {
2766 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2767 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2768 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2772 if (PL_op->op_private &
2773 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2775 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2776 sv = hv_exists_ent((HV*)sv, keysv, 0)
2777 ? &PL_sv_yes : &PL_sv_no;
2780 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2781 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2789 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2790 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2791 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2792 bool preeminent = TRUE;
2794 HV * const hv = (HV*)sv;
2797 if (UNLIKELY(localizing)) {
2801 /* If we can determine whether the element exist,
2802 * Try to preserve the existenceness of a tied hash
2803 * element by using EXISTS and DELETE if possible.
2804 * Fallback to FETCH and STORE otherwise. */
2805 if (SvCANEXISTDELETE(hv))
2806 preeminent = hv_exists_ent(hv, keysv, 0);
2809 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2810 svp = he ? &HeVAL(he) : NULL;
2814 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2818 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2819 lv = sv_newmortal();
2820 sv_upgrade(lv, SVt_PVLV);
2822 sv_magic(lv, key2 = newSVsv(keysv),
2823 PERL_MAGIC_defelem, NULL, 0);
2824 /* sv_magic() increments refcount */
2825 SvREFCNT_dec_NN(key2);
2826 LvTARG(lv) = SvREFCNT_inc_simple_NN(hv);
2832 if (HvNAME_get(hv) && isGV(sv))
2833 save_gp(MUTABLE_GV(sv),
2834 !(PL_op->op_flags & OPf_SPECIAL));
2835 else if (preeminent) {
2836 save_helem_flags(hv, keysv, svp,
2837 (PL_op->op_flags & OPf_SPECIAL)
2838 ? 0 : SAVEf_SETMAGIC);
2839 sv = *svp; /* may have changed */
2842 SAVEHDELETE(hv, keysv);
2847 sv = (svp && *svp ? *svp : &PL_sv_undef);
2848 /* see note in pp_helem() */
2849 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2858 actions >>= MDEREF_SHIFT;
2877 itersvp = CxITERVAR(cx);
2880 switch (CxTYPE(cx)) {
2882 case CXt_LOOP_LAZYSV: /* string increment */
2884 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2885 SV *end = cx->blk_loop.state_u.lazysv.end;
2886 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2887 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2889 const char *max = SvPV_const(end, maxlen);
2890 if (DO_UTF8(end) && IN_UNI_8_BIT)
2891 maxlen = sv_len_utf8_nomg(end);
2892 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2896 /* NB: on the first iteration, oldsv will have a ref count of at
2897 * least 2 (one extra from blk_loop.itersave), so the GV or pad
2898 * slot will get localised; on subsequent iterations the RC==1
2899 * optimisation may kick in and the SV will be reused. */
2900 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2901 /* safe to reuse old SV */
2902 sv_setsv(oldsv, cur);
2906 /* we need a fresh SV every time so that loop body sees a
2907 * completely new SV for closures/references to work as
2909 *itersvp = newSVsv(cur);
2910 SvREFCNT_dec(oldsv);
2912 if (strEQ(SvPVX_const(cur), max))
2913 sv_setiv(cur, 0); /* terminate next time */
2919 case CXt_LOOP_LAZYIV: /* integer increment */
2921 IV cur = cx->blk_loop.state_u.lazyiv.cur;
2922 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2926 /* see NB comment above */
2927 if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2928 /* safe to reuse old SV */
2930 if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV))
2933 /* Cheap SvIOK_only().
2934 * Assert that flags which SvIOK_only() would test or
2935 * clear can't be set, because we're SVt_IV */
2936 assert(!(SvFLAGS(oldsv) &
2937 (SVf_OOK|SVf_UTF8|(SVf_OK & ~(SVf_IOK|SVp_IOK)))));
2938 SvFLAGS(oldsv) |= (SVf_IOK|SVp_IOK);
2939 /* SvIV_set() where sv_any points to head */
2940 oldsv->sv_u.svu_iv = cur;
2944 sv_setiv(oldsv, cur);
2948 /* we need a fresh SV every time so that loop body sees a
2949 * completely new SV for closures/references to work as they
2951 *itersvp = newSViv(cur);
2952 SvREFCNT_dec(oldsv);
2955 if (UNLIKELY(cur == IV_MAX)) {
2956 /* Handle end of range at IV_MAX */
2957 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2959 ++cx->blk_loop.state_u.lazyiv.cur;
2963 case CXt_LOOP_LIST: /* for (1,2,3) */
2965 assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
2966 inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
2967 ix = (cx->blk_loop.state_u.stack.ix += inc);
2968 if (UNLIKELY(inc > 0
2969 ? ix > cx->blk_oldsp
2970 : ix <= cx->blk_loop.state_u.stack.basesp)
2974 sv = PL_stack_base[ix];
2976 goto loop_ary_common;
2978 case CXt_LOOP_ARY: /* for (@ary) */
2980 av = cx->blk_loop.state_u.ary.ary;
2981 inc = 1 - (PL_op->op_private & OPpITER_REVERSED);
2982 ix = (cx->blk_loop.state_u.ary.ix += inc);
2983 if (UNLIKELY(inc > 0
2989 if (UNLIKELY(SvRMAGICAL(av))) {
2990 SV * const * const svp = av_fetch(av, ix, FALSE);
2991 sv = svp ? *svp : NULL;
2994 sv = AvARRAY(av)[ix];
2999 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
3000 SvSetMagicSV(*itersvp, sv);
3005 if (UNLIKELY(SvIS_FREED(sv))) {
3007 Perl_croak(aTHX_ "Use of freed value in iteration");
3014 SvREFCNT_inc_simple_void_NN(sv);
3018 sv = newSVavdefelem(av, ix, 0);
3025 SvREFCNT_dec(oldsv);
3029 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
3037 /* pp_enteriter should have pre-extended the stack */
3038 assert(PL_stack_sp < PL_stack_max);
3039 *++PL_stack_sp =retsv;
3041 return PL_op->op_next;
3045 A description of how taint works in pattern matching and substitution.
3047 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
3048 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
3050 While the pattern is being assembled/concatenated and then compiled,
3051 PL_tainted will get set (via TAINT_set) if any component of the pattern
3052 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
3053 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
3054 TAINT_get). It will also be set if any component of the pattern matches
3055 based on locale-dependent behavior.
3057 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
3058 the pattern is marked as tainted. This means that subsequent usage, such
3059 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
3060 on the new pattern too.
3062 RXf_TAINTED_SEEN is used post-execution by the get magic code
3063 of $1 et al to indicate whether the returned value should be tainted.
3064 It is the responsibility of the caller of the pattern (i.e. pp_match,
3065 pp_subst etc) to set this flag for any other circumstances where $1 needs
3068 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
3070 There are three possible sources of taint
3072 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
3073 * the replacement string (or expression under /e)
3075 There are four destinations of taint and they are affected by the sources
3076 according to the rules below:
3078 * the return value (not including /r):
3079 tainted by the source string and pattern, but only for the
3080 number-of-iterations case; boolean returns aren't tainted;
3081 * the modified string (or modified copy under /r):
3082 tainted by the source string, pattern, and replacement strings;
3084 tainted by the pattern, and under 'use re "taint"', by the source
3086 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
3087 should always be unset before executing subsequent code.
3089 The overall action of pp_subst is:
3091 * at the start, set bits in rxtainted indicating the taint status of
3092 the various sources.
3094 * After each pattern execution, update the SUBST_TAINT_PAT bit in
3095 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
3096 pattern has subsequently become tainted via locale ops.
3098 * If control is being passed to pp_substcont to execute a /e block,
3099 save rxtainted in the CXt_SUBST block, for future use by
3102 * Whenever control is being returned to perl code (either by falling
3103 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
3104 use the flag bits in rxtainted to make all the appropriate types of
3105 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
3106 et al will appear tainted.
3108 pp_match is just a simpler version of the above.
3124 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
3125 See "how taint works" above */
3128 REGEXP *rx = PM_GETRE(pm);
3130 int force_on_match = 0;
3131 const I32 oldsave = PL_savestack_ix;
3133 bool doutf8 = FALSE; /* whether replacement is in utf8 */
3138 /* known replacement string? */
3139 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
3143 if (PL_op->op_flags & OPf_STACKED)
3152 SvGETMAGIC(TARG); /* must come before cow check */
3154 /* note that a string might get converted to COW during matching */
3155 was_cow = cBOOL(SvIsCOW(TARG));
3157 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3158 #ifndef PERL_ANY_COW
3160 sv_force_normal_flags(TARG,0);
3162 if ((SvREADONLY(TARG)
3163 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
3164 || SvTYPE(TARG) > SVt_PVLV)
3165 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
3166 Perl_croak_no_modify();
3170 orig = SvPV_nomg(TARG, len);
3171 /* note we don't (yet) force the var into being a string; if we fail
3172 * to match, we leave as-is; on successful match however, we *will*
3173 * coerce into a string, then repeat the match */
3174 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
3177 /* only replace once? */
3178 once = !(rpm->op_pmflags & PMf_GLOBAL);
3180 /* See "how taint works" above */
3183 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
3184 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
3185 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
3186 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3187 ? SUBST_TAINT_BOOLRET : 0));
3193 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
3195 strend = orig + len;
3196 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
3197 maxiters = 2 * slen + 10; /* We can match twice at each
3198 position, once with zero-length,
3199 second time with non-zero. */
3201 /* handle the empty pattern */
3202 if (!RX_PRELEN(rx) && PL_curpm && !ReANY(rx)->mother_re) {
3203 if (PL_curpm == PL_reg_curpm) {
3204 if (PL_curpm_under) {
3205 if (PL_curpm_under == PL_reg_curpm) {
3206 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
3208 pm = PL_curpm_under;
3217 #ifdef PERL_SAWAMPERSAND
3218 r_flags = ( RX_NPARENS(rx)
3220 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
3221 || (rpm->op_pmflags & PMf_KEEPCOPY)
3226 r_flags = REXEC_COPY_STR;
3229 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
3232 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
3233 LEAVE_SCOPE(oldsave);
3238 /* known replacement string? */
3240 /* replacement needing upgrading? */
3241 if (DO_UTF8(TARG) && !doutf8) {
3242 nsv = sv_newmortal();
3244 sv_utf8_upgrade(nsv);
3245 c = SvPV_const(nsv, clen);
3249 c = SvPV_const(dstr, clen);
3250 doutf8 = DO_UTF8(dstr);
3253 if (SvTAINTED(dstr))
3254 rxtainted |= SUBST_TAINT_REPL;
3261 /* can do inplace substitution? */
3266 && (I32)clen <= RX_MINLENRET(rx)
3268 || !(r_flags & REXEC_COPY_STR)
3269 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
3271 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
3272 && (!doutf8 || SvUTF8(TARG))
3273 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
3277 /* string might have got converted to COW since we set was_cow */
3278 if (SvIsCOW(TARG)) {
3279 if (!force_on_match)
3281 assert(SvVOK(TARG));
3284 if (force_on_match) {
3285 /* redo the first match, this time with the orig var
3286 * forced into being a string */
3288 orig = SvPV_force_nomg(TARG, len);
3294 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3295 rxtainted |= SUBST_TAINT_PAT;
3296 m = orig + RX_OFFS(rx)[0].start;
3297 d = orig + RX_OFFS(rx)[0].end;
3299 if (m - s > strend - d) { /* faster to shorten from end */
3302 Copy(c, m, clen, char);
3307 Move(d, m, i, char);
3311 SvCUR_set(TARG, m - s);
3313 else { /* faster from front */
3317 Move(s, d - i, i, char);
3320 Copy(c, d, clen, char);
3327 d = s = RX_OFFS(rx)[0].start + orig;
3330 if (UNLIKELY(iters++ > maxiters))
3331 DIE(aTHX_ "Substitution loop");
3332 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
3333 rxtainted |= SUBST_TAINT_PAT;
3334 m = RX_OFFS(rx)[0].start + orig;
3337 Move(s, d, i, char);
3341 Copy(c, d, clen, char);
3344 s = RX_OFFS(rx)[0].end + orig;
3345 } while (CALLREGEXEC(rx, s, strend, orig,
3346 s == m, /* don't match same null twice */
3348 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3351 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
3352 Move(s, d, i+1, char); /* include the NUL */
3362 if (force_on_match) {
3363 /* redo the first match, this time with the orig var
3364 * forced into being a string */
3366 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3367 /* I feel that it should be possible to avoid this mortal copy
3368 given that the code below copies into a new destination.
3369 However, I suspect it isn't worth the complexity of
3370 unravelling the C<goto force_it> for the small number of
3371 cases where it would be viable to drop into the copy code. */
3372 TARG = sv_2mortal(newSVsv(TARG));
3374 orig = SvPV_force_nomg(TARG, len);
3380 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
3381 rxtainted |= SUBST_TAINT_PAT;
3383 s = RX_OFFS(rx)[0].start + orig;
3384 dstr = newSVpvn_flags(orig, s-orig,
3385 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
3390 /* note that a whole bunch of local vars are saved here for
3391 * use by pp_substcont: here's a list of them in case you're
3392 * searching for places in this sub that uses a particular var:
3393 * iters maxiters r_flags oldsave rxtainted orig dstr targ
3394 * s m strend rx once */
3396 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
3400 if (UNLIKELY(iters++ > maxiters))
3401 DIE(aTHX_ "Substitution loop");
3402 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
3403 rxtainted |= SUBST_TAINT_PAT;
3404 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
3406 char *old_orig = orig;
3407 assert(RX_SUBOFFSET(rx) == 0);
3409 orig = RX_SUBBEG(rx);
3410 s = orig + (old_s - old_orig);
3411 strend = s + (strend - old_s);
3413 m = RX_OFFS(rx)[0].start + orig;
3414 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
3415 s = RX_OFFS(rx)[0].end + orig;
3417 /* replacement already stringified */
3419 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
3423 sv_catsv(dstr, repl);
3424 if (UNLIKELY(SvTAINTED(repl)))
3425 rxtainted |= SUBST_TAINT_REPL;
3429 } while (CALLREGEXEC(rx, s, strend, orig,
3430 s == m, /* Yields minend of 0 or 1 */
3432 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
3433 assert(strend >= s);
3434 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
3436 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
3437 /* From here on down we're using the copy, and leaving the original
3444 /* The match may make the string COW. If so, brilliant, because
3445 that's just saved us one malloc, copy and free - the regexp has
3446 donated the old buffer, and we malloc an entirely new one, rather
3447 than the regexp malloc()ing a buffer and copying our original,
3448 only for us to throw it away here during the substitution. */
3449 if (SvIsCOW(TARG)) {
3450 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
3456 SvPV_set(TARG, SvPVX(dstr));
3457 SvCUR_set(TARG, SvCUR(dstr));
3458 SvLEN_set(TARG, SvLEN(dstr));
3459 SvFLAGS(TARG) |= SvUTF8(dstr);
3460 SvPV_set(dstr, NULL);
3467 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
3468 (void)SvPOK_only_UTF8(TARG);
3471 /* See "how taint works" above */
3473 if ((rxtainted & SUBST_TAINT_PAT) ||
3474 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
3475 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
3477 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
3479 if (!(rxtainted & SUBST_TAINT_BOOLRET)
3480 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
3482 SvTAINTED_on(TOPs); /* taint return value */
3484 SvTAINTED_off(TOPs); /* may have got tainted earlier */
3486 /* needed for mg_set below */
3488 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
3492 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
3494 LEAVE_SCOPE(oldsave);
3503 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
3504 ++*PL_markstack_ptr;
3506 LEAVE_with_name("grep_item"); /* exit inner scope */
3509 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
3511 const U8 gimme = GIMME_V;
3513 LEAVE_with_name("grep"); /* exit outer scope */
3514 (void)POPMARK; /* pop src */
3515 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
3516 (void)POPMARK; /* pop dst */
3517 SP = PL_stack_base + POPMARK; /* pop original mark */
3518 if (gimme == G_SCALAR) {
3522 else if (gimme == G_ARRAY)
3529 ENTER_with_name("grep_item"); /* enter inner scope */
3532 src = PL_stack_base[TOPMARK];
3533 if (SvPADTMP(src)) {
3534 src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
3540 RETURNOP(cLOGOP->op_other);
3544 /* leave_adjust_stacks():
3546 * Process a scope's return args (in the range from_sp+1 .. PL_stack_sp),
3547 * positioning them at to_sp+1 onwards, and do the equivalent of a
3548 * FREEMPS and TAINT_NOT.
3550 * Not intended to be called in void context.
3552 * When leaving a sub, eval, do{} or other scope, the things that need
3553 * doing to process the return args are:
3554 * * in scalar context, only return the last arg (or PL_sv_undef if none);
3555 * * for the types of return that return copies of their args (such
3556 * as rvalue sub return), make a mortal copy of every return arg,
3557 * except where we can optimise the copy away without it being
3558 * semantically visible;
3559 * * make sure that the arg isn't prematurely freed; in the case of an
3560 * arg not copied, this may involve mortalising it. For example, in
3561 * C<sub f { my $x = ...; $x }>, $x would be freed when we do
3562 * CX_LEAVE_SCOPE(cx) unless it's protected or copied.
3564 * What condition to use when deciding whether to pass the arg through
3565 * or make a copy, is determined by the 'pass' arg; its valid values are:
3566 * 0: rvalue sub/eval exit
3567 * 1: other rvalue scope exit
3568 * 2: :lvalue sub exit in rvalue context
3569 * 3: :lvalue sub exit in lvalue context and other lvalue scope exits
3571 * There is a big issue with doing a FREETMPS. We would like to free any
3572 * temps created by the last statement which the sub executed, rather than
3573 * leaving them for the caller. In a situation where a sub call isn't
3574 * soon followed by a nextstate (e.g. nested recursive calls, a la
3575 * fibonacci()), temps can accumulate, causing memory and performance
3578 * On the other hand, we don't want to free any TEMPs which are keeping
3579 * alive any return args that we skipped copying; nor do we wish to undo
3580 * any mortalising done here.
3582 * The solution is to split the temps stack frame into two, with a cut
3583 * point delineating the two halves. We arrange that by the end of this
3584 * function, all the temps stack frame entries we wish to keep are in the
3585 * range PL_tmps_floor+1.. tmps_base-1, while the ones to free now are in
3586 * the range tmps_base .. PL_tmps_ix. During the course of this
3587 * function, tmps_base starts off as PL_tmps_floor+1, then increases
3588 * whenever we find or create a temp that we know should be kept. In
3589 * general the stuff above tmps_base is undecided until we reach the end,
3590 * and we may need a sort stage for that.
3592 * To determine whether a TEMP is keeping a return arg alive, every
3593 * arg that is kept rather than copied and which has the SvTEMP flag
3594 * set, has the flag temporarily unset, to mark it. At the end we scan
3595 * the temps stack frame above the cut for entries without SvTEMP and
3596 * keep them, while turning SvTEMP on again. Note that if we die before
3597 * the SvTEMPs flags are set again, its safe: at worst, subsequent use of
3598 * those SVs may be slightly less efficient.
3600 * In practice various optimisations for some common cases mean we can
3601 * avoid most of the scanning and swapping about with the temps stack.
3605 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
3609 SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
3612 PERL_ARGS_ASSERT_LEAVE_ADJUST_STACKS;
3616 if (gimme == G_ARRAY) {
3617 nargs = SP - from_sp;
3621 assert(gimme == G_SCALAR);
3622 if (UNLIKELY(from_sp >= SP)) {
3623 /* no return args */
3624 assert(from_sp == SP);
3626 *++SP = &PL_sv_undef;
3636 /* common code for G_SCALAR and G_ARRAY */
3638 tmps_base = PL_tmps_floor + 1;
3642 /* pointer version of tmps_base. Not safe across temp stack
3646 EXTEND_MORTAL(nargs); /* one big extend for worst-case scenario */
3647 tmps_basep = PL_tmps_stack + tmps_base;
3649 /* process each return arg */
3652 SV *sv = *from_sp++;
3654 assert(PL_tmps_ix + nargs < PL_tmps_max);
3656 /* PADTMPs with container set magic shouldn't appear in the
3657 * wild. This assert is more important for pp_leavesublv(),
3658 * but by testing for it here, we're more likely to catch
3659 * bad cases (what with :lvalue subs not being widely
3660 * deployed). The two issues are that for something like
3661 * sub :lvalue { $tied{foo} }
3663 * sub :lvalue { substr($foo,1,2) }
3664 * pp_leavesublv() will croak if the sub returns a PADTMP,
3665 * and currently functions like pp_substr() return a mortal
3666 * rather than using their PADTMP when returning a PVLV.
3667 * This is because the PVLV will hold a ref to $foo,
3668 * so $foo would get delayed in being freed while
3669 * the PADTMP SV remained in the PAD.
3670 * So if this assert fails it means either:
3671 * 1) there is pp code similar to pp_substr that is
3672 * returning a PADTMP instead of a mortal, and probably
3674 * 2) pp_leavesublv is making unwarranted assumptions
3675 * about always croaking on a PADTMP
3677 if (SvPADTMP(sv) && SvSMAGICAL(sv)) {
3679 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
3680 assert(PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type));
3686 pass == 0 ? (SvTEMP(sv) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3687 : pass == 1 ? ((SvTEMP(sv) || SvPADTMP(sv)) && !SvMAGICAL(sv) && SvREFCNT(sv) == 1)
3688 : pass == 2 ? (!SvPADTMP(sv))
3691 /* pass through: skip copy for logic or optimisation
3692 * reasons; instead mortalise it, except that ... */
3696 /* ... since this SV is an SvTEMP , we don't need to
3697 * re-mortalise it; instead we just need to ensure
3698 * that its existing entry in the temps stack frame
3699 * ends up below the cut and so avoids being freed
3700 * this time round. We mark it as needing to be kept
3701 * by temporarily unsetting SvTEMP; then at the end,
3702 * we shuffle any !SvTEMP entries on the tmps stack
3703 * back below the cut.
3704 * However, there's a significant chance that there's
3705 * a 1:1 correspondence between the first few (or all)
3706 * elements in the return args stack frame and those
3707 * in the temps stack frame; e,g.:
3708 * sub f { ....; map {...} .... },
3709 * or if we're exiting multiple scopes and one of the
3710 * inner scopes has already made mortal copies of each
3713 * If so, this arg sv will correspond to the next item
3714 * on the tmps stack above the cut, and so can be kept
3715 * merely by moving the cut boundary up one, rather
3716 * than messing with SvTEMP. If all args are 1:1 then
3717 * we can avoid the sorting stage below completely.
3719 * If there are no items above the cut on the tmps
3720 * stack, then the SvTEMP must comne from an item
3721 * below the cut, so there's nothing to do.
3723 if (tmps_basep <= &PL_tmps_stack[PL_tmps_ix]) {
3724 if (sv == *tmps_basep)
3730 else if (!SvPADTMP(sv)) {
3731 /* mortalise arg to avoid it being freed during save
3732 * stack unwinding. Pad tmps don't need mortalising as
3733 * they're never freed. This is the equivalent of
3734 * sv_2mortal(SvREFCNT_inc(sv)), except that:
3735 * * it assumes that the temps stack has already been
3737 * * it puts the new item at the cut rather than at
3738 * ++PL_tmps_ix, moving the previous occupant there
3741 if (!SvIMMORTAL(sv)) {
3742 SvREFCNT_inc_simple_void_NN(sv);
3744 /* Note that if there's nothing above the cut,
3745 * this copies the garbage one slot above
3746 * PL_tmps_ix onto itself. This is harmless (the
3747 * stack's already been extended), but might in
3748 * theory trigger warnings from tools like ASan
3750 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3756 /* Make a mortal copy of the SV.
3757 * The following code is the equivalent of sv_mortalcopy()
3759 * * it assumes the temps stack has already been extended;
3760 * * it optimises the copying for some simple SV types;
3761 * * it puts the new item at the cut rather than at
3762 * ++PL_tmps_ix, moving the previous occupant there
3765 SV *newsv = newSV(0);
3767 PL_tmps_stack[++PL_tmps_ix] = *tmps_basep;
3768 /* put it on the tmps stack early so it gets freed if we die */
3769 *tmps_basep++ = newsv;
3772 if (SvTYPE(sv) <= SVt_IV) {
3773 /* arg must be one of undef, IV/UV, or RV: skip
3774 * sv_setsv_flags() and do the copy directly */
3776 U32 srcflags = SvFLAGS(sv);
3778 assert(!SvGMAGICAL(sv));
3779 if (srcflags & (SVf_IOK|SVf_ROK)) {
3780 SET_SVANY_FOR_BODYLESS_IV(newsv);
3782 if (srcflags & SVf_ROK) {
3783 newsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(sv));
3784 /* SV type plus flags */
3785 dstflags = (SVt_IV|SVf_ROK|SVs_TEMP);
3788 /* both src and dst are <= SVt_IV, so sv_any
3789 * points to the head; so access the heads
3790 * directly rather than going via sv_any.
3792 assert( &(sv->sv_u.svu_iv)
3793 == &(((XPVIV*) SvANY(sv))->xiv_iv));
3794 assert( &(newsv->sv_u.svu_iv)
3795 == &(((XPVIV*) SvANY(newsv))->xiv_iv));
3796 newsv->sv_u.svu_iv = sv->sv_u.svu_iv;
3797 /* SV type plus flags */
3798 dstflags = (SVt_IV|SVf_IOK|SVp_IOK|SVs_TEMP
3799 |(srcflags & SVf_IVisUV));
3803 assert(!(srcflags & SVf_OK));
3804 dstflags = (SVt_NULL|SVs_TEMP); /* SV type plus flags */
3806 SvFLAGS(newsv) = dstflags;
3810 /* do the full sv_setsv() */
3814 old_base = tmps_basep - PL_tmps_stack;
3816 sv_setsv_flags(newsv, sv, SV_DO_COW_SVSETSV);
3817 /* the mg_get or sv_setsv might have created new temps
3818 * or realloced the tmps stack; regrow and reload */
3819 EXTEND_MORTAL(nargs);
3820 tmps_basep = PL_tmps_stack + old_base;
3821 TAINT_NOT; /* Each item is independent */
3827 /* If there are any temps left above the cut, we need to sort
3828 * them into those to keep and those to free. The only ones to
3829 * keep are those for which we've temporarily unset SvTEMP.
3830 * Work inwards from the two ends at tmps_basep .. PL_tmps_ix,
3831 * swapping pairs as necessary. Stop when we meet in the middle.
3834 SV **top = PL_tmps_stack + PL_tmps_ix;
3835 while (tmps_basep <= top) {
3848 tmps_base = tmps_basep - PL_tmps_stack;
3851 PL_stack_sp = to_sp;
3853 /* unrolled FREETMPS() but using tmps_base-1 rather than PL_tmps_floor */
3854 while (PL_tmps_ix >= tmps_base) {
3855 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
3857 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
3861 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
3867 /* also tail-called by pp_return */
3877 assert(CxTYPE(cx) == CXt_SUB);
3879 if (CxMULTICALL(cx)) {
3880 /* entry zero of a stack is always PL_sv_undef, which
3881 * simplifies converting a '()' return into undef in scalar context */
3882 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
3886 gimme = cx->blk_gimme;
3887 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
3889 if (gimme == G_VOID)
3890 PL_stack_sp = oldsp;
3892 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
3895 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
3897 retop = cx->blk_sub.retop;
3904 /* clear (if possible) or abandon the current @_. If 'abandon' is true,
3905 * forces an abandon */
3908 Perl_clear_defarray(pTHX_ AV* av, bool abandon)
3910 const SSize_t fill = AvFILLp(av);
3912 PERL_ARGS_ASSERT_CLEAR_DEFARRAY;
3914 if (LIKELY(!abandon && SvREFCNT(av) == 1 && !SvMAGICAL(av))) {
3919 AV *newav = newAV();
3920 av_extend(newav, fill);
3921 AvREIFY_only(newav);
3922 PAD_SVl(0) = MUTABLE_SV(newav);
3923 SvREFCNT_dec_NN(av);
3934 I32 old_savestack_ix;
3939 /* Locate the CV to call:
3940 * - most common case: RV->CV: f(), $ref->():
3941 * note that if a sub is compiled before its caller is compiled,
3942 * the stash entry will be a ref to a CV, rather than being a GV.
3943 * - second most common case: CV: $ref->method()
3946 /* a non-magic-RV -> CV ? */
3947 if (LIKELY( (SvFLAGS(sv) & (SVf_ROK|SVs_GMG)) == SVf_ROK)) {
3948 cv = MUTABLE_CV(SvRV(sv));
3949 if (UNLIKELY(SvOBJECT(cv))) /* might be overloaded */
3953 cv = MUTABLE_CV(sv);
3956 if (UNLIKELY(SvTYPE(cv) != SVt_PVCV)) {
3957 /* handle all the weird cases */
3958 switch (SvTYPE(sv)) {
3960 if (!isGV_with_GP(sv))
3964 cv = GvCVu((const GV *)sv);
3965 if (UNLIKELY(!cv)) {
3967 cv = sv_2cv(sv, &stash, &gv, 0);
3969 old_savestack_ix = PL_savestack_ix;
3980 if (UNLIKELY(SvAMAGIC(sv))) {
3981 sv = amagic_deref_call(sv, to_cv_amg);
3982 /* Don't SPAGAIN here. */
3988 if (UNLIKELY(!SvOK(sv)))
3989 DIE(aTHX_ PL_no_usym, "a subroutine");
3991 if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
3992 if (PL_op->op_flags & OPf_STACKED) /* hasargs */
3993 SP = PL_stack_base + POPMARK;
3996 if (GIMME_V == G_SCALAR)
3997 PUSHs(&PL_sv_undef);
4001 sym = SvPV_nomg_const(sv, len);
4002 if (PL_op->op_private & HINT_STRICT_REFS)
4003 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
4004 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
4007 cv = MUTABLE_CV(SvRV(sv));
4008 if (LIKELY(SvTYPE(cv) == SVt_PVCV))
4014 DIE(aTHX_ "Not a CODE reference");
4018 /* At this point we want to save PL_savestack_ix, either by doing a
4019 * cx_pushsub(), or for XS, doing an ENTER. But we don't yet know the final
4020 * CV we will be using (so we don't know whether its XS, so we can't
4021 * cx_pushsub() or ENTER yet), and determining cv may itself push stuff on
4022 * the save stack. So remember where we are currently on the save
4023 * stack, and later update the CX or scopestack entry accordingly. */
4024 old_savestack_ix = PL_savestack_ix;
4026 /* these two fields are in a union. If they ever become separate,
4027 * we have to test for both of them being null below */
4029 assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
4030 while (UNLIKELY(!CvROOT(cv))) {
4034 /* anonymous or undef'd function leaves us no recourse */
4035 if (CvLEXICAL(cv) && CvHASGV(cv))
4036 DIE(aTHX_ "Undefined subroutine &%" SVf " called",
4037 SVfARG(cv_name(cv, NULL, 0)));
4038 if (CvANON(cv) || !CvHASGV(cv)) {
4039 DIE(aTHX_ "Undefined subroutine called");
4042 /* autoloaded stub? */
4043 if (cv != GvCV(gv = CvGV(cv))) {
4046 /* should call AUTOLOAD now? */
4049 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
4050 (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
4051 |(PL_op->op_flags & OPf_REF
4052 ? GV_AUTOLOAD_ISMETHOD
4054 cv = autogv ? GvCV(autogv) : NULL;
4057 sub_name = sv_newmortal();
4058 gv_efullname3(sub_name, gv, NULL);
4059 DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name));
4063 /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */
4064 if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE))
4065 DIE(aTHX_ "Closure prototype called");
4067 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
4070 Perl_get_db_sub(aTHX_ &sv, cv);
4072 PL_curcopdb = PL_curcop;
4074 /* check for lsub that handles lvalue subroutines */
4075 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
4076 /* if lsub not found then fall back to DB::sub */
4077 if (!cv) cv = GvCV(PL_DBsub);
4079 cv = GvCV(PL_DBsub);
4082 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
4083 DIE(aTHX_ "No DB::sub routine defined");
4086 if (!(CvISXSUB(cv))) {
4087 /* This path taken at least 75% of the time */
4094 /* keep PADTMP args alive throughout the call (we need to do this
4095 * because @_ isn't refcounted). Note that we create the mortals
4096 * in the caller's tmps frame, so they won't be freed until after
4097 * we return from the sub.
4106 *svp = sv = sv_mortalcopy(sv);
4112 cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix);
4113 hasargs = cBOOL(PL_op->op_flags & OPf_STACKED);
4114 cx_pushsub(cx, cv, PL_op->op_next, hasargs);
4116 padlist = CvPADLIST(cv);
4117 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2))
4118 pad_push(padlist, depth);
4119 PAD_SET_CUR_NOSAVE(padlist, depth);
4120 if (LIKELY(hasargs)) {
4121 AV *const av = MUTABLE_AV(PAD_SVl(0));
4125 defavp = &GvAV(PL_defgv);
4126 cx->blk_sub.savearray = *defavp;
4127 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
4129 /* it's the responsibility of whoever leaves a sub to ensure
4130 * that a clean, empty AV is left in pad[0]. This is normally
4131 * done by cx_popsub() */
4132 assert(!AvREAL(av) && AvFILLp(av) == -1);
4135 if (UNLIKELY(items - 1 > AvMAX(av))) {
4136 SV **ary = AvALLOC(av);
4137 Renew(ary, items, SV*);
4138 AvMAX(av) = items - 1;
4143 Copy(MARK+1,AvARRAY(av),items,SV*);
4144 AvFILLp(av) = items - 1;
4146 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4148 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4149 SVfARG(cv_name(cv, NULL, 0)));
4150 /* warning must come *after* we fully set up the context
4151 * stuff so that __WARN__ handlers can safely dounwind()
4154 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
4155 && ckWARN(WARN_RECURSION)
4156 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
4157 sub_crush_depth(cv);
4158 RETURNOP(CvSTART(cv));
4161 SSize_t markix = TOPMARK;
4165 /* pretend we did the ENTER earlier */
4166 PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix;
4171 if (UNLIKELY(((PL_op->op_private
4172 & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
4173 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
4175 DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf,
4176 SVfARG(cv_name(cv, NULL, 0)));
4178 if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) {
4179 /* Need to copy @_ to stack. Alternative may be to
4180 * switch stack to @_, and copy return values
4181 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
4182 AV * const av = GvAV(PL_defgv);
4183 const SSize_t items = AvFILL(av) + 1;
4187 const bool m = cBOOL(SvRMAGICAL(av));
4188 /* Mark is at the end of the stack. */
4190 for (; i < items; ++i)
4194 SV ** const svp = av_fetch(av, i, 0);
4195 sv = svp ? *svp : NULL;
4197 else sv = AvARRAY(av)[i];
4198 if (sv) SP[i+1] = sv;
4200 SP[i+1] = newSVavdefelem(av, i, 1);
4208 SV **mark = PL_stack_base + markix;
4209 SSize_t items = SP - mark;
4212 if (*mark && SvPADTMP(*mark)) {
4213 *mark = sv_mortalcopy(*mark);
4217 /* We assume first XSUB in &DB::sub is the called one. */
4218 if (UNLIKELY(PL_curcopdb)) {
4219 SAVEVPTR(PL_curcop);
4220 PL_curcop = PL_curcopdb;
4223 /* Do we need to open block here? XXXX */
4225 /* calculate gimme here as PL_op might get changed and then not
4226 * restored until the LEAVE further down */
4227 is_scalar = (GIMME_V == G_SCALAR);
4229 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
4231 CvXSUB(cv)(aTHX_ cv);
4233 /* Enforce some sanity in scalar context. */
4235 SV **svp = PL_stack_base + markix + 1;
4236 if (svp != PL_stack_sp) {
4237 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
4247 Perl_sub_crush_depth(pTHX_ CV *cv)
4249 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
4252 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
4254 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"",
4255 SVfARG(cv_name(cv,NULL,0)));
4261 /* like croak, but report in context of caller */
4264 Perl_croak_caller(const char *pat, ...)
4268 const PERL_CONTEXT *cx = caller_cx(0, NULL);
4270 /* make error appear at call site */
4272 PL_curcop = cx->blk_oldcop;
4274 va_start(args, pat);
4276 NOT_REACHED; /* NOTREACHED */
4285 SV* const elemsv = POPs;
4286 IV elem = SvIV(elemsv);
4287 AV *const av = MUTABLE_AV(POPs);
4288 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
4289 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
4290 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4291 bool preeminent = TRUE;
4294 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
4295 Perl_warner(aTHX_ packWARN(WARN_MISC),
4296 "Use of reference \"%" SVf "\" as array index",
4298 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
4301 if (UNLIKELY(localizing)) {
4305 /* If we can determine whether the element exist,
4306 * Try to preserve the existenceness of a tied array
4307 * element by using EXISTS and DELETE if possible.
4308 * Fallback to FETCH and STORE otherwise. */
4309 if (SvCANEXISTDELETE(av))
4310 preeminent = av_exists(av, elem);
4313 svp = av_fetch(av, elem, lval && !defer);
4315 #ifdef PERL_MALLOC_WRAP
4316 if (SvUOK(elemsv)) {
4317 const UV uv = SvUV(elemsv);
4318 elem = uv > IV_MAX ? IV_MAX : uv;
4320 else if (SvNOK(elemsv))
4321 elem = (IV)SvNV(elemsv);
4323 static const char oom_array_extend[] =
4324 "Out of memory during array extend"; /* Duplicated in av.c */
4325 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
4328 if (!svp || !*svp) {
4331 DIE(aTHX_ PL_no_aelem, elem);
4332 len = av_tindex(av);
4333 mPUSHs(newSVavdefelem(av,
4334 /* Resolve a negative index now, unless it points before the
4335 beginning of the array, in which case record it for error
4336 reporting in magic_setdefelem. */
4337 elem < 0 && len + elem >= 0 ? len + elem : elem,
4341 if (UNLIKELY(localizing)) {
4343 save_aelem(av, elem, svp);
4345 SAVEADELETE(av, elem);
4347 else if (PL_op->op_private & OPpDEREF) {
4348 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
4352 sv = (svp ? *svp : &PL_sv_undef);
4353 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
4360 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
4362 PERL_ARGS_ASSERT_VIVIFY_REF;
4367 Perl_croak_no_modify();
4368 prepare_SV_for_RV(sv);
4371 SvRV_set(sv, newSV(0));
4374 SvRV_set(sv, MUTABLE_SV(newAV()));
4377 SvRV_set(sv, MUTABLE_SV(newHV()));
4384 if (SvGMAGICAL(sv)) {
4385 /* copy the sv without magic to prevent magic from being
4387 SV* msv = sv_newmortal();
4388 sv_setsv_nomg(msv, sv);
4394 PERL_STATIC_INLINE HV *
4395 S_opmethod_stash(pTHX_ SV* meth)
4400 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
4401 ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a "
4402 "package or object reference", SVfARG(meth)),
4404 : *(PL_stack_base + TOPMARK + 1);
4406 PERL_ARGS_ASSERT_OPMETHOD_STASH;
4410 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value",
4413 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
4414 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
4415 stash = gv_stashsv(sv, GV_CACHE_ONLY);
4416 if (stash) return stash;
4420 ob = MUTABLE_SV(SvRV(sv));
4421 else if (!SvOK(sv)) goto undefined;
4422 else if (isGV_with_GP(sv)) {
4424 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
4425 "without a package or object reference",
4428 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
4429 assert(!LvTARGLEN(ob));
4433 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
4436 /* this isn't a reference */
4439 const char * const packname = SvPV_nomg_const(sv, packlen);
4440 const U32 packname_utf8 = SvUTF8(sv);
4441 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
4442 if (stash) return stash;
4444 if (!(iogv = gv_fetchpvn_flags(
4445 packname, packlen, packname_utf8, SVt_PVIO
4447 !(ob=MUTABLE_SV(GvIO(iogv))))
4449 /* this isn't the name of a filehandle either */
4452 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" "
4453 "without a package or object reference",
4456 /* assume it's a package name */
4457 stash = gv_stashpvn(packname, packlen, packname_utf8);
4458 if (stash) return stash;
4459 else return MUTABLE_HV(sv);
4461 /* it _is_ a filehandle name -- replace with a reference */
4462 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
4465 /* if we got here, ob should be an object or a glob */
4466 if (!ob || !(SvOBJECT(ob)
4467 || (isGV_with_GP(ob)
4468 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
4471 Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference",
4472 SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES)
4473 ? newSVpvs_flags("DOES", SVs_TEMP)
4485 SV* const meth = TOPs;
4488 SV* const rmeth = SvRV(meth);
4489 if (SvTYPE(rmeth) == SVt_PVCV) {
4495 stash = opmethod_stash(meth);
4497 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
4500 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4504 #define METHOD_CHECK_CACHE(stash,cache,meth) \
4505 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
4507 gv = MUTABLE_GV(HeVAL(he)); \
4508 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
4509 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
4511 XPUSHs(MUTABLE_SV(GvCV(gv))); \
4520 SV* const meth = cMETHOPx_meth(PL_op);
4521 HV* const stash = opmethod_stash(meth);
4523 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
4524 METHOD_CHECK_CACHE(stash, stash, meth);
4527 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
4530 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4539 SV* const meth = cMETHOPx_meth(PL_op);
4540 HV* const stash = CopSTASH(PL_curcop);
4541 /* Actually, SUPER doesn't need real object's (or class') stash at all,
4542 * as it uses CopSTASH. However, we must ensure that object(class) is
4543 * correct (this check is done by S_opmethod_stash) */
4544 opmethod_stash(meth);
4546 if ((cache = HvMROMETA(stash)->super)) {
4547 METHOD_CHECK_CACHE(stash, cache, meth);
4550 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
4553 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4561 SV* const meth = cMETHOPx_meth(PL_op);
4562 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
4563 opmethod_stash(meth); /* not used but needed for error checks */
4565 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
4566 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
4568 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
4571 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4575 PP(pp_method_redir_super)
4580 SV* const meth = cMETHOPx_meth(PL_op);
4581 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
4582 opmethod_stash(meth); /* not used but needed for error checks */
4584 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
4585 else if ((cache = HvMROMETA(stash)->super)) {
4586 METHOD_CHECK_CACHE(stash, cache, meth);
4589 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
4592 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
4597 * ex: set ts=8 sts=4 sw=4 et: