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
51 PL_curcop = (COP*)PL_op;
52 TAINT_NOT; /* Each statement is presumed innocent */
53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
64 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
65 PUSHs(save_scalar(cGVOP_gv));
67 PUSHs(GvSVn(cGVOP_gv));
77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
81 PUSHMARK(PL_stack_sp);
92 /* no PUTBACK, SETs doesn't inc/dec SP */
99 XPUSHs(MUTABLE_SV(cGVOP_gv));
108 /* SP is not used to remove a variable that is saved across the
109 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
110 register or load/store vs direct mem ops macro is introduced, this
111 should be a define block between direct PL_stack_sp and dSP operations,
112 presently, using PL_stack_sp is bias towards CISC cpus */
113 SV * const sv = *PL_stack_sp;
117 if (PL_op->op_type == OP_AND)
119 return cLOGOP->op_other;
127 /* sassign keeps its args in the optree traditionally backwards.
128 So we pop them differently.
130 SV *left = POPs; SV *right = TOPs;
132 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
133 SV * const temp = left;
134 left = right; right = temp;
136 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
138 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
140 SV * const cv = SvRV(right);
141 const U32 cv_type = SvTYPE(cv);
142 const bool is_gv = isGV_with_GP(left);
143 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
149 /* Can do the optimisation if left (LVALUE) is not a typeglob,
150 right (RVALUE) is a reference to something, and we're in void
152 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
153 /* Is the target symbol table currently empty? */
154 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
155 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
156 /* Good. Create a new proxy constant subroutine in the target.
157 The gv becomes a(nother) reference to the constant. */
158 SV *const value = SvRV(cv);
160 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
161 SvPCS_IMPORTED_on(gv);
163 SvREFCNT_inc_simple_void(value);
169 /* Need to fix things up. */
171 /* Need to fix GV. */
172 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
176 /* We've been returned a constant rather than a full subroutine,
177 but they expect a subroutine reference to apply. */
179 ENTER_with_name("sassign_coderef");
180 SvREFCNT_inc_void(SvRV(cv));
181 /* newCONSTSUB takes a reference count on the passed in SV
182 from us. We set the name to NULL, otherwise we get into
183 all sorts of fun as the reference to our new sub is
184 donated to the GV that we're about to assign to.
186 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
189 LEAVE_with_name("sassign_coderef");
191 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
193 First: ops for \&{"BONK"}; return us the constant in the
195 Second: ops for *{"BONK"} cause that symbol table entry
196 (and our reference to it) to be upgraded from RV
198 Thirdly: We get here. cv is actually PVGV now, and its
199 GvCV() is actually the subroutine we're looking for
201 So change the reference so that it points to the subroutine
202 of that typeglob, as that's what they were after all along.
204 GV *const upgraded = MUTABLE_GV(cv);
205 CV *const source = GvCV(upgraded);
208 assert(CvFLAGS(source) & CVf_CONST);
210 SvREFCNT_inc_void(source);
211 SvREFCNT_dec_NN(upgraded);
212 SvRV_set(right, MUTABLE_SV(source));
218 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
219 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
222 packWARN(WARN_MISC), "Useless assignment to a temporary"
224 SvSetMagicSV(left, right);
234 RETURNOP(cLOGOP->op_other);
236 RETURNOP(cLOGOP->op_next);
243 TAINT_NOT; /* Each statement is presumed innocent */
244 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
246 if (!(PL_op->op_flags & OPf_SPECIAL)) {
247 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
248 LEAVE_SCOPE(oldsave);
255 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
260 const char *rpv = NULL;
262 bool rcopied = FALSE;
264 if (TARG == right && right != left) { /* $r = $l.$r */
265 rpv = SvPV_nomg_const(right, rlen);
266 rbyte = !DO_UTF8(right);
267 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
268 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
272 if (TARG != left) { /* not $l .= $r */
274 const char* const lpv = SvPV_nomg_const(left, llen);
275 lbyte = !DO_UTF8(left);
276 sv_setpvn(TARG, lpv, llen);
282 else { /* $l .= $r and left == TARG */
284 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
285 report_uninit(right);
289 SvPV_force_nomg_nolen(left);
291 lbyte = !DO_UTF8(left);
298 /* $r.$r: do magic twice: tied might return different 2nd time */
300 rpv = SvPV_nomg_const(right, rlen);
301 rbyte = !DO_UTF8(right);
303 if (lbyte != rbyte) {
304 /* sv_utf8_upgrade_nomg() may reallocate the stack */
307 sv_utf8_upgrade_nomg(TARG);
310 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
311 sv_utf8_upgrade_nomg(right);
312 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;
364 if (PL_op->op_flags & OPf_SPECIAL) {
365 /* fake the RHS of my ($x,$y,..) = @_ */
367 S_pushav(aTHX_ GvAVn(PL_defgv));
371 /* note, this is only skipped for compile-time-known void cxt */
372 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
375 for (i = 0; i <count; i++)
376 *++SP = PAD_SV(base+i);
378 if (PL_op->op_private & OPpLVAL_INTRO) {
379 SV **svp = &(PAD_SVl(base));
380 const UV payload = (UV)(
381 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
382 | (count << SAVE_TIGHT_SHIFT)
383 | SAVEt_CLEARPADRANGE);
384 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
385 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
392 for (i = 0; i <count; i++)
393 SvPADSTALE_off(*svp++); /* mark lexical as active */
404 OP * const op = PL_op;
405 /* access PL_curpad once */
406 SV ** const padentry = &(PAD_SVl(op->op_targ));
411 PUTBACK; /* no pop/push after this, TOPs ok */
413 if (op->op_flags & OPf_MOD) {
414 if (op->op_private & OPpLVAL_INTRO)
415 if (!(op->op_private & OPpPAD_STATE))
416 save_clearsv(padentry);
417 if (op->op_private & OPpDEREF) {
418 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
419 than TARG reduces the scope of TARG, so it does not
420 span the call to save_clearsv, resulting in smaller
422 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
435 tryAMAGICunTARGETlist(iter_amg, 0);
436 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
438 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
439 if (!isGV_with_GP(PL_last_in_gv)) {
440 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
441 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
444 XPUSHs(MUTABLE_SV(PL_last_in_gv));
447 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
450 return do_readline();
458 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
462 (SvIOK_notUV(left) && SvIOK_notUV(right))
463 ? (SvIVX(left) == SvIVX(right))
464 : ( do_ncmp(left, right) == 0)
473 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
474 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
475 Perl_croak_no_modify();
476 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
477 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
479 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
480 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
482 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
483 if (inc) sv_inc(TOPs);
496 if (PL_op->op_type == OP_OR)
498 RETURNOP(cLOGOP->op_other);
507 const int op_type = PL_op->op_type;
508 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
513 if (UNLIKELY(!sv || !SvANY(sv))) {
514 if (op_type == OP_DOR)
516 RETURNOP(cLOGOP->op_other);
522 if (UNLIKELY(!sv || !SvANY(sv)))
527 switch (SvTYPE(sv)) {
529 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
533 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
537 if (CvROOT(sv) || CvXSUB(sv))
550 if(op_type == OP_DOR)
552 RETURNOP(cLOGOP->op_other);
554 /* assuming OP_DEFINED */
562 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
563 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
567 useleft = USE_LEFT(svl);
568 #ifdef PERL_PRESERVE_IVUV
569 /* We must see if we can perform the addition with integers if possible,
570 as the integer code detects overflow while the NV code doesn't.
571 If either argument hasn't had a numeric conversion yet attempt to get
572 the IV. It's important to do this now, rather than just assuming that
573 it's not IOK as a PV of "9223372036854775806" may not take well to NV
574 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
575 integer in case the second argument is IV=9223372036854775806
576 We can (now) rely on sv_2iv to do the right thing, only setting the
577 public IOK flag if the value in the NV (or PV) slot is truly integer.
579 A side effect is that this also aggressively prefers integer maths over
580 fp maths for integer values.
582 How to detect overflow?
584 C 99 section 6.2.6.1 says
586 The range of nonnegative values of a signed integer type is a subrange
587 of the corresponding unsigned integer type, and the representation of
588 the same value in each type is the same. A computation involving
589 unsigned operands can never overflow, because a result that cannot be
590 represented by the resulting unsigned integer type is reduced modulo
591 the number that is one greater than the largest value that can be
592 represented by the resulting type.
596 which I read as "unsigned ints wrap."
598 signed integer overflow seems to be classed as "exception condition"
600 If an exceptional condition occurs during the evaluation of an
601 expression (that is, if the result is not mathematically defined or not
602 in the range of representable values for its type), the behavior is
605 (6.5, the 5th paragraph)
607 I had assumed that on 2s complement machines signed arithmetic would
608 wrap, hence coded pp_add and pp_subtract on the assumption that
609 everything perl builds on would be happy. After much wailing and
610 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
611 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
612 unsigned code below is actually shorter than the old code. :-)
615 if (SvIV_please_nomg(svr)) {
616 /* Unless the left argument is integer in range we are going to have to
617 use NV maths. Hence only attempt to coerce the right argument if
618 we know the left is integer. */
626 /* left operand is undef, treat as zero. + 0 is identity,
627 Could SETi or SETu right now, but space optimise by not adding
628 lots of code to speed up what is probably a rarish case. */
630 /* Left operand is defined, so is it IV? */
631 if (SvIV_please_nomg(svl)) {
632 if ((auvok = SvUOK(svl)))
635 const IV aiv = SvIVX(svl);
638 auvok = 1; /* Now acting as a sign flag. */
639 } else { /* 2s complement assumption for IV_MIN */
647 bool result_good = 0;
650 bool buvok = SvUOK(svr);
655 const IV biv = SvIVX(svr);
662 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
663 else "IV" now, independent of how it came in.
664 if a, b represents positive, A, B negative, a maps to -A etc
669 all UV maths. negate result if A negative.
670 add if signs same, subtract if signs differ. */
676 /* Must get smaller */
682 /* result really should be -(auv-buv). as its negation
683 of true value, need to swap our result flag */
700 if (result <= (UV)IV_MIN)
703 /* result valid, but out of range for IV. */
708 } /* Overflow, drop through to NVs. */
713 NV value = SvNV_nomg(svr);
716 /* left operand is undef, treat as zero. + 0.0 is identity. */
720 SETn( value + SvNV_nomg(svl) );
728 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
729 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
730 const U32 lval = PL_op->op_flags & OPf_MOD;
731 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
732 SV *sv = (svp ? *svp : &PL_sv_undef);
734 if (UNLIKELY(!svp && lval))
735 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
738 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
746 dVAR; dSP; dMARK; dTARGET;
748 do_join(TARG, *MARK, MARK, SP);
759 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
760 * will be enough to hold an OP*.
762 SV* const sv = sv_newmortal();
763 sv_upgrade(sv, SVt_PVLV);
765 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
768 XPUSHs(MUTABLE_SV(PL_op));
773 /* Oversized hot code. */
777 dVAR; dSP; dMARK; dORIGMARK;
781 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
785 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
788 if (MARK == ORIGMARK) {
789 /* If using default handle then we need to make space to
790 * pass object as 1st arg, so move other args up ...
794 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
797 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
799 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
800 | (PL_op->op_type == OP_SAY
801 ? TIED_METHOD_SAY : 0)), sp - mark);
804 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
805 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
808 SETERRNO(EBADF,RMS_IFI);
811 else if (!(fp = IoOFP(io))) {
813 report_wrongway_fh(gv, '<');
816 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
820 SV * const ofs = GvSV(PL_ofsgv); /* $, */
822 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
824 if (!do_print(*MARK, fp))
828 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
829 if (!do_print(GvSV(PL_ofsgv), fp)) {
838 if (!do_print(*MARK, fp))
846 if (PL_op->op_type == OP_SAY) {
847 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
850 else if (PL_ors_sv && SvOK(PL_ors_sv))
851 if (!do_print(PL_ors_sv, fp)) /* $\ */
854 if (IoFLAGS(io) & IOf_FLUSH)
855 if (PerlIO_flush(fp) == EOF)
865 XPUSHs(&PL_sv_undef);
872 const I32 gimme = GIMME_V;
873 static const char an_array[] = "an ARRAY";
874 static const char a_hash[] = "a HASH";
875 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
876 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
880 if (UNLIKELY(SvAMAGIC(sv))) {
881 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
884 if (UNLIKELY(SvTYPE(sv) != type))
885 /* diag_listed_as: Not an ARRAY reference */
886 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
887 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
888 && PL_op->op_private & OPpLVAL_INTRO))
889 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
891 else if (UNLIKELY(SvTYPE(sv) != type)) {
894 if (!isGV_with_GP(sv)) {
895 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
903 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
904 if (PL_op->op_private & OPpLVAL_INTRO)
905 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
907 if (PL_op->op_flags & OPf_REF) {
911 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
912 const I32 flags = is_lvalue_sub();
913 if (flags && !(flags & OPpENTERSUB_INARGS)) {
914 if (gimme != G_ARRAY)
915 goto croak_cant_return;
922 AV *const av = MUTABLE_AV(sv);
923 /* The guts of pp_rv2av, with no intending change to preserve history
924 (until such time as we get tools that can do blame annotation across
925 whitespace changes. */
926 if (gimme == G_ARRAY) {
932 else if (gimme == G_SCALAR) {
934 const SSize_t maxarg = AvFILL(av) + 1;
938 /* The guts of pp_rv2hv */
939 if (gimme == G_ARRAY) { /* array wanted */
941 return Perl_do_kv(aTHX);
943 else if ((PL_op->op_private & OPpTRUEBOOL
944 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
945 && block_gimme() == G_VOID ))
946 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
947 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
948 else if (gimme == G_SCALAR) {
950 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
957 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
958 is_pp_rv2av ? "array" : "hash");
963 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
967 PERL_ARGS_ASSERT_DO_ODDBALL;
970 if (ckWARN(WARN_MISC)) {
972 if (oddkey == firstkey &&
974 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
975 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
977 err = "Reference found where even-sized list expected";
980 err = "Odd number of elements in hash assignment";
981 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
990 SV **lastlelem = PL_stack_sp;
991 SV **lastrelem = PL_stack_base + POPMARK;
992 SV **firstrelem = PL_stack_base + POPMARK + 1;
993 SV **firstlelem = lastrelem + 1;
1007 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1009 if (gimme == G_ARRAY)
1010 lval = PL_op->op_flags & OPf_MOD || LVRET;
1012 /* If there's a common identifier on both sides we have to take
1013 * special care that assigning the identifier on the left doesn't
1014 * clobber a value on the right that's used later in the list.
1015 * Don't bother if LHS is just an empty hash or array.
1018 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1020 firstlelem != lastlelem
1021 || ! ((sv = *firstlelem))
1023 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1024 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1025 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1028 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1029 for (relem = firstrelem; relem <= lastrelem; relem++) {
1030 if (LIKELY((sv = *relem))) {
1031 TAINT_NOT; /* Each item is independent */
1033 /* Dear TODO test in t/op/sort.t, I love you.
1034 (It's relying on a panic, not a "semi-panic" from newSVsv()
1035 and then an assertion failure below.) */
1036 if (UNLIKELY(SvIS_FREED(sv))) {
1037 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1040 /* Not newSVsv(), as it does not allow copy-on-write,
1041 resulting in wasteful copies. We need a second copy of
1042 a temp here, hence the SV_NOSTEAL. */
1043 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1054 while (LIKELY(lelem <= lastlelem)) {
1055 TAINT_NOT; /* Each item stands on its own, taintwise. */
1057 switch (SvTYPE(sv)) {
1059 ary = MUTABLE_AV(sv);
1060 magic = SvMAGICAL(ary) != 0;
1062 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1064 av_extend(ary, lastrelem - relem);
1066 while (relem <= lastrelem) { /* gobble up all the rest */
1069 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1071 sv_setsv_nomg(sv, *relem);
1073 didstore = av_store(ary,i++,sv);
1082 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1083 SvSETMAGIC(MUTABLE_SV(ary));
1086 case SVt_PVHV: { /* normal hash */
1090 SV** topelem = relem;
1091 SV **firsthashrelem = relem;
1093 hash = MUTABLE_HV(sv);
1094 magic = SvMAGICAL(hash) != 0;
1096 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1097 if (UNLIKELY(odd)) {
1098 do_oddball(lastrelem, firsthashrelem);
1099 /* we have firstlelem to reuse, it's not needed anymore
1101 *(lastrelem+1) = &PL_sv_undef;
1105 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1107 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1110 /* Copy the key if aassign is called in lvalue context,
1111 to avoid having the next op modify our rhs. Copy
1112 it also if it is gmagical, lest it make the
1113 hv_store_ent call below croak, leaking the value. */
1114 sv = lval || SvGMAGICAL(*relem)
1115 ? sv_mortalcopy(*relem)
1121 sv_setsv_nomg(tmpstr,*relem++); /* value */
1122 if (gimme == G_ARRAY) {
1123 if (hv_exists_ent(hash, sv, 0))
1124 /* key overwrites an existing entry */
1127 /* copy element back: possibly to an earlier
1128 * stack location if we encountered dups earlier,
1129 * possibly to a later stack location if odd */
1131 *topelem++ = tmpstr;
1134 didstore = hv_store_ent(hash,sv,tmpstr,0);
1136 if (!didstore) sv_2mortal(tmpstr);
1142 if (duplicates && gimme == G_ARRAY) {
1143 /* at this point we have removed the duplicate key/value
1144 * pairs from the stack, but the remaining values may be
1145 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1146 * the (a 2), but the stack now probably contains
1147 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1148 * obliterates the earlier key. So refresh all values. */
1149 lastrelem -= duplicates;
1150 relem = firsthashrelem;
1151 while (relem < lastrelem+odd) {
1153 he = hv_fetch_ent(hash, *relem++, 0, 0);
1154 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1157 if (odd && gimme == G_ARRAY) lastrelem++;
1161 if (SvIMMORTAL(sv)) {
1162 if (relem <= lastrelem)
1166 if (relem <= lastrelem) {
1168 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1169 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1172 packWARN(WARN_MISC),
1173 "Useless assignment to a temporary"
1175 sv_setsv(sv, *relem);
1179 sv_setsv(sv, &PL_sv_undef);
1184 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1185 /* Will be used to set PL_tainting below */
1186 Uid_t tmp_uid = PerlProc_getuid();
1187 Uid_t tmp_euid = PerlProc_geteuid();
1188 Gid_t tmp_gid = PerlProc_getgid();
1189 Gid_t tmp_egid = PerlProc_getegid();
1191 /* XXX $> et al currently silently ignore failures */
1192 if (PL_delaymagic & DM_UID) {
1193 #ifdef HAS_SETRESUID
1195 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1196 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1199 # ifdef HAS_SETREUID
1201 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1202 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1205 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1206 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1207 PL_delaymagic &= ~DM_RUID;
1209 # endif /* HAS_SETRUID */
1211 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1212 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1213 PL_delaymagic &= ~DM_EUID;
1215 # endif /* HAS_SETEUID */
1216 if (PL_delaymagic & DM_UID) {
1217 if (PL_delaymagic_uid != PL_delaymagic_euid)
1218 DIE(aTHX_ "No setreuid available");
1219 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1221 # endif /* HAS_SETREUID */
1222 #endif /* HAS_SETRESUID */
1224 tmp_uid = PerlProc_getuid();
1225 tmp_euid = PerlProc_geteuid();
1227 /* XXX $> et al currently silently ignore failures */
1228 if (PL_delaymagic & DM_GID) {
1229 #ifdef HAS_SETRESGID
1231 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1232 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1235 # ifdef HAS_SETREGID
1237 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1238 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1241 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1242 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1243 PL_delaymagic &= ~DM_RGID;
1245 # endif /* HAS_SETRGID */
1247 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1248 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1249 PL_delaymagic &= ~DM_EGID;
1251 # endif /* HAS_SETEGID */
1252 if (PL_delaymagic & DM_GID) {
1253 if (PL_delaymagic_gid != PL_delaymagic_egid)
1254 DIE(aTHX_ "No setregid available");
1255 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1257 # endif /* HAS_SETREGID */
1258 #endif /* HAS_SETRESGID */
1260 tmp_gid = PerlProc_getgid();
1261 tmp_egid = PerlProc_getegid();
1263 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1264 #ifdef NO_TAINT_SUPPORT
1265 PERL_UNUSED_VAR(tmp_uid);
1266 PERL_UNUSED_VAR(tmp_euid);
1267 PERL_UNUSED_VAR(tmp_gid);
1268 PERL_UNUSED_VAR(tmp_egid);
1273 if (gimme == G_VOID)
1274 SP = firstrelem - 1;
1275 else if (gimme == G_SCALAR) {
1278 SETi(lastrelem - firstrelem + 1);
1282 /* note that in this case *firstlelem may have been overwritten
1283 by sv_undef in the odd hash case */
1286 SP = firstrelem + (lastlelem - firstlelem);
1287 lelem = firstlelem + (relem - firstrelem);
1289 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1299 PMOP * const pm = cPMOP;
1300 REGEXP * rx = PM_GETRE(pm);
1301 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1302 SV * const rv = sv_newmortal();
1306 SvUPGRADE(rv, SVt_IV);
1307 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1308 loathe to use it here, but it seems to be the right fix. Or close.
1309 The key part appears to be that it's essential for pp_qr to return a new
1310 object (SV), which implies that there needs to be an effective way to
1311 generate a new SV from the existing SV that is pre-compiled in the
1313 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1316 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1317 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1318 *cvp = cv_clone(cv);
1319 SvREFCNT_dec_NN(cv);
1323 HV *const stash = gv_stashsv(pkg, GV_ADD);
1324 SvREFCNT_dec_NN(pkg);
1325 (void)sv_bless(rv, stash);
1328 if (UNLIKELY(RX_ISTAINTED(rx))) {
1330 SvTAINTED_on(SvRV(rv));
1343 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1346 const char *truebase; /* Start of string */
1347 REGEXP *rx = PM_GETRE(pm);
1349 const I32 gimme = GIMME;
1351 const I32 oldsave = PL_savestack_ix;
1352 I32 had_zerolen = 0;
1355 if (PL_op->op_flags & OPf_STACKED)
1357 else if (PL_op->op_private & OPpTARGET_MY)
1364 PUTBACK; /* EVAL blocks need stack_sp. */
1365 /* Skip get-magic if this is a qr// clone, because regcomp has
1367 truebase = ReANY(rx)->mother_re
1368 ? SvPV_nomg_const(TARG, len)
1369 : SvPV_const(TARG, len);
1371 DIE(aTHX_ "panic: pp_match");
1372 strend = truebase + len;
1373 rxtainted = (RX_ISTAINTED(rx) ||
1374 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1377 /* We need to know this in case we fail out early - pos() must be reset */
1378 global = dynpm->op_pmflags & PMf_GLOBAL;
1380 /* PMdf_USED is set after a ?? matches once */
1383 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1385 pm->op_pmflags & PMf_USED
1388 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1392 /* empty pattern special-cased to use last successful pattern if
1393 possible, except for qr// */
1394 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1400 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1401 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1402 UVuf" < %"IVdf")\n",
1403 (UV)len, (IV)RX_MINLEN(rx)));
1407 /* get pos() if //g */
1409 mg = mg_find_mglob(TARG);
1410 if (mg && mg->mg_len >= 0) {
1411 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1412 /* last time pos() was set, it was zero-length match */
1413 if (mg->mg_flags & MGf_MINMATCH)
1418 #ifdef PERL_SAWAMPERSAND
1421 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1422 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1426 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1427 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1428 * only on the first iteration. Therefore we need to copy $' as well
1429 * as $&, to make the rest of the string available for captures in
1430 * subsequent iterations */
1431 if (! (global && gimme == G_ARRAY))
1432 r_flags |= REXEC_COPY_SKIP_POST;
1434 #ifdef PERL_SAWAMPERSAND
1435 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1436 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1437 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1444 s = truebase + curpos;
1446 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1447 had_zerolen, TARG, NULL, r_flags))
1451 if (dynpm->op_pmflags & PMf_ONCE)
1453 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1455 dynpm->op_pmflags |= PMf_USED;
1459 RX_MATCH_TAINTED_on(rx);
1460 TAINT_IF(RX_MATCH_TAINTED(rx));
1464 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1466 mg = sv_magicext_mglob(TARG);
1467 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1468 if (RX_ZERO_LEN(rx))
1469 mg->mg_flags |= MGf_MINMATCH;
1471 mg->mg_flags &= ~MGf_MINMATCH;
1474 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1475 LEAVE_SCOPE(oldsave);
1479 /* push captures on stack */
1482 const I32 nparens = RX_NPARENS(rx);
1483 I32 i = (global && !nparens) ? 1 : 0;
1485 SPAGAIN; /* EVAL blocks could move the stack. */
1486 EXTEND(SP, nparens + i);
1487 EXTEND_MORTAL(nparens + i);
1488 for (i = !i; i <= nparens; i++) {
1489 PUSHs(sv_newmortal());
1490 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1491 && RX_OFFS(rx)[i].end != -1 ))
1493 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1494 const char * const s = RX_OFFS(rx)[i].start + truebase;
1495 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1496 || len < 0 || len > strend - s))
1497 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1498 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1499 (long) i, (long) RX_OFFS(rx)[i].start,
1500 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1501 sv_setpvn(*SP, s, len);
1502 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1507 curpos = (UV)RX_OFFS(rx)[0].end;
1508 had_zerolen = RX_ZERO_LEN(rx);
1509 PUTBACK; /* EVAL blocks may use stack */
1510 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1513 LEAVE_SCOPE(oldsave);
1519 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1521 mg = mg_find_mglob(TARG);
1525 LEAVE_SCOPE(oldsave);
1526 if (gimme == G_ARRAY)
1532 Perl_do_readline(pTHX)
1534 dVAR; dSP; dTARGETSTACKED;
1539 IO * const io = GvIO(PL_last_in_gv);
1540 const I32 type = PL_op->op_type;
1541 const I32 gimme = GIMME_V;
1544 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1546 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1547 if (gimme == G_SCALAR) {
1549 SvSetSV_nosteal(TARG, TOPs);
1559 if (IoFLAGS(io) & IOf_ARGV) {
1560 if (IoFLAGS(io) & IOf_START) {
1562 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1563 IoFLAGS(io) &= ~IOf_START;
1564 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1565 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1566 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1567 SvSETMAGIC(GvSV(PL_last_in_gv));
1572 fp = nextargv(PL_last_in_gv);
1573 if (!fp) { /* Note: fp != IoIFP(io) */
1574 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1577 else if (type == OP_GLOB)
1578 fp = Perl_start_glob(aTHX_ POPs, io);
1580 else if (type == OP_GLOB)
1582 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1583 report_wrongway_fh(PL_last_in_gv, '>');
1587 if ((!io || !(IoFLAGS(io) & IOf_START))
1588 && ckWARN(WARN_CLOSED)
1591 report_evil_fh(PL_last_in_gv);
1593 if (gimme == G_SCALAR) {
1594 /* undef TARG, and push that undefined value */
1595 if (type != OP_RCATLINE) {
1596 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1604 if (gimme == G_SCALAR) {
1606 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1609 if (type == OP_RCATLINE)
1610 SvPV_force_nomg_nolen(sv);
1614 else if (isGV_with_GP(sv)) {
1615 SvPV_force_nomg_nolen(sv);
1617 SvUPGRADE(sv, SVt_PV);
1618 tmplen = SvLEN(sv); /* remember if already alloced */
1619 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1620 /* try short-buffering it. Please update t/op/readline.t
1621 * if you change the growth length.
1626 if (type == OP_RCATLINE && SvOK(sv)) {
1628 SvPV_force_nomg_nolen(sv);
1634 sv = sv_2mortal(newSV(80));
1638 /* This should not be marked tainted if the fp is marked clean */
1639 #define MAYBE_TAINT_LINE(io, sv) \
1640 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1645 /* delay EOF state for a snarfed empty file */
1646 #define SNARF_EOF(gimme,rs,io,sv) \
1647 (gimme != G_SCALAR || SvCUR(sv) \
1648 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1652 if (!sv_gets(sv, fp, offset)
1654 || SNARF_EOF(gimme, PL_rs, io, sv)
1655 || PerlIO_error(fp)))
1657 PerlIO_clearerr(fp);
1658 if (IoFLAGS(io) & IOf_ARGV) {
1659 fp = nextargv(PL_last_in_gv);
1662 (void)do_close(PL_last_in_gv, FALSE);
1664 else if (type == OP_GLOB) {
1665 if (!do_close(PL_last_in_gv, FALSE)) {
1666 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1667 "glob failed (child exited with status %d%s)",
1668 (int)(STATUS_CURRENT >> 8),
1669 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1672 if (gimme == G_SCALAR) {
1673 if (type != OP_RCATLINE) {
1674 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1680 MAYBE_TAINT_LINE(io, sv);
1683 MAYBE_TAINT_LINE(io, sv);
1685 IoFLAGS(io) |= IOf_NOLINE;
1689 if (type == OP_GLOB) {
1692 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1693 char * const tmps = SvEND(sv) - 1;
1694 if (*tmps == *SvPVX_const(PL_rs)) {
1696 SvCUR_set(sv, SvCUR(sv) - 1);
1699 for (t1 = SvPVX_const(sv); *t1; t1++)
1701 if (strchr("*%?", *t1))
1703 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1706 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1707 (void)POPs; /* Unmatched wildcard? Chuck it... */
1710 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1711 if (ckWARN(WARN_UTF8)) {
1712 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1713 const STRLEN len = SvCUR(sv) - offset;
1716 if (!is_utf8_string_loc(s, len, &f))
1717 /* Emulate :encoding(utf8) warning in the same case. */
1718 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1719 "utf8 \"\\x%02X\" does not map to Unicode",
1720 f < (U8*)SvEND(sv) ? *f : 0);
1723 if (gimme == G_ARRAY) {
1724 if (SvLEN(sv) - SvCUR(sv) > 20) {
1725 SvPV_shrink_to_cur(sv);
1727 sv = sv_2mortal(newSV(80));
1730 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1731 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1732 const STRLEN new_len
1733 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1734 SvPV_renew(sv, new_len);
1745 SV * const keysv = POPs;
1746 HV * const hv = MUTABLE_HV(POPs);
1747 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1748 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1750 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1751 bool preeminent = TRUE;
1753 if (SvTYPE(hv) != SVt_PVHV)
1760 /* If we can determine whether the element exist,
1761 * Try to preserve the existenceness of a tied hash
1762 * element by using EXISTS and DELETE if possible.
1763 * Fallback to FETCH and STORE otherwise. */
1764 if (SvCANEXISTDELETE(hv))
1765 preeminent = hv_exists_ent(hv, keysv, 0);
1768 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1769 svp = he ? &HeVAL(he) : NULL;
1771 if (!svp || !*svp || *svp == &PL_sv_undef) {
1775 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1777 lv = sv_newmortal();
1778 sv_upgrade(lv, SVt_PVLV);
1780 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1781 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1782 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1788 if (HvNAME_get(hv) && isGV(*svp))
1789 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1790 else if (preeminent)
1791 save_helem_flags(hv, keysv, svp,
1792 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1794 SAVEHDELETE(hv, keysv);
1796 else if (PL_op->op_private & OPpDEREF) {
1797 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1801 sv = (svp && *svp ? *svp : &PL_sv_undef);
1802 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1803 * was to make C<local $tied{foo} = $tied{foo}> possible.
1804 * However, it seems no longer to be needed for that purpose, and
1805 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1806 * would loop endlessly since the pos magic is getting set on the
1807 * mortal copy and lost. However, the copy has the effect of
1808 * triggering the get magic, and losing it altogether made things like
1809 * c<$tied{foo};> in void context no longer do get magic, which some
1810 * code relied on. Also, delayed triggering of magic on @+ and friends
1811 * meant the original regex may be out of scope by now. So as a
1812 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1813 * being called too many times). */
1814 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1828 cx = &cxstack[cxstack_ix];
1829 itersvp = CxITERVAR(cx);
1831 switch (CxTYPE(cx)) {
1833 case CXt_LOOP_LAZYSV: /* string increment */
1835 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1836 SV *end = cx->blk_loop.state_u.lazysv.end;
1837 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1838 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1840 const char *max = SvPV_const(end, maxlen);
1841 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
1845 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1846 /* safe to reuse old SV */
1847 sv_setsv(oldsv, cur);
1851 /* we need a fresh SV every time so that loop body sees a
1852 * completely new SV for closures/references to work as
1854 *itersvp = newSVsv(cur);
1855 SvREFCNT_dec_NN(oldsv);
1857 if (strEQ(SvPVX_const(cur), max))
1858 sv_setiv(cur, 0); /* terminate next time */
1864 case CXt_LOOP_LAZYIV: /* integer increment */
1866 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1867 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
1871 /* don't risk potential race */
1872 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1873 /* safe to reuse old SV */
1874 sv_setiv(oldsv, cur);
1878 /* we need a fresh SV every time so that loop body sees a
1879 * completely new SV for closures/references to work as they
1881 *itersvp = newSViv(cur);
1882 SvREFCNT_dec_NN(oldsv);
1885 if (UNLIKELY(cur == IV_MAX)) {
1886 /* Handle end of range at IV_MAX */
1887 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1889 ++cx->blk_loop.state_u.lazyiv.cur;
1893 case CXt_LOOP_FOR: /* iterate array */
1896 AV *av = cx->blk_loop.state_u.ary.ary;
1898 bool av_is_stack = FALSE;
1905 if (PL_op->op_private & OPpITER_REVERSED) {
1906 ix = --cx->blk_loop.state_u.ary.ix;
1907 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
1911 ix = ++cx->blk_loop.state_u.ary.ix;
1912 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
1916 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
1917 SV * const * const svp = av_fetch(av, ix, FALSE);
1918 sv = svp ? *svp : NULL;
1921 sv = AvARRAY(av)[ix];
1925 if (UNLIKELY(SvIS_FREED(sv))) {
1927 Perl_croak(aTHX_ "Use of freed value in iteration");
1930 assert(!IS_PADGV(sv));
1935 SvREFCNT_inc_simple_void_NN(sv);
1938 else if (!av_is_stack) {
1939 sv = newSVavdefelem(av, ix, 0);
1946 SvREFCNT_dec(oldsv);
1951 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1957 A description of how taint works in pattern matching and substitution.
1959 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1960 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1962 While the pattern is being assembled/concatenated and then compiled,
1963 PL_tainted will get set (via TAINT_set) if any component of the pattern
1964 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1965 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1966 TAINT_get). It will also be set if any component of the pattern matches
1967 based on locale-dependent behavior.
1969 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1970 the pattern is marked as tainted. This means that subsequent usage, such
1971 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1972 on the new pattern too.
1974 RXf_TAINTED_SEEN is used post-execution by the get magic code
1975 of $1 et al to indicate whether the returned value should be tainted.
1976 It is the responsibility of the caller of the pattern (i.e. pp_match,
1977 pp_subst etc) to set this flag for any other circumstances where $1 needs
1980 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1982 There are three possible sources of taint
1984 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1985 * the replacement string (or expression under /e)
1987 There are four destinations of taint and they are affected by the sources
1988 according to the rules below:
1990 * the return value (not including /r):
1991 tainted by the source string and pattern, but only for the
1992 number-of-iterations case; boolean returns aren't tainted;
1993 * the modified string (or modified copy under /r):
1994 tainted by the source string, pattern, and replacement strings;
1996 tainted by the pattern, and under 'use re "taint"', by the source
1998 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1999 should always be unset before executing subsequent code.
2001 The overall action of pp_subst is:
2003 * at the start, set bits in rxtainted indicating the taint status of
2004 the various sources.
2006 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2007 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2008 pattern has subsequently become tainted via locale ops.
2010 * If control is being passed to pp_substcont to execute a /e block,
2011 save rxtainted in the CXt_SUBST block, for future use by
2014 * Whenever control is being returned to perl code (either by falling
2015 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2016 use the flag bits in rxtainted to make all the appropriate types of
2017 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2018 et al will appear tainted.
2020 pp_match is just a simpler version of the above.
2036 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2037 See "how taint works" above */
2040 REGEXP *rx = PM_GETRE(pm);
2042 int force_on_match = 0;
2043 const I32 oldsave = PL_savestack_ix;
2045 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2050 /* known replacement string? */
2051 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2055 if (PL_op->op_flags & OPf_STACKED)
2057 else if (PL_op->op_private & OPpTARGET_MY)
2064 SvGETMAGIC(TARG); /* must come before cow check */
2066 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2067 because they make integers such as 256 "false". */
2068 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2071 sv_force_normal_flags(TARG,0);
2073 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2074 && (SvREADONLY(TARG)
2075 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2076 || SvTYPE(TARG) > SVt_PVLV)
2077 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2078 Perl_croak_no_modify();
2081 orig = SvPV_nomg(TARG, len);
2082 /* note we don't (yet) force the var into being a string; if we fail
2083 * to match, we leave as-is; on successful match howeverm, we *will*
2084 * coerce into a string, then repeat the match */
2085 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2088 /* only replace once? */
2089 once = !(rpm->op_pmflags & PMf_GLOBAL);
2091 /* See "how taint works" above */
2094 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2095 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2096 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2097 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2098 ? SUBST_TAINT_BOOLRET : 0));
2104 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2106 strend = orig + len;
2107 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2108 maxiters = 2 * slen + 10; /* We can match twice at each
2109 position, once with zero-length,
2110 second time with non-zero. */
2112 if (!RX_PRELEN(rx) && PL_curpm
2113 && !ReANY(rx)->mother_re) {
2118 #ifdef PERL_SAWAMPERSAND
2119 r_flags = ( RX_NPARENS(rx)
2121 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2122 || (rpm->op_pmflags & PMf_KEEPCOPY)
2127 r_flags = REXEC_COPY_STR;
2130 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2133 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2134 LEAVE_SCOPE(oldsave);
2139 /* known replacement string? */
2141 /* replacement needing upgrading? */
2142 if (DO_UTF8(TARG) && !doutf8) {
2143 nsv = sv_newmortal();
2146 sv_recode_to_utf8(nsv, PL_encoding);
2148 sv_utf8_upgrade(nsv);
2149 c = SvPV_const(nsv, clen);
2153 c = SvPV_const(dstr, clen);
2154 doutf8 = DO_UTF8(dstr);
2157 if (SvTAINTED(dstr))
2158 rxtainted |= SUBST_TAINT_REPL;
2165 /* can do inplace substitution? */
2170 && (I32)clen <= RX_MINLENRET(rx)
2172 || !(r_flags & REXEC_COPY_STR)
2173 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2175 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2176 && (!doutf8 || SvUTF8(TARG))
2177 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2181 if (SvIsCOW(TARG)) {
2182 if (!force_on_match)
2184 assert(SvVOK(TARG));
2187 if (force_on_match) {
2188 /* redo the first match, this time with the orig var
2189 * forced into being a string */
2191 orig = SvPV_force_nomg(TARG, len);
2197 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2198 rxtainted |= SUBST_TAINT_PAT;
2199 m = orig + RX_OFFS(rx)[0].start;
2200 d = orig + RX_OFFS(rx)[0].end;
2202 if (m - s > strend - d) { /* faster to shorten from end */
2205 Copy(c, m, clen, char);
2210 Move(d, m, i, char);
2214 SvCUR_set(TARG, m - s);
2216 else { /* faster from front */
2220 Move(s, d - i, i, char);
2223 Copy(c, d, clen, char);
2230 d = s = RX_OFFS(rx)[0].start + orig;
2233 if (UNLIKELY(iters++ > maxiters))
2234 DIE(aTHX_ "Substitution loop");
2235 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2236 rxtainted |= SUBST_TAINT_PAT;
2237 m = RX_OFFS(rx)[0].start + orig;
2240 Move(s, d, i, char);
2244 Copy(c, d, clen, char);
2247 s = RX_OFFS(rx)[0].end + orig;
2248 } while (CALLREGEXEC(rx, s, strend, orig,
2249 s == m, /* don't match same null twice */
2251 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2254 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2255 Move(s, d, i+1, char); /* include the NUL */
2265 if (force_on_match) {
2266 /* redo the first match, this time with the orig var
2267 * forced into being a string */
2269 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2270 /* I feel that it should be possible to avoid this mortal copy
2271 given that the code below copies into a new destination.
2272 However, I suspect it isn't worth the complexity of
2273 unravelling the C<goto force_it> for the small number of
2274 cases where it would be viable to drop into the copy code. */
2275 TARG = sv_2mortal(newSVsv(TARG));
2277 orig = SvPV_force_nomg(TARG, len);
2283 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2284 rxtainted |= SUBST_TAINT_PAT;
2286 s = RX_OFFS(rx)[0].start + orig;
2287 dstr = newSVpvn_flags(orig, s-orig,
2288 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2293 /* note that a whole bunch of local vars are saved here for
2294 * use by pp_substcont: here's a list of them in case you're
2295 * searching for places in this sub that uses a particular var:
2296 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2297 * s m strend rx once */
2299 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2303 if (UNLIKELY(iters++ > maxiters))
2304 DIE(aTHX_ "Substitution loop");
2305 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2306 rxtainted |= SUBST_TAINT_PAT;
2307 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2309 char *old_orig = orig;
2310 assert(RX_SUBOFFSET(rx) == 0);
2312 orig = RX_SUBBEG(rx);
2313 s = orig + (old_s - old_orig);
2314 strend = s + (strend - old_s);
2316 m = RX_OFFS(rx)[0].start + orig;
2317 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2318 s = RX_OFFS(rx)[0].end + orig;
2320 /* replacement already stringified */
2322 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2327 if (!nsv) nsv = sv_newmortal();
2328 sv_copypv(nsv, repl);
2329 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2330 sv_catsv(dstr, nsv);
2332 else sv_catsv(dstr, repl);
2333 if (UNLIKELY(SvTAINTED(repl)))
2334 rxtainted |= SUBST_TAINT_REPL;
2338 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2340 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2341 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2343 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2344 /* From here on down we're using the copy, and leaving the original
2351 /* The match may make the string COW. If so, brilliant, because
2352 that's just saved us one malloc, copy and free - the regexp has
2353 donated the old buffer, and we malloc an entirely new one, rather
2354 than the regexp malloc()ing a buffer and copying our original,
2355 only for us to throw it away here during the substitution. */
2356 if (SvIsCOW(TARG)) {
2357 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2363 SvPV_set(TARG, SvPVX(dstr));
2364 SvCUR_set(TARG, SvCUR(dstr));
2365 SvLEN_set(TARG, SvLEN(dstr));
2366 SvFLAGS(TARG) |= SvUTF8(dstr);
2367 SvPV_set(dstr, NULL);
2374 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2375 (void)SvPOK_only_UTF8(TARG);
2378 /* See "how taint works" above */
2380 if ((rxtainted & SUBST_TAINT_PAT) ||
2381 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2382 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2384 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2386 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2387 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2389 SvTAINTED_on(TOPs); /* taint return value */
2391 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2393 /* needed for mg_set below */
2395 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2399 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2401 LEAVE_SCOPE(oldsave);
2410 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2411 ++*PL_markstack_ptr;
2413 LEAVE_with_name("grep_item"); /* exit inner scope */
2416 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2418 const I32 gimme = GIMME_V;
2420 LEAVE_with_name("grep"); /* exit outer scope */
2421 (void)POPMARK; /* pop src */
2422 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2423 (void)POPMARK; /* pop dst */
2424 SP = PL_stack_base + POPMARK; /* pop original mark */
2425 if (gimme == G_SCALAR) {
2426 if (PL_op->op_private & OPpGREP_LEX) {
2427 SV* const sv = sv_newmortal();
2428 sv_setiv(sv, items);
2436 else if (gimme == G_ARRAY)
2443 ENTER_with_name("grep_item"); /* enter inner scope */
2446 src = PL_stack_base[*PL_markstack_ptr];
2447 if (SvPADTMP(src)) {
2448 assert(!IS_PADGV(src));
2449 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2453 if (PL_op->op_private & OPpGREP_LEX)
2454 PAD_SVl(PL_op->op_targ) = src;
2458 RETURNOP(cLOGOP->op_other);
2472 if (CxMULTICALL(&cxstack[cxstack_ix]))
2476 cxstack_ix++; /* temporarily protect top context */
2479 if (gimme == G_SCALAR) {
2481 if (LIKELY(MARK <= SP)) {
2482 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2483 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2484 && !SvMAGICAL(TOPs)) {
2485 *MARK = SvREFCNT_inc(TOPs);
2490 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2492 *MARK = sv_mortalcopy(sv);
2493 SvREFCNT_dec_NN(sv);
2496 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2497 && !SvMAGICAL(TOPs)) {
2501 *MARK = sv_mortalcopy(TOPs);
2505 *MARK = &PL_sv_undef;
2509 else if (gimme == G_ARRAY) {
2510 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2511 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2512 || SvMAGICAL(*MARK)) {
2513 *MARK = sv_mortalcopy(*MARK);
2514 TAINT_NOT; /* Each item is independent */
2521 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2523 PL_curpm = newpm; /* ... and pop $1 et al */
2526 return cx->blk_sub.retop;
2536 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2539 DIE(aTHX_ "Not a CODE reference");
2540 /* This is overwhelmingly the most common case: */
2541 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
2542 switch (SvTYPE(sv)) {
2545 if (!(cv = GvCVu((const GV *)sv))) {
2547 cv = sv_2cv(sv, &stash, &gv, 0);
2556 if(isGV_with_GP(sv)) goto we_have_a_glob;
2559 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2561 SP = PL_stack_base + POPMARK;
2569 sv = amagic_deref_call(sv, to_cv_amg);
2570 /* Don't SPAGAIN here. */
2577 DIE(aTHX_ PL_no_usym, "a subroutine");
2578 sym = SvPV_nomg_const(sv, len);
2579 if (PL_op->op_private & HINT_STRICT_REFS)
2580 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2581 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2584 cv = MUTABLE_CV(SvRV(sv));
2585 if (SvTYPE(cv) == SVt_PVCV)
2590 DIE(aTHX_ "Not a CODE reference");
2591 /* This is the second most common case: */
2593 cv = MUTABLE_CV(sv);
2601 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
2602 DIE(aTHX_ "Closure prototype called");
2603 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2607 /* anonymous or undef'd function leaves us no recourse */
2608 if (CvANON(cv) || !(gv = CvGV(cv))) {
2610 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2611 HEKfARG(CvNAME_HEK(cv)));
2612 DIE(aTHX_ "Undefined subroutine called");
2615 /* autoloaded stub? */
2616 if (cv != GvCV(gv)) {
2619 /* should call AUTOLOAD now? */
2622 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2623 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2629 sub_name = sv_newmortal();
2630 gv_efullname3(sub_name, gv, NULL);
2631 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2639 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2642 Perl_get_db_sub(aTHX_ &sv, cv);
2644 PL_curcopdb = PL_curcop;
2646 /* check for lsub that handles lvalue subroutines */
2647 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2648 /* if lsub not found then fall back to DB::sub */
2649 if (!cv) cv = GvCV(PL_DBsub);
2651 cv = GvCV(PL_DBsub);
2654 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2655 DIE(aTHX_ "No DB::sub routine defined");
2660 if (!(CvISXSUB(cv))) {
2661 /* This path taken at least 75% of the time */
2663 PADLIST * const padlist = CvPADLIST(cv);
2666 PUSHBLOCK(cx, CXt_SUB, MARK);
2668 cx->blk_sub.retop = PL_op->op_next;
2669 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
2670 PERL_STACK_OVERFLOW_CHECK();
2671 pad_push(padlist, depth);
2674 PAD_SET_CUR_NOSAVE(padlist, depth);
2675 if (LIKELY(hasargs)) {
2676 AV *const av = MUTABLE_AV(PAD_SVl(0));
2680 if (UNLIKELY(AvREAL(av))) {
2681 /* @_ is normally not REAL--this should only ever
2682 * happen when DB::sub() calls things that modify @_ */
2687 defavp = &GvAV(PL_defgv);
2688 cx->blk_sub.savearray = *defavp;
2689 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
2690 CX_CURPAD_SAVE(cx->blk_sub);
2691 cx->blk_sub.argarray = av;
2694 if (UNLIKELY(items - 1 > AvMAX(av))) {
2695 SV **ary = AvALLOC(av);
2696 AvMAX(av) = items - 1;
2697 Renew(ary, items, SV*);
2702 Copy(MARK+1,AvARRAY(av),items,SV*);
2703 AvFILLp(av) = items - 1;
2709 if (SvPADTMP(*MARK)) {
2710 assert(!IS_PADGV(*MARK));
2711 *MARK = sv_mortalcopy(*MARK);
2719 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2721 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2722 /* warning must come *after* we fully set up the context
2723 * stuff so that __WARN__ handlers can safely dounwind()
2726 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
2727 && ckWARN(WARN_RECURSION)
2728 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
2729 sub_crush_depth(cv);
2730 RETURNOP(CvSTART(cv));
2733 SSize_t markix = TOPMARK;
2738 if (UNLIKELY(((PL_op->op_private
2739 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2740 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2742 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2744 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
2745 /* Need to copy @_ to stack. Alternative may be to
2746 * switch stack to @_, and copy return values
2747 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2748 AV * const av = GvAV(PL_defgv);
2749 const SSize_t items = AvFILL(av) + 1;
2753 const bool m = cBOOL(SvRMAGICAL(av));
2754 /* Mark is at the end of the stack. */
2756 for (; i < items; ++i)
2760 SV ** const svp = av_fetch(av, i, 0);
2761 sv = svp ? *svp : NULL;
2763 else sv = AvARRAY(av)[i];
2764 if (sv) SP[i+1] = sv;
2766 SP[i+1] = newSVavdefelem(av, i, 1);
2774 SV **mark = PL_stack_base + markix;
2775 SSize_t items = SP - mark;
2778 if (*mark && SvPADTMP(*mark)) {
2779 assert(!IS_PADGV(*mark));
2780 *mark = sv_mortalcopy(*mark);
2784 /* We assume first XSUB in &DB::sub is the called one. */
2785 if (UNLIKELY(PL_curcopdb)) {
2786 SAVEVPTR(PL_curcop);
2787 PL_curcop = PL_curcopdb;
2790 /* Do we need to open block here? XXXX */
2792 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2794 CvXSUB(cv)(aTHX_ cv);
2796 /* Enforce some sanity in scalar context. */
2797 if (gimme == G_SCALAR) {
2798 SV **svp = PL_stack_base + markix + 1;
2799 if (svp != PL_stack_sp) {
2800 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2810 Perl_sub_crush_depth(pTHX_ CV *cv)
2812 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2815 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2817 HEK *const hek = CvNAME_HEK(cv);
2820 tmpstr = sv_2mortal(newSVhek(hek));
2823 tmpstr = sv_newmortal();
2824 gv_efullname3(tmpstr, CvGV(cv), NULL);
2826 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2835 SV* const elemsv = POPs;
2836 IV elem = SvIV(elemsv);
2837 AV *const av = MUTABLE_AV(POPs);
2838 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2839 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2840 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2841 bool preeminent = TRUE;
2844 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
2845 Perl_warner(aTHX_ packWARN(WARN_MISC),
2846 "Use of reference \"%"SVf"\" as array index",
2848 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
2851 if (UNLIKELY(localizing)) {
2855 /* If we can determine whether the element exist,
2856 * Try to preserve the existenceness of a tied array
2857 * element by using EXISTS and DELETE if possible.
2858 * Fallback to FETCH and STORE otherwise. */
2859 if (SvCANEXISTDELETE(av))
2860 preeminent = av_exists(av, elem);
2863 svp = av_fetch(av, elem, lval && !defer);
2865 #ifdef PERL_MALLOC_WRAP
2866 if (SvUOK(elemsv)) {
2867 const UV uv = SvUV(elemsv);
2868 elem = uv > IV_MAX ? IV_MAX : uv;
2870 else if (SvNOK(elemsv))
2871 elem = (IV)SvNV(elemsv);
2873 static const char oom_array_extend[] =
2874 "Out of memory during array extend"; /* Duplicated in av.c */
2875 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2878 if (!svp || !*svp) {
2881 DIE(aTHX_ PL_no_aelem, elem);
2882 len = av_tindex(av);
2883 mPUSHs(newSVavdefelem(av,
2884 /* Resolve a negative index now, unless it points before the
2885 beginning of the array, in which case record it for error
2886 reporting in magic_setdefelem. */
2887 elem < 0 && len + elem >= 0 ? len + elem : elem,
2891 if (UNLIKELY(localizing)) {
2893 save_aelem(av, elem, svp);
2895 SAVEADELETE(av, elem);
2897 else if (PL_op->op_private & OPpDEREF) {
2898 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2902 sv = (svp ? *svp : &PL_sv_undef);
2903 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2910 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2912 PERL_ARGS_ASSERT_VIVIFY_REF;
2917 Perl_croak_no_modify();
2918 prepare_SV_for_RV(sv);
2921 SvRV_set(sv, newSV(0));
2924 SvRV_set(sv, MUTABLE_SV(newAV()));
2927 SvRV_set(sv, MUTABLE_SV(newHV()));
2934 if (SvGMAGICAL(sv)) {
2935 /* copy the sv without magic to prevent magic from being
2937 SV* msv = sv_newmortal();
2938 sv_setsv_nomg(msv, sv);
2947 SV* const sv = TOPs;
2950 SV* const rsv = SvRV(sv);
2951 if (SvTYPE(rsv) == SVt_PVCV) {
2957 SETs(method_common(sv, NULL));
2964 SV* const sv = cSVOP_sv;
2965 U32 hash = SvSHARED_HASH(sv);
2967 XPUSHs(method_common(sv, &hash));
2972 S_method_common(pTHX_ SV* meth, U32* hashp)
2979 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2980 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2981 "package or object reference", SVfARG(meth)),
2983 : *(PL_stack_base + TOPMARK + 1);
2985 PERL_ARGS_ASSERT_METHOD_COMMON;
2989 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2994 ob = MUTABLE_SV(SvRV(sv));
2995 else if (!SvOK(sv)) goto undefined;
2996 else if (isGV_with_GP(sv)) {
2998 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2999 "without a package or object reference",
3002 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3003 assert(!LvTARGLEN(ob));
3007 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3010 /* this isn't a reference */
3013 const char * const packname = SvPV_nomg_const(sv, packlen);
3014 const bool packname_is_utf8 = !!SvUTF8(sv);
3015 const HE* const he =
3016 (const HE *)hv_common(
3017 PL_stashcache, NULL, packname, packlen,
3018 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
3022 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3023 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3024 (void*)stash, SVfARG(sv)));
3028 if (!(iogv = gv_fetchpvn_flags(
3029 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3031 !(ob=MUTABLE_SV(GvIO(iogv))))
3033 /* this isn't the name of a filehandle either */
3036 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3037 "without a package or object reference",
3040 /* assume it's a package name */
3041 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3045 SV* const ref = newSViv(PTR2IV(stash));
3046 (void)hv_store(PL_stashcache, packname,
3047 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3048 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3049 (void*)stash, SVfARG(sv)));
3053 /* it _is_ a filehandle name -- replace with a reference */
3054 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3057 /* if we got here, ob should be an object or a glob */
3058 if (!ob || !(SvOBJECT(ob)
3059 || (isGV_with_GP(ob)
3060 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3063 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3064 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3065 ? newSVpvs_flags("DOES", SVs_TEMP)
3069 stash = SvSTASH(ob);
3072 /* NOTE: stash may be null, hope hv_fetch_ent and
3073 gv_fetchmethod can cope (it seems they can) */
3075 /* shortcut for simple names */
3077 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3079 gv = MUTABLE_GV(HeVAL(he));
3081 if (isGV(gv) && GvCV(gv) &&
3082 (!GvCVGEN(gv) || GvCVGEN(gv)
3083 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3084 return MUTABLE_SV(GvCV(gv));
3088 assert(stash || packsv);
3089 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3090 meth, GV_AUTOLOAD | GV_CROAK);
3093 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3098 * c-indentation-style: bsd
3100 * indent-tabs-mode: nil
3103 * ex: set ts=8 sts=4 sw=4 et: