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;
51 TAINT_NOT; /* Each statement is presumed innocent */
52 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
62 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
63 PUSHs(save_scalar(cGVOP_gv));
65 PUSHs(GvSVn(cGVOP_gv));
66 if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
76 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
79 PUSHMARK(PL_stack_sp);
90 /* no PUTBACK, SETs doesn't inc/dec SP */
97 XPUSHs(MUTABLE_SV(cGVOP_gv));
99 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_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);
242 TAINT_NOT; /* Each statement is presumed innocent */
243 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
245 if (!(PL_op->op_flags & OPf_SPECIAL)) {
246 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
247 LEAVE_SCOPE(oldsave);
254 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
259 const char *rpv = NULL;
261 bool rcopied = FALSE;
263 if (TARG == right && right != left) { /* $r = $l.$r */
264 rpv = SvPV_nomg_const(right, rlen);
265 rbyte = !DO_UTF8(right);
266 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
267 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
271 if (TARG != left) { /* not $l .= $r */
273 const char* const lpv = SvPV_nomg_const(left, llen);
274 lbyte = !DO_UTF8(left);
275 sv_setpvn(TARG, lpv, llen);
281 else { /* $l .= $r and left == TARG */
283 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
284 report_uninit(right);
288 SvPV_force_nomg_nolen(left);
290 lbyte = !DO_UTF8(left);
297 /* $r.$r: do magic twice: tied might return different 2nd time */
299 rpv = SvPV_nomg_const(right, rlen);
300 rbyte = !DO_UTF8(right);
302 if (lbyte != rbyte) {
303 /* sv_utf8_upgrade_nomg() may reallocate the stack */
306 sv_utf8_upgrade_nomg(TARG);
309 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
310 sv_utf8_upgrade_nomg(right);
311 rpv = SvPV_nomg_const(right, rlen);
315 sv_catpvn_nomg(TARG, rpv, rlen);
322 /* push the elements of av onto the stack.
323 * XXX Note that padav has similar code but without the mg_get().
324 * I suspect that the mg_get is no longer needed, but while padav
325 * differs, it can't share this function */
328 S_pushav(pTHX_ AV* const av)
331 const SSize_t maxarg = AvFILL(av) + 1;
333 if (UNLIKELY(SvRMAGICAL(av))) {
335 for (i=0; i < (PADOFFSET)maxarg; i++) {
336 SV ** const svp = av_fetch(av, i, FALSE);
337 /* See note in pp_helem, and bug id #27839 */
339 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
345 for (i=0; i < (PADOFFSET)maxarg; i++) {
346 SV * const sv = AvARRAY(av)[i];
347 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
355 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
360 PADOFFSET base = PL_op->op_targ;
361 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) {
374 for (i = 0; i <count; i++)
375 *++SP = PAD_SV(base+i);
377 if (PL_op->op_private & OPpLVAL_INTRO) {
378 SV **svp = &(PAD_SVl(base));
379 const UV payload = (UV)(
380 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
381 | (count << SAVE_TIGHT_SHIFT)
382 | SAVEt_CLEARPADRANGE);
383 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
384 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
391 for (i = 0; i <count; i++)
392 SvPADSTALE_off(*svp++); /* mark lexical as active */
403 OP * const op = PL_op;
404 /* access PL_curpad once */
405 SV ** const padentry = &(PAD_SVl(op->op_targ));
410 PUTBACK; /* no pop/push after this, TOPs ok */
412 if (op->op_flags & OPf_MOD) {
413 if (op->op_private & OPpLVAL_INTRO)
414 if (!(op->op_private & OPpPAD_STATE))
415 save_clearsv(padentry);
416 if (op->op_private & OPpDEREF) {
417 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
418 than TARG reduces the scope of TARG, so it does not
419 span the call to save_clearsv, resulting in smaller
421 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
433 tryAMAGICunTARGETlist(iter_amg, 0);
434 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
436 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
437 if (!isGV_with_GP(PL_last_in_gv)) {
438 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
439 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
442 XPUSHs(MUTABLE_SV(PL_last_in_gv));
445 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
448 return do_readline();
456 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
460 (SvIOK_notUV(left) && SvIOK_notUV(right))
461 ? (SvIVX(left) == SvIVX(right))
462 : ( do_ncmp(left, right) == 0)
471 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
472 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
473 Perl_croak_no_modify();
474 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
475 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
477 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
478 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
480 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
481 if (inc) sv_inc(TOPs);
494 if (PL_op->op_type == OP_OR)
496 RETURNOP(cLOGOP->op_other);
505 const int op_type = PL_op->op_type;
506 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
511 if (UNLIKELY(!sv || !SvANY(sv))) {
512 if (op_type == OP_DOR)
514 RETURNOP(cLOGOP->op_other);
520 if (UNLIKELY(!sv || !SvANY(sv)))
525 switch (SvTYPE(sv)) {
527 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
531 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
535 if (CvROOT(sv) || CvXSUB(sv))
548 if(op_type == OP_DOR)
550 RETURNOP(cLOGOP->op_other);
552 /* assuming OP_DEFINED */
560 dSP; dATARGET; bool useleft; SV *svl, *svr;
561 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
565 useleft = USE_LEFT(svl);
566 #ifdef PERL_PRESERVE_IVUV
567 /* We must see if we can perform the addition with integers if possible,
568 as the integer code detects overflow while the NV code doesn't.
569 If either argument hasn't had a numeric conversion yet attempt to get
570 the IV. It's important to do this now, rather than just assuming that
571 it's not IOK as a PV of "9223372036854775806" may not take well to NV
572 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
573 integer in case the second argument is IV=9223372036854775806
574 We can (now) rely on sv_2iv to do the right thing, only setting the
575 public IOK flag if the value in the NV (or PV) slot is truly integer.
577 A side effect is that this also aggressively prefers integer maths over
578 fp maths for integer values.
580 How to detect overflow?
582 C 99 section 6.2.6.1 says
584 The range of nonnegative values of a signed integer type is a subrange
585 of the corresponding unsigned integer type, and the representation of
586 the same value in each type is the same. A computation involving
587 unsigned operands can never overflow, because a result that cannot be
588 represented by the resulting unsigned integer type is reduced modulo
589 the number that is one greater than the largest value that can be
590 represented by the resulting type.
594 which I read as "unsigned ints wrap."
596 signed integer overflow seems to be classed as "exception condition"
598 If an exceptional condition occurs during the evaluation of an
599 expression (that is, if the result is not mathematically defined or not
600 in the range of representable values for its type), the behavior is
603 (6.5, the 5th paragraph)
605 I had assumed that on 2s complement machines signed arithmetic would
606 wrap, hence coded pp_add and pp_subtract on the assumption that
607 everything perl builds on would be happy. After much wailing and
608 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
609 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
610 unsigned code below is actually shorter than the old code. :-)
613 if (SvIV_please_nomg(svr)) {
614 /* Unless the left argument is integer in range we are going to have to
615 use NV maths. Hence only attempt to coerce the right argument if
616 we know the left is integer. */
624 /* left operand is undef, treat as zero. + 0 is identity,
625 Could SETi or SETu right now, but space optimise by not adding
626 lots of code to speed up what is probably a rarish case. */
628 /* Left operand is defined, so is it IV? */
629 if (SvIV_please_nomg(svl)) {
630 if ((auvok = SvUOK(svl)))
633 const IV aiv = SvIVX(svl);
636 auvok = 1; /* Now acting as a sign flag. */
637 } else { /* 2s complement assumption for IV_MIN */
645 bool result_good = 0;
648 bool buvok = SvUOK(svr);
653 const IV biv = SvIVX(svr);
660 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
661 else "IV" now, independent of how it came in.
662 if a, b represents positive, A, B negative, a maps to -A etc
667 all UV maths. negate result if A negative.
668 add if signs same, subtract if signs differ. */
674 /* Must get smaller */
680 /* result really should be -(auv-buv). as its negation
681 of true value, need to swap our result flag */
698 if (result <= (UV)IV_MIN)
701 /* result valid, but out of range for IV. */
706 } /* Overflow, drop through to NVs. */
711 NV value = SvNV_nomg(svr);
714 /* left operand is undef, treat as zero. + 0.0 is identity. */
718 SETn( value + SvNV_nomg(svl) );
726 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
727 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
728 const U32 lval = PL_op->op_flags & OPf_MOD;
729 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
730 SV *sv = (svp ? *svp : &PL_sv_undef);
732 if (UNLIKELY(!svp && lval))
733 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
736 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
746 do_join(TARG, *MARK, MARK, SP);
757 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
758 * will be enough to hold an OP*.
760 SV* const sv = sv_newmortal();
761 sv_upgrade(sv, SVt_PVLV);
763 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
766 XPUSHs(MUTABLE_SV(PL_op));
771 /* Oversized hot code. */
775 dSP; dMARK; dORIGMARK;
779 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
783 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
786 if (MARK == ORIGMARK) {
787 /* If using default handle then we need to make space to
788 * pass object as 1st arg, so move other args up ...
792 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
795 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
797 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
798 | (PL_op->op_type == OP_SAY
799 ? TIED_METHOD_SAY : 0)), sp - mark);
802 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
803 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
806 SETERRNO(EBADF,RMS_IFI);
809 else if (!(fp = IoOFP(io))) {
811 report_wrongway_fh(gv, '<');
814 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
818 SV * const ofs = GvSV(PL_ofsgv); /* $, */
820 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
822 if (!do_print(*MARK, fp))
826 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
827 if (!do_print(GvSV(PL_ofsgv), fp)) {
836 if (!do_print(*MARK, fp))
844 if (PL_op->op_type == OP_SAY) {
845 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
848 else if (PL_ors_sv && SvOK(PL_ors_sv))
849 if (!do_print(PL_ors_sv, fp)) /* $\ */
852 if (IoFLAGS(io) & IOf_FLUSH)
853 if (PerlIO_flush(fp) == EOF)
863 XPUSHs(&PL_sv_undef);
870 const I32 gimme = GIMME_V;
871 static const char an_array[] = "an ARRAY";
872 static const char a_hash[] = "a HASH";
873 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
874 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
878 if (UNLIKELY(SvAMAGIC(sv))) {
879 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
882 if (UNLIKELY(SvTYPE(sv) != type))
883 /* diag_listed_as: Not an ARRAY reference */
884 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
885 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
886 && PL_op->op_private & OPpLVAL_INTRO))
887 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
889 else if (UNLIKELY(SvTYPE(sv) != type)) {
892 if (!isGV_with_GP(sv)) {
893 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
901 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
902 if (PL_op->op_private & OPpLVAL_INTRO)
903 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
905 if (PL_op->op_flags & OPf_REF) {
909 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
910 const I32 flags = is_lvalue_sub();
911 if (flags && !(flags & OPpENTERSUB_INARGS)) {
912 if (gimme != G_ARRAY)
913 goto croak_cant_return;
920 AV *const av = MUTABLE_AV(sv);
921 /* The guts of pp_rv2av, with no intending change to preserve history
922 (until such time as we get tools that can do blame annotation across
923 whitespace changes. */
924 if (gimme == G_ARRAY) {
930 else if (gimme == G_SCALAR) {
932 const SSize_t maxarg = AvFILL(av) + 1;
936 /* The guts of pp_rv2hv */
937 if (gimme == G_ARRAY) { /* array wanted */
939 return Perl_do_kv(aTHX);
941 else if ((PL_op->op_private & OPpTRUEBOOL
942 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
943 && block_gimme() == G_VOID ))
944 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
945 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
946 else if (gimme == G_SCALAR) {
948 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
955 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
956 is_pp_rv2av ? "array" : "hash");
961 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
963 PERL_ARGS_ASSERT_DO_ODDBALL;
966 if (ckWARN(WARN_MISC)) {
968 if (oddkey == firstkey &&
970 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
971 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
973 err = "Reference found where even-sized list expected";
976 err = "Odd number of elements in hash assignment";
977 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
986 SV **lastlelem = PL_stack_sp;
987 SV **lastrelem = PL_stack_base + POPMARK;
988 SV **firstrelem = PL_stack_base + POPMARK + 1;
989 SV **firstlelem = lastrelem + 1;
1003 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1005 if (gimme == G_ARRAY)
1006 lval = PL_op->op_flags & OPf_MOD || LVRET;
1008 /* If there's a common identifier on both sides we have to take
1009 * special care that assigning the identifier on the left doesn't
1010 * clobber a value on the right that's used later in the list.
1011 * Don't bother if LHS is just an empty hash or array.
1014 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
1016 firstlelem != lastlelem
1017 || ! ((sv = *firstlelem))
1019 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1020 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1021 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1024 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1025 for (relem = firstrelem; relem <= lastrelem; relem++) {
1026 if (LIKELY((sv = *relem))) {
1027 TAINT_NOT; /* Each item is independent */
1029 /* Dear TODO test in t/op/sort.t, I love you.
1030 (It's relying on a panic, not a "semi-panic" from newSVsv()
1031 and then an assertion failure below.) */
1032 if (UNLIKELY(SvIS_FREED(sv))) {
1033 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1036 /* Not newSVsv(), as it does not allow copy-on-write,
1037 resulting in wasteful copies. We need a second copy of
1038 a temp here, hence the SV_NOSTEAL. */
1039 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1050 while (LIKELY(lelem <= lastlelem)) {
1051 TAINT_NOT; /* Each item stands on its own, taintwise. */
1053 switch (SvTYPE(sv)) {
1055 ary = MUTABLE_AV(sv);
1056 magic = SvMAGICAL(ary) != 0;
1058 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1060 av_extend(ary, lastrelem - relem);
1062 while (relem <= lastrelem) { /* gobble up all the rest */
1065 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1067 sv_setsv_nomg(sv, *relem);
1069 didstore = av_store(ary,i++,sv);
1078 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1079 SvSETMAGIC(MUTABLE_SV(ary));
1082 case SVt_PVHV: { /* normal hash */
1086 SV** topelem = relem;
1087 SV **firsthashrelem = relem;
1089 hash = MUTABLE_HV(sv);
1090 magic = SvMAGICAL(hash) != 0;
1092 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1093 if (UNLIKELY(odd)) {
1094 do_oddball(lastrelem, firsthashrelem);
1095 /* we have firstlelem to reuse, it's not needed anymore
1097 *(lastrelem+1) = &PL_sv_undef;
1101 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1103 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1106 /* Copy the key if aassign is called in lvalue context,
1107 to avoid having the next op modify our rhs. Copy
1108 it also if it is gmagical, lest it make the
1109 hv_store_ent call below croak, leaking the value. */
1110 sv = lval || SvGMAGICAL(*relem)
1111 ? sv_mortalcopy(*relem)
1117 sv_setsv_nomg(tmpstr,*relem++); /* value */
1118 if (gimme == G_ARRAY) {
1119 if (hv_exists_ent(hash, sv, 0))
1120 /* key overwrites an existing entry */
1123 /* copy element back: possibly to an earlier
1124 * stack location if we encountered dups earlier,
1125 * possibly to a later stack location if odd */
1127 *topelem++ = tmpstr;
1130 didstore = hv_store_ent(hash,sv,tmpstr,0);
1132 if (!didstore) sv_2mortal(tmpstr);
1138 if (duplicates && gimme == G_ARRAY) {
1139 /* at this point we have removed the duplicate key/value
1140 * pairs from the stack, but the remaining values may be
1141 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1142 * the (a 2), but the stack now probably contains
1143 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1144 * obliterates the earlier key. So refresh all values. */
1145 lastrelem -= duplicates;
1146 relem = firsthashrelem;
1147 while (relem < lastrelem+odd) {
1149 he = hv_fetch_ent(hash, *relem++, 0, 0);
1150 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1153 if (odd && gimme == G_ARRAY) lastrelem++;
1157 if (SvIMMORTAL(sv)) {
1158 if (relem <= lastrelem)
1162 if (relem <= lastrelem) {
1164 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1165 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1168 packWARN(WARN_MISC),
1169 "Useless assignment to a temporary"
1171 sv_setsv(sv, *relem);
1175 sv_setsv(sv, &PL_sv_undef);
1180 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1181 /* Will be used to set PL_tainting below */
1182 Uid_t tmp_uid = PerlProc_getuid();
1183 Uid_t tmp_euid = PerlProc_geteuid();
1184 Gid_t tmp_gid = PerlProc_getgid();
1185 Gid_t tmp_egid = PerlProc_getegid();
1187 /* XXX $> et al currently silently ignore failures */
1188 if (PL_delaymagic & DM_UID) {
1189 #ifdef HAS_SETRESUID
1191 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1192 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1195 # ifdef HAS_SETREUID
1197 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1198 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1201 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1202 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1203 PL_delaymagic &= ~DM_RUID;
1205 # endif /* HAS_SETRUID */
1207 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1208 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1209 PL_delaymagic &= ~DM_EUID;
1211 # endif /* HAS_SETEUID */
1212 if (PL_delaymagic & DM_UID) {
1213 if (PL_delaymagic_uid != PL_delaymagic_euid)
1214 DIE(aTHX_ "No setreuid available");
1215 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1217 # endif /* HAS_SETREUID */
1218 #endif /* HAS_SETRESUID */
1220 tmp_uid = PerlProc_getuid();
1221 tmp_euid = PerlProc_geteuid();
1223 /* XXX $> et al currently silently ignore failures */
1224 if (PL_delaymagic & DM_GID) {
1225 #ifdef HAS_SETRESGID
1227 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1228 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1231 # ifdef HAS_SETREGID
1233 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1234 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1237 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1238 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1239 PL_delaymagic &= ~DM_RGID;
1241 # endif /* HAS_SETRGID */
1243 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1244 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1245 PL_delaymagic &= ~DM_EGID;
1247 # endif /* HAS_SETEGID */
1248 if (PL_delaymagic & DM_GID) {
1249 if (PL_delaymagic_gid != PL_delaymagic_egid)
1250 DIE(aTHX_ "No setregid available");
1251 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1253 # endif /* HAS_SETREGID */
1254 #endif /* HAS_SETRESGID */
1256 tmp_gid = PerlProc_getgid();
1257 tmp_egid = PerlProc_getegid();
1259 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1260 #ifdef NO_TAINT_SUPPORT
1261 PERL_UNUSED_VAR(tmp_uid);
1262 PERL_UNUSED_VAR(tmp_euid);
1263 PERL_UNUSED_VAR(tmp_gid);
1264 PERL_UNUSED_VAR(tmp_egid);
1269 if (gimme == G_VOID)
1270 SP = firstrelem - 1;
1271 else if (gimme == G_SCALAR) {
1274 SETi(lastrelem - firstrelem + 1);
1278 /* note that in this case *firstlelem may have been overwritten
1279 by sv_undef in the odd hash case */
1282 SP = firstrelem + (lastlelem - firstlelem);
1283 lelem = firstlelem + (relem - firstrelem);
1285 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1295 PMOP * const pm = cPMOP;
1296 REGEXP * rx = PM_GETRE(pm);
1297 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1298 SV * const rv = sv_newmortal();
1302 SvUPGRADE(rv, SVt_IV);
1303 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1304 loathe to use it here, but it seems to be the right fix. Or close.
1305 The key part appears to be that it's essential for pp_qr to return a new
1306 object (SV), which implies that there needs to be an effective way to
1307 generate a new SV from the existing SV that is pre-compiled in the
1309 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1312 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1313 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1314 *cvp = cv_clone(cv);
1315 SvREFCNT_dec_NN(cv);
1319 HV *const stash = gv_stashsv(pkg, GV_ADD);
1320 SvREFCNT_dec_NN(pkg);
1321 (void)sv_bless(rv, stash);
1324 if (UNLIKELY(RX_ISTAINTED(rx))) {
1326 SvTAINTED_on(SvRV(rv));
1339 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1342 const char *truebase; /* Start of string */
1343 REGEXP *rx = PM_GETRE(pm);
1345 const I32 gimme = GIMME;
1347 const I32 oldsave = PL_savestack_ix;
1348 I32 had_zerolen = 0;
1351 if (PL_op->op_flags & OPf_STACKED)
1353 else if (PL_op->op_private & OPpTARGET_MY)
1360 PUTBACK; /* EVAL blocks need stack_sp. */
1361 /* Skip get-magic if this is a qr// clone, because regcomp has
1363 truebase = ReANY(rx)->mother_re
1364 ? SvPV_nomg_const(TARG, len)
1365 : SvPV_const(TARG, len);
1367 DIE(aTHX_ "panic: pp_match");
1368 strend = truebase + len;
1369 rxtainted = (RX_ISTAINTED(rx) ||
1370 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1373 /* We need to know this in case we fail out early - pos() must be reset */
1374 global = dynpm->op_pmflags & PMf_GLOBAL;
1376 /* PMdf_USED is set after a ?? matches once */
1379 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1381 pm->op_pmflags & PMf_USED
1384 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1388 /* empty pattern special-cased to use last successful pattern if
1389 possible, except for qr// */
1390 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1396 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1397 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1398 UVuf" < %"IVdf")\n",
1399 (UV)len, (IV)RX_MINLEN(rx)));
1403 /* get pos() if //g */
1405 mg = mg_find_mglob(TARG);
1406 if (mg && mg->mg_len >= 0) {
1407 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1408 /* last time pos() was set, it was zero-length match */
1409 if (mg->mg_flags & MGf_MINMATCH)
1414 #ifdef PERL_SAWAMPERSAND
1417 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1418 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1422 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1423 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1424 * only on the first iteration. Therefore we need to copy $' as well
1425 * as $&, to make the rest of the string available for captures in
1426 * subsequent iterations */
1427 if (! (global && gimme == G_ARRAY))
1428 r_flags |= REXEC_COPY_SKIP_POST;
1430 #ifdef PERL_SAWAMPERSAND
1431 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1432 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1433 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1440 s = truebase + curpos;
1442 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1443 had_zerolen, TARG, NULL, r_flags))
1447 if (dynpm->op_pmflags & PMf_ONCE)
1449 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1451 dynpm->op_pmflags |= PMf_USED;
1455 RX_MATCH_TAINTED_on(rx);
1456 TAINT_IF(RX_MATCH_TAINTED(rx));
1460 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1462 mg = sv_magicext_mglob(TARG);
1463 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1464 if (RX_ZERO_LEN(rx))
1465 mg->mg_flags |= MGf_MINMATCH;
1467 mg->mg_flags &= ~MGf_MINMATCH;
1470 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1471 LEAVE_SCOPE(oldsave);
1475 /* push captures on stack */
1478 const I32 nparens = RX_NPARENS(rx);
1479 I32 i = (global && !nparens) ? 1 : 0;
1481 SPAGAIN; /* EVAL blocks could move the stack. */
1482 EXTEND(SP, nparens + i);
1483 EXTEND_MORTAL(nparens + i);
1484 for (i = !i; i <= nparens; i++) {
1485 PUSHs(sv_newmortal());
1486 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1487 && RX_OFFS(rx)[i].end != -1 ))
1489 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1490 const char * const s = RX_OFFS(rx)[i].start + truebase;
1491 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1492 || len < 0 || len > strend - s))
1493 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1494 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1495 (long) i, (long) RX_OFFS(rx)[i].start,
1496 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1497 sv_setpvn(*SP, s, len);
1498 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1503 curpos = (UV)RX_OFFS(rx)[0].end;
1504 had_zerolen = RX_ZERO_LEN(rx);
1505 PUTBACK; /* EVAL blocks may use stack */
1506 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1509 LEAVE_SCOPE(oldsave);
1515 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1517 mg = mg_find_mglob(TARG);
1521 LEAVE_SCOPE(oldsave);
1522 if (gimme == G_ARRAY)
1528 Perl_do_readline(pTHX)
1530 dSP; dTARGETSTACKED;
1535 IO * const io = GvIO(PL_last_in_gv);
1536 const I32 type = PL_op->op_type;
1537 const I32 gimme = GIMME_V;
1540 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1542 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1543 if (gimme == G_SCALAR) {
1545 SvSetSV_nosteal(TARG, TOPs);
1555 if (IoFLAGS(io) & IOf_ARGV) {
1556 if (IoFLAGS(io) & IOf_START) {
1558 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1559 IoFLAGS(io) &= ~IOf_START;
1560 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1561 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1562 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1563 SvSETMAGIC(GvSV(PL_last_in_gv));
1568 fp = nextargv(PL_last_in_gv);
1569 if (!fp) { /* Note: fp != IoIFP(io) */
1570 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1573 else if (type == OP_GLOB)
1574 fp = Perl_start_glob(aTHX_ POPs, io);
1576 else if (type == OP_GLOB)
1578 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1579 report_wrongway_fh(PL_last_in_gv, '>');
1583 if ((!io || !(IoFLAGS(io) & IOf_START))
1584 && ckWARN(WARN_CLOSED)
1587 report_evil_fh(PL_last_in_gv);
1589 if (gimme == G_SCALAR) {
1590 /* undef TARG, and push that undefined value */
1591 if (type != OP_RCATLINE) {
1592 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1600 if (gimme == G_SCALAR) {
1602 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1605 if (type == OP_RCATLINE)
1606 SvPV_force_nomg_nolen(sv);
1610 else if (isGV_with_GP(sv)) {
1611 SvPV_force_nomg_nolen(sv);
1613 SvUPGRADE(sv, SVt_PV);
1614 tmplen = SvLEN(sv); /* remember if already alloced */
1615 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1616 /* try short-buffering it. Please update t/op/readline.t
1617 * if you change the growth length.
1622 if (type == OP_RCATLINE && SvOK(sv)) {
1624 SvPV_force_nomg_nolen(sv);
1630 sv = sv_2mortal(newSV(80));
1634 /* This should not be marked tainted if the fp is marked clean */
1635 #define MAYBE_TAINT_LINE(io, sv) \
1636 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1641 /* delay EOF state for a snarfed empty file */
1642 #define SNARF_EOF(gimme,rs,io,sv) \
1643 (gimme != G_SCALAR || SvCUR(sv) \
1644 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1648 if (!sv_gets(sv, fp, offset)
1650 || SNARF_EOF(gimme, PL_rs, io, sv)
1651 || PerlIO_error(fp)))
1653 PerlIO_clearerr(fp);
1654 if (IoFLAGS(io) & IOf_ARGV) {
1655 fp = nextargv(PL_last_in_gv);
1658 (void)do_close(PL_last_in_gv, FALSE);
1660 else if (type == OP_GLOB) {
1661 if (!do_close(PL_last_in_gv, FALSE)) {
1662 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1663 "glob failed (child exited with status %d%s)",
1664 (int)(STATUS_CURRENT >> 8),
1665 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1668 if (gimme == G_SCALAR) {
1669 if (type != OP_RCATLINE) {
1670 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1676 MAYBE_TAINT_LINE(io, sv);
1679 MAYBE_TAINT_LINE(io, sv);
1681 IoFLAGS(io) |= IOf_NOLINE;
1685 if (type == OP_GLOB) {
1688 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1689 char * const tmps = SvEND(sv) - 1;
1690 if (*tmps == *SvPVX_const(PL_rs)) {
1692 SvCUR_set(sv, SvCUR(sv) - 1);
1695 for (t1 = SvPVX_const(sv); *t1; t1++)
1697 if (strchr("*%?", *t1))
1699 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1702 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1703 (void)POPs; /* Unmatched wildcard? Chuck it... */
1706 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1707 if (ckWARN(WARN_UTF8)) {
1708 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1709 const STRLEN len = SvCUR(sv) - offset;
1712 if (!is_utf8_string_loc(s, len, &f))
1713 /* Emulate :encoding(utf8) warning in the same case. */
1714 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1715 "utf8 \"\\x%02X\" does not map to Unicode",
1716 f < (U8*)SvEND(sv) ? *f : 0);
1719 if (gimme == G_ARRAY) {
1720 if (SvLEN(sv) - SvCUR(sv) > 20) {
1721 SvPV_shrink_to_cur(sv);
1723 sv = sv_2mortal(newSV(80));
1726 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1727 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1728 const STRLEN new_len
1729 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1730 SvPV_renew(sv, new_len);
1741 SV * const keysv = POPs;
1742 HV * const hv = MUTABLE_HV(POPs);
1743 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1744 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1746 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1747 bool preeminent = TRUE;
1749 if (SvTYPE(hv) != SVt_PVHV)
1756 /* If we can determine whether the element exist,
1757 * Try to preserve the existenceness of a tied hash
1758 * element by using EXISTS and DELETE if possible.
1759 * Fallback to FETCH and STORE otherwise. */
1760 if (SvCANEXISTDELETE(hv))
1761 preeminent = hv_exists_ent(hv, keysv, 0);
1764 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1765 svp = he ? &HeVAL(he) : NULL;
1767 if (!svp || !*svp || *svp == &PL_sv_undef) {
1771 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1773 lv = sv_newmortal();
1774 sv_upgrade(lv, SVt_PVLV);
1776 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1777 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1778 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1784 if (HvNAME_get(hv) && isGV(*svp))
1785 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1786 else if (preeminent)
1787 save_helem_flags(hv, keysv, svp,
1788 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1790 SAVEHDELETE(hv, keysv);
1792 else if (PL_op->op_private & OPpDEREF) {
1793 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1797 sv = (svp && *svp ? *svp : &PL_sv_undef);
1798 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1799 * was to make C<local $tied{foo} = $tied{foo}> possible.
1800 * However, it seems no longer to be needed for that purpose, and
1801 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1802 * would loop endlessly since the pos magic is getting set on the
1803 * mortal copy and lost. However, the copy has the effect of
1804 * triggering the get magic, and losing it altogether made things like
1805 * c<$tied{foo};> in void context no longer do get magic, which some
1806 * code relied on. Also, delayed triggering of magic on @+ and friends
1807 * meant the original regex may be out of scope by now. So as a
1808 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1809 * being called too many times). */
1810 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1824 cx = &cxstack[cxstack_ix];
1825 itersvp = CxITERVAR(cx);
1827 switch (CxTYPE(cx)) {
1829 case CXt_LOOP_LAZYSV: /* string increment */
1831 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1832 SV *end = cx->blk_loop.state_u.lazysv.end;
1833 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1834 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1836 const char *max = SvPV_const(end, maxlen);
1837 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
1841 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1842 /* safe to reuse old SV */
1843 sv_setsv(oldsv, cur);
1847 /* we need a fresh SV every time so that loop body sees a
1848 * completely new SV for closures/references to work as
1850 *itersvp = newSVsv(cur);
1851 SvREFCNT_dec_NN(oldsv);
1853 if (strEQ(SvPVX_const(cur), max))
1854 sv_setiv(cur, 0); /* terminate next time */
1860 case CXt_LOOP_LAZYIV: /* integer increment */
1862 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1863 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
1867 /* don't risk potential race */
1868 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1869 /* safe to reuse old SV */
1870 sv_setiv(oldsv, cur);
1874 /* we need a fresh SV every time so that loop body sees a
1875 * completely new SV for closures/references to work as they
1877 *itersvp = newSViv(cur);
1878 SvREFCNT_dec_NN(oldsv);
1881 if (UNLIKELY(cur == IV_MAX)) {
1882 /* Handle end of range at IV_MAX */
1883 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1885 ++cx->blk_loop.state_u.lazyiv.cur;
1889 case CXt_LOOP_FOR: /* iterate array */
1892 AV *av = cx->blk_loop.state_u.ary.ary;
1894 bool av_is_stack = FALSE;
1901 if (PL_op->op_private & OPpITER_REVERSED) {
1902 ix = --cx->blk_loop.state_u.ary.ix;
1903 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
1907 ix = ++cx->blk_loop.state_u.ary.ix;
1908 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
1912 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
1913 SV * const * const svp = av_fetch(av, ix, FALSE);
1914 sv = svp ? *svp : NULL;
1917 sv = AvARRAY(av)[ix];
1921 if (UNLIKELY(SvIS_FREED(sv))) {
1923 Perl_croak(aTHX_ "Use of freed value in iteration");
1930 SvREFCNT_inc_simple_void_NN(sv);
1933 else if (!av_is_stack) {
1934 sv = newSVavdefelem(av, ix, 0);
1941 SvREFCNT_dec(oldsv);
1946 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1952 A description of how taint works in pattern matching and substitution.
1954 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1955 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1957 While the pattern is being assembled/concatenated and then compiled,
1958 PL_tainted will get set (via TAINT_set) if any component of the pattern
1959 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1960 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1961 TAINT_get). It will also be set if any component of the pattern matches
1962 based on locale-dependent behavior.
1964 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1965 the pattern is marked as tainted. This means that subsequent usage, such
1966 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1967 on the new pattern too.
1969 RXf_TAINTED_SEEN is used post-execution by the get magic code
1970 of $1 et al to indicate whether the returned value should be tainted.
1971 It is the responsibility of the caller of the pattern (i.e. pp_match,
1972 pp_subst etc) to set this flag for any other circumstances where $1 needs
1975 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1977 There are three possible sources of taint
1979 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1980 * the replacement string (or expression under /e)
1982 There are four destinations of taint and they are affected by the sources
1983 according to the rules below:
1985 * the return value (not including /r):
1986 tainted by the source string and pattern, but only for the
1987 number-of-iterations case; boolean returns aren't tainted;
1988 * the modified string (or modified copy under /r):
1989 tainted by the source string, pattern, and replacement strings;
1991 tainted by the pattern, and under 'use re "taint"', by the source
1993 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1994 should always be unset before executing subsequent code.
1996 The overall action of pp_subst is:
1998 * at the start, set bits in rxtainted indicating the taint status of
1999 the various sources.
2001 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2002 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2003 pattern has subsequently become tainted via locale ops.
2005 * If control is being passed to pp_substcont to execute a /e block,
2006 save rxtainted in the CXt_SUBST block, for future use by
2009 * Whenever control is being returned to perl code (either by falling
2010 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2011 use the flag bits in rxtainted to make all the appropriate types of
2012 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2013 et al will appear tainted.
2015 pp_match is just a simpler version of the above.
2031 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2032 See "how taint works" above */
2035 REGEXP *rx = PM_GETRE(pm);
2037 int force_on_match = 0;
2038 const I32 oldsave = PL_savestack_ix;
2040 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2045 /* known replacement string? */
2046 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2050 if (PL_op->op_flags & OPf_STACKED)
2052 else if (PL_op->op_private & OPpTARGET_MY)
2059 SvGETMAGIC(TARG); /* must come before cow check */
2061 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2062 because they make integers such as 256 "false". */
2063 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2066 sv_force_normal_flags(TARG,0);
2068 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2069 && (SvREADONLY(TARG)
2070 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2071 || SvTYPE(TARG) > SVt_PVLV)
2072 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2073 Perl_croak_no_modify();
2076 orig = SvPV_nomg(TARG, len);
2077 /* note we don't (yet) force the var into being a string; if we fail
2078 * to match, we leave as-is; on successful match howeverm, we *will*
2079 * coerce into a string, then repeat the match */
2080 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2083 /* only replace once? */
2084 once = !(rpm->op_pmflags & PMf_GLOBAL);
2086 /* See "how taint works" above */
2089 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2090 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2091 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2092 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2093 ? SUBST_TAINT_BOOLRET : 0));
2099 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2101 strend = orig + len;
2102 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2103 maxiters = 2 * slen + 10; /* We can match twice at each
2104 position, once with zero-length,
2105 second time with non-zero. */
2107 if (!RX_PRELEN(rx) && PL_curpm
2108 && !ReANY(rx)->mother_re) {
2113 #ifdef PERL_SAWAMPERSAND
2114 r_flags = ( RX_NPARENS(rx)
2116 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2117 || (rpm->op_pmflags & PMf_KEEPCOPY)
2122 r_flags = REXEC_COPY_STR;
2125 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2128 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2129 LEAVE_SCOPE(oldsave);
2134 /* known replacement string? */
2136 /* replacement needing upgrading? */
2137 if (DO_UTF8(TARG) && !doutf8) {
2138 nsv = sv_newmortal();
2141 sv_recode_to_utf8(nsv, PL_encoding);
2143 sv_utf8_upgrade(nsv);
2144 c = SvPV_const(nsv, clen);
2148 c = SvPV_const(dstr, clen);
2149 doutf8 = DO_UTF8(dstr);
2152 if (SvTAINTED(dstr))
2153 rxtainted |= SUBST_TAINT_REPL;
2160 /* can do inplace substitution? */
2165 && (I32)clen <= RX_MINLENRET(rx)
2167 || !(r_flags & REXEC_COPY_STR)
2168 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2170 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2171 && (!doutf8 || SvUTF8(TARG))
2172 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2176 if (SvIsCOW(TARG)) {
2177 if (!force_on_match)
2179 assert(SvVOK(TARG));
2182 if (force_on_match) {
2183 /* redo the first match, this time with the orig var
2184 * forced into being a string */
2186 orig = SvPV_force_nomg(TARG, len);
2192 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2193 rxtainted |= SUBST_TAINT_PAT;
2194 m = orig + RX_OFFS(rx)[0].start;
2195 d = orig + RX_OFFS(rx)[0].end;
2197 if (m - s > strend - d) { /* faster to shorten from end */
2200 Copy(c, m, clen, char);
2205 Move(d, m, i, char);
2209 SvCUR_set(TARG, m - s);
2211 else { /* faster from front */
2215 Move(s, d - i, i, char);
2218 Copy(c, d, clen, char);
2225 d = s = RX_OFFS(rx)[0].start + orig;
2228 if (UNLIKELY(iters++ > maxiters))
2229 DIE(aTHX_ "Substitution loop");
2230 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2231 rxtainted |= SUBST_TAINT_PAT;
2232 m = RX_OFFS(rx)[0].start + orig;
2235 Move(s, d, i, char);
2239 Copy(c, d, clen, char);
2242 s = RX_OFFS(rx)[0].end + orig;
2243 } while (CALLREGEXEC(rx, s, strend, orig,
2244 s == m, /* don't match same null twice */
2246 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2249 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2250 Move(s, d, i+1, char); /* include the NUL */
2260 if (force_on_match) {
2261 /* redo the first match, this time with the orig var
2262 * forced into being a string */
2264 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2265 /* I feel that it should be possible to avoid this mortal copy
2266 given that the code below copies into a new destination.
2267 However, I suspect it isn't worth the complexity of
2268 unravelling the C<goto force_it> for the small number of
2269 cases where it would be viable to drop into the copy code. */
2270 TARG = sv_2mortal(newSVsv(TARG));
2272 orig = SvPV_force_nomg(TARG, len);
2278 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2279 rxtainted |= SUBST_TAINT_PAT;
2281 s = RX_OFFS(rx)[0].start + orig;
2282 dstr = newSVpvn_flags(orig, s-orig,
2283 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2288 /* note that a whole bunch of local vars are saved here for
2289 * use by pp_substcont: here's a list of them in case you're
2290 * searching for places in this sub that uses a particular var:
2291 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2292 * s m strend rx once */
2294 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2298 if (UNLIKELY(iters++ > maxiters))
2299 DIE(aTHX_ "Substitution loop");
2300 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2301 rxtainted |= SUBST_TAINT_PAT;
2302 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2304 char *old_orig = orig;
2305 assert(RX_SUBOFFSET(rx) == 0);
2307 orig = RX_SUBBEG(rx);
2308 s = orig + (old_s - old_orig);
2309 strend = s + (strend - old_s);
2311 m = RX_OFFS(rx)[0].start + orig;
2312 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2313 s = RX_OFFS(rx)[0].end + orig;
2315 /* replacement already stringified */
2317 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2322 if (!nsv) nsv = sv_newmortal();
2323 sv_copypv(nsv, repl);
2324 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2325 sv_catsv(dstr, nsv);
2327 else sv_catsv(dstr, repl);
2328 if (UNLIKELY(SvTAINTED(repl)))
2329 rxtainted |= SUBST_TAINT_REPL;
2333 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2335 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2336 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2338 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2339 /* From here on down we're using the copy, and leaving the original
2346 /* The match may make the string COW. If so, brilliant, because
2347 that's just saved us one malloc, copy and free - the regexp has
2348 donated the old buffer, and we malloc an entirely new one, rather
2349 than the regexp malloc()ing a buffer and copying our original,
2350 only for us to throw it away here during the substitution. */
2351 if (SvIsCOW(TARG)) {
2352 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2358 SvPV_set(TARG, SvPVX(dstr));
2359 SvCUR_set(TARG, SvCUR(dstr));
2360 SvLEN_set(TARG, SvLEN(dstr));
2361 SvFLAGS(TARG) |= SvUTF8(dstr);
2362 SvPV_set(dstr, NULL);
2369 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2370 (void)SvPOK_only_UTF8(TARG);
2373 /* See "how taint works" above */
2375 if ((rxtainted & SUBST_TAINT_PAT) ||
2376 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2377 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2379 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2381 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2382 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2384 SvTAINTED_on(TOPs); /* taint return value */
2386 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2388 /* needed for mg_set below */
2390 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2394 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2396 LEAVE_SCOPE(oldsave);
2405 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2406 ++*PL_markstack_ptr;
2408 LEAVE_with_name("grep_item"); /* exit inner scope */
2411 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2413 const I32 gimme = GIMME_V;
2415 LEAVE_with_name("grep"); /* exit outer scope */
2416 (void)POPMARK; /* pop src */
2417 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2418 (void)POPMARK; /* pop dst */
2419 SP = PL_stack_base + POPMARK; /* pop original mark */
2420 if (gimme == G_SCALAR) {
2421 if (PL_op->op_private & OPpGREP_LEX) {
2422 SV* const sv = sv_newmortal();
2423 sv_setiv(sv, items);
2431 else if (gimme == G_ARRAY)
2438 ENTER_with_name("grep_item"); /* enter inner scope */
2441 src = PL_stack_base[*PL_markstack_ptr];
2442 if (SvPADTMP(src)) {
2443 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2447 if (PL_op->op_private & OPpGREP_LEX)
2448 PAD_SVl(PL_op->op_targ) = src;
2452 RETURNOP(cLOGOP->op_other);
2466 if (CxMULTICALL(&cxstack[cxstack_ix]))
2470 cxstack_ix++; /* temporarily protect top context */
2473 if (gimme == G_SCALAR) {
2475 if (LIKELY(MARK <= SP)) {
2476 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2477 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2478 && !SvMAGICAL(TOPs)) {
2479 *MARK = SvREFCNT_inc(TOPs);
2484 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2486 *MARK = sv_mortalcopy(sv);
2487 SvREFCNT_dec_NN(sv);
2490 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2491 && !SvMAGICAL(TOPs)) {
2495 *MARK = sv_mortalcopy(TOPs);
2499 *MARK = &PL_sv_undef;
2503 else if (gimme == G_ARRAY) {
2504 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2505 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2506 || SvMAGICAL(*MARK)) {
2507 *MARK = sv_mortalcopy(*MARK);
2508 TAINT_NOT; /* Each item is independent */
2515 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2517 PL_curpm = newpm; /* ... and pop $1 et al */
2520 return cx->blk_sub.retop;
2530 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2533 DIE(aTHX_ "Not a CODE reference");
2534 /* This is overwhelmingly the most common case: */
2535 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
2536 switch (SvTYPE(sv)) {
2539 if (!(cv = GvCVu((const GV *)sv))) {
2541 cv = sv_2cv(sv, &stash, &gv, 0);
2550 if(isGV_with_GP(sv)) goto we_have_a_glob;
2553 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2555 SP = PL_stack_base + POPMARK;
2563 sv = amagic_deref_call(sv, to_cv_amg);
2564 /* Don't SPAGAIN here. */
2571 DIE(aTHX_ PL_no_usym, "a subroutine");
2572 sym = SvPV_nomg_const(sv, len);
2573 if (PL_op->op_private & HINT_STRICT_REFS)
2574 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2575 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2578 cv = MUTABLE_CV(SvRV(sv));
2579 if (SvTYPE(cv) == SVt_PVCV)
2584 DIE(aTHX_ "Not a CODE reference");
2585 /* This is the second most common case: */
2587 cv = MUTABLE_CV(sv);
2595 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
2596 DIE(aTHX_ "Closure prototype called");
2597 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2601 /* anonymous or undef'd function leaves us no recourse */
2602 if (CvLEXICAL(cv) && CvHASGV(cv))
2603 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
2604 SVfARG(cv_name(cv, NULL)));
2605 if (CvANON(cv) || !CvHASGV(cv)) {
2606 DIE(aTHX_ "Undefined subroutine called");
2609 /* autoloaded stub? */
2610 if (cv != GvCV(gv = CvGV(cv))) {
2613 /* should call AUTOLOAD now? */
2616 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2617 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2623 sub_name = sv_newmortal();
2624 gv_efullname3(sub_name, gv, NULL);
2625 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2633 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2636 Perl_get_db_sub(aTHX_ &sv, cv);
2638 PL_curcopdb = PL_curcop;
2640 /* check for lsub that handles lvalue subroutines */
2641 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2642 /* if lsub not found then fall back to DB::sub */
2643 if (!cv) cv = GvCV(PL_DBsub);
2645 cv = GvCV(PL_DBsub);
2648 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2649 DIE(aTHX_ "No DB::sub routine defined");
2654 if (!(CvISXSUB(cv))) {
2655 /* This path taken at least 75% of the time */
2657 PADLIST * const padlist = CvPADLIST(cv);
2660 PUSHBLOCK(cx, CXt_SUB, MARK);
2662 cx->blk_sub.retop = PL_op->op_next;
2663 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
2664 PERL_STACK_OVERFLOW_CHECK();
2665 pad_push(padlist, depth);
2668 PAD_SET_CUR_NOSAVE(padlist, depth);
2669 if (LIKELY(hasargs)) {
2670 AV *const av = MUTABLE_AV(PAD_SVl(0));
2674 if (UNLIKELY(AvREAL(av))) {
2675 /* @_ is normally not REAL--this should only ever
2676 * happen when DB::sub() calls things that modify @_ */
2681 defavp = &GvAV(PL_defgv);
2682 cx->blk_sub.savearray = *defavp;
2683 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
2684 CX_CURPAD_SAVE(cx->blk_sub);
2685 cx->blk_sub.argarray = av;
2688 if (UNLIKELY(items - 1 > AvMAX(av))) {
2689 SV **ary = AvALLOC(av);
2690 AvMAX(av) = items - 1;
2691 Renew(ary, items, SV*);
2696 Copy(MARK+1,AvARRAY(av),items,SV*);
2697 AvFILLp(av) = items - 1;
2703 if (SvPADTMP(*MARK)) {
2704 *MARK = sv_mortalcopy(*MARK);
2712 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2714 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2715 /* warning must come *after* we fully set up the context
2716 * stuff so that __WARN__ handlers can safely dounwind()
2719 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
2720 && ckWARN(WARN_RECURSION)
2721 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
2722 sub_crush_depth(cv);
2723 RETURNOP(CvSTART(cv));
2726 SSize_t markix = TOPMARK;
2731 if (UNLIKELY(((PL_op->op_private
2732 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2733 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2735 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2737 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
2738 /* Need to copy @_ to stack. Alternative may be to
2739 * switch stack to @_, and copy return values
2740 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2741 AV * const av = GvAV(PL_defgv);
2742 const SSize_t items = AvFILL(av) + 1;
2746 const bool m = cBOOL(SvRMAGICAL(av));
2747 /* Mark is at the end of the stack. */
2749 for (; i < items; ++i)
2753 SV ** const svp = av_fetch(av, i, 0);
2754 sv = svp ? *svp : NULL;
2756 else sv = AvARRAY(av)[i];
2757 if (sv) SP[i+1] = sv;
2759 SP[i+1] = newSVavdefelem(av, i, 1);
2767 SV **mark = PL_stack_base + markix;
2768 SSize_t items = SP - mark;
2771 if (*mark && SvPADTMP(*mark)) {
2772 *mark = sv_mortalcopy(*mark);
2776 /* We assume first XSUB in &DB::sub is the called one. */
2777 if (UNLIKELY(PL_curcopdb)) {
2778 SAVEVPTR(PL_curcop);
2779 PL_curcop = PL_curcopdb;
2782 /* Do we need to open block here? XXXX */
2784 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2786 CvXSUB(cv)(aTHX_ cv);
2788 /* Enforce some sanity in scalar context. */
2789 if (gimme == G_SCALAR) {
2790 SV **svp = PL_stack_base + markix + 1;
2791 if (svp != PL_stack_sp) {
2792 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2802 Perl_sub_crush_depth(pTHX_ CV *cv)
2804 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2807 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2809 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2810 SVfARG(cv_name(cv,NULL)));
2818 SV* const elemsv = POPs;
2819 IV elem = SvIV(elemsv);
2820 AV *const av = MUTABLE_AV(POPs);
2821 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2822 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2823 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2824 bool preeminent = TRUE;
2827 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
2828 Perl_warner(aTHX_ packWARN(WARN_MISC),
2829 "Use of reference \"%"SVf"\" as array index",
2831 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
2834 if (UNLIKELY(localizing)) {
2838 /* If we can determine whether the element exist,
2839 * Try to preserve the existenceness of a tied array
2840 * element by using EXISTS and DELETE if possible.
2841 * Fallback to FETCH and STORE otherwise. */
2842 if (SvCANEXISTDELETE(av))
2843 preeminent = av_exists(av, elem);
2846 svp = av_fetch(av, elem, lval && !defer);
2848 #ifdef PERL_MALLOC_WRAP
2849 if (SvUOK(elemsv)) {
2850 const UV uv = SvUV(elemsv);
2851 elem = uv > IV_MAX ? IV_MAX : uv;
2853 else if (SvNOK(elemsv))
2854 elem = (IV)SvNV(elemsv);
2856 static const char oom_array_extend[] =
2857 "Out of memory during array extend"; /* Duplicated in av.c */
2858 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2861 if (!svp || !*svp) {
2864 DIE(aTHX_ PL_no_aelem, elem);
2865 len = av_tindex(av);
2866 mPUSHs(newSVavdefelem(av,
2867 /* Resolve a negative index now, unless it points before the
2868 beginning of the array, in which case record it for error
2869 reporting in magic_setdefelem. */
2870 elem < 0 && len + elem >= 0 ? len + elem : elem,
2874 if (UNLIKELY(localizing)) {
2876 save_aelem(av, elem, svp);
2878 SAVEADELETE(av, elem);
2880 else if (PL_op->op_private & OPpDEREF) {
2881 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2885 sv = (svp ? *svp : &PL_sv_undef);
2886 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2893 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2895 PERL_ARGS_ASSERT_VIVIFY_REF;
2900 Perl_croak_no_modify();
2901 prepare_SV_for_RV(sv);
2904 SvRV_set(sv, newSV(0));
2907 SvRV_set(sv, MUTABLE_SV(newAV()));
2910 SvRV_set(sv, MUTABLE_SV(newHV()));
2917 if (SvGMAGICAL(sv)) {
2918 /* copy the sv without magic to prevent magic from being
2920 SV* msv = sv_newmortal();
2921 sv_setsv_nomg(msv, sv);
2930 SV* const sv = TOPs;
2933 SV* const rsv = SvRV(sv);
2934 if (SvTYPE(rsv) == SVt_PVCV) {
2940 SETs(method_common(sv, NULL));
2947 SV* const sv = cSVOP_sv;
2948 U32 hash = SvSHARED_HASH(sv);
2950 XPUSHs(method_common(sv, &hash));
2955 S_method_common(pTHX_ SV* meth, U32* hashp)
2961 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2962 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2963 "package or object reference", SVfARG(meth)),
2965 : *(PL_stack_base + TOPMARK + 1);
2967 PERL_ARGS_ASSERT_METHOD_COMMON;
2971 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2976 ob = MUTABLE_SV(SvRV(sv));
2977 else if (!SvOK(sv)) goto undefined;
2978 else if (isGV_with_GP(sv)) {
2980 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2981 "without a package or object reference",
2984 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
2985 assert(!LvTARGLEN(ob));
2989 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
2992 /* this isn't a reference */
2995 const char * const packname = SvPV_nomg_const(sv, packlen);
2996 const U32 packname_utf8 = SvUTF8(sv);
2997 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
2998 if (stash) goto fetch;
3000 if (!(iogv = gv_fetchpvn_flags(
3001 packname, packlen, packname_utf8, SVt_PVIO
3003 !(ob=MUTABLE_SV(GvIO(iogv))))
3005 /* this isn't the name of a filehandle either */
3008 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3009 "without a package or object reference",
3012 /* assume it's a package name */
3013 stash = gv_stashpvn(packname, packlen, packname_utf8);
3014 if (!stash) packsv = sv;
3017 /* it _is_ a filehandle name -- replace with a reference */
3018 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3021 /* if we got here, ob should be an object or a glob */
3022 if (!ob || !(SvOBJECT(ob)
3023 || (isGV_with_GP(ob)
3024 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3027 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3028 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3029 ? newSVpvs_flags("DOES", SVs_TEMP)
3033 stash = SvSTASH(ob);
3036 /* NOTE: stash may be null, hope hv_fetch_ent and
3037 gv_fetchmethod can cope (it seems they can) */
3039 /* shortcut for simple names */
3041 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3043 gv = MUTABLE_GV(HeVAL(he));
3045 if (isGV(gv) && GvCV(gv) &&
3046 (!GvCVGEN(gv) || GvCVGEN(gv)
3047 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3048 return MUTABLE_SV(GvCV(gv));
3052 assert(stash || packsv);
3053 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3054 meth, GV_AUTOLOAD | GV_CROAK);
3057 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3062 * c-indentation-style: bsd
3064 * indent-tabs-mode: nil
3067 * ex: set ts=8 sts=4 sw=4 et: