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
51 PL_curcop = (COP*)PL_op;
52 TAINT_NOT; /* Each statement is presumed innocent */
53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
64 if (PL_op->op_private & OPpLVAL_INTRO)
65 PUSHs(save_scalar(cGVOP_gv));
67 PUSHs(GvSVn(cGVOP_gv));
77 /* This is sometimes called directly by pp_coreargs. */
81 PUSHMARK(PL_stack_sp);
96 XPUSHs(MUTABLE_SV(cGVOP_gv));
107 if (PL_op->op_type == OP_AND)
109 RETURNOP(cLOGOP->op_other);
115 dVAR; dSP; dPOPTOPssrl;
117 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
118 SV * const temp = left;
119 left = right; right = temp;
121 if (PL_tainting && PL_tainted && !SvTAINTED(left))
123 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
124 SV * const cv = SvRV(left);
125 const U32 cv_type = SvTYPE(cv);
126 const bool is_gv = isGV_with_GP(right);
127 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
133 /* Can do the optimisation if right (LVALUE) is not a typeglob,
134 left (RVALUE) is a reference to something, and we're in void
136 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
137 /* Is the target symbol table currently empty? */
138 GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
139 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
140 /* Good. Create a new proxy constant subroutine in the target.
141 The gv becomes a(nother) reference to the constant. */
142 SV *const value = SvRV(cv);
144 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
145 SvPCS_IMPORTED_on(gv);
147 SvREFCNT_inc_simple_void(value);
153 /* Need to fix things up. */
155 /* Need to fix GV. */
156 right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
160 /* We've been returned a constant rather than a full subroutine,
161 but they expect a subroutine reference to apply. */
163 ENTER_with_name("sassign_coderef");
164 SvREFCNT_inc_void(SvRV(cv));
165 /* newCONSTSUB takes a reference count on the passed in SV
166 from us. We set the name to NULL, otherwise we get into
167 all sorts of fun as the reference to our new sub is
168 donated to the GV that we're about to assign to.
170 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
173 LEAVE_with_name("sassign_coderef");
175 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
177 First: ops for \&{"BONK"}; return us the constant in the
179 Second: ops for *{"BONK"} cause that symbol table entry
180 (and our reference to it) to be upgraded from RV
182 Thirdly: We get here. cv is actually PVGV now, and its
183 GvCV() is actually the subroutine we're looking for
185 So change the reference so that it points to the subroutine
186 of that typeglob, as that's what they were after all along.
188 GV *const upgraded = MUTABLE_GV(cv);
189 CV *const source = GvCV(upgraded);
192 assert(CvFLAGS(source) & CVf_CONST);
194 SvREFCNT_inc_void(source);
195 SvREFCNT_dec(upgraded);
196 SvRV_set(left, MUTABLE_SV(source));
202 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
203 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
206 packWARN(WARN_MISC), "Useless assignment to a temporary"
208 SvSetMagicSV(right, left);
218 RETURNOP(cLOGOP->op_other);
220 RETURNOP(cLOGOP->op_next);
227 TAINT_NOT; /* Each statement is presumed innocent */
228 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
230 if (!(PL_op->op_flags & OPf_SPECIAL)) {
231 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
239 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
244 const char *rpv = NULL;
246 bool rcopied = FALSE;
248 if (TARG == right && right != left) { /* $r = $l.$r */
249 rpv = SvPV_nomg_const(right, rlen);
250 rbyte = !DO_UTF8(right);
251 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
252 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
256 if (TARG != left) { /* not $l .= $r */
258 const char* const lpv = SvPV_nomg_const(left, llen);
259 lbyte = !DO_UTF8(left);
260 sv_setpvn(TARG, lpv, llen);
266 else { /* $l .= $r */
268 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
269 report_uninit(right);
272 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
273 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
280 /* $r.$r: do magic twice: tied might return different 2nd time */
282 rpv = SvPV_nomg_const(right, rlen);
283 rbyte = !DO_UTF8(right);
285 if (lbyte != rbyte) {
286 /* sv_utf8_upgrade_nomg() may reallocate the stack */
289 sv_utf8_upgrade_nomg(TARG);
292 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
293 sv_utf8_upgrade_nomg(right);
294 rpv = SvPV_nomg_const(right, rlen);
298 sv_catpvn_nomg(TARG, rpv, rlen);
309 if (PL_op->op_flags & OPf_MOD) {
310 if (PL_op->op_private & OPpLVAL_INTRO)
311 if (!(PL_op->op_private & OPpPAD_STATE))
312 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
313 if (PL_op->op_private & OPpDEREF) {
315 TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
328 tryAMAGICunTARGET(iter_amg, 0, 0);
329 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
331 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
332 if (!isGV_with_GP(PL_last_in_gv)) {
333 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
334 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
337 XPUSHs(MUTABLE_SV(PL_last_in_gv));
340 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
343 return do_readline();
351 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
355 (SvIOK_notUV(left) && SvIOK_notUV(right))
356 ? (SvIVX(left) == SvIVX(right))
357 : ( do_ncmp(left, right) == 0)
366 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
367 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
368 Perl_croak_no_modify(aTHX);
369 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
370 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
372 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
373 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
375 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
376 if (inc) sv_inc(TOPs);
389 if (PL_op->op_type == OP_OR)
391 RETURNOP(cLOGOP->op_other);
400 const int op_type = PL_op->op_type;
401 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
406 if (!sv || !SvANY(sv)) {
407 if (op_type == OP_DOR)
409 RETURNOP(cLOGOP->op_other);
415 if (!sv || !SvANY(sv))
420 switch (SvTYPE(sv)) {
422 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
426 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
430 if (CvROOT(sv) || CvXSUB(sv))
443 if(op_type == OP_DOR)
445 RETURNOP(cLOGOP->op_other);
447 /* assuming OP_DEFINED */
455 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
456 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
460 useleft = USE_LEFT(svl);
461 #ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
472 A side effect is that this also aggressively prefers integer maths over
473 fp maths for integer values.
475 How to detect overflow?
477 C 99 section 6.2.6.1 says
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
489 which I read as "unsigned ints wrap."
491 signed integer overflow seems to be classed as "exception condition"
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
498 (6.5, the 5th paragraph)
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
508 SvIV_please_nomg(svr);
511 /* Unless the left argument is integer in range we are going to have to
512 use NV maths. Hence only attempt to coerce the right argument if
513 we know the left is integer. */
521 /* left operand is undef, treat as zero. + 0 is identity,
522 Could SETi or SETu right now, but space optimise by not adding
523 lots of code to speed up what is probably a rarish case. */
525 /* Left operand is defined, so is it IV? */
526 SvIV_please_nomg(svl);
528 if ((auvok = SvUOK(svl)))
531 register const IV aiv = SvIVX(svl);
534 auvok = 1; /* Now acting as a sign flag. */
535 } else { /* 2s complement assumption for IV_MIN */
543 bool result_good = 0;
546 bool buvok = SvUOK(svr);
551 register const IV biv = SvIVX(svr);
558 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
559 else "IV" now, independent of how it came in.
560 if a, b represents positive, A, B negative, a maps to -A etc
565 all UV maths. negate result if A negative.
566 add if signs same, subtract if signs differ. */
572 /* Must get smaller */
578 /* result really should be -(auv-buv). as its negation
579 of true value, need to swap our result flag */
596 if (result <= (UV)IV_MIN)
599 /* result valid, but out of range for IV. */
604 } /* Overflow, drop through to NVs. */
609 NV value = SvNV_nomg(svr);
612 /* left operand is undef, treat as zero. + 0.0 is identity. */
616 SETn( value + SvNV_nomg(svl) );
624 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
625 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
626 const U32 lval = PL_op->op_flags & OPf_MOD;
627 SV** const svp = av_fetch(av, PL_op->op_private, lval);
628 SV *sv = (svp ? *svp : &PL_sv_undef);
630 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
638 dVAR; dSP; dMARK; dTARGET;
640 do_join(TARG, *MARK, MARK, SP);
651 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
652 * will be enough to hold an OP*.
654 SV* const sv = sv_newmortal();
655 sv_upgrade(sv, SVt_PVLV);
657 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
660 XPUSHs(MUTABLE_SV(PL_op));
665 /* Oversized hot code. */
669 dVAR; dSP; dMARK; dORIGMARK;
673 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
677 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
680 if (MARK == ORIGMARK) {
681 /* If using default handle then we need to make space to
682 * pass object as 1st arg, so move other args up ...
686 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
689 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
691 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
692 | (PL_op->op_type == OP_SAY
693 ? TIED_METHOD_SAY : 0)), sp - mark);
696 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
697 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
700 SETERRNO(EBADF,RMS_IFI);
703 else if (!(fp = IoOFP(io))) {
705 report_wrongway_fh(gv, '<');
708 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
712 SV * const ofs = GvSV(PL_ofsgv); /* $, */
714 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
716 if (!do_print(*MARK, fp))
720 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
721 if (!do_print(GvSV(PL_ofsgv), fp)) {
730 if (!do_print(*MARK, fp))
738 if (PL_op->op_type == OP_SAY) {
739 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
742 else if (PL_ors_sv && SvOK(PL_ors_sv))
743 if (!do_print(PL_ors_sv, fp)) /* $\ */
746 if (IoFLAGS(io) & IOf_FLUSH)
747 if (PerlIO_flush(fp) == EOF)
757 XPUSHs(&PL_sv_undef);
764 const I32 gimme = GIMME_V;
765 static const char an_array[] = "an ARRAY";
766 static const char a_hash[] = "a HASH";
767 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
768 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
773 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
776 if (SvTYPE(sv) != type)
777 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
778 if (PL_op->op_flags & OPf_REF) {
782 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
783 const I32 flags = is_lvalue_sub();
784 if (flags && !(flags & OPpENTERSUB_INARGS)) {
785 if (gimme != G_ARRAY)
786 goto croak_cant_return;
791 else if (PL_op->op_flags & OPf_MOD
792 && PL_op->op_private & OPpLVAL_INTRO)
793 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
796 if (SvTYPE(sv) == type) {
797 if (PL_op->op_flags & OPf_REF) {
802 if (gimme != G_ARRAY)
803 goto croak_cant_return;
811 if (!isGV_with_GP(sv)) {
812 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
820 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
821 if (PL_op->op_private & OPpLVAL_INTRO)
822 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
823 if (PL_op->op_flags & OPf_REF) {
827 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
828 const I32 flags = is_lvalue_sub();
829 if (flags && !(flags & OPpENTERSUB_INARGS)) {
830 if (gimme != G_ARRAY)
831 goto croak_cant_return;
840 AV *const av = MUTABLE_AV(sv);
841 /* The guts of pp_rv2av, with no intending change to preserve history
842 (until such time as we get tools that can do blame annotation across
843 whitespace changes. */
844 if (gimme == G_ARRAY) {
845 const I32 maxarg = AvFILL(av) + 1;
846 (void)POPs; /* XXXX May be optimized away? */
848 if (SvRMAGICAL(av)) {
850 for (i=0; i < (U32)maxarg; i++) {
851 SV ** const svp = av_fetch(av, i, FALSE);
852 /* See note in pp_helem, and bug id #27839 */
854 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
859 Copy(AvARRAY(av), SP+1, maxarg, SV*);
863 else if (gimme == G_SCALAR) {
865 const I32 maxarg = AvFILL(av) + 1;
869 /* The guts of pp_rv2hv */
870 if (gimme == G_ARRAY) { /* array wanted */
872 return Perl_do_kv(aTHX);
874 else if (gimme == G_SCALAR) {
876 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
884 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
885 is_pp_rv2av ? "array" : "hash");
890 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
894 PERL_ARGS_ASSERT_DO_ODDBALL;
900 if (ckWARN(WARN_MISC)) {
902 if (relem == firstrelem &&
904 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
905 SvTYPE(SvRV(*relem)) == SVt_PVHV))
907 err = "Reference found where even-sized list expected";
910 err = "Odd number of elements in hash assignment";
911 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
915 didstore = hv_store_ent(hash,*relem,tmpstr,0);
916 if (SvMAGICAL(hash)) {
917 if (SvSMAGICAL(tmpstr))
929 SV **lastlelem = PL_stack_sp;
930 SV **lastrelem = PL_stack_base + POPMARK;
931 SV **firstrelem = PL_stack_base + POPMARK + 1;
932 SV **firstlelem = lastrelem + 1;
945 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
947 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
950 /* If there's a common identifier on both sides we have to take
951 * special care that assigning the identifier on the left doesn't
952 * clobber a value on the right that's used later in the list.
953 * Don't bother if LHS is just an empty hash or array.
956 if ( (PL_op->op_private & OPpASSIGN_COMMON)
958 firstlelem != lastlelem
959 || ! ((sv = *firstlelem))
961 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
962 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
963 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
966 EXTEND_MORTAL(lastrelem - firstrelem + 1);
967 for (relem = firstrelem; relem <= lastrelem; relem++) {
969 TAINT_NOT; /* Each item is independent */
971 /* Dear TODO test in t/op/sort.t, I love you.
972 (It's relying on a panic, not a "semi-panic" from newSVsv()
973 and then an assertion failure below.) */
974 if (SvIS_FREED(sv)) {
975 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
978 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
979 and we need a second copy of a temp here. */
980 *relem = sv_2mortal(newSVsv(sv));
990 while (lelem <= lastlelem) {
991 TAINT_NOT; /* Each item stands on its own, taintwise. */
993 switch (SvTYPE(sv)) {
995 ary = MUTABLE_AV(sv);
996 magic = SvMAGICAL(ary) != 0;
998 av_extend(ary, lastrelem - relem);
1000 while (relem <= lastrelem) { /* gobble up all the rest */
1004 sv_setsv(sv, *relem);
1006 didstore = av_store(ary,i++,sv);
1015 if (PL_delaymagic & DM_ARRAY_ISA)
1016 SvSETMAGIC(MUTABLE_SV(ary));
1018 case SVt_PVHV: { /* normal hash */
1020 SV** topelem = relem;
1022 hash = MUTABLE_HV(sv);
1023 magic = SvMAGICAL(hash) != 0;
1025 firsthashrelem = relem;
1027 while (relem < lastrelem) { /* gobble up all the rest */
1029 sv = *relem ? *relem : &PL_sv_no;
1033 sv_setsv(tmpstr,*relem); /* value */
1035 if (gimme != G_VOID) {
1036 if (hv_exists_ent(hash, sv, 0))
1037 /* key overwrites an existing entry */
1040 if (gimme == G_ARRAY) {
1041 /* copy element back: possibly to an earlier
1042 * stack location if we encountered dups earlier */
1044 *topelem++ = tmpstr;
1047 didstore = hv_store_ent(hash,sv,tmpstr,0);
1049 if (SvSMAGICAL(tmpstr))
1056 if (relem == lastrelem) {
1057 do_oddball(hash, relem, firstrelem);
1063 if (SvIMMORTAL(sv)) {
1064 if (relem <= lastrelem)
1068 if (relem <= lastrelem) {
1070 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1071 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1074 packWARN(WARN_MISC),
1075 "Useless assignment to a temporary"
1077 sv_setsv(sv, *relem);
1081 sv_setsv(sv, &PL_sv_undef);
1086 if (PL_delaymagic & ~DM_DELAY) {
1087 if (PL_delaymagic & DM_UID) {
1088 #ifdef HAS_SETRESUID
1089 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1090 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1093 # ifdef HAS_SETREUID
1094 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1095 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1098 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1099 (void)setruid(PL_uid);
1100 PL_delaymagic &= ~DM_RUID;
1102 # endif /* HAS_SETRUID */
1104 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1105 (void)seteuid(PL_euid);
1106 PL_delaymagic &= ~DM_EUID;
1108 # endif /* HAS_SETEUID */
1109 if (PL_delaymagic & DM_UID) {
1110 if (PL_uid != PL_euid)
1111 DIE(aTHX_ "No setreuid available");
1112 (void)PerlProc_setuid(PL_uid);
1114 # endif /* HAS_SETREUID */
1115 #endif /* HAS_SETRESUID */
1116 PL_uid = PerlProc_getuid();
1117 PL_euid = PerlProc_geteuid();
1119 if (PL_delaymagic & DM_GID) {
1120 #ifdef HAS_SETRESGID
1121 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1122 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1125 # ifdef HAS_SETREGID
1126 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1127 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1130 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1131 (void)setrgid(PL_gid);
1132 PL_delaymagic &= ~DM_RGID;
1134 # endif /* HAS_SETRGID */
1136 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1137 (void)setegid(PL_egid);
1138 PL_delaymagic &= ~DM_EGID;
1140 # endif /* HAS_SETEGID */
1141 if (PL_delaymagic & DM_GID) {
1142 if (PL_gid != PL_egid)
1143 DIE(aTHX_ "No setregid available");
1144 (void)PerlProc_setgid(PL_gid);
1146 # endif /* HAS_SETREGID */
1147 #endif /* HAS_SETRESGID */
1148 PL_gid = PerlProc_getgid();
1149 PL_egid = PerlProc_getegid();
1151 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1155 if (gimme == G_VOID)
1156 SP = firstrelem - 1;
1157 else if (gimme == G_SCALAR) {
1160 SETi(lastrelem - firstrelem + 1 - duplicates);
1167 /* at this point we have removed the duplicate key/value
1168 * pairs from the stack, but the remaining values may be
1169 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1170 * the (a 2), but the stack now probably contains
1171 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1172 * obliterates the earlier key. So refresh all values. */
1173 lastrelem -= duplicates;
1174 relem = firsthashrelem;
1175 while (relem < lastrelem) {
1178 he = hv_fetch_ent(hash, sv, 0, 0);
1179 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1185 SP = firstrelem + (lastlelem - firstlelem);
1186 lelem = firstlelem + (relem - firstrelem);
1188 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1197 register PMOP * const pm = cPMOP;
1198 REGEXP * rx = PM_GETRE(pm);
1199 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1200 SV * const rv = sv_newmortal();
1202 SvUPGRADE(rv, SVt_IV);
1203 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1204 loathe to use it here, but it seems to be the right fix. Or close.
1205 The key part appears to be that it's essential for pp_qr to return a new
1206 object (SV), which implies that there needs to be an effective way to
1207 generate a new SV from the existing SV that is pre-compiled in the
1209 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1213 HV *const stash = gv_stashsv(pkg, GV_ADD);
1215 (void)sv_bless(rv, stash);
1218 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1220 SvTAINTED_on(SvRV(rv));
1229 register PMOP *pm = cPMOP;
1231 register const char *t;
1232 register const char *s;
1235 U8 r_flags = REXEC_CHECKED;
1236 const char *truebase; /* Start of string */
1237 register REGEXP *rx = PM_GETRE(pm);
1239 const I32 gimme = GIMME;
1242 const I32 oldsave = PL_savestack_ix;
1243 I32 update_minmatch = 1;
1244 I32 had_zerolen = 0;
1247 if (PL_op->op_flags & OPf_STACKED)
1249 else if (PL_op->op_private & OPpTARGET_MY)
1256 PUTBACK; /* EVAL blocks need stack_sp. */
1257 /* Skip get-magic if this is a qr// clone, because regcomp has
1259 s = ((struct regexp *)SvANY(rx))->mother_re
1260 ? SvPV_nomg_const(TARG, len)
1261 : SvPV_const(TARG, len);
1263 DIE(aTHX_ "panic: pp_match");
1265 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1266 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1269 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1271 /* PMdf_USED is set after a ?? matches once */
1274 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1276 pm->op_pmflags & PMf_USED
1280 if (gimme == G_ARRAY)
1287 /* empty pattern special-cased to use last successful pattern if possible */
1288 if (!RX_PRELEN(rx) && PL_curpm) {
1293 if (RX_MINLEN(rx) > (I32)len)
1298 /* XXXX What part of this is needed with true \G-support? */
1299 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1300 RX_OFFS(rx)[0].start = -1;
1301 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1302 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1303 if (mg && mg->mg_len >= 0) {
1304 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1305 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1306 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1307 r_flags |= REXEC_IGNOREPOS;
1308 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1309 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1314 update_minmatch = 0;
1318 /* XXX: comment out !global get safe $1 vars after a
1319 match, BUT be aware that this leads to dramatic slowdowns on
1320 /g matches against large strings. So far a solution to this problem
1321 appears to be quite tricky.
1322 Test for the unsafe vars are TODO for now. */
1323 if ( (!global && RX_NPARENS(rx))
1324 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1325 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1326 r_flags |= REXEC_COPY_STR;
1328 r_flags |= REXEC_SCREAM;
1331 if (global && RX_OFFS(rx)[0].start != -1) {
1332 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1333 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1335 if (update_minmatch++)
1336 minmatch = had_zerolen;
1338 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1339 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1340 /* FIXME - can PL_bostr be made const char *? */
1341 PL_bostr = (char *)truebase;
1342 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1346 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1348 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1349 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1350 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1351 && (r_flags & REXEC_SCREAM)))
1352 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1355 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1356 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1360 if (dynpm->op_pmflags & PMf_ONCE) {
1362 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1364 dynpm->op_pmflags |= PMf_USED;
1370 RX_MATCH_TAINTED_on(rx);
1371 TAINT_IF(RX_MATCH_TAINTED(rx));
1372 if (gimme == G_ARRAY) {
1373 const I32 nparens = RX_NPARENS(rx);
1374 I32 i = (global && !nparens) ? 1 : 0;
1376 SPAGAIN; /* EVAL blocks could move the stack. */
1377 EXTEND(SP, nparens + i);
1378 EXTEND_MORTAL(nparens + i);
1379 for (i = !i; i <= nparens; i++) {
1380 PUSHs(sv_newmortal());
1381 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1382 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1383 s = RX_OFFS(rx)[i].start + truebase;
1384 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1385 len < 0 || len > strend - s)
1386 DIE(aTHX_ "panic: pp_match start/end pointers");
1387 sv_setpvn(*SP, s, len);
1388 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1393 if (dynpm->op_pmflags & PMf_CONTINUE) {
1395 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1396 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398 #ifdef PERL_OLD_COPY_ON_WRITE
1400 sv_force_normal_flags(TARG, 0);
1402 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1403 &PL_vtbl_mglob, NULL, 0);
1405 if (RX_OFFS(rx)[0].start != -1) {
1406 mg->mg_len = RX_OFFS(rx)[0].end;
1407 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1408 mg->mg_flags |= MGf_MINMATCH;
1410 mg->mg_flags &= ~MGf_MINMATCH;
1413 had_zerolen = (RX_OFFS(rx)[0].start != -1
1414 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1415 == (UV)RX_OFFS(rx)[0].end));
1416 PUTBACK; /* EVAL blocks may use stack */
1417 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1422 LEAVE_SCOPE(oldsave);
1428 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1429 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1433 #ifdef PERL_OLD_COPY_ON_WRITE
1435 sv_force_normal_flags(TARG, 0);
1437 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1438 &PL_vtbl_mglob, NULL, 0);
1440 if (RX_OFFS(rx)[0].start != -1) {
1441 mg->mg_len = RX_OFFS(rx)[0].end;
1442 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1443 mg->mg_flags |= MGf_MINMATCH;
1445 mg->mg_flags &= ~MGf_MINMATCH;
1448 LEAVE_SCOPE(oldsave);
1452 yup: /* Confirmed by INTUIT */
1454 RX_MATCH_TAINTED_on(rx);
1455 TAINT_IF(RX_MATCH_TAINTED(rx));
1457 if (dynpm->op_pmflags & PMf_ONCE) {
1459 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1461 dynpm->op_pmflags |= PMf_USED;
1464 if (RX_MATCH_COPIED(rx))
1465 Safefree(RX_SUBBEG(rx));
1466 RX_MATCH_COPIED_off(rx);
1467 RX_SUBBEG(rx) = NULL;
1469 /* FIXME - should rx->subbeg be const char *? */
1470 RX_SUBBEG(rx) = (char *) truebase;
1471 RX_OFFS(rx)[0].start = s - truebase;
1472 if (RX_MATCH_UTF8(rx)) {
1473 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1474 RX_OFFS(rx)[0].end = t - truebase;
1477 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1479 RX_SUBLEN(rx) = strend - truebase;
1482 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1484 #ifdef PERL_OLD_COPY_ON_WRITE
1485 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1487 PerlIO_printf(Perl_debug_log,
1488 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1489 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1492 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1494 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1495 assert (SvPOKp(RX_SAVED_COPY(rx)));
1500 RX_SUBBEG(rx) = savepvn(t, strend - t);
1501 #ifdef PERL_OLD_COPY_ON_WRITE
1502 RX_SAVED_COPY(rx) = NULL;
1505 RX_SUBLEN(rx) = strend - t;
1506 RX_MATCH_COPIED_on(rx);
1507 off = RX_OFFS(rx)[0].start = s - t;
1508 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1510 else { /* startp/endp are used by @- @+. */
1511 RX_OFFS(rx)[0].start = s - truebase;
1512 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1514 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1516 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1517 LEAVE_SCOPE(oldsave);
1522 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1523 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1524 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1529 LEAVE_SCOPE(oldsave);
1530 if (gimme == G_ARRAY)
1536 Perl_do_readline(pTHX)
1538 dVAR; dSP; dTARGETSTACKED;
1543 register IO * const io = GvIO(PL_last_in_gv);
1544 register const I32 type = PL_op->op_type;
1545 const I32 gimme = GIMME_V;
1548 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1550 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1551 if (gimme == G_SCALAR) {
1553 SvSetSV_nosteal(TARG, TOPs);
1563 if (IoFLAGS(io) & IOf_ARGV) {
1564 if (IoFLAGS(io) & IOf_START) {
1566 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1567 IoFLAGS(io) &= ~IOf_START;
1568 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1569 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1570 SvSETMAGIC(GvSV(PL_last_in_gv));
1575 fp = nextargv(PL_last_in_gv);
1576 if (!fp) { /* Note: fp != IoIFP(io) */
1577 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1580 else if (type == OP_GLOB)
1581 fp = Perl_start_glob(aTHX_ POPs, io);
1583 else if (type == OP_GLOB)
1585 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1586 report_wrongway_fh(PL_last_in_gv, '>');
1590 if ((!io || !(IoFLAGS(io) & IOf_START))
1591 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1593 if (type == OP_GLOB)
1594 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1595 "glob failed (can't start child: %s)",
1598 report_evil_fh(PL_last_in_gv);
1600 if (gimme == G_SCALAR) {
1601 /* undef TARG, and push that undefined value */
1602 if (type != OP_RCATLINE) {
1603 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1611 if (gimme == G_SCALAR) {
1613 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1616 if (type == OP_RCATLINE)
1617 SvPV_force_nomg_nolen(sv);
1621 else if (isGV_with_GP(sv)) {
1622 SvPV_force_nomg_nolen(sv);
1624 SvUPGRADE(sv, SVt_PV);
1625 tmplen = SvLEN(sv); /* remember if already alloced */
1626 if (!tmplen && !SvREADONLY(sv)) {
1627 /* try short-buffering it. Please update t/op/readline.t
1628 * if you change the growth length.
1633 if (type == OP_RCATLINE && SvOK(sv)) {
1635 SvPV_force_nomg_nolen(sv);
1641 sv = sv_2mortal(newSV(80));
1645 /* This should not be marked tainted if the fp is marked clean */
1646 #define MAYBE_TAINT_LINE(io, sv) \
1647 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1652 /* delay EOF state for a snarfed empty file */
1653 #define SNARF_EOF(gimme,rs,io,sv) \
1654 (gimme != G_SCALAR || SvCUR(sv) \
1655 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1659 if (!sv_gets(sv, fp, offset)
1661 || SNARF_EOF(gimme, PL_rs, io, sv)
1662 || PerlIO_error(fp)))
1664 PerlIO_clearerr(fp);
1665 if (IoFLAGS(io) & IOf_ARGV) {
1666 fp = nextargv(PL_last_in_gv);
1669 (void)do_close(PL_last_in_gv, FALSE);
1671 else if (type == OP_GLOB) {
1672 if (!do_close(PL_last_in_gv, FALSE)) {
1673 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1674 "glob failed (child exited with status %d%s)",
1675 (int)(STATUS_CURRENT >> 8),
1676 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1679 if (gimme == G_SCALAR) {
1680 if (type != OP_RCATLINE) {
1681 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1687 MAYBE_TAINT_LINE(io, sv);
1690 MAYBE_TAINT_LINE(io, sv);
1692 IoFLAGS(io) |= IOf_NOLINE;
1696 if (type == OP_GLOB) {
1699 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1700 char * const tmps = SvEND(sv) - 1;
1701 if (*tmps == *SvPVX_const(PL_rs)) {
1703 SvCUR_set(sv, SvCUR(sv) - 1);
1706 for (t1 = SvPVX_const(sv); *t1; t1++)
1707 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1708 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1710 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1711 (void)POPs; /* Unmatched wildcard? Chuck it... */
1714 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1715 if (ckWARN(WARN_UTF8)) {
1716 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1717 const STRLEN len = SvCUR(sv) - offset;
1720 if (!is_utf8_string_loc(s, len, &f))
1721 /* Emulate :encoding(utf8) warning in the same case. */
1722 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1723 "utf8 \"\\x%02X\" does not map to Unicode",
1724 f < (U8*)SvEND(sv) ? *f : 0);
1727 if (gimme == G_ARRAY) {
1728 if (SvLEN(sv) - SvCUR(sv) > 20) {
1729 SvPV_shrink_to_cur(sv);
1731 sv = sv_2mortal(newSV(80));
1734 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1735 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1736 const STRLEN new_len
1737 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1738 SvPV_renew(sv, new_len);
1749 SV * const keysv = POPs;
1750 HV * const hv = MUTABLE_HV(POPs);
1751 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1752 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1754 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1755 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1756 bool preeminent = TRUE;
1758 if (SvTYPE(hv) != SVt_PVHV)
1765 /* If we can determine whether the element exist,
1766 * Try to preserve the existenceness of a tied hash
1767 * element by using EXISTS and DELETE if possible.
1768 * Fallback to FETCH and STORE otherwise. */
1769 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1770 preeminent = hv_exists_ent(hv, keysv, 0);
1773 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1774 svp = he ? &HeVAL(he) : NULL;
1776 if (!svp || *svp == &PL_sv_undef) {
1780 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1782 lv = sv_newmortal();
1783 sv_upgrade(lv, SVt_PVLV);
1785 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1786 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1787 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1793 if (HvNAME_get(hv) && isGV(*svp))
1794 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1795 else if (preeminent)
1796 save_helem_flags(hv, keysv, svp,
1797 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1799 SAVEHDELETE(hv, keysv);
1801 else if (PL_op->op_private & OPpDEREF) {
1802 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1806 sv = (svp ? *svp : &PL_sv_undef);
1807 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1808 * was to make C<local $tied{foo} = $tied{foo}> possible.
1809 * However, it seems no longer to be needed for that purpose, and
1810 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1811 * would loop endlessly since the pos magic is getting set on the
1812 * mortal copy and lost. However, the copy has the effect of
1813 * triggering the get magic, and losing it altogether made things like
1814 * c<$tied{foo};> in void context no longer do get magic, which some
1815 * code relied on. Also, delayed triggering of magic on @+ and friends
1816 * meant the original regex may be out of scope by now. So as a
1817 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1818 * being called too many times). */
1819 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1828 register PERL_CONTEXT *cx;
1831 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1832 bool av_is_stack = FALSE;
1835 cx = &cxstack[cxstack_ix];
1836 if (!CxTYPE_is_LOOP(cx))
1837 DIE(aTHX_ "panic: pp_iter");
1839 itersvp = CxITERVAR(cx);
1840 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1841 /* string increment */
1842 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1843 SV *end = cx->blk_loop.state_u.lazysv.end;
1844 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1845 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1847 const char *max = SvPV_const(end, maxlen);
1848 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1849 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1850 /* safe to reuse old SV */
1851 sv_setsv(*itersvp, cur);
1855 /* we need a fresh SV every time so that loop body sees a
1856 * completely new SV for closures/references to work as
1859 *itersvp = newSVsv(cur);
1860 SvREFCNT_dec(oldsv);
1862 if (strEQ(SvPVX_const(cur), max))
1863 sv_setiv(cur, 0); /* terminate next time */
1870 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1871 /* integer increment */
1872 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1875 /* don't risk potential race */
1876 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1877 /* safe to reuse old SV */
1878 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1882 /* we need a fresh SV every time so that loop body sees a
1883 * completely new SV for closures/references to work as they
1886 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1887 SvREFCNT_dec(oldsv);
1890 /* Handle end of range at IV_MAX */
1891 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1892 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1894 cx->blk_loop.state_u.lazyiv.cur++;
1895 cx->blk_loop.state_u.lazyiv.end++;
1902 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1903 av = cx->blk_loop.state_u.ary.ary;
1908 if (PL_op->op_private & OPpITER_REVERSED) {
1909 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1910 ? cx->blk_loop.resetsp + 1 : 0))
1913 if (SvMAGICAL(av) || AvREIFY(av)) {
1914 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1915 sv = svp ? *svp : NULL;
1918 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1922 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1926 if (SvMAGICAL(av) || AvREIFY(av)) {
1927 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1928 sv = svp ? *svp : NULL;
1931 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1935 if (sv && SvIS_FREED(sv)) {
1937 Perl_croak(aTHX_ "Use of freed value in iteration");
1942 SvREFCNT_inc_simple_void_NN(sv);
1946 if (!av_is_stack && sv == &PL_sv_undef) {
1947 SV *lv = newSV_type(SVt_PVLV);
1949 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1950 LvTARG(lv) = SvREFCNT_inc_simple(av);
1951 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1952 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1958 SvREFCNT_dec(oldsv);
1964 A description of how taint works in pattern matching and substitution.
1966 While the pattern is being assembled/concatenated and then compiled,
1967 PL_tainted will get set if any component of the pattern is tainted, e.g.
1968 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1969 is set on the pattern if PL_tainted is set.
1971 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1972 the pattern is marked as tainted. This means that subsequent usage, such
1973 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1975 During execution of a pattern, locale-variant ops such as ALNUML set the
1976 local flag RF_tainted. At the end of execution, the engine sets the
1977 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1980 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1981 of $1 et al to indicate whether the returned value should be tainted.
1982 It is the responsibility of the caller of the pattern (i.e. pp_match,
1983 pp_subst etc) to set this flag for any other circumstances where $1 needs
1986 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1988 There are three possible sources of taint
1990 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1991 * the replacement string (or expression under /e)
1993 There are four destinations of taint and they are affected by the sources
1994 according to the rules below:
1996 * the return value (not including /r):
1997 tainted by the source string and pattern, but only for the
1998 number-of-iterations case; boolean returns aren't tainted;
1999 * the modified string (or modified copy under /r):
2000 tainted by the source string, pattern, and replacement strings;
2002 tainted by the pattern, and under 'use re "taint"', by the source
2004 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2005 should always be unset before executing subsequent code.
2007 The overall action of pp_subst is:
2009 * at the start, set bits in rxtainted indicating the taint status of
2010 the various sources.
2012 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2013 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2014 pattern has subsequently become tainted via locale ops.
2016 * If control is being passed to pp_substcont to execute a /e block,
2017 save rxtainted in the CXt_SUBST block, for future use by
2020 * Whenever control is being returned to perl code (either by falling
2021 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2022 use the flag bits in rxtainted to make all the appropriate types of
2023 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2024 et al will appear tainted.
2026 pp_match is just a simpler version of the above.
2033 register PMOP *pm = cPMOP;
2045 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2046 See "how taint works" above */
2049 register REGEXP *rx = PM_GETRE(pm);
2051 int force_on_match = 0;
2052 const I32 oldsave = PL_savestack_ix;
2054 bool doutf8 = FALSE;
2055 #ifdef PERL_OLD_COPY_ON_WRITE
2059 /* known replacement string? */
2060 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2064 if (PL_op->op_flags & OPf_STACKED)
2066 else if (PL_op->op_private & OPpTARGET_MY)
2073 #ifdef PERL_OLD_COPY_ON_WRITE
2074 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2075 because they make integers such as 256 "false". */
2076 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2079 sv_force_normal_flags(TARG,0);
2081 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2082 #ifdef PERL_OLD_COPY_ON_WRITE
2085 && (SvREADONLY(TARG)
2086 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2087 || SvTYPE(TARG) > SVt_PVLV)
2088 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2089 Perl_croak_no_modify(aTHX);
2093 s = SvPV_mutable(TARG, len);
2094 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2097 /* only replace once? */
2098 once = !(rpm->op_pmflags & PMf_GLOBAL);
2100 /* See "how taint works" above */
2103 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2104 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2105 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2106 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2107 ? SUBST_TAINT_BOOLRET : 0));
2111 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2115 DIE(aTHX_ "panic: pp_subst");
2118 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2119 maxiters = 2 * slen + 10; /* We can match twice at each
2120 position, once with zero-length,
2121 second time with non-zero. */
2123 if (!RX_PRELEN(rx) && PL_curpm) {
2127 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2128 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2129 ? REXEC_COPY_STR : 0;
2131 r_flags |= REXEC_SCREAM;
2134 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2136 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2140 /* How to do it in subst? */
2141 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2143 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2144 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2145 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2146 && (r_flags & REXEC_SCREAM))))
2151 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2152 r_flags | REXEC_CHECKED))
2156 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2157 LEAVE_SCOPE(oldsave);
2161 /* known replacement string? */
2163 if (SvTAINTED(dstr))
2164 rxtainted |= SUBST_TAINT_REPL;
2166 /* Upgrade the source if the replacement is utf8 but the source is not,
2167 * but only if it matched; see
2168 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2170 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2171 char * const orig_pvx = SvPVX(TARG);
2172 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2174 /* If the lengths are the same, the pattern contains only
2175 * invariants, can keep going; otherwise, various internal markers
2176 * could be off, so redo */
2177 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2182 /* replacement needing upgrading? */
2183 if (DO_UTF8(TARG) && !doutf8) {
2184 nsv = sv_newmortal();
2187 sv_recode_to_utf8(nsv, PL_encoding);
2189 sv_utf8_upgrade(nsv);
2190 c = SvPV_const(nsv, clen);
2194 c = SvPV_const(dstr, clen);
2195 doutf8 = DO_UTF8(dstr);
2203 /* can do inplace substitution? */
2205 #ifdef PERL_OLD_COPY_ON_WRITE
2208 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2209 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2210 && (!doutf8 || SvUTF8(TARG))
2211 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2214 #ifdef PERL_OLD_COPY_ON_WRITE
2215 if (SvIsCOW(TARG)) {
2216 assert (!force_on_match);
2220 if (force_on_match) {
2222 s = SvPV_force(TARG, len);
2227 SvSCREAM_off(TARG); /* disable possible screamer */
2229 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2230 rxtainted |= SUBST_TAINT_PAT;
2231 m = orig + RX_OFFS(rx)[0].start;
2232 d = orig + RX_OFFS(rx)[0].end;
2234 if (m - s > strend - d) { /* faster to shorten from end */
2236 Copy(c, m, clen, char);
2241 Move(d, m, i, char);
2245 SvCUR_set(TARG, m - s);
2247 else if ((i = m - s)) { /* faster from front */
2250 Move(s, d - i, i, char);
2253 Copy(c, m, clen, char);
2258 Copy(c, d, clen, char);
2268 if (iters++ > maxiters)
2269 DIE(aTHX_ "Substitution loop");
2270 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2271 rxtainted |= SUBST_TAINT_PAT;
2272 m = RX_OFFS(rx)[0].start + orig;
2275 Move(s, d, i, char);
2279 Copy(c, d, clen, char);
2282 s = RX_OFFS(rx)[0].end + orig;
2283 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2285 /* don't match same null twice */
2286 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2289 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2290 Move(s, d, i+1, char); /* include the NUL */
2297 if (force_on_match) {
2299 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2300 /* I feel that it should be possible to avoid this mortal copy
2301 given that the code below copies into a new destination.
2302 However, I suspect it isn't worth the complexity of
2303 unravelling the C<goto force_it> for the small number of
2304 cases where it would be viable to drop into the copy code. */
2305 TARG = sv_2mortal(newSVsv(TARG));
2307 s = SvPV_force(TARG, len);
2310 #ifdef PERL_OLD_COPY_ON_WRITE
2313 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2314 rxtainted |= SUBST_TAINT_PAT;
2315 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2318 register PERL_CONTEXT *cx;
2320 /* note that a whole bunch of local vars are saved here for
2321 * use by pp_substcont: here's a list of them in case you're
2322 * searching for places in this sub that uses a particular var:
2323 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2324 * s m strend rx once */
2326 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2328 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2330 if (iters++ > maxiters)
2331 DIE(aTHX_ "Substitution loop");
2332 if (RX_MATCH_TAINTED(rx))
2333 rxtainted |= SUBST_TAINT_PAT;
2334 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2337 orig = RX_SUBBEG(rx);
2339 strend = s + (strend - m);
2341 m = RX_OFFS(rx)[0].start + orig;
2342 if (doutf8 && !SvUTF8(dstr))
2343 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2345 sv_catpvn(dstr, s, m-s);
2346 s = RX_OFFS(rx)[0].end + orig;
2348 sv_catpvn(dstr, c, clen);
2351 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2352 TARG, NULL, r_flags));
2353 if (doutf8 && !DO_UTF8(TARG))
2354 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2356 sv_catpvn(dstr, s, strend - s);
2358 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2359 /* From here on down we're using the copy, and leaving the original
2365 #ifdef PERL_OLD_COPY_ON_WRITE
2366 /* The match may make the string COW. If so, brilliant, because
2367 that's just saved us one malloc, copy and free - the regexp has
2368 donated the old buffer, and we malloc an entirely new one, rather
2369 than the regexp malloc()ing a buffer and copying our original,
2370 only for us to throw it away here during the substitution. */
2371 if (SvIsCOW(TARG)) {
2372 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2378 SvPV_set(TARG, SvPVX(dstr));
2379 SvCUR_set(TARG, SvCUR(dstr));
2380 SvLEN_set(TARG, SvLEN(dstr));
2381 doutf8 |= DO_UTF8(dstr);
2382 SvPV_set(dstr, NULL);
2389 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2390 (void)SvPOK_only_UTF8(TARG);
2395 /* See "how taint works" above */
2397 if ((rxtainted & SUBST_TAINT_PAT) ||
2398 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2399 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2401 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2403 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2404 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2406 SvTAINTED_on(TOPs); /* taint return value */
2408 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2410 /* needed for mg_set below */
2412 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2415 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2417 LEAVE_SCOPE(oldsave);
2426 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2427 ++*PL_markstack_ptr;
2429 LEAVE_with_name("grep_item"); /* exit inner scope */
2432 if (PL_stack_base + *PL_markstack_ptr > SP) {
2434 const I32 gimme = GIMME_V;
2436 LEAVE_with_name("grep"); /* exit outer scope */
2437 (void)POPMARK; /* pop src */
2438 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2439 (void)POPMARK; /* pop dst */
2440 SP = PL_stack_base + POPMARK; /* pop original mark */
2441 if (gimme == G_SCALAR) {
2442 if (PL_op->op_private & OPpGREP_LEX) {
2443 SV* const sv = sv_newmortal();
2444 sv_setiv(sv, items);
2452 else if (gimme == G_ARRAY)
2459 ENTER_with_name("grep_item"); /* enter inner scope */
2462 src = PL_stack_base[*PL_markstack_ptr];
2464 if (PL_op->op_private & OPpGREP_LEX)
2465 PAD_SVl(PL_op->op_targ) = src;
2469 RETURNOP(cLOGOP->op_other);
2480 register PERL_CONTEXT *cx;
2483 if (CxMULTICALL(&cxstack[cxstack_ix]))
2487 cxstack_ix++; /* temporarily protect top context */
2490 if (gimme == G_SCALAR) {
2493 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2494 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2495 *MARK = SvREFCNT_inc(TOPs);
2500 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2502 *MARK = sv_mortalcopy(sv);
2506 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2510 *MARK = sv_mortalcopy(TOPs);
2514 *MARK = &PL_sv_undef;
2518 else if (gimme == G_ARRAY) {
2519 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2520 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
2521 *MARK = sv_mortalcopy(*MARK);
2522 TAINT_NOT; /* Each item is independent */
2530 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2531 PL_curpm = newpm; /* ... and pop $1 et al */
2534 return cx->blk_sub.retop;
2542 register PERL_CONTEXT *cx;
2544 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2547 DIE(aTHX_ "Not a CODE reference");
2548 switch (SvTYPE(sv)) {
2549 /* This is overwhelming the most common case: */
2552 if (!(cv = GvCVu((const GV *)sv))) {
2554 cv = sv_2cv(sv, &stash, &gv, 0);
2563 if(isGV_with_GP(sv)) goto we_have_a_glob;
2566 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2568 SP = PL_stack_base + POPMARK;
2576 sv = amagic_deref_call(sv, to_cv_amg);
2577 /* Don't SPAGAIN here. */
2583 sym = SvPV_nomg_const(sv, len);
2585 DIE(aTHX_ PL_no_usym, "a subroutine");
2586 if (PL_op->op_private & HINT_STRICT_REFS)
2587 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2588 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2591 cv = MUTABLE_CV(SvRV(sv));
2592 if (SvTYPE(cv) == SVt_PVCV)
2597 DIE(aTHX_ "Not a CODE reference");
2598 /* This is the second most common case: */
2600 cv = MUTABLE_CV(sv);
2608 if (CvCLONE(cv) && ! CvCLONED(cv))
2609 DIE(aTHX_ "Closure prototype called");
2610 if (!CvROOT(cv) && !CvXSUB(cv)) {
2614 /* anonymous or undef'd function leaves us no recourse */
2615 if (CvANON(cv) || !(gv = CvGV(cv)))
2616 DIE(aTHX_ "Undefined subroutine called");
2618 /* autoloaded stub? */
2619 if (cv != GvCV(gv)) {
2622 /* should call AUTOLOAD now? */
2625 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2626 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2632 sub_name = sv_newmortal();
2633 gv_efullname3(sub_name, gv, NULL);
2634 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2638 DIE(aTHX_ "Not a CODE reference");
2643 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2644 Perl_get_db_sub(aTHX_ &sv, cv);
2646 PL_curcopdb = PL_curcop;
2648 /* check for lsub that handles lvalue subroutines */
2649 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2650 /* if lsub not found then fall back to DB::sub */
2651 if (!cv) cv = GvCV(PL_DBsub);
2653 cv = GvCV(PL_DBsub);
2656 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2657 DIE(aTHX_ "No DB::sub routine defined");
2660 if (!(CvISXSUB(cv))) {
2661 /* This path taken at least 75% of the time */
2663 register I32 items = SP - MARK;
2664 AV* const padlist = CvPADLIST(cv);
2665 PUSHBLOCK(cx, CXt_SUB, MARK);
2667 cx->blk_sub.retop = PL_op->op_next;
2669 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2670 * that eval'' ops within this sub know the correct lexical space.
2671 * Owing the speed considerations, we choose instead to search for
2672 * the cv using find_runcv() when calling doeval().
2674 if (CvDEPTH(cv) >= 2) {
2675 PERL_STACK_OVERFLOW_CHECK();
2676 pad_push(padlist, CvDEPTH(cv));
2679 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2681 AV *const av = MUTABLE_AV(PAD_SVl(0));
2683 /* @_ is normally not REAL--this should only ever
2684 * happen when DB::sub() calls things that modify @_ */
2689 cx->blk_sub.savearray = GvAV(PL_defgv);
2690 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2691 CX_CURPAD_SAVE(cx->blk_sub);
2692 cx->blk_sub.argarray = av;
2695 if (items > AvMAX(av) + 1) {
2696 SV **ary = AvALLOC(av);
2697 if (AvARRAY(av) != ary) {
2698 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2701 if (items > AvMAX(av) + 1) {
2702 AvMAX(av) = items - 1;
2703 Renew(ary,items,SV*);
2708 Copy(MARK,AvARRAY(av),items,SV*);
2709 AvFILLp(av) = items - 1;
2717 /* warning must come *after* we fully set up the context
2718 * stuff so that __WARN__ handlers can safely dounwind()
2721 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2722 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2723 sub_crush_depth(cv);
2724 RETURNOP(CvSTART(cv));
2727 I32 markix = TOPMARK;
2732 /* Need to copy @_ to stack. Alternative may be to
2733 * switch stack to @_, and copy return values
2734 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2735 AV * const av = GvAV(PL_defgv);
2736 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2739 /* Mark is at the end of the stack. */
2741 Copy(AvARRAY(av), SP + 1, items, SV*);
2746 /* We assume first XSUB in &DB::sub is the called one. */
2748 SAVEVPTR(PL_curcop);
2749 PL_curcop = PL_curcopdb;
2752 /* Do we need to open block here? XXXX */
2754 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2756 CvXSUB(cv)(aTHX_ cv);
2758 /* Enforce some sanity in scalar context. */
2759 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2760 if (markix > PL_stack_sp - PL_stack_base)
2761 *(PL_stack_base + markix) = &PL_sv_undef;
2763 *(PL_stack_base + markix) = *PL_stack_sp;
2764 PL_stack_sp = PL_stack_base + markix;
2772 Perl_sub_crush_depth(pTHX_ CV *cv)
2774 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2777 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2779 SV* const tmpstr = sv_newmortal();
2780 gv_efullname3(tmpstr, CvGV(cv), NULL);
2781 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2790 SV* const elemsv = POPs;
2791 IV elem = SvIV(elemsv);
2792 AV *const av = MUTABLE_AV(POPs);
2793 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2794 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2795 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2796 bool preeminent = TRUE;
2799 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2800 Perl_warner(aTHX_ packWARN(WARN_MISC),
2801 "Use of reference \"%"SVf"\" as array index",
2803 if (SvTYPE(av) != SVt_PVAV)
2810 /* If we can determine whether the element exist,
2811 * Try to preserve the existenceness of a tied array
2812 * element by using EXISTS and DELETE if possible.
2813 * Fallback to FETCH and STORE otherwise. */
2814 if (SvCANEXISTDELETE(av))
2815 preeminent = av_exists(av, elem);
2818 svp = av_fetch(av, elem, lval && !defer);
2820 #ifdef PERL_MALLOC_WRAP
2821 if (SvUOK(elemsv)) {
2822 const UV uv = SvUV(elemsv);
2823 elem = uv > IV_MAX ? IV_MAX : uv;
2825 else if (SvNOK(elemsv))
2826 elem = (IV)SvNV(elemsv);
2828 static const char oom_array_extend[] =
2829 "Out of memory during array extend"; /* Duplicated in av.c */
2830 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2833 if (!svp || *svp == &PL_sv_undef) {
2836 DIE(aTHX_ PL_no_aelem, elem);
2837 lv = sv_newmortal();
2838 sv_upgrade(lv, SVt_PVLV);
2840 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2841 LvTARG(lv) = SvREFCNT_inc_simple(av);
2842 LvTARGOFF(lv) = elem;
2849 save_aelem(av, elem, svp);
2851 SAVEADELETE(av, elem);
2853 else if (PL_op->op_private & OPpDEREF) {
2854 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2858 sv = (svp ? *svp : &PL_sv_undef);
2859 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2866 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2868 PERL_ARGS_ASSERT_VIVIFY_REF;
2873 Perl_croak_no_modify(aTHX);
2874 prepare_SV_for_RV(sv);
2877 SvRV_set(sv, newSV(0));
2880 SvRV_set(sv, MUTABLE_SV(newAV()));
2883 SvRV_set(sv, MUTABLE_SV(newHV()));
2889 if (SvGMAGICAL(sv)) {
2890 /* copy the sv without magic to prevent magic from being
2892 SV* msv = sv_newmortal();
2893 sv_setsv_nomg(msv, sv);
2902 SV* const sv = TOPs;
2905 SV* const rsv = SvRV(sv);
2906 if (SvTYPE(rsv) == SVt_PVCV) {
2912 SETs(method_common(sv, NULL));
2919 SV* const sv = cSVOP_sv;
2920 U32 hash = SvSHARED_HASH(sv);
2922 XPUSHs(method_common(sv, &hash));
2927 S_method_common(pTHX_ SV* meth, U32* hashp)
2934 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2936 PERL_ARGS_ASSERT_METHOD_COMMON;
2939 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2944 ob = MUTABLE_SV(SvRV(sv));
2948 const char * packname = NULL;
2949 bool packname_is_utf8 = FALSE;
2951 /* this isn't a reference */
2952 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2953 const HE* const he =
2954 (const HE *)hv_common_key_len(
2955 PL_stashcache, packname,
2956 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2960 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2967 !(iogv = gv_fetchpvn_flags(
2968 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2970 !(ob=MUTABLE_SV(GvIO(iogv))))
2972 /* this isn't the name of a filehandle either */
2974 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2975 ? !isIDFIRST_utf8((U8*)packname)
2976 : !isIDFIRST_L1((U8)*packname)
2979 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2981 SvOK(sv) ? "without a package or object reference"
2982 : "on an undefined value");
2984 /* assume it's a package name */
2985 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
2989 SV* const ref = newSViv(PTR2IV(stash));
2990 (void)hv_store(PL_stashcache, packname,
2991 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
2995 /* it _is_ a filehandle name -- replace with a reference */
2996 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
2999 /* if we got here, ob should be a reference or a glob */
3000 if (!ob || !(SvOBJECT(ob)
3001 || (SvTYPE(ob) == SVt_PVGV
3003 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3006 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3007 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3008 ? newSVpvs_flags("DOES", SVs_TEMP)
3012 stash = SvSTASH(ob);
3015 /* NOTE: stash may be null, hope hv_fetch_ent and
3016 gv_fetchmethod can cope (it seems they can) */
3018 /* shortcut for simple names */
3020 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3022 gv = MUTABLE_GV(HeVAL(he));
3023 if (isGV(gv) && GvCV(gv) &&
3024 (!GvCVGEN(gv) || GvCVGEN(gv)
3025 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3026 return MUTABLE_SV(GvCV(gv));
3030 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3031 meth, GV_AUTOLOAD | GV_CROAK);
3035 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3040 * c-indentation-style: bsd
3042 * indent-tabs-mode: t
3045 * ex: set ts=8 sts=4 sw=4 noet: