3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
51 TAINT_NOT; /* Each statement is presumed innocent */
52 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
62 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
63 PUSHs(save_scalar(cGVOP_gv));
65 PUSHs(GvSVn(cGVOP_gv));
66 if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
72 /* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
79 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
82 PUSHMARK(PL_stack_sp);
93 /* no PUTBACK, SETs doesn't inc/dec SP */
100 XPUSHs(MUTABLE_SV(cGVOP_gv));
102 && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
108 /* also used for: pp_andassign() */
114 /* SP is not used to remove a variable that is saved across the
115 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
116 register or load/store vs direct mem ops macro is introduced, this
117 should be a define block between direct PL_stack_sp and dSP operations,
118 presently, using PL_stack_sp is bias towards CISC cpus */
119 SV * const sv = *PL_stack_sp;
123 if (PL_op->op_type == OP_AND)
125 return cLOGOP->op_other;
133 /* sassign keeps its args in the optree traditionally backwards.
134 So we pop them differently.
136 SV *left = POPs; SV *right = TOPs;
138 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
139 SV * const temp = left;
140 left = right; right = temp;
142 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
144 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
146 SV * const cv = SvRV(right);
147 const U32 cv_type = SvTYPE(cv);
148 const bool is_gv = isGV_with_GP(left);
149 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
155 /* Can do the optimisation if left (LVALUE) is not a typeglob,
156 right (RVALUE) is a reference to something, and we're in void
158 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
159 /* Is the target symbol table currently empty? */
160 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
161 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
162 /* Good. Create a new proxy constant subroutine in the target.
163 The gv becomes a(nother) reference to the constant. */
164 SV *const value = SvRV(cv);
166 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
167 SvPCS_IMPORTED_on(gv);
169 SvREFCNT_inc_simple_void(value);
175 /* Need to fix things up. */
177 /* Need to fix GV. */
178 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
182 /* We've been returned a constant rather than a full subroutine,
183 but they expect a subroutine reference to apply. */
185 ENTER_with_name("sassign_coderef");
186 SvREFCNT_inc_void(SvRV(cv));
187 /* newCONSTSUB takes a reference count on the passed in SV
188 from us. We set the name to NULL, otherwise we get into
189 all sorts of fun as the reference to our new sub is
190 donated to the GV that we're about to assign to.
192 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
195 LEAVE_with_name("sassign_coderef");
197 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
199 First: ops for \&{"BONK"}; return us the constant in the
201 Second: ops for *{"BONK"} cause that symbol table entry
202 (and our reference to it) to be upgraded from RV
204 Thirdly: We get here. cv is actually PVGV now, and its
205 GvCV() is actually the subroutine we're looking for
207 So change the reference so that it points to the subroutine
208 of that typeglob, as that's what they were after all along.
210 GV *const upgraded = MUTABLE_GV(cv);
211 CV *const source = GvCV(upgraded);
214 assert(CvFLAGS(source) & CVf_CONST);
216 SvREFCNT_inc_void(source);
217 SvREFCNT_dec_NN(upgraded);
218 SvRV_set(right, MUTABLE_SV(source));
224 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
225 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
228 packWARN(WARN_MISC), "Useless assignment to a temporary"
230 SvSetMagicSV(left, right);
240 RETURNOP(cLOGOP->op_other);
242 RETURNOP(cLOGOP->op_next);
248 TAINT_NOT; /* Each statement is presumed innocent */
249 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
251 if (!(PL_op->op_flags & OPf_SPECIAL)) {
252 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
253 LEAVE_SCOPE(oldsave);
260 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
265 const char *rpv = NULL;
267 bool rcopied = FALSE;
269 if (TARG == right && right != left) { /* $r = $l.$r */
270 rpv = SvPV_nomg_const(right, rlen);
271 rbyte = !DO_UTF8(right);
272 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
273 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
277 if (TARG != left) { /* not $l .= $r */
279 const char* const lpv = SvPV_nomg_const(left, llen);
280 lbyte = !DO_UTF8(left);
281 sv_setpvn(TARG, lpv, llen);
287 else { /* $l .= $r and left == TARG */
289 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
290 report_uninit(right);
294 SvPV_force_nomg_nolen(left);
296 lbyte = !DO_UTF8(left);
303 /* $r.$r: do magic twice: tied might return different 2nd time */
305 rpv = SvPV_nomg_const(right, rlen);
306 rbyte = !DO_UTF8(right);
308 if (lbyte != rbyte) {
309 /* sv_utf8_upgrade_nomg() may reallocate the stack */
312 sv_utf8_upgrade_nomg(TARG);
315 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
316 sv_utf8_upgrade_nomg(right);
317 rpv = SvPV_nomg_const(right, rlen);
321 sv_catpvn_nomg(TARG, rpv, rlen);
328 /* push the elements of av onto the stack.
329 * XXX Note that padav has similar code but without the mg_get().
330 * I suspect that the mg_get is no longer needed, but while padav
331 * differs, it can't share this function */
334 S_pushav(pTHX_ AV* const av)
337 const SSize_t maxarg = AvFILL(av) + 1;
339 if (UNLIKELY(SvRMAGICAL(av))) {
341 for (i=0; i < (PADOFFSET)maxarg; i++) {
342 SV ** const svp = av_fetch(av, i, FALSE);
343 /* See note in pp_helem, and bug id #27839 */
345 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
351 for (i=0; i < (PADOFFSET)maxarg; i++) {
352 SV * const sv = AvARRAY(av)[i];
353 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
361 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
366 PADOFFSET base = PL_op->op_targ;
367 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
369 if (PL_op->op_flags & OPf_SPECIAL) {
370 /* fake the RHS of my ($x,$y,..) = @_ */
372 S_pushav(aTHX_ GvAVn(PL_defgv));
376 /* note, this is only skipped for compile-time-known void cxt */
377 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
380 for (i = 0; i <count; i++)
381 *++SP = PAD_SV(base+i);
383 if (PL_op->op_private & OPpLVAL_INTRO) {
384 SV **svp = &(PAD_SVl(base));
385 const UV payload = (UV)(
386 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
387 | (count << SAVE_TIGHT_SHIFT)
388 | SAVEt_CLEARPADRANGE);
389 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
390 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
397 for (i = 0; i <count; i++)
398 SvPADSTALE_off(*svp++); /* mark lexical as active */
409 OP * const op = PL_op;
410 /* access PL_curpad once */
411 SV ** const padentry = &(PAD_SVl(op->op_targ));
416 PUTBACK; /* no pop/push after this, TOPs ok */
418 if (op->op_flags & OPf_MOD) {
419 if (op->op_private & OPpLVAL_INTRO)
420 if (!(op->op_private & OPpPAD_STATE))
421 save_clearsv(padentry);
422 if (op->op_private & OPpDEREF) {
423 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
424 than TARG reduces the scope of TARG, so it does not
425 span the call to save_clearsv, resulting in smaller
427 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
439 tryAMAGICunTARGETlist(iter_amg, 0);
440 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
442 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
443 if (!isGV_with_GP(PL_last_in_gv)) {
444 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
445 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
448 XPUSHs(MUTABLE_SV(PL_last_in_gv));
451 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
454 return do_readline();
462 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
466 (SvIOK_notUV(left) && SvIOK_notUV(right))
467 ? (SvIVX(left) == SvIVX(right))
468 : ( do_ncmp(left, right) == 0)
474 /* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
480 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
481 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
482 Perl_croak_no_modify();
483 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
484 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
486 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
487 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
489 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
490 if (inc) sv_inc(TOPs);
497 /* also used for: pp_orassign() */
506 if (PL_op->op_type == OP_OR)
508 RETURNOP(cLOGOP->op_other);
513 /* also used for: pp_dor() pp_dorassign() */
520 const int op_type = PL_op->op_type;
521 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
526 if (UNLIKELY(!sv || !SvANY(sv))) {
527 if (op_type == OP_DOR)
529 RETURNOP(cLOGOP->op_other);
535 if (UNLIKELY(!sv || !SvANY(sv)))
540 switch (SvTYPE(sv)) {
542 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
546 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
550 if (CvROOT(sv) || CvXSUB(sv))
563 if(op_type == OP_DOR)
565 RETURNOP(cLOGOP->op_other);
567 /* assuming OP_DEFINED */
575 dSP; dATARGET; bool useleft; SV *svl, *svr;
576 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
580 useleft = USE_LEFT(svl);
581 #ifdef PERL_PRESERVE_IVUV
582 /* We must see if we can perform the addition with integers if possible,
583 as the integer code detects overflow while the NV code doesn't.
584 If either argument hasn't had a numeric conversion yet attempt to get
585 the IV. It's important to do this now, rather than just assuming that
586 it's not IOK as a PV of "9223372036854775806" may not take well to NV
587 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
588 integer in case the second argument is IV=9223372036854775806
589 We can (now) rely on sv_2iv to do the right thing, only setting the
590 public IOK flag if the value in the NV (or PV) slot is truly integer.
592 A side effect is that this also aggressively prefers integer maths over
593 fp maths for integer values.
595 How to detect overflow?
597 C 99 section 6.2.6.1 says
599 The range of nonnegative values of a signed integer type is a subrange
600 of the corresponding unsigned integer type, and the representation of
601 the same value in each type is the same. A computation involving
602 unsigned operands can never overflow, because a result that cannot be
603 represented by the resulting unsigned integer type is reduced modulo
604 the number that is one greater than the largest value that can be
605 represented by the resulting type.
609 which I read as "unsigned ints wrap."
611 signed integer overflow seems to be classed as "exception condition"
613 If an exceptional condition occurs during the evaluation of an
614 expression (that is, if the result is not mathematically defined or not
615 in the range of representable values for its type), the behavior is
618 (6.5, the 5th paragraph)
620 I had assumed that on 2s complement machines signed arithmetic would
621 wrap, hence coded pp_add and pp_subtract on the assumption that
622 everything perl builds on would be happy. After much wailing and
623 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
624 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
625 unsigned code below is actually shorter than the old code. :-)
628 if (SvIV_please_nomg(svr)) {
629 /* Unless the left argument is integer in range we are going to have to
630 use NV maths. Hence only attempt to coerce the right argument if
631 we know the left is integer. */
639 /* left operand is undef, treat as zero. + 0 is identity,
640 Could SETi or SETu right now, but space optimise by not adding
641 lots of code to speed up what is probably a rarish case. */
643 /* Left operand is defined, so is it IV? */
644 if (SvIV_please_nomg(svl)) {
645 if ((auvok = SvUOK(svl)))
648 const IV aiv = SvIVX(svl);
651 auvok = 1; /* Now acting as a sign flag. */
652 } else { /* 2s complement assumption for IV_MIN */
660 bool result_good = 0;
663 bool buvok = SvUOK(svr);
668 const IV biv = SvIVX(svr);
675 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
676 else "IV" now, independent of how it came in.
677 if a, b represents positive, A, B negative, a maps to -A etc
682 all UV maths. negate result if A negative.
683 add if signs same, subtract if signs differ. */
689 /* Must get smaller */
695 /* result really should be -(auv-buv). as its negation
696 of true value, need to swap our result flag */
713 if (result <= (UV)IV_MIN)
716 /* result valid, but out of range for IV. */
721 } /* Overflow, drop through to NVs. */
726 NV value = SvNV_nomg(svr);
729 /* left operand is undef, treat as zero. + 0.0 is identity. */
733 SETn( value + SvNV_nomg(svl) );
739 /* also used for: pp_aelemfast_lex() */
744 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
745 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
746 const U32 lval = PL_op->op_flags & OPf_MOD;
747 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
748 SV *sv = (svp ? *svp : &PL_sv_undef);
750 if (UNLIKELY(!svp && lval))
751 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
754 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
764 do_join(TARG, *MARK, MARK, SP);
775 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
776 * will be enough to hold an OP*.
778 SV* const sv = sv_newmortal();
779 sv_upgrade(sv, SVt_PVLV);
781 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
784 XPUSHs(MUTABLE_SV(PL_op));
789 /* Oversized hot code. */
791 /* also used for: pp_say() */
795 dSP; dMARK; dORIGMARK;
799 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
803 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
806 if (MARK == ORIGMARK) {
807 /* If using default handle then we need to make space to
808 * pass object as 1st arg, so move other args up ...
812 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
815 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
817 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
818 | (PL_op->op_type == OP_SAY
819 ? TIED_METHOD_SAY : 0)), sp - mark);
822 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
823 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
826 SETERRNO(EBADF,RMS_IFI);
829 else if (!(fp = IoOFP(io))) {
831 report_wrongway_fh(gv, '<');
834 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
838 SV * const ofs = GvSV(PL_ofsgv); /* $, */
840 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
842 if (!do_print(*MARK, fp))
846 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
847 if (!do_print(GvSV(PL_ofsgv), fp)) {
856 if (!do_print(*MARK, fp))
864 if (PL_op->op_type == OP_SAY) {
865 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
868 else if (PL_ors_sv && SvOK(PL_ors_sv))
869 if (!do_print(PL_ors_sv, fp)) /* $\ */
872 if (IoFLAGS(io) & IOf_FLUSH)
873 if (PerlIO_flush(fp) == EOF)
883 XPUSHs(&PL_sv_undef);
888 /* also used for: pp_rv2hv() */
893 const I32 gimme = GIMME_V;
894 static const char an_array[] = "an ARRAY";
895 static const char a_hash[] = "a HASH";
896 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
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, with no intending change to preserve history
945 (until such time as we get tools that can do blame annotation across
946 whitespace changes. */
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)) {
1074 TAINT_NOT; /* Each item stands on its own, taintwise. */
1076 switch (SvTYPE(sv)) {
1078 ary = MUTABLE_AV(sv);
1079 magic = SvMAGICAL(ary) != 0;
1081 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1083 av_extend(ary, lastrelem - relem);
1085 while (relem <= lastrelem) { /* gobble up all the rest */
1088 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1090 sv_setsv_nomg(sv, *relem);
1092 didstore = av_store(ary,i++,sv);
1101 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1102 SvSETMAGIC(MUTABLE_SV(ary));
1105 case SVt_PVHV: { /* normal hash */
1109 SV** topelem = relem;
1110 SV **firsthashrelem = relem;
1112 hash = MUTABLE_HV(sv);
1113 magic = SvMAGICAL(hash) != 0;
1115 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1116 if (UNLIKELY(odd)) {
1117 do_oddball(lastrelem, firsthashrelem);
1118 /* we have firstlelem to reuse, it's not needed anymore
1120 *(lastrelem+1) = &PL_sv_undef;
1124 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1126 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1129 /* Copy the key if aassign is called in lvalue context,
1130 to avoid having the next op modify our rhs. Copy
1131 it also if it is gmagical, lest it make the
1132 hv_store_ent call below croak, leaking the value. */
1133 sv = lval || SvGMAGICAL(*relem)
1134 ? sv_mortalcopy(*relem)
1140 sv_setsv_nomg(tmpstr,*relem++); /* value */
1141 if (gimme == G_ARRAY) {
1142 if (hv_exists_ent(hash, sv, 0))
1143 /* key overwrites an existing entry */
1146 /* copy element back: possibly to an earlier
1147 * stack location if we encountered dups earlier,
1148 * possibly to a later stack location if odd */
1150 *topelem++ = tmpstr;
1153 didstore = hv_store_ent(hash,sv,tmpstr,0);
1155 if (!didstore) sv_2mortal(tmpstr);
1161 if (duplicates && gimme == G_ARRAY) {
1162 /* at this point we have removed the duplicate key/value
1163 * pairs from the stack, but the remaining values may be
1164 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1165 * the (a 2), but the stack now probably contains
1166 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1167 * obliterates the earlier key. So refresh all values. */
1168 lastrelem -= duplicates;
1169 relem = firsthashrelem;
1170 while (relem < lastrelem+odd) {
1172 he = hv_fetch_ent(hash, *relem++, 0, 0);
1173 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1176 if (odd && gimme == G_ARRAY) lastrelem++;
1180 if (SvIMMORTAL(sv)) {
1181 if (relem <= lastrelem)
1185 if (relem <= lastrelem) {
1187 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1188 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1191 packWARN(WARN_MISC),
1192 "Useless assignment to a temporary"
1194 sv_setsv(sv, *relem);
1198 sv_setsv(sv, &PL_sv_undef);
1203 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1204 /* Will be used to set PL_tainting below */
1205 Uid_t tmp_uid = PerlProc_getuid();
1206 Uid_t tmp_euid = PerlProc_geteuid();
1207 Gid_t tmp_gid = PerlProc_getgid();
1208 Gid_t tmp_egid = PerlProc_getegid();
1210 /* XXX $> et al currently silently ignore failures */
1211 if (PL_delaymagic & DM_UID) {
1212 #ifdef HAS_SETRESUID
1214 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1215 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1218 # ifdef HAS_SETREUID
1220 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1221 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1224 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1225 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1226 PL_delaymagic &= ~DM_RUID;
1228 # endif /* HAS_SETRUID */
1230 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1231 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1232 PL_delaymagic &= ~DM_EUID;
1234 # endif /* HAS_SETEUID */
1235 if (PL_delaymagic & DM_UID) {
1236 if (PL_delaymagic_uid != PL_delaymagic_euid)
1237 DIE(aTHX_ "No setreuid available");
1238 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1240 # endif /* HAS_SETREUID */
1241 #endif /* HAS_SETRESUID */
1243 tmp_uid = PerlProc_getuid();
1244 tmp_euid = PerlProc_geteuid();
1246 /* XXX $> et al currently silently ignore failures */
1247 if (PL_delaymagic & DM_GID) {
1248 #ifdef HAS_SETRESGID
1250 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1251 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1254 # ifdef HAS_SETREGID
1256 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1257 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1260 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1261 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1262 PL_delaymagic &= ~DM_RGID;
1264 # endif /* HAS_SETRGID */
1266 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1267 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1268 PL_delaymagic &= ~DM_EGID;
1270 # endif /* HAS_SETEGID */
1271 if (PL_delaymagic & DM_GID) {
1272 if (PL_delaymagic_gid != PL_delaymagic_egid)
1273 DIE(aTHX_ "No setregid available");
1274 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1276 # endif /* HAS_SETREGID */
1277 #endif /* HAS_SETRESGID */
1279 tmp_gid = PerlProc_getgid();
1280 tmp_egid = PerlProc_getegid();
1282 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1283 #ifdef NO_TAINT_SUPPORT
1284 PERL_UNUSED_VAR(tmp_uid);
1285 PERL_UNUSED_VAR(tmp_euid);
1286 PERL_UNUSED_VAR(tmp_gid);
1287 PERL_UNUSED_VAR(tmp_egid);
1292 if (gimme == G_VOID)
1293 SP = firstrelem - 1;
1294 else if (gimme == G_SCALAR) {
1297 SETi(lastrelem - firstrelem + 1);
1301 /* note that in this case *firstlelem may have been overwritten
1302 by sv_undef in the odd hash case */
1305 SP = firstrelem + (lastlelem - firstlelem);
1306 lelem = firstlelem + (relem - firstrelem);
1308 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1318 PMOP * const pm = cPMOP;
1319 REGEXP * rx = PM_GETRE(pm);
1320 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1321 SV * const rv = sv_newmortal();
1325 SvUPGRADE(rv, SVt_IV);
1326 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1327 loathe to use it here, but it seems to be the right fix. Or close.
1328 The key part appears to be that it's essential for pp_qr to return a new
1329 object (SV), which implies that there needs to be an effective way to
1330 generate a new SV from the existing SV that is pre-compiled in the
1332 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1335 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1336 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1337 *cvp = cv_clone(cv);
1338 SvREFCNT_dec_NN(cv);
1342 HV *const stash = gv_stashsv(pkg, GV_ADD);
1343 SvREFCNT_dec_NN(pkg);
1344 (void)sv_bless(rv, stash);
1347 if (UNLIKELY(RX_ISTAINTED(rx))) {
1349 SvTAINTED_on(SvRV(rv));
1362 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1365 const char *truebase; /* Start of string */
1366 REGEXP *rx = PM_GETRE(pm);
1368 const I32 gimme = GIMME;
1370 const I32 oldsave = PL_savestack_ix;
1371 I32 had_zerolen = 0;
1374 if (PL_op->op_flags & OPf_STACKED)
1376 else if (PL_op->op_private & OPpTARGET_MY)
1383 PUTBACK; /* EVAL blocks need stack_sp. */
1384 /* Skip get-magic if this is a qr// clone, because regcomp has
1386 truebase = ReANY(rx)->mother_re
1387 ? SvPV_nomg_const(TARG, len)
1388 : SvPV_const(TARG, len);
1390 DIE(aTHX_ "panic: pp_match");
1391 strend = truebase + len;
1392 rxtainted = (RX_ISTAINTED(rx) ||
1393 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1396 /* We need to know this in case we fail out early - pos() must be reset */
1397 global = dynpm->op_pmflags & PMf_GLOBAL;
1399 /* PMdf_USED is set after a ?? matches once */
1402 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1404 pm->op_pmflags & PMf_USED
1407 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1411 /* empty pattern special-cased to use last successful pattern if
1412 possible, except for qr// */
1413 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1419 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1420 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1421 UVuf" < %"IVdf")\n",
1422 (UV)len, (IV)RX_MINLEN(rx)));
1426 /* get pos() if //g */
1428 mg = mg_find_mglob(TARG);
1429 if (mg && mg->mg_len >= 0) {
1430 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1431 /* last time pos() was set, it was zero-length match */
1432 if (mg->mg_flags & MGf_MINMATCH)
1437 #ifdef PERL_SAWAMPERSAND
1440 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1441 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1445 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1446 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1447 * only on the first iteration. Therefore we need to copy $' as well
1448 * as $&, to make the rest of the string available for captures in
1449 * subsequent iterations */
1450 if (! (global && gimme == G_ARRAY))
1451 r_flags |= REXEC_COPY_SKIP_POST;
1453 #ifdef PERL_SAWAMPERSAND
1454 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1455 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1456 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1463 s = truebase + curpos;
1465 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1466 had_zerolen, TARG, NULL, r_flags))
1470 if (dynpm->op_pmflags & PMf_ONCE)
1472 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1474 dynpm->op_pmflags |= PMf_USED;
1478 RX_MATCH_TAINTED_on(rx);
1479 TAINT_IF(RX_MATCH_TAINTED(rx));
1483 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1485 mg = sv_magicext_mglob(TARG);
1486 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1487 if (RX_ZERO_LEN(rx))
1488 mg->mg_flags |= MGf_MINMATCH;
1490 mg->mg_flags &= ~MGf_MINMATCH;
1493 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1494 LEAVE_SCOPE(oldsave);
1498 /* push captures on stack */
1501 const I32 nparens = RX_NPARENS(rx);
1502 I32 i = (global && !nparens) ? 1 : 0;
1504 SPAGAIN; /* EVAL blocks could move the stack. */
1505 EXTEND(SP, nparens + i);
1506 EXTEND_MORTAL(nparens + i);
1507 for (i = !i; i <= nparens; i++) {
1508 PUSHs(sv_newmortal());
1509 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1510 && RX_OFFS(rx)[i].end != -1 ))
1512 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1513 const char * const s = RX_OFFS(rx)[i].start + truebase;
1514 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1515 || len < 0 || len > strend - s))
1516 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1517 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1518 (long) i, (long) RX_OFFS(rx)[i].start,
1519 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1520 sv_setpvn(*SP, s, len);
1521 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1526 curpos = (UV)RX_OFFS(rx)[0].end;
1527 had_zerolen = RX_ZERO_LEN(rx);
1528 PUTBACK; /* EVAL blocks may use stack */
1529 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1532 LEAVE_SCOPE(oldsave);
1538 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1540 mg = mg_find_mglob(TARG);
1544 LEAVE_SCOPE(oldsave);
1545 if (gimme == G_ARRAY)
1551 Perl_do_readline(pTHX)
1553 dSP; dTARGETSTACKED;
1558 IO * const io = GvIO(PL_last_in_gv);
1559 const I32 type = PL_op->op_type;
1560 const I32 gimme = GIMME_V;
1563 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1565 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1566 if (gimme == G_SCALAR) {
1568 SvSetSV_nosteal(TARG, TOPs);
1578 if (IoFLAGS(io) & IOf_ARGV) {
1579 if (IoFLAGS(io) & IOf_START) {
1581 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1582 IoFLAGS(io) &= ~IOf_START;
1583 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1584 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1585 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1586 SvSETMAGIC(GvSV(PL_last_in_gv));
1591 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1592 if (!fp) { /* Note: fp != IoIFP(io) */
1593 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1596 else if (type == OP_GLOB)
1597 fp = Perl_start_glob(aTHX_ POPs, io);
1599 else if (type == OP_GLOB)
1601 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1602 report_wrongway_fh(PL_last_in_gv, '>');
1606 if ((!io || !(IoFLAGS(io) & IOf_START))
1607 && ckWARN(WARN_CLOSED)
1610 report_evil_fh(PL_last_in_gv);
1612 if (gimme == G_SCALAR) {
1613 /* undef TARG, and push that undefined value */
1614 if (type != OP_RCATLINE) {
1615 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1623 if (gimme == G_SCALAR) {
1625 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1628 if (type == OP_RCATLINE)
1629 SvPV_force_nomg_nolen(sv);
1633 else if (isGV_with_GP(sv)) {
1634 SvPV_force_nomg_nolen(sv);
1636 SvUPGRADE(sv, SVt_PV);
1637 tmplen = SvLEN(sv); /* remember if already alloced */
1638 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1639 /* try short-buffering it. Please update t/op/readline.t
1640 * if you change the growth length.
1645 if (type == OP_RCATLINE && SvOK(sv)) {
1647 SvPV_force_nomg_nolen(sv);
1653 sv = sv_2mortal(newSV(80));
1657 /* This should not be marked tainted if the fp is marked clean */
1658 #define MAYBE_TAINT_LINE(io, sv) \
1659 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1664 /* delay EOF state for a snarfed empty file */
1665 #define SNARF_EOF(gimme,rs,io,sv) \
1666 (gimme != G_SCALAR || SvCUR(sv) \
1667 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1671 if (!sv_gets(sv, fp, offset)
1673 || SNARF_EOF(gimme, PL_rs, io, sv)
1674 || PerlIO_error(fp)))
1676 PerlIO_clearerr(fp);
1677 if (IoFLAGS(io) & IOf_ARGV) {
1678 fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
1681 (void)do_close(PL_last_in_gv, FALSE);
1683 else if (type == OP_GLOB) {
1684 if (!do_close(PL_last_in_gv, FALSE)) {
1685 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1686 "glob failed (child exited with status %d%s)",
1687 (int)(STATUS_CURRENT >> 8),
1688 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1691 if (gimme == G_SCALAR) {
1692 if (type != OP_RCATLINE) {
1693 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1699 MAYBE_TAINT_LINE(io, sv);
1702 MAYBE_TAINT_LINE(io, sv);
1704 IoFLAGS(io) |= IOf_NOLINE;
1708 if (type == OP_GLOB) {
1711 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1712 char * const tmps = SvEND(sv) - 1;
1713 if (*tmps == *SvPVX_const(PL_rs)) {
1715 SvCUR_set(sv, SvCUR(sv) - 1);
1718 for (t1 = SvPVX_const(sv); *t1; t1++)
1720 if (strchr("*%?", *t1))
1722 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1725 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1726 (void)POPs; /* Unmatched wildcard? Chuck it... */
1729 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1730 if (ckWARN(WARN_UTF8)) {
1731 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1732 const STRLEN len = SvCUR(sv) - offset;
1735 if (!is_utf8_string_loc(s, len, &f))
1736 /* Emulate :encoding(utf8) warning in the same case. */
1737 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1738 "utf8 \"\\x%02X\" does not map to Unicode",
1739 f < (U8*)SvEND(sv) ? *f : 0);
1742 if (gimme == G_ARRAY) {
1743 if (SvLEN(sv) - SvCUR(sv) > 20) {
1744 SvPV_shrink_to_cur(sv);
1746 sv = sv_2mortal(newSV(80));
1749 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1750 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1751 const STRLEN new_len
1752 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1753 SvPV_renew(sv, new_len);
1764 SV * const keysv = POPs;
1765 HV * const hv = MUTABLE_HV(POPs);
1766 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1767 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1769 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1770 bool preeminent = TRUE;
1772 if (SvTYPE(hv) != SVt_PVHV)
1779 /* If we can determine whether the element exist,
1780 * Try to preserve the existenceness of a tied hash
1781 * element by using EXISTS and DELETE if possible.
1782 * Fallback to FETCH and STORE otherwise. */
1783 if (SvCANEXISTDELETE(hv))
1784 preeminent = hv_exists_ent(hv, keysv, 0);
1787 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1788 svp = he ? &HeVAL(he) : NULL;
1790 if (!svp || !*svp || *svp == &PL_sv_undef) {
1794 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1796 lv = sv_newmortal();
1797 sv_upgrade(lv, SVt_PVLV);
1799 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1800 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1801 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1807 if (HvNAME_get(hv) && isGV(*svp))
1808 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1809 else if (preeminent)
1810 save_helem_flags(hv, keysv, svp,
1811 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1813 SAVEHDELETE(hv, keysv);
1815 else if (PL_op->op_private & OPpDEREF) {
1816 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1820 sv = (svp && *svp ? *svp : &PL_sv_undef);
1821 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1822 * was to make C<local $tied{foo} = $tied{foo}> possible.
1823 * However, it seems no longer to be needed for that purpose, and
1824 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1825 * would loop endlessly since the pos magic is getting set on the
1826 * mortal copy and lost. However, the copy has the effect of
1827 * triggering the get magic, and losing it altogether made things like
1828 * c<$tied{foo};> in void context no longer do get magic, which some
1829 * code relied on. Also, delayed triggering of magic on @+ and friends
1830 * meant the original regex may be out of scope by now. So as a
1831 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1832 * being called too many times). */
1833 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1847 cx = &cxstack[cxstack_ix];
1848 itersvp = CxITERVAR(cx);
1850 switch (CxTYPE(cx)) {
1852 case CXt_LOOP_LAZYSV: /* string increment */
1854 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1855 SV *end = cx->blk_loop.state_u.lazysv.end;
1856 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1857 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1859 const char *max = SvPV_const(end, maxlen);
1860 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
1864 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1865 /* safe to reuse old SV */
1866 sv_setsv(oldsv, cur);
1870 /* we need a fresh SV every time so that loop body sees a
1871 * completely new SV for closures/references to work as
1873 *itersvp = newSVsv(cur);
1874 SvREFCNT_dec_NN(oldsv);
1876 if (strEQ(SvPVX_const(cur), max))
1877 sv_setiv(cur, 0); /* terminate next time */
1883 case CXt_LOOP_LAZYIV: /* integer increment */
1885 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1886 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
1890 /* don't risk potential race */
1891 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1892 /* safe to reuse old SV */
1893 sv_setiv(oldsv, cur);
1897 /* we need a fresh SV every time so that loop body sees a
1898 * completely new SV for closures/references to work as they
1900 *itersvp = newSViv(cur);
1901 SvREFCNT_dec_NN(oldsv);
1904 if (UNLIKELY(cur == IV_MAX)) {
1905 /* Handle end of range at IV_MAX */
1906 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1908 ++cx->blk_loop.state_u.lazyiv.cur;
1912 case CXt_LOOP_FOR: /* iterate array */
1915 AV *av = cx->blk_loop.state_u.ary.ary;
1917 bool av_is_stack = FALSE;
1924 if (PL_op->op_private & OPpITER_REVERSED) {
1925 ix = --cx->blk_loop.state_u.ary.ix;
1926 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
1930 ix = ++cx->blk_loop.state_u.ary.ix;
1931 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
1935 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
1936 SV * const * const svp = av_fetch(av, ix, FALSE);
1937 sv = svp ? *svp : NULL;
1940 sv = AvARRAY(av)[ix];
1944 if (UNLIKELY(SvIS_FREED(sv))) {
1946 Perl_croak(aTHX_ "Use of freed value in iteration");
1953 SvREFCNT_inc_simple_void_NN(sv);
1956 else if (!av_is_stack) {
1957 sv = newSVavdefelem(av, ix, 0);
1964 SvREFCNT_dec(oldsv);
1969 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1975 A description of how taint works in pattern matching and substitution.
1977 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1978 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1980 While the pattern is being assembled/concatenated and then compiled,
1981 PL_tainted will get set (via TAINT_set) if any component of the pattern
1982 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1983 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1984 TAINT_get). It will also be set if any component of the pattern matches
1985 based on locale-dependent behavior.
1987 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1988 the pattern is marked as tainted. This means that subsequent usage, such
1989 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1990 on the new pattern too.
1992 RXf_TAINTED_SEEN is used post-execution by the get magic code
1993 of $1 et al to indicate whether the returned value should be tainted.
1994 It is the responsibility of the caller of the pattern (i.e. pp_match,
1995 pp_subst etc) to set this flag for any other circumstances where $1 needs
1998 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2000 There are three possible sources of taint
2002 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2003 * the replacement string (or expression under /e)
2005 There are four destinations of taint and they are affected by the sources
2006 according to the rules below:
2008 * the return value (not including /r):
2009 tainted by the source string and pattern, but only for the
2010 number-of-iterations case; boolean returns aren't tainted;
2011 * the modified string (or modified copy under /r):
2012 tainted by the source string, pattern, and replacement strings;
2014 tainted by the pattern, and under 'use re "taint"', by the source
2016 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2017 should always be unset before executing subsequent code.
2019 The overall action of pp_subst is:
2021 * at the start, set bits in rxtainted indicating the taint status of
2022 the various sources.
2024 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2025 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2026 pattern has subsequently become tainted via locale ops.
2028 * If control is being passed to pp_substcont to execute a /e block,
2029 save rxtainted in the CXt_SUBST block, for future use by
2032 * Whenever control is being returned to perl code (either by falling
2033 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2034 use the flag bits in rxtainted to make all the appropriate types of
2035 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2036 et al will appear tainted.
2038 pp_match is just a simpler version of the above.
2054 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2055 See "how taint works" above */
2058 REGEXP *rx = PM_GETRE(pm);
2060 int force_on_match = 0;
2061 const I32 oldsave = PL_savestack_ix;
2063 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2068 /* known replacement string? */
2069 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2073 if (PL_op->op_flags & OPf_STACKED)
2075 else if (PL_op->op_private & OPpTARGET_MY)
2082 SvGETMAGIC(TARG); /* must come before cow check */
2084 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2085 because they make integers such as 256 "false". */
2086 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089 sv_force_normal_flags(TARG,0);
2091 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2092 && (SvREADONLY(TARG)
2093 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2094 || SvTYPE(TARG) > SVt_PVLV)
2095 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2096 Perl_croak_no_modify();
2099 orig = SvPV_nomg(TARG, len);
2100 /* note we don't (yet) force the var into being a string; if we fail
2101 * to match, we leave as-is; on successful match howeverm, we *will*
2102 * coerce into a string, then repeat the match */
2103 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2106 /* only replace once? */
2107 once = !(rpm->op_pmflags & PMf_GLOBAL);
2109 /* See "how taint works" above */
2112 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2113 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2114 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2115 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2116 ? SUBST_TAINT_BOOLRET : 0));
2122 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2124 strend = orig + len;
2125 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2126 maxiters = 2 * slen + 10; /* We can match twice at each
2127 position, once with zero-length,
2128 second time with non-zero. */
2130 if (!RX_PRELEN(rx) && PL_curpm
2131 && !ReANY(rx)->mother_re) {
2136 #ifdef PERL_SAWAMPERSAND
2137 r_flags = ( RX_NPARENS(rx)
2139 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2140 || (rpm->op_pmflags & PMf_KEEPCOPY)
2145 r_flags = REXEC_COPY_STR;
2148 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2151 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2152 LEAVE_SCOPE(oldsave);
2157 /* known replacement string? */
2159 /* replacement needing upgrading? */
2160 if (DO_UTF8(TARG) && !doutf8) {
2161 nsv = sv_newmortal();
2164 sv_recode_to_utf8(nsv, PL_encoding);
2166 sv_utf8_upgrade(nsv);
2167 c = SvPV_const(nsv, clen);
2171 c = SvPV_const(dstr, clen);
2172 doutf8 = DO_UTF8(dstr);
2175 if (SvTAINTED(dstr))
2176 rxtainted |= SUBST_TAINT_REPL;
2183 /* can do inplace substitution? */
2188 && (I32)clen <= RX_MINLENRET(rx)
2190 || !(r_flags & REXEC_COPY_STR)
2191 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2193 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2194 && (!doutf8 || SvUTF8(TARG))
2195 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2199 if (SvIsCOW(TARG)) {
2200 if (!force_on_match)
2202 assert(SvVOK(TARG));
2205 if (force_on_match) {
2206 /* redo the first match, this time with the orig var
2207 * forced into being a string */
2209 orig = SvPV_force_nomg(TARG, len);
2215 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2216 rxtainted |= SUBST_TAINT_PAT;
2217 m = orig + RX_OFFS(rx)[0].start;
2218 d = orig + RX_OFFS(rx)[0].end;
2220 if (m - s > strend - d) { /* faster to shorten from end */
2223 Copy(c, m, clen, char);
2228 Move(d, m, i, char);
2232 SvCUR_set(TARG, m - s);
2234 else { /* faster from front */
2238 Move(s, d - i, i, char);
2241 Copy(c, d, clen, char);
2248 d = s = RX_OFFS(rx)[0].start + orig;
2251 if (UNLIKELY(iters++ > maxiters))
2252 DIE(aTHX_ "Substitution loop");
2253 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2254 rxtainted |= SUBST_TAINT_PAT;
2255 m = RX_OFFS(rx)[0].start + orig;
2258 Move(s, d, i, char);
2262 Copy(c, d, clen, char);
2265 s = RX_OFFS(rx)[0].end + orig;
2266 } while (CALLREGEXEC(rx, s, strend, orig,
2267 s == m, /* don't match same null twice */
2269 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2272 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2273 Move(s, d, i+1, char); /* include the NUL */
2283 if (force_on_match) {
2284 /* redo the first match, this time with the orig var
2285 * forced into being a string */
2287 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2288 /* I feel that it should be possible to avoid this mortal copy
2289 given that the code below copies into a new destination.
2290 However, I suspect it isn't worth the complexity of
2291 unravelling the C<goto force_it> for the small number of
2292 cases where it would be viable to drop into the copy code. */
2293 TARG = sv_2mortal(newSVsv(TARG));
2295 orig = SvPV_force_nomg(TARG, len);
2301 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2302 rxtainted |= SUBST_TAINT_PAT;
2304 s = RX_OFFS(rx)[0].start + orig;
2305 dstr = newSVpvn_flags(orig, s-orig,
2306 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2311 /* note that a whole bunch of local vars are saved here for
2312 * use by pp_substcont: here's a list of them in case you're
2313 * searching for places in this sub that uses a particular var:
2314 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2315 * s m strend rx once */
2317 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2321 if (UNLIKELY(iters++ > maxiters))
2322 DIE(aTHX_ "Substitution loop");
2323 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2324 rxtainted |= SUBST_TAINT_PAT;
2325 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2327 char *old_orig = orig;
2328 assert(RX_SUBOFFSET(rx) == 0);
2330 orig = RX_SUBBEG(rx);
2331 s = orig + (old_s - old_orig);
2332 strend = s + (strend - old_s);
2334 m = RX_OFFS(rx)[0].start + orig;
2335 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2336 s = RX_OFFS(rx)[0].end + orig;
2338 /* replacement already stringified */
2340 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2345 if (!nsv) nsv = sv_newmortal();
2346 sv_copypv(nsv, repl);
2347 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2348 sv_catsv(dstr, nsv);
2350 else sv_catsv(dstr, repl);
2351 if (UNLIKELY(SvTAINTED(repl)))
2352 rxtainted |= SUBST_TAINT_REPL;
2356 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2358 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2359 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2361 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2362 /* From here on down we're using the copy, and leaving the original
2369 /* The match may make the string COW. If so, brilliant, because
2370 that's just saved us one malloc, copy and free - the regexp has
2371 donated the old buffer, and we malloc an entirely new one, rather
2372 than the regexp malloc()ing a buffer and copying our original,
2373 only for us to throw it away here during the substitution. */
2374 if (SvIsCOW(TARG)) {
2375 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2381 SvPV_set(TARG, SvPVX(dstr));
2382 SvCUR_set(TARG, SvCUR(dstr));
2383 SvLEN_set(TARG, SvLEN(dstr));
2384 SvFLAGS(TARG) |= SvUTF8(dstr);
2385 SvPV_set(dstr, NULL);
2392 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2393 (void)SvPOK_only_UTF8(TARG);
2396 /* See "how taint works" above */
2398 if ((rxtainted & SUBST_TAINT_PAT) ||
2399 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2400 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2402 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2404 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2405 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2407 SvTAINTED_on(TOPs); /* taint return value */
2409 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2411 /* needed for mg_set below */
2413 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2417 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2419 LEAVE_SCOPE(oldsave);
2428 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2429 ++*PL_markstack_ptr;
2431 LEAVE_with_name("grep_item"); /* exit inner scope */
2434 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2436 const I32 gimme = GIMME_V;
2438 LEAVE_with_name("grep"); /* exit outer scope */
2439 (void)POPMARK; /* pop src */
2440 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2441 (void)POPMARK; /* pop dst */
2442 SP = PL_stack_base + POPMARK; /* pop original mark */
2443 if (gimme == G_SCALAR) {
2444 if (PL_op->op_private & OPpGREP_LEX) {
2445 SV* const sv = sv_newmortal();
2446 sv_setiv(sv, items);
2454 else if (gimme == G_ARRAY)
2461 ENTER_with_name("grep_item"); /* enter inner scope */
2464 src = PL_stack_base[*PL_markstack_ptr];
2465 if (SvPADTMP(src)) {
2466 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2470 if (PL_op->op_private & OPpGREP_LEX)
2471 PAD_SVl(PL_op->op_targ) = src;
2475 RETURNOP(cLOGOP->op_other);
2489 if (CxMULTICALL(&cxstack[cxstack_ix]))
2493 cxstack_ix++; /* temporarily protect top context */
2496 if (gimme == G_SCALAR) {
2498 if (LIKELY(MARK <= SP)) {
2499 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2500 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2501 && !SvMAGICAL(TOPs)) {
2502 *MARK = SvREFCNT_inc(TOPs);
2507 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2509 *MARK = sv_mortalcopy(sv);
2510 SvREFCNT_dec_NN(sv);
2513 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2514 && !SvMAGICAL(TOPs)) {
2518 *MARK = sv_mortalcopy(TOPs);
2522 *MARK = &PL_sv_undef;
2526 else if (gimme == G_ARRAY) {
2527 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2528 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2529 || SvMAGICAL(*MARK)) {
2530 *MARK = sv_mortalcopy(*MARK);
2531 TAINT_NOT; /* Each item is independent */
2538 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2540 PL_curpm = newpm; /* ... and pop $1 et al */
2543 return cx->blk_sub.retop;
2553 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2556 DIE(aTHX_ "Not a CODE reference");
2557 /* This is overwhelmingly the most common case: */
2558 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
2559 switch (SvTYPE(sv)) {
2562 if (!(cv = GvCVu((const GV *)sv))) {
2564 cv = sv_2cv(sv, &stash, &gv, 0);
2573 if(isGV_with_GP(sv)) goto we_have_a_glob;
2576 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2578 SP = PL_stack_base + POPMARK;
2586 sv = amagic_deref_call(sv, to_cv_amg);
2587 /* Don't SPAGAIN here. */
2594 DIE(aTHX_ PL_no_usym, "a subroutine");
2595 sym = SvPV_nomg_const(sv, len);
2596 if (PL_op->op_private & HINT_STRICT_REFS)
2597 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2598 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2601 cv = MUTABLE_CV(SvRV(sv));
2602 if (SvTYPE(cv) == SVt_PVCV)
2607 DIE(aTHX_ "Not a CODE reference");
2608 /* This is the second most common case: */
2610 cv = MUTABLE_CV(sv);
2618 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
2619 DIE(aTHX_ "Closure prototype called");
2620 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2624 /* anonymous or undef'd function leaves us no recourse */
2625 if (CvLEXICAL(cv) && CvHASGV(cv))
2626 DIE(aTHX_ "Undefined subroutine &%"SVf" called",
2627 SVfARG(cv_name(cv, NULL, 0)));
2628 if (CvANON(cv) || !CvHASGV(cv)) {
2629 DIE(aTHX_ "Undefined subroutine called");
2632 /* autoloaded stub? */
2633 if (cv != GvCV(gv = CvGV(cv))) {
2636 /* should call AUTOLOAD now? */
2639 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2640 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2646 sub_name = sv_newmortal();
2647 gv_efullname3(sub_name, gv, NULL);
2648 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2656 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2659 Perl_get_db_sub(aTHX_ &sv, cv);
2661 PL_curcopdb = PL_curcop;
2663 /* check for lsub that handles lvalue subroutines */
2664 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2665 /* if lsub not found then fall back to DB::sub */
2666 if (!cv) cv = GvCV(PL_DBsub);
2668 cv = GvCV(PL_DBsub);
2671 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2672 DIE(aTHX_ "No DB::sub routine defined");
2677 if (!(CvISXSUB(cv))) {
2678 /* This path taken at least 75% of the time */
2680 PADLIST * const padlist = CvPADLIST(cv);
2683 PUSHBLOCK(cx, CXt_SUB, MARK);
2685 cx->blk_sub.retop = PL_op->op_next;
2686 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
2687 PERL_STACK_OVERFLOW_CHECK();
2688 pad_push(padlist, depth);
2691 PAD_SET_CUR_NOSAVE(padlist, depth);
2692 if (LIKELY(hasargs)) {
2693 AV *const av = MUTABLE_AV(PAD_SVl(0));
2697 if (UNLIKELY(AvREAL(av))) {
2698 /* @_ is normally not REAL--this should only ever
2699 * happen when DB::sub() calls things that modify @_ */
2704 defavp = &GvAV(PL_defgv);
2705 cx->blk_sub.savearray = *defavp;
2706 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
2707 CX_CURPAD_SAVE(cx->blk_sub);
2708 cx->blk_sub.argarray = av;
2711 if (UNLIKELY(items - 1 > AvMAX(av))) {
2712 SV **ary = AvALLOC(av);
2713 AvMAX(av) = items - 1;
2714 Renew(ary, items, SV*);
2719 Copy(MARK+1,AvARRAY(av),items,SV*);
2720 AvFILLp(av) = items - 1;
2726 if (SvPADTMP(*MARK)) {
2727 *MARK = sv_mortalcopy(*MARK);
2735 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2737 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2738 /* warning must come *after* we fully set up the context
2739 * stuff so that __WARN__ handlers can safely dounwind()
2742 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
2743 && ckWARN(WARN_RECURSION)
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
2745 sub_crush_depth(cv);
2746 RETURNOP(CvSTART(cv));
2749 SSize_t markix = TOPMARK;
2754 if (UNLIKELY(((PL_op->op_private
2755 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2756 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2758 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2760 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
2761 /* Need to copy @_ to stack. Alternative may be to
2762 * switch stack to @_, and copy return values
2763 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2764 AV * const av = GvAV(PL_defgv);
2765 const SSize_t items = AvFILL(av) + 1;
2769 const bool m = cBOOL(SvRMAGICAL(av));
2770 /* Mark is at the end of the stack. */
2772 for (; i < items; ++i)
2776 SV ** const svp = av_fetch(av, i, 0);
2777 sv = svp ? *svp : NULL;
2779 else sv = AvARRAY(av)[i];
2780 if (sv) SP[i+1] = sv;
2782 SP[i+1] = newSVavdefelem(av, i, 1);
2790 SV **mark = PL_stack_base + markix;
2791 SSize_t items = SP - mark;
2794 if (*mark && SvPADTMP(*mark)) {
2795 *mark = sv_mortalcopy(*mark);
2799 /* We assume first XSUB in &DB::sub is the called one. */
2800 if (UNLIKELY(PL_curcopdb)) {
2801 SAVEVPTR(PL_curcop);
2802 PL_curcop = PL_curcopdb;
2805 /* Do we need to open block here? XXXX */
2807 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2809 CvXSUB(cv)(aTHX_ cv);
2811 /* Enforce some sanity in scalar context. */
2812 if (gimme == G_SCALAR) {
2813 SV **svp = PL_stack_base + markix + 1;
2814 if (svp != PL_stack_sp) {
2815 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2825 Perl_sub_crush_depth(pTHX_ CV *cv)
2827 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2830 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2832 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2833 SVfARG(cv_name(cv,NULL,0)));
2841 SV* const elemsv = POPs;
2842 IV elem = SvIV(elemsv);
2843 AV *const av = MUTABLE_AV(POPs);
2844 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2845 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2846 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2847 bool preeminent = TRUE;
2850 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
2851 Perl_warner(aTHX_ packWARN(WARN_MISC),
2852 "Use of reference \"%"SVf"\" as array index",
2854 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
2857 if (UNLIKELY(localizing)) {
2861 /* If we can determine whether the element exist,
2862 * Try to preserve the existenceness of a tied array
2863 * element by using EXISTS and DELETE if possible.
2864 * Fallback to FETCH and STORE otherwise. */
2865 if (SvCANEXISTDELETE(av))
2866 preeminent = av_exists(av, elem);
2869 svp = av_fetch(av, elem, lval && !defer);
2871 #ifdef PERL_MALLOC_WRAP
2872 if (SvUOK(elemsv)) {
2873 const UV uv = SvUV(elemsv);
2874 elem = uv > IV_MAX ? IV_MAX : uv;
2876 else if (SvNOK(elemsv))
2877 elem = (IV)SvNV(elemsv);
2879 static const char oom_array_extend[] =
2880 "Out of memory during array extend"; /* Duplicated in av.c */
2881 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2884 if (!svp || !*svp) {
2887 DIE(aTHX_ PL_no_aelem, elem);
2888 len = av_tindex(av);
2889 mPUSHs(newSVavdefelem(av,
2890 /* Resolve a negative index now, unless it points before the
2891 beginning of the array, in which case record it for error
2892 reporting in magic_setdefelem. */
2893 elem < 0 && len + elem >= 0 ? len + elem : elem,
2897 if (UNLIKELY(localizing)) {
2899 save_aelem(av, elem, svp);
2901 SAVEADELETE(av, elem);
2903 else if (PL_op->op_private & OPpDEREF) {
2904 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2908 sv = (svp ? *svp : &PL_sv_undef);
2909 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2916 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2918 PERL_ARGS_ASSERT_VIVIFY_REF;
2923 Perl_croak_no_modify();
2924 prepare_SV_for_RV(sv);
2927 SvRV_set(sv, newSV(0));
2930 SvRV_set(sv, MUTABLE_SV(newAV()));
2933 SvRV_set(sv, MUTABLE_SV(newHV()));
2940 if (SvGMAGICAL(sv)) {
2941 /* copy the sv without magic to prevent magic from being
2943 SV* msv = sv_newmortal();
2944 sv_setsv_nomg(msv, sv);
2953 SV* const sv = TOPs;
2956 SV* const rsv = SvRV(sv);
2957 if (SvTYPE(rsv) == SVt_PVCV) {
2963 SETs(method_common(sv, NULL));
2970 SV* const sv = cSVOP_sv;
2971 U32 hash = SvSHARED_HASH(sv);
2973 XPUSHs(method_common(sv, &hash));
2978 S_method_common(pTHX_ SV* meth, U32* hashp)
2984 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2985 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2986 "package or object reference", SVfARG(meth)),
2988 : *(PL_stack_base + TOPMARK + 1);
2990 PERL_ARGS_ASSERT_METHOD_COMMON;
2994 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2999 ob = MUTABLE_SV(SvRV(sv));
3000 else if (!SvOK(sv)) goto undefined;
3001 else if (isGV_with_GP(sv)) {
3003 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3004 "without a package or object reference",
3007 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
3008 assert(!LvTARGLEN(ob));
3012 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
3015 /* this isn't a reference */
3018 const char * const packname = SvPV_nomg_const(sv, packlen);
3019 const U32 packname_utf8 = SvUTF8(sv);
3020 stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
3021 if (stash) goto fetch;
3023 if (!(iogv = gv_fetchpvn_flags(
3024 packname, packlen, packname_utf8, SVt_PVIO
3026 !(ob=MUTABLE_SV(GvIO(iogv))))
3028 /* this isn't the name of a filehandle either */
3031 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3032 "without a package or object reference",
3035 /* assume it's a package name */
3036 stash = gv_stashpvn(packname, packlen, packname_utf8);
3037 if (!stash) packsv = sv;
3040 /* it _is_ a filehandle name -- replace with a reference */
3041 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3044 /* if we got here, ob should be an object or a glob */
3045 if (!ob || !(SvOBJECT(ob)
3046 || (isGV_with_GP(ob)
3047 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3050 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3051 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3052 ? newSVpvs_flags("DOES", SVs_TEMP)
3056 stash = SvSTASH(ob);
3059 /* NOTE: stash may be null, hope hv_fetch_ent and
3060 gv_fetchmethod can cope (it seems they can) */
3062 /* shortcut for simple names */
3064 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3066 gv = MUTABLE_GV(HeVAL(he));
3068 if (isGV(gv) && GvCV(gv) &&
3069 (!GvCVGEN(gv) || GvCVGEN(gv)
3070 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3071 return MUTABLE_SV(GvCV(gv));
3075 assert(stash || packsv);
3076 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3077 meth, GV_AUTOLOAD | GV_CROAK);
3080 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3085 * c-indentation-style: bsd
3087 * indent-tabs-mode: nil
3090 * ex: set ts=8 sts=4 sw=4 et: