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))
72 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
79 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
82 PUSHMARK(PL_stack_sp);
93 /* no PUTBACK, SETs doesn't inc/dec SP */
100 XPUSHs(MUTABLE_SV(cGVOP_gv));
102 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
108 /* also used for: pp_andassign() */
114 /* SP is not used to remove a variable that is saved across the
115 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
116 register or load/store vs direct mem ops macro is introduced, this
117 should be a define block between direct PL_stack_sp and dSP operations,
118 presently, using PL_stack_sp is bias towards CISC cpus */
119 SV * const sv = *PL_stack_sp;
123 if (PL_op->op_type == OP_AND)
125 return cLOGOP->op_other;
133 /* sassign keeps its args in the optree traditionally backwards.
134 So we pop them differently.
136 SV *left = POPs; SV *right = TOPs;
138 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
139 SV * const temp = left;
140 left = right; right = temp;
142 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
144 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
146 SV * const cv = SvRV(right);
147 const U32 cv_type = SvTYPE(cv);
148 const bool is_gv = isGV_with_GP(left);
149 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
155 /* Can do the optimisation if left (LVALUE) is not a typeglob,
156 right (RVALUE) is a reference to something, and we're in void
158 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
159 /* Is the target symbol table currently empty? */
160 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
161 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
162 /* Good. Create a new proxy constant subroutine in the target.
163 The gv becomes a(nother) reference to the constant. */
164 SV *const value = SvRV(cv);
166 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
167 SvPCS_IMPORTED_on(gv);
169 SvREFCNT_inc_simple_void(value);
175 /* Need to fix things up. */
177 /* Need to fix GV. */
178 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
182 /* We've been returned a constant rather than a full subroutine,
183 but they expect a subroutine reference to apply. */
185 ENTER_with_name("sassign_coderef");
186 SvREFCNT_inc_void(SvRV(cv));
187 /* newCONSTSUB takes a reference count on the passed in SV
188 from us. We set the name to NULL, otherwise we get into
189 all sorts of fun as the reference to our new sub is
190 donated to the GV that we're about to assign to.
192 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
195 LEAVE_with_name("sassign_coderef");
197 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
199 First: ops for \&{"BONK"}; return us the constant in the
201 Second: ops for *{"BONK"} cause that symbol table entry
202 (and our reference to it) to be upgraded from RV
204 Thirdly: We get here. cv is actually PVGV now, and its
205 GvCV() is actually the subroutine we're looking for
207 So change the reference so that it points to the subroutine
208 of that typeglob, as that's what they were after all along.
210 GV *const upgraded = MUTABLE_GV(cv);
211 CV *const source = GvCV(upgraded);
214 assert(CvFLAGS(source) & CVf_CONST);
216 SvREFCNT_inc_void(source);
217 SvREFCNT_dec_NN(upgraded);
218 SvRV_set(right, MUTABLE_SV(source));
224 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
225 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
228 packWARN(WARN_MISC), "Useless assignment to a temporary"
230 SvSetMagicSV(left, right);
240 RETURNOP(cLOGOP->op_other);
242 RETURNOP(cLOGOP->op_next);
248 TAINT_NOT; /* Each statement is presumed innocent */
249 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
251 if (!(PL_op->op_flags & OPf_SPECIAL)) {
252 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
253 LEAVE_SCOPE(oldsave);
260 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
265 const char *rpv = NULL;
267 bool rcopied = FALSE;
269 if (TARG == right && right != left) { /* $r = $l.$r */
270 rpv = SvPV_nomg_const(right, rlen);
271 rbyte = !DO_UTF8(right);
272 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
273 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
277 if (TARG != left) { /* not $l .= $r */
279 const char* const lpv = SvPV_nomg_const(left, llen);
280 lbyte = !DO_UTF8(left);
281 sv_setpvn(TARG, lpv, llen);
287 else { /* $l .= $r and left == TARG */
289 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
290 report_uninit(right);
294 SvPV_force_nomg_nolen(left);
296 lbyte = !DO_UTF8(left);
303 /* $r.$r: do magic twice: tied might return different 2nd time */
305 rpv = SvPV_nomg_const(right, rlen);
306 rbyte = !DO_UTF8(right);
308 if (lbyte != rbyte) {
309 /* sv_utf8_upgrade_nomg() may reallocate the stack */
312 sv_utf8_upgrade_nomg(TARG);
315 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
316 sv_utf8_upgrade_nomg(right);
317 rpv = SvPV_nomg_const(right, rlen);
321 sv_catpvn_nomg(TARG, rpv, rlen);
328 /* push the elements of av onto the stack.
329 * XXX Note that padav has similar code but without the mg_get().
330 * I suspect that the mg_get is no longer needed, but while padav
331 * differs, it can't share this function */
334 S_pushav(pTHX_ AV* const av)
337 const SSize_t maxarg = AvFILL(av) + 1;
339 if (UNLIKELY(SvRMAGICAL(av))) {
341 for (i=0; i < (PADOFFSET)maxarg; i++) {
342 SV ** const svp = av_fetch(av, i, FALSE);
343 /* See note in pp_helem, and bug id #27839 */
345 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
351 for (i=0; i < (PADOFFSET)maxarg; i++) {
352 SV * const sv = AvARRAY(av)[i];
353 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
361 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
366 PADOFFSET base = PL_op->op_targ;
367 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
369 if (PL_op->op_flags & OPf_SPECIAL) {
370 /* fake the RHS of my ($x,$y,..) = @_ */
372 S_pushav(aTHX_ GvAVn(PL_defgv));
376 /* note, this is only skipped for compile-time-known void cxt */
377 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
380 for (i = 0; i <count; i++)
381 *++SP = PAD_SV(base+i);
383 if (PL_op->op_private & OPpLVAL_INTRO) {
384 SV **svp = &(PAD_SVl(base));
385 const UV payload = (UV)(
386 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
387 | (count << SAVE_TIGHT_SHIFT)
388 | SAVEt_CLEARPADRANGE);
389 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
390 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
397 for (i = 0; i <count; i++)
398 SvPADSTALE_off(*svp++); /* mark lexical as active */
409 OP * const op = PL_op;
410 /* access PL_curpad once */
411 SV ** const padentry = &(PAD_SVl(op->op_targ));
416 PUTBACK; /* no pop/push after this, TOPs ok */
418 if (op->op_flags & OPf_MOD) {
419 if (op->op_private & OPpLVAL_INTRO)
420 if (!(op->op_private & OPpPAD_STATE))
421 save_clearsv(padentry);
422 if (op->op_private & OPpDEREF) {
423 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
424 than TARG reduces the scope of TARG, so it does not
425 span the call to save_clearsv, resulting in smaller
427 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
439 tryAMAGICunTARGETlist(iter_amg, 0);
440 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
442 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
443 if (!isGV_with_GP(PL_last_in_gv)) {
444 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
445 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
448 XPUSHs(MUTABLE_SV(PL_last_in_gv));
451 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
454 return do_readline();
462 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
466 (SvIOK_notUV(left) && SvIOK_notUV(right))
467 ? (SvIVX(left) == SvIVX(right))
468 : ( do_ncmp(left, right) == 0)
474 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
480 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
481 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
482 Perl_croak_no_modify();
483 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
484 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
486 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
487 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
489 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
490 if (inc) sv_inc(TOPs);
497 /* also used for: pp_orassign() */
506 if (PL_op->op_type == OP_OR)
508 RETURNOP(cLOGOP->op_other);
513 /* also used for: pp_dor() pp_dorassign() */
520 const int op_type = PL_op->op_type;
521 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
526 if (UNLIKELY(!sv || !SvANY(sv))) {
527 if (op_type == OP_DOR)
529 RETURNOP(cLOGOP->op_other);
535 if (UNLIKELY(!sv || !SvANY(sv)))
540 switch (SvTYPE(sv)) {
542 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
546 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
550 if (CvROOT(sv) || CvXSUB(sv))
563 if(op_type == OP_DOR)
565 RETURNOP(cLOGOP->op_other);
567 /* assuming OP_DEFINED */
575 dSP; dATARGET; bool useleft; SV *svl, *svr;
576 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
580 useleft = USE_LEFT(svl);
581 #ifdef PERL_PRESERVE_IVUV
582 /* We must see if we can perform the addition with integers if possible,
583 as the integer code detects overflow while the NV code doesn't.
584 If either argument hasn't had a numeric conversion yet attempt to get
585 the IV. It's important to do this now, rather than just assuming that
586 it's not IOK as a PV of "9223372036854775806" may not take well to NV
587 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
588 integer in case the second argument is IV=9223372036854775806
589 We can (now) rely on sv_2iv to do the right thing, only setting the
590 public IOK flag if the value in the NV (or PV) slot is truly integer.
592 A side effect is that this also aggressively prefers integer maths over
593 fp maths for integer values.
595 How to detect overflow?
597 C 99 section 6.2.6.1 says
599 The range of nonnegative values of a signed integer type is a subrange
600 of the corresponding unsigned integer type, and the representation of
601 the same value in each type is the same. A computation involving
602 unsigned operands can never overflow, because a result that cannot be
603 represented by the resulting unsigned integer type is reduced modulo
604 the number that is one greater than the largest value that can be
605 represented by the resulting type.
609 which I read as "unsigned ints wrap."
611 signed integer overflow seems to be classed as "exception condition"
613 If an exceptional condition occurs during the evaluation of an
614 expression (that is, if the result is not mathematically defined or not
615 in the range of representable values for its type), the behavior is
618 (6.5, the 5th paragraph)
620 I had assumed that on 2s complement machines signed arithmetic would
621 wrap, hence coded pp_add and pp_subtract on the assumption that
622 everything perl builds on would be happy. After much wailing and
623 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
624 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
625 unsigned code below is actually shorter than the old code. :-)
628 if (SvIV_please_nomg(svr)) {
629 /* Unless the left argument is integer in range we are going to have to
630 use NV maths. Hence only attempt to coerce the right argument if
631 we know the left is integer. */
639 /* left operand is undef, treat as zero. + 0 is identity,
640 Could SETi or SETu right now, but space optimise by not adding
641 lots of code to speed up what is probably a rarish case. */
643 /* Left operand is defined, so is it IV? */
644 if (SvIV_please_nomg(svl)) {
645 if ((auvok = SvUOK(svl)))
648 const IV aiv = SvIVX(svl);
651 auvok = 1; /* Now acting as a sign flag. */
652 } else { /* 2s complement assumption for IV_MIN */
660 bool result_good = 0;
663 bool buvok = SvUOK(svr);
668 const IV biv = SvIVX(svr);
675 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
676 else "IV" now, independent of how it came in.
677 if a, b represents positive, A, B negative, a maps to -A etc
682 all UV maths. negate result if A negative.
683 add if signs same, subtract if signs differ. */
689 /* Must get smaller */
695 /* result really should be -(auv-buv). as its negation
696 of true value, need to swap our result flag */
713 if (result <= (UV)IV_MIN)
716 /* result valid, but out of range for IV. */
721 } /* Overflow, drop through to NVs. */
726 NV value = SvNV_nomg(svr);
729 /* left operand is undef, treat as zero. + 0.0 is identity. */
733 SETn( value + SvNV_nomg(svl) );
739 /* also used for: pp_aelemfast_lex() */
744 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
745 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
746 const U32 lval = PL_op->op_flags & OPf_MOD;
747 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
748 SV *sv = (svp ? *svp : &PL_sv_undef);
750 if (UNLIKELY(!svp && lval))
751 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
754 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
764 do_join(TARG, *MARK, MARK, SP);
775 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
776 * will be enough to hold an OP*.
778 SV* const sv = sv_newmortal();
779 sv_upgrade(sv, SVt_PVLV);
781 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
784 XPUSHs(MUTABLE_SV(PL_op));
789 /* Oversized hot code. */
791 /* also used for: pp_say() */
795 dSP; dMARK; dORIGMARK;
799 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
803 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
806 if (MARK == ORIGMARK) {
807 /* If using default handle then we need to make space to
808 * pass object as 1st arg, so move other args up ...
812 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
815 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
817 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
818 | (PL_op->op_type == OP_SAY
819 ? TIED_METHOD_SAY : 0)), sp - mark);
822 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
823 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
826 SETERRNO(EBADF,RMS_IFI);
829 else if (!(fp = IoOFP(io))) {
831 report_wrongway_fh(gv, '<');
834 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
838 SV * const ofs = GvSV(PL_ofsgv); /* $, */
840 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
842 if (!do_print(*MARK, fp))
846 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
847 if (!do_print(GvSV(PL_ofsgv), fp)) {
856 if (!do_print(*MARK, fp))
864 if (PL_op->op_type == OP_SAY) {
865 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
868 else if (PL_ors_sv && SvOK(PL_ors_sv))
869 if (!do_print(PL_ors_sv, fp)) /* $\ */
872 if (IoFLAGS(io) & IOf_FLUSH)
873 if (PerlIO_flush(fp) == EOF)
883 XPUSHs(&PL_sv_undef);
888 /* also used for: pp_rv2hv() */
889 /* also called directly by pp_lvavref */
894 const I32 gimme = GIMME_V;
895 static const char an_array[] = "an ARRAY";
896 static const char a_hash[] = "a HASH";
897 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
898 || PL_op->op_type == OP_LVAVREF;
899 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
903 if (UNLIKELY(SvAMAGIC(sv))) {
904 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
907 if (UNLIKELY(SvTYPE(sv) != type))
908 /* diag_listed_as: Not an ARRAY reference */
909 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
910 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
911 && PL_op->op_private & OPpLVAL_INTRO))
912 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
914 else if (UNLIKELY(SvTYPE(sv) != type)) {
917 if (!isGV_with_GP(sv)) {
918 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
926 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
927 if (PL_op->op_private & OPpLVAL_INTRO)
928 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
930 if (PL_op->op_flags & OPf_REF) {
934 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
935 const I32 flags = is_lvalue_sub();
936 if (flags && !(flags & OPpENTERSUB_INARGS)) {
937 if (gimme != G_ARRAY)
938 goto croak_cant_return;
945 AV *const av = MUTABLE_AV(sv);
946 /* The guts of pp_rv2av, with no intending change to preserve history
947 (until such time as we get tools that can do blame annotation across
948 whitespace changes. */
949 if (gimme == G_ARRAY) {
955 else if (gimme == G_SCALAR) {
957 const SSize_t maxarg = AvFILL(av) + 1;
961 /* The guts of pp_rv2hv */
962 if (gimme == G_ARRAY) { /* array wanted */
964 return Perl_do_kv(aTHX);
966 else if ((PL_op->op_private & OPpTRUEBOOL
967 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
968 && block_gimme() == G_VOID ))
969 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
970 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
971 else if (gimme == G_SCALAR) {
973 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
980 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
981 is_pp_rv2av ? "array" : "hash");
986 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
988 PERL_ARGS_ASSERT_DO_ODDBALL;
991 if (ckWARN(WARN_MISC)) {
993 if (oddkey == firstkey &&
995 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
996 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
998 err = "Reference found where even-sized list expected";
1001 err = "Odd number of elements in hash assignment";
1002 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1011 SV **lastlelem = PL_stack_sp;
1012 SV **lastrelem = PL_stack_base + POPMARK;
1013 SV **firstrelem = PL_stack_base + POPMARK + 1;
1014 SV **firstlelem = lastrelem + 1;
1028 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1030 if (gimme == G_ARRAY)
1031 lval = PL_op->op_flags & OPf_MOD || LVRET;
1033 /* If there's a common identifier on both sides we have to take
1034 * special care that assigning the identifier on the left doesn't
1035 * clobber a value on the right that's used later in the list.
1036 * Don't bother if LHS is just an empty hash or array.
1039 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
1041 firstlelem != lastlelem
1042 || ! ((sv = *firstlelem))
1044 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1045 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1046 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1049 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1050 for (relem = firstrelem; relem <= lastrelem; relem++) {
1051 if (LIKELY((sv = *relem))) {
1052 TAINT_NOT; /* Each item is independent */
1054 /* Dear TODO test in t/op/sort.t, I love you.
1055 (It's relying on a panic, not a "semi-panic" from newSVsv()
1056 and then an assertion failure below.) */
1057 if (UNLIKELY(SvIS_FREED(sv))) {
1058 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1061 /* Not newSVsv(), as it does not allow copy-on-write,
1062 resulting in wasteful copies. We need a second copy of
1063 a temp here, hence the SV_NOSTEAL. */
1064 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1075 while (LIKELY(lelem <= lastlelem)) {
1077 TAINT_NOT; /* Each item stands on its own, taintwise. */
1079 if (UNLIKELY(!sv)) {
1082 ASSUME(SvTYPE(sv) == SVt_PVAV);
1084 switch (SvTYPE(sv)) {
1086 ary = MUTABLE_AV(sv);
1087 magic = SvMAGICAL(ary) != 0;
1089 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1091 av_extend(ary, lastrelem - relem);
1093 while (relem <= lastrelem) { /* gobble up all the rest */
1096 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1097 if (LIKELY(!alias)) {
1099 sv_setsv_nomg(sv, *relem);
1104 DIE(aTHX_ "Assigned value is not a reference");
1105 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1106 /* diag_listed_as: Assigned value is not %s reference */
1108 "Assigned value is not a SCALAR reference");
1110 *relem = sv_mortalcopy(*relem);
1111 /* XXX else check for weak refs? */
1112 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1115 didstore = av_store(ary,i++,sv);
1124 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1125 SvSETMAGIC(MUTABLE_SV(ary));
1128 case SVt_PVHV: { /* normal hash */
1132 SV** topelem = relem;
1133 SV **firsthashrelem = relem;
1135 hash = MUTABLE_HV(sv);
1136 magic = SvMAGICAL(hash) != 0;
1138 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1139 if (UNLIKELY(odd)) {
1140 do_oddball(lastrelem, firsthashrelem);
1141 /* we have firstlelem to reuse, it's not needed anymore
1143 *(lastrelem+1) = &PL_sv_undef;
1147 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1149 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1152 /* Copy the key if aassign is called in lvalue context,
1153 to avoid having the next op modify our rhs. Copy
1154 it also if it is gmagical, lest it make the
1155 hv_store_ent call below croak, leaking the value. */
1156 sv = lval || SvGMAGICAL(*relem)
1157 ? sv_mortalcopy(*relem)
1163 sv_setsv_nomg(tmpstr,*relem++); /* value */
1164 if (gimme == G_ARRAY) {
1165 if (hv_exists_ent(hash, sv, 0))
1166 /* key overwrites an existing entry */
1169 /* copy element back: possibly to an earlier
1170 * stack location if we encountered dups earlier,
1171 * possibly to a later stack location if odd */
1173 *topelem++ = tmpstr;
1176 didstore = hv_store_ent(hash,sv,tmpstr,0);
1178 if (!didstore) sv_2mortal(tmpstr);
1184 if (duplicates && gimme == G_ARRAY) {
1185 /* at this point we have removed the duplicate key/value
1186 * pairs from the stack, but the remaining values may be
1187 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1188 * the (a 2), but the stack now probably contains
1189 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1190 * obliterates the earlier key. So refresh all values. */
1191 lastrelem -= duplicates;
1192 relem = firsthashrelem;
1193 while (relem < lastrelem+odd) {
1195 he = hv_fetch_ent(hash, *relem++, 0, 0);
1196 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1199 if (odd && gimme == G_ARRAY) lastrelem++;
1203 if (SvIMMORTAL(sv)) {
1204 if (relem <= lastrelem)
1208 if (relem <= lastrelem) {
1210 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1211 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1214 packWARN(WARN_MISC),
1215 "Useless assignment to a temporary"
1217 sv_setsv(sv, *relem);
1221 sv_setsv(sv, &PL_sv_undef);
1226 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1227 /* Will be used to set PL_tainting below */
1228 Uid_t tmp_uid = PerlProc_getuid();
1229 Uid_t tmp_euid = PerlProc_geteuid();
1230 Gid_t tmp_gid = PerlProc_getgid();
1231 Gid_t tmp_egid = PerlProc_getegid();
1233 /* XXX $> et al currently silently ignore failures */
1234 if (PL_delaymagic & DM_UID) {
1235 #ifdef HAS_SETRESUID
1237 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1238 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1241 # ifdef HAS_SETREUID
1243 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1244 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1247 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1248 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1249 PL_delaymagic &= ~DM_RUID;
1251 # endif /* HAS_SETRUID */
1253 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1254 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1255 PL_delaymagic &= ~DM_EUID;
1257 # endif /* HAS_SETEUID */
1258 if (PL_delaymagic & DM_UID) {
1259 if (PL_delaymagic_uid != PL_delaymagic_euid)
1260 DIE(aTHX_ "No setreuid available");
1261 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1263 # endif /* HAS_SETREUID */
1264 #endif /* HAS_SETRESUID */
1266 tmp_uid = PerlProc_getuid();
1267 tmp_euid = PerlProc_geteuid();
1269 /* XXX $> et al currently silently ignore failures */
1270 if (PL_delaymagic & DM_GID) {
1271 #ifdef HAS_SETRESGID
1273 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1274 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1277 # ifdef HAS_SETREGID
1279 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1280 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1283 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1284 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1285 PL_delaymagic &= ~DM_RGID;
1287 # endif /* HAS_SETRGID */
1289 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1290 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1291 PL_delaymagic &= ~DM_EGID;
1293 # endif /* HAS_SETEGID */
1294 if (PL_delaymagic & DM_GID) {
1295 if (PL_delaymagic_gid != PL_delaymagic_egid)
1296 DIE(aTHX_ "No setregid available");
1297 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1299 # endif /* HAS_SETREGID */
1300 #endif /* HAS_SETRESGID */
1302 tmp_gid = PerlProc_getgid();
1303 tmp_egid = PerlProc_getegid();
1305 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1306 #ifdef NO_TAINT_SUPPORT
1307 PERL_UNUSED_VAR(tmp_uid);
1308 PERL_UNUSED_VAR(tmp_euid);
1309 PERL_UNUSED_VAR(tmp_gid);
1310 PERL_UNUSED_VAR(tmp_egid);
1315 if (gimme == G_VOID)
1316 SP = firstrelem - 1;
1317 else if (gimme == G_SCALAR) {
1320 SETi(lastrelem - firstrelem + 1);
1324 /* note that in this case *firstlelem may have been overwritten
1325 by sv_undef in the odd hash case */
1328 SP = firstrelem + (lastlelem - firstlelem);
1329 lelem = firstlelem + (relem - firstrelem);
1331 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1341 PMOP * const pm = cPMOP;
1342 REGEXP * rx = PM_GETRE(pm);
1343 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1344 SV * const rv = sv_newmortal();
1348 SvUPGRADE(rv, SVt_IV);
1349 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1350 loathe to use it here, but it seems to be the right fix. Or close.
1351 The key part appears to be that it's essential for pp_qr to return a new
1352 object (SV), which implies that there needs to be an effective way to
1353 generate a new SV from the existing SV that is pre-compiled in the
1355 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1358 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1359 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1360 *cvp = cv_clone(cv);
1361 SvREFCNT_dec_NN(cv);
1365 HV *const stash = gv_stashsv(pkg, GV_ADD);
1366 SvREFCNT_dec_NN(pkg);
1367 (void)sv_bless(rv, stash);
1370 if (UNLIKELY(RX_ISTAINTED(rx))) {
1372 SvTAINTED_on(SvRV(rv));
1385 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1388 const char *truebase; /* Start of string */
1389 REGEXP *rx = PM_GETRE(pm);
1391 const I32 gimme = GIMME;
1393 const I32 oldsave = PL_savestack_ix;
1394 I32 had_zerolen = 0;
1397 if (PL_op->op_flags & OPf_STACKED)
1399 else if (PL_op->op_private & OPpTARGET_MY)
1406 PUTBACK; /* EVAL blocks need stack_sp. */
1407 /* Skip get-magic if this is a qr// clone, because regcomp has
1409 truebase = ReANY(rx)->mother_re
1410 ? SvPV_nomg_const(TARG, len)
1411 : SvPV_const(TARG, len);
1413 DIE(aTHX_ "panic: pp_match");
1414 strend = truebase + len;
1415 rxtainted = (RX_ISTAINTED(rx) ||
1416 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1419 /* We need to know this in case we fail out early - pos() must be reset */
1420 global = dynpm->op_pmflags & PMf_GLOBAL;
1422 /* PMdf_USED is set after a ?? matches once */
1425 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1427 pm->op_pmflags & PMf_USED
1430 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1434 /* empty pattern special-cased to use last successful pattern if
1435 possible, except for qr// */
1436 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1442 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1443 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1444 UVuf" < %"IVdf")\n",
1445 (UV)len, (IV)RX_MINLEN(rx)));
1449 /* get pos() if //g */
1451 mg = mg_find_mglob(TARG);
1452 if (mg && mg->mg_len >= 0) {
1453 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1454 /* last time pos() was set, it was zero-length match */
1455 if (mg->mg_flags & MGf_MINMATCH)
1460 #ifdef PERL_SAWAMPERSAND
1463 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1464 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1468 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1469 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1470 * only on the first iteration. Therefore we need to copy $' as well
1471 * as $&, to make the rest of the string available for captures in
1472 * subsequent iterations */
1473 if (! (global && gimme == G_ARRAY))
1474 r_flags |= REXEC_COPY_SKIP_POST;
1476 #ifdef PERL_SAWAMPERSAND
1477 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1478 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1479 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1486 s = truebase + curpos;
1488 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1489 had_zerolen, TARG, NULL, r_flags))
1493 if (dynpm->op_pmflags & PMf_ONCE)
1495 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1497 dynpm->op_pmflags |= PMf_USED;
1501 RX_MATCH_TAINTED_on(rx);
1502 TAINT_IF(RX_MATCH_TAINTED(rx));
1506 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1508 mg = sv_magicext_mglob(TARG);
1509 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1510 if (RX_ZERO_LEN(rx))
1511 mg->mg_flags |= MGf_MINMATCH;
1513 mg->mg_flags &= ~MGf_MINMATCH;
1516 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1517 LEAVE_SCOPE(oldsave);
1521 /* push captures on stack */
1524 const I32 nparens = RX_NPARENS(rx);
1525 I32 i = (global && !nparens) ? 1 : 0;
1527 SPAGAIN; /* EVAL blocks could move the stack. */
1528 EXTEND(SP, nparens + i);
1529 EXTEND_MORTAL(nparens + i);
1530 for (i = !i; i <= nparens; i++) {
1531 PUSHs(sv_newmortal());
1532 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1533 && RX_OFFS(rx)[i].end != -1 ))
1535 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1536 const char * const s = RX_OFFS(rx)[i].start + truebase;
1537 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1538 || len < 0 || len > strend - s))
1539 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1540 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1541 (long) i, (long) RX_OFFS(rx)[i].start,
1542 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1543 sv_setpvn(*SP, s, len);
1544 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1549 curpos = (UV)RX_OFFS(rx)[0].end;
1550 had_zerolen = RX_ZERO_LEN(rx);
1551 PUTBACK; /* EVAL blocks may use stack */
1552 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1555 LEAVE_SCOPE(oldsave);
1561 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1563 mg = mg_find_mglob(TARG);
1567 LEAVE_SCOPE(oldsave);
1568 if (gimme == G_ARRAY)
1574 Perl_do_readline(pTHX)
1576 dSP; dTARGETSTACKED;
1581 IO * const io = GvIO(PL_last_in_gv);
1582 const I32 type = PL_op->op_type;
1583 const I32 gimme = GIMME_V;
1586 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1588 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1589 if (gimme == G_SCALAR) {
1591 SvSetSV_nosteal(TARG, TOPs);
1601 if (IoFLAGS(io) & IOf_ARGV) {
1602 if (IoFLAGS(io) & IOf_START) {
1604 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1605 IoFLAGS(io) &= ~IOf_START;
1606 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1607 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1608 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1609 SvSETMAGIC(GvSV(PL_last_in_gv));
1614 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1615 if (!fp) { /* Note: fp != IoIFP(io) */
1616 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1619 else if (type == OP_GLOB)
1620 fp = Perl_start_glob(aTHX_ POPs, io);
1622 else if (type == OP_GLOB)
1624 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1625 report_wrongway_fh(PL_last_in_gv, '>');
1629 if ((!io || !(IoFLAGS(io) & IOf_START))
1630 && ckWARN(WARN_CLOSED)
1633 report_evil_fh(PL_last_in_gv);
1635 if (gimme == G_SCALAR) {
1636 /* undef TARG, and push that undefined value */
1637 if (type != OP_RCATLINE) {
1638 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1646 if (gimme == G_SCALAR) {
1648 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1651 if (type == OP_RCATLINE)
1652 SvPV_force_nomg_nolen(sv);
1656 else if (isGV_with_GP(sv)) {
1657 SvPV_force_nomg_nolen(sv);
1659 SvUPGRADE(sv, SVt_PV);
1660 tmplen = SvLEN(sv); /* remember if already alloced */
1661 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1662 /* try short-buffering it. Please update t/op/readline.t
1663 * if you change the growth length.
1668 if (type == OP_RCATLINE && SvOK(sv)) {
1670 SvPV_force_nomg_nolen(sv);
1676 sv = sv_2mortal(newSV(80));
1680 /* This should not be marked tainted if the fp is marked clean */
1681 #define MAYBE_TAINT_LINE(io, sv) \
1682 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1687 /* delay EOF state for a snarfed empty file */
1688 #define SNARF_EOF(gimme,rs,io,sv) \
1689 (gimme != G_SCALAR || SvCUR(sv) \
1690 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1694 if (!sv_gets(sv, fp, offset)
1696 || SNARF_EOF(gimme, PL_rs, io, sv)
1697 || PerlIO_error(fp)))
1699 PerlIO_clearerr(fp);
1700 if (IoFLAGS(io) & IOf_ARGV) {
1701 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1704 (void)do_close(PL_last_in_gv, FALSE);
1706 else if (type == OP_GLOB) {
1707 if (!do_close(PL_last_in_gv, FALSE)) {
1708 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1709 "glob failed (child exited with status %d%s)",
1710 (int)(STATUS_CURRENT >> 8),
1711 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1714 if (gimme == G_SCALAR) {
1715 if (type != OP_RCATLINE) {
1716 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1722 MAYBE_TAINT_LINE(io, sv);
1725 MAYBE_TAINT_LINE(io, sv);
1727 IoFLAGS(io) |= IOf_NOLINE;
1731 if (type == OP_GLOB) {
1734 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1735 char * const tmps = SvEND(sv) - 1;
1736 if (*tmps == *SvPVX_const(PL_rs)) {
1738 SvCUR_set(sv, SvCUR(sv) - 1);
1741 for (t1 = SvPVX_const(sv); *t1; t1++)
1743 if (strchr("*%?", *t1))
1745 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1748 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1749 (void)POPs; /* Unmatched wildcard? Chuck it... */
1752 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1753 if (ckWARN(WARN_UTF8)) {
1754 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1755 const STRLEN len = SvCUR(sv) - offset;
1758 if (!is_utf8_string_loc(s, len, &f))
1759 /* Emulate :encoding(utf8) warning in the same case. */
1760 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1761 "utf8 \"\\x%02X\" does not map to Unicode",
1762 f < (U8*)SvEND(sv) ? *f : 0);
1765 if (gimme == G_ARRAY) {
1766 if (SvLEN(sv) - SvCUR(sv) > 20) {
1767 SvPV_shrink_to_cur(sv);
1769 sv = sv_2mortal(newSV(80));
1772 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1773 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1774 const STRLEN new_len
1775 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1776 SvPV_renew(sv, new_len);
1787 SV * const keysv = POPs;
1788 HV * const hv = MUTABLE_HV(POPs);
1789 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1790 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1792 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1793 bool preeminent = TRUE;
1795 if (SvTYPE(hv) != SVt_PVHV)
1802 /* If we can determine whether the element exist,
1803 * Try to preserve the existenceness of a tied hash
1804 * element by using EXISTS and DELETE if possible.
1805 * Fallback to FETCH and STORE otherwise. */
1806 if (SvCANEXISTDELETE(hv))
1807 preeminent = hv_exists_ent(hv, keysv, 0);
1810 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1811 svp = he ? &HeVAL(he) : NULL;
1813 if (!svp || !*svp || *svp == &PL_sv_undef) {
1817 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1819 lv = sv_newmortal();
1820 sv_upgrade(lv, SVt_PVLV);
1822 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1823 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1824 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1830 if (HvNAME_get(hv) && isGV(*svp))
1831 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1832 else if (preeminent)
1833 save_helem_flags(hv, keysv, svp,
1834 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1836 SAVEHDELETE(hv, keysv);
1838 else if (PL_op->op_private & OPpDEREF) {
1839 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1843 sv = (svp && *svp ? *svp : &PL_sv_undef);
1844 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1845 * was to make C<local $tied{foo} = $tied{foo}> possible.
1846 * However, it seems no longer to be needed for that purpose, and
1847 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1848 * would loop endlessly since the pos magic is getting set on the
1849 * mortal copy and lost. However, the copy has the effect of
1850 * triggering the get magic, and losing it altogether made things like
1851 * c<$tied{foo};> in void context no longer do get magic, which some
1852 * code relied on. Also, delayed triggering of magic on @+ and friends
1853 * meant the original regex may be out of scope by now. So as a
1854 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1855 * being called too many times). */
1856 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1870 cx = &cxstack[cxstack_ix];
1871 itersvp = CxITERVAR(cx);
1873 switch (CxTYPE(cx)) {
1875 case CXt_LOOP_LAZYSV: /* string increment */
1877 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1878 SV *end = cx->blk_loop.state_u.lazysv.end;
1879 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1880 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1882 const char *max = SvPV_const(end, maxlen);
1883 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
1887 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1888 /* safe to reuse old SV */
1889 sv_setsv(oldsv, cur);
1893 /* we need a fresh SV every time so that loop body sees a
1894 * completely new SV for closures/references to work as
1896 *itersvp = newSVsv(cur);
1897 SvREFCNT_dec_NN(oldsv);
1899 if (strEQ(SvPVX_const(cur), max))
1900 sv_setiv(cur, 0); /* terminate next time */
1906 case CXt_LOOP_LAZYIV: /* integer increment */
1908 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1909 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
1913 /* don't risk potential race */
1914 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1915 /* safe to reuse old SV */
1916 sv_setiv(oldsv, cur);
1920 /* we need a fresh SV every time so that loop body sees a
1921 * completely new SV for closures/references to work as they
1923 *itersvp = newSViv(cur);
1924 SvREFCNT_dec_NN(oldsv);
1927 if (UNLIKELY(cur == IV_MAX)) {
1928 /* Handle end of range at IV_MAX */
1929 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1931 ++cx->blk_loop.state_u.lazyiv.cur;
1935 case CXt_LOOP_FOR: /* iterate array */
1938 AV *av = cx->blk_loop.state_u.ary.ary;
1940 bool av_is_stack = FALSE;
1947 if (PL_op->op_private & OPpITER_REVERSED) {
1948 ix = --cx->blk_loop.state_u.ary.ix;
1949 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
1953 ix = ++cx->blk_loop.state_u.ary.ix;
1954 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
1958 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
1959 SV * const * const svp = av_fetch(av, ix, FALSE);
1960 sv = svp ? *svp : NULL;
1963 sv = AvARRAY(av)[ix];
1966 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
1967 SvSetMagicSV(*itersvp, sv);
1972 if (UNLIKELY(SvIS_FREED(sv))) {
1974 Perl_croak(aTHX_ "Use of freed value in iteration");
1981 SvREFCNT_inc_simple_void_NN(sv);
1984 else if (!av_is_stack) {
1985 sv = newSVavdefelem(av, ix, 0);
1992 SvREFCNT_dec(oldsv);
1997 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2003 A description of how taint works in pattern matching and substitution.
2005 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2006 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2008 While the pattern is being assembled/concatenated and then compiled,
2009 PL_tainted will get set (via TAINT_set) if any component of the pattern
2010 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2011 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2012 TAINT_get). It will also be set if any component of the pattern matches
2013 based on locale-dependent behavior.
2015 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2016 the pattern is marked as tainted. This means that subsequent usage, such
2017 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2018 on the new pattern too.
2020 RXf_TAINTED_SEEN is used post-execution by the get magic code
2021 of $1 et al to indicate whether the returned value should be tainted.
2022 It is the responsibility of the caller of the pattern (i.e. pp_match,
2023 pp_subst etc) to set this flag for any other circumstances where $1 needs
2026 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2028 There are three possible sources of taint
2030 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2031 * the replacement string (or expression under /e)
2033 There are four destinations of taint and they are affected by the sources
2034 according to the rules below:
2036 * the return value (not including /r):
2037 tainted by the source string and pattern, but only for the
2038 number-of-iterations case; boolean returns aren't tainted;
2039 * the modified string (or modified copy under /r):
2040 tainted by the source string, pattern, and replacement strings;
2042 tainted by the pattern, and under 'use re "taint"', by the source
2044 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2045 should always be unset before executing subsequent code.
2047 The overall action of pp_subst is:
2049 * at the start, set bits in rxtainted indicating the taint status of
2050 the various sources.
2052 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2053 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2054 pattern has subsequently become tainted via locale ops.
2056 * If control is being passed to pp_substcont to execute a /e block,
2057 save rxtainted in the CXt_SUBST block, for future use by
2060 * Whenever control is being returned to perl code (either by falling
2061 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2062 use the flag bits in rxtainted to make all the appropriate types of
2063 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2064 et al will appear tainted.
2066 pp_match is just a simpler version of the above.
2082 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2083 See "how taint works" above */
2086 REGEXP *rx = PM_GETRE(pm);
2088 int force_on_match = 0;
2089 const I32 oldsave = PL_savestack_ix;
2091 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2096 /* known replacement string? */
2097 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2101 if (PL_op->op_flags & OPf_STACKED)
2103 else if (PL_op->op_private & OPpTARGET_MY)
2110 SvGETMAGIC(TARG); /* must come before cow check */
2112 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2113 because they make integers such as 256 "false". */
2114 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2117 sv_force_normal_flags(TARG,0);
2119 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2120 && (SvREADONLY(TARG)
2121 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2122 || SvTYPE(TARG) > SVt_PVLV)
2123 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2124 Perl_croak_no_modify();
2127 orig = SvPV_nomg(TARG, len);
2128 /* note we don't (yet) force the var into being a string; if we fail
2129 * to match, we leave as-is; on successful match howeverm, we *will*
2130 * coerce into a string, then repeat the match */
2131 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2134 /* only replace once? */
2135 once = !(rpm->op_pmflags & PMf_GLOBAL);
2137 /* See "how taint works" above */
2140 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2141 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2142 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2143 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2144 ? SUBST_TAINT_BOOLRET : 0));
2150 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2152 strend = orig + len;
2153 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2154 maxiters = 2 * slen + 10; /* We can match twice at each
2155 position, once with zero-length,
2156 second time with non-zero. */
2158 if (!RX_PRELEN(rx) && PL_curpm
2159 && !ReANY(rx)->mother_re) {
2164 #ifdef PERL_SAWAMPERSAND
2165 r_flags = ( RX_NPARENS(rx)
2167 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2168 || (rpm->op_pmflags & PMf_KEEPCOPY)
2173 r_flags = REXEC_COPY_STR;
2176 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2179 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2180 LEAVE_SCOPE(oldsave);
2185 /* known replacement string? */
2187 /* replacement needing upgrading? */
2188 if (DO_UTF8(TARG) && !doutf8) {
2189 nsv = sv_newmortal();
2192 sv_recode_to_utf8(nsv, PL_encoding);
2194 sv_utf8_upgrade(nsv);
2195 c = SvPV_const(nsv, clen);
2199 c = SvPV_const(dstr, clen);
2200 doutf8 = DO_UTF8(dstr);
2203 if (SvTAINTED(dstr))
2204 rxtainted |= SUBST_TAINT_REPL;
2211 /* can do inplace substitution? */
2216 && (I32)clen <= RX_MINLENRET(rx)
2218 || !(r_flags & REXEC_COPY_STR)
2219 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2221 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2222 && (!doutf8 || SvUTF8(TARG))
2223 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2227 if (SvIsCOW(TARG)) {
2228 if (!force_on_match)
2230 assert(SvVOK(TARG));
2233 if (force_on_match) {
2234 /* redo the first match, this time with the orig var
2235 * forced into being a string */
2237 orig = SvPV_force_nomg(TARG, len);
2243 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2244 rxtainted |= SUBST_TAINT_PAT;
2245 m = orig + RX_OFFS(rx)[0].start;
2246 d = orig + RX_OFFS(rx)[0].end;
2248 if (m - s > strend - d) { /* faster to shorten from end */
2251 Copy(c, m, clen, char);
2256 Move(d, m, i, char);
2260 SvCUR_set(TARG, m - s);
2262 else { /* faster from front */
2266 Move(s, d - i, i, char);
2269 Copy(c, d, clen, char);
2276 d = s = RX_OFFS(rx)[0].start + orig;
2279 if (UNLIKELY(iters++ > maxiters))
2280 DIE(aTHX_ "Substitution loop");
2281 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2282 rxtainted |= SUBST_TAINT_PAT;
2283 m = RX_OFFS(rx)[0].start + orig;
2286 Move(s, d, i, char);
2290 Copy(c, d, clen, char);
2293 s = RX_OFFS(rx)[0].end + orig;
2294 } while (CALLREGEXEC(rx, s, strend, orig,
2295 s == m, /* don't match same null twice */
2297 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2300 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2301 Move(s, d, i+1, char); /* include the NUL */
2311 if (force_on_match) {
2312 /* redo the first match, this time with the orig var
2313 * forced into being a string */
2315 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2316 /* I feel that it should be possible to avoid this mortal copy
2317 given that the code below copies into a new destination.
2318 However, I suspect it isn't worth the complexity of
2319 unravelling the C<goto force_it> for the small number of
2320 cases where it would be viable to drop into the copy code. */
2321 TARG = sv_2mortal(newSVsv(TARG));
2323 orig = SvPV_force_nomg(TARG, len);
2329 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2330 rxtainted |= SUBST_TAINT_PAT;
2332 s = RX_OFFS(rx)[0].start + orig;
2333 dstr = newSVpvn_flags(orig, s-orig,
2334 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2339 /* note that a whole bunch of local vars are saved here for
2340 * use by pp_substcont: here's a list of them in case you're
2341 * searching for places in this sub that uses a particular var:
2342 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2343 * s m strend rx once */
2345 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2349 if (UNLIKELY(iters++ > maxiters))
2350 DIE(aTHX_ "Substitution loop");
2351 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2352 rxtainted |= SUBST_TAINT_PAT;
2353 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2355 char *old_orig = orig;
2356 assert(RX_SUBOFFSET(rx) == 0);
2358 orig = RX_SUBBEG(rx);
2359 s = orig + (old_s - old_orig);
2360 strend = s + (strend - old_s);
2362 m = RX_OFFS(rx)[0].start + orig;
2363 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2364 s = RX_OFFS(rx)[0].end + orig;
2366 /* replacement already stringified */
2368 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2373 if (!nsv) nsv = sv_newmortal();
2374 sv_copypv(nsv, repl);
2375 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2376 sv_catsv(dstr, nsv);
2378 else sv_catsv(dstr, repl);
2379 if (UNLIKELY(SvTAINTED(repl)))
2380 rxtainted |= SUBST_TAINT_REPL;
2384 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2386 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2387 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2389 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2390 /* From here on down we're using the copy, and leaving the original
2397 /* The match may make the string COW. If so, brilliant, because
2398 that's just saved us one malloc, copy and free - the regexp has
2399 donated the old buffer, and we malloc an entirely new one, rather
2400 than the regexp malloc()ing a buffer and copying our original,
2401 only for us to throw it away here during the substitution. */
2402 if (SvIsCOW(TARG)) {
2403 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2409 SvPV_set(TARG, SvPVX(dstr));
2410 SvCUR_set(TARG, SvCUR(dstr));
2411 SvLEN_set(TARG, SvLEN(dstr));
2412 SvFLAGS(TARG) |= SvUTF8(dstr);
2413 SvPV_set(dstr, NULL);
2420 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2421 (void)SvPOK_only_UTF8(TARG);
2424 /* See "how taint works" above */
2426 if ((rxtainted & SUBST_TAINT_PAT) ||
2427 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2428 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2430 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2432 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2433 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2435 SvTAINTED_on(TOPs); /* taint return value */
2437 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2439 /* needed for mg_set below */
2441 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2445 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2447 LEAVE_SCOPE(oldsave);
2456 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2457 ++*PL_markstack_ptr;
2459 LEAVE_with_name("grep_item"); /* exit inner scope */
2462 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2464 const I32 gimme = GIMME_V;
2466 LEAVE_with_name("grep"); /* exit outer scope */
2467 (void)POPMARK; /* pop src */
2468 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2469 (void)POPMARK; /* pop dst */
2470 SP = PL_stack_base + POPMARK; /* pop original mark */
2471 if (gimme == G_SCALAR) {
2472 if (PL_op->op_private & OPpGREP_LEX) {
2473 SV* const sv = sv_newmortal();
2474 sv_setiv(sv, items);
2482 else if (gimme == G_ARRAY)
2489 ENTER_with_name("grep_item"); /* enter inner scope */
2492 src = PL_stack_base[*PL_markstack_ptr];
2493 if (SvPADTMP(src)) {
2494 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2498 if (PL_op->op_private & OPpGREP_LEX)
2499 PAD_SVl(PL_op->op_targ) = src;
2503 RETURNOP(cLOGOP->op_other);
2517 if (CxMULTICALL(&cxstack[cxstack_ix]))
2521 cxstack_ix++; /* temporarily protect top context */
2524 if (gimme == G_SCALAR) {
2526 if (LIKELY(MARK <= SP)) {
2527 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2528 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2529 && !SvMAGICAL(TOPs)) {
2530 *MARK = SvREFCNT_inc(TOPs);
2535 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2537 *MARK = sv_mortalcopy(sv);
2538 SvREFCNT_dec_NN(sv);
2541 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2542 && !SvMAGICAL(TOPs)) {
2546 *MARK = sv_mortalcopy(TOPs);
2550 *MARK = &PL_sv_undef;
2554 else if (gimme == G_ARRAY) {
2555 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2556 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2557 || SvMAGICAL(*MARK)) {
2558 *MARK = sv_mortalcopy(*MARK);
2559 TAINT_NOT; /* Each item is independent */
2566 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2568 PL_curpm = newpm; /* ... and pop $1 et al */
2571 return cx->blk_sub.retop;
2581 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2584 DIE(aTHX_ "Not a CODE reference");
2585 /* This is overwhelmingly the most common case: */
2586 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
2587 switch (SvTYPE(sv)) {
2590 if (!(cv = GvCVu((const GV *)sv))) {
2592 cv = sv_2cv(sv, &stash, &gv, 0);
2601 if(isGV_with_GP(sv)) goto we_have_a_glob;
2604 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2606 SP = PL_stack_base + POPMARK;
2614 sv = amagic_deref_call(sv, to_cv_amg);
2615 /* Don't SPAGAIN here. */
2622 DIE(aTHX_ PL_no_usym, "a subroutine");
2623 sym = SvPV_nomg_const(sv, len);
2624 if (PL_op->op_private & HINT_STRICT_REFS)
2625 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2626 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2629 cv = MUTABLE_CV(SvRV(sv));
2630 if (SvTYPE(cv) == SVt_PVCV)
2635 DIE(aTHX_ "Not a CODE reference");
2636 /* This is the second most common case: */
2638 cv = MUTABLE_CV(sv);
2646 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
2647 DIE(aTHX_ "Closure prototype called");
2648 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2652 /* anonymous or undef'd function leaves us no recourse */
2653 if (CvLEXICAL(cv) && CvHASGV(cv))
2654 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
2655 SVfARG(cv_name(cv, NULL, 0)));
2656 if (CvANON(cv) || !CvHASGV(cv)) {
2657 DIE(aTHX_ "Undefined subroutine called");
2660 /* autoloaded stub? */
2661 if (cv != GvCV(gv = CvGV(cv))) {
2664 /* should call AUTOLOAD now? */
2667 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2668 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2674 sub_name = sv_newmortal();
2675 gv_efullname3(sub_name, gv, NULL);
2676 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2684 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2687 Perl_get_db_sub(aTHX_ &sv, cv);
2689 PL_curcopdb = PL_curcop;
2691 /* check for lsub that handles lvalue subroutines */
2692 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2693 /* if lsub not found then fall back to DB::sub */
2694 if (!cv) cv = GvCV(PL_DBsub);
2696 cv = GvCV(PL_DBsub);
2699 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2700 DIE(aTHX_ "No DB::sub routine defined");
2705 if (!(CvISXSUB(cv))) {
2706 /* This path taken at least 75% of the time */
2708 PADLIST * const padlist = CvPADLIST(cv);
2711 PUSHBLOCK(cx, CXt_SUB, MARK);
2713 cx->blk_sub.retop = PL_op->op_next;
2714 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
2715 PERL_STACK_OVERFLOW_CHECK();
2716 pad_push(padlist, depth);
2719 PAD_SET_CUR_NOSAVE(padlist, depth);
2720 if (LIKELY(hasargs)) {
2721 AV *const av = MUTABLE_AV(PAD_SVl(0));
2725 if (UNLIKELY(AvREAL(av))) {
2726 /* @_ is normally not REAL--this should only ever
2727 * happen when DB::sub() calls things that modify @_ */
2732 defavp = &GvAV(PL_defgv);
2733 cx->blk_sub.savearray = *defavp;
2734 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
2735 CX_CURPAD_SAVE(cx->blk_sub);
2736 cx->blk_sub.argarray = av;
2739 if (UNLIKELY(items - 1 > AvMAX(av))) {
2740 SV **ary = AvALLOC(av);
2741 AvMAX(av) = items - 1;
2742 Renew(ary, items, SV*);
2747 Copy(MARK+1,AvARRAY(av),items,SV*);
2748 AvFILLp(av) = items - 1;
2754 if (SvPADTMP(*MARK)) {
2755 *MARK = sv_mortalcopy(*MARK);
2763 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2765 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2766 /* warning must come *after* we fully set up the context
2767 * stuff so that __WARN__ handlers can safely dounwind()
2770 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
2771 && ckWARN(WARN_RECURSION)
2772 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
2773 sub_crush_depth(cv);
2774 RETURNOP(CvSTART(cv));
2777 SSize_t markix = TOPMARK;
2782 if (UNLIKELY(((PL_op->op_private
2783 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2784 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2786 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2788 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
2789 /* Need to copy @_ to stack. Alternative may be to
2790 * switch stack to @_, and copy return values
2791 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2792 AV * const av = GvAV(PL_defgv);
2793 const SSize_t items = AvFILL(av) + 1;
2797 const bool m = cBOOL(SvRMAGICAL(av));
2798 /* Mark is at the end of the stack. */
2800 for (; i < items; ++i)
2804 SV ** const svp = av_fetch(av, i, 0);
2805 sv = svp ? *svp : NULL;
2807 else sv = AvARRAY(av)[i];
2808 if (sv) SP[i+1] = sv;
2810 SP[i+1] = newSVavdefelem(av, i, 1);
2818 SV **mark = PL_stack_base + markix;
2819 SSize_t items = SP - mark;
2822 if (*mark && SvPADTMP(*mark)) {
2823 *mark = sv_mortalcopy(*mark);
2827 /* We assume first XSUB in &DB::sub is the called one. */
2828 if (UNLIKELY(PL_curcopdb)) {
2829 SAVEVPTR(PL_curcop);
2830 PL_curcop = PL_curcopdb;
2833 /* Do we need to open block here? XXXX */
2835 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2837 CvXSUB(cv)(aTHX_ cv);
2839 /* Enforce some sanity in scalar context. */
2840 if (gimme == G_SCALAR) {
2841 SV **svp = PL_stack_base + markix + 1;
2842 if (svp != PL_stack_sp) {
2843 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2853 Perl_sub_crush_depth(pTHX_ CV *cv)
2855 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2858 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2860 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2861 SVfARG(cv_name(cv,NULL,0)));
2869 SV* const elemsv = POPs;
2870 IV elem = SvIV(elemsv);
2871 AV *const av = MUTABLE_AV(POPs);
2872 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2873 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2874 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2875 bool preeminent = TRUE;
2878 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
2879 Perl_warner(aTHX_ packWARN(WARN_MISC),
2880 "Use of reference \"%"SVf"\" as array index",
2882 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
2885 if (UNLIKELY(localizing)) {
2889 /* If we can determine whether the element exist,
2890 * Try to preserve the existenceness of a tied array
2891 * element by using EXISTS and DELETE if possible.
2892 * Fallback to FETCH and STORE otherwise. */
2893 if (SvCANEXISTDELETE(av))
2894 preeminent = av_exists(av, elem);
2897 svp = av_fetch(av, elem, lval && !defer);
2899 #ifdef PERL_MALLOC_WRAP
2900 if (SvUOK(elemsv)) {
2901 const UV uv = SvUV(elemsv);
2902 elem = uv > IV_MAX ? IV_MAX : uv;
2904 else if (SvNOK(elemsv))
2905 elem = (IV)SvNV(elemsv);
2907 static const char oom_array_extend[] =
2908 "Out of memory during array extend"; /* Duplicated in av.c */
2909 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2912 if (!svp || !*svp) {
2915 DIE(aTHX_ PL_no_aelem, elem);
2916 len = av_tindex(av);
2917 mPUSHs(newSVavdefelem(av,
2918 /* Resolve a negative index now, unless it points before the
2919 beginning of the array, in which case record it for error
2920 reporting in magic_setdefelem. */
2921 elem < 0 && len + elem >= 0 ? len + elem : elem,
2925 if (UNLIKELY(localizing)) {
2927 save_aelem(av, elem, svp);
2929 SAVEADELETE(av, elem);
2931 else if (PL_op->op_private & OPpDEREF) {
2932 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2936 sv = (svp ? *svp : &PL_sv_undef);
2937 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2944 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2946 PERL_ARGS_ASSERT_VIVIFY_REF;
2951 Perl_croak_no_modify();
2952 prepare_SV_for_RV(sv);
2955 SvRV_set(sv, newSV(0));
2958 SvRV_set(sv, MUTABLE_SV(newAV()));
2961 SvRV_set(sv, MUTABLE_SV(newHV()));
2968 if (SvGMAGICAL(sv)) {
2969 /* copy the sv without magic to prevent magic from being
2971 SV* msv = sv_newmortal();
2972 sv_setsv_nomg(msv, sv);
2981 SV* const sv = TOPs;
2984 SV* const rsv = SvRV(sv);
2985 if (SvTYPE(rsv) == SVt_PVCV) {
2991 SETs(method_common(sv, NULL));
2998 SV* const meth = cMETHOPx_meth(PL_op);
2999 U32 hash = SvSHARED_HASH(meth);
3001 XPUSHs(method_common(meth, &hash));
3006 S_method_common(pTHX_ SV* meth, U32* hashp)
3012 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
3013 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3014 "package or object reference", SVfARG(meth)),
3016 : *(PL_stack_base + TOPMARK + 1);
3018 PERL_ARGS_ASSERT_METHOD_COMMON;
3022 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3027 ob = MUTABLE_SV(SvRV(sv));
3028 else if (!SvOK(sv)) goto undefined;
3029 else if (isGV_with_GP(sv)) {
3031 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3032 "without a package or object reference",
3035 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3036 assert(!LvTARGLEN(ob));
3040 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3043 /* this isn't a reference */
3046 const char * const packname = SvPV_nomg_const(sv, packlen);
3047 const U32 packname_utf8 = SvUTF8(sv);
3048 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3049 if (stash) goto fetch;
3051 if (!(iogv = gv_fetchpvn_flags(
3052 packname, packlen, packname_utf8, SVt_PVIO
3054 !(ob=MUTABLE_SV(GvIO(iogv))))
3056 /* this isn't the name of a filehandle either */
3059 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3060 "without a package or object reference",
3063 /* assume it's a package name */
3064 stash = gv_stashpvn(packname, packlen, packname_utf8);
3065 if (!stash) packsv = sv;
3068 /* it _is_ a filehandle name -- replace with a reference */
3069 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3072 /* if we got here, ob should be an object or a glob */
3073 if (!ob || !(SvOBJECT(ob)
3074 || (isGV_with_GP(ob)
3075 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3078 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3079 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3080 ? newSVpvs_flags("DOES", SVs_TEMP)
3084 stash = SvSTASH(ob);
3087 /* NOTE: stash may be null, hope hv_fetch_ent and
3088 gv_fetchmethod can cope (it seems they can) */
3090 /* shortcut for simple names */
3092 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3094 gv = MUTABLE_GV(HeVAL(he));
3096 if (isGV(gv) && GvCV(gv) &&
3097 (!GvCVGEN(gv) || GvCVGEN(gv)
3098 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3099 return MUTABLE_SV(GvCV(gv));
3103 assert(stash || packsv);
3104 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3105 meth, GV_AUTOLOAD | GV_CROAK);
3108 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3113 * c-indentation-style: bsd
3115 * indent-tabs-mode: nil
3118 * ex: set ts=8 sts=4 sw=4 et: