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));
80 PUSHMARK(PL_stack_sp);
95 XPUSHs(MUTABLE_SV(cGVOP_gv));
106 if (PL_op->op_type == OP_AND)
108 RETURNOP(cLOGOP->op_other);
114 dVAR; dSP; dPOPTOPssrl;
116 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
117 SV * const temp = left;
118 left = right; right = temp;
120 if (PL_tainting && PL_tainted && !SvTAINTED(left))
122 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
123 SV * const cv = SvRV(left);
124 const U32 cv_type = SvTYPE(cv);
125 const bool is_gv = isGV_with_GP(right);
126 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
132 /* Can do the optimisation if right (LVALUE) is not a typeglob,
133 left (RVALUE) is a reference to something, and we're in void
135 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
136 /* Is the target symbol table currently empty? */
137 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
138 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
139 /* Good. Create a new proxy constant subroutine in the target.
140 The gv becomes a(nother) reference to the constant. */
141 SV *const value = SvRV(cv);
143 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
144 SvPCS_IMPORTED_on(gv);
146 SvREFCNT_inc_simple_void(value);
152 /* Need to fix things up. */
154 /* Need to fix GV. */
155 right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
159 /* We've been returned a constant rather than a full subroutine,
160 but they expect a subroutine reference to apply. */
162 ENTER_with_name("sassign_coderef");
163 SvREFCNT_inc_void(SvRV(cv));
164 /* newCONSTSUB takes a reference count on the passed in SV
165 from us. We set the name to NULL, otherwise we get into
166 all sorts of fun as the reference to our new sub is
167 donated to the GV that we're about to assign to.
169 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
172 LEAVE_with_name("sassign_coderef");
174 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
176 First: ops for \&{"BONK"}; return us the constant in the
178 Second: ops for *{"BONK"} cause that symbol table entry
179 (and our reference to it) to be upgraded from RV
181 Thirdly: We get here. cv is actually PVGV now, and its
182 GvCV() is actually the subroutine we're looking for
184 So change the reference so that it points to the subroutine
185 of that typeglob, as that's what they were after all along.
187 GV *const upgraded = MUTABLE_GV(cv);
188 CV *const source = GvCV(upgraded);
191 assert(CvFLAGS(source) & CVf_CONST);
193 SvREFCNT_inc_void(source);
194 SvREFCNT_dec(upgraded);
195 SvRV_set(left, MUTABLE_SV(source));
201 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
202 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
205 packWARN(WARN_MISC), "Useless assignment to a temporary"
207 SvSetMagicSV(right, left);
217 RETURNOP(cLOGOP->op_other);
219 RETURNOP(cLOGOP->op_next);
226 TAINT_NOT; /* Each statement is presumed innocent */
227 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
229 if (!(PL_op->op_flags & OPf_SPECIAL)) {
230 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
231 LEAVE_SCOPE(oldsave);
238 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
243 const char *rpv = NULL;
245 bool rcopied = FALSE;
247 if (TARG == right && right != left) { /* $r = $l.$r */
248 rpv = SvPV_nomg_const(right, rlen);
249 rbyte = !DO_UTF8(right);
250 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
251 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
255 if (TARG != left) { /* not $l .= $r */
257 const char* const lpv = SvPV_nomg_const(left, llen);
258 lbyte = !DO_UTF8(left);
259 sv_setpvn(TARG, lpv, llen);
265 else { /* $l .= $r */
267 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
268 report_uninit(right);
271 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
272 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
279 /* $r.$r: do magic twice: tied might return different 2nd time */
281 rpv = SvPV_nomg_const(right, rlen);
282 rbyte = !DO_UTF8(right);
284 if (lbyte != rbyte) {
285 /* sv_utf8_upgrade_nomg() may reallocate the stack */
288 sv_utf8_upgrade_nomg(TARG);
291 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
292 sv_utf8_upgrade_nomg(right);
293 rpv = SvPV_nomg_const(right, rlen);
297 sv_catpvn_nomg(TARG, rpv, rlen);
308 if (PL_op->op_flags & OPf_MOD) {
309 if (PL_op->op_private & OPpLVAL_INTRO)
310 if (!(PL_op->op_private & OPpPAD_STATE))
311 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
312 if (PL_op->op_private & OPpDEREF) {
314 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
324 dSP; SvGETMAGIC(TOPs);
325 tryAMAGICunTARGET(iter_amg, 0, 0);
326 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
327 if (!isGV_with_GP(PL_last_in_gv)) {
328 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
329 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
332 XPUSHs(MUTABLE_SV(PL_last_in_gv));
335 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
338 return do_readline();
344 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
345 #ifndef NV_PRESERVES_UV
346 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
348 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
352 #ifdef PERL_PRESERVE_IVUV
353 SvIV_please_nomg(TOPs);
355 /* Unless the left argument is integer in range we are going
356 to have to use NV maths. Hence only attempt to coerce the
357 right argument if we know the left is integer. */
358 SvIV_please_nomg(TOPm1s);
360 const bool auvok = SvUOK(TOPm1s);
361 const bool buvok = SvUOK(TOPs);
363 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
364 /* Casting IV to UV before comparison isn't going to matter
365 on 2s complement. On 1s complement or sign&magnitude
366 (if we have any of them) it could to make negative zero
367 differ from normal zero. As I understand it. (Need to
368 check - is negative zero implementation defined behaviour
370 const UV buv = SvUVX(POPs);
371 const UV auv = SvUVX(TOPs);
373 SETs(boolSV(auv == buv));
376 { /* ## Mixed IV,UV ## */
380 /* == is commutative so doesn't matter which is left or right */
382 /* top of stack (b) is the iv */
391 /* As uv is a UV, it's >0, so it cannot be == */
394 /* we know iv is >= 0 */
395 SETs(boolSV((UV)iv == SvUVX(uvp)));
402 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
404 if (Perl_isnan(left) || Perl_isnan(right))
406 SETs(boolSV(left == right));
409 SETs(boolSV(SvNV_nomg(TOPs) == value));
418 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
419 Perl_croak_no_modify(aTHX);
420 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
421 && SvIVX(TOPs) != IV_MAX)
423 SvIV_set(TOPs, SvIVX(TOPs) + 1);
424 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
426 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
439 if (PL_op->op_type == OP_OR)
441 RETURNOP(cLOGOP->op_other);
450 const int op_type = PL_op->op_type;
451 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
456 if (!sv || !SvANY(sv)) {
457 if (op_type == OP_DOR)
459 RETURNOP(cLOGOP->op_other);
465 if (!sv || !SvANY(sv))
470 switch (SvTYPE(sv)) {
472 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
476 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
480 if (CvROOT(sv) || CvXSUB(sv))
493 if(op_type == OP_DOR)
495 RETURNOP(cLOGOP->op_other);
497 /* assuming OP_DEFINED */
505 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
506 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
510 useleft = USE_LEFT(svl);
511 #ifdef PERL_PRESERVE_IVUV
512 /* We must see if we can perform the addition with integers if possible,
513 as the integer code detects overflow while the NV code doesn't.
514 If either argument hasn't had a numeric conversion yet attempt to get
515 the IV. It's important to do this now, rather than just assuming that
516 it's not IOK as a PV of "9223372036854775806" may not take well to NV
517 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
518 integer in case the second argument is IV=9223372036854775806
519 We can (now) rely on sv_2iv to do the right thing, only setting the
520 public IOK flag if the value in the NV (or PV) slot is truly integer.
522 A side effect is that this also aggressively prefers integer maths over
523 fp maths for integer values.
525 How to detect overflow?
527 C 99 section 6.2.6.1 says
529 The range of nonnegative values of a signed integer type is a subrange
530 of the corresponding unsigned integer type, and the representation of
531 the same value in each type is the same. A computation involving
532 unsigned operands can never overflow, because a result that cannot be
533 represented by the resulting unsigned integer type is reduced modulo
534 the number that is one greater than the largest value that can be
535 represented by the resulting type.
539 which I read as "unsigned ints wrap."
541 signed integer overflow seems to be classed as "exception condition"
543 If an exceptional condition occurs during the evaluation of an
544 expression (that is, if the result is not mathematically defined or not
545 in the range of representable values for its type), the behavior is
548 (6.5, the 5th paragraph)
550 I had assumed that on 2s complement machines signed arithmetic would
551 wrap, hence coded pp_add and pp_subtract on the assumption that
552 everything perl builds on would be happy. After much wailing and
553 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
554 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
555 unsigned code below is actually shorter than the old code. :-)
558 SvIV_please_nomg(svr);
561 /* Unless the left argument is integer in range we are going to have to
562 use NV maths. Hence only attempt to coerce the right argument if
563 we know the left is integer. */
571 /* left operand is undef, treat as zero. + 0 is identity,
572 Could SETi or SETu right now, but space optimise by not adding
573 lots of code to speed up what is probably a rarish case. */
575 /* Left operand is defined, so is it IV? */
576 SvIV_please_nomg(svl);
578 if ((auvok = SvUOK(svl)))
581 register const IV aiv = SvIVX(svl);
584 auvok = 1; /* Now acting as a sign flag. */
585 } else { /* 2s complement assumption for IV_MIN */
593 bool result_good = 0;
596 bool buvok = SvUOK(svr);
601 register const IV biv = SvIVX(svr);
608 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
609 else "IV" now, independent of how it came in.
610 if a, b represents positive, A, B negative, a maps to -A etc
615 all UV maths. negate result if A negative.
616 add if signs same, subtract if signs differ. */
622 /* Must get smaller */
628 /* result really should be -(auv-buv). as its negation
629 of true value, need to swap our result flag */
646 if (result <= (UV)IV_MIN)
649 /* result valid, but out of range for IV. */
654 } /* Overflow, drop through to NVs. */
659 NV value = SvNV_nomg(svr);
662 /* left operand is undef, treat as zero. + 0.0 is identity. */
666 SETn( value + SvNV_nomg(svl) );
674 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
675 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
676 const U32 lval = PL_op->op_flags & OPf_MOD;
677 SV** const svp = av_fetch(av, PL_op->op_private, lval);
678 SV *sv = (svp ? *svp : &PL_sv_undef);
680 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
688 dVAR; dSP; dMARK; dTARGET;
690 do_join(TARG, *MARK, MARK, SP);
701 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
702 * will be enough to hold an OP*.
704 SV* const sv = sv_newmortal();
705 sv_upgrade(sv, SVt_PVLV);
707 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
710 XPUSHs(MUTABLE_SV(PL_op));
715 /* Oversized hot code. */
719 dVAR; dSP; dMARK; dORIGMARK;
723 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
727 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
730 if (MARK == ORIGMARK) {
731 /* If using default handle then we need to make space to
732 * pass object as 1st arg, so move other args up ...
736 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
739 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
741 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
742 | (PL_op->op_type == OP_SAY
743 ? TIED_METHOD_SAY : 0)), sp - mark);
746 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
747 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
750 SETERRNO(EBADF,RMS_IFI);
753 else if (!(fp = IoOFP(io))) {
755 report_wrongway_fh(gv, '<');
758 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
762 SV * const ofs = GvSV(PL_ofsgv); /* $, */
764 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
766 if (!do_print(*MARK, fp))
770 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
771 if (!do_print(GvSV(PL_ofsgv), fp)) {
780 if (!do_print(*MARK, fp))
788 if (PL_op->op_type == OP_SAY) {
789 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
792 else if (PL_ors_sv && SvOK(PL_ors_sv))
793 if (!do_print(PL_ors_sv, fp)) /* $\ */
796 if (IoFLAGS(io) & IOf_FLUSH)
797 if (PerlIO_flush(fp) == EOF)
807 XPUSHs(&PL_sv_undef);
814 const I32 gimme = GIMME_V;
815 static const char an_array[] = "an ARRAY";
816 static const char a_hash[] = "a HASH";
817 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
818 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
820 if (!(PL_op->op_private & OPpDEREFed))
824 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
828 if (SvTYPE(sv) != type)
829 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
830 if (PL_op->op_flags & OPf_REF) {
834 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
835 const I32 flags = is_lvalue_sub();
836 if (flags && !(flags & OPpENTERSUB_INARGS)) {
837 if (gimme != G_ARRAY)
838 goto croak_cant_return;
843 else if (PL_op->op_flags & OPf_MOD
844 && PL_op->op_private & OPpLVAL_INTRO)
845 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
848 if (SvTYPE(sv) == type) {
849 if (PL_op->op_flags & OPf_REF) {
854 if (gimme != G_ARRAY)
855 goto croak_cant_return;
863 if (!isGV_with_GP(sv)) {
864 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
872 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
873 if (PL_op->op_private & OPpLVAL_INTRO)
874 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
875 if (PL_op->op_flags & OPf_REF) {
879 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
880 const I32 flags = is_lvalue_sub();
881 if (flags && !(flags & OPpENTERSUB_INARGS)) {
882 if (gimme != G_ARRAY)
883 goto croak_cant_return;
892 AV *const av = MUTABLE_AV(sv);
893 /* The guts of pp_rv2av, with no intending change to preserve history
894 (until such time as we get tools that can do blame annotation across
895 whitespace changes. */
896 if (gimme == G_ARRAY) {
897 const I32 maxarg = AvFILL(av) + 1;
898 (void)POPs; /* XXXX May be optimized away? */
900 if (SvRMAGICAL(av)) {
902 for (i=0; i < (U32)maxarg; i++) {
903 SV ** const svp = av_fetch(av, i, FALSE);
904 /* See note in pp_helem, and bug id #27839 */
906 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
911 Copy(AvARRAY(av), SP+1, maxarg, SV*);
915 else if (gimme == G_SCALAR) {
917 const I32 maxarg = AvFILL(av) + 1;
921 /* The guts of pp_rv2hv */
922 if (gimme == G_ARRAY) { /* array wanted */
924 return Perl_do_kv(aTHX);
926 else if (gimme == G_SCALAR) {
928 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
936 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
937 is_pp_rv2av ? "array" : "hash");
942 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
946 PERL_ARGS_ASSERT_DO_ODDBALL;
952 if (ckWARN(WARN_MISC)) {
954 if (relem == firstrelem &&
956 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
957 SvTYPE(SvRV(*relem)) == SVt_PVHV))
959 err = "Reference found where even-sized list expected";
962 err = "Odd number of elements in hash assignment";
963 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
967 didstore = hv_store_ent(hash,*relem,tmpstr,0);
968 if (SvMAGICAL(hash)) {
969 if (SvSMAGICAL(tmpstr))
981 SV **lastlelem = PL_stack_sp;
982 SV **lastrelem = PL_stack_base + POPMARK;
983 SV **firstrelem = PL_stack_base + POPMARK + 1;
984 SV **firstlelem = lastrelem + 1;
997 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
999 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1002 /* If there's a common identifier on both sides we have to take
1003 * special care that assigning the identifier on the left doesn't
1004 * clobber a value on the right that's used later in the list.
1005 * Don't bother if LHS is just an empty hash or array.
1008 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1010 firstlelem != lastlelem
1011 || ! ((sv = *firstlelem))
1013 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1014 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1015 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1018 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1019 for (relem = firstrelem; relem <= lastrelem; relem++) {
1020 if ((sv = *relem)) {
1021 TAINT_NOT; /* Each item is independent */
1023 /* Dear TODO test in t/op/sort.t, I love you.
1024 (It's relying on a panic, not a "semi-panic" from newSVsv()
1025 and then an assertion failure below.) */
1026 if (SvIS_FREED(sv)) {
1027 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1030 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1031 and we need a second copy of a temp here. */
1032 *relem = sv_2mortal(newSVsv(sv));
1042 while (lelem <= lastlelem) {
1043 TAINT_NOT; /* Each item stands on its own, taintwise. */
1045 switch (SvTYPE(sv)) {
1047 ary = MUTABLE_AV(sv);
1048 magic = SvMAGICAL(ary) != 0;
1050 av_extend(ary, lastrelem - relem);
1052 while (relem <= lastrelem) { /* gobble up all the rest */
1056 sv_setsv(sv, *relem);
1058 didstore = av_store(ary,i++,sv);
1067 if (PL_delaymagic & DM_ARRAY_ISA)
1068 SvSETMAGIC(MUTABLE_SV(ary));
1070 case SVt_PVHV: { /* normal hash */
1072 SV** topelem = relem;
1074 hash = MUTABLE_HV(sv);
1075 magic = SvMAGICAL(hash) != 0;
1077 firsthashrelem = relem;
1079 while (relem < lastrelem) { /* gobble up all the rest */
1081 sv = *relem ? *relem : &PL_sv_no;
1085 sv_setsv(tmpstr,*relem); /* value */
1087 if (gimme != G_VOID) {
1088 if (hv_exists_ent(hash, sv, 0))
1089 /* key overwrites an existing entry */
1092 if (gimme == G_ARRAY) {
1093 /* copy element back: possibly to an earlier
1094 * stack location if we encountered dups earlier */
1096 *topelem++ = tmpstr;
1099 didstore = hv_store_ent(hash,sv,tmpstr,0);
1101 if (SvSMAGICAL(tmpstr))
1108 if (relem == lastrelem) {
1109 do_oddball(hash, relem, firstrelem);
1115 if (SvIMMORTAL(sv)) {
1116 if (relem <= lastrelem)
1120 if (relem <= lastrelem) {
1122 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1123 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1126 packWARN(WARN_MISC),
1127 "Useless assignment to a temporary"
1129 sv_setsv(sv, *relem);
1133 sv_setsv(sv, &PL_sv_undef);
1138 if (PL_delaymagic & ~DM_DELAY) {
1139 if (PL_delaymagic & DM_UID) {
1140 #ifdef HAS_SETRESUID
1141 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1142 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1145 # ifdef HAS_SETREUID
1146 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1147 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1150 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1151 (void)setruid(PL_uid);
1152 PL_delaymagic &= ~DM_RUID;
1154 # endif /* HAS_SETRUID */
1156 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1157 (void)seteuid(PL_euid);
1158 PL_delaymagic &= ~DM_EUID;
1160 # endif /* HAS_SETEUID */
1161 if (PL_delaymagic & DM_UID) {
1162 if (PL_uid != PL_euid)
1163 DIE(aTHX_ "No setreuid available");
1164 (void)PerlProc_setuid(PL_uid);
1166 # endif /* HAS_SETREUID */
1167 #endif /* HAS_SETRESUID */
1168 PL_uid = PerlProc_getuid();
1169 PL_euid = PerlProc_geteuid();
1171 if (PL_delaymagic & DM_GID) {
1172 #ifdef HAS_SETRESGID
1173 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1174 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1177 # ifdef HAS_SETREGID
1178 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1179 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1182 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1183 (void)setrgid(PL_gid);
1184 PL_delaymagic &= ~DM_RGID;
1186 # endif /* HAS_SETRGID */
1188 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1189 (void)setegid(PL_egid);
1190 PL_delaymagic &= ~DM_EGID;
1192 # endif /* HAS_SETEGID */
1193 if (PL_delaymagic & DM_GID) {
1194 if (PL_gid != PL_egid)
1195 DIE(aTHX_ "No setregid available");
1196 (void)PerlProc_setgid(PL_gid);
1198 # endif /* HAS_SETREGID */
1199 #endif /* HAS_SETRESGID */
1200 PL_gid = PerlProc_getgid();
1201 PL_egid = PerlProc_getegid();
1203 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1207 if (gimme == G_VOID)
1208 SP = firstrelem - 1;
1209 else if (gimme == G_SCALAR) {
1212 SETi(lastrelem - firstrelem + 1 - duplicates);
1219 /* at this point we have removed the duplicate key/value
1220 * pairs from the stack, but the remaining values may be
1221 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1222 * the (a 2), but the stack now probably contains
1223 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1224 * obliterates the earlier key. So refresh all values. */
1225 lastrelem -= duplicates;
1226 relem = firsthashrelem;
1227 while (relem < lastrelem) {
1230 he = hv_fetch_ent(hash, sv, 0, 0);
1231 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1237 SP = firstrelem + (lastlelem - firstlelem);
1238 lelem = firstlelem + (relem - firstrelem);
1240 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1249 register PMOP * const pm = cPMOP;
1250 REGEXP * rx = PM_GETRE(pm);
1251 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1252 SV * const rv = sv_newmortal();
1254 SvUPGRADE(rv, SVt_IV);
1255 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1256 loathe to use it here, but it seems to be the right fix. Or close.
1257 The key part appears to be that it's essential for pp_qr to return a new
1258 object (SV), which implies that there needs to be an effective way to
1259 generate a new SV from the existing SV that is pre-compiled in the
1261 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1265 HV *const stash = gv_stashsv(pkg, GV_ADD);
1267 (void)sv_bless(rv, stash);
1270 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1272 SvTAINTED_on(SvRV(rv));
1281 register PMOP *pm = cPMOP;
1283 register const char *t;
1284 register const char *s;
1287 U8 r_flags = REXEC_CHECKED;
1288 const char *truebase; /* Start of string */
1289 register REGEXP *rx = PM_GETRE(pm);
1291 const I32 gimme = GIMME;
1294 const I32 oldsave = PL_savestack_ix;
1295 I32 update_minmatch = 1;
1296 I32 had_zerolen = 0;
1299 if (PL_op->op_flags & OPf_STACKED)
1301 else if (PL_op->op_private & OPpTARGET_MY)
1308 PUTBACK; /* EVAL blocks need stack_sp. */
1309 /* Skip get-magic if this is a qr// clone, because regcomp has
1311 s = ((struct regexp *)SvANY(rx))->mother_re
1312 ? SvPV_nomg_const(TARG, len)
1313 : SvPV_const(TARG, len);
1315 DIE(aTHX_ "panic: pp_match");
1317 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1318 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1321 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1323 /* PMdf_USED is set after a ?? matches once */
1326 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1328 pm->op_pmflags & PMf_USED
1332 if (gimme == G_ARRAY)
1339 /* empty pattern special-cased to use last successful pattern if possible */
1340 if (!RX_PRELEN(rx) && PL_curpm) {
1345 if (RX_MINLEN(rx) > (I32)len)
1350 /* XXXX What part of this is needed with true \G-support? */
1351 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1352 RX_OFFS(rx)[0].start = -1;
1353 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1354 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1355 if (mg && mg->mg_len >= 0) {
1356 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1357 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1358 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1359 r_flags |= REXEC_IGNOREPOS;
1360 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1361 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1364 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1365 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1366 update_minmatch = 0;
1370 /* XXX: comment out !global get safe $1 vars after a
1371 match, BUT be aware that this leads to dramatic slowdowns on
1372 /g matches against large strings. So far a solution to this problem
1373 appears to be quite tricky.
1374 Test for the unsafe vars are TODO for now. */
1375 if ( (!global && RX_NPARENS(rx))
1376 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1377 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1378 r_flags |= REXEC_COPY_STR;
1380 r_flags |= REXEC_SCREAM;
1383 if (global && RX_OFFS(rx)[0].start != -1) {
1384 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1385 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1387 if (update_minmatch++)
1388 minmatch = had_zerolen;
1390 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1391 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1392 /* FIXME - can PL_bostr be made const char *? */
1393 PL_bostr = (char *)truebase;
1394 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1398 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1400 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1401 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1402 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1403 && (r_flags & REXEC_SCREAM)))
1404 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1407 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1408 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1412 if (dynpm->op_pmflags & PMf_ONCE) {
1414 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1416 dynpm->op_pmflags |= PMf_USED;
1422 RX_MATCH_TAINTED_on(rx);
1423 TAINT_IF(RX_MATCH_TAINTED(rx));
1424 if (gimme == G_ARRAY) {
1425 const I32 nparens = RX_NPARENS(rx);
1426 I32 i = (global && !nparens) ? 1 : 0;
1428 SPAGAIN; /* EVAL blocks could move the stack. */
1429 EXTEND(SP, nparens + i);
1430 EXTEND_MORTAL(nparens + i);
1431 for (i = !i; i <= nparens; i++) {
1432 PUSHs(sv_newmortal());
1433 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1434 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1435 s = RX_OFFS(rx)[i].start + truebase;
1436 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1437 len < 0 || len > strend - s)
1438 DIE(aTHX_ "panic: pp_match start/end pointers");
1439 sv_setpvn(*SP, s, len);
1440 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1445 if (dynpm->op_pmflags & PMf_CONTINUE) {
1447 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1448 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1450 #ifdef PERL_OLD_COPY_ON_WRITE
1452 sv_force_normal_flags(TARG, 0);
1454 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1455 &PL_vtbl_mglob, NULL, 0);
1457 if (RX_OFFS(rx)[0].start != -1) {
1458 mg->mg_len = RX_OFFS(rx)[0].end;
1459 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1460 mg->mg_flags |= MGf_MINMATCH;
1462 mg->mg_flags &= ~MGf_MINMATCH;
1465 had_zerolen = (RX_OFFS(rx)[0].start != -1
1466 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1467 == (UV)RX_OFFS(rx)[0].end));
1468 PUTBACK; /* EVAL blocks may use stack */
1469 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1474 LEAVE_SCOPE(oldsave);
1480 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1481 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1485 #ifdef PERL_OLD_COPY_ON_WRITE
1487 sv_force_normal_flags(TARG, 0);
1489 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1490 &PL_vtbl_mglob, NULL, 0);
1492 if (RX_OFFS(rx)[0].start != -1) {
1493 mg->mg_len = RX_OFFS(rx)[0].end;
1494 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1495 mg->mg_flags |= MGf_MINMATCH;
1497 mg->mg_flags &= ~MGf_MINMATCH;
1500 LEAVE_SCOPE(oldsave);
1504 yup: /* Confirmed by INTUIT */
1506 RX_MATCH_TAINTED_on(rx);
1507 TAINT_IF(RX_MATCH_TAINTED(rx));
1509 if (dynpm->op_pmflags & PMf_ONCE) {
1511 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1513 dynpm->op_pmflags |= PMf_USED;
1516 if (RX_MATCH_COPIED(rx))
1517 Safefree(RX_SUBBEG(rx));
1518 RX_MATCH_COPIED_off(rx);
1519 RX_SUBBEG(rx) = NULL;
1521 /* FIXME - should rx->subbeg be const char *? */
1522 RX_SUBBEG(rx) = (char *) truebase;
1523 RX_OFFS(rx)[0].start = s - truebase;
1524 if (RX_MATCH_UTF8(rx)) {
1525 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1526 RX_OFFS(rx)[0].end = t - truebase;
1529 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1531 RX_SUBLEN(rx) = strend - truebase;
1534 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1536 #ifdef PERL_OLD_COPY_ON_WRITE
1537 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1539 PerlIO_printf(Perl_debug_log,
1540 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1541 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1544 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1546 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1547 assert (SvPOKp(RX_SAVED_COPY(rx)));
1552 RX_SUBBEG(rx) = savepvn(t, strend - t);
1553 #ifdef PERL_OLD_COPY_ON_WRITE
1554 RX_SAVED_COPY(rx) = NULL;
1557 RX_SUBLEN(rx) = strend - t;
1558 RX_MATCH_COPIED_on(rx);
1559 off = RX_OFFS(rx)[0].start = s - t;
1560 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1562 else { /* startp/endp are used by @- @+. */
1563 RX_OFFS(rx)[0].start = s - truebase;
1564 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1566 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1568 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1569 LEAVE_SCOPE(oldsave);
1574 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1575 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1576 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1581 LEAVE_SCOPE(oldsave);
1582 if (gimme == G_ARRAY)
1588 Perl_do_readline(pTHX)
1590 dVAR; dSP; dTARGETSTACKED;
1595 register IO * const io = GvIO(PL_last_in_gv);
1596 register const I32 type = PL_op->op_type;
1597 const I32 gimme = GIMME_V;
1600 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1602 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1603 if (gimme == G_SCALAR) {
1605 SvSetSV_nosteal(TARG, TOPs);
1615 if (IoFLAGS(io) & IOf_ARGV) {
1616 if (IoFLAGS(io) & IOf_START) {
1618 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1619 IoFLAGS(io) &= ~IOf_START;
1620 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1621 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1622 SvSETMAGIC(GvSV(PL_last_in_gv));
1627 fp = nextargv(PL_last_in_gv);
1628 if (!fp) { /* Note: fp != IoIFP(io) */
1629 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1632 else if (type == OP_GLOB)
1633 fp = Perl_start_glob(aTHX_ POPs, io);
1635 else if (type == OP_GLOB)
1637 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1638 report_wrongway_fh(PL_last_in_gv, '>');
1642 if ((!io || !(IoFLAGS(io) & IOf_START))
1643 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1645 if (type == OP_GLOB)
1646 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1647 "glob failed (can't start child: %s)",
1650 report_evil_fh(PL_last_in_gv);
1652 if (gimme == G_SCALAR) {
1653 /* undef TARG, and push that undefined value */
1654 if (type != OP_RCATLINE) {
1655 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1663 if (gimme == G_SCALAR) {
1665 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1668 if (type == OP_RCATLINE)
1669 SvPV_force_nolen(sv);
1673 else if (isGV_with_GP(sv)) {
1674 SvPV_force_nolen(sv);
1676 SvUPGRADE(sv, SVt_PV);
1677 tmplen = SvLEN(sv); /* remember if already alloced */
1678 if (!tmplen && !SvREADONLY(sv)) {
1679 /* try short-buffering it. Please update t/op/readline.t
1680 * if you change the growth length.
1685 if (type == OP_RCATLINE && SvOK(sv)) {
1687 SvPV_force_nolen(sv);
1693 sv = sv_2mortal(newSV(80));
1697 /* This should not be marked tainted if the fp is marked clean */
1698 #define MAYBE_TAINT_LINE(io, sv) \
1699 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1704 /* delay EOF state for a snarfed empty file */
1705 #define SNARF_EOF(gimme,rs,io,sv) \
1706 (gimme != G_SCALAR || SvCUR(sv) \
1707 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1711 if (!sv_gets(sv, fp, offset)
1713 || SNARF_EOF(gimme, PL_rs, io, sv)
1714 || PerlIO_error(fp)))
1716 PerlIO_clearerr(fp);
1717 if (IoFLAGS(io) & IOf_ARGV) {
1718 fp = nextargv(PL_last_in_gv);
1721 (void)do_close(PL_last_in_gv, FALSE);
1723 else if (type == OP_GLOB) {
1724 if (!do_close(PL_last_in_gv, FALSE)) {
1725 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1726 "glob failed (child exited with status %d%s)",
1727 (int)(STATUS_CURRENT >> 8),
1728 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1731 if (gimme == G_SCALAR) {
1732 if (type != OP_RCATLINE) {
1733 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1739 MAYBE_TAINT_LINE(io, sv);
1742 MAYBE_TAINT_LINE(io, sv);
1744 IoFLAGS(io) |= IOf_NOLINE;
1748 if (type == OP_GLOB) {
1751 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1752 char * const tmps = SvEND(sv) - 1;
1753 if (*tmps == *SvPVX_const(PL_rs)) {
1755 SvCUR_set(sv, SvCUR(sv) - 1);
1758 for (t1 = SvPVX_const(sv); *t1; t1++)
1759 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1760 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1762 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1763 (void)POPs; /* Unmatched wildcard? Chuck it... */
1766 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1767 if (ckWARN(WARN_UTF8)) {
1768 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1769 const STRLEN len = SvCUR(sv) - offset;
1772 if (!is_utf8_string_loc(s, len, &f))
1773 /* Emulate :encoding(utf8) warning in the same case. */
1774 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1775 "utf8 \"\\x%02X\" does not map to Unicode",
1776 f < (U8*)SvEND(sv) ? *f : 0);
1779 if (gimme == G_ARRAY) {
1780 if (SvLEN(sv) - SvCUR(sv) > 20) {
1781 SvPV_shrink_to_cur(sv);
1783 sv = sv_2mortal(newSV(80));
1786 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1787 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1788 const STRLEN new_len
1789 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1790 SvPV_renew(sv, new_len);
1799 register PERL_CONTEXT *cx;
1800 I32 gimme = OP_GIMME(PL_op, -1);
1803 if (cxstack_ix >= 0) {
1804 /* If this flag is set, we're just inside a return, so we should
1805 * store the caller's context */
1806 gimme = (PL_op->op_flags & OPf_SPECIAL)
1808 : cxstack[cxstack_ix].blk_gimme;
1813 ENTER_with_name("block");
1816 PUSHBLOCK(cx, CXt_BLOCK, SP);
1826 SV * const keysv = POPs;
1827 HV * const hv = MUTABLE_HV(POPs);
1828 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1829 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1831 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1832 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1833 bool preeminent = TRUE;
1835 if (SvTYPE(hv) != SVt_PVHV)
1842 /* If we can determine whether the element exist,
1843 * Try to preserve the existenceness of a tied hash
1844 * element by using EXISTS and DELETE if possible.
1845 * Fallback to FETCH and STORE otherwise. */
1846 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1847 preeminent = hv_exists_ent(hv, keysv, 0);
1850 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1851 svp = he ? &HeVAL(he) : NULL;
1853 if (!svp || *svp == &PL_sv_undef) {
1857 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1859 lv = sv_newmortal();
1860 sv_upgrade(lv, SVt_PVLV);
1862 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1863 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1864 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1870 if (HvNAME_get(hv) && isGV(*svp))
1871 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1872 else if (preeminent)
1873 save_helem_flags(hv, keysv, svp,
1874 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1876 SAVEHDELETE(hv, keysv);
1878 else if (PL_op->op_private & OPpDEREF)
1879 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1881 sv = (svp ? *svp : &PL_sv_undef);
1882 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1883 * was to make C<local $tied{foo} = $tied{foo}> possible.
1884 * However, it seems no longer to be needed for that purpose, and
1885 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1886 * would loop endlessly since the pos magic is getting set on the
1887 * mortal copy and lost. However, the copy has the effect of
1888 * triggering the get magic, and losing it altogether made things like
1889 * c<$tied{foo};> in void context no longer do get magic, which some
1890 * code relied on. Also, delayed triggering of magic on @+ and friends
1891 * meant the original regex may be out of scope by now. So as a
1892 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1893 * being called too many times). */
1894 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1903 register PERL_CONTEXT *cx;
1908 if (PL_op->op_flags & OPf_SPECIAL) {
1909 cx = &cxstack[cxstack_ix];
1910 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1915 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1918 if (gimme == G_VOID)
1920 else if (gimme == G_SCALAR) {
1924 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1927 *MARK = sv_mortalcopy(TOPs);
1930 *MARK = &PL_sv_undef;
1934 else if (gimme == G_ARRAY) {
1935 /* in case LEAVE wipes old return values */
1937 for (mark = newsp + 1; mark <= SP; mark++) {
1938 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1939 *mark = sv_mortalcopy(*mark);
1940 TAINT_NOT; /* Each item is independent */
1944 PL_curpm = newpm; /* Don't pop $1 et al till now */
1946 LEAVE_with_name("block");
1954 register PERL_CONTEXT *cx;
1957 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1958 bool av_is_stack = FALSE;
1961 cx = &cxstack[cxstack_ix];
1962 if (!CxTYPE_is_LOOP(cx))
1963 DIE(aTHX_ "panic: pp_iter");
1965 itersvp = CxITERVAR(cx);
1966 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1967 /* string increment */
1968 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1969 SV *end = cx->blk_loop.state_u.lazysv.end;
1970 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1971 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1973 const char *max = SvPV_const(end, maxlen);
1974 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1975 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1976 /* safe to reuse old SV */
1977 sv_setsv(*itersvp, cur);
1981 /* we need a fresh SV every time so that loop body sees a
1982 * completely new SV for closures/references to work as
1985 *itersvp = newSVsv(cur);
1986 SvREFCNT_dec(oldsv);
1988 if (strEQ(SvPVX_const(cur), max))
1989 sv_setiv(cur, 0); /* terminate next time */
1996 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1997 /* integer increment */
1998 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
2001 /* don't risk potential race */
2002 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
2003 /* safe to reuse old SV */
2004 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
2008 /* we need a fresh SV every time so that loop body sees a
2009 * completely new SV for closures/references to work as they
2012 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
2013 SvREFCNT_dec(oldsv);
2016 /* Handle end of range at IV_MAX */
2017 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
2018 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2020 cx->blk_loop.state_u.lazyiv.cur++;
2021 cx->blk_loop.state_u.lazyiv.end++;
2028 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2029 av = cx->blk_loop.state_u.ary.ary;
2034 if (PL_op->op_private & OPpITER_REVERSED) {
2035 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2036 ? cx->blk_loop.resetsp + 1 : 0))
2039 if (SvMAGICAL(av) || AvREIFY(av)) {
2040 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2041 sv = svp ? *svp : NULL;
2044 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2048 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2052 if (SvMAGICAL(av) || AvREIFY(av)) {
2053 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2054 sv = svp ? *svp : NULL;
2057 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2061 if (sv && SvIS_FREED(sv)) {
2063 Perl_croak(aTHX_ "Use of freed value in iteration");
2068 SvREFCNT_inc_simple_void_NN(sv);
2072 if (!av_is_stack && sv == &PL_sv_undef) {
2073 SV *lv = newSV_type(SVt_PVLV);
2075 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2076 LvTARG(lv) = SvREFCNT_inc_simple(av);
2077 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2078 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2084 SvREFCNT_dec(oldsv);
2090 A description of how taint works in pattern matching and substitution.
2092 While the pattern is being assembled/concatenated and them compiled,
2093 PL_tainted will get set if any component of the pattern is tainted, e.g.
2094 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
2095 is set on the pattern if PL_tainted is set.
2097 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2098 the pattern is marked as tainted. This means that subsequent usage, such
2099 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
2101 During execution of a pattern, locale-variant ops such as ALNUML set the
2102 local flag RF_tainted. At the end of execution, the engine sets the
2103 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2106 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2107 of $1 et al to indicate whether the returned value should be tainted.
2108 It is the responsibility of the caller of the pattern (i.e. pp_match,
2109 pp_subst etc) to set this flag for any other circumstances where $1 needs
2112 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2114 There are three possible sources of taint
2116 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2117 * the replacement string (or expression under /e)
2119 There are four destinations of taint and they are affected by the sources
2120 according to the rules below:
2122 * the return value (not including /r):
2123 tainted by the source string and pattern, but only for the
2124 number-of-iterations case; boolean returns aren't tainted;
2125 * the modified string (or modified copy under /r):
2126 tainted by the source string, pattern, and replacement strings;
2128 tainted by the pattern, and under 'use re "taint"', by the source
2130 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2131 should always be unset before executing subsequent code.
2133 The overall action of pp_subst is:
2135 * at the start, set bits in rxtainted indicating the taint status of
2136 the various sources.
2138 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2139 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2140 pattern has subsequently become tainted via locale ops.
2142 * If control is being passed to pp_substcont to execute a /e block,
2143 save rxtainted in the CXt_SUBST block, for future use by
2146 * Whenever control is being returned to perl code (either by falling
2147 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2148 use the flag bits in rxtainted to make all the appropriate types of
2149 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2150 et al will appear tainted.
2152 pp_match is just a simpler version of the above.
2159 register PMOP *pm = cPMOP;
2171 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2172 See "how taint works" above */
2175 register REGEXP *rx = PM_GETRE(pm);
2177 int force_on_match = 0;
2178 const I32 oldsave = PL_savestack_ix;
2180 bool doutf8 = FALSE;
2181 #ifdef PERL_OLD_COPY_ON_WRITE
2185 /* known replacement string? */
2186 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2190 if (PL_op->op_flags & OPf_STACKED)
2192 else if (PL_op->op_private & OPpTARGET_MY)
2199 /* In non-destructive replacement mode, duplicate target scalar so it
2200 * remains unchanged. */
2201 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2202 TARG = sv_2mortal(newSVsv(TARG));
2204 #ifdef PERL_OLD_COPY_ON_WRITE
2205 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2206 because they make integers such as 256 "false". */
2207 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2210 sv_force_normal_flags(TARG,0);
2213 #ifdef PERL_OLD_COPY_ON_WRITE
2217 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2218 || SvTYPE(TARG) > SVt_PVLV)
2219 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2220 Perl_croak_no_modify(aTHX);
2224 s = SvPV_mutable(TARG, len);
2225 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2228 /* only replace once? */
2229 once = !(rpm->op_pmflags & PMf_GLOBAL);
2231 /* See "how taint works" above */
2234 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2235 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2236 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2237 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2238 ? SUBST_TAINT_BOOLRET : 0));
2242 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2246 DIE(aTHX_ "panic: pp_subst");
2249 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2250 maxiters = 2 * slen + 10; /* We can match twice at each
2251 position, once with zero-length,
2252 second time with non-zero. */
2254 if (!RX_PRELEN(rx) && PL_curpm) {
2258 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2259 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2260 ? REXEC_COPY_STR : 0;
2262 r_flags |= REXEC_SCREAM;
2265 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2267 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2271 /* How to do it in subst? */
2272 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2274 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2275 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2276 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2277 && (r_flags & REXEC_SCREAM))))
2282 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2283 r_flags | REXEC_CHECKED))
2287 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2288 LEAVE_SCOPE(oldsave);
2292 /* known replacement string? */
2294 if (SvTAINTED(dstr))
2295 rxtainted |= SUBST_TAINT_REPL;
2297 /* Upgrade the source if the replacement is utf8 but the source is not,
2298 * but only if it matched; see
2299 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2301 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2302 char * const orig_pvx = SvPVX(TARG);
2303 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2305 /* If the lengths are the same, the pattern contains only
2306 * invariants, can keep going; otherwise, various internal markers
2307 * could be off, so redo */
2308 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2313 /* replacement needing upgrading? */
2314 if (DO_UTF8(TARG) && !doutf8) {
2315 nsv = sv_newmortal();
2318 sv_recode_to_utf8(nsv, PL_encoding);
2320 sv_utf8_upgrade(nsv);
2321 c = SvPV_const(nsv, clen);
2325 c = SvPV_const(dstr, clen);
2326 doutf8 = DO_UTF8(dstr);
2334 /* can do inplace substitution? */
2336 #ifdef PERL_OLD_COPY_ON_WRITE
2339 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2340 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2341 && (!doutf8 || SvUTF8(TARG)))
2344 #ifdef PERL_OLD_COPY_ON_WRITE
2345 if (SvIsCOW(TARG)) {
2346 assert (!force_on_match);
2350 if (force_on_match) {
2352 s = SvPV_force(TARG, len);
2357 SvSCREAM_off(TARG); /* disable possible screamer */
2359 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2360 rxtainted |= SUBST_TAINT_PAT;
2361 m = orig + RX_OFFS(rx)[0].start;
2362 d = orig + RX_OFFS(rx)[0].end;
2364 if (m - s > strend - d) { /* faster to shorten from end */
2366 Copy(c, m, clen, char);
2371 Move(d, m, i, char);
2375 SvCUR_set(TARG, m - s);
2377 else if ((i = m - s)) { /* faster from front */
2380 Move(s, d - i, i, char);
2383 Copy(c, m, clen, char);
2388 Copy(c, d, clen, char);
2394 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
2398 if (iters++ > maxiters)
2399 DIE(aTHX_ "Substitution loop");
2400 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2401 rxtainted |= SUBST_TAINT_PAT;
2402 m = RX_OFFS(rx)[0].start + orig;
2405 Move(s, d, i, char);
2409 Copy(c, d, clen, char);
2412 s = RX_OFFS(rx)[0].end + orig;
2413 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2415 /* don't match same null twice */
2416 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2419 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2420 Move(s, d, i+1, char); /* include the NUL */
2423 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2430 if (force_on_match) {
2432 s = SvPV_force(TARG, len);
2435 #ifdef PERL_OLD_COPY_ON_WRITE
2438 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2439 rxtainted |= SUBST_TAINT_PAT;
2440 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2443 register PERL_CONTEXT *cx;
2445 /* note that a whole bunch of local vars are saved here for
2446 * use by pp_substcont: here's a list of them in case you're
2447 * searching for places in this sub that uses a particular var:
2448 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2449 * s m strend rx once */
2451 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2453 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2455 if (iters++ > maxiters)
2456 DIE(aTHX_ "Substitution loop");
2457 if (RX_MATCH_TAINTED(rx))
2458 rxtainted |= SUBST_TAINT_PAT;
2459 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2462 orig = RX_SUBBEG(rx);
2464 strend = s + (strend - m);
2466 m = RX_OFFS(rx)[0].start + orig;
2467 if (doutf8 && !SvUTF8(dstr))
2468 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2470 sv_catpvn(dstr, s, m-s);
2471 s = RX_OFFS(rx)[0].end + orig;
2473 sv_catpvn(dstr, c, clen);
2476 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2477 TARG, NULL, r_flags));
2478 if (doutf8 && !DO_UTF8(TARG))
2479 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2481 sv_catpvn(dstr, s, strend - s);
2483 #ifdef PERL_OLD_COPY_ON_WRITE
2484 /* The match may make the string COW. If so, brilliant, because that's
2485 just saved us one malloc, copy and free - the regexp has donated
2486 the old buffer, and we malloc an entirely new one, rather than the
2487 regexp malloc()ing a buffer and copying our original, only for
2488 us to throw it away here during the substitution. */
2489 if (SvIsCOW(TARG)) {
2490 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2496 SvPV_set(TARG, SvPVX(dstr));
2497 SvCUR_set(TARG, SvCUR(dstr));
2498 SvLEN_set(TARG, SvLEN(dstr));
2499 doutf8 |= DO_UTF8(dstr);
2500 SvPV_set(dstr, NULL);
2503 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2508 (void)SvPOK_only_UTF8(TARG);
2512 /* See "how taint works" above */
2514 if ((rxtainted & SUBST_TAINT_PAT) ||
2515 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2516 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2518 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2520 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2521 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2523 SvTAINTED_on(TOPs); /* taint return value */
2525 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2527 /* needed for mg_set below */
2529 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2532 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2534 LEAVE_SCOPE(oldsave);
2543 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2544 ++*PL_markstack_ptr;
2546 LEAVE_with_name("grep_item"); /* exit inner scope */
2549 if (PL_stack_base + *PL_markstack_ptr > SP) {
2551 const I32 gimme = GIMME_V;
2553 LEAVE_with_name("grep"); /* exit outer scope */
2554 (void)POPMARK; /* pop src */
2555 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2556 (void)POPMARK; /* pop dst */
2557 SP = PL_stack_base + POPMARK; /* pop original mark */
2558 if (gimme == G_SCALAR) {
2559 if (PL_op->op_private & OPpGREP_LEX) {
2560 SV* const sv = sv_newmortal();
2561 sv_setiv(sv, items);
2569 else if (gimme == G_ARRAY)
2576 ENTER_with_name("grep_item"); /* enter inner scope */
2579 src = PL_stack_base[*PL_markstack_ptr];
2581 if (PL_op->op_private & OPpGREP_LEX)
2582 PAD_SVl(PL_op->op_targ) = src;
2586 RETURNOP(cLOGOP->op_other);
2597 register PERL_CONTEXT *cx;
2601 if (CxMULTICALL(&cxstack[cxstack_ix]))
2605 cxstack_ix++; /* temporarily protect top context */
2606 gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
2609 if (gimme == G_SCALAR) {
2612 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2613 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2614 *MARK = SvREFCNT_inc(TOPs);
2617 if (gmagic) SvGETMAGIC(*MARK);
2620 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2622 *MARK = sv_mortalcopy(sv);
2626 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2628 if (gmagic) SvGETMAGIC(TOPs);
2631 *MARK = sv_mortalcopy(TOPs);
2635 *MARK = &PL_sv_undef;
2639 else if (gimme == G_ARRAY) {
2640 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2641 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
2642 *MARK = sv_mortalcopy(*MARK);
2643 TAINT_NOT; /* Each item is independent */
2651 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2652 PL_curpm = newpm; /* ... and pop $1 et al */
2655 return cx->blk_sub.retop;
2658 /* This duplicates the above code because the above code must not
2659 * get any slower by more conditions */
2667 register PERL_CONTEXT *cx;
2670 if (CxMULTICALL(&cxstack[cxstack_ix]))
2674 cxstack_ix++; /* temporarily protect top context */
2678 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2679 /* We are an argument to a function or grep().
2680 * This kind of lvalueness was legal before lvalue
2681 * subroutines too, so be backward compatible:
2682 * cannot report errors. */
2684 /* Scalar context *is* possible, on the LHS of ->. */
2685 if (gimme == G_SCALAR)
2687 if (gimme == G_ARRAY) {
2689 if (!CvLVALUE(cx->blk_sub.cv))
2691 EXTEND_MORTAL(SP - newsp);
2692 for (mark = newsp + 1; mark <= SP; mark++) {
2695 else if (SvFLAGS(*mark) & SVs_PADTMP)
2696 *mark = sv_mortalcopy(*mark);
2698 /* Can be a localized value subject to deletion. */
2699 PL_tmps_stack[++PL_tmps_ix] = *mark;
2700 SvREFCNT_inc_void(*mark);
2705 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2706 /* Here we go for robustness, not for speed, so we change all
2707 * the refcounts so the caller gets a live guy. Cannot set
2708 * TEMP, so sv_2mortal is out of question. */
2709 if (!CvLVALUE(cx->blk_sub.cv)) {
2715 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2717 if (gimme == G_SCALAR) {
2721 if ((SvPADTMP(TOPs) ||
2722 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2725 !SvSMAGICAL(TOPs)) {
2731 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2732 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2733 : "a readonly value" : "a temporary");
2735 else { /* Can be a localized value
2736 * subject to deletion. */
2737 PL_tmps_stack[++PL_tmps_ix] = *mark;
2738 SvREFCNT_inc_void(*mark);
2742 /* sub:lvalue{} will take us here.
2743 Presumably the case of a non-empty array never happens.
2752 ? "Can't return undef from lvalue subroutine"
2753 : "Array returned from lvalue subroutine in scalar "
2760 else if (gimme == G_ARRAY) {
2761 EXTEND_MORTAL(SP - newsp);
2762 for (mark = newsp + 1; mark <= SP; mark++) {
2763 if (*mark != &PL_sv_undef
2765 || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
2769 /* Might be flattened array after $#array = */
2776 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2777 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2780 /* Can be a localized value subject to deletion. */
2781 PL_tmps_stack[++PL_tmps_ix] = *mark;
2782 SvREFCNT_inc_void(*mark);
2788 if (gimme == G_SCALAR) {
2792 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2793 *MARK = SvREFCNT_inc(TOPs);
2798 *MARK = SvTEMP(TOPs)
2800 : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs));
2804 *MARK = &PL_sv_undef;
2808 else if (gimme == G_ARRAY) {
2810 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2812 *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2817 if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2818 assert(gimme == G_SCALAR);
2822 if (cx->blk_sub.retop->op_type == OP_RV2SV)
2823 deref_type = OPpDEREF_SV;
2824 else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2825 deref_type = OPpDEREF_AV;
2827 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2828 deref_type = OPpDEREF_HV;
2830 vivify_ref(TOPs, deref_type);
2838 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2839 PL_curpm = newpm; /* ... and pop $1 et al */
2842 return cx->blk_sub.retop;
2850 register PERL_CONTEXT *cx;
2852 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2855 DIE(aTHX_ "Not a CODE reference");
2856 switch (SvTYPE(sv)) {
2857 /* This is overwhelming the most common case: */
2859 if (!isGV_with_GP(sv))
2860 DIE(aTHX_ "Not a CODE reference");
2862 if (!(cv = GvCVu((const GV *)sv))) {
2864 cv = sv_2cv(sv, &stash, &gv, 0);
2873 if(isGV_with_GP(sv)) goto we_have_a_glob;
2876 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2878 SP = PL_stack_base + POPMARK;
2886 sv = amagic_deref_call(sv, to_cv_amg);
2887 /* Don't SPAGAIN here. */
2893 sym = SvPV_nomg_const(sv, len);
2895 DIE(aTHX_ PL_no_usym, "a subroutine");
2896 if (PL_op->op_private & HINT_STRICT_REFS)
2897 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2898 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2901 cv = MUTABLE_CV(SvRV(sv));
2902 if (SvTYPE(cv) == SVt_PVCV)
2907 DIE(aTHX_ "Not a CODE reference");
2908 /* This is the second most common case: */
2910 cv = MUTABLE_CV(sv);
2918 if (CvCLONE(cv) && ! CvCLONED(cv))
2919 DIE(aTHX_ "Closure prototype called");
2920 if (!CvROOT(cv) && !CvXSUB(cv)) {
2924 /* anonymous or undef'd function leaves us no recourse */
2925 if (CvANON(cv) || !(gv = CvGV(cv)))
2926 DIE(aTHX_ "Undefined subroutine called");
2928 /* autoloaded stub? */
2929 if (cv != GvCV(gv)) {
2932 /* should call AUTOLOAD now? */
2935 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2942 sub_name = sv_newmortal();
2943 gv_efullname3(sub_name, gv, NULL);
2944 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2948 DIE(aTHX_ "Not a CODE reference");
2953 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2954 Perl_get_db_sub(aTHX_ &sv, cv);
2956 PL_curcopdb = PL_curcop;
2958 /* check for lsub that handles lvalue subroutines */
2959 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2960 /* if lsub not found then fall back to DB::sub */
2961 if (!cv) cv = GvCV(PL_DBsub);
2963 cv = GvCV(PL_DBsub);
2966 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2967 DIE(aTHX_ "No DB::sub routine defined");
2970 if (!(CvISXSUB(cv))) {
2971 /* This path taken at least 75% of the time */
2973 register I32 items = SP - MARK;
2974 AV* const padlist = CvPADLIST(cv);
2975 PUSHBLOCK(cx, CXt_SUB, MARK);
2977 cx->blk_sub.retop = PL_op->op_next;
2979 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2980 * that eval'' ops within this sub know the correct lexical space.
2981 * Owing the speed considerations, we choose instead to search for
2982 * the cv using find_runcv() when calling doeval().
2984 if (CvDEPTH(cv) >= 2) {
2985 PERL_STACK_OVERFLOW_CHECK();
2986 pad_push(padlist, CvDEPTH(cv));
2989 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2991 AV *const av = MUTABLE_AV(PAD_SVl(0));
2993 /* @_ is normally not REAL--this should only ever
2994 * happen when DB::sub() calls things that modify @_ */
2999 cx->blk_sub.savearray = GvAV(PL_defgv);
3000 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
3001 CX_CURPAD_SAVE(cx->blk_sub);
3002 cx->blk_sub.argarray = av;
3005 if (items > AvMAX(av) + 1) {
3006 SV **ary = AvALLOC(av);
3007 if (AvARRAY(av) != ary) {
3008 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
3011 if (items > AvMAX(av) + 1) {
3012 AvMAX(av) = items - 1;
3013 Renew(ary,items,SV*);
3018 Copy(MARK,AvARRAY(av),items,SV*);
3019 AvFILLp(av) = items - 1;
3027 /* warning must come *after* we fully set up the context
3028 * stuff so that __WARN__ handlers can safely dounwind()
3031 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3032 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3033 sub_crush_depth(cv);
3034 RETURNOP(CvSTART(cv));
3037 I32 markix = TOPMARK;
3042 /* Need to copy @_ to stack. Alternative may be to
3043 * switch stack to @_, and copy return values
3044 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3045 AV * const av = GvAV(PL_defgv);
3046 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
3049 /* Mark is at the end of the stack. */
3051 Copy(AvARRAY(av), SP + 1, items, SV*);
3056 /* We assume first XSUB in &DB::sub is the called one. */
3058 SAVEVPTR(PL_curcop);
3059 PL_curcop = PL_curcopdb;
3062 /* Do we need to open block here? XXXX */
3064 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3066 CvXSUB(cv)(aTHX_ cv);
3068 /* Enforce some sanity in scalar context. */
3069 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3070 if (markix > PL_stack_sp - PL_stack_base)
3071 *(PL_stack_base + markix) = &PL_sv_undef;
3073 *(PL_stack_base + markix) = *PL_stack_sp;
3074 PL_stack_sp = PL_stack_base + markix;
3082 Perl_sub_crush_depth(pTHX_ CV *cv)
3084 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3087 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3089 SV* const tmpstr = sv_newmortal();
3090 gv_efullname3(tmpstr, CvGV(cv), NULL);
3091 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3100 SV* const elemsv = POPs;
3101 IV elem = SvIV(elemsv);
3102 AV *const av = MUTABLE_AV(POPs);
3103 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3104 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3105 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3106 bool preeminent = TRUE;
3109 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3110 Perl_warner(aTHX_ packWARN(WARN_MISC),
3111 "Use of reference \"%"SVf"\" as array index",
3114 elem -= CopARYBASE_get(PL_curcop);
3115 if (SvTYPE(av) != SVt_PVAV)
3122 /* If we can determine whether the element exist,
3123 * Try to preserve the existenceness of a tied array
3124 * element by using EXISTS and DELETE if possible.
3125 * Fallback to FETCH and STORE otherwise. */
3126 if (SvCANEXISTDELETE(av))
3127 preeminent = av_exists(av, elem);
3130 svp = av_fetch(av, elem, lval && !defer);
3132 #ifdef PERL_MALLOC_WRAP
3133 if (SvUOK(elemsv)) {
3134 const UV uv = SvUV(elemsv);
3135 elem = uv > IV_MAX ? IV_MAX : uv;
3137 else if (SvNOK(elemsv))
3138 elem = (IV)SvNV(elemsv);
3140 static const char oom_array_extend[] =
3141 "Out of memory during array extend"; /* Duplicated in av.c */
3142 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3145 if (!svp || *svp == &PL_sv_undef) {
3148 DIE(aTHX_ PL_no_aelem, elem);
3149 lv = sv_newmortal();
3150 sv_upgrade(lv, SVt_PVLV);
3152 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3153 LvTARG(lv) = SvREFCNT_inc_simple(av);
3154 LvTARGOFF(lv) = elem;
3161 save_aelem(av, elem, svp);
3163 SAVEADELETE(av, elem);
3165 else if (PL_op->op_private & OPpDEREF)
3166 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3168 sv = (svp ? *svp : &PL_sv_undef);
3169 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3176 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3178 PERL_ARGS_ASSERT_VIVIFY_REF;
3183 Perl_croak_no_modify(aTHX);
3184 prepare_SV_for_RV(sv);
3187 SvRV_set(sv, newSV(0));
3190 SvRV_set(sv, MUTABLE_SV(newAV()));
3193 SvRV_set(sv, MUTABLE_SV(newHV()));
3204 SV* const sv = TOPs;
3207 SV* const rsv = SvRV(sv);
3208 if (SvTYPE(rsv) == SVt_PVCV) {
3214 SETs(method_common(sv, NULL));
3221 SV* const sv = cSVOP_sv;
3222 U32 hash = SvSHARED_HASH(sv);
3224 XPUSHs(method_common(sv, &hash));
3229 S_method_common(pTHX_ SV* meth, U32* hashp)
3235 const char* packname = NULL;
3238 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3240 PERL_ARGS_ASSERT_METHOD_COMMON;
3243 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3248 ob = MUTABLE_SV(SvRV(sv));
3252 /* this isn't a reference */
3253 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3254 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3256 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3263 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3264 !(ob=MUTABLE_SV(GvIO(iogv))))
3266 /* this isn't the name of a filehandle either */
3268 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3269 ? !isIDFIRST_utf8((U8*)packname)
3270 : !isIDFIRST(*packname)
3273 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3275 SvOK(sv) ? "without a package or object reference"
3276 : "on an undefined value");
3278 /* assume it's a package name */
3279 stash = gv_stashpvn(packname, packlen, 0);
3283 SV* const ref = newSViv(PTR2IV(stash));
3284 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3288 /* it _is_ a filehandle name -- replace with a reference */
3289 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3292 /* if we got here, ob should be a reference or a glob */
3293 if (!ob || !(SvOBJECT(ob)
3294 || (SvTYPE(ob) == SVt_PVGV
3296 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3299 const char * const name = SvPV_nolen_const(meth);
3300 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3301 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3305 stash = SvSTASH(ob);
3308 /* NOTE: stash may be null, hope hv_fetch_ent and
3309 gv_fetchmethod can cope (it seems they can) */
3311 /* shortcut for simple names */
3313 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3315 gv = MUTABLE_GV(HeVAL(he));
3316 if (isGV(gv) && GvCV(gv) &&
3317 (!GvCVGEN(gv) || GvCVGEN(gv)
3318 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3319 return MUTABLE_SV(GvCV(gv));
3323 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3324 SvPV_nolen_const(meth),
3325 GV_AUTOLOAD | GV_CROAK);
3329 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3334 * c-indentation-style: bsd
3336 * indent-tabs-mode: t
3339 * ex: set ts=8 sts=4 sw=4 noet: