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 (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 && TAINT_get && !SvTAINTED(right))
138 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
139 SV * const cv = SvRV(right);
140 const U32 cv_type = SvTYPE(cv);
141 const bool is_gv = isGV_with_GP(left);
142 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
148 /* Can do the optimisation if left (LVALUE) is not a typeglob,
149 right (RVALUE) is a reference to something, and we're in void
151 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
152 /* Is the target symbol table currently empty? */
153 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
154 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
155 /* Good. Create a new proxy constant subroutine in the target.
156 The gv becomes a(nother) reference to the constant. */
157 SV *const value = SvRV(cv);
159 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
160 SvPCS_IMPORTED_on(gv);
162 SvREFCNT_inc_simple_void(value);
168 /* Need to fix things up. */
170 /* Need to fix GV. */
171 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
175 /* We've been returned a constant rather than a full subroutine,
176 but they expect a subroutine reference to apply. */
178 ENTER_with_name("sassign_coderef");
179 SvREFCNT_inc_void(SvRV(cv));
180 /* newCONSTSUB takes a reference count on the passed in SV
181 from us. We set the name to NULL, otherwise we get into
182 all sorts of fun as the reference to our new sub is
183 donated to the GV that we're about to assign to.
185 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
188 LEAVE_with_name("sassign_coderef");
190 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
192 First: ops for \&{"BONK"}; return us the constant in the
194 Second: ops for *{"BONK"} cause that symbol table entry
195 (and our reference to it) to be upgraded from RV
197 Thirdly: We get here. cv is actually PVGV now, and its
198 GvCV() is actually the subroutine we're looking for
200 So change the reference so that it points to the subroutine
201 of that typeglob, as that's what they were after all along.
203 GV *const upgraded = MUTABLE_GV(cv);
204 CV *const source = GvCV(upgraded);
207 assert(CvFLAGS(source) & CVf_CONST);
209 SvREFCNT_inc_void(source);
210 SvREFCNT_dec_NN(upgraded);
211 SvRV_set(right, MUTABLE_SV(source));
217 SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
218 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
221 packWARN(WARN_MISC), "Useless assignment to a temporary"
223 SvSetMagicSV(left, right);
233 RETURNOP(cLOGOP->op_other);
235 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 dVAR; 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 */
283 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
284 report_uninit(right);
287 SvPV_force_nomg_nolen(left);
288 lbyte = !DO_UTF8(left);
295 /* $r.$r: do magic twice: tied might return different 2nd time */
297 rpv = SvPV_nomg_const(right, rlen);
298 rbyte = !DO_UTF8(right);
300 if (lbyte != rbyte) {
301 /* sv_utf8_upgrade_nomg() may reallocate the stack */
304 sv_utf8_upgrade_nomg(TARG);
307 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
308 sv_utf8_upgrade_nomg(right);
309 rpv = SvPV_nomg_const(right, rlen);
313 sv_catpvn_nomg(TARG, rpv, rlen);
320 /* push the elements of av onto the stack.
321 * XXX Note that padav has similar code but without the mg_get().
322 * I suspect that the mg_get is no longer needed, but while padav
323 * differs, it can't share this function */
326 S_pushav(pTHX_ AV* const av)
329 const SSize_t maxarg = AvFILL(av) + 1;
331 if (SvRMAGICAL(av)) {
333 for (i=0; i < (PADOFFSET)maxarg; i++) {
334 SV ** const svp = av_fetch(av, i, FALSE);
335 /* See note in pp_helem, and bug id #27839 */
337 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
343 for (i=0; i < (PADOFFSET)maxarg; i++) {
344 SV * const sv = AvARRAY(av)[i];
345 SP[i+1] = sv ? sv : &PL_sv_undef;
353 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
358 PADOFFSET base = PL_op->op_targ;
359 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
361 if (PL_op->op_flags & OPf_SPECIAL) {
362 /* fake the RHS of my ($x,$y,..) = @_ */
364 S_pushav(aTHX_ GvAVn(PL_defgv));
368 /* note, this is only skipped for compile-time-known void cxt */
369 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
372 for (i = 0; i <count; i++)
373 *++SP = PAD_SV(base+i);
375 if (PL_op->op_private & OPpLVAL_INTRO) {
376 SV **svp = &(PAD_SVl(base));
377 const UV payload = (UV)(
378 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
379 | (count << SAVE_TIGHT_SHIFT)
380 | SAVEt_CLEARPADRANGE);
381 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
382 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
389 for (i = 0; i <count; i++)
390 SvPADSTALE_off(*svp++); /* mark lexical as active */
401 OP * const op = PL_op;
402 /* access PL_curpad once */
403 SV ** const padentry = &(PAD_SVl(op->op_targ));
408 PUTBACK; /* no pop/push after this, TOPs ok */
410 if (op->op_flags & OPf_MOD) {
411 if (op->op_private & OPpLVAL_INTRO)
412 if (!(op->op_private & OPpPAD_STATE))
413 save_clearsv(padentry);
414 if (op->op_private & OPpDEREF) {
415 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
416 than TARG reduces the scope of TARG, so it does not
417 span the call to save_clearsv, resulting in smaller
419 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
432 tryAMAGICunTARGETlist(iter_amg, 0);
433 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
435 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
436 if (!isGV_with_GP(PL_last_in_gv)) {
437 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
438 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
441 XPUSHs(MUTABLE_SV(PL_last_in_gv));
444 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
447 return do_readline();
455 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
459 (SvIOK_notUV(left) && SvIOK_notUV(right))
460 ? (SvIVX(left) == SvIVX(right))
461 : ( do_ncmp(left, right) == 0)
470 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
471 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
472 Perl_croak_no_modify();
473 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
474 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
476 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
477 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
479 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
480 if (inc) sv_inc(TOPs);
493 if (PL_op->op_type == OP_OR)
495 RETURNOP(cLOGOP->op_other);
504 const int op_type = PL_op->op_type;
505 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
510 if (!sv || !SvANY(sv)) {
511 if (op_type == OP_DOR)
513 RETURNOP(cLOGOP->op_other);
519 if (!sv || !SvANY(sv))
524 switch (SvTYPE(sv)) {
526 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
530 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
534 if (CvROOT(sv) || CvXSUB(sv))
547 if(op_type == OP_DOR)
549 RETURNOP(cLOGOP->op_other);
551 /* assuming OP_DEFINED */
559 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
560 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
564 useleft = USE_LEFT(svl);
565 #ifdef PERL_PRESERVE_IVUV
566 /* We must see if we can perform the addition with integers if possible,
567 as the integer code detects overflow while the NV code doesn't.
568 If either argument hasn't had a numeric conversion yet attempt to get
569 the IV. It's important to do this now, rather than just assuming that
570 it's not IOK as a PV of "9223372036854775806" may not take well to NV
571 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
572 integer in case the second argument is IV=9223372036854775806
573 We can (now) rely on sv_2iv to do the right thing, only setting the
574 public IOK flag if the value in the NV (or PV) slot is truly integer.
576 A side effect is that this also aggressively prefers integer maths over
577 fp maths for integer values.
579 How to detect overflow?
581 C 99 section 6.2.6.1 says
583 The range of nonnegative values of a signed integer type is a subrange
584 of the corresponding unsigned integer type, and the representation of
585 the same value in each type is the same. A computation involving
586 unsigned operands can never overflow, because a result that cannot be
587 represented by the resulting unsigned integer type is reduced modulo
588 the number that is one greater than the largest value that can be
589 represented by the resulting type.
593 which I read as "unsigned ints wrap."
595 signed integer overflow seems to be classed as "exception condition"
597 If an exceptional condition occurs during the evaluation of an
598 expression (that is, if the result is not mathematically defined or not
599 in the range of representable values for its type), the behavior is
602 (6.5, the 5th paragraph)
604 I had assumed that on 2s complement machines signed arithmetic would
605 wrap, hence coded pp_add and pp_subtract on the assumption that
606 everything perl builds on would be happy. After much wailing and
607 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
608 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
609 unsigned code below is actually shorter than the old code. :-)
612 if (SvIV_please_nomg(svr)) {
613 /* Unless the left argument is integer in range we are going to have to
614 use NV maths. Hence only attempt to coerce the right argument if
615 we know the left is integer. */
623 /* left operand is undef, treat as zero. + 0 is identity,
624 Could SETi or SETu right now, but space optimise by not adding
625 lots of code to speed up what is probably a rarish case. */
627 /* Left operand is defined, so is it IV? */
628 if (SvIV_please_nomg(svl)) {
629 if ((auvok = SvUOK(svl)))
632 const IV aiv = SvIVX(svl);
635 auvok = 1; /* Now acting as a sign flag. */
636 } else { /* 2s complement assumption for IV_MIN */
644 bool result_good = 0;
647 bool buvok = SvUOK(svr);
652 const IV biv = SvIVX(svr);
659 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
660 else "IV" now, independent of how it came in.
661 if a, b represents positive, A, B negative, a maps to -A etc
666 all UV maths. negate result if A negative.
667 add if signs same, subtract if signs differ. */
673 /* Must get smaller */
679 /* result really should be -(auv-buv). as its negation
680 of true value, need to swap our result flag */
697 if (result <= (UV)IV_MIN)
700 /* result valid, but out of range for IV. */
705 } /* Overflow, drop through to NVs. */
710 NV value = SvNV_nomg(svr);
713 /* left operand is undef, treat as zero. + 0.0 is identity. */
717 SETn( value + SvNV_nomg(svl) );
725 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
726 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
727 const U32 lval = PL_op->op_flags & OPf_MOD;
728 SV** const svp = av_fetch(av, PL_op->op_private, lval);
729 SV *sv = (svp ? *svp : &PL_sv_undef);
731 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
739 dVAR; dSP; dMARK; dTARGET;
741 do_join(TARG, *MARK, MARK, SP);
752 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
753 * will be enough to hold an OP*.
755 SV* const sv = sv_newmortal();
756 sv_upgrade(sv, SVt_PVLV);
758 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
761 XPUSHs(MUTABLE_SV(PL_op));
766 /* Oversized hot code. */
770 dVAR; dSP; dMARK; dORIGMARK;
774 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
778 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
781 if (MARK == ORIGMARK) {
782 /* If using default handle then we need to make space to
783 * pass object as 1st arg, so move other args up ...
787 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
790 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
792 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
793 | (PL_op->op_type == OP_SAY
794 ? TIED_METHOD_SAY : 0)), sp - mark);
797 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
798 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
801 SETERRNO(EBADF,RMS_IFI);
804 else if (!(fp = IoOFP(io))) {
806 report_wrongway_fh(gv, '<');
809 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
813 SV * const ofs = GvSV(PL_ofsgv); /* $, */
815 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
817 if (!do_print(*MARK, fp))
821 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
822 if (!do_print(GvSV(PL_ofsgv), fp)) {
831 if (!do_print(*MARK, fp))
839 if (PL_op->op_type == OP_SAY) {
840 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
843 else if (PL_ors_sv && SvOK(PL_ors_sv))
844 if (!do_print(PL_ors_sv, fp)) /* $\ */
847 if (IoFLAGS(io) & IOf_FLUSH)
848 if (PerlIO_flush(fp) == EOF)
858 XPUSHs(&PL_sv_undef);
865 const I32 gimme = GIMME_V;
866 static const char an_array[] = "an ARRAY";
867 static const char a_hash[] = "a HASH";
868 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
869 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
874 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
877 if (SvTYPE(sv) != type)
878 /* diag_listed_as: Not an ARRAY reference */
879 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
880 else if (PL_op->op_flags & OPf_MOD
881 && PL_op->op_private & OPpLVAL_INTRO)
882 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
884 else if (SvTYPE(sv) != type) {
887 if (!isGV_with_GP(sv)) {
888 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
896 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
897 if (PL_op->op_private & OPpLVAL_INTRO)
898 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
900 if (PL_op->op_flags & OPf_REF) {
904 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
905 const I32 flags = is_lvalue_sub();
906 if (flags && !(flags & OPpENTERSUB_INARGS)) {
907 if (gimme != G_ARRAY)
908 goto croak_cant_return;
915 AV *const av = MUTABLE_AV(sv);
916 /* The guts of pp_rv2av, with no intending change to preserve history
917 (until such time as we get tools that can do blame annotation across
918 whitespace changes. */
919 if (gimme == G_ARRAY) {
925 else if (gimme == G_SCALAR) {
927 const SSize_t maxarg = AvFILL(av) + 1;
931 /* The guts of pp_rv2hv */
932 if (gimme == G_ARRAY) { /* array wanted */
934 return Perl_do_kv(aTHX);
936 else if ((PL_op->op_private & OPpTRUEBOOL
937 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
938 && block_gimme() == G_VOID ))
939 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
940 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
941 else if (gimme == G_SCALAR) {
943 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
951 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
952 is_pp_rv2av ? "array" : "hash");
957 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
961 PERL_ARGS_ASSERT_DO_ODDBALL;
964 if (ckWARN(WARN_MISC)) {
966 if (oddkey == firstkey &&
968 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
969 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
971 err = "Reference found where even-sized list expected";
974 err = "Odd number of elements in hash assignment";
975 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
984 SV **lastlelem = PL_stack_sp;
985 SV **lastrelem = PL_stack_base + POPMARK;
986 SV **firstrelem = PL_stack_base + POPMARK + 1;
987 SV **firstlelem = lastrelem + 1;
1001 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1003 if (gimme == G_ARRAY)
1004 lval = PL_op->op_flags & OPf_MOD || LVRET;
1006 /* If there's a common identifier on both sides we have to take
1007 * special care that assigning the identifier on the left doesn't
1008 * clobber a value on the right that's used later in the list.
1009 * Don't bother if LHS is just an empty hash or array.
1012 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1014 firstlelem != lastlelem
1015 || ! ((sv = *firstlelem))
1017 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1018 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1019 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1022 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1023 for (relem = firstrelem; relem <= lastrelem; relem++) {
1024 if ((sv = *relem)) {
1025 TAINT_NOT; /* Each item is independent */
1027 /* Dear TODO test in t/op/sort.t, I love you.
1028 (It's relying on a panic, not a "semi-panic" from newSVsv()
1029 and then an assertion failure below.) */
1030 if (SvIS_FREED(sv)) {
1031 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1034 /* Not newSVsv(), as it does not allow copy-on-write,
1035 resulting in wasteful copies. We need a second copy of
1036 a temp here, hence the SV_NOSTEAL. */
1037 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1048 while (lelem <= lastlelem) {
1049 TAINT_NOT; /* Each item stands on its own, taintwise. */
1051 switch (SvTYPE(sv)) {
1053 ary = MUTABLE_AV(sv);
1054 magic = SvMAGICAL(ary) != 0;
1056 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1058 av_extend(ary, lastrelem - relem);
1060 while (relem <= lastrelem) { /* gobble up all the rest */
1063 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1065 sv_setsv_nomg(sv, *relem);
1067 didstore = av_store(ary,i++,sv);
1076 if (PL_delaymagic & DM_ARRAY_ISA)
1077 SvSETMAGIC(MUTABLE_SV(ary));
1080 case SVt_PVHV: { /* normal hash */
1084 SV** topelem = relem;
1085 SV **firsthashrelem = relem;
1087 hash = MUTABLE_HV(sv);
1088 magic = SvMAGICAL(hash) != 0;
1090 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1092 do_oddball(lastrelem, firsthashrelem);
1093 /* we have firstlelem to reuse, it's not needed anymore
1095 *(lastrelem+1) = &PL_sv_undef;
1099 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1101 while (relem < lastrelem+odd) { /* gobble up all the rest */
1104 /* Copy the key if aassign is called in lvalue context,
1105 to avoid having the next op modify our rhs. Copy
1106 it also if it is gmagical, lest it make the
1107 hv_store_ent call below croak, leaking the value. */
1108 sv = lval || SvGMAGICAL(*relem)
1109 ? sv_mortalcopy(*relem)
1115 sv_setsv_nomg(tmpstr,*relem++); /* value */
1116 if (gimme == G_ARRAY) {
1117 if (hv_exists_ent(hash, sv, 0))
1118 /* key overwrites an existing entry */
1121 /* copy element back: possibly to an earlier
1122 * stack location if we encountered dups earlier,
1123 * possibly to a later stack location if odd */
1125 *topelem++ = tmpstr;
1128 didstore = hv_store_ent(hash,sv,tmpstr,0);
1130 if (!didstore) sv_2mortal(tmpstr);
1136 if (duplicates && gimme == G_ARRAY) {
1137 /* at this point we have removed the duplicate key/value
1138 * pairs from the stack, but the remaining values may be
1139 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1140 * the (a 2), but the stack now probably contains
1141 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1142 * obliterates the earlier key. So refresh all values. */
1143 lastrelem -= duplicates;
1144 relem = firsthashrelem;
1145 while (relem < lastrelem+odd) {
1147 he = hv_fetch_ent(hash, *relem++, 0, 0);
1148 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1151 if (odd && gimme == G_ARRAY) lastrelem++;
1155 if (SvIMMORTAL(sv)) {
1156 if (relem <= lastrelem)
1160 if (relem <= lastrelem) {
1162 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1163 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1166 packWARN(WARN_MISC),
1167 "Useless assignment to a temporary"
1169 sv_setsv(sv, *relem);
1173 sv_setsv(sv, &PL_sv_undef);
1178 if (PL_delaymagic & ~DM_DELAY) {
1179 /* Will be used to set PL_tainting below */
1180 Uid_t tmp_uid = PerlProc_getuid();
1181 Uid_t tmp_euid = PerlProc_geteuid();
1182 Gid_t tmp_gid = PerlProc_getgid();
1183 Gid_t tmp_egid = PerlProc_getegid();
1185 if (PL_delaymagic & DM_UID) {
1186 #ifdef HAS_SETRESUID
1187 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1188 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1191 # ifdef HAS_SETREUID
1192 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1193 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1196 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1197 (void)setruid(PL_delaymagic_uid);
1198 PL_delaymagic &= ~DM_RUID;
1200 # endif /* HAS_SETRUID */
1202 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1203 (void)seteuid(PL_delaymagic_euid);
1204 PL_delaymagic &= ~DM_EUID;
1206 # endif /* HAS_SETEUID */
1207 if (PL_delaymagic & DM_UID) {
1208 if (PL_delaymagic_uid != PL_delaymagic_euid)
1209 DIE(aTHX_ "No setreuid available");
1210 (void)PerlProc_setuid(PL_delaymagic_uid);
1212 # endif /* HAS_SETREUID */
1213 #endif /* HAS_SETRESUID */
1214 tmp_uid = PerlProc_getuid();
1215 tmp_euid = PerlProc_geteuid();
1217 if (PL_delaymagic & DM_GID) {
1218 #ifdef HAS_SETRESGID
1219 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1220 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1223 # ifdef HAS_SETREGID
1224 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1225 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1228 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1229 (void)setrgid(PL_delaymagic_gid);
1230 PL_delaymagic &= ~DM_RGID;
1232 # endif /* HAS_SETRGID */
1234 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1235 (void)setegid(PL_delaymagic_egid);
1236 PL_delaymagic &= ~DM_EGID;
1238 # endif /* HAS_SETEGID */
1239 if (PL_delaymagic & DM_GID) {
1240 if (PL_delaymagic_gid != PL_delaymagic_egid)
1241 DIE(aTHX_ "No setregid available");
1242 (void)PerlProc_setgid(PL_delaymagic_gid);
1244 # endif /* HAS_SETREGID */
1245 #endif /* HAS_SETRESGID */
1246 tmp_gid = PerlProc_getgid();
1247 tmp_egid = PerlProc_getegid();
1249 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1250 #ifdef NO_TAINT_SUPPORT
1251 PERL_UNUSED_VAR(tmp_uid);
1252 PERL_UNUSED_VAR(tmp_euid);
1253 PERL_UNUSED_VAR(tmp_gid);
1254 PERL_UNUSED_VAR(tmp_egid);
1259 if (gimme == G_VOID)
1260 SP = firstrelem - 1;
1261 else if (gimme == G_SCALAR) {
1264 SETi(lastrelem - firstrelem + 1);
1268 /* note that in this case *firstlelem may have been overwritten
1269 by sv_undef in the odd hash case */
1272 SP = firstrelem + (lastlelem - firstlelem);
1273 lelem = firstlelem + (relem - firstrelem);
1275 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1285 PMOP * const pm = cPMOP;
1286 REGEXP * rx = PM_GETRE(pm);
1287 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1288 SV * const rv = sv_newmortal();
1292 SvUPGRADE(rv, SVt_IV);
1293 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1294 loathe to use it here, but it seems to be the right fix. Or close.
1295 The key part appears to be that it's essential for pp_qr to return a new
1296 object (SV), which implies that there needs to be an effective way to
1297 generate a new SV from the existing SV that is pre-compiled in the
1299 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1302 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1303 if ((cv = *cvp) && CvCLONE(*cvp)) {
1304 *cvp = cv_clone(cv);
1305 SvREFCNT_dec_NN(cv);
1309 HV *const stash = gv_stashsv(pkg, GV_ADD);
1310 SvREFCNT_dec_NN(pkg);
1311 (void)sv_bless(rv, stash);
1314 if (RX_ISTAINTED(rx)) {
1316 SvTAINTED_on(SvRV(rv));
1329 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1332 const char *truebase; /* Start of string */
1333 REGEXP *rx = PM_GETRE(pm);
1335 const I32 gimme = GIMME;
1337 const I32 oldsave = PL_savestack_ix;
1338 I32 had_zerolen = 0;
1341 if (PL_op->op_flags & OPf_STACKED)
1343 else if (PL_op->op_private & OPpTARGET_MY)
1350 PUTBACK; /* EVAL blocks need stack_sp. */
1351 /* Skip get-magic if this is a qr// clone, because regcomp has
1353 truebase = ReANY(rx)->mother_re
1354 ? SvPV_nomg_const(TARG, len)
1355 : SvPV_const(TARG, len);
1357 DIE(aTHX_ "panic: pp_match");
1358 strend = truebase + len;
1359 rxtainted = (RX_ISTAINTED(rx) ||
1360 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1363 /* We need to know this in case we fail out early - pos() must be reset */
1364 global = dynpm->op_pmflags & PMf_GLOBAL;
1366 /* PMdf_USED is set after a ?? matches once */
1369 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1371 pm->op_pmflags & PMf_USED
1374 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1378 /* empty pattern special-cased to use last successful pattern if
1379 possible, except for qr// */
1380 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1386 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1387 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1388 UVuf" < %"IVdf")\n",
1389 (UV)len, (IV)RX_MINLEN(rx)));
1393 /* get pos() if //g */
1395 mg = mg_find_mglob(TARG);
1396 if (mg && mg->mg_len >= 0) {
1397 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1398 /* last time pos() was set, it was zero-length match */
1399 if (mg->mg_flags & MGf_MINMATCH)
1404 #ifdef PERL_SAWAMPERSAND
1407 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1408 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1412 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1413 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1414 * only on the first iteration. Therefore we need to copy $' as well
1415 * as $&, to make the rest of the string available for captures in
1416 * subsequent iterations */
1417 if (! (global && gimme == G_ARRAY))
1418 r_flags |= REXEC_COPY_SKIP_POST;
1420 #ifdef PERL_SAWAMPERSAND
1421 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1422 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1423 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1430 s = truebase + curpos;
1432 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1433 had_zerolen, TARG, NULL, r_flags))
1437 if (dynpm->op_pmflags & PMf_ONCE)
1439 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1441 dynpm->op_pmflags |= PMf_USED;
1445 RX_MATCH_TAINTED_on(rx);
1446 TAINT_IF(RX_MATCH_TAINTED(rx));
1450 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1452 mg = sv_magicext_mglob(TARG);
1453 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1454 if (RX_ZERO_LEN(rx))
1455 mg->mg_flags |= MGf_MINMATCH;
1457 mg->mg_flags &= ~MGf_MINMATCH;
1460 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1461 LEAVE_SCOPE(oldsave);
1465 /* push captures on stack */
1468 const I32 nparens = RX_NPARENS(rx);
1469 I32 i = (global && !nparens) ? 1 : 0;
1471 SPAGAIN; /* EVAL blocks could move the stack. */
1472 EXTEND(SP, nparens + i);
1473 EXTEND_MORTAL(nparens + i);
1474 for (i = !i; i <= nparens; i++) {
1475 PUSHs(sv_newmortal());
1476 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1477 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1478 const char * const s = RX_OFFS(rx)[i].start + truebase;
1479 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1480 len < 0 || len > strend - s)
1481 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1482 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1483 (long) i, (long) RX_OFFS(rx)[i].start,
1484 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1485 sv_setpvn(*SP, s, len);
1486 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1491 curpos = (UV)RX_OFFS(rx)[0].end;
1492 had_zerolen = RX_ZERO_LEN(rx);
1493 PUTBACK; /* EVAL blocks may use stack */
1494 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1497 LEAVE_SCOPE(oldsave);
1503 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1505 mg = mg_find_mglob(TARG);
1509 LEAVE_SCOPE(oldsave);
1510 if (gimme == G_ARRAY)
1516 Perl_do_readline(pTHX)
1518 dVAR; dSP; dTARGETSTACKED;
1523 IO * const io = GvIO(PL_last_in_gv);
1524 const I32 type = PL_op->op_type;
1525 const I32 gimme = GIMME_V;
1528 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1530 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1531 if (gimme == G_SCALAR) {
1533 SvSetSV_nosteal(TARG, TOPs);
1543 if (IoFLAGS(io) & IOf_ARGV) {
1544 if (IoFLAGS(io) & IOf_START) {
1546 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1547 IoFLAGS(io) &= ~IOf_START;
1548 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1549 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1550 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1551 SvSETMAGIC(GvSV(PL_last_in_gv));
1556 fp = nextargv(PL_last_in_gv);
1557 if (!fp) { /* Note: fp != IoIFP(io) */
1558 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1561 else if (type == OP_GLOB)
1562 fp = Perl_start_glob(aTHX_ POPs, io);
1564 else if (type == OP_GLOB)
1566 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1567 report_wrongway_fh(PL_last_in_gv, '>');
1571 if ((!io || !(IoFLAGS(io) & IOf_START))
1572 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1574 if (type == OP_GLOB)
1575 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1576 "glob failed (can't start child: %s)",
1579 report_evil_fh(PL_last_in_gv);
1581 if (gimme == G_SCALAR) {
1582 /* undef TARG, and push that undefined value */
1583 if (type != OP_RCATLINE) {
1584 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1592 if (gimme == G_SCALAR) {
1594 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1597 if (type == OP_RCATLINE)
1598 SvPV_force_nomg_nolen(sv);
1602 else if (isGV_with_GP(sv)) {
1603 SvPV_force_nomg_nolen(sv);
1605 SvUPGRADE(sv, SVt_PV);
1606 tmplen = SvLEN(sv); /* remember if already alloced */
1607 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1608 /* try short-buffering it. Please update t/op/readline.t
1609 * if you change the growth length.
1614 if (type == OP_RCATLINE && SvOK(sv)) {
1616 SvPV_force_nomg_nolen(sv);
1622 sv = sv_2mortal(newSV(80));
1626 /* This should not be marked tainted if the fp is marked clean */
1627 #define MAYBE_TAINT_LINE(io, sv) \
1628 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1633 /* delay EOF state for a snarfed empty file */
1634 #define SNARF_EOF(gimme,rs,io,sv) \
1635 (gimme != G_SCALAR || SvCUR(sv) \
1636 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1640 if (!sv_gets(sv, fp, offset)
1642 || SNARF_EOF(gimme, PL_rs, io, sv)
1643 || PerlIO_error(fp)))
1645 PerlIO_clearerr(fp);
1646 if (IoFLAGS(io) & IOf_ARGV) {
1647 fp = nextargv(PL_last_in_gv);
1650 (void)do_close(PL_last_in_gv, FALSE);
1652 else if (type == OP_GLOB) {
1653 if (!do_close(PL_last_in_gv, FALSE)) {
1654 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1655 "glob failed (child exited with status %d%s)",
1656 (int)(STATUS_CURRENT >> 8),
1657 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1660 if (gimme == G_SCALAR) {
1661 if (type != OP_RCATLINE) {
1662 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1668 MAYBE_TAINT_LINE(io, sv);
1671 MAYBE_TAINT_LINE(io, sv);
1673 IoFLAGS(io) |= IOf_NOLINE;
1677 if (type == OP_GLOB) {
1680 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1681 char * const tmps = SvEND(sv) - 1;
1682 if (*tmps == *SvPVX_const(PL_rs)) {
1684 SvCUR_set(sv, SvCUR(sv) - 1);
1687 for (t1 = SvPVX_const(sv); *t1; t1++)
1688 if (!isALPHANUMERIC(*t1) &&
1689 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1691 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1692 (void)POPs; /* Unmatched wildcard? Chuck it... */
1695 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1696 if (ckWARN(WARN_UTF8)) {
1697 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1698 const STRLEN len = SvCUR(sv) - offset;
1701 if (!is_utf8_string_loc(s, len, &f))
1702 /* Emulate :encoding(utf8) warning in the same case. */
1703 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1704 "utf8 \"\\x%02X\" does not map to Unicode",
1705 f < (U8*)SvEND(sv) ? *f : 0);
1708 if (gimme == G_ARRAY) {
1709 if (SvLEN(sv) - SvCUR(sv) > 20) {
1710 SvPV_shrink_to_cur(sv);
1712 sv = sv_2mortal(newSV(80));
1715 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1716 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1717 const STRLEN new_len
1718 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1719 SvPV_renew(sv, new_len);
1730 SV * const keysv = POPs;
1731 HV * const hv = MUTABLE_HV(POPs);
1732 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1733 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1735 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1736 bool preeminent = TRUE;
1738 if (SvTYPE(hv) != SVt_PVHV)
1745 /* If we can determine whether the element exist,
1746 * Try to preserve the existenceness of a tied hash
1747 * element by using EXISTS and DELETE if possible.
1748 * Fallback to FETCH and STORE otherwise. */
1749 if (SvCANEXISTDELETE(hv))
1750 preeminent = hv_exists_ent(hv, keysv, 0);
1753 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1754 svp = he ? &HeVAL(he) : NULL;
1756 if (!svp || !*svp || *svp == &PL_sv_undef) {
1760 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1762 lv = sv_newmortal();
1763 sv_upgrade(lv, SVt_PVLV);
1765 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1766 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1767 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1773 if (HvNAME_get(hv) && isGV(*svp))
1774 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1775 else if (preeminent)
1776 save_helem_flags(hv, keysv, svp,
1777 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1779 SAVEHDELETE(hv, keysv);
1781 else if (PL_op->op_private & OPpDEREF) {
1782 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1786 sv = (svp && *svp ? *svp : &PL_sv_undef);
1787 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1788 * was to make C<local $tied{foo} = $tied{foo}> possible.
1789 * However, it seems no longer to be needed for that purpose, and
1790 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1791 * would loop endlessly since the pos magic is getting set on the
1792 * mortal copy and lost. However, the copy has the effect of
1793 * triggering the get magic, and losing it altogether made things like
1794 * c<$tied{foo};> in void context no longer do get magic, which some
1795 * code relied on. Also, delayed triggering of magic on @+ and friends
1796 * meant the original regex may be out of scope by now. So as a
1797 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1798 * being called too many times). */
1799 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1813 cx = &cxstack[cxstack_ix];
1814 itersvp = CxITERVAR(cx);
1816 switch (CxTYPE(cx)) {
1818 case CXt_LOOP_LAZYSV: /* string increment */
1820 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1821 SV *end = cx->blk_loop.state_u.lazysv.end;
1822 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1823 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1825 const char *max = SvPV_const(end, maxlen);
1826 if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1830 if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1831 /* safe to reuse old SV */
1832 sv_setsv(oldsv, cur);
1836 /* we need a fresh SV every time so that loop body sees a
1837 * completely new SV for closures/references to work as
1839 *itersvp = newSVsv(cur);
1840 SvREFCNT_dec_NN(oldsv);
1842 if (strEQ(SvPVX_const(cur), max))
1843 sv_setiv(cur, 0); /* terminate next time */
1849 case CXt_LOOP_LAZYIV: /* integer increment */
1851 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1852 if (cur > cx->blk_loop.state_u.lazyiv.end)
1856 /* don't risk potential race */
1857 if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1858 /* safe to reuse old SV */
1859 sv_setiv(oldsv, cur);
1863 /* we need a fresh SV every time so that loop body sees a
1864 * completely new SV for closures/references to work as they
1866 *itersvp = newSViv(cur);
1867 SvREFCNT_dec_NN(oldsv);
1870 if (cur == IV_MAX) {
1871 /* Handle end of range at IV_MAX */
1872 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1874 ++cx->blk_loop.state_u.lazyiv.cur;
1878 case CXt_LOOP_FOR: /* iterate array */
1881 AV *av = cx->blk_loop.state_u.ary.ary;
1883 bool av_is_stack = FALSE;
1890 if (PL_op->op_private & OPpITER_REVERSED) {
1891 ix = --cx->blk_loop.state_u.ary.ix;
1892 if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
1896 ix = ++cx->blk_loop.state_u.ary.ix;
1897 if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
1901 if (SvMAGICAL(av) || AvREIFY(av)) {
1902 SV * const * const svp = av_fetch(av, ix, FALSE);
1903 sv = svp ? *svp : NULL;
1906 sv = AvARRAY(av)[ix];
1910 if (SvIS_FREED(sv)) {
1912 Perl_croak(aTHX_ "Use of freed value in iteration");
1914 if (SvPADTMP(sv) && !IS_PADGV(sv))
1918 SvREFCNT_inc_simple_void_NN(sv);
1921 else if (!av_is_stack) {
1922 SV *lv = newSV_type(SVt_PVLV);
1924 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1925 LvTARG(lv) = SvREFCNT_inc_simple(av);
1927 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1935 SvREFCNT_dec(oldsv);
1940 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1946 A description of how taint works in pattern matching and substitution.
1948 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1949 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1951 While the pattern is being assembled/concatenated and then compiled,
1952 PL_tainted will get set (via TAINT_set) if any component of the pattern
1953 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1954 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1957 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1958 the pattern is marked as tainted. This means that subsequent usage, such
1959 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1960 on the new pattern too.
1962 At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
1963 regex is cleared; during execution, locale-variant ops such as POSIXL may
1964 set RXf_TAINTED_SEEN.
1966 RXf_TAINTED_SEEN is used post-execution by the get magic code
1967 of $1 et al to indicate whether the returned value should be tainted.
1968 It is the responsibility of the caller of the pattern (i.e. pp_match,
1969 pp_subst etc) to set this flag for any other circumstances where $1 needs
1972 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1974 There are three possible sources of taint
1976 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1977 * the replacement string (or expression under /e)
1979 There are four destinations of taint and they are affected by the sources
1980 according to the rules below:
1982 * the return value (not including /r):
1983 tainted by the source string and pattern, but only for the
1984 number-of-iterations case; boolean returns aren't tainted;
1985 * the modified string (or modified copy under /r):
1986 tainted by the source string, pattern, and replacement strings;
1988 tainted by the pattern, and under 'use re "taint"', by the source
1990 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1991 should always be unset before executing subsequent code.
1993 The overall action of pp_subst is:
1995 * at the start, set bits in rxtainted indicating the taint status of
1996 the various sources.
1998 * After each pattern execution, update the SUBST_TAINT_PAT bit in
1999 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2000 pattern has subsequently become tainted via locale ops.
2002 * If control is being passed to pp_substcont to execute a /e block,
2003 save rxtainted in the CXt_SUBST block, for future use by
2006 * Whenever control is being returned to perl code (either by falling
2007 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2008 use the flag bits in rxtainted to make all the appropriate types of
2009 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2010 et al will appear tainted.
2012 pp_match is just a simpler version of the above.
2028 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2029 See "how taint works" above */
2032 REGEXP *rx = PM_GETRE(pm);
2034 int force_on_match = 0;
2035 const I32 oldsave = PL_savestack_ix;
2037 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2042 /* known replacement string? */
2043 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2047 if (PL_op->op_flags & OPf_STACKED)
2049 else if (PL_op->op_private & OPpTARGET_MY)
2056 SvGETMAGIC(TARG); /* must come before cow check */
2058 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2059 because they make integers such as 256 "false". */
2060 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2063 sv_force_normal_flags(TARG,0);
2065 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2066 && (SvREADONLY(TARG)
2067 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2068 || SvTYPE(TARG) > SVt_PVLV)
2069 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2070 Perl_croak_no_modify();
2073 orig = SvPV_nomg(TARG, len);
2074 /* note we don't (yet) force the var into being a string; if we fail
2075 * to match, we leave as-is; on successful match howeverm, we *will*
2076 * coerce into a string, then repeat the match */
2077 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2080 /* only replace once? */
2081 once = !(rpm->op_pmflags & PMf_GLOBAL);
2083 /* See "how taint works" above */
2086 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2087 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2088 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2089 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2090 ? SUBST_TAINT_BOOLRET : 0));
2096 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2098 strend = orig + len;
2099 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2100 maxiters = 2 * slen + 10; /* We can match twice at each
2101 position, once with zero-length,
2102 second time with non-zero. */
2104 if (!RX_PRELEN(rx) && PL_curpm
2105 && !ReANY(rx)->mother_re) {
2110 #ifdef PERL_SAWAMPERSAND
2111 r_flags = ( RX_NPARENS(rx)
2113 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2114 || (rpm->op_pmflags & PMf_KEEPCOPY)
2119 r_flags = REXEC_COPY_STR;
2122 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2125 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2126 LEAVE_SCOPE(oldsave);
2131 /* known replacement string? */
2133 /* replacement needing upgrading? */
2134 if (DO_UTF8(TARG) && !doutf8) {
2135 nsv = sv_newmortal();
2138 sv_recode_to_utf8(nsv, PL_encoding);
2140 sv_utf8_upgrade(nsv);
2141 c = SvPV_const(nsv, clen);
2145 c = SvPV_const(dstr, clen);
2146 doutf8 = DO_UTF8(dstr);
2149 if (SvTAINTED(dstr))
2150 rxtainted |= SUBST_TAINT_REPL;
2157 /* can do inplace substitution? */
2162 && (I32)clen <= RX_MINLENRET(rx)
2164 || !(r_flags & REXEC_COPY_STR)
2165 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2167 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2168 && (!doutf8 || SvUTF8(TARG))
2169 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2173 if (SvIsCOW(TARG)) {
2174 if (!force_on_match)
2176 assert(SvVOK(TARG));
2179 if (force_on_match) {
2180 /* redo the first match, this time with the orig var
2181 * forced into being a string */
2183 orig = SvPV_force_nomg(TARG, len);
2189 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2190 rxtainted |= SUBST_TAINT_PAT;
2191 m = orig + RX_OFFS(rx)[0].start;
2192 d = orig + RX_OFFS(rx)[0].end;
2194 if (m - s > strend - d) { /* faster to shorten from end */
2197 Copy(c, m, clen, char);
2202 Move(d, m, i, char);
2206 SvCUR_set(TARG, m - s);
2208 else { /* faster from front */
2212 Move(s, d - i, i, char);
2215 Copy(c, d, clen, char);
2222 d = s = RX_OFFS(rx)[0].start + orig;
2225 if (iters++ > maxiters)
2226 DIE(aTHX_ "Substitution loop");
2227 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2228 rxtainted |= SUBST_TAINT_PAT;
2229 m = RX_OFFS(rx)[0].start + orig;
2232 Move(s, d, i, char);
2236 Copy(c, d, clen, char);
2239 s = RX_OFFS(rx)[0].end + orig;
2240 } while (CALLREGEXEC(rx, s, strend, orig,
2241 s == m, /* don't match same null twice */
2243 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2246 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2247 Move(s, d, i+1, char); /* include the NUL */
2257 if (force_on_match) {
2258 /* redo the first match, this time with the orig var
2259 * forced into being a string */
2261 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2262 /* I feel that it should be possible to avoid this mortal copy
2263 given that the code below copies into a new destination.
2264 However, I suspect it isn't worth the complexity of
2265 unravelling the C<goto force_it> for the small number of
2266 cases where it would be viable to drop into the copy code. */
2267 TARG = sv_2mortal(newSVsv(TARG));
2269 orig = SvPV_force_nomg(TARG, len);
2275 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2276 rxtainted |= SUBST_TAINT_PAT;
2278 s = RX_OFFS(rx)[0].start + orig;
2279 dstr = newSVpvn_flags(orig, s-orig,
2280 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2285 /* note that a whole bunch of local vars are saved here for
2286 * use by pp_substcont: here's a list of them in case you're
2287 * searching for places in this sub that uses a particular var:
2288 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2289 * s m strend rx once */
2291 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2295 if (iters++ > maxiters)
2296 DIE(aTHX_ "Substitution loop");
2297 if (RX_MATCH_TAINTED(rx))
2298 rxtainted |= SUBST_TAINT_PAT;
2299 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2301 char *old_orig = orig;
2302 assert(RX_SUBOFFSET(rx) == 0);
2304 orig = RX_SUBBEG(rx);
2305 s = orig + (old_s - old_orig);
2306 strend = s + (strend - old_s);
2308 m = RX_OFFS(rx)[0].start + orig;
2309 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2310 s = RX_OFFS(rx)[0].end + orig;
2312 /* replacement already stringified */
2314 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2319 if (!nsv) nsv = sv_newmortal();
2320 sv_copypv(nsv, repl);
2321 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2322 sv_catsv(dstr, nsv);
2324 else sv_catsv(dstr, repl);
2325 if (SvTAINTED(repl))
2326 rxtainted |= SUBST_TAINT_REPL;
2330 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2332 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2333 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2335 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2336 /* From here on down we're using the copy, and leaving the original
2343 /* The match may make the string COW. If so, brilliant, because
2344 that's just saved us one malloc, copy and free - the regexp has
2345 donated the old buffer, and we malloc an entirely new one, rather
2346 than the regexp malloc()ing a buffer and copying our original,
2347 only for us to throw it away here during the substitution. */
2348 if (SvIsCOW(TARG)) {
2349 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2355 SvPV_set(TARG, SvPVX(dstr));
2356 SvCUR_set(TARG, SvCUR(dstr));
2357 SvLEN_set(TARG, SvLEN(dstr));
2358 SvFLAGS(TARG) |= SvUTF8(dstr);
2359 SvPV_set(dstr, NULL);
2366 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2367 (void)SvPOK_only_UTF8(TARG);
2370 /* See "how taint works" above */
2372 if ((rxtainted & SUBST_TAINT_PAT) ||
2373 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2374 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2376 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2378 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2379 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2381 SvTAINTED_on(TOPs); /* taint return value */
2383 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2385 /* needed for mg_set below */
2387 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2391 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2393 LEAVE_SCOPE(oldsave);
2402 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2403 ++*PL_markstack_ptr;
2405 LEAVE_with_name("grep_item"); /* exit inner scope */
2408 if (PL_stack_base + *PL_markstack_ptr > SP) {
2410 const I32 gimme = GIMME_V;
2412 LEAVE_with_name("grep"); /* exit outer scope */
2413 (void)POPMARK; /* pop src */
2414 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2415 (void)POPMARK; /* pop dst */
2416 SP = PL_stack_base + POPMARK; /* pop original mark */
2417 if (gimme == G_SCALAR) {
2418 if (PL_op->op_private & OPpGREP_LEX) {
2419 SV* const sv = sv_newmortal();
2420 sv_setiv(sv, items);
2428 else if (gimme == G_ARRAY)
2435 ENTER_with_name("grep_item"); /* enter inner scope */
2438 src = PL_stack_base[*PL_markstack_ptr];
2439 if (SvPADTMP(src) && !IS_PADGV(src)) {
2440 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2444 if (PL_op->op_private & OPpGREP_LEX)
2445 PAD_SVl(PL_op->op_targ) = src;
2449 RETURNOP(cLOGOP->op_other);
2463 if (CxMULTICALL(&cxstack[cxstack_ix]))
2467 cxstack_ix++; /* temporarily protect top context */
2470 if (gimme == G_SCALAR) {
2473 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2474 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2475 && !SvMAGICAL(TOPs)) {
2476 *MARK = SvREFCNT_inc(TOPs);
2481 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2483 *MARK = sv_mortalcopy(sv);
2484 SvREFCNT_dec_NN(sv);
2487 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2488 && !SvMAGICAL(TOPs)) {
2492 *MARK = sv_mortalcopy(TOPs);
2496 *MARK = &PL_sv_undef;
2500 else if (gimme == G_ARRAY) {
2501 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2502 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2503 || SvMAGICAL(*MARK)) {
2504 *MARK = sv_mortalcopy(*MARK);
2505 TAINT_NOT; /* Each item is independent */
2512 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2514 PL_curpm = newpm; /* ... and pop $1 et al */
2517 return cx->blk_sub.retop;
2527 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2530 DIE(aTHX_ "Not a CODE reference");
2531 switch (SvTYPE(sv)) {
2532 /* This is overwhelming the most common case: */
2535 if (!(cv = GvCVu((const GV *)sv))) {
2537 cv = sv_2cv(sv, &stash, &gv, 0);
2546 if(isGV_with_GP(sv)) goto we_have_a_glob;
2549 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2551 SP = PL_stack_base + POPMARK;
2559 sv = amagic_deref_call(sv, to_cv_amg);
2560 /* Don't SPAGAIN here. */
2567 DIE(aTHX_ PL_no_usym, "a subroutine");
2568 sym = SvPV_nomg_const(sv, len);
2569 if (PL_op->op_private & HINT_STRICT_REFS)
2570 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2571 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2574 cv = MUTABLE_CV(SvRV(sv));
2575 if (SvTYPE(cv) == SVt_PVCV)
2580 DIE(aTHX_ "Not a CODE reference");
2581 /* This is the second most common case: */
2583 cv = MUTABLE_CV(sv);
2590 if (CvCLONE(cv) && ! CvCLONED(cv))
2591 DIE(aTHX_ "Closure prototype called");
2592 if (!CvROOT(cv) && !CvXSUB(cv)) {
2596 /* anonymous or undef'd function leaves us no recourse */
2597 if (CvANON(cv) || !(gv = CvGV(cv))) {
2599 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2600 HEKfARG(CvNAME_HEK(cv)));
2601 DIE(aTHX_ "Undefined subroutine called");
2604 /* autoloaded stub? */
2605 if (cv != GvCV(gv)) {
2608 /* should call AUTOLOAD now? */
2611 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2612 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2618 sub_name = sv_newmortal();
2619 gv_efullname3(sub_name, gv, NULL);
2620 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2629 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2630 Perl_get_db_sub(aTHX_ &sv, cv);
2632 PL_curcopdb = PL_curcop;
2634 /* check for lsub that handles lvalue subroutines */
2635 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2636 /* if lsub not found then fall back to DB::sub */
2637 if (!cv) cv = GvCV(PL_DBsub);
2639 cv = GvCV(PL_DBsub);
2642 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2643 DIE(aTHX_ "No DB::sub routine defined");
2646 if (!(CvISXSUB(cv))) {
2647 /* This path taken at least 75% of the time */
2649 I32 items = SP - MARK;
2650 PADLIST * const padlist = CvPADLIST(cv);
2651 PUSHBLOCK(cx, CXt_SUB, MARK);
2653 cx->blk_sub.retop = PL_op->op_next;
2655 if (CvDEPTH(cv) >= 2) {
2656 PERL_STACK_OVERFLOW_CHECK();
2657 pad_push(padlist, CvDEPTH(cv));
2660 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2662 AV *const av = MUTABLE_AV(PAD_SVl(0));
2664 /* @_ is normally not REAL--this should only ever
2665 * happen when DB::sub() calls things that modify @_ */
2670 cx->blk_sub.savearray = GvAV(PL_defgv);
2671 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2672 CX_CURPAD_SAVE(cx->blk_sub);
2673 cx->blk_sub.argarray = av;
2676 if (items - 1 > AvMAX(av)) {
2677 SV **ary = AvALLOC(av);
2678 AvMAX(av) = items - 1;
2679 Renew(ary, items, SV*);
2684 Copy(MARK,AvARRAY(av),items,SV*);
2685 AvFILLp(av) = items - 1;
2691 if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
2692 *MARK = sv_mortalcopy(*MARK);
2699 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2701 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2702 /* warning must come *after* we fully set up the context
2703 * stuff so that __WARN__ handlers can safely dounwind()
2706 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2707 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2708 sub_crush_depth(cv);
2709 RETURNOP(CvSTART(cv));
2712 I32 markix = TOPMARK;
2717 if (((PL_op->op_private
2718 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2719 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2721 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2724 /* Need to copy @_ to stack. Alternative may be to
2725 * switch stack to @_, and copy return values
2726 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2727 AV * const av = GvAV(PL_defgv);
2728 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2731 /* Mark is at the end of the stack. */
2733 Copy(AvARRAY(av), SP + 1, items, SV*);
2739 SV **mark = PL_stack_base + markix;
2740 I32 items = SP - mark;
2743 if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
2744 *mark = sv_mortalcopy(*mark);
2747 /* We assume first XSUB in &DB::sub is the called one. */
2749 SAVEVPTR(PL_curcop);
2750 PL_curcop = PL_curcopdb;
2753 /* Do we need to open block here? XXXX */
2755 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2757 CvXSUB(cv)(aTHX_ cv);
2759 /* Enforce some sanity in scalar context. */
2760 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2761 if (markix > PL_stack_sp - PL_stack_base)
2762 *(PL_stack_base + markix) = &PL_sv_undef;
2764 *(PL_stack_base + markix) = *PL_stack_sp;
2765 PL_stack_sp = PL_stack_base + markix;
2773 Perl_sub_crush_depth(pTHX_ CV *cv)
2775 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2778 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2780 HEK *const hek = CvNAME_HEK(cv);
2783 tmpstr = sv_2mortal(newSVhek(hek));
2786 tmpstr = sv_newmortal();
2787 gv_efullname3(tmpstr, CvGV(cv), NULL);
2789 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2798 SV* const elemsv = POPs;
2799 IV elem = SvIV(elemsv);
2800 AV *const av = MUTABLE_AV(POPs);
2801 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2802 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2803 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2804 bool preeminent = TRUE;
2807 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2808 Perl_warner(aTHX_ packWARN(WARN_MISC),
2809 "Use of reference \"%"SVf"\" as array index",
2811 if (SvTYPE(av) != SVt_PVAV)
2818 /* If we can determine whether the element exist,
2819 * Try to preserve the existenceness of a tied array
2820 * element by using EXISTS and DELETE if possible.
2821 * Fallback to FETCH and STORE otherwise. */
2822 if (SvCANEXISTDELETE(av))
2823 preeminent = av_exists(av, elem);
2826 svp = av_fetch(av, elem, lval && !defer);
2828 #ifdef PERL_MALLOC_WRAP
2829 if (SvUOK(elemsv)) {
2830 const UV uv = SvUV(elemsv);
2831 elem = uv > IV_MAX ? IV_MAX : uv;
2833 else if (SvNOK(elemsv))
2834 elem = (IV)SvNV(elemsv);
2836 static const char oom_array_extend[] =
2837 "Out of memory during array extend"; /* Duplicated in av.c */
2838 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2841 if (!svp || !*svp) {
2845 DIE(aTHX_ PL_no_aelem, elem);
2847 lv = sv_newmortal();
2848 sv_upgrade(lv, SVt_PVLV);
2850 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2851 LvTARG(lv) = SvREFCNT_inc_simple(av);
2852 /* Resolve a negative index now, unless it points before the
2853 beginning of the array, in which case record it for error
2854 reporting in magic_setdefelem. */
2856 elem < 0 && len + elem >= 0 ? len + elem : elem;
2863 save_aelem(av, elem, svp);
2865 SAVEADELETE(av, elem);
2867 else if (PL_op->op_private & OPpDEREF) {
2868 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2872 sv = (svp ? *svp : &PL_sv_undef);
2873 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2880 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2882 PERL_ARGS_ASSERT_VIVIFY_REF;
2887 Perl_croak_no_modify();
2888 prepare_SV_for_RV(sv);
2891 SvRV_set(sv, newSV(0));
2894 SvRV_set(sv, MUTABLE_SV(newAV()));
2897 SvRV_set(sv, MUTABLE_SV(newHV()));
2904 if (SvGMAGICAL(sv)) {
2905 /* copy the sv without magic to prevent magic from being
2907 SV* msv = sv_newmortal();
2908 sv_setsv_nomg(msv, sv);
2917 SV* const sv = TOPs;
2920 SV* const rsv = SvRV(sv);
2921 if (SvTYPE(rsv) == SVt_PVCV) {
2927 SETs(method_common(sv, NULL));
2934 SV* const sv = cSVOP_sv;
2935 U32 hash = SvSHARED_HASH(sv);
2937 XPUSHs(method_common(sv, &hash));
2942 S_method_common(pTHX_ SV* meth, U32* hashp)
2949 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2950 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2951 "package or object reference", SVfARG(meth)),
2953 : *(PL_stack_base + TOPMARK + 1);
2955 PERL_ARGS_ASSERT_METHOD_COMMON;
2959 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2964 ob = MUTABLE_SV(SvRV(sv));
2965 else if (!SvOK(sv)) goto undefined;
2966 else if (isGV_with_GP(sv)) {
2968 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2969 "without a package or object reference",
2972 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
2973 assert(!LvTARGLEN(ob));
2977 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
2980 /* this isn't a reference */
2983 const char * const packname = SvPV_nomg_const(sv, packlen);
2984 const bool packname_is_utf8 = !!SvUTF8(sv);
2985 const HE* const he =
2986 (const HE *)hv_common(
2987 PL_stashcache, NULL, packname, packlen,
2988 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
2992 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2993 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
2998 if (!(iogv = gv_fetchpvn_flags(
2999 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3001 !(ob=MUTABLE_SV(GvIO(iogv))))
3003 /* this isn't the name of a filehandle either */
3006 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3007 "without a package or object reference",
3010 /* assume it's a package name */
3011 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3015 SV* const ref = newSViv(PTR2IV(stash));
3016 (void)hv_store(PL_stashcache, packname,
3017 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3018 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3023 /* it _is_ a filehandle name -- replace with a reference */
3024 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3027 /* if we got here, ob should be an object or a glob */
3028 if (!ob || !(SvOBJECT(ob)
3029 || (isGV_with_GP(ob)
3030 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3033 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3034 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3035 ? newSVpvs_flags("DOES", SVs_TEMP)
3039 stash = SvSTASH(ob);
3042 /* NOTE: stash may be null, hope hv_fetch_ent and
3043 gv_fetchmethod can cope (it seems they can) */
3045 /* shortcut for simple names */
3047 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3049 gv = MUTABLE_GV(HeVAL(he));
3050 if (isGV(gv) && GvCV(gv) &&
3051 (!GvCVGEN(gv) || GvCVGEN(gv)
3052 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3053 return MUTABLE_SV(GvCV(gv));
3057 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3058 meth, GV_AUTOLOAD | GV_CROAK);
3062 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3067 * c-indentation-style: bsd
3069 * indent-tabs-mode: nil
3072 * ex: set ts=8 sts=4 sw=4 et: