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_utf8(m, s-m, DO_UTF8(TARG));
2444 register PERL_CONTEXT *cx;
2446 /* note that a whole bunch of local vars are saved here for
2447 * use by pp_substcont: here's a list of them in case you're
2448 * searching for places in this sub that uses a particular var:
2449 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2450 * s m strend rx once */
2452 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2454 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2456 if (iters++ > maxiters)
2457 DIE(aTHX_ "Substitution loop");
2458 if (RX_MATCH_TAINTED(rx))
2459 rxtainted |= SUBST_TAINT_PAT;
2460 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2463 orig = RX_SUBBEG(rx);
2465 strend = s + (strend - m);
2467 m = RX_OFFS(rx)[0].start + orig;
2468 if (doutf8 && !SvUTF8(dstr))
2469 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2471 sv_catpvn(dstr, s, m-s);
2472 s = RX_OFFS(rx)[0].end + orig;
2474 sv_catpvn(dstr, c, clen);
2477 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2478 TARG, NULL, r_flags));
2479 if (doutf8 && !DO_UTF8(TARG))
2480 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2482 sv_catpvn(dstr, s, strend - s);
2484 #ifdef PERL_OLD_COPY_ON_WRITE
2485 /* The match may make the string COW. If so, brilliant, because that's
2486 just saved us one malloc, copy and free - the regexp has donated
2487 the old buffer, and we malloc an entirely new one, rather than the
2488 regexp malloc()ing a buffer and copying our original, only for
2489 us to throw it away here during the substitution. */
2490 if (SvIsCOW(TARG)) {
2491 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2497 SvPV_set(TARG, SvPVX(dstr));
2498 SvCUR_set(TARG, SvCUR(dstr));
2499 SvLEN_set(TARG, SvLEN(dstr));
2500 doutf8 |= DO_UTF8(dstr);
2501 SvPV_set(dstr, NULL);
2504 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2509 (void)SvPOK_only_UTF8(TARG);
2513 /* See "how taint works" above */
2515 if ((rxtainted & SUBST_TAINT_PAT) ||
2516 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2517 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2519 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2521 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2522 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2524 SvTAINTED_on(TOPs); /* taint return value */
2526 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2528 /* needed for mg_set below */
2530 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2533 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2535 LEAVE_SCOPE(oldsave);
2544 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2545 ++*PL_markstack_ptr;
2547 LEAVE_with_name("grep_item"); /* exit inner scope */
2550 if (PL_stack_base + *PL_markstack_ptr > SP) {
2552 const I32 gimme = GIMME_V;
2554 LEAVE_with_name("grep"); /* exit outer scope */
2555 (void)POPMARK; /* pop src */
2556 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2557 (void)POPMARK; /* pop dst */
2558 SP = PL_stack_base + POPMARK; /* pop original mark */
2559 if (gimme == G_SCALAR) {
2560 if (PL_op->op_private & OPpGREP_LEX) {
2561 SV* const sv = sv_newmortal();
2562 sv_setiv(sv, items);
2570 else if (gimme == G_ARRAY)
2577 ENTER_with_name("grep_item"); /* enter inner scope */
2580 src = PL_stack_base[*PL_markstack_ptr];
2582 if (PL_op->op_private & OPpGREP_LEX)
2583 PAD_SVl(PL_op->op_targ) = src;
2587 RETURNOP(cLOGOP->op_other);
2598 register PERL_CONTEXT *cx;
2602 if (CxMULTICALL(&cxstack[cxstack_ix]))
2606 cxstack_ix++; /* temporarily protect top context */
2607 gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
2610 if (gimme == G_SCALAR) {
2613 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2615 *MARK = SvREFCNT_inc(TOPs);
2618 if (gmagic) SvGETMAGIC(*MARK);
2621 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2623 *MARK = sv_mortalcopy(sv);
2627 else if (SvTEMP(TOPs)) {
2629 if (gmagic) SvGETMAGIC(TOPs);
2632 *MARK = sv_mortalcopy(TOPs);
2636 *MARK = &PL_sv_undef;
2640 else if (gimme == G_ARRAY) {
2641 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2642 if (!SvTEMP(*MARK)) {
2643 *MARK = sv_mortalcopy(*MARK);
2644 TAINT_NOT; /* Each item is independent */
2652 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2653 PL_curpm = newpm; /* ... and pop $1 et al */
2656 return cx->blk_sub.retop;
2659 /* This duplicates the above code because the above code must not
2660 * get any slower by more conditions */
2668 register PERL_CONTEXT *cx;
2671 if (CxMULTICALL(&cxstack[cxstack_ix]))
2675 cxstack_ix++; /* temporarily protect top context */
2679 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2680 /* We are an argument to a function or grep().
2681 * This kind of lvalueness was legal before lvalue
2682 * subroutines too, so be backward compatible:
2683 * cannot report errors. */
2685 /* Scalar context *is* possible, on the LHS of ->. */
2686 if (gimme == G_SCALAR)
2688 if (gimme == G_ARRAY) {
2690 if (!CvLVALUE(cx->blk_sub.cv))
2692 EXTEND_MORTAL(SP - newsp);
2693 for (mark = newsp + 1; mark <= SP; mark++) {
2696 else if (SvFLAGS(*mark) & SVs_PADTMP
2697 || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
2699 *mark = sv_mortalcopy(*mark);
2701 /* Can be a localized value subject to deletion. */
2702 PL_tmps_stack[++PL_tmps_ix] = *mark;
2703 SvREFCNT_inc_void(*mark);
2708 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2709 /* Here we go for robustness, not for speed, so we change all
2710 * the refcounts so the caller gets a live guy. Cannot set
2711 * TEMP, so sv_2mortal is out of question. */
2712 if (!CvLVALUE(cx->blk_sub.cv)) {
2718 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2720 if (gimme == G_SCALAR) {
2724 if ((SvPADTMP(TOPs) ||
2725 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2728 !SvSMAGICAL(TOPs)) {
2734 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2735 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2736 : "a readonly value" : "a temporary");
2738 else { /* Can be a localized value
2739 * subject to deletion. */
2740 PL_tmps_stack[++PL_tmps_ix] = *mark;
2741 SvREFCNT_inc_void(*mark);
2745 /* sub:lvalue{} will take us here.
2746 Presumably the case of a non-empty array never happens.
2755 ? "Can't return undef from lvalue subroutine"
2756 : "Array returned from lvalue subroutine in scalar "
2763 else if (gimme == G_ARRAY) {
2764 EXTEND_MORTAL(SP - newsp);
2765 for (mark = newsp + 1; mark <= SP; mark++) {
2766 if (*mark != &PL_sv_undef
2768 || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE))
2772 /* Might be flattened array after $#array = */
2779 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2780 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2783 /* Can be a localized value subject to deletion. */
2784 PL_tmps_stack[++PL_tmps_ix] = *mark;
2785 SvREFCNT_inc_void(*mark);
2791 if (gimme == G_SCALAR) {
2795 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2796 *MARK = SvREFCNT_inc(TOPs);
2801 *MARK = SvTEMP(TOPs)
2803 : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs));
2807 *MARK = &PL_sv_undef;
2811 else if (gimme == G_ARRAY) {
2813 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2815 *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2820 if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2821 assert(gimme == G_SCALAR);
2825 if (cx->blk_sub.retop->op_type == OP_RV2SV)
2826 deref_type = OPpDEREF_SV;
2827 else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2828 deref_type = OPpDEREF_AV;
2830 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2831 deref_type = OPpDEREF_HV;
2833 vivify_ref(TOPs, deref_type);
2841 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2842 PL_curpm = newpm; /* ... and pop $1 et al */
2845 return cx->blk_sub.retop;
2853 register PERL_CONTEXT *cx;
2855 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2858 DIE(aTHX_ "Not a CODE reference");
2859 switch (SvTYPE(sv)) {
2860 /* This is overwhelming the most common case: */
2862 if (!isGV_with_GP(sv))
2863 DIE(aTHX_ "Not a CODE reference");
2865 if (!(cv = GvCVu((const GV *)sv))) {
2867 cv = sv_2cv(sv, &stash, &gv, 0);
2876 if(isGV_with_GP(sv)) goto we_have_a_glob;
2879 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2881 SP = PL_stack_base + POPMARK;
2889 sv = amagic_deref_call(sv, to_cv_amg);
2890 /* Don't SPAGAIN here. */
2896 sym = SvPV_nomg_const(sv, len);
2898 DIE(aTHX_ PL_no_usym, "a subroutine");
2899 if (PL_op->op_private & HINT_STRICT_REFS)
2900 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2901 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2904 cv = MUTABLE_CV(SvRV(sv));
2905 if (SvTYPE(cv) == SVt_PVCV)
2910 DIE(aTHX_ "Not a CODE reference");
2911 /* This is the second most common case: */
2913 cv = MUTABLE_CV(sv);
2921 if (CvCLONE(cv) && ! CvCLONED(cv))
2922 DIE(aTHX_ "Closure prototype called");
2923 if (!CvROOT(cv) && !CvXSUB(cv)) {
2927 /* anonymous or undef'd function leaves us no recourse */
2928 if (CvANON(cv) || !(gv = CvGV(cv)))
2929 DIE(aTHX_ "Undefined subroutine called");
2931 /* autoloaded stub? */
2932 if (cv != GvCV(gv)) {
2935 /* should call AUTOLOAD now? */
2938 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2945 sub_name = sv_newmortal();
2946 gv_efullname3(sub_name, gv, NULL);
2947 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2951 DIE(aTHX_ "Not a CODE reference");
2956 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2957 Perl_get_db_sub(aTHX_ &sv, cv);
2959 PL_curcopdb = PL_curcop;
2961 /* check for lsub that handles lvalue subroutines */
2962 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2963 /* if lsub not found then fall back to DB::sub */
2964 if (!cv) cv = GvCV(PL_DBsub);
2966 cv = GvCV(PL_DBsub);
2969 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2970 DIE(aTHX_ "No DB::sub routine defined");
2973 if (!(CvISXSUB(cv))) {
2974 /* This path taken at least 75% of the time */
2976 register I32 items = SP - MARK;
2977 AV* const padlist = CvPADLIST(cv);
2978 PUSHBLOCK(cx, CXt_SUB, MARK);
2980 cx->blk_sub.retop = PL_op->op_next;
2982 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2983 * that eval'' ops within this sub know the correct lexical space.
2984 * Owing the speed considerations, we choose instead to search for
2985 * the cv using find_runcv() when calling doeval().
2987 if (CvDEPTH(cv) >= 2) {
2988 PERL_STACK_OVERFLOW_CHECK();
2989 pad_push(padlist, CvDEPTH(cv));
2992 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2994 AV *const av = MUTABLE_AV(PAD_SVl(0));
2996 /* @_ is normally not REAL--this should only ever
2997 * happen when DB::sub() calls things that modify @_ */
3002 cx->blk_sub.savearray = GvAV(PL_defgv);
3003 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
3004 CX_CURPAD_SAVE(cx->blk_sub);
3005 cx->blk_sub.argarray = av;
3008 if (items > AvMAX(av) + 1) {
3009 SV **ary = AvALLOC(av);
3010 if (AvARRAY(av) != ary) {
3011 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
3014 if (items > AvMAX(av) + 1) {
3015 AvMAX(av) = items - 1;
3016 Renew(ary,items,SV*);
3021 Copy(MARK,AvARRAY(av),items,SV*);
3022 AvFILLp(av) = items - 1;
3030 /* warning must come *after* we fully set up the context
3031 * stuff so that __WARN__ handlers can safely dounwind()
3034 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3035 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3036 sub_crush_depth(cv);
3037 RETURNOP(CvSTART(cv));
3040 I32 markix = TOPMARK;
3045 /* Need to copy @_ to stack. Alternative may be to
3046 * switch stack to @_, and copy return values
3047 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3048 AV * const av = GvAV(PL_defgv);
3049 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
3052 /* Mark is at the end of the stack. */
3054 Copy(AvARRAY(av), SP + 1, items, SV*);
3059 /* We assume first XSUB in &DB::sub is the called one. */
3061 SAVEVPTR(PL_curcop);
3062 PL_curcop = PL_curcopdb;
3065 /* Do we need to open block here? XXXX */
3067 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3069 CvXSUB(cv)(aTHX_ cv);
3071 /* Enforce some sanity in scalar context. */
3072 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3073 if (markix > PL_stack_sp - PL_stack_base)
3074 *(PL_stack_base + markix) = &PL_sv_undef;
3076 *(PL_stack_base + markix) = *PL_stack_sp;
3077 PL_stack_sp = PL_stack_base + markix;
3085 Perl_sub_crush_depth(pTHX_ CV *cv)
3087 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3090 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3092 SV* const tmpstr = sv_newmortal();
3093 gv_efullname3(tmpstr, CvGV(cv), NULL);
3094 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3103 SV* const elemsv = POPs;
3104 IV elem = SvIV(elemsv);
3105 AV *const av = MUTABLE_AV(POPs);
3106 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3107 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3108 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3109 bool preeminent = TRUE;
3112 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3113 Perl_warner(aTHX_ packWARN(WARN_MISC),
3114 "Use of reference \"%"SVf"\" as array index",
3117 elem -= CopARYBASE_get(PL_curcop);
3118 if (SvTYPE(av) != SVt_PVAV)
3125 /* If we can determine whether the element exist,
3126 * Try to preserve the existenceness of a tied array
3127 * element by using EXISTS and DELETE if possible.
3128 * Fallback to FETCH and STORE otherwise. */
3129 if (SvCANEXISTDELETE(av))
3130 preeminent = av_exists(av, elem);
3133 svp = av_fetch(av, elem, lval && !defer);
3135 #ifdef PERL_MALLOC_WRAP
3136 if (SvUOK(elemsv)) {
3137 const UV uv = SvUV(elemsv);
3138 elem = uv > IV_MAX ? IV_MAX : uv;
3140 else if (SvNOK(elemsv))
3141 elem = (IV)SvNV(elemsv);
3143 static const char oom_array_extend[] =
3144 "Out of memory during array extend"; /* Duplicated in av.c */
3145 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3148 if (!svp || *svp == &PL_sv_undef) {
3151 DIE(aTHX_ PL_no_aelem, elem);
3152 lv = sv_newmortal();
3153 sv_upgrade(lv, SVt_PVLV);
3155 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3156 LvTARG(lv) = SvREFCNT_inc_simple(av);
3157 LvTARGOFF(lv) = elem;
3164 save_aelem(av, elem, svp);
3166 SAVEADELETE(av, elem);
3168 else if (PL_op->op_private & OPpDEREF)
3169 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3171 sv = (svp ? *svp : &PL_sv_undef);
3172 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3179 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3181 PERL_ARGS_ASSERT_VIVIFY_REF;
3186 Perl_croak_no_modify(aTHX);
3187 prepare_SV_for_RV(sv);
3190 SvRV_set(sv, newSV(0));
3193 SvRV_set(sv, MUTABLE_SV(newAV()));
3196 SvRV_set(sv, MUTABLE_SV(newHV()));
3207 SV* const sv = TOPs;
3210 SV* const rsv = SvRV(sv);
3211 if (SvTYPE(rsv) == SVt_PVCV) {
3217 SETs(method_common(sv, NULL));
3224 SV* const sv = cSVOP_sv;
3225 U32 hash = SvSHARED_HASH(sv);
3227 XPUSHs(method_common(sv, &hash));
3232 S_method_common(pTHX_ SV* meth, U32* hashp)
3238 const char* packname = NULL;
3241 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3243 PERL_ARGS_ASSERT_METHOD_COMMON;
3246 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3251 ob = MUTABLE_SV(SvRV(sv));
3255 /* this isn't a reference */
3256 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3257 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3259 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3266 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3267 !(ob=MUTABLE_SV(GvIO(iogv))))
3269 /* this isn't the name of a filehandle either */
3271 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3272 ? !isIDFIRST_utf8((U8*)packname)
3273 : !isIDFIRST(*packname)
3276 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3278 SvOK(sv) ? "without a package or object reference"
3279 : "on an undefined value");
3281 /* assume it's a package name */
3282 stash = gv_stashpvn(packname, packlen, 0);
3286 SV* const ref = newSViv(PTR2IV(stash));
3287 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3291 /* it _is_ a filehandle name -- replace with a reference */
3292 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3295 /* if we got here, ob should be a reference or a glob */
3296 if (!ob || !(SvOBJECT(ob)
3297 || (SvTYPE(ob) == SVt_PVGV
3299 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3302 const char * const name = SvPV_nolen_const(meth);
3303 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3304 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3308 stash = SvSTASH(ob);
3311 /* NOTE: stash may be null, hope hv_fetch_ent and
3312 gv_fetchmethod can cope (it seems they can) */
3314 /* shortcut for simple names */
3316 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3318 gv = MUTABLE_GV(HeVAL(he));
3319 if (isGV(gv) && GvCV(gv) &&
3320 (!GvCVGEN(gv) || GvCVGEN(gv)
3321 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3322 return MUTABLE_SV(GvCV(gv));
3326 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3327 SvPV_nolen_const(meth),
3328 GV_AUTOLOAD | GV_CROAK);
3332 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3337 * c-indentation-style: bsd
3339 * indent-tabs-mode: t
3342 * ex: set ts=8 sts=4 sw=4 noet: