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);
302 rpv = SvPV_nomg_const(right, rlen);
303 rbyte = !DO_UTF8(right);
305 if (lbyte != rbyte) {
307 sv_utf8_upgrade_nomg(TARG);
310 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
311 sv_utf8_upgrade_nomg(right);
312 rpv = SvPV_nomg_const(right, rlen);
315 sv_catpvn_nomg(TARG, rpv, rlen);
322 /* push the elements of av onto the stack.
323 * XXX Note that padav has similar code but without the mg_get().
324 * I suspect that the mg_get is no longer needed, but while padav
325 * differs, it can't share this function */
328 S_pushav(pTHX_ AV* const av)
331 const SSize_t maxarg = AvFILL(av) + 1;
333 if (UNLIKELY(SvRMAGICAL(av))) {
335 for (i=0; i < (PADOFFSET)maxarg; i++) {
336 SV ** const svp = av_fetch(av, i, FALSE);
337 /* See note in pp_helem, and bug id #27839 */
339 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
345 for (i=0; i < (PADOFFSET)maxarg; i++) {
346 SV * const sv = AvARRAY(av)[i];
347 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
355 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
360 PADOFFSET base = PL_op->op_targ;
361 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
363 if (PL_op->op_flags & OPf_SPECIAL) {
364 /* fake the RHS of my ($x,$y,..) = @_ */
366 S_pushav(aTHX_ GvAVn(PL_defgv));
370 /* note, this is only skipped for compile-time-known void cxt */
371 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
374 for (i = 0; i <count; i++)
375 *++SP = PAD_SV(base+i);
377 if (PL_op->op_private & OPpLVAL_INTRO) {
378 SV **svp = &(PAD_SVl(base));
379 const UV payload = (UV)(
380 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
381 | (count << SAVE_TIGHT_SHIFT)
382 | SAVEt_CLEARPADRANGE);
383 STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
384 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
391 for (i = 0; i <count; i++)
392 SvPADSTALE_off(*svp++); /* mark lexical as active */
403 OP * const op = PL_op;
404 /* access PL_curpad once */
405 SV ** const padentry = &(PAD_SVl(op->op_targ));
410 PUTBACK; /* no pop/push after this, TOPs ok */
412 if (op->op_flags & OPf_MOD) {
413 if (op->op_private & OPpLVAL_INTRO)
414 if (!(op->op_private & OPpPAD_STATE))
415 save_clearsv(padentry);
416 if (op->op_private & OPpDEREF) {
417 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
418 than TARG reduces the scope of TARG, so it does not
419 span the call to save_clearsv, resulting in smaller
421 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
433 tryAMAGICunTARGETlist(iter_amg, 0);
434 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
436 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
437 if (!isGV_with_GP(PL_last_in_gv)) {
438 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
439 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
442 XPUSHs(MUTABLE_SV(PL_last_in_gv));
445 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
446 if (PL_last_in_gv == (GV *)&PL_sv_undef)
447 PL_last_in_gv = NULL;
449 assert(isGV_with_GP(PL_last_in_gv));
452 return do_readline();
460 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
464 (SvIOK_notUV(left) && SvIOK_notUV(right))
465 ? (SvIVX(left) == SvIVX(right))
466 : ( do_ncmp(left, right) == 0)
472 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
478 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
479 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
480 Perl_croak_no_modify();
481 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
482 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
484 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
485 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
487 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
488 if (inc) sv_inc(TOPs);
495 /* also used for: pp_orassign() */
504 if (PL_op->op_type == OP_OR)
506 RETURNOP(cLOGOP->op_other);
511 /* also used for: pp_dor() pp_dorassign() */
518 const int op_type = PL_op->op_type;
519 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
524 if (UNLIKELY(!sv || !SvANY(sv))) {
525 if (op_type == OP_DOR)
527 RETURNOP(cLOGOP->op_other);
533 if (UNLIKELY(!sv || !SvANY(sv)))
538 switch (SvTYPE(sv)) {
540 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
544 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
548 if (CvROOT(sv) || CvXSUB(sv))
561 if(op_type == OP_DOR)
563 RETURNOP(cLOGOP->op_other);
565 /* assuming OP_DEFINED */
573 dSP; dATARGET; bool useleft; SV *svl, *svr;
574 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
578 useleft = USE_LEFT(svl);
579 #ifdef PERL_PRESERVE_IVUV
580 /* We must see if we can perform the addition with integers if possible,
581 as the integer code detects overflow while the NV code doesn't.
582 If either argument hasn't had a numeric conversion yet attempt to get
583 the IV. It's important to do this now, rather than just assuming that
584 it's not IOK as a PV of "9223372036854775806" may not take well to NV
585 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
586 integer in case the second argument is IV=9223372036854775806
587 We can (now) rely on sv_2iv to do the right thing, only setting the
588 public IOK flag if the value in the NV (or PV) slot is truly integer.
590 A side effect is that this also aggressively prefers integer maths over
591 fp maths for integer values.
593 How to detect overflow?
595 C 99 section 6.2.6.1 says
597 The range of nonnegative values of a signed integer type is a subrange
598 of the corresponding unsigned integer type, and the representation of
599 the same value in each type is the same. A computation involving
600 unsigned operands can never overflow, because a result that cannot be
601 represented by the resulting unsigned integer type is reduced modulo
602 the number that is one greater than the largest value that can be
603 represented by the resulting type.
607 which I read as "unsigned ints wrap."
609 signed integer overflow seems to be classed as "exception condition"
611 If an exceptional condition occurs during the evaluation of an
612 expression (that is, if the result is not mathematically defined or not
613 in the range of representable values for its type), the behavior is
616 (6.5, the 5th paragraph)
618 I had assumed that on 2s complement machines signed arithmetic would
619 wrap, hence coded pp_add and pp_subtract on the assumption that
620 everything perl builds on would be happy. After much wailing and
621 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
622 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
623 unsigned code below is actually shorter than the old code. :-)
626 if (SvIV_please_nomg(svr)) {
627 /* Unless the left argument is integer in range we are going to have to
628 use NV maths. Hence only attempt to coerce the right argument if
629 we know the left is integer. */
637 /* left operand is undef, treat as zero. + 0 is identity,
638 Could SETi or SETu right now, but space optimise by not adding
639 lots of code to speed up what is probably a rarish case. */
641 /* Left operand is defined, so is it IV? */
642 if (SvIV_please_nomg(svl)) {
643 if ((auvok = SvUOK(svl)))
646 const IV aiv = SvIVX(svl);
649 auvok = 1; /* Now acting as a sign flag. */
650 } else { /* 2s complement assumption for IV_MIN */
658 bool result_good = 0;
661 bool buvok = SvUOK(svr);
666 const IV biv = SvIVX(svr);
673 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
674 else "IV" now, independent of how it came in.
675 if a, b represents positive, A, B negative, a maps to -A etc
680 all UV maths. negate result if A negative.
681 add if signs same, subtract if signs differ. */
687 /* Must get smaller */
693 /* result really should be -(auv-buv). as its negation
694 of true value, need to swap our result flag */
711 if (result <= (UV)IV_MIN)
714 /* result valid, but out of range for IV. */
719 } /* Overflow, drop through to NVs. */
724 NV value = SvNV_nomg(svr);
727 /* left operand is undef, treat as zero. + 0.0 is identity. */
731 SETn( value + SvNV_nomg(svl) );
737 /* also used for: pp_aelemfast_lex() */
742 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
743 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
744 const U32 lval = PL_op->op_flags & OPf_MOD;
745 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
746 SV *sv = (svp ? *svp : &PL_sv_undef);
748 if (UNLIKELY(!svp && lval))
749 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
752 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
762 do_join(TARG, *MARK, MARK, SP);
773 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
774 * will be enough to hold an OP*.
776 SV* const sv = sv_newmortal();
777 sv_upgrade(sv, SVt_PVLV);
779 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
782 XPUSHs(MUTABLE_SV(PL_op));
787 /* Oversized hot code. */
789 /* also used for: pp_say() */
793 dSP; dMARK; dORIGMARK;
797 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
801 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
804 if (MARK == ORIGMARK) {
805 /* If using default handle then we need to make space to
806 * pass object as 1st arg, so move other args up ...
810 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
813 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
815 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
816 | (PL_op->op_type == OP_SAY
817 ? TIED_METHOD_SAY : 0)), sp - mark);
820 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
821 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
824 SETERRNO(EBADF,RMS_IFI);
827 else if (!(fp = IoOFP(io))) {
829 report_wrongway_fh(gv, '<');
832 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
836 SV * const ofs = GvSV(PL_ofsgv); /* $, */
838 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
840 if (!do_print(*MARK, fp))
844 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
845 if (!do_print(GvSV(PL_ofsgv), fp)) {
854 if (!do_print(*MARK, fp))
862 if (PL_op->op_type == OP_SAY) {
863 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
866 else if (PL_ors_sv && SvOK(PL_ors_sv))
867 if (!do_print(PL_ors_sv, fp)) /* $\ */
870 if (IoFLAGS(io) & IOf_FLUSH)
871 if (PerlIO_flush(fp) == EOF)
881 XPUSHs(&PL_sv_undef);
886 /* also used for: pp_rv2hv() */
887 /* also called directly by pp_lvavref */
892 const I32 gimme = GIMME_V;
893 static const char an_array[] = "an ARRAY";
894 static const char a_hash[] = "a HASH";
895 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
896 || PL_op->op_type == OP_LVAVREF;
897 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
901 if (UNLIKELY(SvAMAGIC(sv))) {
902 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
905 if (UNLIKELY(SvTYPE(sv) != type))
906 /* diag_listed_as: Not an ARRAY reference */
907 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
908 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
909 && PL_op->op_private & OPpLVAL_INTRO))
910 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
912 else if (UNLIKELY(SvTYPE(sv) != type)) {
915 if (!isGV_with_GP(sv)) {
916 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
924 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
925 if (PL_op->op_private & OPpLVAL_INTRO)
926 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
928 if (PL_op->op_flags & OPf_REF) {
932 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
933 const I32 flags = is_lvalue_sub();
934 if (flags && !(flags & OPpENTERSUB_INARGS)) {
935 if (gimme != G_ARRAY)
936 goto croak_cant_return;
943 AV *const av = MUTABLE_AV(sv);
944 /* The guts of pp_rv2av */
945 if (gimme == G_ARRAY) {
951 else if (gimme == G_SCALAR) {
953 const SSize_t maxarg = AvFILL(av) + 1;
957 /* The guts of pp_rv2hv */
958 if (gimme == G_ARRAY) { /* array wanted */
960 return Perl_do_kv(aTHX);
962 else if ((PL_op->op_private & OPpTRUEBOOL
963 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
964 && block_gimme() == G_VOID ))
965 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
966 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
967 else if (gimme == G_SCALAR) {
969 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
976 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
977 is_pp_rv2av ? "array" : "hash");
982 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
984 PERL_ARGS_ASSERT_DO_ODDBALL;
987 if (ckWARN(WARN_MISC)) {
989 if (oddkey == firstkey &&
991 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
992 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
994 err = "Reference found where even-sized list expected";
997 err = "Odd number of elements in hash assignment";
998 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
1007 SV **lastlelem = PL_stack_sp;
1008 SV **lastrelem = PL_stack_base + POPMARK;
1009 SV **firstrelem = PL_stack_base + POPMARK + 1;
1010 SV **firstlelem = lastrelem + 1;
1024 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1026 if (gimme == G_ARRAY)
1027 lval = PL_op->op_flags & OPf_MOD || LVRET;
1029 /* If there's a common identifier on both sides we have to take
1030 * special care that assigning the identifier on the left doesn't
1031 * clobber a value on the right that's used later in the list.
1032 * Don't bother if LHS is just an empty hash or array.
1035 if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
1037 firstlelem != lastlelem
1038 || ! ((sv = *firstlelem))
1040 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1041 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1042 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1045 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1046 for (relem = firstrelem; relem <= lastrelem; relem++) {
1047 if (LIKELY((sv = *relem))) {
1048 TAINT_NOT; /* Each item is independent */
1050 /* Dear TODO test in t/op/sort.t, I love you.
1051 (It's relying on a panic, not a "semi-panic" from newSVsv()
1052 and then an assertion failure below.) */
1053 if (UNLIKELY(SvIS_FREED(sv))) {
1054 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1057 /* Not newSVsv(), as it does not allow copy-on-write,
1058 resulting in wasteful copies. We need a second copy of
1059 a temp here, hence the SV_NOSTEAL. */
1060 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1071 while (LIKELY(lelem <= lastlelem)) {
1073 TAINT_NOT; /* Each item stands on its own, taintwise. */
1075 if (UNLIKELY(!sv)) {
1078 ASSUME(SvTYPE(sv) == SVt_PVAV);
1080 switch (SvTYPE(sv)) {
1082 ary = MUTABLE_AV(sv);
1083 magic = SvMAGICAL(ary) != 0;
1085 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1087 av_extend(ary, lastrelem - relem);
1089 while (relem <= lastrelem) { /* gobble up all the rest */
1092 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1093 if (LIKELY(!alias)) {
1095 sv_setsv_nomg(sv, *relem);
1100 DIE(aTHX_ "Assigned value is not a reference");
1101 if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
1102 /* diag_listed_as: Assigned value is not %s reference */
1104 "Assigned value is not a SCALAR reference");
1106 *relem = sv_mortalcopy(*relem);
1107 /* XXX else check for weak refs? */
1108 sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
1111 didstore = av_store(ary,i++,sv);
1120 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1121 SvSETMAGIC(MUTABLE_SV(ary));
1124 case SVt_PVHV: { /* normal hash */
1128 SV** topelem = relem;
1129 SV **firsthashrelem = relem;
1131 hash = MUTABLE_HV(sv);
1132 magic = SvMAGICAL(hash) != 0;
1134 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1135 if (UNLIKELY(odd)) {
1136 do_oddball(lastrelem, firsthashrelem);
1137 /* we have firstlelem to reuse, it's not needed anymore
1139 *(lastrelem+1) = &PL_sv_undef;
1143 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1145 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1148 /* Copy the key if aassign is called in lvalue context,
1149 to avoid having the next op modify our rhs. Copy
1150 it also if it is gmagical, lest it make the
1151 hv_store_ent call below croak, leaking the value. */
1152 sv = lval || SvGMAGICAL(*relem)
1153 ? sv_mortalcopy(*relem)
1159 sv_setsv_nomg(tmpstr,*relem++); /* value */
1160 if (gimme == G_ARRAY) {
1161 if (hv_exists_ent(hash, sv, 0))
1162 /* key overwrites an existing entry */
1165 /* copy element back: possibly to an earlier
1166 * stack location if we encountered dups earlier,
1167 * possibly to a later stack location if odd */
1169 *topelem++ = tmpstr;
1172 didstore = hv_store_ent(hash,sv,tmpstr,0);
1174 if (!didstore) sv_2mortal(tmpstr);
1180 if (duplicates && gimme == G_ARRAY) {
1181 /* at this point we have removed the duplicate key/value
1182 * pairs from the stack, but the remaining values may be
1183 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1184 * the (a 2), but the stack now probably contains
1185 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1186 * obliterates the earlier key. So refresh all values. */
1187 lastrelem -= duplicates;
1188 relem = firsthashrelem;
1189 while (relem < lastrelem+odd) {
1191 he = hv_fetch_ent(hash, *relem++, 0, 0);
1192 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1195 if (odd && gimme == G_ARRAY) lastrelem++;
1199 if (SvIMMORTAL(sv)) {
1200 if (relem <= lastrelem)
1204 if (relem <= lastrelem) {
1206 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1207 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1210 packWARN(WARN_MISC),
1211 "Useless assignment to a temporary"
1213 sv_setsv(sv, *relem);
1217 sv_setsv(sv, &PL_sv_undef);
1222 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1223 /* Will be used to set PL_tainting below */
1224 Uid_t tmp_uid = PerlProc_getuid();
1225 Uid_t tmp_euid = PerlProc_geteuid();
1226 Gid_t tmp_gid = PerlProc_getgid();
1227 Gid_t tmp_egid = PerlProc_getegid();
1229 /* XXX $> et al currently silently ignore failures */
1230 if (PL_delaymagic & DM_UID) {
1231 #ifdef HAS_SETRESUID
1233 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1234 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1237 # ifdef HAS_SETREUID
1239 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1240 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1243 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1244 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1245 PL_delaymagic &= ~DM_RUID;
1247 # endif /* HAS_SETRUID */
1249 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1250 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1251 PL_delaymagic &= ~DM_EUID;
1253 # endif /* HAS_SETEUID */
1254 if (PL_delaymagic & DM_UID) {
1255 if (PL_delaymagic_uid != PL_delaymagic_euid)
1256 DIE(aTHX_ "No setreuid available");
1257 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1259 # endif /* HAS_SETREUID */
1260 #endif /* HAS_SETRESUID */
1262 tmp_uid = PerlProc_getuid();
1263 tmp_euid = PerlProc_geteuid();
1265 /* XXX $> et al currently silently ignore failures */
1266 if (PL_delaymagic & DM_GID) {
1267 #ifdef HAS_SETRESGID
1269 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1270 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1273 # ifdef HAS_SETREGID
1275 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1276 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1279 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1280 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1281 PL_delaymagic &= ~DM_RGID;
1283 # endif /* HAS_SETRGID */
1285 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1286 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1287 PL_delaymagic &= ~DM_EGID;
1289 # endif /* HAS_SETEGID */
1290 if (PL_delaymagic & DM_GID) {
1291 if (PL_delaymagic_gid != PL_delaymagic_egid)
1292 DIE(aTHX_ "No setregid available");
1293 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1295 # endif /* HAS_SETREGID */
1296 #endif /* HAS_SETRESGID */
1298 tmp_gid = PerlProc_getgid();
1299 tmp_egid = PerlProc_getegid();
1301 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1302 #ifdef NO_TAINT_SUPPORT
1303 PERL_UNUSED_VAR(tmp_uid);
1304 PERL_UNUSED_VAR(tmp_euid);
1305 PERL_UNUSED_VAR(tmp_gid);
1306 PERL_UNUSED_VAR(tmp_egid);
1311 if (gimme == G_VOID)
1312 SP = firstrelem - 1;
1313 else if (gimme == G_SCALAR) {
1316 SETi(lastrelem - firstrelem + 1);
1320 /* note that in this case *firstlelem may have been overwritten
1321 by sv_undef in the odd hash case */
1324 SP = firstrelem + (lastlelem - firstlelem);
1325 lelem = firstlelem + (relem - firstrelem);
1327 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1337 PMOP * const pm = cPMOP;
1338 REGEXP * rx = PM_GETRE(pm);
1339 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1340 SV * const rv = sv_newmortal();
1344 SvUPGRADE(rv, SVt_IV);
1345 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1346 loathe to use it here, but it seems to be the right fix. Or close.
1347 The key part appears to be that it's essential for pp_qr to return a new
1348 object (SV), which implies that there needs to be an effective way to
1349 generate a new SV from the existing SV that is pre-compiled in the
1351 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1354 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1355 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1356 *cvp = cv_clone(cv);
1357 SvREFCNT_dec_NN(cv);
1361 HV *const stash = gv_stashsv(pkg, GV_ADD);
1362 SvREFCNT_dec_NN(pkg);
1363 (void)sv_bless(rv, stash);
1366 if (UNLIKELY(RX_ISTAINTED(rx))) {
1368 SvTAINTED_on(SvRV(rv));
1381 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1384 const char *truebase; /* Start of string */
1385 REGEXP *rx = PM_GETRE(pm);
1387 const I32 gimme = GIMME_V;
1389 const I32 oldsave = PL_savestack_ix;
1390 I32 had_zerolen = 0;
1393 if (PL_op->op_flags & OPf_STACKED)
1402 PUTBACK; /* EVAL blocks need stack_sp. */
1403 /* Skip get-magic if this is a qr// clone, because regcomp has
1405 truebase = ReANY(rx)->mother_re
1406 ? SvPV_nomg_const(TARG, len)
1407 : SvPV_const(TARG, len);
1409 DIE(aTHX_ "panic: pp_match");
1410 strend = truebase + len;
1411 rxtainted = (RX_ISTAINTED(rx) ||
1412 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1415 /* We need to know this in case we fail out early - pos() must be reset */
1416 global = dynpm->op_pmflags & PMf_GLOBAL;
1418 /* PMdf_USED is set after a ?? matches once */
1421 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1423 pm->op_pmflags & PMf_USED
1426 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1430 /* empty pattern special-cased to use last successful pattern if
1431 possible, except for qr// */
1432 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1438 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1439 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1440 UVuf" < %"IVdf")\n",
1441 (UV)len, (IV)RX_MINLEN(rx)));
1445 /* get pos() if //g */
1447 mg = mg_find_mglob(TARG);
1448 if (mg && mg->mg_len >= 0) {
1449 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1450 /* last time pos() was set, it was zero-length match */
1451 if (mg->mg_flags & MGf_MINMATCH)
1456 #ifdef PERL_SAWAMPERSAND
1459 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1460 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1464 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1465 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1466 * only on the first iteration. Therefore we need to copy $' as well
1467 * as $&, to make the rest of the string available for captures in
1468 * subsequent iterations */
1469 if (! (global && gimme == G_ARRAY))
1470 r_flags |= REXEC_COPY_SKIP_POST;
1472 #ifdef PERL_SAWAMPERSAND
1473 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1474 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1475 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1482 s = truebase + curpos;
1484 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1485 had_zerolen, TARG, NULL, r_flags))
1489 if (dynpm->op_pmflags & PMf_ONCE)
1491 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1493 dynpm->op_pmflags |= PMf_USED;
1497 RX_MATCH_TAINTED_on(rx);
1498 TAINT_IF(RX_MATCH_TAINTED(rx));
1502 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1504 mg = sv_magicext_mglob(TARG);
1505 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1506 if (RX_ZERO_LEN(rx))
1507 mg->mg_flags |= MGf_MINMATCH;
1509 mg->mg_flags &= ~MGf_MINMATCH;
1512 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1513 LEAVE_SCOPE(oldsave);
1517 /* push captures on stack */
1520 const I32 nparens = RX_NPARENS(rx);
1521 I32 i = (global && !nparens) ? 1 : 0;
1523 SPAGAIN; /* EVAL blocks could move the stack. */
1524 EXTEND(SP, nparens + i);
1525 EXTEND_MORTAL(nparens + i);
1526 for (i = !i; i <= nparens; i++) {
1527 PUSHs(sv_newmortal());
1528 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1529 && RX_OFFS(rx)[i].end != -1 ))
1531 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1532 const char * const s = RX_OFFS(rx)[i].start + truebase;
1533 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1534 || len < 0 || len > strend - s))
1535 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1536 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1537 (long) i, (long) RX_OFFS(rx)[i].start,
1538 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1539 sv_setpvn(*SP, s, len);
1540 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1545 curpos = (UV)RX_OFFS(rx)[0].end;
1546 had_zerolen = RX_ZERO_LEN(rx);
1547 PUTBACK; /* EVAL blocks may use stack */
1548 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1551 LEAVE_SCOPE(oldsave);
1554 NOT_REACHED; /* NOTREACHED */
1557 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1559 mg = mg_find_mglob(TARG);
1563 LEAVE_SCOPE(oldsave);
1564 if (gimme == G_ARRAY)
1570 Perl_do_readline(pTHX)
1572 dSP; dTARGETSTACKED;
1577 IO * const io = GvIO(PL_last_in_gv);
1578 const I32 type = PL_op->op_type;
1579 const I32 gimme = GIMME_V;
1582 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1584 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1585 if (gimme == G_SCALAR) {
1587 SvSetSV_nosteal(TARG, TOPs);
1597 if (IoFLAGS(io) & IOf_ARGV) {
1598 if (IoFLAGS(io) & IOf_START) {
1600 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1601 IoFLAGS(io) &= ~IOf_START;
1602 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1603 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1604 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1605 SvSETMAGIC(GvSV(PL_last_in_gv));
1610 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1611 if (!fp) { /* Note: fp != IoIFP(io) */
1612 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1615 else if (type == OP_GLOB)
1616 fp = Perl_start_glob(aTHX_ POPs, io);
1618 else if (type == OP_GLOB)
1620 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1621 report_wrongway_fh(PL_last_in_gv, '>');
1625 if ((!io || !(IoFLAGS(io) & IOf_START))
1626 && ckWARN(WARN_CLOSED)
1629 report_evil_fh(PL_last_in_gv);
1631 if (gimme == G_SCALAR) {
1632 /* undef TARG, and push that undefined value */
1633 if (type != OP_RCATLINE) {
1634 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1642 if (gimme == G_SCALAR) {
1644 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1647 if (type == OP_RCATLINE)
1648 SvPV_force_nomg_nolen(sv);
1652 else if (isGV_with_GP(sv)) {
1653 SvPV_force_nomg_nolen(sv);
1655 SvUPGRADE(sv, SVt_PV);
1656 tmplen = SvLEN(sv); /* remember if already alloced */
1657 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1658 /* try short-buffering it. Please update t/op/readline.t
1659 * if you change the growth length.
1664 if (type == OP_RCATLINE && SvOK(sv)) {
1666 SvPV_force_nomg_nolen(sv);
1672 sv = sv_2mortal(newSV(80));
1676 /* This should not be marked tainted if the fp is marked clean */
1677 #define MAYBE_TAINT_LINE(io, sv) \
1678 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1683 /* delay EOF state for a snarfed empty file */
1684 #define SNARF_EOF(gimme,rs,io,sv) \
1685 (gimme != G_SCALAR || SvCUR(sv) \
1686 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1690 if (!sv_gets(sv, fp, offset)
1692 || SNARF_EOF(gimme, PL_rs, io, sv)
1693 || PerlIO_error(fp)))
1695 PerlIO_clearerr(fp);
1696 if (IoFLAGS(io) & IOf_ARGV) {
1697 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1700 (void)do_close(PL_last_in_gv, FALSE);
1702 else if (type == OP_GLOB) {
1703 if (!do_close(PL_last_in_gv, FALSE)) {
1704 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1705 "glob failed (child exited with status %d%s)",
1706 (int)(STATUS_CURRENT >> 8),
1707 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1710 if (gimme == G_SCALAR) {
1711 if (type != OP_RCATLINE) {
1712 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1718 MAYBE_TAINT_LINE(io, sv);
1721 MAYBE_TAINT_LINE(io, sv);
1723 IoFLAGS(io) |= IOf_NOLINE;
1727 if (type == OP_GLOB) {
1730 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1731 char * const tmps = SvEND(sv) - 1;
1732 if (*tmps == *SvPVX_const(PL_rs)) {
1734 SvCUR_set(sv, SvCUR(sv) - 1);
1737 for (t1 = SvPVX_const(sv); *t1; t1++)
1739 if (strchr("*%?", *t1))
1741 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1744 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1745 (void)POPs; /* Unmatched wildcard? Chuck it... */
1748 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1749 if (ckWARN(WARN_UTF8)) {
1750 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1751 const STRLEN len = SvCUR(sv) - offset;
1754 if (!is_utf8_string_loc(s, len, &f))
1755 /* Emulate :encoding(utf8) warning in the same case. */
1756 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1757 "utf8 \"\\x%02X\" does not map to Unicode",
1758 f < (U8*)SvEND(sv) ? *f : 0);
1761 if (gimme == G_ARRAY) {
1762 if (SvLEN(sv) - SvCUR(sv) > 20) {
1763 SvPV_shrink_to_cur(sv);
1765 sv = sv_2mortal(newSV(80));
1768 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1769 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1770 const STRLEN new_len
1771 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1772 SvPV_renew(sv, new_len);
1783 SV * const keysv = POPs;
1784 HV * const hv = MUTABLE_HV(POPs);
1785 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1786 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1788 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1789 bool preeminent = TRUE;
1791 if (SvTYPE(hv) != SVt_PVHV)
1798 /* If we can determine whether the element exist,
1799 * Try to preserve the existenceness of a tied hash
1800 * element by using EXISTS and DELETE if possible.
1801 * Fallback to FETCH and STORE otherwise. */
1802 if (SvCANEXISTDELETE(hv))
1803 preeminent = hv_exists_ent(hv, keysv, 0);
1806 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1807 svp = he ? &HeVAL(he) : NULL;
1809 if (!svp || !*svp || *svp == &PL_sv_undef) {
1813 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1815 lv = sv_newmortal();
1816 sv_upgrade(lv, SVt_PVLV);
1818 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1819 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1820 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1826 if (HvNAME_get(hv) && isGV(*svp))
1827 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1828 else if (preeminent)
1829 save_helem_flags(hv, keysv, svp,
1830 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1832 SAVEHDELETE(hv, keysv);
1834 else if (PL_op->op_private & OPpDEREF) {
1835 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1839 sv = (svp && *svp ? *svp : &PL_sv_undef);
1840 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1841 * was to make C<local $tied{foo} = $tied{foo}> possible.
1842 * However, it seems no longer to be needed for that purpose, and
1843 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1844 * would loop endlessly since the pos magic is getting set on the
1845 * mortal copy and lost. However, the copy has the effect of
1846 * triggering the get magic, and losing it altogether made things like
1847 * c<$tied{foo};> in void context no longer do get magic, which some
1848 * code relied on. Also, delayed triggering of magic on @+ and friends
1849 * meant the original regex may be out of scope by now. So as a
1850 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1851 * being called too many times). */
1852 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1859 /* a stripped-down version of Perl_softref2xv() for use by
1860 * pp_multideref(), which doesn't use PL_op->op_flags */
1863 S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
1866 if (PL_op->op_private & HINT_STRICT_REFS) {
1868 Perl_die(aTHX_ PL_no_symref_sv, sv,
1869 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
1871 Perl_die(aTHX_ PL_no_usym, what);
1874 Perl_die(aTHX_ PL_no_usym, what);
1875 return gv_fetchsv_nomg(sv, GV_ADD, type);
1879 /* handle one or more derefs and array/hash indexings, e.g.
1880 * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
1882 * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
1883 * Each of these either contains an action, or an argument, such as
1884 * a UV to use as an array index, or a lexical var to retrieve.
1885 * In fact, several actions re stored per UV; we keep shifting new actions
1886 * of the one UV, and only reload when it becomes zero.
1891 SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
1892 UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
1893 UV actions = items->uv;
1896 /* this tells find_uninit_var() where we're up to */
1897 PL_multideref_pc = items;
1900 /* there are three main classes of action; the first retrieve
1901 * the initial AV or HV from a variable or the stack; the second
1902 * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
1903 * the third an unrolled (/DREFHV, rv2hv, helem).
1905 switch (actions & MDEREF_ACTION_MASK) {
1908 actions = (++items)->uv;
1911 case MDEREF_AV_padav_aelem: /* $lex[...] */
1912 sv = PAD_SVl((++items)->pad_offset);
1915 case MDEREF_AV_gvav_aelem: /* $pkg[...] */
1916 sv = UNOP_AUX_item_sv(++items);
1917 assert(isGV_with_GP(sv));
1918 sv = (SV*)GvAVn((GV*)sv);
1921 case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
1926 goto do_AV_rv2av_aelem;
1929 case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
1930 sv = UNOP_AUX_item_sv(++items);
1931 assert(isGV_with_GP(sv));
1932 sv = GvSVn((GV*)sv);
1933 goto do_AV_vivify_rv2av_aelem;
1935 case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
1936 sv = PAD_SVl((++items)->pad_offset);
1939 do_AV_vivify_rv2av_aelem:
1940 case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
1941 /* this is the OPpDEREF action normally found at the end of
1942 * ops like aelem, helem, rv2sv */
1943 sv = vivify_ref(sv, OPpDEREF_AV);
1947 /* this is basically a copy of pp_rv2av when it just has the
1950 if (LIKELY(SvROK(sv))) {
1951 if (UNLIKELY(SvAMAGIC(sv))) {
1952 sv = amagic_deref_call(sv, to_av_amg);
1955 if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
1956 DIE(aTHX_ "Not an ARRAY reference");
1958 else if (SvTYPE(sv) != SVt_PVAV) {
1959 if (!isGV_with_GP(sv))
1960 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
1961 sv = MUTABLE_SV(GvAVn((GV*)sv));
1967 /* retrieve the key; this may be either a lexical or package
1968 * var (whose index/ptr is stored as an item) or a signed
1969 * integer constant stored as an item.
1972 IV elem = 0; /* to shut up stupid compiler warnings */
1975 assert(SvTYPE(sv) == SVt_PVAV);
1977 switch (actions & MDEREF_INDEX_MASK) {
1978 case MDEREF_INDEX_none:
1980 case MDEREF_INDEX_const:
1981 elem = (++items)->iv;
1983 case MDEREF_INDEX_padsv:
1984 elemsv = PAD_SVl((++items)->pad_offset);
1986 case MDEREF_INDEX_gvsv:
1987 elemsv = UNOP_AUX_item_sv(++items);
1988 assert(isGV_with_GP(elemsv));
1989 elemsv = GvSVn((GV*)elemsv);
1991 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
1992 && ckWARN(WARN_MISC)))
1993 Perl_warner(aTHX_ packWARN(WARN_MISC),
1994 "Use of reference \"%"SVf"\" as array index",
1996 /* the only time that S_find_uninit_var() needs this
1997 * is to determine which index value triggered the
1998 * undef warning. So just update it here. Note that
1999 * since we don't save and restore this var (e.g. for
2000 * tie or overload execution), its value will be
2001 * meaningless apart from just here */
2002 PL_multideref_pc = items;
2003 elem = SvIV(elemsv);
2008 /* this is basically a copy of pp_aelem with OPpDEREF skipped */
2010 if (!(actions & MDEREF_FLAG_last)) {
2011 SV** svp = av_fetch((AV*)sv, elem, 1);
2012 if (!svp || ! (sv=*svp))
2013 DIE(aTHX_ PL_no_aelem, elem);
2017 if (PL_op->op_private &
2018 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2020 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2021 sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
2024 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2025 sv = av_delete((AV*)sv, elem, discard);
2033 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2034 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2035 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2036 bool preeminent = TRUE;
2037 AV *const av = (AV*)sv;
2040 if (UNLIKELY(localizing)) {
2044 /* If we can determine whether the element exist,
2045 * Try to preserve the existenceness of a tied array
2046 * element by using EXISTS and DELETE if possible.
2047 * Fallback to FETCH and STORE otherwise. */
2048 if (SvCANEXISTDELETE(av))
2049 preeminent = av_exists(av, elem);
2052 svp = av_fetch(av, elem, lval && !defer);
2055 if (!svp || !(sv = *svp)) {
2058 DIE(aTHX_ PL_no_aelem, elem);
2059 len = av_tindex(av);
2060 sv = sv_2mortal(newSVavdefelem(av,
2061 /* Resolve a negative index now, unless it points
2062 * before the beginning of the array, in which
2063 * case record it for error reporting in
2064 * magic_setdefelem. */
2065 elem < 0 && len + elem >= 0
2066 ? len + elem : elem, 1));
2069 if (UNLIKELY(localizing)) {
2071 save_aelem(av, elem, svp);
2072 sv = *svp; /* may have changed */
2075 SAVEADELETE(av, elem);
2080 sv = (svp ? *svp : &PL_sv_undef);
2081 /* see note in pp_helem() */
2082 if (SvRMAGICAL(av) && SvGMAGICAL(sv))
2099 case MDEREF_HV_padhv_helem: /* $lex{...} */
2100 sv = PAD_SVl((++items)->pad_offset);
2103 case MDEREF_HV_gvhv_helem: /* $pkg{...} */
2104 sv = UNOP_AUX_item_sv(++items);
2105 assert(isGV_with_GP(sv));
2106 sv = (SV*)GvHVn((GV*)sv);
2109 case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
2114 goto do_HV_rv2hv_helem;
2117 case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
2118 sv = UNOP_AUX_item_sv(++items);
2119 assert(isGV_with_GP(sv));
2120 sv = GvSVn((GV*)sv);
2121 goto do_HV_vivify_rv2hv_helem;
2123 case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
2124 sv = PAD_SVl((++items)->pad_offset);
2127 do_HV_vivify_rv2hv_helem:
2128 case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
2129 /* this is the OPpDEREF action normally found at the end of
2130 * ops like aelem, helem, rv2sv */
2131 sv = vivify_ref(sv, OPpDEREF_HV);
2135 /* this is basically a copy of pp_rv2hv when it just has the
2136 * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
2139 if (LIKELY(SvROK(sv))) {
2140 if (UNLIKELY(SvAMAGIC(sv))) {
2141 sv = amagic_deref_call(sv, to_hv_amg);
2144 if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
2145 DIE(aTHX_ "Not a HASH reference");
2147 else if (SvTYPE(sv) != SVt_PVHV) {
2148 if (!isGV_with_GP(sv))
2149 sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
2150 sv = MUTABLE_SV(GvHVn((GV*)sv));
2156 /* retrieve the key; this may be either a lexical / package
2157 * var or a string constant, whose index/ptr is stored as an
2160 SV *keysv = NULL; /* to shut up stupid compiler warnings */
2162 assert(SvTYPE(sv) == SVt_PVHV);
2164 switch (actions & MDEREF_INDEX_MASK) {
2165 case MDEREF_INDEX_none:
2168 case MDEREF_INDEX_const:
2169 keysv = UNOP_AUX_item_sv(++items);
2172 case MDEREF_INDEX_padsv:
2173 keysv = PAD_SVl((++items)->pad_offset);
2176 case MDEREF_INDEX_gvsv:
2177 keysv = UNOP_AUX_item_sv(++items);
2178 keysv = GvSVn((GV*)keysv);
2182 /* see comment above about setting this var */
2183 PL_multideref_pc = items;
2186 /* ensure that candidate CONSTs have been HEKified */
2187 assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
2188 || SvTYPE(keysv) >= SVt_PVMG
2191 || SvIsCOW_shared_hash(keysv));
2193 /* this is basically a copy of pp_helem with OPpDEREF skipped */
2195 if (!(actions & MDEREF_FLAG_last)) {
2196 HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
2197 if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
2198 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2202 if (PL_op->op_private &
2203 (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
2205 if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
2206 sv = hv_exists_ent((HV*)sv, keysv, 0)
2207 ? &PL_sv_yes : &PL_sv_no;
2210 I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
2211 sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
2219 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2220 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2221 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2222 bool preeminent = TRUE;
2224 HV * const hv = (HV*)sv;
2227 if (UNLIKELY(localizing)) {
2231 /* If we can determine whether the element exist,
2232 * Try to preserve the existenceness of a tied hash
2233 * element by using EXISTS and DELETE if possible.
2234 * Fallback to FETCH and STORE otherwise. */
2235 if (SvCANEXISTDELETE(hv))
2236 preeminent = hv_exists_ent(hv, keysv, 0);
2239 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
2240 svp = he ? &HeVAL(he) : NULL;
2244 if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
2248 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
2249 lv = sv_newmortal();
2250 sv_upgrade(lv, SVt_PVLV);
2252 sv_magic(lv, key2 = newSVsv(keysv),
2253 PERL_MAGIC_defelem, NULL, 0);
2254 /* sv_magic() increments refcount */
2255 SvREFCNT_dec_NN(key2);
2256 LvTARG(lv) = SvREFCNT_inc_simple(hv);
2262 if (HvNAME_get(hv) && isGV(sv))
2263 save_gp(MUTABLE_GV(sv),
2264 !(PL_op->op_flags & OPf_SPECIAL));
2265 else if (preeminent) {
2266 save_helem_flags(hv, keysv, svp,
2267 (PL_op->op_flags & OPf_SPECIAL)
2268 ? 0 : SAVEf_SETMAGIC);
2269 sv = *svp; /* may have changed */
2272 SAVEHDELETE(hv, keysv);
2277 sv = (svp && *svp ? *svp : &PL_sv_undef);
2278 /* see note in pp_helem() */
2279 if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
2288 actions >>= MDEREF_SHIFT;
2302 cx = &cxstack[cxstack_ix];
2303 itersvp = CxITERVAR(cx);
2305 switch (CxTYPE(cx)) {
2307 case CXt_LOOP_LAZYSV: /* string increment */
2309 SV* cur = cx->blk_loop.state_u.lazysv.cur;
2310 SV *end = cx->blk_loop.state_u.lazysv.end;
2311 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
2312 It has SvPVX of "" and SvCUR of 0, which is what we want. */
2314 const char *max = SvPV_const(end, maxlen);
2315 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
2319 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2320 /* safe to reuse old SV */
2321 sv_setsv(oldsv, cur);
2325 /* we need a fresh SV every time so that loop body sees a
2326 * completely new SV for closures/references to work as
2328 *itersvp = newSVsv(cur);
2329 SvREFCNT_dec_NN(oldsv);
2331 if (strEQ(SvPVX_const(cur), max))
2332 sv_setiv(cur, 0); /* terminate next time */
2338 case CXt_LOOP_LAZYIV: /* integer increment */
2340 IV cur = cx->blk_loop.state_u.lazyiv.cur;
2341 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
2345 /* don't risk potential race */
2346 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
2347 /* safe to reuse old SV */
2348 sv_setiv(oldsv, cur);
2352 /* we need a fresh SV every time so that loop body sees a
2353 * completely new SV for closures/references to work as they
2355 *itersvp = newSViv(cur);
2356 SvREFCNT_dec_NN(oldsv);
2359 if (UNLIKELY(cur == IV_MAX)) {
2360 /* Handle end of range at IV_MAX */
2361 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2363 ++cx->blk_loop.state_u.lazyiv.cur;
2367 case CXt_LOOP_FOR: /* iterate array */
2370 AV *av = cx->blk_loop.state_u.ary.ary;
2372 bool av_is_stack = FALSE;
2379 if (PL_op->op_private & OPpITER_REVERSED) {
2380 ix = --cx->blk_loop.state_u.ary.ix;
2381 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
2385 ix = ++cx->blk_loop.state_u.ary.ix;
2386 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
2390 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
2391 SV * const * const svp = av_fetch(av, ix, FALSE);
2392 sv = svp ? *svp : NULL;
2395 sv = AvARRAY(av)[ix];
2398 if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
2399 SvSetMagicSV(*itersvp, sv);
2404 if (UNLIKELY(SvIS_FREED(sv))) {
2406 Perl_croak(aTHX_ "Use of freed value in iteration");
2413 SvREFCNT_inc_simple_void_NN(sv);
2416 else if (!av_is_stack) {
2417 sv = newSVavdefelem(av, ix, 0);
2424 SvREFCNT_dec(oldsv);
2429 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2435 A description of how taint works in pattern matching and substitution.
2437 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2438 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2440 While the pattern is being assembled/concatenated and then compiled,
2441 PL_tainted will get set (via TAINT_set) if any component of the pattern
2442 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2443 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2444 TAINT_get). It will also be set if any component of the pattern matches
2445 based on locale-dependent behavior.
2447 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2448 the pattern is marked as tainted. This means that subsequent usage, such
2449 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2450 on the new pattern too.
2452 RXf_TAINTED_SEEN is used post-execution by the get magic code
2453 of $1 et al to indicate whether the returned value should be tainted.
2454 It is the responsibility of the caller of the pattern (i.e. pp_match,
2455 pp_subst etc) to set this flag for any other circumstances where $1 needs
2458 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2460 There are three possible sources of taint
2462 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2463 * the replacement string (or expression under /e)
2465 There are four destinations of taint and they are affected by the sources
2466 according to the rules below:
2468 * the return value (not including /r):
2469 tainted by the source string and pattern, but only for the
2470 number-of-iterations case; boolean returns aren't tainted;
2471 * the modified string (or modified copy under /r):
2472 tainted by the source string, pattern, and replacement strings;
2474 tainted by the pattern, and under 'use re "taint"', by the source
2476 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2477 should always be unset before executing subsequent code.
2479 The overall action of pp_subst is:
2481 * at the start, set bits in rxtainted indicating the taint status of
2482 the various sources.
2484 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2485 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2486 pattern has subsequently become tainted via locale ops.
2488 * If control is being passed to pp_substcont to execute a /e block,
2489 save rxtainted in the CXt_SUBST block, for future use by
2492 * Whenever control is being returned to perl code (either by falling
2493 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2494 use the flag bits in rxtainted to make all the appropriate types of
2495 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2496 et al will appear tainted.
2498 pp_match is just a simpler version of the above.
2514 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2515 See "how taint works" above */
2518 REGEXP *rx = PM_GETRE(pm);
2520 int force_on_match = 0;
2521 const I32 oldsave = PL_savestack_ix;
2523 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2528 /* known replacement string? */
2529 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2533 if (PL_op->op_flags & OPf_STACKED)
2542 SvGETMAGIC(TARG); /* must come before cow check */
2544 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2545 because they make integers such as 256 "false". */
2546 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2549 sv_force_normal_flags(TARG,0);
2551 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2552 && (SvREADONLY(TARG)
2553 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2554 || SvTYPE(TARG) > SVt_PVLV)
2555 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2556 Perl_croak_no_modify();
2559 orig = SvPV_nomg(TARG, len);
2560 /* note we don't (yet) force the var into being a string; if we fail
2561 * to match, we leave as-is; on successful match howeverm, we *will*
2562 * coerce into a string, then repeat the match */
2563 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2566 /* only replace once? */
2567 once = !(rpm->op_pmflags & PMf_GLOBAL);
2569 /* See "how taint works" above */
2572 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2573 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2574 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2575 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2576 ? SUBST_TAINT_BOOLRET : 0));
2582 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2584 strend = orig + len;
2585 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2586 maxiters = 2 * slen + 10; /* We can match twice at each
2587 position, once with zero-length,
2588 second time with non-zero. */
2590 if (!RX_PRELEN(rx) && PL_curpm
2591 && !ReANY(rx)->mother_re) {
2596 #ifdef PERL_SAWAMPERSAND
2597 r_flags = ( RX_NPARENS(rx)
2599 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2600 || (rpm->op_pmflags & PMf_KEEPCOPY)
2605 r_flags = REXEC_COPY_STR;
2608 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2611 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2612 LEAVE_SCOPE(oldsave);
2617 /* known replacement string? */
2619 /* replacement needing upgrading? */
2620 if (DO_UTF8(TARG) && !doutf8) {
2621 nsv = sv_newmortal();
2624 sv_recode_to_utf8(nsv, _get_encoding());
2626 sv_utf8_upgrade(nsv);
2627 c = SvPV_const(nsv, clen);
2631 c = SvPV_const(dstr, clen);
2632 doutf8 = DO_UTF8(dstr);
2635 if (SvTAINTED(dstr))
2636 rxtainted |= SUBST_TAINT_REPL;
2643 /* can do inplace substitution? */
2648 && (I32)clen <= RX_MINLENRET(rx)
2650 || !(r_flags & REXEC_COPY_STR)
2651 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2653 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2654 && (!doutf8 || SvUTF8(TARG))
2655 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2659 if (SvIsCOW(TARG)) {
2660 if (!force_on_match)
2662 assert(SvVOK(TARG));
2665 if (force_on_match) {
2666 /* redo the first match, this time with the orig var
2667 * forced into being a string */
2669 orig = SvPV_force_nomg(TARG, len);
2675 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2676 rxtainted |= SUBST_TAINT_PAT;
2677 m = orig + RX_OFFS(rx)[0].start;
2678 d = orig + RX_OFFS(rx)[0].end;
2680 if (m - s > strend - d) { /* faster to shorten from end */
2683 Copy(c, m, clen, char);
2688 Move(d, m, i, char);
2692 SvCUR_set(TARG, m - s);
2694 else { /* faster from front */
2698 Move(s, d - i, i, char);
2701 Copy(c, d, clen, char);
2708 d = s = RX_OFFS(rx)[0].start + orig;
2711 if (UNLIKELY(iters++ > maxiters))
2712 DIE(aTHX_ "Substitution loop");
2713 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2714 rxtainted |= SUBST_TAINT_PAT;
2715 m = RX_OFFS(rx)[0].start + orig;
2718 Move(s, d, i, char);
2722 Copy(c, d, clen, char);
2725 s = RX_OFFS(rx)[0].end + orig;
2726 } while (CALLREGEXEC(rx, s, strend, orig,
2727 s == m, /* don't match same null twice */
2729 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2732 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2733 Move(s, d, i+1, char); /* include the NUL */
2743 if (force_on_match) {
2744 /* redo the first match, this time with the orig var
2745 * forced into being a string */
2747 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2748 /* I feel that it should be possible to avoid this mortal copy
2749 given that the code below copies into a new destination.
2750 However, I suspect it isn't worth the complexity of
2751 unravelling the C<goto force_it> for the small number of
2752 cases where it would be viable to drop into the copy code. */
2753 TARG = sv_2mortal(newSVsv(TARG));
2755 orig = SvPV_force_nomg(TARG, len);
2761 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2762 rxtainted |= SUBST_TAINT_PAT;
2764 s = RX_OFFS(rx)[0].start + orig;
2765 dstr = newSVpvn_flags(orig, s-orig,
2766 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2771 /* note that a whole bunch of local vars are saved here for
2772 * use by pp_substcont: here's a list of them in case you're
2773 * searching for places in this sub that uses a particular var:
2774 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2775 * s m strend rx once */
2777 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2781 if (UNLIKELY(iters++ > maxiters))
2782 DIE(aTHX_ "Substitution loop");
2783 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2784 rxtainted |= SUBST_TAINT_PAT;
2785 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2787 char *old_orig = orig;
2788 assert(RX_SUBOFFSET(rx) == 0);
2790 orig = RX_SUBBEG(rx);
2791 s = orig + (old_s - old_orig);
2792 strend = s + (strend - old_s);
2794 m = RX_OFFS(rx)[0].start + orig;
2795 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2796 s = RX_OFFS(rx)[0].end + orig;
2798 /* replacement already stringified */
2800 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2805 if (!nsv) nsv = sv_newmortal();
2806 sv_copypv(nsv, repl);
2807 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
2808 sv_catsv(dstr, nsv);
2810 else sv_catsv(dstr, repl);
2811 if (UNLIKELY(SvTAINTED(repl)))
2812 rxtainted |= SUBST_TAINT_REPL;
2816 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2818 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2819 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2821 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2822 /* From here on down we're using the copy, and leaving the original
2829 /* The match may make the string COW. If so, brilliant, because
2830 that's just saved us one malloc, copy and free - the regexp has
2831 donated the old buffer, and we malloc an entirely new one, rather
2832 than the regexp malloc()ing a buffer and copying our original,
2833 only for us to throw it away here during the substitution. */
2834 if (SvIsCOW(TARG)) {
2835 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2841 SvPV_set(TARG, SvPVX(dstr));
2842 SvCUR_set(TARG, SvCUR(dstr));
2843 SvLEN_set(TARG, SvLEN(dstr));
2844 SvFLAGS(TARG) |= SvUTF8(dstr);
2845 SvPV_set(dstr, NULL);
2852 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2853 (void)SvPOK_only_UTF8(TARG);
2856 /* See "how taint works" above */
2858 if ((rxtainted & SUBST_TAINT_PAT) ||
2859 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2860 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2862 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2864 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2865 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2867 SvTAINTED_on(TOPs); /* taint return value */
2869 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2871 /* needed for mg_set below */
2873 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2877 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2879 LEAVE_SCOPE(oldsave);
2888 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2889 ++*PL_markstack_ptr;
2891 LEAVE_with_name("grep_item"); /* exit inner scope */
2894 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2896 const I32 gimme = GIMME_V;
2898 LEAVE_with_name("grep"); /* exit outer scope */
2899 (void)POPMARK; /* pop src */
2900 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2901 (void)POPMARK; /* pop dst */
2902 SP = PL_stack_base + POPMARK; /* pop original mark */
2903 if (gimme == G_SCALAR) {
2904 if (PL_op->op_private & OPpGREP_LEX) {
2905 SV* const sv = sv_newmortal();
2906 sv_setiv(sv, items);
2914 else if (gimme == G_ARRAY)
2921 ENTER_with_name("grep_item"); /* enter inner scope */
2924 src = PL_stack_base[*PL_markstack_ptr];
2925 if (SvPADTMP(src)) {
2926 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2930 if (PL_op->op_private & OPpGREP_LEX)
2931 PAD_SVl(PL_op->op_targ) = src;
2935 RETURNOP(cLOGOP->op_other);
2949 if (CxMULTICALL(&cxstack[cxstack_ix]))
2953 cxstack_ix++; /* temporarily protect top context */
2956 if (gimme == G_SCALAR) {
2958 if (LIKELY(MARK <= SP)) {
2959 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2960 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2961 && !SvMAGICAL(TOPs)) {
2962 *MARK = SvREFCNT_inc(TOPs);
2967 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2969 *MARK = sv_mortalcopy(sv);
2970 SvREFCNT_dec_NN(sv);
2973 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2974 && !SvMAGICAL(TOPs)) {
2978 *MARK = sv_mortalcopy(TOPs);
2982 *MARK = &PL_sv_undef;
2986 else if (gimme == G_ARRAY) {
2987 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2988 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2989 || SvMAGICAL(*MARK)) {
2990 *MARK = sv_mortalcopy(*MARK);
2991 TAINT_NOT; /* Each item is independent */
2998 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
3000 PL_curpm = newpm; /* ... and pop $1 et al */
3003 return cx->blk_sub.retop;
3013 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
3016 DIE(aTHX_ "Not a CODE reference");
3017 /* This is overwhelmingly the most common case: */
3018 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
3019 switch (SvTYPE(sv)) {
3022 if (!(cv = GvCVu((const GV *)sv))) {
3024 cv = sv_2cv(sv, &stash, &gv, 0);
3033 if(isGV_with_GP(sv)) goto we_have_a_glob;
3036 if (sv == &PL_sv_yes) { /* unfound import, ignore */
3038 SP = PL_stack_base + POPMARK;
3046 sv = amagic_deref_call(sv, to_cv_amg);
3047 /* Don't SPAGAIN here. */
3054 DIE(aTHX_ PL_no_usym, "a subroutine");
3055 sym = SvPV_nomg_const(sv, len);
3056 if (PL_op->op_private & HINT_STRICT_REFS)
3057 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
3058 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
3061 cv = MUTABLE_CV(SvRV(sv));
3062 if (SvTYPE(cv) == SVt_PVCV)
3067 DIE(aTHX_ "Not a CODE reference");
3068 /* This is the second most common case: */
3070 cv = MUTABLE_CV(sv);
3078 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
3079 DIE(aTHX_ "Closure prototype called");
3080 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
3084 /* anonymous or undef'd function leaves us no recourse */
3085 if (CvLEXICAL(cv) && CvHASGV(cv))
3086 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
3087 SVfARG(cv_name(cv, NULL, 0)));
3088 if (CvANON(cv) || !CvHASGV(cv)) {
3089 DIE(aTHX_ "Undefined subroutine called");
3092 /* autoloaded stub? */
3093 if (cv != GvCV(gv = CvGV(cv))) {
3096 /* should call AUTOLOAD now? */
3099 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
3100 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
3106 sub_name = sv_newmortal();
3107 gv_efullname3(sub_name, gv, NULL);
3108 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
3116 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
3119 Perl_get_db_sub(aTHX_ &sv, cv);
3121 PL_curcopdb = PL_curcop;
3123 /* check for lsub that handles lvalue subroutines */
3124 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
3125 /* if lsub not found then fall back to DB::sub */
3126 if (!cv) cv = GvCV(PL_DBsub);
3128 cv = GvCV(PL_DBsub);
3131 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
3132 DIE(aTHX_ "No DB::sub routine defined");
3137 if (!(CvISXSUB(cv))) {
3138 /* This path taken at least 75% of the time */
3140 PADLIST * const padlist = CvPADLIST(cv);
3143 PUSHBLOCK(cx, CXt_SUB, MARK);
3145 cx->blk_sub.retop = PL_op->op_next;
3146 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
3147 PERL_STACK_OVERFLOW_CHECK();
3148 pad_push(padlist, depth);
3151 PAD_SET_CUR_NOSAVE(padlist, depth);
3152 if (LIKELY(hasargs)) {
3153 AV *const av = MUTABLE_AV(PAD_SVl(0));
3157 if (UNLIKELY(AvREAL(av))) {
3158 /* @_ is normally not REAL--this should only ever
3159 * happen when DB::sub() calls things that modify @_ */
3164 defavp = &GvAV(PL_defgv);
3165 cx->blk_sub.savearray = *defavp;
3166 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
3167 CX_CURPAD_SAVE(cx->blk_sub);
3168 cx->blk_sub.argarray = av;
3171 if (UNLIKELY(items - 1 > AvMAX(av))) {
3172 SV **ary = AvALLOC(av);
3173 AvMAX(av) = items - 1;
3174 Renew(ary, items, SV*);
3179 Copy(MARK+1,AvARRAY(av),items,SV*);
3180 AvFILLp(av) = items - 1;
3186 if (SvPADTMP(*MARK)) {
3187 *MARK = sv_mortalcopy(*MARK);
3195 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3197 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3198 /* warning must come *after* we fully set up the context
3199 * stuff so that __WARN__ handlers can safely dounwind()
3202 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
3203 && ckWARN(WARN_RECURSION)
3204 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
3205 sub_crush_depth(cv);
3206 RETURNOP(CvSTART(cv));
3209 SSize_t markix = TOPMARK;
3214 if (UNLIKELY(((PL_op->op_private
3215 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
3216 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
3218 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
3220 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
3221 /* Need to copy @_ to stack. Alternative may be to
3222 * switch stack to @_, and copy return values
3223 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3224 AV * const av = GvAV(PL_defgv);
3225 const SSize_t items = AvFILL(av) + 1;
3229 const bool m = cBOOL(SvRMAGICAL(av));
3230 /* Mark is at the end of the stack. */
3232 for (; i < items; ++i)
3236 SV ** const svp = av_fetch(av, i, 0);
3237 sv = svp ? *svp : NULL;
3239 else sv = AvARRAY(av)[i];
3240 if (sv) SP[i+1] = sv;
3242 SP[i+1] = newSVavdefelem(av, i, 1);
3250 SV **mark = PL_stack_base + markix;
3251 SSize_t items = SP - mark;
3254 if (*mark && SvPADTMP(*mark)) {
3255 *mark = sv_mortalcopy(*mark);
3259 /* We assume first XSUB in &DB::sub is the called one. */
3260 if (UNLIKELY(PL_curcopdb)) {
3261 SAVEVPTR(PL_curcop);
3262 PL_curcop = PL_curcopdb;
3265 /* Do we need to open block here? XXXX */
3267 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3269 CvXSUB(cv)(aTHX_ cv);
3271 /* Enforce some sanity in scalar context. */
3272 if (gimme == G_SCALAR) {
3273 SV **svp = PL_stack_base + markix + 1;
3274 if (svp != PL_stack_sp) {
3275 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
3285 Perl_sub_crush_depth(pTHX_ CV *cv)
3287 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3290 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3292 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3293 SVfARG(cv_name(cv,NULL,0)));
3301 SV* const elemsv = POPs;
3302 IV elem = SvIV(elemsv);
3303 AV *const av = MUTABLE_AV(POPs);
3304 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3305 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
3306 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3307 bool preeminent = TRUE;
3310 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
3311 Perl_warner(aTHX_ packWARN(WARN_MISC),
3312 "Use of reference \"%"SVf"\" as array index",
3314 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
3317 if (UNLIKELY(localizing)) {
3321 /* If we can determine whether the element exist,
3322 * Try to preserve the existenceness of a tied array
3323 * element by using EXISTS and DELETE if possible.
3324 * Fallback to FETCH and STORE otherwise. */
3325 if (SvCANEXISTDELETE(av))
3326 preeminent = av_exists(av, elem);
3329 svp = av_fetch(av, elem, lval && !defer);
3331 #ifdef PERL_MALLOC_WRAP
3332 if (SvUOK(elemsv)) {
3333 const UV uv = SvUV(elemsv);
3334 elem = uv > IV_MAX ? IV_MAX : uv;
3336 else if (SvNOK(elemsv))
3337 elem = (IV)SvNV(elemsv);
3339 static const char oom_array_extend[] =
3340 "Out of memory during array extend"; /* Duplicated in av.c */
3341 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3344 if (!svp || !*svp) {
3347 DIE(aTHX_ PL_no_aelem, elem);
3348 len = av_tindex(av);
3349 mPUSHs(newSVavdefelem(av,
3350 /* Resolve a negative index now, unless it points before the
3351 beginning of the array, in which case record it for error
3352 reporting in magic_setdefelem. */
3353 elem < 0 && len + elem >= 0 ? len + elem : elem,
3357 if (UNLIKELY(localizing)) {
3359 save_aelem(av, elem, svp);
3361 SAVEADELETE(av, elem);
3363 else if (PL_op->op_private & OPpDEREF) {
3364 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
3368 sv = (svp ? *svp : &PL_sv_undef);
3369 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3376 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3378 PERL_ARGS_ASSERT_VIVIFY_REF;
3383 Perl_croak_no_modify();
3384 prepare_SV_for_RV(sv);
3387 SvRV_set(sv, newSV(0));
3390 SvRV_set(sv, MUTABLE_SV(newAV()));
3393 SvRV_set(sv, MUTABLE_SV(newHV()));
3400 if (SvGMAGICAL(sv)) {
3401 /* copy the sv without magic to prevent magic from being
3403 SV* msv = sv_newmortal();
3404 sv_setsv_nomg(msv, sv);
3410 PERL_STATIC_INLINE HV *
3411 S_opmethod_stash(pTHX_ SV* meth)
3416 SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
3417 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3418 "package or object reference", SVfARG(meth)),
3420 : *(PL_stack_base + TOPMARK + 1);
3422 PERL_ARGS_ASSERT_OPMETHOD_STASH;
3426 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3429 if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
3430 else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
3431 stash = gv_stashsv(sv, GV_CACHE_ONLY);
3432 if (stash) return stash;
3436 ob = MUTABLE_SV(SvRV(sv));
3437 else if (!SvOK(sv)) goto undefined;
3438 else if (isGV_with_GP(sv)) {
3440 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3441 "without a package or object reference",
3444 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3445 assert(!LvTARGLEN(ob));
3449 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3452 /* this isn't a reference */
3455 const char * const packname = SvPV_nomg_const(sv, packlen);
3456 const U32 packname_utf8 = SvUTF8(sv);
3457 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3458 if (stash) return stash;
3460 if (!(iogv = gv_fetchpvn_flags(
3461 packname, packlen, packname_utf8, SVt_PVIO
3463 !(ob=MUTABLE_SV(GvIO(iogv))))
3465 /* this isn't the name of a filehandle either */
3468 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3469 "without a package or object reference",
3472 /* assume it's a package name */
3473 stash = gv_stashpvn(packname, packlen, packname_utf8);
3474 if (stash) return stash;
3475 else return MUTABLE_HV(sv);
3477 /* it _is_ a filehandle name -- replace with a reference */
3478 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3481 /* if we got here, ob should be an object or a glob */
3482 if (!ob || !(SvOBJECT(ob)
3483 || (isGV_with_GP(ob)
3484 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3487 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3488 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3489 ? newSVpvs_flags("DOES", SVs_TEMP)
3501 SV* const meth = TOPs;
3504 SV* const rmeth = SvRV(meth);
3505 if (SvTYPE(rmeth) == SVt_PVCV) {
3511 stash = opmethod_stash(meth);
3513 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3516 SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3520 #define METHOD_CHECK_CACHE(stash,cache,meth) \
3521 const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
3523 gv = MUTABLE_GV(HeVAL(he)); \
3524 if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
3525 == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
3527 XPUSHs(MUTABLE_SV(GvCV(gv))); \
3536 SV* const meth = cMETHOPx_meth(PL_op);
3537 HV* const stash = opmethod_stash(meth);
3539 if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
3540 METHOD_CHECK_CACHE(stash, stash, meth);
3543 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3546 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3555 SV* const meth = cMETHOPx_meth(PL_op);
3556 HV* const stash = CopSTASH(PL_curcop);
3557 /* Actually, SUPER doesn't need real object's (or class') stash at all,
3558 * as it uses CopSTASH. However, we must ensure that object(class) is
3559 * correct (this check is done by S_opmethod_stash) */
3560 opmethod_stash(meth);
3562 if ((cache = HvMROMETA(stash)->super)) {
3563 METHOD_CHECK_CACHE(stash, cache, meth);
3566 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3569 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3577 SV* const meth = cMETHOPx_meth(PL_op);
3578 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3579 opmethod_stash(meth); /* not used but needed for error checks */
3581 if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
3582 else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3584 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
3587 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3591 PP(pp_method_redir_super)
3596 SV* const meth = cMETHOPx_meth(PL_op);
3597 HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
3598 opmethod_stash(meth); /* not used but needed for error checks */
3600 if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
3601 else if ((cache = HvMROMETA(stash)->super)) {
3602 METHOD_CHECK_CACHE(stash, cache, meth);
3605 gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
3608 XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
3614 * c-indentation-style: bsd
3616 * indent-tabs-mode: nil
3619 * ex: set ts=8 sts=4 sw=4 et: