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, pp_grepstart and
83 PUSHMARK(PL_stack_sp);
94 /* no PUTBACK, SETs doesn't inc/dec SP */
101 XPUSHs(MUTABLE_SV(cGVOP_gv));
103 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
109 /* also used for: pp_andassign() */
115 /* SP is not used to remove a variable that is saved across the
116 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
117 register or load/store vs direct mem ops macro is introduced, this
118 should be a define block between direct PL_stack_sp and dSP operations,
119 presently, using PL_stack_sp is bias towards CISC cpus */
120 SV * const sv = *PL_stack_sp;
124 if (PL_op->op_type == OP_AND)
126 return cLOGOP->op_other;
134 /* sassign keeps its args in the optree traditionally backwards.
135 So we pop them differently.
137 SV *left = POPs; SV *right = TOPs;
139 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
140 SV * const temp = left;
141 left = right; right = temp;
143 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
145 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
147 SV * const cv = SvRV(right);
148 const U32 cv_type = SvTYPE(cv);
149 const bool is_gv = isGV_with_GP(left);
150 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
156 /* Can do the optimisation if left (LVALUE) is not a typeglob,
157 right (RVALUE) is a reference to something, and we're in void
159 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
160 /* Is the target symbol table currently empty? */
161 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
162 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
163 /* Good. Create a new proxy constant subroutine in the target.
164 The gv becomes a(nother) reference to the constant. */
165 SV *const value = SvRV(cv);
167 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
168 SvPCS_IMPORTED_on(gv);
170 SvREFCNT_inc_simple_void(value);
176 /* Need to fix things up. */
178 /* Need to fix GV. */
179 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
183 /* We've been returned a constant rather than a full subroutine,
184 but they expect a subroutine reference to apply. */
186 ENTER_with_name("sassign_coderef");
187 SvREFCNT_inc_void(SvRV(cv));
188 /* newCONSTSUB takes a reference count on the passed in SV
189 from us. We set the name to NULL, otherwise we get into
190 all sorts of fun as the reference to our new sub is
191 donated to the GV that we're about to assign to.
193 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
196 LEAVE_with_name("sassign_coderef");
198 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
200 First: ops for \&{"BONK"}; return us the constant in the
202 Second: ops for *{"BONK"} cause that symbol table entry
203 (and our reference to it) to be upgraded from RV
205 Thirdly: We get here. cv is actually PVGV now, and its
206 GvCV() is actually the subroutine we're looking for
208 So change the reference so that it points to the subroutine
209 of that typeglob, as that's what they were after all along.
211 GV *const upgraded = MUTABLE_GV(cv);
212 CV *const source = GvCV(upgraded);
215 assert(CvFLAGS(source) & CVf_CONST);
217 SvREFCNT_inc_void(source);
218 SvREFCNT_dec_NN(upgraded);
219 SvRV_set(right, MUTABLE_SV(source));
225 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
226 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
229 packWARN(WARN_MISC), "Useless assignment to a temporary"
231 SvSetMagicSV(left, right);
241 RETURNOP(cLOGOP->op_other);
243 RETURNOP(cLOGOP->op_next);
249 TAINT_NOT; /* Each statement is presumed innocent */
250 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
252 if (!(PL_op->op_flags & OPf_SPECIAL)) {
253 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
254 LEAVE_SCOPE(oldsave);
261 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
266 const char *rpv = NULL;
268 bool rcopied = FALSE;
270 if (TARG == right && right != left) { /* $r = $l.$r */
271 rpv = SvPV_nomg_const(right, rlen);
272 rbyte = !DO_UTF8(right);
273 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
274 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
278 if (TARG != left) { /* not $l .= $r */
280 const char* const lpv = SvPV_nomg_const(left, llen);
281 lbyte = !DO_UTF8(left);
282 sv_setpvn(TARG, lpv, llen);
288 else { /* $l .= $r and left == TARG */
290 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
291 report_uninit(right);
295 SvPV_force_nomg_nolen(left);
297 lbyte = !DO_UTF8(left);
303 rpv = SvPV_nomg_const(right, rlen);
304 rbyte = !DO_UTF8(right);
306 if (lbyte != rbyte) {
308 sv_utf8_upgrade_nomg(TARG);
311 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
312 sv_utf8_upgrade_nomg(right);
313 rpv = SvPV_nomg_const(right, rlen);
316 sv_catpvn_nomg(TARG, rpv, rlen);
323 /* push the elements of av onto the stack.
324 * XXX Note that padav has similar code but without the mg_get().
325 * I suspect that the mg_get is no longer needed, but while padav
326 * differs, it can't share this function */
329 S_pushav(pTHX_ AV* const av)
332 const SSize_t maxarg = AvFILL(av) + 1;
334 if (UNLIKELY(SvRMAGICAL(av))) {
336 for (i=0; i < (PADOFFSET)maxarg; i++) {
337 SV ** const svp = av_fetch(av, i, FALSE);
338 /* See note in pp_helem, and bug id #27839 */
340 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
346 for (i=0; i < (PADOFFSET)maxarg; i++) {
347 SV * const sv = AvARRAY(av)[i];
348 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
356 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
361 PADOFFSET base = PL_op->op_targ;
362 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
364 if (PL_op->op_flags & OPf_SPECIAL) {
365 /* fake the RHS of my ($x,$y,..) = @_ */
367 S_pushav(aTHX_ GvAVn(PL_defgv));
371 /* note, this is only skipped for compile-time-known void cxt */
372 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
375 for (i = 0; i <count; i++)
376 *++SP = PAD_SV(base+i);
378 if (PL_op->op_private & OPpLVAL_INTRO) {
379 SV **svp = &(PAD_SVl(base));
380 const UV payload = (UV)(
381 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
382 | (count << SAVE_TIGHT_SHIFT)
383 | SAVEt_CLEARPADRANGE);
384 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
385 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
392 for (i = 0; i <count; i++)
393 SvPADSTALE_off(*svp++); /* mark lexical as active */
404 OP * const op = PL_op;
405 /* access PL_curpad once */
406 SV ** const padentry = &(PAD_SVl(op->op_targ));
411 PUTBACK; /* no pop/push after this, TOPs ok */
413 if (op->op_flags & OPf_MOD) {
414 if (op->op_private & OPpLVAL_INTRO)
415 if (!(op->op_private & OPpPAD_STATE))
416 save_clearsv(padentry);
417 if (op->op_private & OPpDEREF) {
418 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
419 than TARG reduces the scope of TARG, so it does not
420 span the call to save_clearsv, resulting in smaller
422 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
434 tryAMAGICunTARGETlist(iter_amg, 0);
435 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
437 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
438 if (!isGV_with_GP(PL_last_in_gv)) {
439 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
440 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
443 XPUSHs(MUTABLE_SV(PL_last_in_gv));
446 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
447 if (PL_last_in_gv == (GV *)&PL_sv_undef)
448 PL_last_in_gv = NULL;
450 assert(isGV_with_GP(PL_last_in_gv));
453 return do_readline();
461 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
465 (SvIOK_notUV(left) && SvIOK_notUV(right))
466 ? (SvIVX(left) == SvIVX(right))
467 : ( do_ncmp(left, right) == 0)
473 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
479 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
480 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
481 Perl_croak_no_modify();
482 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
483 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
485 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
486 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
488 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
489 if (inc) sv_inc(TOPs);
496 /* also used for: pp_orassign() */
505 if (PL_op->op_type == OP_OR)
507 RETURNOP(cLOGOP->op_other);
512 /* also used for: pp_dor() pp_dorassign() */
519 const int op_type = PL_op->op_type;
520 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
525 if (UNLIKELY(!sv || !SvANY(sv))) {
526 if (op_type == OP_DOR)
528 RETURNOP(cLOGOP->op_other);
534 if (UNLIKELY(!sv || !SvANY(sv)))
539 switch (SvTYPE(sv)) {
541 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
545 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
549 if (CvROOT(sv) || CvXSUB(sv))
562 if(op_type == OP_DOR)
564 RETURNOP(cLOGOP->op_other);
566 /* assuming OP_DEFINED */
574 dSP; dATARGET; bool useleft; SV *svl, *svr;
575 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
579 useleft = USE_LEFT(svl);
580 #ifdef PERL_PRESERVE_IVUV
581 /* We must see if we can perform the addition with integers if possible,
582 as the integer code detects overflow while the NV code doesn't.
583 If either argument hasn't had a numeric conversion yet attempt to get
584 the IV. It's important to do this now, rather than just assuming that
585 it's not IOK as a PV of "9223372036854775806" may not take well to NV
586 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
587 integer in case the second argument is IV=9223372036854775806
588 We can (now) rely on sv_2iv to do the right thing, only setting the
589 public IOK flag if the value in the NV (or PV) slot is truly integer.
591 A side effect is that this also aggressively prefers integer maths over
592 fp maths for integer values.
594 How to detect overflow?
596 C 99 section 6.2.6.1 says
598 The range of nonnegative values of a signed integer type is a subrange
599 of the corresponding unsigned integer type, and the representation of
600 the same value in each type is the same. A computation involving
601 unsigned operands can never overflow, because a result that cannot be
602 represented by the resulting unsigned integer type is reduced modulo
603 the number that is one greater than the largest value that can be
604 represented by the resulting type.
608 which I read as "unsigned ints wrap."
610 signed integer overflow seems to be classed as "exception condition"
612 If an exceptional condition occurs during the evaluation of an
613 expression (that is, if the result is not mathematically defined or not
614 in the range of representable values for its type), the behavior is
617 (6.5, the 5th paragraph)
619 I had assumed that on 2s complement machines signed arithmetic would
620 wrap, hence coded pp_add and pp_subtract on the assumption that
621 everything perl builds on would be happy. After much wailing and
622 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
623 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
624 unsigned code below is actually shorter than the old code. :-)
627 if (SvIV_please_nomg(svr)) {
628 /* Unless the left argument is integer in range we are going to have to
629 use NV maths. Hence only attempt to coerce the right argument if
630 we know the left is integer. */
638 /* left operand is undef, treat as zero. + 0 is identity,
639 Could SETi or SETu right now, but space optimise by not adding
640 lots of code to speed up what is probably a rarish case. */
642 /* Left operand is defined, so is it IV? */
643 if (SvIV_please_nomg(svl)) {
644 if ((auvok = SvUOK(svl)))
647 const IV aiv = SvIVX(svl);
650 auvok = 1; /* Now acting as a sign flag. */
652 auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
659 bool result_good = 0;
662 bool buvok = SvUOK(svr);
667 const IV biv = SvIVX(svr);
672 buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
674 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
675 else "IV" now, independent of how it came in.
676 if a, b represents positive, A, B negative, a maps to -A etc
681 all UV maths. negate result if A negative.
682 add if signs same, subtract if signs differ. */
688 /* Must get smaller */
694 /* result really should be -(auv-buv). as its negation
695 of true value, need to swap our result flag */
712 if (result <= (UV)IV_MIN)
713 SETi(result == (UV)IV_MIN
714 ? IV_MIN : -(IV)result);
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 */
947 if (gimme == G_ARRAY) {
953 else if (gimme == G_SCALAR) {
955 const SSize_t maxarg = AvFILL(av) + 1;
959 /* The guts of pp_rv2hv */
960 if (gimme == G_ARRAY) { /* array wanted */
962 return Perl_do_kv(aTHX);
964 else if ((PL_op->op_private & OPpTRUEBOOL
965 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
966 && block_gimme() == G_VOID ))
967 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
968 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
969 else if (gimme == G_SCALAR) {
971 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
978 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
979 is_pp_rv2av ? "array" : "hash");
984 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
986 PERL_ARGS_ASSERT_DO_ODDBALL;
989 if (ckWARN(WARN_MISC)) {
991 if (oddkey == firstkey &&
993 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
994 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
996 err = "Reference found where even-sized list expected";
999 err = "Odd number of elements in hash assignment";
1000 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1009 SV **lastlelem = PL_stack_sp;
1010 SV **lastrelem = PL_stack_base + POPMARK;
1011 SV **firstrelem = PL_stack_base + POPMARK + 1;
1012 SV **firstlelem = lastrelem + 1;
1026 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1028 if (gimme == G_ARRAY)
1029 lval = PL_op->op_flags & OPf_MOD || LVRET;
1031 /* If there's a common identifier on both sides we have to take
1032 * special care that assigning the identifier on the left doesn't
1033 * clobber a value on the right that's used later in the list.
1034 * Don't bother if LHS is just an empty hash or array.
1037 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
1039 firstlelem != lastlelem
1040 || ! ((sv = *firstlelem))
1042 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1043 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1044 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1047 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1048 for (relem = firstrelem; relem <= lastrelem; relem++) {
1049 if (LIKELY((sv = *relem))) {
1050 TAINT_NOT; /* Each item is independent */
1052 /* Dear TODO test in t/op/sort.t, I love you.
1053 (It's relying on a panic, not a "semi-panic" from newSVsv()
1054 and then an assertion failure below.) */
1055 if (UNLIKELY(SvIS_FREED(sv))) {
1056 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1059 /* Not newSVsv(), as it does not allow copy-on-write,
1060 resulting in wasteful copies. We need a second copy of
1061 a temp here, hence the SV_NOSTEAL. */
1062 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1073 while (LIKELY(lelem <= lastlelem)) {
1075 TAINT_NOT; /* Each item stands on its own, taintwise. */
1077 if (UNLIKELY(!sv)) {
1080 ASSUME(SvTYPE(sv) == SVt_PVAV);
1082 switch (SvTYPE(sv)) {
1084 ary = MUTABLE_AV(sv);
1085 magic = SvMAGICAL(ary) != 0;
1087 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1089 av_extend(ary, lastrelem - relem);
1091 while (relem <= lastrelem) { /* gobble up all the rest */
1094 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1095 if (LIKELY(!alias)) {
1097 sv_setsv_nomg(sv, *relem);
1102 DIE(aTHX_ "Assigned value is not a reference");
1103 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1104 /* diag_listed_as: Assigned value is not %s reference */
1106 "Assigned value is not a SCALAR reference");
1108 *relem = sv_mortalcopy(*relem);
1109 /* XXX else check for weak refs? */
1110 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1113 didstore = av_store(ary,i++,sv);
1122 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1123 SvSETMAGIC(MUTABLE_SV(ary));
1126 case SVt_PVHV: { /* normal hash */
1130 SV** topelem = relem;
1131 SV **firsthashrelem = relem;
1133 hash = MUTABLE_HV(sv);
1134 magic = SvMAGICAL(hash) != 0;
1136 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1137 if (UNLIKELY(odd)) {
1138 do_oddball(lastrelem, firsthashrelem);
1139 /* we have firstlelem to reuse, it's not needed anymore
1141 *(lastrelem+1) = &PL_sv_undef;
1145 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1147 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1150 /* Copy the key if aassign is called in lvalue context,
1151 to avoid having the next op modify our rhs. Copy
1152 it also if it is gmagical, lest it make the
1153 hv_store_ent call below croak, leaking the value. */
1154 sv = lval || SvGMAGICAL(*relem)
1155 ? sv_mortalcopy(*relem)
1161 sv_setsv_nomg(tmpstr,*relem++); /* value */
1162 if (gimme == G_ARRAY) {
1163 if (hv_exists_ent(hash, sv, 0))
1164 /* key overwrites an existing entry */
1167 /* copy element back: possibly to an earlier
1168 * stack location if we encountered dups earlier,
1169 * possibly to a later stack location if odd */
1171 *topelem++ = tmpstr;
1174 didstore = hv_store_ent(hash,sv,tmpstr,0);
1176 if (!didstore) sv_2mortal(tmpstr);
1182 if (duplicates && gimme == G_ARRAY) {
1183 /* at this point we have removed the duplicate key/value
1184 * pairs from the stack, but the remaining values may be
1185 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1186 * the (a 2), but the stack now probably contains
1187 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1188 * obliterates the earlier key. So refresh all values. */
1189 lastrelem -= duplicates;
1190 relem = firsthashrelem;
1191 while (relem < lastrelem+odd) {
1193 he = hv_fetch_ent(hash, *relem++, 0, 0);
1194 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1197 if (odd && gimme == G_ARRAY) lastrelem++;
1201 if (SvIMMORTAL(sv)) {
1202 if (relem <= lastrelem)
1206 if (relem <= lastrelem) {
1208 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1209 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1212 packWARN(WARN_MISC),
1213 "Useless assignment to a temporary"
1215 sv_setsv(sv, *relem);
1219 sv_setsv(sv, &PL_sv_undef);
1224 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1225 /* Will be used to set PL_tainting below */
1226 Uid_t tmp_uid = PerlProc_getuid();
1227 Uid_t tmp_euid = PerlProc_geteuid();
1228 Gid_t tmp_gid = PerlProc_getgid();
1229 Gid_t tmp_egid = PerlProc_getegid();
1231 /* XXX $> et al currently silently ignore failures */
1232 if (PL_delaymagic & DM_UID) {
1233 #ifdef HAS_SETRESUID
1235 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1236 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1239 # ifdef HAS_SETREUID
1241 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1242 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1245 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1246 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1247 PL_delaymagic &= ~DM_RUID;
1249 # endif /* HAS_SETRUID */
1251 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1252 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1253 PL_delaymagic &= ~DM_EUID;
1255 # endif /* HAS_SETEUID */
1256 if (PL_delaymagic & DM_UID) {
1257 if (PL_delaymagic_uid != PL_delaymagic_euid)
1258 DIE(aTHX_ "No setreuid available");
1259 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1261 # endif /* HAS_SETREUID */
1262 #endif /* HAS_SETRESUID */
1264 tmp_uid = PerlProc_getuid();
1265 tmp_euid = PerlProc_geteuid();
1267 /* XXX $> et al currently silently ignore failures */
1268 if (PL_delaymagic & DM_GID) {
1269 #ifdef HAS_SETRESGID
1271 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1272 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1275 # ifdef HAS_SETREGID
1277 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1278 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1281 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1282 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1283 PL_delaymagic &= ~DM_RGID;
1285 # endif /* HAS_SETRGID */
1287 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1288 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1289 PL_delaymagic &= ~DM_EGID;
1291 # endif /* HAS_SETEGID */
1292 if (PL_delaymagic & DM_GID) {
1293 if (PL_delaymagic_gid != PL_delaymagic_egid)
1294 DIE(aTHX_ "No setregid available");
1295 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1297 # endif /* HAS_SETREGID */
1298 #endif /* HAS_SETRESGID */
1300 tmp_gid = PerlProc_getgid();
1301 tmp_egid = PerlProc_getegid();
1303 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1304 #ifdef NO_TAINT_SUPPORT
1305 PERL_UNUSED_VAR(tmp_uid);
1306 PERL_UNUSED_VAR(tmp_euid);
1307 PERL_UNUSED_VAR(tmp_gid);
1308 PERL_UNUSED_VAR(tmp_egid);
1313 if (gimme == G_VOID)
1314 SP = firstrelem - 1;
1315 else if (gimme == G_SCALAR) {
1318 SETi(lastrelem - firstrelem + 1);
1322 /* note that in this case *firstlelem may have been overwritten
1323 by sv_undef in the odd hash case */
1326 SP = firstrelem + (lastlelem - firstlelem);
1327 lelem = firstlelem + (relem - firstrelem);
1329 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1339 PMOP * const pm = cPMOP;
1340 REGEXP * rx = PM_GETRE(pm);
1341 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1342 SV * const rv = sv_newmortal();
1346 SvUPGRADE(rv, SVt_IV);
1347 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1348 loathe to use it here, but it seems to be the right fix. Or close.
1349 The key part appears to be that it's essential for pp_qr to return a new
1350 object (SV), which implies that there needs to be an effective way to
1351 generate a new SV from the existing SV that is pre-compiled in the
1353 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1356 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1357 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1358 *cvp = cv_clone(cv);
1359 SvREFCNT_dec_NN(cv);
1363 HV *const stash = gv_stashsv(pkg, GV_ADD);
1364 SvREFCNT_dec_NN(pkg);
1365 (void)sv_bless(rv, stash);
1368 if (UNLIKELY(RX_ISTAINTED(rx))) {
1370 SvTAINTED_on(SvRV(rv));
1383 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1386 const char *truebase; /* Start of string */
1387 REGEXP *rx = PM_GETRE(pm);
1389 const I32 gimme = GIMME_V;
1391 const I32 oldsave = PL_savestack_ix;
1392 I32 had_zerolen = 0;
1395 if (PL_op->op_flags & OPf_STACKED)
1404 PUTBACK; /* EVAL blocks need stack_sp. */
1405 /* Skip get-magic if this is a qr// clone, because regcomp has
1407 truebase = ReANY(rx)->mother_re
1408 ? SvPV_nomg_const(TARG, len)
1409 : SvPV_const(TARG, len);
1411 DIE(aTHX_ "panic: pp_match");
1412 strend = truebase + len;
1413 rxtainted = (RX_ISTAINTED(rx) ||
1414 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1417 /* We need to know this in case we fail out early - pos() must be reset */
1418 global = dynpm->op_pmflags & PMf_GLOBAL;
1420 /* PMdf_USED is set after a ?? matches once */
1423 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1425 pm->op_pmflags & PMf_USED
1428 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1432 /* empty pattern special-cased to use last successful pattern if
1433 possible, except for qr// */
1434 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1440 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1441 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1442 UVuf" < %"IVdf")\n",
1443 (UV)len, (IV)RX_MINLEN(rx)));
1447 /* get pos() if //g */
1449 mg = mg_find_mglob(TARG);
1450 if (mg && mg->mg_len >= 0) {
1451 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1452 /* last time pos() was set, it was zero-length match */
1453 if (mg->mg_flags & MGf_MINMATCH)
1458 #ifdef PERL_SAWAMPERSAND
1461 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1462 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1466 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1467 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1468 * only on the first iteration. Therefore we need to copy $' as well
1469 * as $&, to make the rest of the string available for captures in
1470 * subsequent iterations */
1471 if (! (global && gimme == G_ARRAY))
1472 r_flags |= REXEC_COPY_SKIP_POST;
1474 #ifdef PERL_SAWAMPERSAND
1475 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1476 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1477 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1484 s = truebase + curpos;
1486 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1487 had_zerolen, TARG, NULL, r_flags))
1491 if (dynpm->op_pmflags & PMf_ONCE)
1493 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1495 dynpm->op_pmflags |= PMf_USED;
1499 RX_MATCH_TAINTED_on(rx);
1500 TAINT_IF(RX_MATCH_TAINTED(rx));
1504 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1506 mg = sv_magicext_mglob(TARG);
1507 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1508 if (RX_ZERO_LEN(rx))
1509 mg->mg_flags |= MGf_MINMATCH;
1511 mg->mg_flags &= ~MGf_MINMATCH;
1514 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1515 LEAVE_SCOPE(oldsave);
1519 /* push captures on stack */
1522 const I32 nparens = RX_NPARENS(rx);
1523 I32 i = (global && !nparens) ? 1 : 0;
1525 SPAGAIN; /* EVAL blocks could move the stack. */
1526 EXTEND(SP, nparens + i);
1527 EXTEND_MORTAL(nparens + i);
1528 for (i = !i; i <= nparens; i++) {
1529 PUSHs(sv_newmortal());
1530 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1531 && RX_OFFS(rx)[i].end != -1 ))
1533 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1534 const char * const s = RX_OFFS(rx)[i].start + truebase;
1535 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1536 || len < 0 || len > strend - s))
1537 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1538 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1539 (long) i, (long) RX_OFFS(rx)[i].start,
1540 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1541 sv_setpvn(*SP, s, len);
1542 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1547 curpos = (UV)RX_OFFS(rx)[0].end;
1548 had_zerolen = RX_ZERO_LEN(rx);
1549 PUTBACK; /* EVAL blocks may use stack */
1550 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1553 LEAVE_SCOPE(oldsave);
1556 NOT_REACHED; /* NOTREACHED */
1559 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1561 mg = mg_find_mglob(TARG);
1565 LEAVE_SCOPE(oldsave);
1566 if (gimme == G_ARRAY)
1572 Perl_do_readline(pTHX)
1574 dSP; dTARGETSTACKED;
1579 IO * const io = GvIO(PL_last_in_gv);
1580 const I32 type = PL_op->op_type;
1581 const I32 gimme = GIMME_V;
1584 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1586 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1587 if (gimme == G_SCALAR) {
1589 SvSetSV_nosteal(TARG, TOPs);
1599 if (IoFLAGS(io) & IOf_ARGV) {
1600 if (IoFLAGS(io) & IOf_START) {
1602 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1603 IoFLAGS(io) &= ~IOf_START;
1604 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1605 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1606 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1607 SvSETMAGIC(GvSV(PL_last_in_gv));
1612 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1613 if (!fp) { /* Note: fp != IoIFP(io) */
1614 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1617 else if (type == OP_GLOB)
1618 fp = Perl_start_glob(aTHX_ POPs, io);
1620 else if (type == OP_GLOB)
1622 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1623 report_wrongway_fh(PL_last_in_gv, '>');
1627 if ((!io || !(IoFLAGS(io) & IOf_START))
1628 && ckWARN(WARN_CLOSED)
1631 report_evil_fh(PL_last_in_gv);
1633 if (gimme == G_SCALAR) {
1634 /* undef TARG, and push that undefined value */
1635 if (type != OP_RCATLINE) {
1636 sv_setsv(TARG,NULL);
1643 if (gimme == G_SCALAR) {
1645 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1648 if (type == OP_RCATLINE)
1649 SvPV_force_nomg_nolen(sv);
1653 else if (isGV_with_GP(sv)) {
1654 SvPV_force_nomg_nolen(sv);
1656 SvUPGRADE(sv, SVt_PV);
1657 tmplen = SvLEN(sv); /* remember if already alloced */
1658 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1659 /* try short-buffering it. Please update t/op/readline.t
1660 * if you change the growth length.
1665 if (type == OP_RCATLINE && SvOK(sv)) {
1667 SvPV_force_nomg_nolen(sv);
1673 sv = sv_2mortal(newSV(80));
1677 /* This should not be marked tainted if the fp is marked clean */
1678 #define MAYBE_TAINT_LINE(io, sv) \
1679 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1684 /* delay EOF state for a snarfed empty file */
1685 #define SNARF_EOF(gimme,rs,io,sv) \
1686 (gimme != G_SCALAR || SvCUR(sv) \
1687 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1691 if (!sv_gets(sv, fp, offset)
1693 || SNARF_EOF(gimme, PL_rs, io, sv)
1694 || PerlIO_error(fp)))
1696 PerlIO_clearerr(fp);
1697 if (IoFLAGS(io) & IOf_ARGV) {
1698 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1701 (void)do_close(PL_last_in_gv, FALSE);
1703 else if (type == OP_GLOB) {
1704 if (!do_close(PL_last_in_gv, FALSE)) {
1705 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1706 "glob failed (child exited with status %d%s)",
1707 (int)(STATUS_CURRENT >> 8),
1708 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1711 if (gimme == G_SCALAR) {
1712 if (type != OP_RCATLINE) {
1713 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1719 MAYBE_TAINT_LINE(io, sv);
1722 MAYBE_TAINT_LINE(io, sv);
1724 IoFLAGS(io) |= IOf_NOLINE;
1728 if (type == OP_GLOB) {
1731 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1732 char * const tmps = SvEND(sv) - 1;
1733 if (*tmps == *SvPVX_const(PL_rs)) {
1735 SvCUR_set(sv, SvCUR(sv) - 1);
1738 for (t1 = SvPVX_const(sv); *t1; t1++)
1740 if (strchr("*%?", *t1))
1742 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1745 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1746 (void)POPs; /* Unmatched wildcard? Chuck it... */
1749 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1750 if (ckWARN(WARN_UTF8)) {
1751 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1752 const STRLEN len = SvCUR(sv) - offset;
1755 if (!is_utf8_string_loc(s, len, &f))
1756 /* Emulate :encoding(utf8) warning in the same case. */
1757 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1758 "utf8 \"\\x%02X\" does not map to Unicode",
1759 f < (U8*)SvEND(sv) ? *f : 0);
1762 if (gimme == G_ARRAY) {
1763 if (SvLEN(sv) - SvCUR(sv) > 20) {
1764 SvPV_shrink_to_cur(sv);
1766 sv = sv_2mortal(newSV(80));
1769 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1770 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1771 const STRLEN new_len
1772 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1773 SvPV_renew(sv, new_len);
1784 SV * const keysv = POPs;
1785 HV * const hv = MUTABLE_HV(POPs);
1786 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1787 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1789 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1790 bool preeminent = TRUE;
1792 if (SvTYPE(hv) != SVt_PVHV)
1799 /* If we can determine whether the element exist,
1800 * Try to preserve the existenceness of a tied hash
1801 * element by using EXISTS and DELETE if possible.
1802 * Fallback to FETCH and STORE otherwise. */
1803 if (SvCANEXISTDELETE(hv))
1804 preeminent = hv_exists_ent(hv, keysv, 0);
1807 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1808 svp = he ? &HeVAL(he) : NULL;
1810 if (!svp || !*svp || *svp == &PL_sv_undef) {
1814 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1816 lv = sv_newmortal();
1817 sv_upgrade(lv, SVt_PVLV);
1819 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1820 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1821 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1827 if (HvNAME_get(hv) && isGV(*svp))
1828 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1829 else if (preeminent)
1830 save_helem_flags(hv, keysv, svp,
1831 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1833 SAVEHDELETE(hv, keysv);
1835 else if (PL_op->op_private & OPpDEREF) {
1836 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1840 sv = (svp && *svp ? *svp : &PL_sv_undef);
1841 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1842 * was to make C<local $tied{foo} = $tied{foo}> possible.
1843 * However, it seems no longer to be needed for that purpose, and
1844 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1845 * would loop endlessly since the pos magic is getting set on the
1846 * mortal copy and lost. However, the copy has the effect of
1847 * triggering the get magic, and losing it altogether made things like
1848 * c<$tied{foo};> in void context no longer do get magic, which some
1849 * code relied on. Also, delayed triggering of magic on @+ and friends
1850 * meant the original regex may be out of scope by now. So as a
1851 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1852 * being called too many times). */
1853 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1860 /* a stripped-down version of Perl_softref2xv() for use by
1861 * pp_multideref(), which doesn't use PL_op->op_flags */
1864 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
1867 if (PL_op->op_private & HINT_STRICT_REFS) {
1869 Perl_die(aTHX_ PL_no_symref_sv, sv,
1870 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
1872 Perl_die(aTHX_ PL_no_usym, what);
1875 Perl_die(aTHX_ PL_no_usym, what);
1876 return gv_fetchsv_nomg(sv, GV_ADD, type);
1880 /* Handle one or more aggregate derefs and array/hash indexings, e.g.
1881 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
1883 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
1884 * Each of these either contains a set of actions, or an argument, such as
1885 * an IV to use as an array index, or a lexical var to retrieve.
1886 * Several actions re stored per UV; we keep shifting new actions off the
1887 * one UV, and only reload when it becomes zero.
1892 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
1893 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
1894 UV actions = items->uv;
1897 /* this tells find_uninit_var() where we're up to */
1898 PL_multideref_pc = items;
1901 /* there are three main classes of action; the first retrieve
1902 * the initial AV or HV from a variable or the stack; the second
1903 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
1904 * the third an unrolled (/DREFHV, rv2hv, helem).
1906 switch (actions & MDEREF_ACTION_MASK) {
1909 actions = (++items)->uv;
1912 case MDEREF_AV_padav_aelem: /* $lex[...] */
1913 sv = PAD_SVl((++items)->pad_offset);
1916 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
1917 sv = UNOP_AUX_item_sv(++items);
1918 assert(isGV_with_GP(sv));
1919 sv = (SV*)GvAVn((GV*)sv);
1922 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
1927 goto do_AV_rv2av_aelem;
1930 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
1931 sv = UNOP_AUX_item_sv(++items);
1932 assert(isGV_with_GP(sv));
1933 sv = GvSVn((GV*)sv);
1934 goto do_AV_vivify_rv2av_aelem;
1936 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
1937 sv = PAD_SVl((++items)->pad_offset);
1940 do_AV_vivify_rv2av_aelem:
1941 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
1942 /* this is the OPpDEREF action normally found at the end of
1943 * ops like aelem, helem, rv2sv */
1944 sv = vivify_ref(sv, OPpDEREF_AV);
1948 /* this is basically a copy of pp_rv2av when it just has the
1951 if (LIKELY(SvROK(sv))) {
1952 if (UNLIKELY(SvAMAGIC(sv))) {
1953 sv = amagic_deref_call(sv, to_av_amg);
1956 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
1957 DIE(aTHX_ "Not an ARRAY reference");
1959 else if (SvTYPE(sv) != SVt_PVAV) {
1960 if (!isGV_with_GP(sv))
1961 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
1962 sv = MUTABLE_SV(GvAVn((GV*)sv));
1968 /* retrieve the key; this may be either a lexical or package
1969 * var (whose index/ptr is stored as an item) or a signed
1970 * integer constant stored as an item.
1973 IV elem = 0; /* to shut up stupid compiler warnings */
1976 assert(SvTYPE(sv) == SVt_PVAV);
1978 switch (actions & MDEREF_INDEX_MASK) {
1979 case MDEREF_INDEX_none:
1981 case MDEREF_INDEX_const:
1982 elem = (++items)->iv;
1984 case MDEREF_INDEX_padsv:
1985 elemsv = PAD_SVl((++items)->pad_offset);
1987 case MDEREF_INDEX_gvsv:
1988 elemsv = UNOP_AUX_item_sv(++items);
1989 assert(isGV_with_GP(elemsv));
1990 elemsv = GvSVn((GV*)elemsv);
1992 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
1993 && ckWARN(WARN_MISC)))
1994 Perl_warner(aTHX_ packWARN(WARN_MISC),
1995 "Use of reference \"%"SVf"\" as array index",
1997 /* the only time that S_find_uninit_var() needs this
1998 * is to determine which index value triggered the
1999 * undef warning. So just update it here. Note that
2000 * since we don't save and restore this var (e.g. for
2001 * tie or overload execution), its value will be
2002 * meaningless apart from just here */
2003 PL_multideref_pc = items;
2004 elem = SvIV(elemsv);
2009 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2011 if (!(actions & MDEREF_FLAG_last)) {
2012 SV** svp = av_fetch((AV*)sv, elem, 1);
2013 if (!svp || ! (sv=*svp))
2014 DIE(aTHX_ PL_no_aelem, elem);
2018 if (PL_op->op_private &
2019 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2021 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2022 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2025 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2026 sv = av_delete((AV*)sv, elem, discard);
2034 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2035 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2036 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2037 bool preeminent = TRUE;
2038 AV *const av = (AV*)sv;
2041 if (UNLIKELY(localizing)) {
2045 /* If we can determine whether the element exist,
2046 * Try to preserve the existenceness of a tied array
2047 * element by using EXISTS and DELETE if possible.
2048 * Fallback to FETCH and STORE otherwise. */
2049 if (SvCANEXISTDELETE(av))
2050 preeminent = av_exists(av, elem);
2053 svp = av_fetch(av, elem, lval && !defer);
2056 if (!svp || !(sv = *svp)) {
2059 DIE(aTHX_ PL_no_aelem, elem);
2060 len = av_tindex(av);
2061 sv = sv_2mortal(newSVavdefelem(av,
2062 /* Resolve a negative index now, unless it points
2063 * before the beginning of the array, in which
2064 * case record it for error reporting in
2065 * magic_setdefelem. */
2066 elem < 0 && len + elem >= 0
2067 ? len + elem : elem, 1));
2070 if (UNLIKELY(localizing)) {
2072 save_aelem(av, elem, svp);
2073 sv = *svp; /* may have changed */
2076 SAVEADELETE(av, elem);
2081 sv = (svp ? *svp : &PL_sv_undef);
2082 /* see note in pp_helem() */
2083 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2100 case MDEREF_HV_padhv_helem: /* $lex{...} */
2101 sv = PAD_SVl((++items)->pad_offset);
2104 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2105 sv = UNOP_AUX_item_sv(++items);
2106 assert(isGV_with_GP(sv));
2107 sv = (SV*)GvHVn((GV*)sv);
2110 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2115 goto do_HV_rv2hv_helem;
2118 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2119 sv = UNOP_AUX_item_sv(++items);
2120 assert(isGV_with_GP(sv));
2121 sv = GvSVn((GV*)sv);
2122 goto do_HV_vivify_rv2hv_helem;
2124 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2125 sv = PAD_SVl((++items)->pad_offset);
2128 do_HV_vivify_rv2hv_helem:
2129 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2130 /* this is the OPpDEREF action normally found at the end of
2131 * ops like aelem, helem, rv2sv */
2132 sv = vivify_ref(sv, OPpDEREF_HV);
2136 /* this is basically a copy of pp_rv2hv when it just has the
2137 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2140 if (LIKELY(SvROK(sv))) {
2141 if (UNLIKELY(SvAMAGIC(sv))) {
2142 sv = amagic_deref_call(sv, to_hv_amg);
2145 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2146 DIE(aTHX_ "Not a HASH reference");
2148 else if (SvTYPE(sv) != SVt_PVHV) {
2149 if (!isGV_with_GP(sv))
2150 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2151 sv = MUTABLE_SV(GvHVn((GV*)sv));
2157 /* retrieve the key; this may be either a lexical / package
2158 * var or a string constant, whose index/ptr is stored as an
2161 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2163 assert(SvTYPE(sv) == SVt_PVHV);
2165 switch (actions & MDEREF_INDEX_MASK) {
2166 case MDEREF_INDEX_none:
2169 case MDEREF_INDEX_const:
2170 keysv = UNOP_AUX_item_sv(++items);
2173 case MDEREF_INDEX_padsv:
2174 keysv = PAD_SVl((++items)->pad_offset);
2177 case MDEREF_INDEX_gvsv:
2178 keysv = UNOP_AUX_item_sv(++items);
2179 keysv = GvSVn((GV*)keysv);
2183 /* see comment above about setting this var */
2184 PL_multideref_pc = items;
2187 /* ensure that candidate CONSTs have been HEKified */
2188 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2189 || SvTYPE(keysv) >= SVt_PVMG
2192 || SvIsCOW_shared_hash(keysv));
2194 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2196 if (!(actions & MDEREF_FLAG_last)) {
2197 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2198 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2199 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2203 if (PL_op->op_private &
2204 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2206 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2207 sv = hv_exists_ent((HV*)sv, keysv, 0)
2208 ? &PL_sv_yes : &PL_sv_no;
2211 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2212 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2220 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2221 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2222 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2223 bool preeminent = TRUE;
2225 HV * const hv = (HV*)sv;
2228 if (UNLIKELY(localizing)) {
2232 /* If we can determine whether the element exist,
2233 * Try to preserve the existenceness of a tied hash
2234 * element by using EXISTS and DELETE if possible.
2235 * Fallback to FETCH and STORE otherwise. */
2236 if (SvCANEXISTDELETE(hv))
2237 preeminent = hv_exists_ent(hv, keysv, 0);
2240 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2241 svp = he ? &HeVAL(he) : NULL;
2245 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2249 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2250 lv = sv_newmortal();
2251 sv_upgrade(lv, SVt_PVLV);
2253 sv_magic(lv, key2 = newSVsv(keysv),
2254 PERL_MAGIC_defelem, NULL, 0);
2255 /* sv_magic() increments refcount */
2256 SvREFCNT_dec_NN(key2);
2257 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2263 if (HvNAME_get(hv) && isGV(sv))
2264 save_gp(MUTABLE_GV(sv),
2265 !(PL_op->op_flags & OPf_SPECIAL));
2266 else if (preeminent) {
2267 save_helem_flags(hv, keysv, svp,
2268 (PL_op->op_flags & OPf_SPECIAL)
2269 ? 0 : SAVEf_SETMAGIC);
2270 sv = *svp; /* may have changed */
2273 SAVEHDELETE(hv, keysv);
2278 sv = (svp && *svp ? *svp : &PL_sv_undef);
2279 /* see note in pp_helem() */
2280 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2289 actions >>= MDEREF_SHIFT;
2303 cx = &cxstack[cxstack_ix];
2304 itersvp = CxITERVAR(cx);
2306 switch (CxTYPE(cx)) {
2308 case CXt_LOOP_LAZYSV: /* string increment */
2310 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2311 SV *end = cx->blk_loop.state_u.lazysv.end;
2312 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2313 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2315 const char *max = SvPV_const(end, maxlen);
2316 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2320 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2321 /* safe to reuse old SV */
2322 sv_setsv(oldsv, cur);
2326 /* we need a fresh SV every time so that loop body sees a
2327 * completely new SV for closures/references to work as
2329 *itersvp = newSVsv(cur);
2330 SvREFCNT_dec_NN(oldsv);
2332 if (strEQ(SvPVX_const(cur), max))
2333 sv_setiv(cur, 0); /* terminate next time */
2339 case CXt_LOOP_LAZYIV: /* integer increment */
2341 IV cur = cx->blk_loop.state_u.lazyiv.cur;
2342 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2346 /* don't risk potential race */
2347 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2348 /* safe to reuse old SV */
2349 sv_setiv(oldsv, cur);
2353 /* we need a fresh SV every time so that loop body sees a
2354 * completely new SV for closures/references to work as they
2356 *itersvp = newSViv(cur);
2357 SvREFCNT_dec_NN(oldsv);
2360 if (UNLIKELY(cur == IV_MAX)) {
2361 /* Handle end of range at IV_MAX */
2362 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2364 ++cx->blk_loop.state_u.lazyiv.cur;
2368 case CXt_LOOP_FOR: /* iterate array */
2371 AV *av = cx->blk_loop.state_u.ary.ary;
2373 bool av_is_stack = FALSE;
2380 if (PL_op->op_private & OPpITER_REVERSED) {
2381 ix = --cx->blk_loop.state_u.ary.ix;
2382 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2386 ix = ++cx->blk_loop.state_u.ary.ix;
2387 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2391 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2392 SV * const * const svp = av_fetch(av, ix, FALSE);
2393 sv = svp ? *svp : NULL;
2396 sv = AvARRAY(av)[ix];
2399 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2400 SvSetMagicSV(*itersvp, sv);
2405 if (UNLIKELY(SvIS_FREED(sv))) {
2407 Perl_croak(aTHX_ "Use of freed value in iteration");
2414 SvREFCNT_inc_simple_void_NN(sv);
2417 else if (!av_is_stack) {
2418 sv = newSVavdefelem(av, ix, 0);
2425 SvREFCNT_dec(oldsv);
2430 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2436 A description of how taint works in pattern matching and substitution.
2438 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2439 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2441 While the pattern is being assembled/concatenated and then compiled,
2442 PL_tainted will get set (via TAINT_set) if any component of the pattern
2443 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2444 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2445 TAINT_get). It will also be set if any component of the pattern matches
2446 based on locale-dependent behavior.
2448 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2449 the pattern is marked as tainted. This means that subsequent usage, such
2450 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2451 on the new pattern too.
2453 RXf_TAINTED_SEEN is used post-execution by the get magic code
2454 of $1 et al to indicate whether the returned value should be tainted.
2455 It is the responsibility of the caller of the pattern (i.e. pp_match,
2456 pp_subst etc) to set this flag for any other circumstances where $1 needs
2459 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2461 There are three possible sources of taint
2463 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2464 * the replacement string (or expression under /e)
2466 There are four destinations of taint and they are affected by the sources
2467 according to the rules below:
2469 * the return value (not including /r):
2470 tainted by the source string and pattern, but only for the
2471 number-of-iterations case; boolean returns aren't tainted;
2472 * the modified string (or modified copy under /r):
2473 tainted by the source string, pattern, and replacement strings;
2475 tainted by the pattern, and under 'use re "taint"', by the source
2477 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2478 should always be unset before executing subsequent code.
2480 The overall action of pp_subst is:
2482 * at the start, set bits in rxtainted indicating the taint status of
2483 the various sources.
2485 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2486 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2487 pattern has subsequently become tainted via locale ops.
2489 * If control is being passed to pp_substcont to execute a /e block,
2490 save rxtainted in the CXt_SUBST block, for future use by
2493 * Whenever control is being returned to perl code (either by falling
2494 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2495 use the flag bits in rxtainted to make all the appropriate types of
2496 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2497 et al will appear tainted.
2499 pp_match is just a simpler version of the above.
2515 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2516 See "how taint works" above */
2519 REGEXP *rx = PM_GETRE(pm);
2521 int force_on_match = 0;
2522 const I32 oldsave = PL_savestack_ix;
2524 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2529 /* known replacement string? */
2530 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2534 if (PL_op->op_flags & OPf_STACKED)
2543 SvGETMAGIC(TARG); /* must come before cow check */
2545 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2546 because they make integers such as 256 "false". */
2547 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2550 sv_force_normal_flags(TARG,0);
2552 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2553 && (SvREADONLY(TARG)
2554 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2555 || SvTYPE(TARG) > SVt_PVLV)
2556 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2557 Perl_croak_no_modify();
2560 orig = SvPV_nomg(TARG, len);
2561 /* note we don't (yet) force the var into being a string; if we fail
2562 * to match, we leave as-is; on successful match howeverm, we *will*
2563 * coerce into a string, then repeat the match */
2564 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2567 /* only replace once? */
2568 once = !(rpm->op_pmflags & PMf_GLOBAL);
2570 /* See "how taint works" above */
2573 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2574 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2575 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2576 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2577 ? SUBST_TAINT_BOOLRET : 0));
2583 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2585 strend = orig + len;
2586 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2587 maxiters = 2 * slen + 10; /* We can match twice at each
2588 position, once with zero-length,
2589 second time with non-zero. */
2591 if (!RX_PRELEN(rx) && PL_curpm
2592 && !ReANY(rx)->mother_re) {
2597 #ifdef PERL_SAWAMPERSAND
2598 r_flags = ( RX_NPARENS(rx)
2600 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2601 || (rpm->op_pmflags & PMf_KEEPCOPY)
2606 r_flags = REXEC_COPY_STR;
2609 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2612 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2613 LEAVE_SCOPE(oldsave);
2618 /* known replacement string? */
2620 /* replacement needing upgrading? */
2621 if (DO_UTF8(TARG) && !doutf8) {
2622 nsv = sv_newmortal();
2625 sv_recode_to_utf8(nsv, _get_encoding());
2627 sv_utf8_upgrade(nsv);
2628 c = SvPV_const(nsv, clen);
2632 c = SvPV_const(dstr, clen);
2633 doutf8 = DO_UTF8(dstr);
2636 if (SvTAINTED(dstr))
2637 rxtainted |= SUBST_TAINT_REPL;
2644 /* can do inplace substitution? */
2649 && (I32)clen <= RX_MINLENRET(rx)
2651 || !(r_flags & REXEC_COPY_STR)
2652 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2654 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2655 && (!doutf8 || SvUTF8(TARG))
2656 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2660 if (SvIsCOW(TARG)) {
2661 if (!force_on_match)
2663 assert(SvVOK(TARG));
2666 if (force_on_match) {
2667 /* redo the first match, this time with the orig var
2668 * forced into being a string */
2670 orig = SvPV_force_nomg(TARG, len);
2676 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2677 rxtainted |= SUBST_TAINT_PAT;
2678 m = orig + RX_OFFS(rx)[0].start;
2679 d = orig + RX_OFFS(rx)[0].end;
2681 if (m - s > strend - d) { /* faster to shorten from end */
2684 Copy(c, m, clen, char);
2689 Move(d, m, i, char);
2693 SvCUR_set(TARG, m - s);
2695 else { /* faster from front */
2699 Move(s, d - i, i, char);
2702 Copy(c, d, clen, char);
2709 d = s = RX_OFFS(rx)[0].start + orig;
2712 if (UNLIKELY(iters++ > maxiters))
2713 DIE(aTHX_ "Substitution loop");
2714 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2715 rxtainted |= SUBST_TAINT_PAT;
2716 m = RX_OFFS(rx)[0].start + orig;
2719 Move(s, d, i, char);
2723 Copy(c, d, clen, char);
2726 s = RX_OFFS(rx)[0].end + orig;
2727 } while (CALLREGEXEC(rx, s, strend, orig,
2728 s == m, /* don't match same null twice */
2730 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2733 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2734 Move(s, d, i+1, char); /* include the NUL */
2744 if (force_on_match) {
2745 /* redo the first match, this time with the orig var
2746 * forced into being a string */
2748 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2749 /* I feel that it should be possible to avoid this mortal copy
2750 given that the code below copies into a new destination.
2751 However, I suspect it isn't worth the complexity of
2752 unravelling the C<goto force_it> for the small number of
2753 cases where it would be viable to drop into the copy code. */
2754 TARG = sv_2mortal(newSVsv(TARG));
2756 orig = SvPV_force_nomg(TARG, len);
2762 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2763 rxtainted |= SUBST_TAINT_PAT;
2765 s = RX_OFFS(rx)[0].start + orig;
2766 dstr = newSVpvn_flags(orig, s-orig,
2767 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2772 /* note that a whole bunch of local vars are saved here for
2773 * use by pp_substcont: here's a list of them in case you're
2774 * searching for places in this sub that uses a particular var:
2775 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2776 * s m strend rx once */
2778 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2782 if (UNLIKELY(iters++ > maxiters))
2783 DIE(aTHX_ "Substitution loop");
2784 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2785 rxtainted |= SUBST_TAINT_PAT;
2786 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2788 char *old_orig = orig;
2789 assert(RX_SUBOFFSET(rx) == 0);
2791 orig = RX_SUBBEG(rx);
2792 s = orig + (old_s - old_orig);
2793 strend = s + (strend - old_s);
2795 m = RX_OFFS(rx)[0].start + orig;
2796 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2797 s = RX_OFFS(rx)[0].end + orig;
2799 /* replacement already stringified */
2801 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2806 if (!nsv) nsv = sv_newmortal();
2807 sv_copypv(nsv, repl);
2808 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
2809 sv_catsv(dstr, nsv);
2811 else sv_catsv(dstr, repl);
2812 if (UNLIKELY(SvTAINTED(repl)))
2813 rxtainted |= SUBST_TAINT_REPL;
2817 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2819 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2820 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2822 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2823 /* From here on down we're using the copy, and leaving the original
2830 /* The match may make the string COW. If so, brilliant, because
2831 that's just saved us one malloc, copy and free - the regexp has
2832 donated the old buffer, and we malloc an entirely new one, rather
2833 than the regexp malloc()ing a buffer and copying our original,
2834 only for us to throw it away here during the substitution. */
2835 if (SvIsCOW(TARG)) {
2836 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2842 SvPV_set(TARG, SvPVX(dstr));
2843 SvCUR_set(TARG, SvCUR(dstr));
2844 SvLEN_set(TARG, SvLEN(dstr));
2845 SvFLAGS(TARG) |= SvUTF8(dstr);
2846 SvPV_set(dstr, NULL);
2853 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2854 (void)SvPOK_only_UTF8(TARG);
2857 /* See "how taint works" above */
2859 if ((rxtainted & SUBST_TAINT_PAT) ||
2860 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2861 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2863 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2865 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2866 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2868 SvTAINTED_on(TOPs); /* taint return value */
2870 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2872 /* needed for mg_set below */
2874 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2878 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2880 LEAVE_SCOPE(oldsave);
2889 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2890 ++*PL_markstack_ptr;
2892 LEAVE_with_name("grep_item"); /* exit inner scope */
2895 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2897 const I32 gimme = GIMME_V;
2899 LEAVE_with_name("grep"); /* exit outer scope */
2900 (void)POPMARK; /* pop src */
2901 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2902 (void)POPMARK; /* pop dst */
2903 SP = PL_stack_base + POPMARK; /* pop original mark */
2904 if (gimme == G_SCALAR) {
2905 if (PL_op->op_private & OPpGREP_LEX) {
2906 SV* const sv = sv_newmortal();
2907 sv_setiv(sv, items);
2915 else if (gimme == G_ARRAY)
2922 ENTER_with_name("grep_item"); /* enter inner scope */
2925 src = PL_stack_base[*PL_markstack_ptr];
2926 if (SvPADTMP(src)) {
2927 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2931 if (PL_op->op_private & OPpGREP_LEX)
2932 PAD_SVl(PL_op->op_targ) = src;
2936 RETURNOP(cLOGOP->op_other);
2950 if (CxMULTICALL(&cxstack[cxstack_ix])) {
2951 /* entry zero of a stack is always PL_sv_undef, which
2952 * simplifies converting a '()' return into undef in scalar context */
2953 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2958 cxstack_ix++; /* temporarily protect top context */
2961 if (gimme == G_SCALAR) {
2963 if (LIKELY(MARK <= SP)) {
2964 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2965 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2966 && !SvMAGICAL(TOPs)) {
2967 *MARK = SvREFCNT_inc(TOPs);
2972 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2974 *MARK = sv_mortalcopy(sv);
2975 SvREFCNT_dec_NN(sv);
2978 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2979 && !SvMAGICAL(TOPs)) {
2983 *MARK = sv_mortalcopy(TOPs);
2987 *MARK = &PL_sv_undef;
2991 else if (gimme == G_ARRAY) {
2992 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2993 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2994 || SvMAGICAL(*MARK)) {
2995 *MARK = sv_mortalcopy(*MARK);
2996 TAINT_NOT; /* Each item is independent */
3003 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3005 PL_curpm = newpm; /* ... and pop $1 et al */
3008 return cx->blk_sub.retop;
3018 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3021 DIE(aTHX_ "Not a CODE reference");
3022 /* This is overwhelmingly the most common case: */
3023 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3024 switch (SvTYPE(sv)) {
3027 if (!(cv = GvCVu((const GV *)sv))) {
3029 cv = sv_2cv(sv, &stash, &gv, 0);
3038 if(isGV_with_GP(sv)) goto we_have_a_glob;
3041 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3043 SP = PL_stack_base + POPMARK;
3051 sv = amagic_deref_call(sv, to_cv_amg);
3052 /* Don't SPAGAIN here. */
3059 DIE(aTHX_ PL_no_usym, "a subroutine");
3060 sym = SvPV_nomg_const(sv, len);
3061 if (PL_op->op_private & HINT_STRICT_REFS)
3062 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3063 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3066 cv = MUTABLE_CV(SvRV(sv));
3067 if (SvTYPE(cv) == SVt_PVCV)
3072 DIE(aTHX_ "Not a CODE reference");
3073 /* This is the second most common case: */
3075 cv = MUTABLE_CV(sv);
3083 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3084 DIE(aTHX_ "Closure prototype called");
3085 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3089 /* anonymous or undef'd function leaves us no recourse */
3090 if (CvLEXICAL(cv) && CvHASGV(cv))
3091 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3092 SVfARG(cv_name(cv, NULL, 0)));
3093 if (CvANON(cv) || !CvHASGV(cv)) {
3094 DIE(aTHX_ "Undefined subroutine called");
3097 /* autoloaded stub? */
3098 if (cv != GvCV(gv = CvGV(cv))) {
3101 /* should call AUTOLOAD now? */
3104 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3105 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3111 sub_name = sv_newmortal();
3112 gv_efullname3(sub_name, gv, NULL);
3113 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3121 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3124 Perl_get_db_sub(aTHX_ &sv, cv);
3126 PL_curcopdb = PL_curcop;
3128 /* check for lsub that handles lvalue subroutines */
3129 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3130 /* if lsub not found then fall back to DB::sub */
3131 if (!cv) cv = GvCV(PL_DBsub);
3133 cv = GvCV(PL_DBsub);
3136 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3137 DIE(aTHX_ "No DB::sub routine defined");
3142 if (!(CvISXSUB(cv))) {
3143 /* This path taken at least 75% of the time */
3145 PADLIST * const padlist = CvPADLIST(cv);
3148 PUSHBLOCK(cx, CXt_SUB, MARK);
3150 cx->blk_sub.retop = PL_op->op_next;
3151 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3152 PERL_STACK_OVERFLOW_CHECK();
3153 pad_push(padlist, depth);
3156 PAD_SET_CUR_NOSAVE(padlist, depth);
3157 if (LIKELY(hasargs)) {
3158 AV *const av = MUTABLE_AV(PAD_SVl(0));
3162 if (UNLIKELY(AvREAL(av))) {
3163 /* @_ is normally not REAL--this should only ever
3164 * happen when DB::sub() calls things that modify @_ */
3169 defavp = &GvAV(PL_defgv);
3170 cx->blk_sub.savearray = *defavp;
3171 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3172 CX_CURPAD_SAVE(cx->blk_sub);
3173 cx->blk_sub.argarray = av;
3176 if (UNLIKELY(items - 1 > AvMAX(av))) {
3177 SV **ary = AvALLOC(av);
3178 AvMAX(av) = items - 1;
3179 Renew(ary, items, SV*);
3184 Copy(MARK+1,AvARRAY(av),items,SV*);
3185 AvFILLp(av) = items - 1;
3191 if (SvPADTMP(*MARK)) {
3192 *MARK = sv_mortalcopy(*MARK);
3200 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3202 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3203 /* warning must come *after* we fully set up the context
3204 * stuff so that __WARN__ handlers can safely dounwind()
3207 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3208 && ckWARN(WARN_RECURSION)
3209 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3210 sub_crush_depth(cv);
3211 RETURNOP(CvSTART(cv));
3214 SSize_t markix = TOPMARK;
3219 if (UNLIKELY(((PL_op->op_private
3220 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3221 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3223 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3225 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3226 /* Need to copy @_ to stack. Alternative may be to
3227 * switch stack to @_, and copy return values
3228 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3229 AV * const av = GvAV(PL_defgv);
3230 const SSize_t items = AvFILL(av) + 1;
3234 const bool m = cBOOL(SvRMAGICAL(av));
3235 /* Mark is at the end of the stack. */
3237 for (; i < items; ++i)
3241 SV ** const svp = av_fetch(av, i, 0);
3242 sv = svp ? *svp : NULL;
3244 else sv = AvARRAY(av)[i];
3245 if (sv) SP[i+1] = sv;
3247 SP[i+1] = newSVavdefelem(av, i, 1);
3255 SV **mark = PL_stack_base + markix;
3256 SSize_t items = SP - mark;
3259 if (*mark && SvPADTMP(*mark)) {
3260 *mark = sv_mortalcopy(*mark);
3264 /* We assume first XSUB in &DB::sub is the called one. */
3265 if (UNLIKELY(PL_curcopdb)) {
3266 SAVEVPTR(PL_curcop);
3267 PL_curcop = PL_curcopdb;
3270 /* Do we need to open block here? XXXX */
3272 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3274 CvXSUB(cv)(aTHX_ cv);
3276 /* Enforce some sanity in scalar context. */
3277 if (gimme == G_SCALAR) {
3278 SV **svp = PL_stack_base + markix + 1;
3279 if (svp != PL_stack_sp) {
3280 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3290 Perl_sub_crush_depth(pTHX_ CV *cv)
3292 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3295 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3297 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3298 SVfARG(cv_name(cv,NULL,0)));
3306 SV* const elemsv = POPs;
3307 IV elem = SvIV(elemsv);
3308 AV *const av = MUTABLE_AV(POPs);
3309 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3310 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3311 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3312 bool preeminent = TRUE;
3315 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3316 Perl_warner(aTHX_ packWARN(WARN_MISC),
3317 "Use of reference \"%"SVf"\" as array index",
3319 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3322 if (UNLIKELY(localizing)) {
3326 /* If we can determine whether the element exist,
3327 * Try to preserve the existenceness of a tied array
3328 * element by using EXISTS and DELETE if possible.
3329 * Fallback to FETCH and STORE otherwise. */
3330 if (SvCANEXISTDELETE(av))
3331 preeminent = av_exists(av, elem);
3334 svp = av_fetch(av, elem, lval && !defer);
3336 #ifdef PERL_MALLOC_WRAP
3337 if (SvUOK(elemsv)) {
3338 const UV uv = SvUV(elemsv);
3339 elem = uv > IV_MAX ? IV_MAX : uv;
3341 else if (SvNOK(elemsv))
3342 elem = (IV)SvNV(elemsv);
3344 static const char oom_array_extend[] =
3345 "Out of memory during array extend"; /* Duplicated in av.c */
3346 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3349 if (!svp || !*svp) {
3352 DIE(aTHX_ PL_no_aelem, elem);
3353 len = av_tindex(av);
3354 mPUSHs(newSVavdefelem(av,
3355 /* Resolve a negative index now, unless it points before the
3356 beginning of the array, in which case record it for error
3357 reporting in magic_setdefelem. */
3358 elem < 0 && len + elem >= 0 ? len + elem : elem,
3362 if (UNLIKELY(localizing)) {
3364 save_aelem(av, elem, svp);
3366 SAVEADELETE(av, elem);
3368 else if (PL_op->op_private & OPpDEREF) {
3369 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3373 sv = (svp ? *svp : &PL_sv_undef);
3374 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3381 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3383 PERL_ARGS_ASSERT_VIVIFY_REF;
3388 Perl_croak_no_modify();
3389 prepare_SV_for_RV(sv);
3392 SvRV_set(sv, newSV(0));
3395 SvRV_set(sv, MUTABLE_SV(newAV()));
3398 SvRV_set(sv, MUTABLE_SV(newHV()));
3405 if (SvGMAGICAL(sv)) {
3406 /* copy the sv without magic to prevent magic from being
3408 SV* msv = sv_newmortal();
3409 sv_setsv_nomg(msv, sv);
3415 PERL_STATIC_INLINE HV *
3416 S_opmethod_stash(pTHX_ SV* meth)
3421 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3422 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3423 "package or object reference", SVfARG(meth)),
3425 : *(PL_stack_base + TOPMARK + 1);
3427 PERL_ARGS_ASSERT_OPMETHOD_STASH;
3431 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3434 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3435 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3436 stash = gv_stashsv(sv, GV_CACHE_ONLY);
3437 if (stash) return stash;
3441 ob = MUTABLE_SV(SvRV(sv));
3442 else if (!SvOK(sv)) goto undefined;
3443 else if (isGV_with_GP(sv)) {
3445 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3446 "without a package or object reference",
3449 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3450 assert(!LvTARGLEN(ob));
3454 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3457 /* this isn't a reference */
3460 const char * const packname = SvPV_nomg_const(sv, packlen);
3461 const U32 packname_utf8 = SvUTF8(sv);
3462 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3463 if (stash) return stash;
3465 if (!(iogv = gv_fetchpvn_flags(
3466 packname, packlen, packname_utf8, SVt_PVIO
3468 !(ob=MUTABLE_SV(GvIO(iogv))))
3470 /* this isn't the name of a filehandle either */
3473 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3474 "without a package or object reference",
3477 /* assume it's a package name */
3478 stash = gv_stashpvn(packname, packlen, packname_utf8);
3479 if (stash) return stash;
3480 else return MUTABLE_HV(sv);
3482 /* it _is_ a filehandle name -- replace with a reference */
3483 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3486 /* if we got here, ob should be an object or a glob */
3487 if (!ob || !(SvOBJECT(ob)
3488 || (isGV_with_GP(ob)
3489 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3492 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3493 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3494 ? newSVpvs_flags("DOES", SVs_TEMP)
3506 SV* const meth = TOPs;
3509 SV* const rmeth = SvRV(meth);
3510 if (SvTYPE(rmeth) == SVt_PVCV) {
3516 stash = opmethod_stash(meth);
3518 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3521 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3525 #define METHOD_CHECK_CACHE(stash,cache,meth) \
3526 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
3528 gv = MUTABLE_GV(HeVAL(he)); \
3529 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
3530 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
3532 XPUSHs(MUTABLE_SV(GvCV(gv))); \
3541 SV* const meth = cMETHOPx_meth(PL_op);
3542 HV* const stash = opmethod_stash(meth);
3544 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3545 METHOD_CHECK_CACHE(stash, stash, meth);
3548 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3551 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3560 SV* const meth = cMETHOPx_meth(PL_op);
3561 HV* const stash = CopSTASH(PL_curcop);
3562 /* Actually, SUPER doesn't need real object's (or class') stash at all,
3563 * as it uses CopSTASH. However, we must ensure that object(class) is
3564 * correct (this check is done by S_opmethod_stash) */
3565 opmethod_stash(meth);
3567 if ((cache = HvMROMETA(stash)->super)) {
3568 METHOD_CHECK_CACHE(stash, cache, meth);
3571 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3574 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3582 SV* const meth = cMETHOPx_meth(PL_op);
3583 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3584 opmethod_stash(meth); /* not used but needed for error checks */
3586 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3587 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3589 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3592 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3596 PP(pp_method_redir_super)
3601 SV* const meth = cMETHOPx_meth(PL_op);
3602 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3603 opmethod_stash(meth); /* not used but needed for error checks */
3605 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3606 else if ((cache = HvMROMETA(stash)->super)) {
3607 METHOD_CHECK_CACHE(stash, cache, meth);
3610 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3613 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3618 * ex: set ts=8 sts=4 sw=4 et: