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);
777 if (SvTYPE(sv) != type)
778 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
779 if (PL_op->op_flags & OPf_REF) {
783 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
784 const I32 flags = is_lvalue_sub();
785 if (flags && !(flags & OPpENTERSUB_INARGS)) {
786 if (gimme != G_ARRAY)
787 goto croak_cant_return;
792 else if (PL_op->op_flags & OPf_MOD
793 && PL_op->op_private & OPpLVAL_INTRO)
794 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
797 if (SvTYPE(sv) == type) {
798 if (PL_op->op_flags & OPf_REF) {
803 if (gimme != G_ARRAY)
804 goto croak_cant_return;
812 if (!isGV_with_GP(sv)) {
813 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
821 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
822 if (PL_op->op_private & OPpLVAL_INTRO)
823 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
824 if (PL_op->op_flags & OPf_REF) {
828 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
829 const I32 flags = is_lvalue_sub();
830 if (flags && !(flags & OPpENTERSUB_INARGS)) {
831 if (gimme != G_ARRAY)
832 goto croak_cant_return;
841 AV *const av = MUTABLE_AV(sv);
842 /* The guts of pp_rv2av, with no intending change to preserve history
843 (until such time as we get tools that can do blame annotation across
844 whitespace changes. */
845 if (gimme == G_ARRAY) {
846 const I32 maxarg = AvFILL(av) + 1;
847 (void)POPs; /* XXXX May be optimized away? */
849 if (SvRMAGICAL(av)) {
851 for (i=0; i < (U32)maxarg; i++) {
852 SV ** const svp = av_fetch(av, i, FALSE);
853 /* See note in pp_helem, and bug id #27839 */
855 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
860 Copy(AvARRAY(av), SP+1, maxarg, SV*);
864 else if (gimme == G_SCALAR) {
866 const I32 maxarg = AvFILL(av) + 1;
870 /* The guts of pp_rv2hv */
871 if (gimme == G_ARRAY) { /* array wanted */
873 return Perl_do_kv(aTHX);
875 else if (gimme == G_SCALAR) {
877 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
885 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
886 is_pp_rv2av ? "array" : "hash");
891 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
895 PERL_ARGS_ASSERT_DO_ODDBALL;
901 if (ckWARN(WARN_MISC)) {
903 if (relem == firstrelem &&
905 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
906 SvTYPE(SvRV(*relem)) == SVt_PVHV))
908 err = "Reference found where even-sized list expected";
911 err = "Odd number of elements in hash assignment";
912 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
916 didstore = hv_store_ent(hash,*relem,tmpstr,0);
917 if (SvMAGICAL(hash)) {
918 if (SvSMAGICAL(tmpstr))
930 SV **lastlelem = PL_stack_sp;
931 SV **lastrelem = PL_stack_base + POPMARK;
932 SV **firstrelem = PL_stack_base + POPMARK + 1;
933 SV **firstlelem = lastrelem + 1;
946 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
948 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
951 /* If there's a common identifier on both sides we have to take
952 * special care that assigning the identifier on the left doesn't
953 * clobber a value on the right that's used later in the list.
954 * Don't bother if LHS is just an empty hash or array.
957 if ( (PL_op->op_private & OPpASSIGN_COMMON)
959 firstlelem != lastlelem
960 || ! ((sv = *firstlelem))
962 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
963 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
964 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
967 EXTEND_MORTAL(lastrelem - firstrelem + 1);
968 for (relem = firstrelem; relem <= lastrelem; relem++) {
970 TAINT_NOT; /* Each item is independent */
972 /* Dear TODO test in t/op/sort.t, I love you.
973 (It's relying on a panic, not a "semi-panic" from newSVsv()
974 and then an assertion failure below.) */
975 if (SvIS_FREED(sv)) {
976 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
979 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
980 and we need a second copy of a temp here. */
981 *relem = sv_2mortal(newSVsv(sv));
991 while (lelem <= lastlelem) {
992 TAINT_NOT; /* Each item stands on its own, taintwise. */
994 switch (SvTYPE(sv)) {
996 ary = MUTABLE_AV(sv);
997 magic = SvMAGICAL(ary) != 0;
999 av_extend(ary, lastrelem - relem);
1001 while (relem <= lastrelem) { /* gobble up all the rest */
1005 sv_setsv(sv, *relem);
1007 didstore = av_store(ary,i++,sv);
1016 if (PL_delaymagic & DM_ARRAY_ISA)
1017 SvSETMAGIC(MUTABLE_SV(ary));
1019 case SVt_PVHV: { /* normal hash */
1021 SV** topelem = relem;
1023 hash = MUTABLE_HV(sv);
1024 magic = SvMAGICAL(hash) != 0;
1026 firsthashrelem = relem;
1028 while (relem < lastrelem) { /* gobble up all the rest */
1030 sv = *relem ? *relem : &PL_sv_no;
1034 sv_setsv(tmpstr,*relem); /* value */
1036 if (gimme != G_VOID) {
1037 if (hv_exists_ent(hash, sv, 0))
1038 /* key overwrites an existing entry */
1041 if (gimme == G_ARRAY) {
1042 /* copy element back: possibly to an earlier
1043 * stack location if we encountered dups earlier */
1045 *topelem++ = tmpstr;
1048 didstore = hv_store_ent(hash,sv,tmpstr,0);
1050 if (SvSMAGICAL(tmpstr))
1057 if (relem == lastrelem) {
1058 do_oddball(hash, relem, firstrelem);
1064 if (SvIMMORTAL(sv)) {
1065 if (relem <= lastrelem)
1069 if (relem <= lastrelem) {
1071 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1072 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1075 packWARN(WARN_MISC),
1076 "Useless assignment to a temporary"
1078 sv_setsv(sv, *relem);
1082 sv_setsv(sv, &PL_sv_undef);
1087 if (PL_delaymagic & ~DM_DELAY) {
1088 if (PL_delaymagic & DM_UID) {
1089 #ifdef HAS_SETRESUID
1090 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1091 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1094 # ifdef HAS_SETREUID
1095 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1096 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1099 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1100 (void)setruid(PL_uid);
1101 PL_delaymagic &= ~DM_RUID;
1103 # endif /* HAS_SETRUID */
1105 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1106 (void)seteuid(PL_euid);
1107 PL_delaymagic &= ~DM_EUID;
1109 # endif /* HAS_SETEUID */
1110 if (PL_delaymagic & DM_UID) {
1111 if (PL_uid != PL_euid)
1112 DIE(aTHX_ "No setreuid available");
1113 (void)PerlProc_setuid(PL_uid);
1115 # endif /* HAS_SETREUID */
1116 #endif /* HAS_SETRESUID */
1117 PL_uid = PerlProc_getuid();
1118 PL_euid = PerlProc_geteuid();
1120 if (PL_delaymagic & DM_GID) {
1121 #ifdef HAS_SETRESGID
1122 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1123 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1126 # ifdef HAS_SETREGID
1127 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1128 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1131 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1132 (void)setrgid(PL_gid);
1133 PL_delaymagic &= ~DM_RGID;
1135 # endif /* HAS_SETRGID */
1137 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1138 (void)setegid(PL_egid);
1139 PL_delaymagic &= ~DM_EGID;
1141 # endif /* HAS_SETEGID */
1142 if (PL_delaymagic & DM_GID) {
1143 if (PL_gid != PL_egid)
1144 DIE(aTHX_ "No setregid available");
1145 (void)PerlProc_setgid(PL_gid);
1147 # endif /* HAS_SETREGID */
1148 #endif /* HAS_SETRESGID */
1149 PL_gid = PerlProc_getgid();
1150 PL_egid = PerlProc_getegid();
1152 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1156 if (gimme == G_VOID)
1157 SP = firstrelem - 1;
1158 else if (gimme == G_SCALAR) {
1161 SETi(lastrelem - firstrelem + 1 - duplicates);
1168 /* at this point we have removed the duplicate key/value
1169 * pairs from the stack, but the remaining values may be
1170 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1171 * the (a 2), but the stack now probably contains
1172 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1173 * obliterates the earlier key. So refresh all values. */
1174 lastrelem -= duplicates;
1175 relem = firsthashrelem;
1176 while (relem < lastrelem) {
1179 he = hv_fetch_ent(hash, sv, 0, 0);
1180 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1186 SP = firstrelem + (lastlelem - firstlelem);
1187 lelem = firstlelem + (relem - firstrelem);
1189 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1198 register PMOP * const pm = cPMOP;
1199 REGEXP * rx = PM_GETRE(pm);
1200 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1201 SV * const rv = sv_newmortal();
1203 SvUPGRADE(rv, SVt_IV);
1204 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1205 loathe to use it here, but it seems to be the right fix. Or close.
1206 The key part appears to be that it's essential for pp_qr to return a new
1207 object (SV), which implies that there needs to be an effective way to
1208 generate a new SV from the existing SV that is pre-compiled in the
1210 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1214 HV *const stash = gv_stashsv(pkg, GV_ADD);
1216 (void)sv_bless(rv, stash);
1219 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1221 SvTAINTED_on(SvRV(rv));
1230 register PMOP *pm = cPMOP;
1232 register const char *t;
1233 register const char *s;
1236 U8 r_flags = REXEC_CHECKED;
1237 const char *truebase; /* Start of string */
1238 register REGEXP *rx = PM_GETRE(pm);
1240 const I32 gimme = GIMME;
1243 const I32 oldsave = PL_savestack_ix;
1244 I32 update_minmatch = 1;
1245 I32 had_zerolen = 0;
1248 if (PL_op->op_flags & OPf_STACKED)
1250 else if (PL_op->op_private & OPpTARGET_MY)
1257 PUTBACK; /* EVAL blocks need stack_sp. */
1258 /* Skip get-magic if this is a qr// clone, because regcomp has
1260 s = ((struct regexp *)SvANY(rx))->mother_re
1261 ? SvPV_nomg_const(TARG, len)
1262 : SvPV_const(TARG, len);
1264 DIE(aTHX_ "panic: pp_match");
1266 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1267 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1270 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1272 /* PMdf_USED is set after a ?? matches once */
1275 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1277 pm->op_pmflags & PMf_USED
1281 if (gimme == G_ARRAY)
1288 /* empty pattern special-cased to use last successful pattern if possible */
1289 if (!RX_PRELEN(rx) && PL_curpm) {
1294 if (RX_MINLEN(rx) > (I32)len)
1299 /* XXXX What part of this is needed with true \G-support? */
1300 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1301 RX_OFFS(rx)[0].start = -1;
1302 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1303 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1304 if (mg && mg->mg_len >= 0) {
1305 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1306 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1307 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1308 r_flags |= REXEC_IGNOREPOS;
1309 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1310 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1313 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1314 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1315 update_minmatch = 0;
1319 /* XXX: comment out !global get safe $1 vars after a
1320 match, BUT be aware that this leads to dramatic slowdowns on
1321 /g matches against large strings. So far a solution to this problem
1322 appears to be quite tricky.
1323 Test for the unsafe vars are TODO for now. */
1324 if ( (!global && RX_NPARENS(rx))
1325 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1326 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1327 r_flags |= REXEC_COPY_STR;
1329 r_flags |= REXEC_SCREAM;
1332 if (global && RX_OFFS(rx)[0].start != -1) {
1333 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1334 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1336 if (update_minmatch++)
1337 minmatch = had_zerolen;
1339 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1340 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1341 /* FIXME - can PL_bostr be made const char *? */
1342 PL_bostr = (char *)truebase;
1343 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1347 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1349 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1350 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1351 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1352 && (r_flags & REXEC_SCREAM)))
1353 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1356 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1357 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1361 if (dynpm->op_pmflags & PMf_ONCE) {
1363 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1365 dynpm->op_pmflags |= PMf_USED;
1371 RX_MATCH_TAINTED_on(rx);
1372 TAINT_IF(RX_MATCH_TAINTED(rx));
1373 if (gimme == G_ARRAY) {
1374 const I32 nparens = RX_NPARENS(rx);
1375 I32 i = (global && !nparens) ? 1 : 0;
1377 SPAGAIN; /* EVAL blocks could move the stack. */
1378 EXTEND(SP, nparens + i);
1379 EXTEND_MORTAL(nparens + i);
1380 for (i = !i; i <= nparens; i++) {
1381 PUSHs(sv_newmortal());
1382 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1383 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1384 s = RX_OFFS(rx)[i].start + truebase;
1385 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1386 len < 0 || len > strend - s)
1387 DIE(aTHX_ "panic: pp_match start/end pointers");
1388 sv_setpvn(*SP, s, len);
1389 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1394 if (dynpm->op_pmflags & PMf_CONTINUE) {
1396 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1397 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1399 #ifdef PERL_OLD_COPY_ON_WRITE
1401 sv_force_normal_flags(TARG, 0);
1403 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1404 &PL_vtbl_mglob, NULL, 0);
1406 if (RX_OFFS(rx)[0].start != -1) {
1407 mg->mg_len = RX_OFFS(rx)[0].end;
1408 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1409 mg->mg_flags |= MGf_MINMATCH;
1411 mg->mg_flags &= ~MGf_MINMATCH;
1414 had_zerolen = (RX_OFFS(rx)[0].start != -1
1415 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1416 == (UV)RX_OFFS(rx)[0].end));
1417 PUTBACK; /* EVAL blocks may use stack */
1418 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1423 LEAVE_SCOPE(oldsave);
1429 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1430 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1434 #ifdef PERL_OLD_COPY_ON_WRITE
1436 sv_force_normal_flags(TARG, 0);
1438 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1439 &PL_vtbl_mglob, NULL, 0);
1441 if (RX_OFFS(rx)[0].start != -1) {
1442 mg->mg_len = RX_OFFS(rx)[0].end;
1443 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1444 mg->mg_flags |= MGf_MINMATCH;
1446 mg->mg_flags &= ~MGf_MINMATCH;
1449 LEAVE_SCOPE(oldsave);
1453 yup: /* Confirmed by INTUIT */
1455 RX_MATCH_TAINTED_on(rx);
1456 TAINT_IF(RX_MATCH_TAINTED(rx));
1458 if (dynpm->op_pmflags & PMf_ONCE) {
1460 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1462 dynpm->op_pmflags |= PMf_USED;
1465 if (RX_MATCH_COPIED(rx))
1466 Safefree(RX_SUBBEG(rx));
1467 RX_MATCH_COPIED_off(rx);
1468 RX_SUBBEG(rx) = NULL;
1470 /* FIXME - should rx->subbeg be const char *? */
1471 RX_SUBBEG(rx) = (char *) truebase;
1472 RX_OFFS(rx)[0].start = s - truebase;
1473 if (RX_MATCH_UTF8(rx)) {
1474 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1475 RX_OFFS(rx)[0].end = t - truebase;
1478 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1480 RX_SUBLEN(rx) = strend - truebase;
1483 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1485 #ifdef PERL_OLD_COPY_ON_WRITE
1486 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1488 PerlIO_printf(Perl_debug_log,
1489 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1490 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1493 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1495 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1496 assert (SvPOKp(RX_SAVED_COPY(rx)));
1501 RX_SUBBEG(rx) = savepvn(t, strend - t);
1502 #ifdef PERL_OLD_COPY_ON_WRITE
1503 RX_SAVED_COPY(rx) = NULL;
1506 RX_SUBLEN(rx) = strend - t;
1507 RX_MATCH_COPIED_on(rx);
1508 off = RX_OFFS(rx)[0].start = s - t;
1509 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1511 else { /* startp/endp are used by @- @+. */
1512 RX_OFFS(rx)[0].start = s - truebase;
1513 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1515 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1517 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1518 LEAVE_SCOPE(oldsave);
1523 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1524 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1525 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1530 LEAVE_SCOPE(oldsave);
1531 if (gimme == G_ARRAY)
1537 Perl_do_readline(pTHX)
1539 dVAR; dSP; dTARGETSTACKED;
1544 register IO * const io = GvIO(PL_last_in_gv);
1545 register const I32 type = PL_op->op_type;
1546 const I32 gimme = GIMME_V;
1549 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1551 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1552 if (gimme == G_SCALAR) {
1554 SvSetSV_nosteal(TARG, TOPs);
1564 if (IoFLAGS(io) & IOf_ARGV) {
1565 if (IoFLAGS(io) & IOf_START) {
1567 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1568 IoFLAGS(io) &= ~IOf_START;
1569 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1570 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1571 SvSETMAGIC(GvSV(PL_last_in_gv));
1576 fp = nextargv(PL_last_in_gv);
1577 if (!fp) { /* Note: fp != IoIFP(io) */
1578 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1581 else if (type == OP_GLOB)
1582 fp = Perl_start_glob(aTHX_ POPs, io);
1584 else if (type == OP_GLOB)
1586 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1587 report_wrongway_fh(PL_last_in_gv, '>');
1591 if ((!io || !(IoFLAGS(io) & IOf_START))
1592 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1594 if (type == OP_GLOB)
1595 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1596 "glob failed (can't start child: %s)",
1599 report_evil_fh(PL_last_in_gv);
1601 if (gimme == G_SCALAR) {
1602 /* undef TARG, and push that undefined value */
1603 if (type != OP_RCATLINE) {
1604 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1612 if (gimme == G_SCALAR) {
1614 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1617 if (type == OP_RCATLINE)
1618 SvPV_force_nolen(sv);
1622 else if (isGV_with_GP(sv)) {
1623 SvPV_force_nolen(sv);
1625 SvUPGRADE(sv, SVt_PV);
1626 tmplen = SvLEN(sv); /* remember if already alloced */
1627 if (!tmplen && !SvREADONLY(sv)) {
1628 /* try short-buffering it. Please update t/op/readline.t
1629 * if you change the growth length.
1634 if (type == OP_RCATLINE && SvOK(sv)) {
1636 SvPV_force_nolen(sv);
1642 sv = sv_2mortal(newSV(80));
1646 /* This should not be marked tainted if the fp is marked clean */
1647 #define MAYBE_TAINT_LINE(io, sv) \
1648 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1653 /* delay EOF state for a snarfed empty file */
1654 #define SNARF_EOF(gimme,rs,io,sv) \
1655 (gimme != G_SCALAR || SvCUR(sv) \
1656 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1660 if (!sv_gets(sv, fp, offset)
1662 || SNARF_EOF(gimme, PL_rs, io, sv)
1663 || PerlIO_error(fp)))
1665 PerlIO_clearerr(fp);
1666 if (IoFLAGS(io) & IOf_ARGV) {
1667 fp = nextargv(PL_last_in_gv);
1670 (void)do_close(PL_last_in_gv, FALSE);
1672 else if (type == OP_GLOB) {
1673 if (!do_close(PL_last_in_gv, FALSE)) {
1674 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1675 "glob failed (child exited with status %d%s)",
1676 (int)(STATUS_CURRENT >> 8),
1677 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1680 if (gimme == G_SCALAR) {
1681 if (type != OP_RCATLINE) {
1682 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1688 MAYBE_TAINT_LINE(io, sv);
1691 MAYBE_TAINT_LINE(io, sv);
1693 IoFLAGS(io) |= IOf_NOLINE;
1697 if (type == OP_GLOB) {
1700 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1701 char * const tmps = SvEND(sv) - 1;
1702 if (*tmps == *SvPVX_const(PL_rs)) {
1704 SvCUR_set(sv, SvCUR(sv) - 1);
1707 for (t1 = SvPVX_const(sv); *t1; t1++)
1708 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1709 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1711 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1712 (void)POPs; /* Unmatched wildcard? Chuck it... */
1715 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1716 if (ckWARN(WARN_UTF8)) {
1717 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1718 const STRLEN len = SvCUR(sv) - offset;
1721 if (!is_utf8_string_loc(s, len, &f))
1722 /* Emulate :encoding(utf8) warning in the same case. */
1723 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1724 "utf8 \"\\x%02X\" does not map to Unicode",
1725 f < (U8*)SvEND(sv) ? *f : 0);
1728 if (gimme == G_ARRAY) {
1729 if (SvLEN(sv) - SvCUR(sv) > 20) {
1730 SvPV_shrink_to_cur(sv);
1732 sv = sv_2mortal(newSV(80));
1735 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1736 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1737 const STRLEN new_len
1738 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1739 SvPV_renew(sv, new_len);
1750 SV * const keysv = POPs;
1751 HV * const hv = MUTABLE_HV(POPs);
1752 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1753 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1755 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1756 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1757 bool preeminent = TRUE;
1759 if (SvTYPE(hv) != SVt_PVHV)
1766 /* If we can determine whether the element exist,
1767 * Try to preserve the existenceness of a tied hash
1768 * element by using EXISTS and DELETE if possible.
1769 * Fallback to FETCH and STORE otherwise. */
1770 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1771 preeminent = hv_exists_ent(hv, keysv, 0);
1774 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1775 svp = he ? &HeVAL(he) : NULL;
1777 if (!svp || *svp == &PL_sv_undef) {
1781 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1783 lv = sv_newmortal();
1784 sv_upgrade(lv, SVt_PVLV);
1786 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1787 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1788 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1794 if (HvNAME_get(hv) && isGV(*svp))
1795 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1796 else if (preeminent)
1797 save_helem_flags(hv, keysv, svp,
1798 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1800 SAVEHDELETE(hv, keysv);
1802 else if (PL_op->op_private & OPpDEREF) {
1803 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1807 sv = (svp ? *svp : &PL_sv_undef);
1808 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1809 * was to make C<local $tied{foo} = $tied{foo}> possible.
1810 * However, it seems no longer to be needed for that purpose, and
1811 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1812 * would loop endlessly since the pos magic is getting set on the
1813 * mortal copy and lost. However, the copy has the effect of
1814 * triggering the get magic, and losing it altogether made things like
1815 * c<$tied{foo};> in void context no longer do get magic, which some
1816 * code relied on. Also, delayed triggering of magic on @+ and friends
1817 * meant the original regex may be out of scope by now. So as a
1818 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1819 * being called too many times). */
1820 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1829 register PERL_CONTEXT *cx;
1832 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1833 bool av_is_stack = FALSE;
1836 cx = &cxstack[cxstack_ix];
1837 if (!CxTYPE_is_LOOP(cx))
1838 DIE(aTHX_ "panic: pp_iter");
1840 itersvp = CxITERVAR(cx);
1841 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1842 /* string increment */
1843 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1844 SV *end = cx->blk_loop.state_u.lazysv.end;
1845 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1846 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1848 const char *max = SvPV_const(end, maxlen);
1849 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1850 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1851 /* safe to reuse old SV */
1852 sv_setsv(*itersvp, cur);
1856 /* we need a fresh SV every time so that loop body sees a
1857 * completely new SV for closures/references to work as
1860 *itersvp = newSVsv(cur);
1861 SvREFCNT_dec(oldsv);
1863 if (strEQ(SvPVX_const(cur), max))
1864 sv_setiv(cur, 0); /* terminate next time */
1871 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1872 /* integer increment */
1873 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1876 /* don't risk potential race */
1877 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1878 /* safe to reuse old SV */
1879 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1883 /* we need a fresh SV every time so that loop body sees a
1884 * completely new SV for closures/references to work as they
1887 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1888 SvREFCNT_dec(oldsv);
1891 /* Handle end of range at IV_MAX */
1892 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1893 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1895 cx->blk_loop.state_u.lazyiv.cur++;
1896 cx->blk_loop.state_u.lazyiv.end++;
1903 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1904 av = cx->blk_loop.state_u.ary.ary;
1909 if (PL_op->op_private & OPpITER_REVERSED) {
1910 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1911 ? cx->blk_loop.resetsp + 1 : 0))
1914 if (SvMAGICAL(av) || AvREIFY(av)) {
1915 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1916 sv = svp ? *svp : NULL;
1919 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1923 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1927 if (SvMAGICAL(av) || AvREIFY(av)) {
1928 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1929 sv = svp ? *svp : NULL;
1932 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1936 if (sv && SvIS_FREED(sv)) {
1938 Perl_croak(aTHX_ "Use of freed value in iteration");
1943 SvREFCNT_inc_simple_void_NN(sv);
1947 if (!av_is_stack && sv == &PL_sv_undef) {
1948 SV *lv = newSV_type(SVt_PVLV);
1950 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1951 LvTARG(lv) = SvREFCNT_inc_simple(av);
1952 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1953 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1959 SvREFCNT_dec(oldsv);
1965 A description of how taint works in pattern matching and substitution.
1967 While the pattern is being assembled/concatenated and them compiled,
1968 PL_tainted will get set if any component of the pattern is tainted, e.g.
1969 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1970 is set on the pattern if PL_tainted is set.
1972 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1973 the pattern is marked as tainted. This means that subsequent usage, such
1974 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1976 During execution of a pattern, locale-variant ops such as ALNUML set the
1977 local flag RF_tainted. At the end of execution, the engine sets the
1978 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1981 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1982 of $1 et al to indicate whether the returned value should be tainted.
1983 It is the responsibility of the caller of the pattern (i.e. pp_match,
1984 pp_subst etc) to set this flag for any other circumstances where $1 needs
1987 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1989 There are three possible sources of taint
1991 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1992 * the replacement string (or expression under /e)
1994 There are four destinations of taint and they are affected by the sources
1995 according to the rules below:
1997 * the return value (not including /r):
1998 tainted by the source string and pattern, but only for the
1999 number-of-iterations case; boolean returns aren't tainted;
2000 * the modified string (or modified copy under /r):
2001 tainted by the source string, pattern, and replacement strings;
2003 tainted by the pattern, and under 'use re "taint"', by the source
2005 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2006 should always be unset before executing subsequent code.
2008 The overall action of pp_subst is:
2010 * at the start, set bits in rxtainted indicating the taint status of
2011 the various sources.
2013 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2014 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2015 pattern has subsequently become tainted via locale ops.
2017 * If control is being passed to pp_substcont to execute a /e block,
2018 save rxtainted in the CXt_SUBST block, for future use by
2021 * Whenever control is being returned to perl code (either by falling
2022 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2023 use the flag bits in rxtainted to make all the appropriate types of
2024 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2025 et al will appear tainted.
2027 pp_match is just a simpler version of the above.
2034 register PMOP *pm = cPMOP;
2046 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2047 See "how taint works" above */
2050 register REGEXP *rx = PM_GETRE(pm);
2052 int force_on_match = 0;
2053 const I32 oldsave = PL_savestack_ix;
2055 bool doutf8 = FALSE;
2056 #ifdef PERL_OLD_COPY_ON_WRITE
2060 /* known replacement string? */
2061 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2065 if (PL_op->op_flags & OPf_STACKED)
2067 else if (PL_op->op_private & OPpTARGET_MY)
2074 #ifdef PERL_OLD_COPY_ON_WRITE
2075 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2076 because they make integers such as 256 "false". */
2077 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2080 sv_force_normal_flags(TARG,0);
2082 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2083 #ifdef PERL_OLD_COPY_ON_WRITE
2086 && (SvREADONLY(TARG)
2087 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2088 || SvTYPE(TARG) > SVt_PVLV)
2089 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2090 Perl_croak_no_modify(aTHX);
2094 s = SvPV_mutable(TARG, len);
2095 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2098 /* only replace once? */
2099 once = !(rpm->op_pmflags & PMf_GLOBAL);
2101 /* See "how taint works" above */
2104 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2105 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2106 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2107 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2108 ? SUBST_TAINT_BOOLRET : 0));
2112 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2116 DIE(aTHX_ "panic: pp_subst");
2119 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2120 maxiters = 2 * slen + 10; /* We can match twice at each
2121 position, once with zero-length,
2122 second time with non-zero. */
2124 if (!RX_PRELEN(rx) && PL_curpm) {
2128 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2129 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2130 ? REXEC_COPY_STR : 0;
2132 r_flags |= REXEC_SCREAM;
2135 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2137 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2141 /* How to do it in subst? */
2142 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2144 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2145 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2146 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2147 && (r_flags & REXEC_SCREAM))))
2152 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2153 r_flags | REXEC_CHECKED))
2157 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2158 LEAVE_SCOPE(oldsave);
2162 /* known replacement string? */
2164 if (SvTAINTED(dstr))
2165 rxtainted |= SUBST_TAINT_REPL;
2167 /* Upgrade the source if the replacement is utf8 but the source is not,
2168 * but only if it matched; see
2169 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2171 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2172 char * const orig_pvx = SvPVX(TARG);
2173 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2175 /* If the lengths are the same, the pattern contains only
2176 * invariants, can keep going; otherwise, various internal markers
2177 * could be off, so redo */
2178 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2183 /* replacement needing upgrading? */
2184 if (DO_UTF8(TARG) && !doutf8) {
2185 nsv = sv_newmortal();
2188 sv_recode_to_utf8(nsv, PL_encoding);
2190 sv_utf8_upgrade(nsv);
2191 c = SvPV_const(nsv, clen);
2195 c = SvPV_const(dstr, clen);
2196 doutf8 = DO_UTF8(dstr);
2204 /* can do inplace substitution? */
2206 #ifdef PERL_OLD_COPY_ON_WRITE
2209 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2210 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2211 && (!doutf8 || SvUTF8(TARG))
2212 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2215 #ifdef PERL_OLD_COPY_ON_WRITE
2216 if (SvIsCOW(TARG)) {
2217 assert (!force_on_match);
2221 if (force_on_match) {
2223 s = SvPV_force(TARG, len);
2228 SvSCREAM_off(TARG); /* disable possible screamer */
2230 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2231 rxtainted |= SUBST_TAINT_PAT;
2232 m = orig + RX_OFFS(rx)[0].start;
2233 d = orig + RX_OFFS(rx)[0].end;
2235 if (m - s > strend - d) { /* faster to shorten from end */
2237 Copy(c, m, clen, char);
2242 Move(d, m, i, char);
2246 SvCUR_set(TARG, m - s);
2248 else if ((i = m - s)) { /* faster from front */
2251 Move(s, d - i, i, char);
2254 Copy(c, m, clen, char);
2259 Copy(c, d, clen, char);
2269 if (iters++ > maxiters)
2270 DIE(aTHX_ "Substitution loop");
2271 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2272 rxtainted |= SUBST_TAINT_PAT;
2273 m = RX_OFFS(rx)[0].start + orig;
2276 Move(s, d, i, char);
2280 Copy(c, d, clen, char);
2283 s = RX_OFFS(rx)[0].end + orig;
2284 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2286 /* don't match same null twice */
2287 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2290 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2291 Move(s, d, i+1, char); /* include the NUL */
2298 if (force_on_match) {
2300 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2301 /* I feel that it should be possible to avoid this mortal copy
2302 given that the code below copies into a new destination.
2303 However, I suspect it isn't worth the complexity of
2304 unravelling the C<goto force_it> for the small number of
2305 cases where it would be viable to drop into the copy code. */
2306 TARG = sv_2mortal(newSVsv(TARG));
2308 s = SvPV_force(TARG, len);
2311 #ifdef PERL_OLD_COPY_ON_WRITE
2314 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2315 rxtainted |= SUBST_TAINT_PAT;
2316 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2319 register PERL_CONTEXT *cx;
2321 /* note that a whole bunch of local vars are saved here for
2322 * use by pp_substcont: here's a list of them in case you're
2323 * searching for places in this sub that uses a particular var:
2324 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2325 * s m strend rx once */
2327 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2329 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2331 if (iters++ > maxiters)
2332 DIE(aTHX_ "Substitution loop");
2333 if (RX_MATCH_TAINTED(rx))
2334 rxtainted |= SUBST_TAINT_PAT;
2335 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2338 orig = RX_SUBBEG(rx);
2340 strend = s + (strend - m);
2342 m = RX_OFFS(rx)[0].start + orig;
2343 if (doutf8 && !SvUTF8(dstr))
2344 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2346 sv_catpvn(dstr, s, m-s);
2347 s = RX_OFFS(rx)[0].end + orig;
2349 sv_catpvn(dstr, c, clen);
2352 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2353 TARG, NULL, r_flags));
2354 if (doutf8 && !DO_UTF8(TARG))
2355 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2357 sv_catpvn(dstr, s, strend - s);
2359 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2360 /* From here on down we're using the copy, and leaving the original
2366 #ifdef PERL_OLD_COPY_ON_WRITE
2367 /* The match may make the string COW. If so, brilliant, because
2368 that's just saved us one malloc, copy and free - the regexp has
2369 donated the old buffer, and we malloc an entirely new one, rather
2370 than the regexp malloc()ing a buffer and copying our original,
2371 only for us to throw it away here during the substitution. */
2372 if (SvIsCOW(TARG)) {
2373 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2379 SvPV_set(TARG, SvPVX(dstr));
2380 SvCUR_set(TARG, SvCUR(dstr));
2381 SvLEN_set(TARG, SvLEN(dstr));
2382 doutf8 |= DO_UTF8(dstr);
2383 SvPV_set(dstr, NULL);
2390 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2391 (void)SvPOK_only_UTF8(TARG);
2396 /* See "how taint works" above */
2398 if ((rxtainted & SUBST_TAINT_PAT) ||
2399 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2400 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2402 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2404 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2405 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2407 SvTAINTED_on(TOPs); /* taint return value */
2409 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2411 /* needed for mg_set below */
2413 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2416 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2418 LEAVE_SCOPE(oldsave);
2427 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2428 ++*PL_markstack_ptr;
2430 LEAVE_with_name("grep_item"); /* exit inner scope */
2433 if (PL_stack_base + *PL_markstack_ptr > SP) {
2435 const I32 gimme = GIMME_V;
2437 LEAVE_with_name("grep"); /* exit outer scope */
2438 (void)POPMARK; /* pop src */
2439 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2440 (void)POPMARK; /* pop dst */
2441 SP = PL_stack_base + POPMARK; /* pop original mark */
2442 if (gimme == G_SCALAR) {
2443 if (PL_op->op_private & OPpGREP_LEX) {
2444 SV* const sv = sv_newmortal();
2445 sv_setiv(sv, items);
2453 else if (gimme == G_ARRAY)
2460 ENTER_with_name("grep_item"); /* enter inner scope */
2463 src = PL_stack_base[*PL_markstack_ptr];
2465 if (PL_op->op_private & OPpGREP_LEX)
2466 PAD_SVl(PL_op->op_targ) = src;
2470 RETURNOP(cLOGOP->op_other);
2481 register PERL_CONTEXT *cx;
2484 if (CxMULTICALL(&cxstack[cxstack_ix]))
2488 cxstack_ix++; /* temporarily protect top context */
2491 if (gimme == G_SCALAR) {
2494 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2495 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2496 *MARK = SvREFCNT_inc(TOPs);
2501 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2503 *MARK = sv_mortalcopy(sv);
2507 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2511 *MARK = sv_mortalcopy(TOPs);
2515 *MARK = &PL_sv_undef;
2519 else if (gimme == G_ARRAY) {
2520 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2521 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
2522 *MARK = sv_mortalcopy(*MARK);
2523 TAINT_NOT; /* Each item is independent */
2531 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2532 PL_curpm = newpm; /* ... and pop $1 et al */
2535 return cx->blk_sub.retop;
2543 register PERL_CONTEXT *cx;
2545 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2548 DIE(aTHX_ "Not a CODE reference");
2549 switch (SvTYPE(sv)) {
2550 /* This is overwhelming the most common case: */
2552 if (!isGV_with_GP(sv))
2553 DIE(aTHX_ "Not a CODE reference");
2555 if (!(cv = GvCVu((const GV *)sv))) {
2557 cv = sv_2cv(sv, &stash, &gv, 0);
2566 if(isGV_with_GP(sv)) goto we_have_a_glob;
2569 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2571 SP = PL_stack_base + POPMARK;
2579 sv = amagic_deref_call(sv, to_cv_amg);
2580 /* Don't SPAGAIN here. */
2586 sym = SvPV_nomg_const(sv, len);
2588 DIE(aTHX_ PL_no_usym, "a subroutine");
2589 if (PL_op->op_private & HINT_STRICT_REFS)
2590 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2591 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2594 cv = MUTABLE_CV(SvRV(sv));
2595 if (SvTYPE(cv) == SVt_PVCV)
2600 DIE(aTHX_ "Not a CODE reference");
2601 /* This is the second most common case: */
2603 cv = MUTABLE_CV(sv);
2611 if (CvCLONE(cv) && ! CvCLONED(cv))
2612 DIE(aTHX_ "Closure prototype called");
2613 if (!CvROOT(cv) && !CvXSUB(cv)) {
2617 /* anonymous or undef'd function leaves us no recourse */
2618 if (CvANON(cv) || !(gv = CvGV(cv)))
2619 DIE(aTHX_ "Undefined subroutine called");
2621 /* autoloaded stub? */
2622 if (cv != GvCV(gv)) {
2625 /* should call AUTOLOAD now? */
2628 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2629 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2635 sub_name = sv_newmortal();
2636 gv_efullname3(sub_name, gv, NULL);
2637 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2641 DIE(aTHX_ "Not a CODE reference");
2646 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2647 Perl_get_db_sub(aTHX_ &sv, cv);
2649 PL_curcopdb = PL_curcop;
2651 /* check for lsub that handles lvalue subroutines */
2652 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2653 /* if lsub not found then fall back to DB::sub */
2654 if (!cv) cv = GvCV(PL_DBsub);
2656 cv = GvCV(PL_DBsub);
2659 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2660 DIE(aTHX_ "No DB::sub routine defined");
2663 if (!(CvISXSUB(cv))) {
2664 /* This path taken at least 75% of the time */
2666 register I32 items = SP - MARK;
2667 AV* const padlist = CvPADLIST(cv);
2668 PUSHBLOCK(cx, CXt_SUB, MARK);
2670 cx->blk_sub.retop = PL_op->op_next;
2672 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2673 * that eval'' ops within this sub know the correct lexical space.
2674 * Owing the speed considerations, we choose instead to search for
2675 * the cv using find_runcv() when calling doeval().
2677 if (CvDEPTH(cv) >= 2) {
2678 PERL_STACK_OVERFLOW_CHECK();
2679 pad_push(padlist, CvDEPTH(cv));
2682 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2684 AV *const av = MUTABLE_AV(PAD_SVl(0));
2686 /* @_ is normally not REAL--this should only ever
2687 * happen when DB::sub() calls things that modify @_ */
2692 cx->blk_sub.savearray = GvAV(PL_defgv);
2693 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2694 CX_CURPAD_SAVE(cx->blk_sub);
2695 cx->blk_sub.argarray = av;
2698 if (items > AvMAX(av) + 1) {
2699 SV **ary = AvALLOC(av);
2700 if (AvARRAY(av) != ary) {
2701 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2704 if (items > AvMAX(av) + 1) {
2705 AvMAX(av) = items - 1;
2706 Renew(ary,items,SV*);
2711 Copy(MARK,AvARRAY(av),items,SV*);
2712 AvFILLp(av) = items - 1;
2720 /* warning must come *after* we fully set up the context
2721 * stuff so that __WARN__ handlers can safely dounwind()
2724 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2725 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2726 sub_crush_depth(cv);
2727 RETURNOP(CvSTART(cv));
2730 I32 markix = TOPMARK;
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 I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2742 /* Mark is at the end of the stack. */
2744 Copy(AvARRAY(av), SP + 1, items, SV*);
2749 /* We assume first XSUB in &DB::sub is the called one. */
2751 SAVEVPTR(PL_curcop);
2752 PL_curcop = PL_curcopdb;
2755 /* Do we need to open block here? XXXX */
2757 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2759 CvXSUB(cv)(aTHX_ cv);
2761 /* Enforce some sanity in scalar context. */
2762 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2763 if (markix > PL_stack_sp - PL_stack_base)
2764 *(PL_stack_base + markix) = &PL_sv_undef;
2766 *(PL_stack_base + markix) = *PL_stack_sp;
2767 PL_stack_sp = PL_stack_base + markix;
2775 Perl_sub_crush_depth(pTHX_ CV *cv)
2777 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2780 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2782 SV* const tmpstr = sv_newmortal();
2783 gv_efullname3(tmpstr, CvGV(cv), NULL);
2784 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2793 SV* const elemsv = POPs;
2794 IV elem = SvIV(elemsv);
2795 AV *const av = MUTABLE_AV(POPs);
2796 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2797 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2798 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2799 bool preeminent = TRUE;
2802 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2803 Perl_warner(aTHX_ packWARN(WARN_MISC),
2804 "Use of reference \"%"SVf"\" as array index",
2806 if (SvTYPE(av) != SVt_PVAV)
2813 /* If we can determine whether the element exist,
2814 * Try to preserve the existenceness of a tied array
2815 * element by using EXISTS and DELETE if possible.
2816 * Fallback to FETCH and STORE otherwise. */
2817 if (SvCANEXISTDELETE(av))
2818 preeminent = av_exists(av, elem);
2821 svp = av_fetch(av, elem, lval && !defer);
2823 #ifdef PERL_MALLOC_WRAP
2824 if (SvUOK(elemsv)) {
2825 const UV uv = SvUV(elemsv);
2826 elem = uv > IV_MAX ? IV_MAX : uv;
2828 else if (SvNOK(elemsv))
2829 elem = (IV)SvNV(elemsv);
2831 static const char oom_array_extend[] =
2832 "Out of memory during array extend"; /* Duplicated in av.c */
2833 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2836 if (!svp || *svp == &PL_sv_undef) {
2839 DIE(aTHX_ PL_no_aelem, elem);
2840 lv = sv_newmortal();
2841 sv_upgrade(lv, SVt_PVLV);
2843 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2844 LvTARG(lv) = SvREFCNT_inc_simple(av);
2845 LvTARGOFF(lv) = elem;
2852 save_aelem(av, elem, svp);
2854 SAVEADELETE(av, elem);
2856 else if (PL_op->op_private & OPpDEREF) {
2857 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2861 sv = (svp ? *svp : &PL_sv_undef);
2862 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2869 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2871 PERL_ARGS_ASSERT_VIVIFY_REF;
2876 Perl_croak_no_modify(aTHX);
2877 prepare_SV_for_RV(sv);
2880 SvRV_set(sv, newSV(0));
2883 SvRV_set(sv, MUTABLE_SV(newAV()));
2886 SvRV_set(sv, MUTABLE_SV(newHV()));
2892 if (SvGMAGICAL(sv)) {
2893 /* copy the sv without magic to prevent magic from being
2895 SV* msv = sv_newmortal();
2896 sv_setsv_nomg(msv, sv);
2905 SV* const sv = TOPs;
2908 SV* const rsv = SvRV(sv);
2909 if (SvTYPE(rsv) == SVt_PVCV) {
2915 SETs(method_common(sv, NULL));
2922 SV* const sv = cSVOP_sv;
2923 U32 hash = SvSHARED_HASH(sv);
2925 XPUSHs(method_common(sv, &hash));
2930 S_method_common(pTHX_ SV* meth, U32* hashp)
2937 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2939 PERL_ARGS_ASSERT_METHOD_COMMON;
2942 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2947 ob = MUTABLE_SV(SvRV(sv));
2951 const char * packname = NULL;
2952 bool packname_is_utf8 = FALSE;
2954 /* this isn't a reference */
2955 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2956 const HE* const he =
2957 (const HE *)hv_common_key_len(
2958 PL_stashcache, packname,
2959 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2963 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2970 !(iogv = gv_fetchpvn_flags(
2971 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2973 !(ob=MUTABLE_SV(GvIO(iogv))))
2975 /* this isn't the name of a filehandle either */
2977 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2978 ? !isIDFIRST_utf8((U8*)packname)
2979 : !isIDFIRST(*packname)
2982 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2984 SvOK(sv) ? "without a package or object reference"
2985 : "on an undefined value");
2987 /* assume it's a package name */
2988 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
2992 SV* const ref = newSViv(PTR2IV(stash));
2993 (void)hv_store(PL_stashcache, packname,
2994 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
2998 /* it _is_ a filehandle name -- replace with a reference */
2999 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3002 /* if we got here, ob should be a reference or a glob */
3003 if (!ob || !(SvOBJECT(ob)
3004 || (SvTYPE(ob) == SVt_PVGV
3006 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3009 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3010 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3011 ? newSVpvs_flags("DOES", SVs_TEMP)
3015 stash = SvSTASH(ob);
3018 /* NOTE: stash may be null, hope hv_fetch_ent and
3019 gv_fetchmethod can cope (it seems they can) */
3021 /* shortcut for simple names */
3023 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3025 gv = MUTABLE_GV(HeVAL(he));
3026 if (isGV(gv) && GvCV(gv) &&
3027 (!GvCVGEN(gv) || GvCVGEN(gv)
3028 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3029 return MUTABLE_SV(GvCV(gv));
3033 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3034 meth, GV_AUTOLOAD | GV_CROAK);
3038 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3043 * c-indentation-style: bsd
3045 * indent-tabs-mode: t
3048 * ex: set ts=8 sts=4 sw=4 noet: