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;
117 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
118 SV * const temp = left;
119 left = right; right = temp;
121 if (PL_tainting && PL_tainted && !SvTAINTED(left))
123 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
124 SV * const cv = SvRV(left);
125 const U32 cv_type = SvTYPE(cv);
126 const U32 gv_type = SvTYPE(right);
127 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
133 /* Can do the optimisation if right (LVALUE) is not a typeglob,
134 left (RVALUE) is a reference to something, and we're in void
136 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
137 /* Is the target symbol table currently empty? */
138 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
139 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
140 /* Good. Create a new proxy constant subroutine in the target.
141 The gv becomes a(nother) reference to the constant. */
142 SV *const value = SvRV(cv);
144 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
145 SvPCS_IMPORTED_on(gv);
147 SvREFCNT_inc_simple_void(value);
153 /* Need to fix things up. */
154 if (gv_type != SVt_PVGV) {
155 /* Need to fix GV. */
156 right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
160 /* We've been returned a constant rather than a full subroutine,
161 but they expect a subroutine reference to apply. */
163 ENTER_with_name("sassign_coderef");
164 SvREFCNT_inc_void(SvRV(cv));
165 /* newCONSTSUB takes a reference count on the passed in SV
166 from us. We set the name to NULL, otherwise we get into
167 all sorts of fun as the reference to our new sub is
168 donated to the GV that we're about to assign to.
170 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
173 LEAVE_with_name("sassign_coderef");
175 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
177 First: ops for \&{"BONK"}; return us the constant in the
179 Second: ops for *{"BONK"} cause that symbol table entry
180 (and our reference to it) to be upgraded from RV
182 Thirdly: We get here. cv is actually PVGV now, and its
183 GvCV() is actually the subroutine we're looking for
185 So change the reference so that it points to the subroutine
186 of that typeglob, as that's what they were after all along.
188 GV *const upgraded = MUTABLE_GV(cv);
189 CV *const source = GvCV(upgraded);
192 assert(CvFLAGS(source) & CVf_CONST);
194 SvREFCNT_inc_void(source);
195 SvREFCNT_dec(upgraded);
196 SvRV_set(left, MUTABLE_SV(source));
201 /* Allow glob assignments like *$x = ..., which, when the glob has a
202 SVf_FAKE flag, cannot be distinguished from $x = ... without looking
204 if( SvTYPE(right) == SVt_PVGV && cBINOP->op_last->op_type == OP_RV2GV
205 && (wasfake = SvFLAGS(right) & SVf_FAKE) )
206 SvFLAGS(right) &= ~SVf_FAKE;
207 SvSetMagicSV(right, left);
208 if(wasfake) SvFLAGS(right) |= SVf_FAKE;
218 RETURNOP(cLOGOP->op_other);
220 RETURNOP(cLOGOP->op_next);
228 TAINT_NOT; /* Each statement is presumed innocent */
229 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
231 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 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) {
286 sv_utf8_upgrade_nomg(TARG);
289 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
290 sv_utf8_upgrade_nomg(right);
291 rpv = SvPV_nomg_const(right, rlen);
294 sv_catpvn_nomg(TARG, rpv, rlen);
305 if (PL_op->op_flags & OPf_MOD) {
306 if (PL_op->op_private & OPpLVAL_INTRO)
307 if (!(PL_op->op_private & OPpPAD_STATE))
308 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
309 if (PL_op->op_private & OPpDEREF) {
311 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
321 dSP; SvGETMAGIC(TOPs);
322 tryAMAGICunTARGET(iter, 0);
323 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
324 if (!isGV_with_GP(PL_last_in_gv)) {
325 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
326 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
329 XPUSHs(MUTABLE_SV(PL_last_in_gv));
332 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
335 return do_readline();
341 tryAMAGICbin_MG(eq_amg, AMGf_set);
342 #ifndef NV_PRESERVES_UV
343 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
345 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
349 #ifdef PERL_PRESERVE_IVUV
350 SvIV_please_nomg(TOPs);
352 /* Unless the left argument is integer in range we are going
353 to have to use NV maths. Hence only attempt to coerce the
354 right argument if we know the left is integer. */
355 SvIV_please_nomg(TOPm1s);
357 const bool auvok = SvUOK(TOPm1s);
358 const bool buvok = SvUOK(TOPs);
360 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
361 /* Casting IV to UV before comparison isn't going to matter
362 on 2s complement. On 1s complement or sign&magnitude
363 (if we have any of them) it could to make negative zero
364 differ from normal zero. As I understand it. (Need to
365 check - is negative zero implementation defined behaviour
367 const UV buv = SvUVX(POPs);
368 const UV auv = SvUVX(TOPs);
370 SETs(boolSV(auv == buv));
373 { /* ## Mixed IV,UV ## */
377 /* == is commutative so doesn't matter which is left or right */
379 /* top of stack (b) is the iv */
388 /* As uv is a UV, it's >0, so it cannot be == */
391 /* we know iv is >= 0 */
392 SETs(boolSV((UV)iv == SvUVX(uvp)));
399 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
401 if (Perl_isnan(left) || Perl_isnan(right))
403 SETs(boolSV(left == right));
406 SETs(boolSV(SvNV_nomg(TOPs) == value));
415 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
416 Perl_croak_no_modify(aTHX);
417 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
418 && SvIVX(TOPs) != IV_MAX)
420 SvIV_set(TOPs, SvIVX(TOPs) + 1);
421 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
423 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
436 if (PL_op->op_type == OP_OR)
438 RETURNOP(cLOGOP->op_other);
447 const int op_type = PL_op->op_type;
448 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
453 if (!sv || !SvANY(sv)) {
454 if (op_type == OP_DOR)
456 RETURNOP(cLOGOP->op_other);
462 if (!sv || !SvANY(sv))
467 switch (SvTYPE(sv)) {
469 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
473 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
477 if (CvROOT(sv) || CvXSUB(sv))
490 if(op_type == OP_DOR)
492 RETURNOP(cLOGOP->op_other);
494 /* assuming OP_DEFINED */
502 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
503 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
507 useleft = USE_LEFT(svl);
508 #ifdef PERL_PRESERVE_IVUV
509 /* We must see if we can perform the addition with integers if possible,
510 as the integer code detects overflow while the NV code doesn't.
511 If either argument hasn't had a numeric conversion yet attempt to get
512 the IV. It's important to do this now, rather than just assuming that
513 it's not IOK as a PV of "9223372036854775806" may not take well to NV
514 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
515 integer in case the second argument is IV=9223372036854775806
516 We can (now) rely on sv_2iv to do the right thing, only setting the
517 public IOK flag if the value in the NV (or PV) slot is truly integer.
519 A side effect is that this also aggressively prefers integer maths over
520 fp maths for integer values.
522 How to detect overflow?
524 C 99 section 6.2.6.1 says
526 The range of nonnegative values of a signed integer type is a subrange
527 of the corresponding unsigned integer type, and the representation of
528 the same value in each type is the same. A computation involving
529 unsigned operands can never overflow, because a result that cannot be
530 represented by the resulting unsigned integer type is reduced modulo
531 the number that is one greater than the largest value that can be
532 represented by the resulting type.
536 which I read as "unsigned ints wrap."
538 signed integer overflow seems to be classed as "exception condition"
540 If an exceptional condition occurs during the evaluation of an
541 expression (that is, if the result is not mathematically defined or not
542 in the range of representable values for its type), the behavior is
545 (6.5, the 5th paragraph)
547 I had assumed that on 2s complement machines signed arithmetic would
548 wrap, hence coded pp_add and pp_subtract on the assumption that
549 everything perl builds on would be happy. After much wailing and
550 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
551 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
552 unsigned code below is actually shorter than the old code. :-)
555 SvIV_please_nomg(svr);
558 /* Unless the left argument is integer in range we are going to have to
559 use NV maths. Hence only attempt to coerce the right argument if
560 we know the left is integer. */
568 /* left operand is undef, treat as zero. + 0 is identity,
569 Could SETi or SETu right now, but space optimise by not adding
570 lots of code to speed up what is probably a rarish case. */
572 /* Left operand is defined, so is it IV? */
573 SvIV_please_nomg(svl);
575 if ((auvok = SvUOK(svl)))
578 register const IV aiv = SvIVX(svl);
581 auvok = 1; /* Now acting as a sign flag. */
582 } else { /* 2s complement assumption for IV_MIN */
590 bool result_good = 0;
593 bool buvok = SvUOK(svr);
598 register const IV biv = SvIVX(svr);
605 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
606 else "IV" now, independent of how it came in.
607 if a, b represents positive, A, B negative, a maps to -A etc
612 all UV maths. negate result if A negative.
613 add if signs same, subtract if signs differ. */
619 /* Must get smaller */
625 /* result really should be -(auv-buv). as its negation
626 of true value, need to swap our result flag */
643 if (result <= (UV)IV_MIN)
646 /* result valid, but out of range for IV. */
651 } /* Overflow, drop through to NVs. */
656 NV value = SvNV_nomg(svr);
659 /* left operand is undef, treat as zero. + 0.0 is identity. */
663 SETn( value + SvNV_nomg(svl) );
671 AV * const av = PL_op->op_flags & OPf_SPECIAL
672 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
673 const U32 lval = PL_op->op_flags & OPf_MOD;
674 SV** const svp = av_fetch(av, PL_op->op_private, lval);
675 SV *sv = (svp ? *svp : &PL_sv_undef);
677 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
685 dVAR; dSP; dMARK; dTARGET;
687 do_join(TARG, *MARK, MARK, SP);
698 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
699 * will be enough to hold an OP*.
701 SV* const sv = sv_newmortal();
702 sv_upgrade(sv, SVt_PVLV);
704 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
707 XPUSHs(MUTABLE_SV(PL_op));
712 /* Oversized hot code. */
716 dVAR; dSP; dMARK; dORIGMARK;
721 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
723 if (gv && (io = GvIO(gv))
724 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
727 if (MARK == ORIGMARK) {
728 /* If using default handle then we need to make space to
729 * pass object as 1st arg, so move other args up ...
733 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
737 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
739 ENTER_with_name("call_PRINT");
740 if( PL_op->op_type == OP_SAY ) {
741 /* local $\ = "\n" */
742 SAVEGENERICSV(PL_ors_sv);
743 PL_ors_sv = newSVpvs("\n");
745 call_method("PRINT", G_SCALAR);
746 LEAVE_with_name("call_PRINT");
753 if (!(io = GvIO(gv))) {
754 if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
755 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
757 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
758 report_evil_fh(gv, io, PL_op->op_type);
759 SETERRNO(EBADF,RMS_IFI);
762 else if (!(fp = IoOFP(io))) {
763 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
765 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
766 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
767 report_evil_fh(gv, io, PL_op->op_type);
769 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
773 SV * const ofs = GvSV(PL_ofsgv); /* $, */
775 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
777 if (!do_print(*MARK, fp))
781 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
782 if (!do_print(GvSV(PL_ofsgv), fp)) {
791 if (!do_print(*MARK, fp))
799 if (PL_op->op_type == OP_SAY) {
800 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
803 else if (PL_ors_sv && SvOK(PL_ors_sv))
804 if (!do_print(PL_ors_sv, fp)) /* $\ */
807 if (IoFLAGS(io) & IOf_FLUSH)
808 if (PerlIO_flush(fp) == EOF)
818 XPUSHs(&PL_sv_undef);
825 const I32 gimme = GIMME_V;
826 static const char an_array[] = "an ARRAY";
827 static const char a_hash[] = "a HASH";
828 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
829 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
831 if (!(PL_op->op_private & OPpDEREFed))
834 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
837 if (SvTYPE(sv) != type)
838 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
839 if (PL_op->op_flags & OPf_REF) {
844 if (gimme != G_ARRAY)
845 goto croak_cant_return;
849 else if (PL_op->op_flags & OPf_MOD
850 && PL_op->op_private & OPpLVAL_INTRO)
851 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
854 if (SvTYPE(sv) == type) {
855 if (PL_op->op_flags & OPf_REF) {
860 if (gimme != G_ARRAY)
861 goto croak_cant_return;
869 if (!isGV_with_GP(sv)) {
870 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
878 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
879 if (PL_op->op_private & OPpLVAL_INTRO)
880 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
881 if (PL_op->op_flags & OPf_REF) {
886 if (gimme != G_ARRAY)
887 goto croak_cant_return;
895 AV *const av = MUTABLE_AV(sv);
896 /* The guts of pp_rv2av, with no intenting change to preserve history
897 (until such time as we get tools that can do blame annotation across
898 whitespace changes. */
899 if (gimme == G_ARRAY) {
900 const I32 maxarg = AvFILL(av) + 1;
901 (void)POPs; /* XXXX May be optimized away? */
903 if (SvRMAGICAL(av)) {
905 for (i=0; i < (U32)maxarg; i++) {
906 SV ** const svp = av_fetch(av, i, FALSE);
907 /* See note in pp_helem, and bug id #27839 */
909 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
914 Copy(AvARRAY(av), SP+1, maxarg, SV*);
918 else if (gimme == G_SCALAR) {
920 const I32 maxarg = AvFILL(av) + 1;
924 /* The guts of pp_rv2hv */
925 if (gimme == G_ARRAY) { /* array wanted */
929 else if (gimme == G_SCALAR) {
931 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
939 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
940 is_pp_rv2av ? "array" : "hash");
945 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
949 PERL_ARGS_ASSERT_DO_ODDBALL;
955 if (ckWARN(WARN_MISC)) {
957 if (relem == firstrelem &&
959 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
960 SvTYPE(SvRV(*relem)) == SVt_PVHV))
962 err = "Reference found where even-sized list expected";
965 err = "Odd number of elements in hash assignment";
966 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
970 didstore = hv_store_ent(hash,*relem,tmpstr,0);
971 if (SvMAGICAL(hash)) {
972 if (SvSMAGICAL(tmpstr))
984 SV **lastlelem = PL_stack_sp;
985 SV **lastrelem = PL_stack_base + POPMARK;
986 SV **firstrelem = PL_stack_base + POPMARK + 1;
987 SV **firstlelem = lastrelem + 1;
1000 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1002 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1005 /* If there's a common identifier on both sides we have to take
1006 * special care that assigning the identifier on the left doesn't
1007 * clobber a value on the right that's used later in the list.
1009 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1010 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1011 for (relem = firstrelem; relem <= lastrelem; relem++) {
1012 if ((sv = *relem)) {
1013 TAINT_NOT; /* Each item is independent */
1015 /* Dear TODO test in t/op/sort.t, I love you.
1016 (It's relying on a panic, not a "semi-panic" from newSVsv()
1017 and then an assertion failure below.) */
1018 if (SvIS_FREED(sv)) {
1019 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1022 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1023 and we need a second copy of a temp here. */
1024 *relem = sv_2mortal(newSVsv(sv));
1034 while (lelem <= lastlelem) {
1035 TAINT_NOT; /* Each item stands on its own, taintwise. */
1037 switch (SvTYPE(sv)) {
1039 ary = MUTABLE_AV(sv);
1040 magic = SvMAGICAL(ary) != 0;
1042 av_extend(ary, lastrelem - relem);
1044 while (relem <= lastrelem) { /* gobble up all the rest */
1048 sv_setsv(sv, *relem);
1050 didstore = av_store(ary,i++,sv);
1059 if (PL_delaymagic & DM_ARRAY_ISA)
1060 SvSETMAGIC(MUTABLE_SV(ary));
1062 case SVt_PVHV: { /* normal hash */
1065 hash = MUTABLE_HV(sv);
1066 magic = SvMAGICAL(hash) != 0;
1068 firsthashrelem = relem;
1070 while (relem < lastrelem) { /* gobble up all the rest */
1072 sv = *relem ? *relem : &PL_sv_no;
1076 sv_setsv(tmpstr,*relem); /* value */
1077 *(relem++) = tmpstr;
1078 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1079 /* key overwrites an existing entry */
1081 didstore = hv_store_ent(hash,sv,tmpstr,0);
1083 if (SvSMAGICAL(tmpstr))
1090 if (relem == lastrelem) {
1091 do_oddball(hash, relem, firstrelem);
1097 if (SvIMMORTAL(sv)) {
1098 if (relem <= lastrelem)
1102 if (relem <= lastrelem) {
1103 sv_setsv(sv, *relem);
1107 sv_setsv(sv, &PL_sv_undef);
1112 if (PL_delaymagic & ~DM_DELAY) {
1113 if (PL_delaymagic & DM_UID) {
1114 #ifdef HAS_SETRESUID
1115 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1116 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1119 # ifdef HAS_SETREUID
1120 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1121 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1124 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1125 (void)setruid(PL_uid);
1126 PL_delaymagic &= ~DM_RUID;
1128 # endif /* HAS_SETRUID */
1130 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1131 (void)seteuid(PL_euid);
1132 PL_delaymagic &= ~DM_EUID;
1134 # endif /* HAS_SETEUID */
1135 if (PL_delaymagic & DM_UID) {
1136 if (PL_uid != PL_euid)
1137 DIE(aTHX_ "No setreuid available");
1138 (void)PerlProc_setuid(PL_uid);
1140 # endif /* HAS_SETREUID */
1141 #endif /* HAS_SETRESUID */
1142 PL_uid = PerlProc_getuid();
1143 PL_euid = PerlProc_geteuid();
1145 if (PL_delaymagic & DM_GID) {
1146 #ifdef HAS_SETRESGID
1147 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1148 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1151 # ifdef HAS_SETREGID
1152 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1153 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1156 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1157 (void)setrgid(PL_gid);
1158 PL_delaymagic &= ~DM_RGID;
1160 # endif /* HAS_SETRGID */
1162 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1163 (void)setegid(PL_egid);
1164 PL_delaymagic &= ~DM_EGID;
1166 # endif /* HAS_SETEGID */
1167 if (PL_delaymagic & DM_GID) {
1168 if (PL_gid != PL_egid)
1169 DIE(aTHX_ "No setregid available");
1170 (void)PerlProc_setgid(PL_gid);
1172 # endif /* HAS_SETREGID */
1173 #endif /* HAS_SETRESGID */
1174 PL_gid = PerlProc_getgid();
1175 PL_egid = PerlProc_getegid();
1177 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1181 if (gimme == G_VOID)
1182 SP = firstrelem - 1;
1183 else if (gimme == G_SCALAR) {
1186 SETi(lastrelem - firstrelem + 1 - duplicates);
1193 /* Removes from the stack the entries which ended up as
1194 * duplicated keys in the hash (fix for [perl #24380]) */
1195 Move(firsthashrelem + duplicates,
1196 firsthashrelem, duplicates, SV**);
1197 lastrelem -= duplicates;
1202 SP = firstrelem + (lastlelem - firstlelem);
1203 lelem = firstlelem + (relem - firstrelem);
1205 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1214 register PMOP * const pm = cPMOP;
1215 REGEXP * rx = PM_GETRE(pm);
1216 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1217 SV * const rv = sv_newmortal();
1219 SvUPGRADE(rv, SVt_IV);
1220 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1221 loathe to use it here, but it seems to be the right fix. Or close.
1222 The key part appears to be that it's essential for pp_qr to return a new
1223 object (SV), which implies that there needs to be an effective way to
1224 generate a new SV from the existing SV that is pre-compiled in the
1226 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1230 HV *const stash = gv_stashsv(pkg, GV_ADD);
1232 (void)sv_bless(rv, stash);
1235 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1244 register PMOP *pm = cPMOP;
1246 register const char *t;
1247 register const char *s;
1250 U8 r_flags = REXEC_CHECKED;
1251 const char *truebase; /* Start of string */
1252 register REGEXP *rx = PM_GETRE(pm);
1254 const I32 gimme = GIMME;
1257 const I32 oldsave = PL_savestack_ix;
1258 I32 update_minmatch = 1;
1259 I32 had_zerolen = 0;
1262 if (PL_op->op_flags & OPf_STACKED)
1264 else if (PL_op->op_private & OPpTARGET_MY)
1271 PUTBACK; /* EVAL blocks need stack_sp. */
1272 /* Skip get-magic if this is a qr// clone, because regcomp has
1274 s = ((struct regexp *)SvANY(rx))->mother_re
1275 ? SvPV_nomg_const(TARG, len)
1276 : SvPV_const(TARG, len);
1278 DIE(aTHX_ "panic: pp_match");
1280 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1281 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1284 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1286 /* PMdf_USED is set after a ?? matches once */
1289 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1291 pm->op_pmflags & PMf_USED
1295 if (gimme == G_ARRAY)
1302 /* empty pattern special-cased to use last successful pattern if possible */
1303 if (!RX_PRELEN(rx) && PL_curpm) {
1308 if (RX_MINLEN(rx) > (I32)len)
1313 /* XXXX What part of this is needed with true \G-support? */
1314 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1315 RX_OFFS(rx)[0].start = -1;
1316 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1317 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1318 if (mg && mg->mg_len >= 0) {
1319 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1320 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1321 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1322 r_flags |= REXEC_IGNOREPOS;
1323 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1324 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1327 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1328 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1329 update_minmatch = 0;
1333 /* XXX: comment out !global get safe $1 vars after a
1334 match, BUT be aware that this leads to dramatic slowdowns on
1335 /g matches against large strings. So far a solution to this problem
1336 appears to be quite tricky.
1337 Test for the unsafe vars are TODO for now. */
1338 if (( !global && RX_NPARENS(rx))
1339 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand ||
1340 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1341 r_flags |= REXEC_COPY_STR;
1343 r_flags |= REXEC_SCREAM;
1346 if (global && RX_OFFS(rx)[0].start != -1) {
1347 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1348 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1350 if (update_minmatch++)
1351 minmatch = had_zerolen;
1353 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1354 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1355 /* FIXME - can PL_bostr be made const char *? */
1356 PL_bostr = (char *)truebase;
1357 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1361 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1363 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1364 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1365 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1366 && (r_flags & REXEC_SCREAM)))
1367 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1370 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1371 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1374 if (dynpm->op_pmflags & PMf_ONCE) {
1376 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1378 dynpm->op_pmflags |= PMf_USED;
1389 RX_MATCH_TAINTED_on(rx);
1390 TAINT_IF(RX_MATCH_TAINTED(rx));
1391 if (gimme == G_ARRAY) {
1392 const I32 nparens = RX_NPARENS(rx);
1393 I32 i = (global && !nparens) ? 1 : 0;
1395 SPAGAIN; /* EVAL blocks could move the stack. */
1396 EXTEND(SP, nparens + i);
1397 EXTEND_MORTAL(nparens + i);
1398 for (i = !i; i <= nparens; i++) {
1399 PUSHs(sv_newmortal());
1400 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1401 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1402 s = RX_OFFS(rx)[i].start + truebase;
1403 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1404 len < 0 || len > strend - s)
1405 DIE(aTHX_ "panic: pp_match start/end pointers");
1406 sv_setpvn(*SP, s, len);
1407 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1412 if (dynpm->op_pmflags & PMf_CONTINUE) {
1414 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1415 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1417 #ifdef PERL_OLD_COPY_ON_WRITE
1419 sv_force_normal_flags(TARG, 0);
1421 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1422 &PL_vtbl_mglob, NULL, 0);
1424 if (RX_OFFS(rx)[0].start != -1) {
1425 mg->mg_len = RX_OFFS(rx)[0].end;
1426 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1427 mg->mg_flags |= MGf_MINMATCH;
1429 mg->mg_flags &= ~MGf_MINMATCH;
1432 had_zerolen = (RX_OFFS(rx)[0].start != -1
1433 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1434 == (UV)RX_OFFS(rx)[0].end));
1435 PUTBACK; /* EVAL blocks may use stack */
1436 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1441 LEAVE_SCOPE(oldsave);
1447 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1448 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1452 #ifdef PERL_OLD_COPY_ON_WRITE
1454 sv_force_normal_flags(TARG, 0);
1456 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1457 &PL_vtbl_mglob, NULL, 0);
1459 if (RX_OFFS(rx)[0].start != -1) {
1460 mg->mg_len = RX_OFFS(rx)[0].end;
1461 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1462 mg->mg_flags |= MGf_MINMATCH;
1464 mg->mg_flags &= ~MGf_MINMATCH;
1467 LEAVE_SCOPE(oldsave);
1471 yup: /* Confirmed by INTUIT */
1473 RX_MATCH_TAINTED_on(rx);
1474 TAINT_IF(RX_MATCH_TAINTED(rx));
1476 if (dynpm->op_pmflags & PMf_ONCE) {
1478 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1480 dynpm->op_pmflags |= PMf_USED;
1483 if (RX_MATCH_COPIED(rx))
1484 Safefree(RX_SUBBEG(rx));
1485 RX_MATCH_COPIED_off(rx);
1486 RX_SUBBEG(rx) = NULL;
1488 /* FIXME - should rx->subbeg be const char *? */
1489 RX_SUBBEG(rx) = (char *) truebase;
1490 RX_OFFS(rx)[0].start = s - truebase;
1491 if (RX_MATCH_UTF8(rx)) {
1492 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1493 RX_OFFS(rx)[0].end = t - truebase;
1496 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1498 RX_SUBLEN(rx) = strend - truebase;
1501 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1503 #ifdef PERL_OLD_COPY_ON_WRITE
1504 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1506 PerlIO_printf(Perl_debug_log,
1507 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1508 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1511 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1513 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1514 assert (SvPOKp(RX_SAVED_COPY(rx)));
1519 RX_SUBBEG(rx) = savepvn(t, strend - t);
1520 #ifdef PERL_OLD_COPY_ON_WRITE
1521 RX_SAVED_COPY(rx) = NULL;
1524 RX_SUBLEN(rx) = strend - t;
1525 RX_MATCH_COPIED_on(rx);
1526 off = RX_OFFS(rx)[0].start = s - t;
1527 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1529 else { /* startp/endp are used by @- @+. */
1530 RX_OFFS(rx)[0].start = s - truebase;
1531 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1533 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1535 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1536 LEAVE_SCOPE(oldsave);
1541 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1542 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1543 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1548 LEAVE_SCOPE(oldsave);
1549 if (gimme == G_ARRAY)
1555 Perl_do_readline(pTHX)
1557 dVAR; dSP; dTARGETSTACKED;
1562 register IO * const io = GvIO(PL_last_in_gv);
1563 register const I32 type = PL_op->op_type;
1564 const I32 gimme = GIMME_V;
1567 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1570 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1572 ENTER_with_name("call_READLINE");
1573 call_method("READLINE", gimme);
1574 LEAVE_with_name("call_READLINE");
1576 if (gimme == G_SCALAR) {
1577 SV* const result = POPs;
1578 SvSetSV_nosteal(TARG, result);
1588 if (IoFLAGS(io) & IOf_ARGV) {
1589 if (IoFLAGS(io) & IOf_START) {
1591 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1592 IoFLAGS(io) &= ~IOf_START;
1593 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1594 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1595 SvSETMAGIC(GvSV(PL_last_in_gv));
1600 fp = nextargv(PL_last_in_gv);
1601 if (!fp) { /* Note: fp != IoIFP(io) */
1602 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1605 else if (type == OP_GLOB)
1606 fp = Perl_start_glob(aTHX_ POPs, io);
1608 else if (type == OP_GLOB)
1610 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1611 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1615 if ((!io || !(IoFLAGS(io) & IOf_START))
1616 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1618 if (type == OP_GLOB)
1619 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1620 "glob failed (can't start child: %s)",
1623 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1625 if (gimme == G_SCALAR) {
1626 /* undef TARG, and push that undefined value */
1627 if (type != OP_RCATLINE) {
1628 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1636 if (gimme == G_SCALAR) {
1638 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1641 if (type == OP_RCATLINE)
1642 SvPV_force_nolen(sv);
1646 else if (isGV_with_GP(sv)) {
1647 SvPV_force_nolen(sv);
1649 SvUPGRADE(sv, SVt_PV);
1650 tmplen = SvLEN(sv); /* remember if already alloced */
1651 if (!tmplen && !SvREADONLY(sv)) {
1652 /* try short-buffering it. Please update t/op/readline.t
1653 * if you change the growth length.
1658 if (type == OP_RCATLINE && SvOK(sv)) {
1660 SvPV_force_nolen(sv);
1666 sv = sv_2mortal(newSV(80));
1670 /* This should not be marked tainted if the fp is marked clean */
1671 #define MAYBE_TAINT_LINE(io, sv) \
1672 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1677 /* delay EOF state for a snarfed empty file */
1678 #define SNARF_EOF(gimme,rs,io,sv) \
1679 (gimme != G_SCALAR || SvCUR(sv) \
1680 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1684 if (!sv_gets(sv, fp, offset)
1686 || SNARF_EOF(gimme, PL_rs, io, sv)
1687 || PerlIO_error(fp)))
1689 PerlIO_clearerr(fp);
1690 if (IoFLAGS(io) & IOf_ARGV) {
1691 fp = nextargv(PL_last_in_gv);
1694 (void)do_close(PL_last_in_gv, FALSE);
1696 else if (type == OP_GLOB) {
1697 if (!do_close(PL_last_in_gv, FALSE)) {
1698 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1699 "glob failed (child exited with status %d%s)",
1700 (int)(STATUS_CURRENT >> 8),
1701 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1704 if (gimme == G_SCALAR) {
1705 if (type != OP_RCATLINE) {
1706 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1712 MAYBE_TAINT_LINE(io, sv);
1715 MAYBE_TAINT_LINE(io, sv);
1717 IoFLAGS(io) |= IOf_NOLINE;
1721 if (type == OP_GLOB) {
1724 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1725 char * const tmps = SvEND(sv) - 1;
1726 if (*tmps == *SvPVX_const(PL_rs)) {
1728 SvCUR_set(sv, SvCUR(sv) - 1);
1731 for (t1 = SvPVX_const(sv); *t1; t1++)
1732 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1733 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1735 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1736 (void)POPs; /* Unmatched wildcard? Chuck it... */
1739 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1740 if (ckWARN(WARN_UTF8)) {
1741 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1742 const STRLEN len = SvCUR(sv) - offset;
1745 if (!is_utf8_string_loc(s, len, &f))
1746 /* Emulate :encoding(utf8) warning in the same case. */
1747 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1748 "utf8 \"\\x%02X\" does not map to Unicode",
1749 f < (U8*)SvEND(sv) ? *f : 0);
1752 if (gimme == G_ARRAY) {
1753 if (SvLEN(sv) - SvCUR(sv) > 20) {
1754 SvPV_shrink_to_cur(sv);
1756 sv = sv_2mortal(newSV(80));
1759 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1760 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1761 const STRLEN new_len
1762 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1763 SvPV_renew(sv, new_len);
1772 register PERL_CONTEXT *cx;
1773 I32 gimme = OP_GIMME(PL_op, -1);
1776 if (cxstack_ix >= 0) {
1777 /* If this flag is set, we're just inside a return, so we should
1778 * store the caller's context */
1779 gimme = (PL_op->op_flags & OPf_SPECIAL)
1781 : cxstack[cxstack_ix].blk_gimme;
1786 ENTER_with_name("block");
1789 PUSHBLOCK(cx, CXt_BLOCK, SP);
1799 SV * const keysv = POPs;
1800 HV * const hv = MUTABLE_HV(POPs);
1801 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1802 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1804 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1805 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1806 bool preeminent = TRUE;
1808 if (SvTYPE(hv) != SVt_PVHV)
1815 /* If we can determine whether the element exist,
1816 * Try to preserve the existenceness of a tied hash
1817 * element by using EXISTS and DELETE if possible.
1818 * Fallback to FETCH and STORE otherwise. */
1819 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1820 preeminent = hv_exists_ent(hv, keysv, 0);
1823 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1824 svp = he ? &HeVAL(he) : NULL;
1826 if (!svp || *svp == &PL_sv_undef) {
1830 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1832 lv = sv_newmortal();
1833 sv_upgrade(lv, SVt_PVLV);
1835 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1836 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1837 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1843 if (HvNAME_get(hv) && isGV(*svp))
1844 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1845 else if (preeminent)
1846 save_helem_flags(hv, keysv, svp,
1847 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1849 SAVEHDELETE(hv, keysv);
1851 else if (PL_op->op_private & OPpDEREF)
1852 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1854 sv = (svp ? *svp : &PL_sv_undef);
1855 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1856 * was to make C<local $tied{foo} = $tied{foo}> possible.
1857 * However, it seems no longer to be needed for that purpose, and
1858 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1859 * would loop endlessly since the pos magic is getting set on the
1860 * mortal copy and lost. However, the copy has the effect of
1861 * triggering the get magic, and losing it altogether made things like
1862 * c<$tied{foo};> in void context no longer do get magic, which some
1863 * code relied on. Also, delayed triggering of magic on @+ and friends
1864 * meant the original regex may be out of scope by now. So as a
1865 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1866 * being called too many times). */
1867 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1876 register PERL_CONTEXT *cx;
1881 if (PL_op->op_flags & OPf_SPECIAL) {
1882 cx = &cxstack[cxstack_ix];
1883 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1888 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1891 if (gimme == G_VOID)
1893 else if (gimme == G_SCALAR) {
1897 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1900 *MARK = sv_mortalcopy(TOPs);
1903 *MARK = &PL_sv_undef;
1907 else if (gimme == G_ARRAY) {
1908 /* in case LEAVE wipes old return values */
1910 for (mark = newsp + 1; mark <= SP; mark++) {
1911 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1912 *mark = sv_mortalcopy(*mark);
1913 TAINT_NOT; /* Each item is independent */
1917 PL_curpm = newpm; /* Don't pop $1 et al till now */
1919 LEAVE_with_name("block");
1927 register PERL_CONTEXT *cx;
1930 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1931 bool av_is_stack = FALSE;
1934 cx = &cxstack[cxstack_ix];
1935 if (!CxTYPE_is_LOOP(cx))
1936 DIE(aTHX_ "panic: pp_iter");
1938 itersvp = CxITERVAR(cx);
1939 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1940 /* string increment */
1941 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1942 SV *end = cx->blk_loop.state_u.lazysv.end;
1943 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1944 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1946 const char *max = SvPV_const(end, maxlen);
1947 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1948 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1949 /* safe to reuse old SV */
1950 sv_setsv(*itersvp, cur);
1954 /* we need a fresh SV every time so that loop body sees a
1955 * completely new SV for closures/references to work as
1958 *itersvp = newSVsv(cur);
1959 SvREFCNT_dec(oldsv);
1961 if (strEQ(SvPVX_const(cur), max))
1962 sv_setiv(cur, 0); /* terminate next time */
1969 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1970 /* integer increment */
1971 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1974 /* don't risk potential race */
1975 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1976 /* safe to reuse old SV */
1977 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.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 they
1985 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1986 SvREFCNT_dec(oldsv);
1989 /* Handle end of range at IV_MAX */
1990 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1991 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1993 cx->blk_loop.state_u.lazyiv.cur++;
1994 cx->blk_loop.state_u.lazyiv.end++;
2001 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2002 av = cx->blk_loop.state_u.ary.ary;
2007 if (PL_op->op_private & OPpITER_REVERSED) {
2008 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2009 ? cx->blk_loop.resetsp + 1 : 0))
2012 if (SvMAGICAL(av) || AvREIFY(av)) {
2013 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2014 sv = svp ? *svp : NULL;
2017 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2021 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2025 if (SvMAGICAL(av) || AvREIFY(av)) {
2026 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2027 sv = svp ? *svp : NULL;
2030 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2034 if (sv && SvIS_FREED(sv)) {
2036 Perl_croak(aTHX_ "Use of freed value in iteration");
2041 SvREFCNT_inc_simple_void_NN(sv);
2045 if (!av_is_stack && sv == &PL_sv_undef) {
2046 SV *lv = newSV_type(SVt_PVLV);
2048 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2049 LvTARG(lv) = SvREFCNT_inc_simple(av);
2050 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2051 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2057 SvREFCNT_dec(oldsv);
2065 register PMOP *pm = cPMOP;
2080 register REGEXP *rx = PM_GETRE(pm);
2082 int force_on_match = 0;
2083 const I32 oldsave = PL_savestack_ix;
2085 bool doutf8 = FALSE;
2087 #ifdef PERL_OLD_COPY_ON_WRITE
2091 /* known replacement string? */
2092 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2096 if (PL_op->op_flags & OPf_STACKED)
2098 else if (PL_op->op_private & OPpTARGET_MY)
2105 /* In non-destructive replacement mode, duplicate target scalar so it
2106 * remains unchanged. */
2107 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2108 TARG = newSVsv(TARG);
2110 #ifdef PERL_OLD_COPY_ON_WRITE
2111 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2112 because they make integers such as 256 "false". */
2113 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2116 sv_force_normal_flags(TARG,0);
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2123 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2124 || SvTYPE(TARG) > SVt_PVLV)
2125 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2126 Perl_croak_no_modify(aTHX);
2130 s = SvPV_mutable(TARG, len);
2131 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2133 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2134 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2139 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2143 DIE(aTHX_ "panic: pp_subst");
2146 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2147 maxiters = 2 * slen + 10; /* We can match twice at each
2148 position, once with zero-length,
2149 second time with non-zero. */
2151 if (!RX_PRELEN(rx) && PL_curpm) {
2155 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2156 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2157 ? REXEC_COPY_STR : 0;
2159 r_flags |= REXEC_SCREAM;
2162 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2164 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2168 /* How to do it in subst? */
2169 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2171 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2172 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2173 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2174 && (r_flags & REXEC_SCREAM))))
2179 /* only replace once? */
2180 once = !(rpm->op_pmflags & PMf_GLOBAL);
2181 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2182 r_flags | REXEC_CHECKED);
2183 /* known replacement string? */
2186 /* Upgrade the source if the replacement is utf8 but the source is not,
2187 * but only if it matched; see
2188 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2190 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2191 const STRLEN new_len = sv_utf8_upgrade(TARG);
2193 /* If the lengths are the same, the pattern contains only
2194 * invariants, can keep going; otherwise, various internal markers
2195 * could be off, so redo */
2196 if (new_len != len) {
2201 /* replacement needing upgrading? */
2202 if (DO_UTF8(TARG) && !doutf8) {
2203 nsv = sv_newmortal();
2206 sv_recode_to_utf8(nsv, PL_encoding);
2208 sv_utf8_upgrade(nsv);
2209 c = SvPV_const(nsv, clen);
2213 c = SvPV_const(dstr, clen);
2214 doutf8 = DO_UTF8(dstr);
2222 /* can do inplace substitution? */
2224 #ifdef PERL_OLD_COPY_ON_WRITE
2227 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2228 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2229 && (!doutf8 || SvUTF8(TARG))) {
2233 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2237 LEAVE_SCOPE(oldsave);
2240 #ifdef PERL_OLD_COPY_ON_WRITE
2241 if (SvIsCOW(TARG)) {
2242 assert (!force_on_match);
2246 if (force_on_match) {
2248 s = SvPV_force(TARG, len);
2253 SvSCREAM_off(TARG); /* disable possible screamer */
2255 rxtainted |= RX_MATCH_TAINTED(rx);
2256 m = orig + RX_OFFS(rx)[0].start;
2257 d = orig + RX_OFFS(rx)[0].end;
2259 if (m - s > strend - d) { /* faster to shorten from end */
2261 Copy(c, m, clen, char);
2266 Move(d, m, i, char);
2270 SvCUR_set(TARG, m - s);
2272 else if ((i = m - s)) { /* faster from front */
2275 Move(s, d - i, i, char);
2278 Copy(c, m, clen, char);
2283 Copy(c, d, clen, char);
2288 TAINT_IF(rxtainted & 1);
2290 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2297 if (iters++ > maxiters)
2298 DIE(aTHX_ "Substitution loop");
2299 rxtainted |= RX_MATCH_TAINTED(rx);
2300 m = RX_OFFS(rx)[0].start + orig;
2303 Move(s, d, i, char);
2307 Copy(c, d, clen, char);
2310 s = RX_OFFS(rx)[0].end + orig;
2311 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2313 /* don't match same null twice */
2314 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2317 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2318 Move(s, d, i+1, char); /* include the NUL */
2320 TAINT_IF(rxtainted & 1);
2322 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2327 (void)SvPOK_only_UTF8(TARG);
2328 TAINT_IF(rxtainted);
2329 if (SvSMAGICAL(TARG)) {
2337 LEAVE_SCOPE(oldsave);
2343 if (force_on_match) {
2345 s = SvPV_force(TARG, len);
2348 #ifdef PERL_OLD_COPY_ON_WRITE
2351 rxtainted |= RX_MATCH_TAINTED(rx);
2352 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2356 register PERL_CONTEXT *cx;
2359 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2361 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2363 if (iters++ > maxiters)
2364 DIE(aTHX_ "Substitution loop");
2365 rxtainted |= RX_MATCH_TAINTED(rx);
2366 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2369 orig = RX_SUBBEG(rx);
2371 strend = s + (strend - m);
2373 m = RX_OFFS(rx)[0].start + orig;
2374 if (doutf8 && !SvUTF8(dstr))
2375 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2377 sv_catpvn(dstr, s, m-s);
2378 s = RX_OFFS(rx)[0].end + orig;
2380 sv_catpvn(dstr, c, clen);
2383 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2384 TARG, NULL, r_flags));
2385 if (doutf8 && !DO_UTF8(TARG))
2386 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2388 sv_catpvn(dstr, s, strend - s);
2390 #ifdef PERL_OLD_COPY_ON_WRITE
2391 /* The match may make the string COW. If so, brilliant, because that's
2392 just saved us one malloc, copy and free - the regexp has donated
2393 the old buffer, and we malloc an entirely new one, rather than the
2394 regexp malloc()ing a buffer and copying our original, only for
2395 us to throw it away here during the substitution. */
2396 if (SvIsCOW(TARG)) {
2397 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2403 SvPV_set(TARG, SvPVX(dstr));
2404 SvCUR_set(TARG, SvCUR(dstr));
2405 SvLEN_set(TARG, SvLEN(dstr));
2406 doutf8 |= DO_UTF8(dstr);
2407 SvPV_set(dstr, NULL);
2409 TAINT_IF(rxtainted & 1);
2411 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2416 (void)SvPOK_only(TARG);
2419 TAINT_IF(rxtainted);
2422 LEAVE_SCOPE(oldsave);
2430 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2434 LEAVE_SCOPE(oldsave);
2443 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2444 ++*PL_markstack_ptr;
2445 LEAVE_with_name("grep_item"); /* exit inner scope */
2448 if (PL_stack_base + *PL_markstack_ptr > SP) {
2450 const I32 gimme = GIMME_V;
2452 LEAVE_with_name("grep"); /* exit outer scope */
2453 (void)POPMARK; /* pop src */
2454 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2455 (void)POPMARK; /* pop dst */
2456 SP = PL_stack_base + POPMARK; /* pop original mark */
2457 if (gimme == G_SCALAR) {
2458 if (PL_op->op_private & OPpGREP_LEX) {
2459 SV* const sv = sv_newmortal();
2460 sv_setiv(sv, items);
2468 else if (gimme == G_ARRAY)
2475 ENTER_with_name("grep_item"); /* enter inner scope */
2478 src = PL_stack_base[*PL_markstack_ptr];
2480 if (PL_op->op_private & OPpGREP_LEX)
2481 PAD_SVl(PL_op->op_targ) = src;
2485 RETURNOP(cLOGOP->op_other);
2496 register PERL_CONTEXT *cx;
2499 if (CxMULTICALL(&cxstack[cxstack_ix]))
2503 cxstack_ix++; /* temporarily protect top context */
2506 if (gimme == G_SCALAR) {
2509 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2511 *MARK = SvREFCNT_inc(TOPs);
2516 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2518 *MARK = sv_mortalcopy(sv);
2523 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2527 *MARK = &PL_sv_undef;
2531 else if (gimme == G_ARRAY) {
2532 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2533 if (!SvTEMP(*MARK)) {
2534 *MARK = sv_mortalcopy(*MARK);
2535 TAINT_NOT; /* Each item is independent */
2543 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2544 PL_curpm = newpm; /* ... and pop $1 et al */
2547 return cx->blk_sub.retop;
2550 /* This duplicates the above code because the above code must not
2551 * get any slower by more conditions */
2559 register PERL_CONTEXT *cx;
2562 if (CxMULTICALL(&cxstack[cxstack_ix]))
2566 cxstack_ix++; /* temporarily protect top context */
2570 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2571 /* We are an argument to a function or grep().
2572 * This kind of lvalueness was legal before lvalue
2573 * subroutines too, so be backward compatible:
2574 * cannot report errors. */
2576 /* Scalar context *is* possible, on the LHS of -> only,
2577 * as in f()->meth(). But this is not an lvalue. */
2578 if (gimme == G_SCALAR)
2580 if (gimme == G_ARRAY) {
2581 if (!CvLVALUE(cx->blk_sub.cv))
2582 goto temporise_array;
2583 EXTEND_MORTAL(SP - newsp);
2584 for (mark = newsp + 1; mark <= SP; mark++) {
2587 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2588 *mark = sv_mortalcopy(*mark);
2590 /* Can be a localized value subject to deletion. */
2591 PL_tmps_stack[++PL_tmps_ix] = *mark;
2592 SvREFCNT_inc_void(*mark);
2597 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2598 /* Here we go for robustness, not for speed, so we change all
2599 * the refcounts so the caller gets a live guy. Cannot set
2600 * TEMP, so sv_2mortal is out of question. */
2601 if (!CvLVALUE(cx->blk_sub.cv)) {
2607 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2609 if (gimme == G_SCALAR) {
2613 /* Temporaries are bad unless they happen to have set magic
2614 * attached, such as the elements of a tied hash or array */
2615 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2616 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2619 !SvSMAGICAL(TOPs)) {
2625 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2626 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2627 : "a readonly value" : "a temporary");
2629 else { /* Can be a localized value
2630 * subject to deletion. */
2631 PL_tmps_stack[++PL_tmps_ix] = *mark;
2632 SvREFCNT_inc_void(*mark);
2635 else { /* Should not happen? */
2641 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2642 (MARK > SP ? "Empty array" : "Array"));
2646 else if (gimme == G_ARRAY) {
2647 EXTEND_MORTAL(SP - newsp);
2648 for (mark = newsp + 1; mark <= SP; mark++) {
2649 if (*mark != &PL_sv_undef
2650 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2651 /* Might be flattened array after $#array = */
2658 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2659 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2662 /* Can be a localized value subject to deletion. */
2663 PL_tmps_stack[++PL_tmps_ix] = *mark;
2664 SvREFCNT_inc_void(*mark);
2670 if (gimme == G_SCALAR) {
2674 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2676 *MARK = SvREFCNT_inc(TOPs);
2681 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2683 *MARK = sv_mortalcopy(sv);
2688 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2692 *MARK = &PL_sv_undef;
2696 else if (gimme == G_ARRAY) {
2698 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2699 if (!SvTEMP(*MARK)) {
2700 *MARK = sv_mortalcopy(*MARK);
2701 TAINT_NOT; /* Each item is independent */
2710 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2711 PL_curpm = newpm; /* ... and pop $1 et al */
2714 return cx->blk_sub.retop;
2722 register PERL_CONTEXT *cx;
2724 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2727 DIE(aTHX_ "Not a CODE reference");
2728 switch (SvTYPE(sv)) {
2729 /* This is overwhelming the most common case: */
2731 if (!isGV_with_GP(sv))
2732 DIE(aTHX_ "Not a CODE reference");
2733 if (!(cv = GvCVu((const GV *)sv))) {
2735 cv = sv_2cv(sv, &stash, &gv, 0);
2744 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2746 SP = PL_stack_base + POPMARK;
2751 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2752 tryAMAGICunDEREF(to_cv);
2757 sym = SvPV_nomg_const(sv, len);
2759 DIE(aTHX_ PL_no_usym, "a subroutine");
2760 if (PL_op->op_private & HINT_STRICT_REFS)
2761 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2762 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2765 cv = MUTABLE_CV(SvRV(sv));
2766 if (SvTYPE(cv) == SVt_PVCV)
2771 DIE(aTHX_ "Not a CODE reference");
2772 /* This is the second most common case: */
2774 cv = MUTABLE_CV(sv);
2782 if (!CvROOT(cv) && !CvXSUB(cv)) {
2786 /* anonymous or undef'd function leaves us no recourse */
2787 if (CvANON(cv) || !(gv = CvGV(cv)))
2788 DIE(aTHX_ "Undefined subroutine called");
2790 /* autoloaded stub? */
2791 if (cv != GvCV(gv)) {
2794 /* should call AUTOLOAD now? */
2797 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2804 sub_name = sv_newmortal();
2805 gv_efullname3(sub_name, gv, NULL);
2806 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2810 DIE(aTHX_ "Not a CODE reference");
2815 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2816 Perl_get_db_sub(aTHX_ &sv, cv);
2818 PL_curcopdb = PL_curcop;
2820 /* check for lsub that handles lvalue subroutines */
2821 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2822 /* if lsub not found then fall back to DB::sub */
2823 if (!cv) cv = GvCV(PL_DBsub);
2825 cv = GvCV(PL_DBsub);
2828 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2829 DIE(aTHX_ "No DB::sub routine defined");
2832 if (!(CvISXSUB(cv))) {
2833 /* This path taken at least 75% of the time */
2835 register I32 items = SP - MARK;
2836 AV* const padlist = CvPADLIST(cv);
2837 PUSHBLOCK(cx, CXt_SUB, MARK);
2839 cx->blk_sub.retop = PL_op->op_next;
2841 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2842 * that eval'' ops within this sub know the correct lexical space.
2843 * Owing the speed considerations, we choose instead to search for
2844 * the cv using find_runcv() when calling doeval().
2846 if (CvDEPTH(cv) >= 2) {
2847 PERL_STACK_OVERFLOW_CHECK();
2848 pad_push(padlist, CvDEPTH(cv));
2851 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2853 AV *const av = MUTABLE_AV(PAD_SVl(0));
2855 /* @_ is normally not REAL--this should only ever
2856 * happen when DB::sub() calls things that modify @_ */
2861 cx->blk_sub.savearray = GvAV(PL_defgv);
2862 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2863 CX_CURPAD_SAVE(cx->blk_sub);
2864 cx->blk_sub.argarray = av;
2867 if (items > AvMAX(av) + 1) {
2868 SV **ary = AvALLOC(av);
2869 if (AvARRAY(av) != ary) {
2870 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2873 if (items > AvMAX(av) + 1) {
2874 AvMAX(av) = items - 1;
2875 Renew(ary,items,SV*);
2880 Copy(MARK,AvARRAY(av),items,SV*);
2881 AvFILLp(av) = items - 1;
2889 /* warning must come *after* we fully set up the context
2890 * stuff so that __WARN__ handlers can safely dounwind()
2893 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2894 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2895 sub_crush_depth(cv);
2896 RETURNOP(CvSTART(cv));
2899 I32 markix = TOPMARK;
2904 /* Need to copy @_ to stack. Alternative may be to
2905 * switch stack to @_, and copy return values
2906 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2907 AV * const av = GvAV(PL_defgv);
2908 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2911 /* Mark is at the end of the stack. */
2913 Copy(AvARRAY(av), SP + 1, items, SV*);
2918 /* We assume first XSUB in &DB::sub is the called one. */
2920 SAVEVPTR(PL_curcop);
2921 PL_curcop = PL_curcopdb;
2924 /* Do we need to open block here? XXXX */
2926 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2928 CvXSUB(cv)(aTHX_ cv);
2930 /* Enforce some sanity in scalar context. */
2931 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2932 if (markix > PL_stack_sp - PL_stack_base)
2933 *(PL_stack_base + markix) = &PL_sv_undef;
2935 *(PL_stack_base + markix) = *PL_stack_sp;
2936 PL_stack_sp = PL_stack_base + markix;
2944 Perl_sub_crush_depth(pTHX_ CV *cv)
2946 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2949 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2951 SV* const tmpstr = sv_newmortal();
2952 gv_efullname3(tmpstr, CvGV(cv), NULL);
2953 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2962 SV* const elemsv = POPs;
2963 IV elem = SvIV(elemsv);
2964 AV *const av = MUTABLE_AV(POPs);
2965 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2966 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2967 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2968 bool preeminent = TRUE;
2971 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2972 Perl_warner(aTHX_ packWARN(WARN_MISC),
2973 "Use of reference \"%"SVf"\" as array index",
2976 elem -= CopARYBASE_get(PL_curcop);
2977 if (SvTYPE(av) != SVt_PVAV)
2984 /* If we can determine whether the element exist,
2985 * Try to preserve the existenceness of a tied array
2986 * element by using EXISTS and DELETE if possible.
2987 * Fallback to FETCH and STORE otherwise. */
2988 if (SvCANEXISTDELETE(av))
2989 preeminent = av_exists(av, elem);
2992 svp = av_fetch(av, elem, lval && !defer);
2994 #ifdef PERL_MALLOC_WRAP
2995 if (SvUOK(elemsv)) {
2996 const UV uv = SvUV(elemsv);
2997 elem = uv > IV_MAX ? IV_MAX : uv;
2999 else if (SvNOK(elemsv))
3000 elem = (IV)SvNV(elemsv);
3002 static const char oom_array_extend[] =
3003 "Out of memory during array extend"; /* Duplicated in av.c */
3004 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3007 if (!svp || *svp == &PL_sv_undef) {
3010 DIE(aTHX_ PL_no_aelem, elem);
3011 lv = sv_newmortal();
3012 sv_upgrade(lv, SVt_PVLV);
3014 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3015 LvTARG(lv) = SvREFCNT_inc_simple(av);
3016 LvTARGOFF(lv) = elem;
3023 save_aelem(av, elem, svp);
3025 SAVEADELETE(av, elem);
3027 else if (PL_op->op_private & OPpDEREF)
3028 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3030 sv = (svp ? *svp : &PL_sv_undef);
3031 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3038 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3040 PERL_ARGS_ASSERT_VIVIFY_REF;
3045 Perl_croak_no_modify(aTHX);
3046 prepare_SV_for_RV(sv);
3049 SvRV_set(sv, newSV(0));
3052 SvRV_set(sv, MUTABLE_SV(newAV()));
3055 SvRV_set(sv, MUTABLE_SV(newHV()));
3066 SV* const sv = TOPs;
3069 SV* const rsv = SvRV(sv);
3070 if (SvTYPE(rsv) == SVt_PVCV) {
3076 SETs(method_common(sv, NULL));
3083 SV* const sv = cSVOP_sv;
3084 U32 hash = SvSHARED_HASH(sv);
3086 XPUSHs(method_common(sv, &hash));
3091 S_method_common(pTHX_ SV* meth, U32* hashp)
3097 const char* packname = NULL;
3100 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3102 PERL_ARGS_ASSERT_METHOD_COMMON;
3105 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3110 ob = MUTABLE_SV(SvRV(sv));
3114 /* this isn't a reference */
3115 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3116 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3118 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3125 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3126 !(ob=MUTABLE_SV(GvIO(iogv))))
3128 /* this isn't the name of a filehandle either */
3130 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3131 ? !isIDFIRST_utf8((U8*)packname)
3132 : !isIDFIRST(*packname)
3135 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3137 SvOK(sv) ? "without a package or object reference"
3138 : "on an undefined value");
3140 /* assume it's a package name */
3141 stash = gv_stashpvn(packname, packlen, 0);
3145 SV* const ref = newSViv(PTR2IV(stash));
3146 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3150 /* it _is_ a filehandle name -- replace with a reference */
3151 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3154 /* if we got here, ob should be a reference or a glob */
3155 if (!ob || !(SvOBJECT(ob)
3156 || (SvTYPE(ob) == SVt_PVGV
3158 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3161 const char * const name = SvPV_nolen_const(meth);
3162 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3163 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3167 stash = SvSTASH(ob);
3170 /* NOTE: stash may be null, hope hv_fetch_ent and
3171 gv_fetchmethod can cope (it seems they can) */
3173 /* shortcut for simple names */
3175 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3177 gv = MUTABLE_GV(HeVAL(he));
3178 if (isGV(gv) && GvCV(gv) &&
3179 (!GvCVGEN(gv) || GvCVGEN(gv)
3180 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3181 return MUTABLE_SV(GvCV(gv));
3185 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3186 SvPV_nolen_const(meth),
3187 GV_AUTOLOAD | GV_CROAK);
3191 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3196 * c-indentation-style: bsd
3198 * indent-tabs-mode: t
3201 * ex: set ts=8 sts=4 sw=4 noet: