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));
200 SvSetMagicSV(right, left);
210 RETURNOP(cLOGOP->op_other);
212 RETURNOP(cLOGOP->op_next);
219 TAINT_NOT; /* Each statement is presumed innocent */
220 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
222 if (!(PL_op->op_flags & OPf_SPECIAL)) {
223 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
224 LEAVE_SCOPE(oldsave);
231 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
236 const char *rpv = NULL;
238 bool rcopied = FALSE;
240 if (TARG == right && right != left) { /* $r = $l.$r */
241 rpv = SvPV_nomg_const(right, rlen);
242 rbyte = !DO_UTF8(right);
243 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
244 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
248 if (TARG != left) { /* not $l .= $r */
250 const char* const lpv = SvPV_nomg_const(left, llen);
251 lbyte = !DO_UTF8(left);
252 sv_setpvn(TARG, lpv, llen);
258 else { /* $l .= $r */
260 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
261 report_uninit(right);
264 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
265 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
272 /* $r.$r: do magic twice: tied might return different 2nd time */
274 rpv = SvPV_nomg_const(right, rlen);
275 rbyte = !DO_UTF8(right);
277 if (lbyte != rbyte) {
278 /* sv_utf8_upgrade_nomg() may reallocate the stack */
281 sv_utf8_upgrade_nomg(TARG);
284 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
285 sv_utf8_upgrade_nomg(right);
286 rpv = SvPV_nomg_const(right, rlen);
290 sv_catpvn_nomg(TARG, rpv, rlen);
301 if (PL_op->op_flags & OPf_MOD) {
302 if (PL_op->op_private & OPpLVAL_INTRO)
303 if (!(PL_op->op_private & OPpPAD_STATE))
304 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
305 if (PL_op->op_private & OPpDEREF) {
307 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
317 dSP; SvGETMAGIC(TOPs);
318 tryAMAGICunTARGET(iter_amg, 0, 0);
319 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
320 if (!isGV_with_GP(PL_last_in_gv)) {
321 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
322 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
325 XPUSHs(MUTABLE_SV(PL_last_in_gv));
328 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
331 return do_readline();
337 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
338 #ifndef NV_PRESERVES_UV
339 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
341 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
345 #ifdef PERL_PRESERVE_IVUV
346 SvIV_please_nomg(TOPs);
348 /* Unless the left argument is integer in range we are going
349 to have to use NV maths. Hence only attempt to coerce the
350 right argument if we know the left is integer. */
351 SvIV_please_nomg(TOPm1s);
353 const bool auvok = SvUOK(TOPm1s);
354 const bool buvok = SvUOK(TOPs);
356 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
357 /* Casting IV to UV before comparison isn't going to matter
358 on 2s complement. On 1s complement or sign&magnitude
359 (if we have any of them) it could to make negative zero
360 differ from normal zero. As I understand it. (Need to
361 check - is negative zero implementation defined behaviour
363 const UV buv = SvUVX(POPs);
364 const UV auv = SvUVX(TOPs);
366 SETs(boolSV(auv == buv));
369 { /* ## Mixed IV,UV ## */
373 /* == is commutative so doesn't matter which is left or right */
375 /* top of stack (b) is the iv */
384 /* As uv is a UV, it's >0, so it cannot be == */
387 /* we know iv is >= 0 */
388 SETs(boolSV((UV)iv == SvUVX(uvp)));
395 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
397 if (Perl_isnan(left) || Perl_isnan(right))
399 SETs(boolSV(left == right));
402 SETs(boolSV(SvNV_nomg(TOPs) == value));
411 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
412 Perl_croak_no_modify(aTHX);
413 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
414 && SvIVX(TOPs) != IV_MAX)
416 SvIV_set(TOPs, SvIVX(TOPs) + 1);
417 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
419 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
432 if (PL_op->op_type == OP_OR)
434 RETURNOP(cLOGOP->op_other);
443 const int op_type = PL_op->op_type;
444 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
449 if (!sv || !SvANY(sv)) {
450 if (op_type == OP_DOR)
452 RETURNOP(cLOGOP->op_other);
458 if (!sv || !SvANY(sv))
463 switch (SvTYPE(sv)) {
465 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
469 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
473 if (CvROOT(sv) || CvXSUB(sv))
486 if(op_type == OP_DOR)
488 RETURNOP(cLOGOP->op_other);
490 /* assuming OP_DEFINED */
498 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
499 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
503 useleft = USE_LEFT(svl);
504 #ifdef PERL_PRESERVE_IVUV
505 /* We must see if we can perform the addition with integers if possible,
506 as the integer code detects overflow while the NV code doesn't.
507 If either argument hasn't had a numeric conversion yet attempt to get
508 the IV. It's important to do this now, rather than just assuming that
509 it's not IOK as a PV of "9223372036854775806" may not take well to NV
510 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
511 integer in case the second argument is IV=9223372036854775806
512 We can (now) rely on sv_2iv to do the right thing, only setting the
513 public IOK flag if the value in the NV (or PV) slot is truly integer.
515 A side effect is that this also aggressively prefers integer maths over
516 fp maths for integer values.
518 How to detect overflow?
520 C 99 section 6.2.6.1 says
522 The range of nonnegative values of a signed integer type is a subrange
523 of the corresponding unsigned integer type, and the representation of
524 the same value in each type is the same. A computation involving
525 unsigned operands can never overflow, because a result that cannot be
526 represented by the resulting unsigned integer type is reduced modulo
527 the number that is one greater than the largest value that can be
528 represented by the resulting type.
532 which I read as "unsigned ints wrap."
534 signed integer overflow seems to be classed as "exception condition"
536 If an exceptional condition occurs during the evaluation of an
537 expression (that is, if the result is not mathematically defined or not
538 in the range of representable values for its type), the behavior is
541 (6.5, the 5th paragraph)
543 I had assumed that on 2s complement machines signed arithmetic would
544 wrap, hence coded pp_add and pp_subtract on the assumption that
545 everything perl builds on would be happy. After much wailing and
546 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
547 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
548 unsigned code below is actually shorter than the old code. :-)
551 SvIV_please_nomg(svr);
554 /* Unless the left argument is integer in range we are going to have to
555 use NV maths. Hence only attempt to coerce the right argument if
556 we know the left is integer. */
564 /* left operand is undef, treat as zero. + 0 is identity,
565 Could SETi or SETu right now, but space optimise by not adding
566 lots of code to speed up what is probably a rarish case. */
568 /* Left operand is defined, so is it IV? */
569 SvIV_please_nomg(svl);
571 if ((auvok = SvUOK(svl)))
574 register const IV aiv = SvIVX(svl);
577 auvok = 1; /* Now acting as a sign flag. */
578 } else { /* 2s complement assumption for IV_MIN */
586 bool result_good = 0;
589 bool buvok = SvUOK(svr);
594 register const IV biv = SvIVX(svr);
601 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602 else "IV" now, independent of how it came in.
603 if a, b represents positive, A, B negative, a maps to -A etc
608 all UV maths. negate result if A negative.
609 add if signs same, subtract if signs differ. */
615 /* Must get smaller */
621 /* result really should be -(auv-buv). as its negation
622 of true value, need to swap our result flag */
639 if (result <= (UV)IV_MIN)
642 /* result valid, but out of range for IV. */
647 } /* Overflow, drop through to NVs. */
652 NV value = SvNV_nomg(svr);
655 /* left operand is undef, treat as zero. + 0.0 is identity. */
659 SETn( value + SvNV_nomg(svl) );
667 AV * const av = PL_op->op_flags & OPf_SPECIAL
668 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
669 const U32 lval = PL_op->op_flags & OPf_MOD;
670 SV** const svp = av_fetch(av, PL_op->op_private, lval);
671 SV *sv = (svp ? *svp : &PL_sv_undef);
673 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
681 dVAR; dSP; dMARK; dTARGET;
683 do_join(TARG, *MARK, MARK, SP);
694 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
695 * will be enough to hold an OP*.
697 SV* const sv = sv_newmortal();
698 sv_upgrade(sv, SVt_PVLV);
700 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
703 XPUSHs(MUTABLE_SV(PL_op));
708 /* Oversized hot code. */
712 dVAR; dSP; dMARK; dORIGMARK;
716 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
720 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
723 if (MARK == ORIGMARK) {
724 /* If using default handle then we need to make space to
725 * pass object as 1st arg, so move other args up ...
729 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
732 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
734 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
735 | (PL_op->op_type == OP_SAY
736 ? TIED_METHOD_SAY : 0)), sp - mark);
739 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
740 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
743 SETERRNO(EBADF,RMS_IFI);
746 else if (!(fp = IoOFP(io))) {
748 report_wrongway_fh(gv, '<');
751 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
755 SV * const ofs = GvSV(PL_ofsgv); /* $, */
757 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
759 if (!do_print(*MARK, fp))
763 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
764 if (!do_print(GvSV(PL_ofsgv), fp)) {
773 if (!do_print(*MARK, fp))
781 if (PL_op->op_type == OP_SAY) {
782 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
785 else if (PL_ors_sv && SvOK(PL_ors_sv))
786 if (!do_print(PL_ors_sv, fp)) /* $\ */
789 if (IoFLAGS(io) & IOf_FLUSH)
790 if (PerlIO_flush(fp) == EOF)
800 XPUSHs(&PL_sv_undef);
807 const I32 gimme = GIMME_V;
808 static const char an_array[] = "an ARRAY";
809 static const char a_hash[] = "a HASH";
810 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
811 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
813 if (!(PL_op->op_private & OPpDEREFed))
817 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
821 if (SvTYPE(sv) != type)
822 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
823 if (PL_op->op_flags & OPf_REF) {
828 if (gimme != G_ARRAY)
829 goto croak_cant_return;
833 else if (PL_op->op_flags & OPf_MOD
834 && PL_op->op_private & OPpLVAL_INTRO)
835 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
838 if (SvTYPE(sv) == type) {
839 if (PL_op->op_flags & OPf_REF) {
844 if (gimme != G_ARRAY)
845 goto croak_cant_return;
853 if (!isGV_with_GP(sv)) {
854 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
862 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
863 if (PL_op->op_private & OPpLVAL_INTRO)
864 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
865 if (PL_op->op_flags & OPf_REF) {
870 if (gimme != G_ARRAY)
871 goto croak_cant_return;
879 AV *const av = MUTABLE_AV(sv);
880 /* The guts of pp_rv2av, with no intending change to preserve history
881 (until such time as we get tools that can do blame annotation across
882 whitespace changes. */
883 if (gimme == G_ARRAY) {
884 const I32 maxarg = AvFILL(av) + 1;
885 (void)POPs; /* XXXX May be optimized away? */
887 if (SvRMAGICAL(av)) {
889 for (i=0; i < (U32)maxarg; i++) {
890 SV ** const svp = av_fetch(av, i, FALSE);
891 /* See note in pp_helem, and bug id #27839 */
893 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
898 Copy(AvARRAY(av), SP+1, maxarg, SV*);
902 else if (gimme == G_SCALAR) {
904 const I32 maxarg = AvFILL(av) + 1;
908 /* The guts of pp_rv2hv */
909 if (gimme == G_ARRAY) { /* array wanted */
911 return Perl_do_kv(aTHX);
913 else if (gimme == G_SCALAR) {
915 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
923 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
924 is_pp_rv2av ? "array" : "hash");
929 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
933 PERL_ARGS_ASSERT_DO_ODDBALL;
939 if (ckWARN(WARN_MISC)) {
941 if (relem == firstrelem &&
943 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
944 SvTYPE(SvRV(*relem)) == SVt_PVHV))
946 err = "Reference found where even-sized list expected";
949 err = "Odd number of elements in hash assignment";
950 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
954 didstore = hv_store_ent(hash,*relem,tmpstr,0);
955 if (SvMAGICAL(hash)) {
956 if (SvSMAGICAL(tmpstr))
968 SV **lastlelem = PL_stack_sp;
969 SV **lastrelem = PL_stack_base + POPMARK;
970 SV **firstrelem = PL_stack_base + POPMARK + 1;
971 SV **firstlelem = lastrelem + 1;
984 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
986 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
989 /* If there's a common identifier on both sides we have to take
990 * special care that assigning the identifier on the left doesn't
991 * clobber a value on the right that's used later in the list.
993 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
994 EXTEND_MORTAL(lastrelem - firstrelem + 1);
995 for (relem = firstrelem; relem <= lastrelem; relem++) {
997 TAINT_NOT; /* Each item is independent */
999 /* Dear TODO test in t/op/sort.t, I love you.
1000 (It's relying on a panic, not a "semi-panic" from newSVsv()
1001 and then an assertion failure below.) */
1002 if (SvIS_FREED(sv)) {
1003 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1006 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1007 and we need a second copy of a temp here. */
1008 *relem = sv_2mortal(newSVsv(sv));
1018 while (lelem <= lastlelem) {
1019 TAINT_NOT; /* Each item stands on its own, taintwise. */
1021 switch (SvTYPE(sv)) {
1023 ary = MUTABLE_AV(sv);
1024 magic = SvMAGICAL(ary) != 0;
1026 av_extend(ary, lastrelem - relem);
1028 while (relem <= lastrelem) { /* gobble up all the rest */
1032 sv_setsv(sv, *relem);
1034 didstore = av_store(ary,i++,sv);
1043 if (PL_delaymagic & DM_ARRAY_ISA)
1044 SvSETMAGIC(MUTABLE_SV(ary));
1046 case SVt_PVHV: { /* normal hash */
1048 SV** topelem = relem;
1050 hash = MUTABLE_HV(sv);
1051 magic = SvMAGICAL(hash) != 0;
1053 firsthashrelem = relem;
1055 while (relem < lastrelem) { /* gobble up all the rest */
1057 sv = *relem ? *relem : &PL_sv_no;
1061 sv_setsv(tmpstr,*relem); /* value */
1063 if (gimme != G_VOID) {
1064 if (hv_exists_ent(hash, sv, 0))
1065 /* key overwrites an existing entry */
1068 if (gimme == G_ARRAY) {
1069 /* copy element back: possibly to an earlier
1070 * stack location if we encountered dups earlier */
1072 *topelem++ = tmpstr;
1075 didstore = hv_store_ent(hash,sv,tmpstr,0);
1077 if (SvSMAGICAL(tmpstr))
1084 if (relem == lastrelem) {
1085 do_oddball(hash, relem, firstrelem);
1091 if (SvIMMORTAL(sv)) {
1092 if (relem <= lastrelem)
1096 if (relem <= lastrelem) {
1097 sv_setsv(sv, *relem);
1101 sv_setsv(sv, &PL_sv_undef);
1106 if (PL_delaymagic & ~DM_DELAY) {
1107 if (PL_delaymagic & DM_UID) {
1108 #ifdef HAS_SETRESUID
1109 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1110 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1113 # ifdef HAS_SETREUID
1114 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1115 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1118 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1119 (void)setruid(PL_uid);
1120 PL_delaymagic &= ~DM_RUID;
1122 # endif /* HAS_SETRUID */
1124 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1125 (void)seteuid(PL_euid);
1126 PL_delaymagic &= ~DM_EUID;
1128 # endif /* HAS_SETEUID */
1129 if (PL_delaymagic & DM_UID) {
1130 if (PL_uid != PL_euid)
1131 DIE(aTHX_ "No setreuid available");
1132 (void)PerlProc_setuid(PL_uid);
1134 # endif /* HAS_SETREUID */
1135 #endif /* HAS_SETRESUID */
1136 PL_uid = PerlProc_getuid();
1137 PL_euid = PerlProc_geteuid();
1139 if (PL_delaymagic & DM_GID) {
1140 #ifdef HAS_SETRESGID
1141 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1142 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1145 # ifdef HAS_SETREGID
1146 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1147 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1150 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1151 (void)setrgid(PL_gid);
1152 PL_delaymagic &= ~DM_RGID;
1154 # endif /* HAS_SETRGID */
1156 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1157 (void)setegid(PL_egid);
1158 PL_delaymagic &= ~DM_EGID;
1160 # endif /* HAS_SETEGID */
1161 if (PL_delaymagic & DM_GID) {
1162 if (PL_gid != PL_egid)
1163 DIE(aTHX_ "No setregid available");
1164 (void)PerlProc_setgid(PL_gid);
1166 # endif /* HAS_SETREGID */
1167 #endif /* HAS_SETRESGID */
1168 PL_gid = PerlProc_getgid();
1169 PL_egid = PerlProc_getegid();
1171 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1175 if (gimme == G_VOID)
1176 SP = firstrelem - 1;
1177 else if (gimme == G_SCALAR) {
1180 SETi(lastrelem - firstrelem + 1 - duplicates);
1187 /* at this point we have removed the duplicate key/value
1188 * pairs from the stack, but the remaining values may be
1189 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1190 * the (a 2), but the stack now probably contains
1191 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1192 * obliterates the earlier key. So refresh all values. */
1193 lastrelem -= duplicates;
1194 relem = firsthashrelem;
1195 while (relem < lastrelem) {
1198 he = hv_fetch_ent(hash, sv, 0, 0);
1199 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1205 SP = firstrelem + (lastlelem - firstlelem);
1206 lelem = firstlelem + (relem - firstrelem);
1208 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1217 register PMOP * const pm = cPMOP;
1218 REGEXP * rx = PM_GETRE(pm);
1219 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1220 SV * const rv = sv_newmortal();
1222 SvUPGRADE(rv, SVt_IV);
1223 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1224 loathe to use it here, but it seems to be the right fix. Or close.
1225 The key part appears to be that it's essential for pp_qr to return a new
1226 object (SV), which implies that there needs to be an effective way to
1227 generate a new SV from the existing SV that is pre-compiled in the
1229 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1233 HV *const stash = gv_stashsv(pkg, GV_ADD);
1235 (void)sv_bless(rv, stash);
1238 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1247 register PMOP *pm = cPMOP;
1249 register const char *t;
1250 register const char *s;
1253 U8 r_flags = REXEC_CHECKED;
1254 const char *truebase; /* Start of string */
1255 register REGEXP *rx = PM_GETRE(pm);
1257 const I32 gimme = GIMME;
1260 const I32 oldsave = PL_savestack_ix;
1261 I32 update_minmatch = 1;
1262 I32 had_zerolen = 0;
1265 if (PL_op->op_flags & OPf_STACKED)
1267 else if (PL_op->op_private & OPpTARGET_MY)
1274 PUTBACK; /* EVAL blocks need stack_sp. */
1275 /* Skip get-magic if this is a qr// clone, because regcomp has
1277 s = ((struct regexp *)SvANY(rx))->mother_re
1278 ? SvPV_nomg_const(TARG, len)
1279 : SvPV_const(TARG, len);
1281 DIE(aTHX_ "panic: pp_match");
1283 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1284 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1287 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1289 /* PMdf_USED is set after a ?? matches once */
1292 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1294 pm->op_pmflags & PMf_USED
1298 if (gimme == G_ARRAY)
1305 /* empty pattern special-cased to use last successful pattern if possible */
1306 if (!RX_PRELEN(rx) && PL_curpm) {
1311 if (RX_MINLEN(rx) > (I32)len)
1316 /* XXXX What part of this is needed with true \G-support? */
1317 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1318 RX_OFFS(rx)[0].start = -1;
1319 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1320 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1321 if (mg && mg->mg_len >= 0) {
1322 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1323 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1324 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1325 r_flags |= REXEC_IGNOREPOS;
1326 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1327 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1330 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1331 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1332 update_minmatch = 0;
1336 /* XXX: comment out !global get safe $1 vars after a
1337 match, BUT be aware that this leads to dramatic slowdowns on
1338 /g matches against large strings. So far a solution to this problem
1339 appears to be quite tricky.
1340 Test for the unsafe vars are TODO for now. */
1341 if ( (!global && RX_NPARENS(rx))
1342 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1343 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1344 r_flags |= REXEC_COPY_STR;
1346 r_flags |= REXEC_SCREAM;
1349 if (global && RX_OFFS(rx)[0].start != -1) {
1350 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1351 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1353 if (update_minmatch++)
1354 minmatch = had_zerolen;
1356 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1357 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1358 /* FIXME - can PL_bostr be made const char *? */
1359 PL_bostr = (char *)truebase;
1360 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1364 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1366 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1367 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1368 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1369 && (r_flags & REXEC_SCREAM)))
1370 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1373 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1374 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1377 if (dynpm->op_pmflags & PMf_ONCE) {
1379 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1381 dynpm->op_pmflags |= PMf_USED;
1392 RX_MATCH_TAINTED_on(rx);
1393 TAINT_IF(RX_MATCH_TAINTED(rx));
1394 if (gimme == G_ARRAY) {
1395 const I32 nparens = RX_NPARENS(rx);
1396 I32 i = (global && !nparens) ? 1 : 0;
1398 SPAGAIN; /* EVAL blocks could move the stack. */
1399 EXTEND(SP, nparens + i);
1400 EXTEND_MORTAL(nparens + i);
1401 for (i = !i; i <= nparens; i++) {
1402 PUSHs(sv_newmortal());
1403 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1404 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1405 s = RX_OFFS(rx)[i].start + truebase;
1406 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1407 len < 0 || len > strend - s)
1408 DIE(aTHX_ "panic: pp_match start/end pointers");
1409 sv_setpvn(*SP, s, len);
1410 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1415 if (dynpm->op_pmflags & PMf_CONTINUE) {
1417 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1418 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1420 #ifdef PERL_OLD_COPY_ON_WRITE
1422 sv_force_normal_flags(TARG, 0);
1424 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1425 &PL_vtbl_mglob, NULL, 0);
1427 if (RX_OFFS(rx)[0].start != -1) {
1428 mg->mg_len = RX_OFFS(rx)[0].end;
1429 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1430 mg->mg_flags |= MGf_MINMATCH;
1432 mg->mg_flags &= ~MGf_MINMATCH;
1435 had_zerolen = (RX_OFFS(rx)[0].start != -1
1436 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1437 == (UV)RX_OFFS(rx)[0].end));
1438 PUTBACK; /* EVAL blocks may use stack */
1439 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1444 LEAVE_SCOPE(oldsave);
1450 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1451 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1455 #ifdef PERL_OLD_COPY_ON_WRITE
1457 sv_force_normal_flags(TARG, 0);
1459 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1460 &PL_vtbl_mglob, NULL, 0);
1462 if (RX_OFFS(rx)[0].start != -1) {
1463 mg->mg_len = RX_OFFS(rx)[0].end;
1464 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1465 mg->mg_flags |= MGf_MINMATCH;
1467 mg->mg_flags &= ~MGf_MINMATCH;
1470 LEAVE_SCOPE(oldsave);
1474 yup: /* Confirmed by INTUIT */
1476 RX_MATCH_TAINTED_on(rx);
1477 TAINT_IF(RX_MATCH_TAINTED(rx));
1479 if (dynpm->op_pmflags & PMf_ONCE) {
1481 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1483 dynpm->op_pmflags |= PMf_USED;
1486 if (RX_MATCH_COPIED(rx))
1487 Safefree(RX_SUBBEG(rx));
1488 RX_MATCH_COPIED_off(rx);
1489 RX_SUBBEG(rx) = NULL;
1491 /* FIXME - should rx->subbeg be const char *? */
1492 RX_SUBBEG(rx) = (char *) truebase;
1493 RX_OFFS(rx)[0].start = s - truebase;
1494 if (RX_MATCH_UTF8(rx)) {
1495 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1496 RX_OFFS(rx)[0].end = t - truebase;
1499 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1501 RX_SUBLEN(rx) = strend - truebase;
1504 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1506 #ifdef PERL_OLD_COPY_ON_WRITE
1507 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1509 PerlIO_printf(Perl_debug_log,
1510 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1511 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1514 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1516 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1517 assert (SvPOKp(RX_SAVED_COPY(rx)));
1522 RX_SUBBEG(rx) = savepvn(t, strend - t);
1523 #ifdef PERL_OLD_COPY_ON_WRITE
1524 RX_SAVED_COPY(rx) = NULL;
1527 RX_SUBLEN(rx) = strend - t;
1528 RX_MATCH_COPIED_on(rx);
1529 off = RX_OFFS(rx)[0].start = s - t;
1530 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1532 else { /* startp/endp are used by @- @+. */
1533 RX_OFFS(rx)[0].start = s - truebase;
1534 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1536 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1538 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1539 LEAVE_SCOPE(oldsave);
1544 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1545 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1546 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1551 LEAVE_SCOPE(oldsave);
1552 if (gimme == G_ARRAY)
1558 Perl_do_readline(pTHX)
1560 dVAR; dSP; dTARGETSTACKED;
1565 register IO * const io = GvIO(PL_last_in_gv);
1566 register const I32 type = PL_op->op_type;
1567 const I32 gimme = GIMME_V;
1570 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1572 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1573 if (gimme == G_SCALAR) {
1575 SvSetSV_nosteal(TARG, TOPs);
1585 if (IoFLAGS(io) & IOf_ARGV) {
1586 if (IoFLAGS(io) & IOf_START) {
1588 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1589 IoFLAGS(io) &= ~IOf_START;
1590 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1591 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1592 SvSETMAGIC(GvSV(PL_last_in_gv));
1597 fp = nextargv(PL_last_in_gv);
1598 if (!fp) { /* Note: fp != IoIFP(io) */
1599 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1602 else if (type == OP_GLOB)
1603 fp = Perl_start_glob(aTHX_ POPs, io);
1605 else if (type == OP_GLOB)
1607 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1608 report_wrongway_fh(PL_last_in_gv, '>');
1612 if ((!io || !(IoFLAGS(io) & IOf_START))
1613 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1615 if (type == OP_GLOB)
1616 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1617 "glob failed (can't start child: %s)",
1620 report_evil_fh(PL_last_in_gv);
1622 if (gimme == G_SCALAR) {
1623 /* undef TARG, and push that undefined value */
1624 if (type != OP_RCATLINE) {
1625 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1633 if (gimme == G_SCALAR) {
1635 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1638 if (type == OP_RCATLINE)
1639 SvPV_force_nolen(sv);
1643 else if (isGV_with_GP(sv)) {
1644 SvPV_force_nolen(sv);
1646 SvUPGRADE(sv, SVt_PV);
1647 tmplen = SvLEN(sv); /* remember if already alloced */
1648 if (!tmplen && !SvREADONLY(sv)) {
1649 /* try short-buffering it. Please update t/op/readline.t
1650 * if you change the growth length.
1655 if (type == OP_RCATLINE && SvOK(sv)) {
1657 SvPV_force_nolen(sv);
1663 sv = sv_2mortal(newSV(80));
1667 /* This should not be marked tainted if the fp is marked clean */
1668 #define MAYBE_TAINT_LINE(io, sv) \
1669 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1674 /* delay EOF state for a snarfed empty file */
1675 #define SNARF_EOF(gimme,rs,io,sv) \
1676 (gimme != G_SCALAR || SvCUR(sv) \
1677 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1681 if (!sv_gets(sv, fp, offset)
1683 || SNARF_EOF(gimme, PL_rs, io, sv)
1684 || PerlIO_error(fp)))
1686 PerlIO_clearerr(fp);
1687 if (IoFLAGS(io) & IOf_ARGV) {
1688 fp = nextargv(PL_last_in_gv);
1691 (void)do_close(PL_last_in_gv, FALSE);
1693 else if (type == OP_GLOB) {
1694 if (!do_close(PL_last_in_gv, FALSE)) {
1695 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1696 "glob failed (child exited with status %d%s)",
1697 (int)(STATUS_CURRENT >> 8),
1698 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1701 if (gimme == G_SCALAR) {
1702 if (type != OP_RCATLINE) {
1703 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1709 MAYBE_TAINT_LINE(io, sv);
1712 MAYBE_TAINT_LINE(io, sv);
1714 IoFLAGS(io) |= IOf_NOLINE;
1718 if (type == OP_GLOB) {
1721 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1722 char * const tmps = SvEND(sv) - 1;
1723 if (*tmps == *SvPVX_const(PL_rs)) {
1725 SvCUR_set(sv, SvCUR(sv) - 1);
1728 for (t1 = SvPVX_const(sv); *t1; t1++)
1729 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1730 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1732 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1733 (void)POPs; /* Unmatched wildcard? Chuck it... */
1736 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1737 if (ckWARN(WARN_UTF8)) {
1738 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1739 const STRLEN len = SvCUR(sv) - offset;
1742 if (!is_utf8_string_loc(s, len, &f))
1743 /* Emulate :encoding(utf8) warning in the same case. */
1744 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1745 "utf8 \"\\x%02X\" does not map to Unicode",
1746 f < (U8*)SvEND(sv) ? *f : 0);
1749 if (gimme == G_ARRAY) {
1750 if (SvLEN(sv) - SvCUR(sv) > 20) {
1751 SvPV_shrink_to_cur(sv);
1753 sv = sv_2mortal(newSV(80));
1756 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1757 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1758 const STRLEN new_len
1759 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1760 SvPV_renew(sv, new_len);
1769 register PERL_CONTEXT *cx;
1770 I32 gimme = OP_GIMME(PL_op, -1);
1773 if (cxstack_ix >= 0) {
1774 /* If this flag is set, we're just inside a return, so we should
1775 * store the caller's context */
1776 gimme = (PL_op->op_flags & OPf_SPECIAL)
1778 : cxstack[cxstack_ix].blk_gimme;
1783 ENTER_with_name("block");
1786 PUSHBLOCK(cx, CXt_BLOCK, SP);
1796 SV * const keysv = POPs;
1797 HV * const hv = MUTABLE_HV(POPs);
1798 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1799 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1801 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1802 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1803 bool preeminent = TRUE;
1805 if (SvTYPE(hv) != SVt_PVHV)
1812 /* If we can determine whether the element exist,
1813 * Try to preserve the existenceness of a tied hash
1814 * element by using EXISTS and DELETE if possible.
1815 * Fallback to FETCH and STORE otherwise. */
1816 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1817 preeminent = hv_exists_ent(hv, keysv, 0);
1820 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1821 svp = he ? &HeVAL(he) : NULL;
1823 if (!svp || *svp == &PL_sv_undef) {
1827 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1829 lv = sv_newmortal();
1830 sv_upgrade(lv, SVt_PVLV);
1832 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1833 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1834 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1840 if (HvNAME_get(hv) && isGV(*svp))
1841 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1842 else if (preeminent)
1843 save_helem_flags(hv, keysv, svp,
1844 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1846 SAVEHDELETE(hv, keysv);
1848 else if (PL_op->op_private & OPpDEREF)
1849 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1851 sv = (svp ? *svp : &PL_sv_undef);
1852 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1853 * was to make C<local $tied{foo} = $tied{foo}> possible.
1854 * However, it seems no longer to be needed for that purpose, and
1855 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1856 * would loop endlessly since the pos magic is getting set on the
1857 * mortal copy and lost. However, the copy has the effect of
1858 * triggering the get magic, and losing it altogether made things like
1859 * c<$tied{foo};> in void context no longer do get magic, which some
1860 * code relied on. Also, delayed triggering of magic on @+ and friends
1861 * meant the original regex may be out of scope by now. So as a
1862 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1863 * being called too many times). */
1864 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1873 register PERL_CONTEXT *cx;
1878 if (PL_op->op_flags & OPf_SPECIAL) {
1879 cx = &cxstack[cxstack_ix];
1880 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1885 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1888 if (gimme == G_VOID)
1890 else if (gimme == G_SCALAR) {
1894 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1897 *MARK = sv_mortalcopy(TOPs);
1900 *MARK = &PL_sv_undef;
1904 else if (gimme == G_ARRAY) {
1905 /* in case LEAVE wipes old return values */
1907 for (mark = newsp + 1; mark <= SP; mark++) {
1908 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1909 *mark = sv_mortalcopy(*mark);
1910 TAINT_NOT; /* Each item is independent */
1914 PL_curpm = newpm; /* Don't pop $1 et al till now */
1916 LEAVE_with_name("block");
1924 register PERL_CONTEXT *cx;
1927 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1928 bool av_is_stack = FALSE;
1931 cx = &cxstack[cxstack_ix];
1932 if (!CxTYPE_is_LOOP(cx))
1933 DIE(aTHX_ "panic: pp_iter");
1935 itersvp = CxITERVAR(cx);
1936 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1937 /* string increment */
1938 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1939 SV *end = cx->blk_loop.state_u.lazysv.end;
1940 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1941 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1943 const char *max = SvPV_const(end, maxlen);
1944 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1945 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1946 /* safe to reuse old SV */
1947 sv_setsv(*itersvp, cur);
1951 /* we need a fresh SV every time so that loop body sees a
1952 * completely new SV for closures/references to work as
1955 *itersvp = newSVsv(cur);
1956 SvREFCNT_dec(oldsv);
1958 if (strEQ(SvPVX_const(cur), max))
1959 sv_setiv(cur, 0); /* terminate next time */
1966 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1967 /* integer increment */
1968 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1971 /* don't risk potential race */
1972 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1973 /* safe to reuse old SV */
1974 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1978 /* we need a fresh SV every time so that loop body sees a
1979 * completely new SV for closures/references to work as they
1982 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1983 SvREFCNT_dec(oldsv);
1986 /* Handle end of range at IV_MAX */
1987 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1988 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1990 cx->blk_loop.state_u.lazyiv.cur++;
1991 cx->blk_loop.state_u.lazyiv.end++;
1998 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1999 av = cx->blk_loop.state_u.ary.ary;
2004 if (PL_op->op_private & OPpITER_REVERSED) {
2005 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2006 ? cx->blk_loop.resetsp + 1 : 0))
2009 if (SvMAGICAL(av) || AvREIFY(av)) {
2010 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2011 sv = svp ? *svp : NULL;
2014 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2018 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2022 if (SvMAGICAL(av) || AvREIFY(av)) {
2023 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2024 sv = svp ? *svp : NULL;
2027 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2031 if (sv && SvIS_FREED(sv)) {
2033 Perl_croak(aTHX_ "Use of freed value in iteration");
2038 SvREFCNT_inc_simple_void_NN(sv);
2042 if (!av_is_stack && sv == &PL_sv_undef) {
2043 SV *lv = newSV_type(SVt_PVLV);
2045 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2046 LvTARG(lv) = SvREFCNT_inc_simple(av);
2047 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2048 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2054 SvREFCNT_dec(oldsv);
2062 register PMOP *pm = cPMOP;
2077 register REGEXP *rx = PM_GETRE(pm);
2079 int force_on_match = 0;
2080 const I32 oldsave = PL_savestack_ix;
2082 bool doutf8 = FALSE;
2084 #ifdef PERL_OLD_COPY_ON_WRITE
2088 /* known replacement string? */
2089 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2093 if (PL_op->op_flags & OPf_STACKED)
2095 else if (PL_op->op_private & OPpTARGET_MY)
2102 /* In non-destructive replacement mode, duplicate target scalar so it
2103 * remains unchanged. */
2104 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2105 TARG = sv_2mortal(newSVsv(TARG));
2107 #ifdef PERL_OLD_COPY_ON_WRITE
2108 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2109 because they make integers such as 256 "false". */
2110 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2113 sv_force_normal_flags(TARG,0);
2116 #ifdef PERL_OLD_COPY_ON_WRITE
2120 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2121 || SvTYPE(TARG) > SVt_PVLV)
2122 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2123 Perl_croak_no_modify(aTHX);
2127 s = SvPV_mutable(TARG, len);
2128 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2130 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2131 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2136 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2140 DIE(aTHX_ "panic: pp_subst");
2143 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2144 maxiters = 2 * slen + 10; /* We can match twice at each
2145 position, once with zero-length,
2146 second time with non-zero. */
2148 if (!RX_PRELEN(rx) && PL_curpm) {
2152 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2153 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2154 ? REXEC_COPY_STR : 0;
2156 r_flags |= REXEC_SCREAM;
2159 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2161 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2165 /* How to do it in subst? */
2166 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2168 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2169 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2170 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2171 && (r_flags & REXEC_SCREAM))))
2176 /* only replace once? */
2177 once = !(rpm->op_pmflags & PMf_GLOBAL);
2178 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2179 r_flags | REXEC_CHECKED);
2180 /* known replacement string? */
2183 /* Upgrade the source if the replacement is utf8 but the source is not,
2184 * but only if it matched; see
2185 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2187 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2188 const STRLEN new_len = sv_utf8_upgrade(TARG);
2190 /* If the lengths are the same, the pattern contains only
2191 * invariants, can keep going; otherwise, various internal markers
2192 * could be off, so redo */
2193 if (new_len != len) {
2198 /* replacement needing upgrading? */
2199 if (DO_UTF8(TARG) && !doutf8) {
2200 nsv = sv_newmortal();
2203 sv_recode_to_utf8(nsv, PL_encoding);
2205 sv_utf8_upgrade(nsv);
2206 c = SvPV_const(nsv, clen);
2210 c = SvPV_const(dstr, clen);
2211 doutf8 = DO_UTF8(dstr);
2219 /* can do inplace substitution? */
2221 #ifdef PERL_OLD_COPY_ON_WRITE
2224 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2225 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2226 && (!doutf8 || SvUTF8(TARG)))
2231 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2235 LEAVE_SCOPE(oldsave);
2238 #ifdef PERL_OLD_COPY_ON_WRITE
2239 if (SvIsCOW(TARG)) {
2240 assert (!force_on_match);
2244 if (force_on_match) {
2246 s = SvPV_force(TARG, len);
2251 SvSCREAM_off(TARG); /* disable possible screamer */
2253 rxtainted |= RX_MATCH_TAINTED(rx);
2254 m = orig + RX_OFFS(rx)[0].start;
2255 d = orig + RX_OFFS(rx)[0].end;
2257 if (m - s > strend - d) { /* faster to shorten from end */
2259 Copy(c, m, clen, char);
2264 Move(d, m, i, char);
2268 SvCUR_set(TARG, m - s);
2270 else if ((i = m - s)) { /* faster from front */
2273 Move(s, d - i, i, char);
2276 Copy(c, m, clen, char);
2281 Copy(c, d, clen, char);
2286 TAINT_IF(rxtainted & 1);
2288 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2295 if (iters++ > maxiters)
2296 DIE(aTHX_ "Substitution loop");
2297 rxtainted |= RX_MATCH_TAINTED(rx);
2298 m = RX_OFFS(rx)[0].start + orig;
2301 Move(s, d, i, char);
2305 Copy(c, d, clen, char);
2308 s = RX_OFFS(rx)[0].end + orig;
2309 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2311 /* don't match same null twice */
2312 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2315 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2316 Move(s, d, i+1, char); /* include the NUL */
2318 TAINT_IF(rxtainted & 1);
2320 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2325 (void)SvPOK_only_UTF8(TARG);
2326 TAINT_IF(rxtainted);
2327 if (SvSMAGICAL(TARG)) {
2335 LEAVE_SCOPE(oldsave);
2341 if (force_on_match) {
2343 s = SvPV_force(TARG, len);
2346 #ifdef PERL_OLD_COPY_ON_WRITE
2349 rxtainted |= RX_MATCH_TAINTED(rx);
2350 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2354 register PERL_CONTEXT *cx;
2357 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2359 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2361 if (iters++ > maxiters)
2362 DIE(aTHX_ "Substitution loop");
2363 rxtainted |= RX_MATCH_TAINTED(rx);
2364 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2367 orig = RX_SUBBEG(rx);
2369 strend = s + (strend - m);
2371 m = RX_OFFS(rx)[0].start + orig;
2372 if (doutf8 && !SvUTF8(dstr))
2373 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2375 sv_catpvn(dstr, s, m-s);
2376 s = RX_OFFS(rx)[0].end + orig;
2378 sv_catpvn(dstr, c, clen);
2381 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2382 TARG, NULL, r_flags));
2383 if (doutf8 && !DO_UTF8(TARG))
2384 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2386 sv_catpvn(dstr, s, strend - s);
2388 #ifdef PERL_OLD_COPY_ON_WRITE
2389 /* The match may make the string COW. If so, brilliant, because that's
2390 just saved us one malloc, copy and free - the regexp has donated
2391 the old buffer, and we malloc an entirely new one, rather than the
2392 regexp malloc()ing a buffer and copying our original, only for
2393 us to throw it away here during the substitution. */
2394 if (SvIsCOW(TARG)) {
2395 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2401 SvPV_set(TARG, SvPVX(dstr));
2402 SvCUR_set(TARG, SvCUR(dstr));
2403 SvLEN_set(TARG, SvLEN(dstr));
2404 doutf8 |= DO_UTF8(dstr);
2405 SvPV_set(dstr, NULL);
2407 TAINT_IF(rxtainted & 1);
2409 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2414 (void)SvPOK_only(TARG);
2417 TAINT_IF(rxtainted);
2420 LEAVE_SCOPE(oldsave);
2428 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2432 LEAVE_SCOPE(oldsave);
2441 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2442 ++*PL_markstack_ptr;
2444 LEAVE_with_name("grep_item"); /* exit inner scope */
2447 if (PL_stack_base + *PL_markstack_ptr > SP) {
2449 const I32 gimme = GIMME_V;
2451 LEAVE_with_name("grep"); /* exit outer scope */
2452 (void)POPMARK; /* pop src */
2453 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2454 (void)POPMARK; /* pop dst */
2455 SP = PL_stack_base + POPMARK; /* pop original mark */
2456 if (gimme == G_SCALAR) {
2457 if (PL_op->op_private & OPpGREP_LEX) {
2458 SV* const sv = sv_newmortal();
2459 sv_setiv(sv, items);
2467 else if (gimme == G_ARRAY)
2474 ENTER_with_name("grep_item"); /* enter inner scope */
2477 src = PL_stack_base[*PL_markstack_ptr];
2479 if (PL_op->op_private & OPpGREP_LEX)
2480 PAD_SVl(PL_op->op_targ) = src;
2484 RETURNOP(cLOGOP->op_other);
2495 register PERL_CONTEXT *cx;
2498 if (CxMULTICALL(&cxstack[cxstack_ix]))
2502 cxstack_ix++; /* temporarily protect top context */
2505 if (gimme == G_SCALAR) {
2508 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2510 *MARK = SvREFCNT_inc(TOPs);
2515 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2517 *MARK = sv_mortalcopy(sv);
2522 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2526 *MARK = &PL_sv_undef;
2530 else if (gimme == G_ARRAY) {
2531 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2532 if (!SvTEMP(*MARK)) {
2533 *MARK = sv_mortalcopy(*MARK);
2534 TAINT_NOT; /* Each item is independent */
2542 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2543 PL_curpm = newpm; /* ... and pop $1 et al */
2546 return cx->blk_sub.retop;
2549 /* This duplicates the above code because the above code must not
2550 * get any slower by more conditions */
2558 register PERL_CONTEXT *cx;
2561 if (CxMULTICALL(&cxstack[cxstack_ix]))
2565 cxstack_ix++; /* temporarily protect top context */
2569 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2570 /* We are an argument to a function or grep().
2571 * This kind of lvalueness was legal before lvalue
2572 * subroutines too, so be backward compatible:
2573 * cannot report errors. */
2575 /* Scalar context *is* possible, on the LHS of -> only,
2576 * as in f()->meth(). But this is not an lvalue. */
2577 if (gimme == G_SCALAR)
2579 if (gimme == G_ARRAY) {
2581 /* We want an array here, but padav will have left us an arrayref for an lvalue,
2582 * so we need to expand it */
2583 if(SvTYPE(*mark) == SVt_PVAV) {
2584 AV *const av = MUTABLE_AV(*mark);
2585 const I32 maxarg = AvFILL(av) + 1;
2586 (void)POPs; /* get rid of the array ref */
2588 if (SvRMAGICAL(av)) {
2590 for (i=0; i < (U32)maxarg; i++) {
2591 SV ** const svp = av_fetch(av, i, FALSE);
2593 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2598 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2603 if (!CvLVALUE(cx->blk_sub.cv))
2604 goto temporise_array;
2605 EXTEND_MORTAL(SP - newsp);
2606 for (mark = newsp + 1; mark <= SP; mark++) {
2609 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2610 *mark = sv_mortalcopy(*mark);
2612 /* Can be a localized value subject to deletion. */
2613 PL_tmps_stack[++PL_tmps_ix] = *mark;
2614 SvREFCNT_inc_void(*mark);
2619 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2620 /* Here we go for robustness, not for speed, so we change all
2621 * the refcounts so the caller gets a live guy. Cannot set
2622 * TEMP, so sv_2mortal is out of question. */
2623 if (!CvLVALUE(cx->blk_sub.cv)) {
2629 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2631 if (gimme == G_SCALAR) {
2635 /* Temporaries are bad unless they happen to have set magic
2636 * attached, such as the elements of a tied hash or array */
2637 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2638 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2641 !SvSMAGICAL(TOPs)) {
2647 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2648 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2649 : "a readonly value" : "a temporary");
2651 else { /* Can be a localized value
2652 * subject to deletion. */
2653 PL_tmps_stack[++PL_tmps_ix] = *mark;
2654 SvREFCNT_inc_void(*mark);
2657 else { /* Should not happen? */
2663 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2664 (MARK > SP ? "Empty array" : "Array"));
2668 else if (gimme == G_ARRAY) {
2669 EXTEND_MORTAL(SP - newsp);
2670 for (mark = newsp + 1; mark <= SP; mark++) {
2671 if (*mark != &PL_sv_undef
2672 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2673 /* Might be flattened array after $#array = */
2680 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2681 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2684 /* Can be a localized value subject to deletion. */
2685 PL_tmps_stack[++PL_tmps_ix] = *mark;
2686 SvREFCNT_inc_void(*mark);
2692 if (gimme == G_SCALAR) {
2696 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2698 *MARK = SvREFCNT_inc(TOPs);
2703 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2705 *MARK = sv_mortalcopy(sv);
2710 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2714 *MARK = &PL_sv_undef;
2718 else if (gimme == G_ARRAY) {
2720 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2721 if (!SvTEMP(*MARK)) {
2722 *MARK = sv_mortalcopy(*MARK);
2723 TAINT_NOT; /* Each item is independent */
2732 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2733 PL_curpm = newpm; /* ... and pop $1 et al */
2736 return cx->blk_sub.retop;
2744 register PERL_CONTEXT *cx;
2746 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2749 DIE(aTHX_ "Not a CODE reference");
2750 switch (SvTYPE(sv)) {
2751 /* This is overwhelming the most common case: */
2753 if (!isGV_with_GP(sv))
2754 DIE(aTHX_ "Not a CODE reference");
2756 if (!(cv = GvCVu((const GV *)sv))) {
2758 cv = sv_2cv(sv, &stash, &gv, 0);
2767 if(isGV_with_GP(sv)) goto we_have_a_glob;
2770 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2772 SP = PL_stack_base + POPMARK;
2780 sv = amagic_deref_call(sv, to_cv_amg);
2781 /* Don't SPAGAIN here. */
2787 sym = SvPV_nomg_const(sv, len);
2789 DIE(aTHX_ PL_no_usym, "a subroutine");
2790 if (PL_op->op_private & HINT_STRICT_REFS)
2791 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2792 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2795 cv = MUTABLE_CV(SvRV(sv));
2796 if (SvTYPE(cv) == SVt_PVCV)
2801 DIE(aTHX_ "Not a CODE reference");
2802 /* This is the second most common case: */
2804 cv = MUTABLE_CV(sv);
2812 if (CvCLONE(cv) && ! CvCLONED(cv))
2813 DIE(aTHX_ "Closure prototype called");
2814 if (!CvROOT(cv) && !CvXSUB(cv)) {
2818 /* anonymous or undef'd function leaves us no recourse */
2819 if (CvANON(cv) || !(gv = CvGV(cv)))
2820 DIE(aTHX_ "Undefined subroutine called");
2822 /* autoloaded stub? */
2823 if (cv != GvCV(gv)) {
2826 /* should call AUTOLOAD now? */
2829 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2836 sub_name = sv_newmortal();
2837 gv_efullname3(sub_name, gv, NULL);
2838 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2842 DIE(aTHX_ "Not a CODE reference");
2847 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2848 Perl_get_db_sub(aTHX_ &sv, cv);
2850 PL_curcopdb = PL_curcop;
2852 /* check for lsub that handles lvalue subroutines */
2853 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2854 /* if lsub not found then fall back to DB::sub */
2855 if (!cv) cv = GvCV(PL_DBsub);
2857 cv = GvCV(PL_DBsub);
2860 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2861 DIE(aTHX_ "No DB::sub routine defined");
2864 if (!(CvISXSUB(cv))) {
2865 /* This path taken at least 75% of the time */
2867 register I32 items = SP - MARK;
2868 AV* const padlist = CvPADLIST(cv);
2869 PUSHBLOCK(cx, CXt_SUB, MARK);
2871 cx->blk_sub.retop = PL_op->op_next;
2873 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2874 * that eval'' ops within this sub know the correct lexical space.
2875 * Owing the speed considerations, we choose instead to search for
2876 * the cv using find_runcv() when calling doeval().
2878 if (CvDEPTH(cv) >= 2) {
2879 PERL_STACK_OVERFLOW_CHECK();
2880 pad_push(padlist, CvDEPTH(cv));
2883 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2885 AV *const av = MUTABLE_AV(PAD_SVl(0));
2887 /* @_ is normally not REAL--this should only ever
2888 * happen when DB::sub() calls things that modify @_ */
2893 cx->blk_sub.savearray = GvAV(PL_defgv);
2894 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2895 CX_CURPAD_SAVE(cx->blk_sub);
2896 cx->blk_sub.argarray = av;
2899 if (items > AvMAX(av) + 1) {
2900 SV **ary = AvALLOC(av);
2901 if (AvARRAY(av) != ary) {
2902 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2905 if (items > AvMAX(av) + 1) {
2906 AvMAX(av) = items - 1;
2907 Renew(ary,items,SV*);
2912 Copy(MARK,AvARRAY(av),items,SV*);
2913 AvFILLp(av) = items - 1;
2921 /* warning must come *after* we fully set up the context
2922 * stuff so that __WARN__ handlers can safely dounwind()
2925 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2926 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2927 sub_crush_depth(cv);
2928 RETURNOP(CvSTART(cv));
2931 I32 markix = TOPMARK;
2936 /* Need to copy @_ to stack. Alternative may be to
2937 * switch stack to @_, and copy return values
2938 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2939 AV * const av = GvAV(PL_defgv);
2940 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2943 /* Mark is at the end of the stack. */
2945 Copy(AvARRAY(av), SP + 1, items, SV*);
2950 /* We assume first XSUB in &DB::sub is the called one. */
2952 SAVEVPTR(PL_curcop);
2953 PL_curcop = PL_curcopdb;
2956 /* Do we need to open block here? XXXX */
2958 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2960 CvXSUB(cv)(aTHX_ cv);
2962 /* Enforce some sanity in scalar context. */
2963 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2964 if (markix > PL_stack_sp - PL_stack_base)
2965 *(PL_stack_base + markix) = &PL_sv_undef;
2967 *(PL_stack_base + markix) = *PL_stack_sp;
2968 PL_stack_sp = PL_stack_base + markix;
2976 Perl_sub_crush_depth(pTHX_ CV *cv)
2978 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2981 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2983 SV* const tmpstr = sv_newmortal();
2984 gv_efullname3(tmpstr, CvGV(cv), NULL);
2985 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2994 SV* const elemsv = POPs;
2995 IV elem = SvIV(elemsv);
2996 AV *const av = MUTABLE_AV(POPs);
2997 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2998 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2999 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3000 bool preeminent = TRUE;
3003 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3004 Perl_warner(aTHX_ packWARN(WARN_MISC),
3005 "Use of reference \"%"SVf"\" as array index",
3008 elem -= CopARYBASE_get(PL_curcop);
3009 if (SvTYPE(av) != SVt_PVAV)
3016 /* If we can determine whether the element exist,
3017 * Try to preserve the existenceness of a tied array
3018 * element by using EXISTS and DELETE if possible.
3019 * Fallback to FETCH and STORE otherwise. */
3020 if (SvCANEXISTDELETE(av))
3021 preeminent = av_exists(av, elem);
3024 svp = av_fetch(av, elem, lval && !defer);
3026 #ifdef PERL_MALLOC_WRAP
3027 if (SvUOK(elemsv)) {
3028 const UV uv = SvUV(elemsv);
3029 elem = uv > IV_MAX ? IV_MAX : uv;
3031 else if (SvNOK(elemsv))
3032 elem = (IV)SvNV(elemsv);
3034 static const char oom_array_extend[] =
3035 "Out of memory during array extend"; /* Duplicated in av.c */
3036 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3039 if (!svp || *svp == &PL_sv_undef) {
3042 DIE(aTHX_ PL_no_aelem, elem);
3043 lv = sv_newmortal();
3044 sv_upgrade(lv, SVt_PVLV);
3046 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3047 LvTARG(lv) = SvREFCNT_inc_simple(av);
3048 LvTARGOFF(lv) = elem;
3055 save_aelem(av, elem, svp);
3057 SAVEADELETE(av, elem);
3059 else if (PL_op->op_private & OPpDEREF)
3060 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3062 sv = (svp ? *svp : &PL_sv_undef);
3063 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3070 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3072 PERL_ARGS_ASSERT_VIVIFY_REF;
3077 Perl_croak_no_modify(aTHX);
3078 prepare_SV_for_RV(sv);
3081 SvRV_set(sv, newSV(0));
3084 SvRV_set(sv, MUTABLE_SV(newAV()));
3087 SvRV_set(sv, MUTABLE_SV(newHV()));
3098 SV* const sv = TOPs;
3101 SV* const rsv = SvRV(sv);
3102 if (SvTYPE(rsv) == SVt_PVCV) {
3108 SETs(method_common(sv, NULL));
3115 SV* const sv = cSVOP_sv;
3116 U32 hash = SvSHARED_HASH(sv);
3118 XPUSHs(method_common(sv, &hash));
3123 S_method_common(pTHX_ SV* meth, U32* hashp)
3129 const char* packname = NULL;
3132 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3134 PERL_ARGS_ASSERT_METHOD_COMMON;
3137 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3142 ob = MUTABLE_SV(SvRV(sv));
3146 /* this isn't a reference */
3147 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3148 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3150 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3157 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3158 !(ob=MUTABLE_SV(GvIO(iogv))))
3160 /* this isn't the name of a filehandle either */
3162 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3163 ? !isIDFIRST_utf8((U8*)packname)
3164 : !isIDFIRST(*packname)
3167 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3169 SvOK(sv) ? "without a package or object reference"
3170 : "on an undefined value");
3172 /* assume it's a package name */
3173 stash = gv_stashpvn(packname, packlen, 0);
3177 SV* const ref = newSViv(PTR2IV(stash));
3178 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3182 /* it _is_ a filehandle name -- replace with a reference */
3183 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3186 /* if we got here, ob should be a reference or a glob */
3187 if (!ob || !(SvOBJECT(ob)
3188 || (SvTYPE(ob) == SVt_PVGV
3190 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3193 const char * const name = SvPV_nolen_const(meth);
3194 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3195 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3199 stash = SvSTASH(ob);
3202 /* NOTE: stash may be null, hope hv_fetch_ent and
3203 gv_fetchmethod can cope (it seems they can) */
3205 /* shortcut for simple names */
3207 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3209 gv = MUTABLE_GV(HeVAL(he));
3210 if (isGV(gv) && GvCV(gv) &&
3211 (!GvCVGEN(gv) || GvCVGEN(gv)
3212 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3213 return MUTABLE_SV(GvCV(gv));
3217 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3218 SvPV_nolen_const(meth),
3219 GV_AUTOLOAD | GV_CROAK);
3223 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3228 * c-indentation-style: bsd
3230 * indent-tabs-mode: t
3233 * ex: set ts=8 sts=4 sw=4 noet: