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;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
73 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
76 PUSHMARK(PL_stack_sp);
87 /* no PUTBACK, SETs doesn't inc/dec SP */
94 XPUSHs(MUTABLE_SV(cGVOP_gv));
102 /* SP is not used to remove a variable that is saved across the
103 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
104 register or load/store vs direct mem ops macro is introduced, this
105 should be a define block between direct PL_stack_sp and dSP operations,
106 presently, using PL_stack_sp is bias towards CISC cpus */
107 SV * const sv = *PL_stack_sp;
111 if (PL_op->op_type == OP_AND)
113 return cLOGOP->op_other;
121 /* sassign keeps its args in the optree traditionally backwards.
122 So we pop them differently.
124 SV *left = POPs; SV *right = TOPs;
126 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
127 SV * const temp = left;
128 left = right; right = temp;
130 if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
132 if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
134 SV * const cv = SvRV(right);
135 const U32 cv_type = SvTYPE(cv);
136 const bool is_gv = isGV_with_GP(left);
137 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
143 /* Can do the optimisation if left (LVALUE) is not a typeglob,
144 right (RVALUE) is a reference to something, and we're in void
146 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
147 /* Is the target symbol table currently empty? */
148 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
149 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
150 /* Good. Create a new proxy constant subroutine in the target.
151 The gv becomes a(nother) reference to the constant. */
152 SV *const value = SvRV(cv);
154 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
155 SvPCS_IMPORTED_on(gv);
157 SvREFCNT_inc_simple_void(value);
163 /* Need to fix things up. */
165 /* Need to fix GV. */
166 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
170 /* We've been returned a constant rather than a full subroutine,
171 but they expect a subroutine reference to apply. */
173 ENTER_with_name("sassign_coderef");
174 SvREFCNT_inc_void(SvRV(cv));
175 /* newCONSTSUB takes a reference count on the passed in SV
176 from us. We set the name to NULL, otherwise we get into
177 all sorts of fun as the reference to our new sub is
178 donated to the GV that we're about to assign to.
180 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
183 LEAVE_with_name("sassign_coderef");
185 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
187 First: ops for \&{"BONK"}; return us the constant in the
189 Second: ops for *{"BONK"} cause that symbol table entry
190 (and our reference to it) to be upgraded from RV
192 Thirdly: We get here. cv is actually PVGV now, and its
193 GvCV() is actually the subroutine we're looking for
195 So change the reference so that it points to the subroutine
196 of that typeglob, as that's what they were after all along.
198 GV *const upgraded = MUTABLE_GV(cv);
199 CV *const source = GvCV(upgraded);
202 assert(CvFLAGS(source) & CVf_CONST);
204 SvREFCNT_inc_void(source);
205 SvREFCNT_dec_NN(upgraded);
206 SvRV_set(right, MUTABLE_SV(source));
212 UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
213 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
216 packWARN(WARN_MISC), "Useless assignment to a temporary"
218 SvSetMagicSV(left, right);
228 RETURNOP(cLOGOP->op_other);
230 RETURNOP(cLOGOP->op_next);
236 TAINT_NOT; /* Each statement is presumed innocent */
237 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
239 if (!(PL_op->op_flags & OPf_SPECIAL)) {
240 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
241 LEAVE_SCOPE(oldsave);
248 dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
253 const char *rpv = NULL;
255 bool rcopied = FALSE;
257 if (TARG == right && right != left) { /* $r = $l.$r */
258 rpv = SvPV_nomg_const(right, rlen);
259 rbyte = !DO_UTF8(right);
260 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
261 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
265 if (TARG != left) { /* not $l .= $r */
267 const char* const lpv = SvPV_nomg_const(left, llen);
268 lbyte = !DO_UTF8(left);
269 sv_setpvn(TARG, lpv, llen);
275 else { /* $l .= $r and left == TARG */
277 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
278 report_uninit(right);
282 SvPV_force_nomg_nolen(left);
284 lbyte = !DO_UTF8(left);
291 /* $r.$r: do magic twice: tied might return different 2nd time */
293 rpv = SvPV_nomg_const(right, rlen);
294 rbyte = !DO_UTF8(right);
296 if (lbyte != rbyte) {
297 /* sv_utf8_upgrade_nomg() may reallocate the stack */
300 sv_utf8_upgrade_nomg(TARG);
303 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
304 sv_utf8_upgrade_nomg(right);
305 rpv = SvPV_nomg_const(right, rlen);
309 sv_catpvn_nomg(TARG, rpv, rlen);
316 /* push the elements of av onto the stack.
317 * XXX Note that padav has similar code but without the mg_get().
318 * I suspect that the mg_get is no longer needed, but while padav
319 * differs, it can't share this function */
322 S_pushav(pTHX_ AV* const av)
325 const SSize_t maxarg = AvFILL(av) + 1;
327 if (UNLIKELY(SvRMAGICAL(av))) {
329 for (i=0; i < (PADOFFSET)maxarg; i++) {
330 SV ** const svp = av_fetch(av, i, FALSE);
331 /* See note in pp_helem, and bug id #27839 */
333 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
339 for (i=0; i < (PADOFFSET)maxarg; i++) {
340 SV * const sv = AvARRAY(av)[i];
341 SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
349 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
354 PADOFFSET base = PL_op->op_targ;
355 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
357 if (PL_op->op_flags & OPf_SPECIAL) {
358 /* fake the RHS of my ($x,$y,..) = @_ */
360 S_pushav(aTHX_ GvAVn(PL_defgv));
364 /* note, this is only skipped for compile-time-known void cxt */
365 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
368 for (i = 0; i <count; i++)
369 *++SP = PAD_SV(base+i);
371 if (PL_op->op_private & OPpLVAL_INTRO) {
372 SV **svp = &(PAD_SVl(base));
373 const UV payload = (UV)(
374 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
375 | (count << SAVE_TIGHT_SHIFT)
376 | SAVEt_CLEARPADRANGE);
377 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
378 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
385 for (i = 0; i <count; i++)
386 SvPADSTALE_off(*svp++); /* mark lexical as active */
397 OP * const op = PL_op;
398 /* access PL_curpad once */
399 SV ** const padentry = &(PAD_SVl(op->op_targ));
404 PUTBACK; /* no pop/push after this, TOPs ok */
406 if (op->op_flags & OPf_MOD) {
407 if (op->op_private & OPpLVAL_INTRO)
408 if (!(op->op_private & OPpPAD_STATE))
409 save_clearsv(padentry);
410 if (op->op_private & OPpDEREF) {
411 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
412 than TARG reduces the scope of TARG, so it does not
413 span the call to save_clearsv, resulting in smaller
415 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
427 tryAMAGICunTARGETlist(iter_amg, 0);
428 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
430 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
431 if (!isGV_with_GP(PL_last_in_gv)) {
432 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
433 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
436 XPUSHs(MUTABLE_SV(PL_last_in_gv));
439 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
442 return do_readline();
450 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
454 (SvIOK_notUV(left) && SvIOK_notUV(right))
455 ? (SvIVX(left) == SvIVX(right))
456 : ( do_ncmp(left, right) == 0)
465 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
466 if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
467 Perl_croak_no_modify();
468 if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
469 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
471 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
472 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
474 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
475 if (inc) sv_inc(TOPs);
488 if (PL_op->op_type == OP_OR)
490 RETURNOP(cLOGOP->op_other);
499 const int op_type = PL_op->op_type;
500 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
505 if (UNLIKELY(!sv || !SvANY(sv))) {
506 if (op_type == OP_DOR)
508 RETURNOP(cLOGOP->op_other);
514 if (UNLIKELY(!sv || !SvANY(sv)))
519 switch (SvTYPE(sv)) {
521 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
525 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
529 if (CvROOT(sv) || CvXSUB(sv))
542 if(op_type == OP_DOR)
544 RETURNOP(cLOGOP->op_other);
546 /* assuming OP_DEFINED */
554 dSP; dATARGET; bool useleft; SV *svl, *svr;
555 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
559 useleft = USE_LEFT(svl);
560 #ifdef PERL_PRESERVE_IVUV
561 /* We must see if we can perform the addition with integers if possible,
562 as the integer code detects overflow while the NV code doesn't.
563 If either argument hasn't had a numeric conversion yet attempt to get
564 the IV. It's important to do this now, rather than just assuming that
565 it's not IOK as a PV of "9223372036854775806" may not take well to NV
566 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
567 integer in case the second argument is IV=9223372036854775806
568 We can (now) rely on sv_2iv to do the right thing, only setting the
569 public IOK flag if the value in the NV (or PV) slot is truly integer.
571 A side effect is that this also aggressively prefers integer maths over
572 fp maths for integer values.
574 How to detect overflow?
576 C 99 section 6.2.6.1 says
578 The range of nonnegative values of a signed integer type is a subrange
579 of the corresponding unsigned integer type, and the representation of
580 the same value in each type is the same. A computation involving
581 unsigned operands can never overflow, because a result that cannot be
582 represented by the resulting unsigned integer type is reduced modulo
583 the number that is one greater than the largest value that can be
584 represented by the resulting type.
588 which I read as "unsigned ints wrap."
590 signed integer overflow seems to be classed as "exception condition"
592 If an exceptional condition occurs during the evaluation of an
593 expression (that is, if the result is not mathematically defined or not
594 in the range of representable values for its type), the behavior is
597 (6.5, the 5th paragraph)
599 I had assumed that on 2s complement machines signed arithmetic would
600 wrap, hence coded pp_add and pp_subtract on the assumption that
601 everything perl builds on would be happy. After much wailing and
602 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
603 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
604 unsigned code below is actually shorter than the old code. :-)
607 if (SvIV_please_nomg(svr)) {
608 /* Unless the left argument is integer in range we are going to have to
609 use NV maths. Hence only attempt to coerce the right argument if
610 we know the left is integer. */
618 /* left operand is undef, treat as zero. + 0 is identity,
619 Could SETi or SETu right now, but space optimise by not adding
620 lots of code to speed up what is probably a rarish case. */
622 /* Left operand is defined, so is it IV? */
623 if (SvIV_please_nomg(svl)) {
624 if ((auvok = SvUOK(svl)))
627 const IV aiv = SvIVX(svl);
630 auvok = 1; /* Now acting as a sign flag. */
631 } else { /* 2s complement assumption for IV_MIN */
639 bool result_good = 0;
642 bool buvok = SvUOK(svr);
647 const IV biv = SvIVX(svr);
654 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
655 else "IV" now, independent of how it came in.
656 if a, b represents positive, A, B negative, a maps to -A etc
661 all UV maths. negate result if A negative.
662 add if signs same, subtract if signs differ. */
668 /* Must get smaller */
674 /* result really should be -(auv-buv). as its negation
675 of true value, need to swap our result flag */
692 if (result <= (UV)IV_MIN)
695 /* result valid, but out of range for IV. */
700 } /* Overflow, drop through to NVs. */
705 NV value = SvNV_nomg(svr);
708 /* left operand is undef, treat as zero. + 0.0 is identity. */
712 SETn( value + SvNV_nomg(svl) );
720 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
721 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
722 const U32 lval = PL_op->op_flags & OPf_MOD;
723 SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
724 SV *sv = (svp ? *svp : &PL_sv_undef);
726 if (UNLIKELY(!svp && lval))
727 DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
730 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
740 do_join(TARG, *MARK, MARK, SP);
751 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
752 * will be enough to hold an OP*.
754 SV* const sv = sv_newmortal();
755 sv_upgrade(sv, SVt_PVLV);
757 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
760 XPUSHs(MUTABLE_SV(PL_op));
765 /* Oversized hot code. */
769 dSP; dMARK; dORIGMARK;
773 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
777 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
780 if (MARK == ORIGMARK) {
781 /* If using default handle then we need to make space to
782 * pass object as 1st arg, so move other args up ...
786 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
789 return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io),
791 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
792 | (PL_op->op_type == OP_SAY
793 ? TIED_METHOD_SAY : 0)), sp - mark);
796 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
797 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
800 SETERRNO(EBADF,RMS_IFI);
803 else if (!(fp = IoOFP(io))) {
805 report_wrongway_fh(gv, '<');
808 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
812 SV * const ofs = GvSV(PL_ofsgv); /* $, */
814 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
816 if (!do_print(*MARK, fp))
820 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
821 if (!do_print(GvSV(PL_ofsgv), fp)) {
830 if (!do_print(*MARK, fp))
838 if (PL_op->op_type == OP_SAY) {
839 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
842 else if (PL_ors_sv && SvOK(PL_ors_sv))
843 if (!do_print(PL_ors_sv, fp)) /* $\ */
846 if (IoFLAGS(io) & IOf_FLUSH)
847 if (PerlIO_flush(fp) == EOF)
857 XPUSHs(&PL_sv_undef);
864 const I32 gimme = GIMME_V;
865 static const char an_array[] = "an ARRAY";
866 static const char a_hash[] = "a HASH";
867 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
868 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
872 if (UNLIKELY(SvAMAGIC(sv))) {
873 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
876 if (UNLIKELY(SvTYPE(sv) != type))
877 /* diag_listed_as: Not an ARRAY reference */
878 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
879 else if (UNLIKELY(PL_op->op_flags & OPf_MOD
880 && PL_op->op_private & OPpLVAL_INTRO))
881 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
883 else if (UNLIKELY(SvTYPE(sv) != type)) {
886 if (!isGV_with_GP(sv)) {
887 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
895 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
896 if (PL_op->op_private & OPpLVAL_INTRO)
897 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
899 if (PL_op->op_flags & OPf_REF) {
903 else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
904 const I32 flags = is_lvalue_sub();
905 if (flags && !(flags & OPpENTERSUB_INARGS)) {
906 if (gimme != G_ARRAY)
907 goto croak_cant_return;
914 AV *const av = MUTABLE_AV(sv);
915 /* The guts of pp_rv2av, with no intending change to preserve history
916 (until such time as we get tools that can do blame annotation across
917 whitespace changes. */
918 if (gimme == G_ARRAY) {
924 else if (gimme == G_SCALAR) {
926 const SSize_t maxarg = AvFILL(av) + 1;
930 /* The guts of pp_rv2hv */
931 if (gimme == G_ARRAY) { /* array wanted */
933 return Perl_do_kv(aTHX);
935 else if ((PL_op->op_private & OPpTRUEBOOL
936 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
937 && block_gimme() == G_VOID ))
938 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
939 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
940 else if (gimme == G_SCALAR) {
942 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
949 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
950 is_pp_rv2av ? "array" : "hash");
955 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
957 PERL_ARGS_ASSERT_DO_ODDBALL;
960 if (ckWARN(WARN_MISC)) {
962 if (oddkey == firstkey &&
964 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
965 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
967 err = "Reference found where even-sized list expected";
970 err = "Odd number of elements in hash assignment";
971 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
980 SV **lastlelem = PL_stack_sp;
981 SV **lastrelem = PL_stack_base + POPMARK;
982 SV **firstrelem = PL_stack_base + POPMARK + 1;
983 SV **firstlelem = lastrelem + 1;
997 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
999 if (gimme == G_ARRAY)
1000 lval = PL_op->op_flags & OPf_MOD || LVRET;
1002 /* If there's a common identifier on both sides we have to take
1003 * special care that assigning the identifier on the left doesn't
1004 * clobber a value on the right that's used later in the list.
1005 * Don't bother if LHS is just an empty hash or array.
1008 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1010 firstlelem != lastlelem
1011 || ! ((sv = *firstlelem))
1013 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1014 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1015 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1018 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1019 for (relem = firstrelem; relem <= lastrelem; relem++) {
1020 if (LIKELY((sv = *relem))) {
1021 TAINT_NOT; /* Each item is independent */
1023 /* Dear TODO test in t/op/sort.t, I love you.
1024 (It's relying on a panic, not a "semi-panic" from newSVsv()
1025 and then an assertion failure below.) */
1026 if (UNLIKELY(SvIS_FREED(sv))) {
1027 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1030 /* Not newSVsv(), as it does not allow copy-on-write,
1031 resulting in wasteful copies. We need a second copy of
1032 a temp here, hence the SV_NOSTEAL. */
1033 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1044 while (LIKELY(lelem <= lastlelem)) {
1045 TAINT_NOT; /* Each item stands on its own, taintwise. */
1047 switch (SvTYPE(sv)) {
1049 ary = MUTABLE_AV(sv);
1050 magic = SvMAGICAL(ary) != 0;
1052 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1054 av_extend(ary, lastrelem - relem);
1056 while (relem <= lastrelem) { /* gobble up all the rest */
1059 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1061 sv_setsv_nomg(sv, *relem);
1063 didstore = av_store(ary,i++,sv);
1072 if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
1073 SvSETMAGIC(MUTABLE_SV(ary));
1076 case SVt_PVHV: { /* normal hash */
1080 SV** topelem = relem;
1081 SV **firsthashrelem = relem;
1083 hash = MUTABLE_HV(sv);
1084 magic = SvMAGICAL(hash) != 0;
1086 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1087 if (UNLIKELY(odd)) {
1088 do_oddball(lastrelem, firsthashrelem);
1089 /* we have firstlelem to reuse, it's not needed anymore
1091 *(lastrelem+1) = &PL_sv_undef;
1095 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1097 while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
1100 /* Copy the key if aassign is called in lvalue context,
1101 to avoid having the next op modify our rhs. Copy
1102 it also if it is gmagical, lest it make the
1103 hv_store_ent call below croak, leaking the value. */
1104 sv = lval || SvGMAGICAL(*relem)
1105 ? sv_mortalcopy(*relem)
1111 sv_setsv_nomg(tmpstr,*relem++); /* value */
1112 if (gimme == G_ARRAY) {
1113 if (hv_exists_ent(hash, sv, 0))
1114 /* key overwrites an existing entry */
1117 /* copy element back: possibly to an earlier
1118 * stack location if we encountered dups earlier,
1119 * possibly to a later stack location if odd */
1121 *topelem++ = tmpstr;
1124 didstore = hv_store_ent(hash,sv,tmpstr,0);
1126 if (!didstore) sv_2mortal(tmpstr);
1132 if (duplicates && gimme == G_ARRAY) {
1133 /* at this point we have removed the duplicate key/value
1134 * pairs from the stack, but the remaining values may be
1135 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1136 * the (a 2), but the stack now probably contains
1137 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1138 * obliterates the earlier key. So refresh all values. */
1139 lastrelem -= duplicates;
1140 relem = firsthashrelem;
1141 while (relem < lastrelem+odd) {
1143 he = hv_fetch_ent(hash, *relem++, 0, 0);
1144 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1147 if (odd && gimme == G_ARRAY) lastrelem++;
1151 if (SvIMMORTAL(sv)) {
1152 if (relem <= lastrelem)
1156 if (relem <= lastrelem) {
1158 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1159 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1162 packWARN(WARN_MISC),
1163 "Useless assignment to a temporary"
1165 sv_setsv(sv, *relem);
1169 sv_setsv(sv, &PL_sv_undef);
1174 if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
1175 /* Will be used to set PL_tainting below */
1176 Uid_t tmp_uid = PerlProc_getuid();
1177 Uid_t tmp_euid = PerlProc_geteuid();
1178 Gid_t tmp_gid = PerlProc_getgid();
1179 Gid_t tmp_egid = PerlProc_getegid();
1181 /* XXX $> et al currently silently ignore failures */
1182 if (PL_delaymagic & DM_UID) {
1183 #ifdef HAS_SETRESUID
1185 setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1186 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1189 # ifdef HAS_SETREUID
1191 setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1192 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
1195 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1196 PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
1197 PL_delaymagic &= ~DM_RUID;
1199 # endif /* HAS_SETRUID */
1201 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1202 PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
1203 PL_delaymagic &= ~DM_EUID;
1205 # endif /* HAS_SETEUID */
1206 if (PL_delaymagic & DM_UID) {
1207 if (PL_delaymagic_uid != PL_delaymagic_euid)
1208 DIE(aTHX_ "No setreuid available");
1209 PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
1211 # endif /* HAS_SETREUID */
1212 #endif /* HAS_SETRESUID */
1214 tmp_uid = PerlProc_getuid();
1215 tmp_euid = PerlProc_geteuid();
1217 /* XXX $> et al currently silently ignore failures */
1218 if (PL_delaymagic & DM_GID) {
1219 #ifdef HAS_SETRESGID
1221 setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1222 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1225 # ifdef HAS_SETREGID
1227 setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1228 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
1231 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1232 PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
1233 PL_delaymagic &= ~DM_RGID;
1235 # endif /* HAS_SETRGID */
1237 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1238 PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
1239 PL_delaymagic &= ~DM_EGID;
1241 # endif /* HAS_SETEGID */
1242 if (PL_delaymagic & DM_GID) {
1243 if (PL_delaymagic_gid != PL_delaymagic_egid)
1244 DIE(aTHX_ "No setregid available");
1245 PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
1247 # endif /* HAS_SETREGID */
1248 #endif /* HAS_SETRESGID */
1250 tmp_gid = PerlProc_getgid();
1251 tmp_egid = PerlProc_getegid();
1253 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1254 #ifdef NO_TAINT_SUPPORT
1255 PERL_UNUSED_VAR(tmp_uid);
1256 PERL_UNUSED_VAR(tmp_euid);
1257 PERL_UNUSED_VAR(tmp_gid);
1258 PERL_UNUSED_VAR(tmp_egid);
1263 if (gimme == G_VOID)
1264 SP = firstrelem - 1;
1265 else if (gimme == G_SCALAR) {
1268 SETi(lastrelem - firstrelem + 1);
1272 /* note that in this case *firstlelem may have been overwritten
1273 by sv_undef in the odd hash case */
1276 SP = firstrelem + (lastlelem - firstlelem);
1277 lelem = firstlelem + (relem - firstrelem);
1279 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1289 PMOP * const pm = cPMOP;
1290 REGEXP * rx = PM_GETRE(pm);
1291 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1292 SV * const rv = sv_newmortal();
1296 SvUPGRADE(rv, SVt_IV);
1297 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1298 loathe to use it here, but it seems to be the right fix. Or close.
1299 The key part appears to be that it's essential for pp_qr to return a new
1300 object (SV), which implies that there needs to be an effective way to
1301 generate a new SV from the existing SV that is pre-compiled in the
1303 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1306 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1307 if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
1308 *cvp = cv_clone(cv);
1309 SvREFCNT_dec_NN(cv);
1313 HV *const stash = gv_stashsv(pkg, GV_ADD);
1314 SvREFCNT_dec_NN(pkg);
1315 (void)sv_bless(rv, stash);
1318 if (UNLIKELY(RX_ISTAINTED(rx))) {
1320 SvTAINTED_on(SvRV(rv));
1333 SSize_t curpos = 0; /* initial pos() or current $+[0] */
1336 const char *truebase; /* Start of string */
1337 REGEXP *rx = PM_GETRE(pm);
1339 const I32 gimme = GIMME;
1341 const I32 oldsave = PL_savestack_ix;
1342 I32 had_zerolen = 0;
1345 if (PL_op->op_flags & OPf_STACKED)
1347 else if (PL_op->op_private & OPpTARGET_MY)
1354 PUTBACK; /* EVAL blocks need stack_sp. */
1355 /* Skip get-magic if this is a qr// clone, because regcomp has
1357 truebase = ReANY(rx)->mother_re
1358 ? SvPV_nomg_const(TARG, len)
1359 : SvPV_const(TARG, len);
1361 DIE(aTHX_ "panic: pp_match");
1362 strend = truebase + len;
1363 rxtainted = (RX_ISTAINTED(rx) ||
1364 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1367 /* We need to know this in case we fail out early - pos() must be reset */
1368 global = dynpm->op_pmflags & PMf_GLOBAL;
1370 /* PMdf_USED is set after a ?? matches once */
1373 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1375 pm->op_pmflags & PMf_USED
1378 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1382 /* empty pattern special-cased to use last successful pattern if
1383 possible, except for qr// */
1384 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1390 if (RX_MINLEN(rx) >= 0 && (STRLEN)RX_MINLEN(rx) > len) {
1391 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
1392 UVuf" < %"IVdf")\n",
1393 (UV)len, (IV)RX_MINLEN(rx)));
1397 /* get pos() if //g */
1399 mg = mg_find_mglob(TARG);
1400 if (mg && mg->mg_len >= 0) {
1401 curpos = MgBYTEPOS(mg, TARG, truebase, len);
1402 /* last time pos() was set, it was zero-length match */
1403 if (mg->mg_flags & MGf_MINMATCH)
1408 #ifdef PERL_SAWAMPERSAND
1411 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1412 || (dynpm->op_pmflags & PMf_KEEPCOPY)
1416 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1417 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1418 * only on the first iteration. Therefore we need to copy $' as well
1419 * as $&, to make the rest of the string available for captures in
1420 * subsequent iterations */
1421 if (! (global && gimme == G_ARRAY))
1422 r_flags |= REXEC_COPY_SKIP_POST;
1424 #ifdef PERL_SAWAMPERSAND
1425 if (dynpm->op_pmflags & PMf_KEEPCOPY)
1426 /* handle KEEPCOPY in pmop but not rx, eg $r=qr/a/; /$r/p */
1427 r_flags &= ~(REXEC_COPY_SKIP_PRE|REXEC_COPY_SKIP_POST);
1434 s = truebase + curpos;
1436 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1437 had_zerolen, TARG, NULL, r_flags))
1441 if (dynpm->op_pmflags & PMf_ONCE)
1443 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1445 dynpm->op_pmflags |= PMf_USED;
1449 RX_MATCH_TAINTED_on(rx);
1450 TAINT_IF(RX_MATCH_TAINTED(rx));
1454 if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
1456 mg = sv_magicext_mglob(TARG);
1457 MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
1458 if (RX_ZERO_LEN(rx))
1459 mg->mg_flags |= MGf_MINMATCH;
1461 mg->mg_flags &= ~MGf_MINMATCH;
1464 if ((!RX_NPARENS(rx) && !global) || gimme != G_ARRAY) {
1465 LEAVE_SCOPE(oldsave);
1469 /* push captures on stack */
1472 const I32 nparens = RX_NPARENS(rx);
1473 I32 i = (global && !nparens) ? 1 : 0;
1475 SPAGAIN; /* EVAL blocks could move the stack. */
1476 EXTEND(SP, nparens + i);
1477 EXTEND_MORTAL(nparens + i);
1478 for (i = !i; i <= nparens; i++) {
1479 PUSHs(sv_newmortal());
1480 if (LIKELY((RX_OFFS(rx)[i].start != -1)
1481 && RX_OFFS(rx)[i].end != -1 ))
1483 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1484 const char * const s = RX_OFFS(rx)[i].start + truebase;
1485 if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
1486 || len < 0 || len > strend - s))
1487 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1488 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1489 (long) i, (long) RX_OFFS(rx)[i].start,
1490 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1491 sv_setpvn(*SP, s, len);
1492 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1497 curpos = (UV)RX_OFFS(rx)[0].end;
1498 had_zerolen = RX_ZERO_LEN(rx);
1499 PUTBACK; /* EVAL blocks may use stack */
1500 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1503 LEAVE_SCOPE(oldsave);
1509 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1511 mg = mg_find_mglob(TARG);
1515 LEAVE_SCOPE(oldsave);
1516 if (gimme == G_ARRAY)
1522 Perl_do_readline(pTHX)
1524 dSP; dTARGETSTACKED;
1529 IO * const io = GvIO(PL_last_in_gv);
1530 const I32 type = PL_op->op_type;
1531 const I32 gimme = GIMME_V;
1534 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1536 Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0);
1537 if (gimme == G_SCALAR) {
1539 SvSetSV_nosteal(TARG, TOPs);
1549 if (IoFLAGS(io) & IOf_ARGV) {
1550 if (IoFLAGS(io) & IOf_START) {
1552 if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
1553 IoFLAGS(io) &= ~IOf_START;
1554 do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
1555 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1556 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1557 SvSETMAGIC(GvSV(PL_last_in_gv));
1562 fp = nextargv(PL_last_in_gv);
1563 if (!fp) { /* Note: fp != IoIFP(io) */
1564 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1567 else if (type == OP_GLOB)
1568 fp = Perl_start_glob(aTHX_ POPs, io);
1570 else if (type == OP_GLOB)
1572 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1573 report_wrongway_fh(PL_last_in_gv, '>');
1577 if ((!io || !(IoFLAGS(io) & IOf_START))
1578 && ckWARN(WARN_CLOSED)
1581 report_evil_fh(PL_last_in_gv);
1583 if (gimme == G_SCALAR) {
1584 /* undef TARG, and push that undefined value */
1585 if (type != OP_RCATLINE) {
1586 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1594 if (gimme == G_SCALAR) {
1596 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1599 if (type == OP_RCATLINE)
1600 SvPV_force_nomg_nolen(sv);
1604 else if (isGV_with_GP(sv)) {
1605 SvPV_force_nomg_nolen(sv);
1607 SvUPGRADE(sv, SVt_PV);
1608 tmplen = SvLEN(sv); /* remember if already alloced */
1609 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1610 /* try short-buffering it. Please update t/op/readline.t
1611 * if you change the growth length.
1616 if (type == OP_RCATLINE && SvOK(sv)) {
1618 SvPV_force_nomg_nolen(sv);
1624 sv = sv_2mortal(newSV(80));
1628 /* This should not be marked tainted if the fp is marked clean */
1629 #define MAYBE_TAINT_LINE(io, sv) \
1630 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1635 /* delay EOF state for a snarfed empty file */
1636 #define SNARF_EOF(gimme,rs,io,sv) \
1637 (gimme != G_SCALAR || SvCUR(sv) \
1638 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1642 if (!sv_gets(sv, fp, offset)
1644 || SNARF_EOF(gimme, PL_rs, io, sv)
1645 || PerlIO_error(fp)))
1647 PerlIO_clearerr(fp);
1648 if (IoFLAGS(io) & IOf_ARGV) {
1649 fp = nextargv(PL_last_in_gv);
1652 (void)do_close(PL_last_in_gv, FALSE);
1654 else if (type == OP_GLOB) {
1655 if (!do_close(PL_last_in_gv, FALSE)) {
1656 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1657 "glob failed (child exited with status %d%s)",
1658 (int)(STATUS_CURRENT >> 8),
1659 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1662 if (gimme == G_SCALAR) {
1663 if (type != OP_RCATLINE) {
1664 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1670 MAYBE_TAINT_LINE(io, sv);
1673 MAYBE_TAINT_LINE(io, sv);
1675 IoFLAGS(io) |= IOf_NOLINE;
1679 if (type == OP_GLOB) {
1682 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1683 char * const tmps = SvEND(sv) - 1;
1684 if (*tmps == *SvPVX_const(PL_rs)) {
1686 SvCUR_set(sv, SvCUR(sv) - 1);
1689 for (t1 = SvPVX_const(sv); *t1; t1++)
1691 if (strchr("*%?", *t1))
1693 if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1696 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1697 (void)POPs; /* Unmatched wildcard? Chuck it... */
1700 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1701 if (ckWARN(WARN_UTF8)) {
1702 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1703 const STRLEN len = SvCUR(sv) - offset;
1706 if (!is_utf8_string_loc(s, len, &f))
1707 /* Emulate :encoding(utf8) warning in the same case. */
1708 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1709 "utf8 \"\\x%02X\" does not map to Unicode",
1710 f < (U8*)SvEND(sv) ? *f : 0);
1713 if (gimme == G_ARRAY) {
1714 if (SvLEN(sv) - SvCUR(sv) > 20) {
1715 SvPV_shrink_to_cur(sv);
1717 sv = sv_2mortal(newSV(80));
1720 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1721 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1722 const STRLEN new_len
1723 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1724 SvPV_renew(sv, new_len);
1735 SV * const keysv = POPs;
1736 HV * const hv = MUTABLE_HV(POPs);
1737 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1738 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1740 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1741 bool preeminent = TRUE;
1743 if (SvTYPE(hv) != SVt_PVHV)
1750 /* If we can determine whether the element exist,
1751 * Try to preserve the existenceness of a tied hash
1752 * element by using EXISTS and DELETE if possible.
1753 * Fallback to FETCH and STORE otherwise. */
1754 if (SvCANEXISTDELETE(hv))
1755 preeminent = hv_exists_ent(hv, keysv, 0);
1758 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1759 svp = he ? &HeVAL(he) : NULL;
1761 if (!svp || !*svp || *svp == &PL_sv_undef) {
1765 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1767 lv = sv_newmortal();
1768 sv_upgrade(lv, SVt_PVLV);
1770 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1771 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1772 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1778 if (HvNAME_get(hv) && isGV(*svp))
1779 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1780 else if (preeminent)
1781 save_helem_flags(hv, keysv, svp,
1782 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1784 SAVEHDELETE(hv, keysv);
1786 else if (PL_op->op_private & OPpDEREF) {
1787 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1791 sv = (svp && *svp ? *svp : &PL_sv_undef);
1792 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1793 * was to make C<local $tied{foo} = $tied{foo}> possible.
1794 * However, it seems no longer to be needed for that purpose, and
1795 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1796 * would loop endlessly since the pos magic is getting set on the
1797 * mortal copy and lost. However, the copy has the effect of
1798 * triggering the get magic, and losing it altogether made things like
1799 * c<$tied{foo};> in void context no longer do get magic, which some
1800 * code relied on. Also, delayed triggering of magic on @+ and friends
1801 * meant the original regex may be out of scope by now. So as a
1802 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1803 * being called too many times). */
1804 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1818 cx = &cxstack[cxstack_ix];
1819 itersvp = CxITERVAR(cx);
1821 switch (CxTYPE(cx)) {
1823 case CXt_LOOP_LAZYSV: /* string increment */
1825 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1826 SV *end = cx->blk_loop.state_u.lazysv.end;
1827 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1828 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1830 const char *max = SvPV_const(end, maxlen);
1831 if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
1835 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1836 /* safe to reuse old SV */
1837 sv_setsv(oldsv, cur);
1841 /* we need a fresh SV every time so that loop body sees a
1842 * completely new SV for closures/references to work as
1844 *itersvp = newSVsv(cur);
1845 SvREFCNT_dec_NN(oldsv);
1847 if (strEQ(SvPVX_const(cur), max))
1848 sv_setiv(cur, 0); /* terminate next time */
1854 case CXt_LOOP_LAZYIV: /* integer increment */
1856 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1857 if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
1861 /* don't risk potential race */
1862 if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
1863 /* safe to reuse old SV */
1864 sv_setiv(oldsv, cur);
1868 /* we need a fresh SV every time so that loop body sees a
1869 * completely new SV for closures/references to work as they
1871 *itersvp = newSViv(cur);
1872 SvREFCNT_dec_NN(oldsv);
1875 if (UNLIKELY(cur == IV_MAX)) {
1876 /* Handle end of range at IV_MAX */
1877 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1879 ++cx->blk_loop.state_u.lazyiv.cur;
1883 case CXt_LOOP_FOR: /* iterate array */
1886 AV *av = cx->blk_loop.state_u.ary.ary;
1888 bool av_is_stack = FALSE;
1895 if (PL_op->op_private & OPpITER_REVERSED) {
1896 ix = --cx->blk_loop.state_u.ary.ix;
1897 if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
1901 ix = ++cx->blk_loop.state_u.ary.ix;
1902 if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
1906 if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
1907 SV * const * const svp = av_fetch(av, ix, FALSE);
1908 sv = svp ? *svp : NULL;
1911 sv = AvARRAY(av)[ix];
1915 if (UNLIKELY(SvIS_FREED(sv))) {
1917 Perl_croak(aTHX_ "Use of freed value in iteration");
1920 assert(!IS_PADGV(sv));
1925 SvREFCNT_inc_simple_void_NN(sv);
1928 else if (!av_is_stack) {
1929 sv = newSVavdefelem(av, ix, 0);
1936 SvREFCNT_dec(oldsv);
1941 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1947 A description of how taint works in pattern matching and substitution.
1949 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
1950 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
1952 While the pattern is being assembled/concatenated and then compiled,
1953 PL_tainted will get set (via TAINT_set) if any component of the pattern
1954 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
1955 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
1956 TAINT_get). It will also be set if any component of the pattern matches
1957 based on locale-dependent behavior.
1959 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1960 the pattern is marked as tainted. This means that subsequent usage, such
1961 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
1962 on the new pattern too.
1964 RXf_TAINTED_SEEN is used post-execution by the get magic code
1965 of $1 et al to indicate whether the returned value should be tainted.
1966 It is the responsibility of the caller of the pattern (i.e. pp_match,
1967 pp_subst etc) to set this flag for any other circumstances where $1 needs
1970 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1972 There are three possible sources of taint
1974 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1975 * the replacement string (or expression under /e)
1977 There are four destinations of taint and they are affected by the sources
1978 according to the rules below:
1980 * the return value (not including /r):
1981 tainted by the source string and pattern, but only for the
1982 number-of-iterations case; boolean returns aren't tainted;
1983 * the modified string (or modified copy under /r):
1984 tainted by the source string, pattern, and replacement strings;
1986 tainted by the pattern, and under 'use re "taint"', by the source
1988 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1989 should always be unset before executing subsequent code.
1991 The overall action of pp_subst is:
1993 * at the start, set bits in rxtainted indicating the taint status of
1994 the various sources.
1996 * After each pattern execution, update the SUBST_TAINT_PAT bit in
1997 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
1998 pattern has subsequently become tainted via locale ops.
2000 * If control is being passed to pp_substcont to execute a /e block,
2001 save rxtainted in the CXt_SUBST block, for future use by
2004 * Whenever control is being returned to perl code (either by falling
2005 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2006 use the flag bits in rxtainted to make all the appropriate types of
2007 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2008 et al will appear tainted.
2010 pp_match is just a simpler version of the above.
2026 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2027 See "how taint works" above */
2030 REGEXP *rx = PM_GETRE(pm);
2032 int force_on_match = 0;
2033 const I32 oldsave = PL_savestack_ix;
2035 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2040 /* known replacement string? */
2041 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2045 if (PL_op->op_flags & OPf_STACKED)
2047 else if (PL_op->op_private & OPpTARGET_MY)
2054 SvGETMAGIC(TARG); /* must come before cow check */
2056 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2057 because they make integers such as 256 "false". */
2058 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2061 sv_force_normal_flags(TARG,0);
2063 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2064 && (SvREADONLY(TARG)
2065 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2066 || SvTYPE(TARG) > SVt_PVLV)
2067 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2068 Perl_croak_no_modify();
2071 orig = SvPV_nomg(TARG, len);
2072 /* note we don't (yet) force the var into being a string; if we fail
2073 * to match, we leave as-is; on successful match howeverm, we *will*
2074 * coerce into a string, then repeat the match */
2075 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2078 /* only replace once? */
2079 once = !(rpm->op_pmflags & PMf_GLOBAL);
2081 /* See "how taint works" above */
2084 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2085 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2086 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2087 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2088 ? SUBST_TAINT_BOOLRET : 0));
2094 DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig);
2096 strend = orig + len;
2097 slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len;
2098 maxiters = 2 * slen + 10; /* We can match twice at each
2099 position, once with zero-length,
2100 second time with non-zero. */
2102 if (!RX_PRELEN(rx) && PL_curpm
2103 && !ReANY(rx)->mother_re) {
2108 #ifdef PERL_SAWAMPERSAND
2109 r_flags = ( RX_NPARENS(rx)
2111 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2112 || (rpm->op_pmflags & PMf_KEEPCOPY)
2117 r_flags = REXEC_COPY_STR;
2120 if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags))
2123 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2124 LEAVE_SCOPE(oldsave);
2129 /* known replacement string? */
2131 /* replacement needing upgrading? */
2132 if (DO_UTF8(TARG) && !doutf8) {
2133 nsv = sv_newmortal();
2136 sv_recode_to_utf8(nsv, PL_encoding);
2138 sv_utf8_upgrade(nsv);
2139 c = SvPV_const(nsv, clen);
2143 c = SvPV_const(dstr, clen);
2144 doutf8 = DO_UTF8(dstr);
2147 if (SvTAINTED(dstr))
2148 rxtainted |= SUBST_TAINT_REPL;
2155 /* can do inplace substitution? */
2160 && (I32)clen <= RX_MINLENRET(rx)
2162 || !(r_flags & REXEC_COPY_STR)
2163 || (!SvGMAGICAL(dstr) && !(RX_EXTFLAGS(rx) & RXf_EVAL_SEEN))
2165 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2166 && (!doutf8 || SvUTF8(TARG))
2167 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2171 if (SvIsCOW(TARG)) {
2172 if (!force_on_match)
2174 assert(SvVOK(TARG));
2177 if (force_on_match) {
2178 /* redo the first match, this time with the orig var
2179 * forced into being a string */
2181 orig = SvPV_force_nomg(TARG, len);
2187 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2188 rxtainted |= SUBST_TAINT_PAT;
2189 m = orig + RX_OFFS(rx)[0].start;
2190 d = orig + RX_OFFS(rx)[0].end;
2192 if (m - s > strend - d) { /* faster to shorten from end */
2195 Copy(c, m, clen, char);
2200 Move(d, m, i, char);
2204 SvCUR_set(TARG, m - s);
2206 else { /* faster from front */
2210 Move(s, d - i, i, char);
2213 Copy(c, d, clen, char);
2220 d = s = RX_OFFS(rx)[0].start + orig;
2223 if (UNLIKELY(iters++ > maxiters))
2224 DIE(aTHX_ "Substitution loop");
2225 if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
2226 rxtainted |= SUBST_TAINT_PAT;
2227 m = RX_OFFS(rx)[0].start + orig;
2230 Move(s, d, i, char);
2234 Copy(c, d, clen, char);
2237 s = RX_OFFS(rx)[0].end + orig;
2238 } while (CALLREGEXEC(rx, s, strend, orig,
2239 s == m, /* don't match same null twice */
2241 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2244 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2245 Move(s, d, i+1, char); /* include the NUL */
2255 if (force_on_match) {
2256 /* redo the first match, this time with the orig var
2257 * forced into being a string */
2259 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2260 /* I feel that it should be possible to avoid this mortal copy
2261 given that the code below copies into a new destination.
2262 However, I suspect it isn't worth the complexity of
2263 unravelling the C<goto force_it> for the small number of
2264 cases where it would be viable to drop into the copy code. */
2265 TARG = sv_2mortal(newSVsv(TARG));
2267 orig = SvPV_force_nomg(TARG, len);
2273 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2274 rxtainted |= SUBST_TAINT_PAT;
2276 s = RX_OFFS(rx)[0].start + orig;
2277 dstr = newSVpvn_flags(orig, s-orig,
2278 SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2283 /* note that a whole bunch of local vars are saved here for
2284 * use by pp_substcont: here's a list of them in case you're
2285 * searching for places in this sub that uses a particular var:
2286 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2287 * s m strend rx once */
2289 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2293 if (UNLIKELY(iters++ > maxiters))
2294 DIE(aTHX_ "Substitution loop");
2295 if (UNLIKELY(RX_MATCH_TAINTED(rx)))
2296 rxtainted |= SUBST_TAINT_PAT;
2297 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2299 char *old_orig = orig;
2300 assert(RX_SUBOFFSET(rx) == 0);
2302 orig = RX_SUBBEG(rx);
2303 s = orig + (old_s - old_orig);
2304 strend = s + (strend - old_s);
2306 m = RX_OFFS(rx)[0].start + orig;
2307 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2308 s = RX_OFFS(rx)[0].end + orig;
2310 /* replacement already stringified */
2312 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2317 if (!nsv) nsv = sv_newmortal();
2318 sv_copypv(nsv, repl);
2319 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2320 sv_catsv(dstr, nsv);
2322 else sv_catsv(dstr, repl);
2323 if (UNLIKELY(SvTAINTED(repl)))
2324 rxtainted |= SUBST_TAINT_REPL;
2328 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2330 REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
2331 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2333 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2334 /* From here on down we're using the copy, and leaving the original
2341 /* The match may make the string COW. If so, brilliant, because
2342 that's just saved us one malloc, copy and free - the regexp has
2343 donated the old buffer, and we malloc an entirely new one, rather
2344 than the regexp malloc()ing a buffer and copying our original,
2345 only for us to throw it away here during the substitution. */
2346 if (SvIsCOW(TARG)) {
2347 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2353 SvPV_set(TARG, SvPVX(dstr));
2354 SvCUR_set(TARG, SvCUR(dstr));
2355 SvLEN_set(TARG, SvLEN(dstr));
2356 SvFLAGS(TARG) |= SvUTF8(dstr);
2357 SvPV_set(dstr, NULL);
2364 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2365 (void)SvPOK_only_UTF8(TARG);
2368 /* See "how taint works" above */
2370 if ((rxtainted & SUBST_TAINT_PAT) ||
2371 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2372 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2374 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2376 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2377 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2379 SvTAINTED_on(TOPs); /* taint return value */
2381 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2383 /* needed for mg_set below */
2385 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2389 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2391 LEAVE_SCOPE(oldsave);
2400 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2401 ++*PL_markstack_ptr;
2403 LEAVE_with_name("grep_item"); /* exit inner scope */
2406 if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
2408 const I32 gimme = GIMME_V;
2410 LEAVE_with_name("grep"); /* exit outer scope */
2411 (void)POPMARK; /* pop src */
2412 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2413 (void)POPMARK; /* pop dst */
2414 SP = PL_stack_base + POPMARK; /* pop original mark */
2415 if (gimme == G_SCALAR) {
2416 if (PL_op->op_private & OPpGREP_LEX) {
2417 SV* const sv = sv_newmortal();
2418 sv_setiv(sv, items);
2426 else if (gimme == G_ARRAY)
2433 ENTER_with_name("grep_item"); /* enter inner scope */
2436 src = PL_stack_base[*PL_markstack_ptr];
2437 if (SvPADTMP(src)) {
2438 assert(!IS_PADGV(src));
2439 src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
2443 if (PL_op->op_private & OPpGREP_LEX)
2444 PAD_SVl(PL_op->op_targ) = src;
2448 RETURNOP(cLOGOP->op_other);
2462 if (CxMULTICALL(&cxstack[cxstack_ix]))
2466 cxstack_ix++; /* temporarily protect top context */
2469 if (gimme == G_SCALAR) {
2471 if (LIKELY(MARK <= SP)) {
2472 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2473 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2474 && !SvMAGICAL(TOPs)) {
2475 *MARK = SvREFCNT_inc(TOPs);
2480 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2482 *MARK = sv_mortalcopy(sv);
2483 SvREFCNT_dec_NN(sv);
2486 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2487 && !SvMAGICAL(TOPs)) {
2491 *MARK = sv_mortalcopy(TOPs);
2495 *MARK = &PL_sv_undef;
2499 else if (gimme == G_ARRAY) {
2500 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2501 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2502 || SvMAGICAL(*MARK)) {
2503 *MARK = sv_mortalcopy(*MARK);
2504 TAINT_NOT; /* Each item is independent */
2511 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2513 PL_curpm = newpm; /* ... and pop $1 et al */
2516 return cx->blk_sub.retop;
2526 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2529 DIE(aTHX_ "Not a CODE reference");
2530 /* This is overwhelmingly the most common case: */
2531 if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
2532 switch (SvTYPE(sv)) {
2535 if (!(cv = GvCVu((const GV *)sv))) {
2537 cv = sv_2cv(sv, &stash, &gv, 0);
2546 if(isGV_with_GP(sv)) goto we_have_a_glob;
2549 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2551 SP = PL_stack_base + POPMARK;
2559 sv = amagic_deref_call(sv, to_cv_amg);
2560 /* Don't SPAGAIN here. */
2567 DIE(aTHX_ PL_no_usym, "a subroutine");
2568 sym = SvPV_nomg_const(sv, len);
2569 if (PL_op->op_private & HINT_STRICT_REFS)
2570 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2571 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2574 cv = MUTABLE_CV(SvRV(sv));
2575 if (SvTYPE(cv) == SVt_PVCV)
2580 DIE(aTHX_ "Not a CODE reference");
2581 /* This is the second most common case: */
2583 cv = MUTABLE_CV(sv);
2591 if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
2592 DIE(aTHX_ "Closure prototype called");
2593 if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
2597 /* anonymous or undef'd function leaves us no recourse */
2598 if (CvANON(cv) || !(gv = CvGV(cv))) {
2600 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2601 HEKfARG(CvNAME_HEK(cv)));
2602 DIE(aTHX_ "Undefined subroutine called");
2605 /* autoloaded stub? */
2606 if (cv != GvCV(gv)) {
2609 /* should call AUTOLOAD now? */
2612 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2613 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2619 sub_name = sv_newmortal();
2620 gv_efullname3(sub_name, gv, NULL);
2621 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2629 if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
2632 Perl_get_db_sub(aTHX_ &sv, cv);
2634 PL_curcopdb = PL_curcop;
2636 /* check for lsub that handles lvalue subroutines */
2637 cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
2638 /* if lsub not found then fall back to DB::sub */
2639 if (!cv) cv = GvCV(PL_DBsub);
2641 cv = GvCV(PL_DBsub);
2644 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2645 DIE(aTHX_ "No DB::sub routine defined");
2650 if (!(CvISXSUB(cv))) {
2651 /* This path taken at least 75% of the time */
2653 PADLIST * const padlist = CvPADLIST(cv);
2656 PUSHBLOCK(cx, CXt_SUB, MARK);
2658 cx->blk_sub.retop = PL_op->op_next;
2659 if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
2660 PERL_STACK_OVERFLOW_CHECK();
2661 pad_push(padlist, depth);
2664 PAD_SET_CUR_NOSAVE(padlist, depth);
2665 if (LIKELY(hasargs)) {
2666 AV *const av = MUTABLE_AV(PAD_SVl(0));
2670 if (UNLIKELY(AvREAL(av))) {
2671 /* @_ is normally not REAL--this should only ever
2672 * happen when DB::sub() calls things that modify @_ */
2677 defavp = &GvAV(PL_defgv);
2678 cx->blk_sub.savearray = *defavp;
2679 *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
2680 CX_CURPAD_SAVE(cx->blk_sub);
2681 cx->blk_sub.argarray = av;
2684 if (UNLIKELY(items - 1 > AvMAX(av))) {
2685 SV **ary = AvALLOC(av);
2686 AvMAX(av) = items - 1;
2687 Renew(ary, items, SV*);
2692 Copy(MARK+1,AvARRAY(av),items,SV*);
2693 AvFILLp(av) = items - 1;
2699 if (SvPADTMP(*MARK)) {
2700 assert(!IS_PADGV(*MARK));
2701 *MARK = sv_mortalcopy(*MARK);
2709 if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2711 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2712 /* warning must come *after* we fully set up the context
2713 * stuff so that __WARN__ handlers can safely dounwind()
2716 if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
2717 && ckWARN(WARN_RECURSION)
2718 && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
2719 sub_crush_depth(cv);
2720 RETURNOP(CvSTART(cv));
2723 SSize_t markix = TOPMARK;
2728 if (UNLIKELY(((PL_op->op_private
2729 & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
2730 ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2732 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2734 if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
2735 /* Need to copy @_ to stack. Alternative may be to
2736 * switch stack to @_, and copy return values
2737 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2738 AV * const av = GvAV(PL_defgv);
2739 const SSize_t items = AvFILL(av) + 1;
2743 const bool m = cBOOL(SvRMAGICAL(av));
2744 /* Mark is at the end of the stack. */
2746 for (; i < items; ++i)
2750 SV ** const svp = av_fetch(av, i, 0);
2751 sv = svp ? *svp : NULL;
2753 else sv = AvARRAY(av)[i];
2754 if (sv) SP[i+1] = sv;
2756 SP[i+1] = newSVavdefelem(av, i, 1);
2764 SV **mark = PL_stack_base + markix;
2765 SSize_t items = SP - mark;
2768 if (*mark && SvPADTMP(*mark)) {
2769 assert(!IS_PADGV(*mark));
2770 *mark = sv_mortalcopy(*mark);
2774 /* We assume first XSUB in &DB::sub is the called one. */
2775 if (UNLIKELY(PL_curcopdb)) {
2776 SAVEVPTR(PL_curcop);
2777 PL_curcop = PL_curcopdb;
2780 /* Do we need to open block here? XXXX */
2782 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2784 CvXSUB(cv)(aTHX_ cv);
2786 /* Enforce some sanity in scalar context. */
2787 if (gimme == G_SCALAR) {
2788 SV **svp = PL_stack_base + markix + 1;
2789 if (svp != PL_stack_sp) {
2790 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
2800 Perl_sub_crush_depth(pTHX_ CV *cv)
2802 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2805 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2807 HEK *const hek = CvNAME_HEK(cv);
2810 tmpstr = sv_2mortal(newSVhek(hek));
2813 tmpstr = sv_newmortal();
2814 gv_efullname3(tmpstr, CvGV(cv), NULL);
2816 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2825 SV* const elemsv = POPs;
2826 IV elem = SvIV(elemsv);
2827 AV *const av = MUTABLE_AV(POPs);
2828 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2829 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
2830 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2831 bool preeminent = TRUE;
2834 if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
2835 Perl_warner(aTHX_ packWARN(WARN_MISC),
2836 "Use of reference \"%"SVf"\" as array index",
2838 if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
2841 if (UNLIKELY(localizing)) {
2845 /* If we can determine whether the element exist,
2846 * Try to preserve the existenceness of a tied array
2847 * element by using EXISTS and DELETE if possible.
2848 * Fallback to FETCH and STORE otherwise. */
2849 if (SvCANEXISTDELETE(av))
2850 preeminent = av_exists(av, elem);
2853 svp = av_fetch(av, elem, lval && !defer);
2855 #ifdef PERL_MALLOC_WRAP
2856 if (SvUOK(elemsv)) {
2857 const UV uv = SvUV(elemsv);
2858 elem = uv > IV_MAX ? IV_MAX : uv;
2860 else if (SvNOK(elemsv))
2861 elem = (IV)SvNV(elemsv);
2863 static const char oom_array_extend[] =
2864 "Out of memory during array extend"; /* Duplicated in av.c */
2865 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2868 if (!svp || !*svp) {
2871 DIE(aTHX_ PL_no_aelem, elem);
2872 len = av_tindex(av);
2873 mPUSHs(newSVavdefelem(av,
2874 /* Resolve a negative index now, unless it points before the
2875 beginning of the array, in which case record it for error
2876 reporting in magic_setdefelem. */
2877 elem < 0 && len + elem >= 0 ? len + elem : elem,
2881 if (UNLIKELY(localizing)) {
2883 save_aelem(av, elem, svp);
2885 SAVEADELETE(av, elem);
2887 else if (PL_op->op_private & OPpDEREF) {
2888 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2892 sv = (svp ? *svp : &PL_sv_undef);
2893 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2900 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2902 PERL_ARGS_ASSERT_VIVIFY_REF;
2907 Perl_croak_no_modify();
2908 prepare_SV_for_RV(sv);
2911 SvRV_set(sv, newSV(0));
2914 SvRV_set(sv, MUTABLE_SV(newAV()));
2917 SvRV_set(sv, MUTABLE_SV(newHV()));
2924 if (SvGMAGICAL(sv)) {
2925 /* copy the sv without magic to prevent magic from being
2927 SV* msv = sv_newmortal();
2928 sv_setsv_nomg(msv, sv);
2937 SV* const sv = TOPs;
2940 SV* const rsv = SvRV(sv);
2941 if (SvTYPE(rsv) == SVt_PVCV) {
2947 SETs(method_common(sv, NULL));
2954 SV* const sv = cSVOP_sv;
2955 U32 hash = SvSHARED_HASH(sv);
2957 XPUSHs(method_common(sv, &hash));
2962 S_method_common(pTHX_ SV* meth, U32* hashp)
2968 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2969 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2970 "package or object reference", SVfARG(meth)),
2972 : *(PL_stack_base + TOPMARK + 1);
2974 PERL_ARGS_ASSERT_METHOD_COMMON;
2978 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2983 ob = MUTABLE_SV(SvRV(sv));
2984 else if (!SvOK(sv)) goto undefined;
2985 else if (isGV_with_GP(sv)) {
2987 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
2988 "without a package or object reference",
2991 if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') {
2992 assert(!LvTARGLEN(ob));
2996 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob));
2999 /* this isn't a reference */
3002 const char * const packname = SvPV_nomg_const(sv, packlen);
3003 const bool packname_is_utf8 = !!SvUTF8(sv);
3004 const HE* const he =
3005 (const HE *)hv_common(
3006 PL_stashcache, NULL, packname, packlen,
3007 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
3011 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3012 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3013 (void*)stash, SVfARG(sv)));
3017 if (!(iogv = gv_fetchpvn_flags(
3018 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3020 !(ob=MUTABLE_SV(GvIO(iogv))))
3022 /* this isn't the name of a filehandle either */
3025 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3026 "without a package or object reference",
3029 /* assume it's a package name */
3030 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3034 SV* const ref = newSViv(PTR2IV(stash));
3035 (void)hv_store(PL_stashcache, packname,
3036 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3037 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3038 (void*)stash, SVfARG(sv)));
3042 /* it _is_ a filehandle name -- replace with a reference */
3043 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3046 /* if we got here, ob should be an object or a glob */
3047 if (!ob || !(SvOBJECT(ob)
3048 || (isGV_with_GP(ob)
3049 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3052 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3053 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3054 ? newSVpvs_flags("DOES", SVs_TEMP)
3058 stash = SvSTASH(ob);
3061 /* NOTE: stash may be null, hope hv_fetch_ent and
3062 gv_fetchmethod can cope (it seems they can) */
3064 /* shortcut for simple names */
3066 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3068 gv = MUTABLE_GV(HeVAL(he));
3070 if (isGV(gv) && GvCV(gv) &&
3071 (!GvCVGEN(gv) || GvCVGEN(gv)
3072 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3073 return MUTABLE_SV(GvCV(gv));
3077 assert(stash || packsv);
3078 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3079 meth, GV_AUTOLOAD | GV_CROAK);
3082 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3087 * c-indentation-style: bsd
3089 * indent-tabs-mode: nil
3092 * ex: set ts=8 sts=4 sw=4 et: