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 U32 gv_type = SvTYPE(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 && gv_type != SVt_PVGV && 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. */
153 if (gv_type != SVt_PVGV) {
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);
220 TAINT_NOT; /* Each statement is presumed innocent */
221 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
223 oldsave = PL_scopestack[PL_scopestack_ix - 1];
224 LEAVE_SCOPE(oldsave);
230 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
235 const char *rpv = NULL;
237 bool rcopied = FALSE;
239 if (TARG == right && right != left) { /* $r = $l.$r */
240 rpv = SvPV_nomg_const(right, rlen);
241 rbyte = !DO_UTF8(right);
242 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
243 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
247 if (TARG != left) { /* not $l .= $r */
249 const char* const lpv = SvPV_nomg_const(left, llen);
250 lbyte = !DO_UTF8(left);
251 sv_setpvn(TARG, lpv, llen);
257 else { /* $l .= $r */
259 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
260 report_uninit(right);
263 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
264 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
271 /* $r.$r: do magic twice: tied might return different 2nd time */
273 rpv = SvPV_nomg_const(right, rlen);
274 rbyte = !DO_UTF8(right);
276 if (lbyte != rbyte) {
278 sv_utf8_upgrade_nomg(TARG);
281 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
282 sv_utf8_upgrade_nomg(right);
283 rpv = SvPV_nomg_const(right, rlen);
286 sv_catpvn_nomg(TARG, rpv, rlen);
297 if (PL_op->op_flags & OPf_MOD) {
298 if (PL_op->op_private & OPpLVAL_INTRO)
299 if (!(PL_op->op_private & OPpPAD_STATE))
300 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
301 if (PL_op->op_private & OPpDEREF) {
303 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
313 tryAMAGICunTARGET(iter, 0);
314 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
315 if (!isGV_with_GP(PL_last_in_gv)) {
316 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
317 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
320 XPUSHs(MUTABLE_SV(PL_last_in_gv));
323 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
326 return do_readline();
332 tryAMAGICbin_MG(eq_amg, AMGf_set);
333 #ifndef NV_PRESERVES_UV
334 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
336 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
340 #ifdef PERL_PRESERVE_IVUV
341 SvIV_please_nomg(TOPs);
343 /* Unless the left argument is integer in range we are going
344 to have to use NV maths. Hence only attempt to coerce the
345 right argument if we know the left is integer. */
346 SvIV_please_nomg(TOPm1s);
348 const bool auvok = SvUOK(TOPm1s);
349 const bool buvok = SvUOK(TOPs);
351 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
352 /* Casting IV to UV before comparison isn't going to matter
353 on 2s complement. On 1s complement or sign&magnitude
354 (if we have any of them) it could to make negative zero
355 differ from normal zero. As I understand it. (Need to
356 check - is negative zero implementation defined behaviour
358 const UV buv = SvUVX(POPs);
359 const UV auv = SvUVX(TOPs);
361 SETs(boolSV(auv == buv));
364 { /* ## Mixed IV,UV ## */
368 /* == is commutative so doesn't matter which is left or right */
370 /* top of stack (b) is the iv */
379 /* As uv is a UV, it's >0, so it cannot be == */
382 /* we know iv is >= 0 */
383 SETs(boolSV((UV)iv == SvUVX(uvp)));
390 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
392 if (Perl_isnan(left) || Perl_isnan(right))
394 SETs(boolSV(left == right));
397 SETs(boolSV(SvNV_nomg(TOPs) == value));
406 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
407 Perl_croak_no_modify(aTHX);
408 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
409 && SvIVX(TOPs) != IV_MAX)
411 SvIV_set(TOPs, SvIVX(TOPs) + 1);
412 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
414 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
427 if (PL_op->op_type == OP_OR)
429 RETURNOP(cLOGOP->op_other);
438 const int op_type = PL_op->op_type;
439 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
444 if (!sv || !SvANY(sv)) {
445 if (op_type == OP_DOR)
447 RETURNOP(cLOGOP->op_other);
453 if (!sv || !SvANY(sv))
458 switch (SvTYPE(sv)) {
460 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
464 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
468 if (CvROOT(sv) || CvXSUB(sv))
481 if(op_type == OP_DOR)
483 RETURNOP(cLOGOP->op_other);
485 /* assuming OP_DEFINED */
493 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
494 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
498 useleft = USE_LEFT(svl);
499 #ifdef PERL_PRESERVE_IVUV
500 /* We must see if we can perform the addition with integers if possible,
501 as the integer code detects overflow while the NV code doesn't.
502 If either argument hasn't had a numeric conversion yet attempt to get
503 the IV. It's important to do this now, rather than just assuming that
504 it's not IOK as a PV of "9223372036854775806" may not take well to NV
505 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
506 integer in case the second argument is IV=9223372036854775806
507 We can (now) rely on sv_2iv to do the right thing, only setting the
508 public IOK flag if the value in the NV (or PV) slot is truly integer.
510 A side effect is that this also aggressively prefers integer maths over
511 fp maths for integer values.
513 How to detect overflow?
515 C 99 section 6.2.6.1 says
517 The range of nonnegative values of a signed integer type is a subrange
518 of the corresponding unsigned integer type, and the representation of
519 the same value in each type is the same. A computation involving
520 unsigned operands can never overflow, because a result that cannot be
521 represented by the resulting unsigned integer type is reduced modulo
522 the number that is one greater than the largest value that can be
523 represented by the resulting type.
527 which I read as "unsigned ints wrap."
529 signed integer overflow seems to be classed as "exception condition"
531 If an exceptional condition occurs during the evaluation of an
532 expression (that is, if the result is not mathematically defined or not
533 in the range of representable values for its type), the behavior is
536 (6.5, the 5th paragraph)
538 I had assumed that on 2s complement machines signed arithmetic would
539 wrap, hence coded pp_add and pp_subtract on the assumption that
540 everything perl builds on would be happy. After much wailing and
541 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
542 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
543 unsigned code below is actually shorter than the old code. :-)
546 SvIV_please_nomg(svr);
549 /* Unless the left argument is integer in range we are going to have to
550 use NV maths. Hence only attempt to coerce the right argument if
551 we know the left is integer. */
559 /* left operand is undef, treat as zero. + 0 is identity,
560 Could SETi or SETu right now, but space optimise by not adding
561 lots of code to speed up what is probably a rarish case. */
563 /* Left operand is defined, so is it IV? */
564 SvIV_please_nomg(svl);
566 if ((auvok = SvUOK(svl)))
569 register const IV aiv = SvIVX(svl);
572 auvok = 1; /* Now acting as a sign flag. */
573 } else { /* 2s complement assumption for IV_MIN */
581 bool result_good = 0;
584 bool buvok = SvUOK(svr);
589 register const IV biv = SvIVX(svr);
596 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
597 else "IV" now, independent of how it came in.
598 if a, b represents positive, A, B negative, a maps to -A etc
603 all UV maths. negate result if A negative.
604 add if signs same, subtract if signs differ. */
610 /* Must get smaller */
616 /* result really should be -(auv-buv). as its negation
617 of true value, need to swap our result flag */
634 if (result <= (UV)IV_MIN)
637 /* result valid, but out of range for IV. */
642 } /* Overflow, drop through to NVs. */
647 NV value = SvNV_nomg(svr);
650 /* left operand is undef, treat as zero. + 0.0 is identity. */
654 SETn( value + SvNV_nomg(svl) );
662 AV * const av = PL_op->op_flags & OPf_SPECIAL
663 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
664 const U32 lval = PL_op->op_flags & OPf_MOD;
665 SV** const svp = av_fetch(av, PL_op->op_private, lval);
666 SV *sv = (svp ? *svp : &PL_sv_undef);
668 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
676 dVAR; dSP; dMARK; dTARGET;
678 do_join(TARG, *MARK, MARK, SP);
689 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
690 * will be enough to hold an OP*.
692 SV* const sv = sv_newmortal();
693 sv_upgrade(sv, SVt_PVLV);
695 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
698 XPUSHs(MUTABLE_SV(PL_op));
703 /* Oversized hot code. */
707 dVAR; dSP; dMARK; dORIGMARK;
712 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
714 if (gv && (io = GvIO(gv))
715 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
718 if (MARK == ORIGMARK) {
719 /* If using default handle then we need to make space to
720 * pass object as 1st arg, so move other args up ...
724 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
728 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
730 ENTER_with_name("call_PRINT");
731 if( PL_op->op_type == OP_SAY ) {
732 /* local $\ = "\n" */
733 SAVEGENERICSV(PL_ors_sv);
734 PL_ors_sv = newSVpvs("\n");
736 call_method("PRINT", G_SCALAR);
737 LEAVE_with_name("call_PRINT");
744 if (!(io = GvIO(gv))) {
745 if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
746 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
748 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
749 report_evil_fh(gv, io, PL_op->op_type);
750 SETERRNO(EBADF,RMS_IFI);
753 else if (!(fp = IoOFP(io))) {
754 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
756 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
757 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
758 report_evil_fh(gv, io, PL_op->op_type);
760 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
764 SV * const ofs = GvSV(PL_ofsgv); /* $, */
766 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
768 if (!do_print(*MARK, fp))
772 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
773 if (!do_print(GvSV(PL_ofsgv), fp)) {
782 if (!do_print(*MARK, fp))
790 if (PL_op->op_type == OP_SAY) {
791 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
794 else if (PL_ors_sv && SvOK(PL_ors_sv))
795 if (!do_print(PL_ors_sv, fp)) /* $\ */
798 if (IoFLAGS(io) & IOf_FLUSH)
799 if (PerlIO_flush(fp) == EOF)
809 XPUSHs(&PL_sv_undef);
816 const I32 gimme = GIMME_V;
817 static const char an_array[] = "an ARRAY";
818 static const char a_hash[] = "a HASH";
819 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
820 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
822 if (!(PL_op->op_private & OPpDEREFed))
825 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
828 if (SvTYPE(sv) != type)
829 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
830 if (PL_op->op_flags & OPf_REF) {
835 if (gimme != G_ARRAY)
836 goto croak_cant_return;
840 else if (PL_op->op_flags & OPf_MOD
841 && PL_op->op_private & OPpLVAL_INTRO)
842 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
845 if (SvTYPE(sv) == type) {
846 if (PL_op->op_flags & OPf_REF) {
851 if (gimme != G_ARRAY)
852 goto croak_cant_return;
860 if (!isGV_with_GP(sv)) {
861 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
869 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
870 if (PL_op->op_private & OPpLVAL_INTRO)
871 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
872 if (PL_op->op_flags & OPf_REF) {
877 if (gimme != G_ARRAY)
878 goto croak_cant_return;
886 AV *const av = MUTABLE_AV(sv);
887 /* The guts of pp_rv2av, with no intenting change to preserve history
888 (until such time as we get tools that can do blame annotation across
889 whitespace changes. */
890 if (gimme == G_ARRAY) {
891 const I32 maxarg = AvFILL(av) + 1;
892 (void)POPs; /* XXXX May be optimized away? */
894 if (SvRMAGICAL(av)) {
896 for (i=0; i < (U32)maxarg; i++) {
897 SV ** const svp = av_fetch(av, i, FALSE);
898 /* See note in pp_helem, and bug id #27839 */
900 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
905 Copy(AvARRAY(av), SP+1, maxarg, SV*);
909 else if (gimme == G_SCALAR) {
911 const I32 maxarg = AvFILL(av) + 1;
915 /* The guts of pp_rv2hv */
916 if (gimme == G_ARRAY) { /* array wanted */
920 else if (gimme == G_SCALAR) {
922 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
930 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
931 is_pp_rv2av ? "array" : "hash");
936 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
940 PERL_ARGS_ASSERT_DO_ODDBALL;
946 if (ckWARN(WARN_MISC)) {
948 if (relem == firstrelem &&
950 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
951 SvTYPE(SvRV(*relem)) == SVt_PVHV))
953 err = "Reference found where even-sized list expected";
956 err = "Odd number of elements in hash assignment";
957 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
961 didstore = hv_store_ent(hash,*relem,tmpstr,0);
962 if (SvMAGICAL(hash)) {
963 if (SvSMAGICAL(tmpstr))
975 SV **lastlelem = PL_stack_sp;
976 SV **lastrelem = PL_stack_base + POPMARK;
977 SV **firstrelem = PL_stack_base + POPMARK + 1;
978 SV **firstlelem = lastrelem + 1;
991 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
993 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
996 /* If there's a common identifier on both sides we have to take
997 * special care that assigning the identifier on the left doesn't
998 * clobber a value on the right that's used later in the list.
1000 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1001 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1002 for (relem = firstrelem; relem <= lastrelem; relem++) {
1003 if ((sv = *relem)) {
1004 TAINT_NOT; /* Each item is independent */
1006 /* Dear TODO test in t/op/sort.t, I love you.
1007 (It's relying on a panic, not a "semi-panic" from newSVsv()
1008 and then an assertion failure below.) */
1009 if (SvIS_FREED(sv)) {
1010 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1013 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1014 and we need a second copy of a temp here. */
1015 *relem = sv_2mortal(newSVsv(sv));
1025 while (lelem <= lastlelem) {
1026 TAINT_NOT; /* Each item stands on its own, taintwise. */
1028 switch (SvTYPE(sv)) {
1030 ary = MUTABLE_AV(sv);
1031 magic = SvMAGICAL(ary) != 0;
1033 av_extend(ary, lastrelem - relem);
1035 while (relem <= lastrelem) { /* gobble up all the rest */
1039 sv_setsv(sv, *relem);
1041 didstore = av_store(ary,i++,sv);
1050 if (PL_delaymagic & DM_ARRAY_ISA)
1051 SvSETMAGIC(MUTABLE_SV(ary));
1053 case SVt_PVHV: { /* normal hash */
1056 hash = MUTABLE_HV(sv);
1057 magic = SvMAGICAL(hash) != 0;
1059 firsthashrelem = relem;
1061 while (relem < lastrelem) { /* gobble up all the rest */
1063 sv = *relem ? *relem : &PL_sv_no;
1067 sv_setsv(tmpstr,*relem); /* value */
1068 *(relem++) = tmpstr;
1069 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1070 /* key overwrites an existing entry */
1072 didstore = hv_store_ent(hash,sv,tmpstr,0);
1074 if (SvSMAGICAL(tmpstr))
1081 if (relem == lastrelem) {
1082 do_oddball(hash, relem, firstrelem);
1088 if (SvIMMORTAL(sv)) {
1089 if (relem <= lastrelem)
1093 if (relem <= lastrelem) {
1094 sv_setsv(sv, *relem);
1098 sv_setsv(sv, &PL_sv_undef);
1103 if (PL_delaymagic & ~DM_DELAY) {
1104 if (PL_delaymagic & DM_UID) {
1105 #ifdef HAS_SETRESUID
1106 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1107 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1110 # ifdef HAS_SETREUID
1111 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1112 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1115 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1116 (void)setruid(PL_uid);
1117 PL_delaymagic &= ~DM_RUID;
1119 # endif /* HAS_SETRUID */
1121 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1122 (void)seteuid(PL_euid);
1123 PL_delaymagic &= ~DM_EUID;
1125 # endif /* HAS_SETEUID */
1126 if (PL_delaymagic & DM_UID) {
1127 if (PL_uid != PL_euid)
1128 DIE(aTHX_ "No setreuid available");
1129 (void)PerlProc_setuid(PL_uid);
1131 # endif /* HAS_SETREUID */
1132 #endif /* HAS_SETRESUID */
1133 PL_uid = PerlProc_getuid();
1134 PL_euid = PerlProc_geteuid();
1136 if (PL_delaymagic & DM_GID) {
1137 #ifdef HAS_SETRESGID
1138 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1139 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1142 # ifdef HAS_SETREGID
1143 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1144 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1147 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1148 (void)setrgid(PL_gid);
1149 PL_delaymagic &= ~DM_RGID;
1151 # endif /* HAS_SETRGID */
1153 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1154 (void)setegid(PL_egid);
1155 PL_delaymagic &= ~DM_EGID;
1157 # endif /* HAS_SETEGID */
1158 if (PL_delaymagic & DM_GID) {
1159 if (PL_gid != PL_egid)
1160 DIE(aTHX_ "No setregid available");
1161 (void)PerlProc_setgid(PL_gid);
1163 # endif /* HAS_SETREGID */
1164 #endif /* HAS_SETRESGID */
1165 PL_gid = PerlProc_getgid();
1166 PL_egid = PerlProc_getegid();
1168 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1172 if (gimme == G_VOID)
1173 SP = firstrelem - 1;
1174 else if (gimme == G_SCALAR) {
1177 SETi(lastrelem - firstrelem + 1 - duplicates);
1184 /* Removes from the stack the entries which ended up as
1185 * duplicated keys in the hash (fix for [perl #24380]) */
1186 Move(firsthashrelem + duplicates,
1187 firsthashrelem, duplicates, SV**);
1188 lastrelem -= duplicates;
1193 SP = firstrelem + (lastlelem - firstlelem);
1194 lelem = firstlelem + (relem - firstrelem);
1196 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1205 register PMOP * const pm = cPMOP;
1206 REGEXP * rx = PM_GETRE(pm);
1207 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1208 SV * const rv = sv_newmortal();
1210 SvUPGRADE(rv, SVt_IV);
1211 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1212 loathe to use it here, but it seems to be the right fix. Or close.
1213 The key part appears to be that it's essential for pp_qr to return a new
1214 object (SV), which implies that there needs to be an effective way to
1215 generate a new SV from the existing SV that is pre-compiled in the
1217 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1221 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1223 (void)sv_bless(rv, stash);
1226 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1235 register PMOP *pm = cPMOP;
1237 register const char *t;
1238 register const char *s;
1241 U8 r_flags = REXEC_CHECKED;
1242 const char *truebase; /* Start of string */
1243 register REGEXP *rx = PM_GETRE(pm);
1245 const I32 gimme = GIMME;
1248 const I32 oldsave = PL_savestack_ix;
1249 I32 update_minmatch = 1;
1250 I32 had_zerolen = 0;
1253 if (PL_op->op_flags & OPf_STACKED)
1255 else if (PL_op->op_private & OPpTARGET_MY)
1262 PUTBACK; /* EVAL blocks need stack_sp. */
1263 /* Skip get-magic if this is a qr// clone, because regcomp has
1265 s = ((struct regexp *)SvANY(rx))->mother_re
1266 ? SvPV_nomg_const(TARG, len)
1267 : SvPV_const(TARG, len);
1269 DIE(aTHX_ "panic: pp_match");
1271 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1272 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1275 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1277 /* PMdf_USED is set after a ?? matches once */
1280 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1282 pm->op_pmflags & PMf_USED
1286 if (gimme == G_ARRAY)
1293 /* empty pattern special-cased to use last successful pattern if possible */
1294 if (!RX_PRELEN(rx) && PL_curpm) {
1299 if (RX_MINLEN(rx) > (I32)len)
1304 /* XXXX What part of this is needed with true \G-support? */
1305 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1306 RX_OFFS(rx)[0].start = -1;
1307 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1308 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1309 if (mg && mg->mg_len >= 0) {
1310 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1311 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1312 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1313 r_flags |= REXEC_IGNOREPOS;
1314 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1315 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1318 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1319 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1320 update_minmatch = 0;
1324 /* XXX: comment out !global get safe $1 vars after a
1325 match, BUT be aware that this leads to dramatic slowdowns on
1326 /g matches against large strings. So far a solution to this problem
1327 appears to be quite tricky.
1328 Test for the unsafe vars are TODO for now. */
1329 if (( !global && RX_NPARENS(rx))
1330 || SvTEMP(TARG) || PL_sawampersand ||
1331 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1332 r_flags |= REXEC_COPY_STR;
1334 r_flags |= REXEC_SCREAM;
1337 if (global && RX_OFFS(rx)[0].start != -1) {
1338 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1339 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1341 if (update_minmatch++)
1342 minmatch = had_zerolen;
1344 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1345 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1346 /* FIXME - can PL_bostr be made const char *? */
1347 PL_bostr = (char *)truebase;
1348 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1352 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1354 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1355 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1356 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1357 && (r_flags & REXEC_SCREAM)))
1358 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1361 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1362 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1365 if (dynpm->op_pmflags & PMf_ONCE) {
1367 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1369 dynpm->op_pmflags |= PMf_USED;
1380 RX_MATCH_TAINTED_on(rx);
1381 TAINT_IF(RX_MATCH_TAINTED(rx));
1382 if (gimme == G_ARRAY) {
1383 const I32 nparens = RX_NPARENS(rx);
1384 I32 i = (global && !nparens) ? 1 : 0;
1386 SPAGAIN; /* EVAL blocks could move the stack. */
1387 EXTEND(SP, nparens + i);
1388 EXTEND_MORTAL(nparens + i);
1389 for (i = !i; i <= nparens; i++) {
1390 PUSHs(sv_newmortal());
1391 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1392 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1393 s = RX_OFFS(rx)[i].start + truebase;
1394 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1395 len < 0 || len > strend - s)
1396 DIE(aTHX_ "panic: pp_match start/end pointers");
1397 sv_setpvn(*SP, s, len);
1398 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1403 if (dynpm->op_pmflags & PMf_CONTINUE) {
1405 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1406 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408 #ifdef PERL_OLD_COPY_ON_WRITE
1410 sv_force_normal_flags(TARG, 0);
1412 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1413 &PL_vtbl_mglob, NULL, 0);
1415 if (RX_OFFS(rx)[0].start != -1) {
1416 mg->mg_len = RX_OFFS(rx)[0].end;
1417 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1418 mg->mg_flags |= MGf_MINMATCH;
1420 mg->mg_flags &= ~MGf_MINMATCH;
1423 had_zerolen = (RX_OFFS(rx)[0].start != -1
1424 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1425 == (UV)RX_OFFS(rx)[0].end));
1426 PUTBACK; /* EVAL blocks may use stack */
1427 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1432 LEAVE_SCOPE(oldsave);
1438 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1439 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1443 #ifdef PERL_OLD_COPY_ON_WRITE
1445 sv_force_normal_flags(TARG, 0);
1447 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1448 &PL_vtbl_mglob, NULL, 0);
1450 if (RX_OFFS(rx)[0].start != -1) {
1451 mg->mg_len = RX_OFFS(rx)[0].end;
1452 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1453 mg->mg_flags |= MGf_MINMATCH;
1455 mg->mg_flags &= ~MGf_MINMATCH;
1458 LEAVE_SCOPE(oldsave);
1462 yup: /* Confirmed by INTUIT */
1464 RX_MATCH_TAINTED_on(rx);
1465 TAINT_IF(RX_MATCH_TAINTED(rx));
1467 if (dynpm->op_pmflags & PMf_ONCE) {
1469 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1471 dynpm->op_pmflags |= PMf_USED;
1474 if (RX_MATCH_COPIED(rx))
1475 Safefree(RX_SUBBEG(rx));
1476 RX_MATCH_COPIED_off(rx);
1477 RX_SUBBEG(rx) = NULL;
1479 /* FIXME - should rx->subbeg be const char *? */
1480 RX_SUBBEG(rx) = (char *) truebase;
1481 RX_OFFS(rx)[0].start = s - truebase;
1482 if (RX_MATCH_UTF8(rx)) {
1483 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1484 RX_OFFS(rx)[0].end = t - truebase;
1487 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1489 RX_SUBLEN(rx) = strend - truebase;
1492 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1494 #ifdef PERL_OLD_COPY_ON_WRITE
1495 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1497 PerlIO_printf(Perl_debug_log,
1498 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1499 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1502 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1504 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1505 assert (SvPOKp(RX_SAVED_COPY(rx)));
1510 RX_SUBBEG(rx) = savepvn(t, strend - t);
1511 #ifdef PERL_OLD_COPY_ON_WRITE
1512 RX_SAVED_COPY(rx) = NULL;
1515 RX_SUBLEN(rx) = strend - t;
1516 RX_MATCH_COPIED_on(rx);
1517 off = RX_OFFS(rx)[0].start = s - t;
1518 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1520 else { /* startp/endp are used by @- @+. */
1521 RX_OFFS(rx)[0].start = s - truebase;
1522 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1524 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1526 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1527 LEAVE_SCOPE(oldsave);
1532 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1533 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1534 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1539 LEAVE_SCOPE(oldsave);
1540 if (gimme == G_ARRAY)
1546 Perl_do_readline(pTHX)
1548 dVAR; dSP; dTARGETSTACKED;
1553 register IO * const io = GvIO(PL_last_in_gv);
1554 register const I32 type = PL_op->op_type;
1555 const I32 gimme = GIMME_V;
1558 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1561 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1563 ENTER_with_name("call_READLINE");
1564 call_method("READLINE", gimme);
1565 LEAVE_with_name("call_READLINE");
1567 if (gimme == G_SCALAR) {
1568 SV* const result = POPs;
1569 SvSetSV_nosteal(TARG, result);
1579 if (IoFLAGS(io) & IOf_ARGV) {
1580 if (IoFLAGS(io) & IOf_START) {
1582 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1583 IoFLAGS(io) &= ~IOf_START;
1584 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1585 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1586 SvSETMAGIC(GvSV(PL_last_in_gv));
1591 fp = nextargv(PL_last_in_gv);
1592 if (!fp) { /* Note: fp != IoIFP(io) */
1593 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1596 else if (type == OP_GLOB)
1597 fp = Perl_start_glob(aTHX_ POPs, io);
1599 else if (type == OP_GLOB)
1601 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1602 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1606 if ((!io || !(IoFLAGS(io) & IOf_START))
1607 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1609 if (type == OP_GLOB)
1610 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1611 "glob failed (can't start child: %s)",
1614 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1616 if (gimme == G_SCALAR) {
1617 /* undef TARG, and push that undefined value */
1618 if (type != OP_RCATLINE) {
1619 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1627 if (gimme == G_SCALAR) {
1629 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1632 if (type == OP_RCATLINE)
1633 SvPV_force_nolen(sv);
1637 else if (isGV_with_GP(sv)) {
1638 SvPV_force_nolen(sv);
1640 SvUPGRADE(sv, SVt_PV);
1641 tmplen = SvLEN(sv); /* remember if already alloced */
1642 if (!tmplen && !SvREADONLY(sv)) {
1643 /* try short-buffering it. Please update t/op/readline.t
1644 * if you change the growth length.
1649 if (type == OP_RCATLINE && SvOK(sv)) {
1651 SvPV_force_nolen(sv);
1657 sv = sv_2mortal(newSV(80));
1661 /* This should not be marked tainted if the fp is marked clean */
1662 #define MAYBE_TAINT_LINE(io, sv) \
1663 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1668 /* delay EOF state for a snarfed empty file */
1669 #define SNARF_EOF(gimme,rs,io,sv) \
1670 (gimme != G_SCALAR || SvCUR(sv) \
1671 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1675 if (!sv_gets(sv, fp, offset)
1677 || SNARF_EOF(gimme, PL_rs, io, sv)
1678 || PerlIO_error(fp)))
1680 PerlIO_clearerr(fp);
1681 if (IoFLAGS(io) & IOf_ARGV) {
1682 fp = nextargv(PL_last_in_gv);
1685 (void)do_close(PL_last_in_gv, FALSE);
1687 else if (type == OP_GLOB) {
1688 if (!do_close(PL_last_in_gv, FALSE)) {
1689 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1690 "glob failed (child exited with status %d%s)",
1691 (int)(STATUS_CURRENT >> 8),
1692 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1695 if (gimme == G_SCALAR) {
1696 if (type != OP_RCATLINE) {
1697 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1703 MAYBE_TAINT_LINE(io, sv);
1706 MAYBE_TAINT_LINE(io, sv);
1708 IoFLAGS(io) |= IOf_NOLINE;
1712 if (type == OP_GLOB) {
1715 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1716 char * const tmps = SvEND(sv) - 1;
1717 if (*tmps == *SvPVX_const(PL_rs)) {
1719 SvCUR_set(sv, SvCUR(sv) - 1);
1722 for (t1 = SvPVX_const(sv); *t1; t1++)
1723 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1724 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1726 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1727 (void)POPs; /* Unmatched wildcard? Chuck it... */
1730 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1731 if (ckWARN(WARN_UTF8)) {
1732 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1733 const STRLEN len = SvCUR(sv) - offset;
1736 if (!is_utf8_string_loc(s, len, &f))
1737 /* Emulate :encoding(utf8) warning in the same case. */
1738 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1739 "utf8 \"\\x%02X\" does not map to Unicode",
1740 f < (U8*)SvEND(sv) ? *f : 0);
1743 if (gimme == G_ARRAY) {
1744 if (SvLEN(sv) - SvCUR(sv) > 20) {
1745 SvPV_shrink_to_cur(sv);
1747 sv = sv_2mortal(newSV(80));
1750 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1751 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1752 const STRLEN new_len
1753 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1754 SvPV_renew(sv, new_len);
1763 register PERL_CONTEXT *cx;
1764 I32 gimme = OP_GIMME(PL_op, -1);
1767 if (cxstack_ix >= 0) {
1768 /* If this flag is set, we're just inside a return, so we should
1769 * store the caller's context */
1770 gimme = (PL_op->op_flags & OPf_SPECIAL)
1772 : cxstack[cxstack_ix].blk_gimme;
1777 ENTER_with_name("block");
1780 PUSHBLOCK(cx, CXt_BLOCK, SP);
1790 SV * const keysv = POPs;
1791 HV * const hv = MUTABLE_HV(POPs);
1792 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1793 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1795 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1796 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1797 bool preeminent = TRUE;
1799 if (SvTYPE(hv) != SVt_PVHV)
1806 /* If we can determine whether the element exist,
1807 * Try to preserve the existenceness of a tied hash
1808 * element by using EXISTS and DELETE if possible.
1809 * Fallback to FETCH and STORE otherwise. */
1810 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1811 preeminent = hv_exists_ent(hv, keysv, 0);
1814 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1815 svp = he ? &HeVAL(he) : NULL;
1817 if (!svp || *svp == &PL_sv_undef) {
1821 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1823 lv = sv_newmortal();
1824 sv_upgrade(lv, SVt_PVLV);
1826 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1827 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1828 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1834 if (HvNAME_get(hv) && isGV(*svp))
1835 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1836 else if (preeminent)
1837 save_helem_flags(hv, keysv, svp,
1838 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1840 SAVEHDELETE(hv, keysv);
1842 else if (PL_op->op_private & OPpDEREF)
1843 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1845 sv = (svp ? *svp : &PL_sv_undef);
1846 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1847 * was to make C<local $tied{foo} = $tied{foo}> possible.
1848 * However, it seems no longer to be needed for that purpose, and
1849 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1850 * would loop endlessly since the pos magic is getting set on the
1851 * mortal copy and lost. However, the copy has the effect of
1852 * triggering the get magic, and losing it altogether made things like
1853 * c<$tied{foo};> in void context no longer do get magic, which some
1854 * code relied on. Also, delayed triggering of magic on @+ and friends
1855 * meant the original regex may be out of scope by now. So as a
1856 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1857 * being called too many times). */
1858 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1867 register PERL_CONTEXT *cx;
1872 if (PL_op->op_flags & OPf_SPECIAL) {
1873 cx = &cxstack[cxstack_ix];
1874 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1879 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1882 if (gimme == G_VOID)
1884 else if (gimme == G_SCALAR) {
1888 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1891 *MARK = sv_mortalcopy(TOPs);
1894 *MARK = &PL_sv_undef;
1898 else if (gimme == G_ARRAY) {
1899 /* in case LEAVE wipes old return values */
1901 for (mark = newsp + 1; mark <= SP; mark++) {
1902 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1903 *mark = sv_mortalcopy(*mark);
1904 TAINT_NOT; /* Each item is independent */
1908 PL_curpm = newpm; /* Don't pop $1 et al till now */
1910 LEAVE_with_name("block");
1918 register PERL_CONTEXT *cx;
1921 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1922 bool av_is_stack = FALSE;
1925 cx = &cxstack[cxstack_ix];
1926 if (!CxTYPE_is_LOOP(cx))
1927 DIE(aTHX_ "panic: pp_iter");
1929 itersvp = CxITERVAR(cx);
1930 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1931 /* string increment */
1932 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1933 SV *end = cx->blk_loop.state_u.lazysv.end;
1934 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1935 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1937 const char *max = SvPV_const(end, maxlen);
1938 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1939 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1940 /* safe to reuse old SV */
1941 sv_setsv(*itersvp, cur);
1945 /* we need a fresh SV every time so that loop body sees a
1946 * completely new SV for closures/references to work as
1949 *itersvp = newSVsv(cur);
1950 SvREFCNT_dec(oldsv);
1952 if (strEQ(SvPVX_const(cur), max))
1953 sv_setiv(cur, 0); /* terminate next time */
1960 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1961 /* integer increment */
1962 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1965 /* don't risk potential race */
1966 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1967 /* safe to reuse old SV */
1968 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1972 /* we need a fresh SV every time so that loop body sees a
1973 * completely new SV for closures/references to work as they
1976 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1977 SvREFCNT_dec(oldsv);
1980 /* Handle end of range at IV_MAX */
1981 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1982 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1984 cx->blk_loop.state_u.lazyiv.cur++;
1985 cx->blk_loop.state_u.lazyiv.end++;
1992 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1993 av = cx->blk_loop.state_u.ary.ary;
1998 if (PL_op->op_private & OPpITER_REVERSED) {
1999 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2000 ? cx->blk_loop.resetsp + 1 : 0))
2003 if (SvMAGICAL(av) || AvREIFY(av)) {
2004 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2005 sv = svp ? *svp : NULL;
2008 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2012 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2016 if (SvMAGICAL(av) || AvREIFY(av)) {
2017 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2018 sv = svp ? *svp : NULL;
2021 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2025 if (sv && SvIS_FREED(sv)) {
2027 Perl_croak(aTHX_ "Use of freed value in iteration");
2032 SvREFCNT_inc_simple_void_NN(sv);
2036 if (!av_is_stack && sv == &PL_sv_undef) {
2037 SV *lv = newSV_type(SVt_PVLV);
2039 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2040 LvTARG(lv) = SvREFCNT_inc_simple(av);
2041 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2042 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2048 SvREFCNT_dec(oldsv);
2056 register PMOP *pm = cPMOP;
2071 register REGEXP *rx = PM_GETRE(pm);
2073 int force_on_match = 0;
2074 const I32 oldsave = PL_savestack_ix;
2076 bool doutf8 = FALSE;
2078 #ifdef PERL_OLD_COPY_ON_WRITE
2082 /* known replacement string? */
2083 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2087 if (PL_op->op_flags & OPf_STACKED)
2089 else if (PL_op->op_private & OPpTARGET_MY)
2096 /* In non-destructive replacement mode, duplicate target scalar so it
2097 * remains unchanged. */
2098 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2099 TARG = newSVsv(TARG);
2101 #ifdef PERL_OLD_COPY_ON_WRITE
2102 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2103 because they make integers such as 256 "false". */
2104 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2107 sv_force_normal_flags(TARG,0);
2110 #ifdef PERL_OLD_COPY_ON_WRITE
2114 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2115 || SvTYPE(TARG) > SVt_PVLV)
2116 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2117 Perl_croak_no_modify(aTHX);
2121 s = SvPV_mutable(TARG, len);
2122 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2124 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2125 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2130 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2134 DIE(aTHX_ "panic: pp_subst");
2137 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2138 maxiters = 2 * slen + 10; /* We can match twice at each
2139 position, once with zero-length,
2140 second time with non-zero. */
2142 if (!RX_PRELEN(rx) && PL_curpm) {
2146 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2147 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2148 ? REXEC_COPY_STR : 0;
2150 r_flags |= REXEC_SCREAM;
2153 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2155 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2159 /* How to do it in subst? */
2160 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2162 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2163 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2164 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2165 && (r_flags & REXEC_SCREAM))))
2170 /* only replace once? */
2171 once = !(rpm->op_pmflags & PMf_GLOBAL);
2172 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2173 r_flags | REXEC_CHECKED);
2174 /* known replacement string? */
2177 /* Upgrade the source if the replacement is utf8 but the source is not,
2178 * but only if it matched; see
2179 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2181 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2182 const STRLEN new_len = sv_utf8_upgrade(TARG);
2184 /* If the lengths are the same, the pattern contains only
2185 * invariants, can keep going; otherwise, various internal markers
2186 * could be off, so redo */
2187 if (new_len != len) {
2192 /* replacement needing upgrading? */
2193 if (DO_UTF8(TARG) && !doutf8) {
2194 nsv = sv_newmortal();
2197 sv_recode_to_utf8(nsv, PL_encoding);
2199 sv_utf8_upgrade(nsv);
2200 c = SvPV_const(nsv, clen);
2204 c = SvPV_const(dstr, clen);
2205 doutf8 = DO_UTF8(dstr);
2213 /* can do inplace substitution? */
2215 #ifdef PERL_OLD_COPY_ON_WRITE
2218 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2219 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2220 && (!doutf8 || SvUTF8(TARG))) {
2224 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2228 LEAVE_SCOPE(oldsave);
2231 #ifdef PERL_OLD_COPY_ON_WRITE
2232 if (SvIsCOW(TARG)) {
2233 assert (!force_on_match);
2237 if (force_on_match) {
2239 s = SvPV_force(TARG, len);
2244 SvSCREAM_off(TARG); /* disable possible screamer */
2246 rxtainted |= RX_MATCH_TAINTED(rx);
2247 m = orig + RX_OFFS(rx)[0].start;
2248 d = orig + RX_OFFS(rx)[0].end;
2250 if (m - s > strend - d) { /* faster to shorten from end */
2252 Copy(c, m, clen, char);
2257 Move(d, m, i, char);
2261 SvCUR_set(TARG, m - s);
2263 else if ((i = m - s)) { /* faster from front */
2266 Move(s, d - i, i, char);
2269 Copy(c, m, clen, char);
2274 Copy(c, d, clen, char);
2279 TAINT_IF(rxtainted & 1);
2281 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2288 if (iters++ > maxiters)
2289 DIE(aTHX_ "Substitution loop");
2290 rxtainted |= RX_MATCH_TAINTED(rx);
2291 m = RX_OFFS(rx)[0].start + orig;
2294 Move(s, d, i, char);
2298 Copy(c, d, clen, char);
2301 s = RX_OFFS(rx)[0].end + orig;
2302 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2304 /* don't match same null twice */
2305 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2308 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2309 Move(s, d, i+1, char); /* include the NUL */
2311 TAINT_IF(rxtainted & 1);
2313 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2318 (void)SvPOK_only_UTF8(TARG);
2319 TAINT_IF(rxtainted);
2320 if (SvSMAGICAL(TARG)) {
2328 LEAVE_SCOPE(oldsave);
2334 if (force_on_match) {
2336 s = SvPV_force(TARG, len);
2339 #ifdef PERL_OLD_COPY_ON_WRITE
2342 rxtainted |= RX_MATCH_TAINTED(rx);
2343 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2347 register PERL_CONTEXT *cx;
2350 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2352 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2354 if (iters++ > maxiters)
2355 DIE(aTHX_ "Substitution loop");
2356 rxtainted |= RX_MATCH_TAINTED(rx);
2357 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2360 orig = RX_SUBBEG(rx);
2362 strend = s + (strend - m);
2364 m = RX_OFFS(rx)[0].start + orig;
2365 if (doutf8 && !SvUTF8(dstr))
2366 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2368 sv_catpvn(dstr, s, m-s);
2369 s = RX_OFFS(rx)[0].end + orig;
2371 sv_catpvn(dstr, c, clen);
2374 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2375 TARG, NULL, r_flags));
2376 if (doutf8 && !DO_UTF8(TARG))
2377 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2379 sv_catpvn(dstr, s, strend - s);
2381 #ifdef PERL_OLD_COPY_ON_WRITE
2382 /* The match may make the string COW. If so, brilliant, because that's
2383 just saved us one malloc, copy and free - the regexp has donated
2384 the old buffer, and we malloc an entirely new one, rather than the
2385 regexp malloc()ing a buffer and copying our original, only for
2386 us to throw it away here during the substitution. */
2387 if (SvIsCOW(TARG)) {
2388 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2394 SvPV_set(TARG, SvPVX(dstr));
2395 SvCUR_set(TARG, SvCUR(dstr));
2396 SvLEN_set(TARG, SvLEN(dstr));
2397 doutf8 |= DO_UTF8(dstr);
2398 SvPV_set(dstr, NULL);
2400 TAINT_IF(rxtainted & 1);
2402 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2407 (void)SvPOK_only(TARG);
2410 TAINT_IF(rxtainted);
2413 LEAVE_SCOPE(oldsave);
2421 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2425 LEAVE_SCOPE(oldsave);
2434 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2435 ++*PL_markstack_ptr;
2436 LEAVE_with_name("grep_item"); /* exit inner scope */
2439 if (PL_stack_base + *PL_markstack_ptr > SP) {
2441 const I32 gimme = GIMME_V;
2443 LEAVE_with_name("grep"); /* exit outer scope */
2444 (void)POPMARK; /* pop src */
2445 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2446 (void)POPMARK; /* pop dst */
2447 SP = PL_stack_base + POPMARK; /* pop original mark */
2448 if (gimme == G_SCALAR) {
2449 if (PL_op->op_private & OPpGREP_LEX) {
2450 SV* const sv = sv_newmortal();
2451 sv_setiv(sv, items);
2459 else if (gimme == G_ARRAY)
2466 ENTER_with_name("grep_item"); /* enter inner scope */
2469 src = PL_stack_base[*PL_markstack_ptr];
2471 if (PL_op->op_private & OPpGREP_LEX)
2472 PAD_SVl(PL_op->op_targ) = src;
2476 RETURNOP(cLOGOP->op_other);
2487 register PERL_CONTEXT *cx;
2490 if (CxMULTICALL(&cxstack[cxstack_ix]))
2494 cxstack_ix++; /* temporarily protect top context */
2497 if (gimme == G_SCALAR) {
2500 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2502 *MARK = SvREFCNT_inc(TOPs);
2507 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2509 *MARK = sv_mortalcopy(sv);
2514 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2518 *MARK = &PL_sv_undef;
2522 else if (gimme == G_ARRAY) {
2523 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2524 if (!SvTEMP(*MARK)) {
2525 *MARK = sv_mortalcopy(*MARK);
2526 TAINT_NOT; /* Each item is independent */
2534 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2535 PL_curpm = newpm; /* ... and pop $1 et al */
2538 return cx->blk_sub.retop;
2541 /* This duplicates the above code because the above code must not
2542 * get any slower by more conditions */
2550 register PERL_CONTEXT *cx;
2553 if (CxMULTICALL(&cxstack[cxstack_ix]))
2557 cxstack_ix++; /* temporarily protect top context */
2561 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2562 /* We are an argument to a function or grep().
2563 * This kind of lvalueness was legal before lvalue
2564 * subroutines too, so be backward compatible:
2565 * cannot report errors. */
2567 /* Scalar context *is* possible, on the LHS of -> only,
2568 * as in f()->meth(). But this is not an lvalue. */
2569 if (gimme == G_SCALAR)
2571 if (gimme == G_ARRAY) {
2572 if (!CvLVALUE(cx->blk_sub.cv))
2573 goto temporise_array;
2574 EXTEND_MORTAL(SP - newsp);
2575 for (mark = newsp + 1; mark <= SP; mark++) {
2578 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2579 *mark = sv_mortalcopy(*mark);
2581 /* Can be a localized value subject to deletion. */
2582 PL_tmps_stack[++PL_tmps_ix] = *mark;
2583 SvREFCNT_inc_void(*mark);
2588 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2589 /* Here we go for robustness, not for speed, so we change all
2590 * the refcounts so the caller gets a live guy. Cannot set
2591 * TEMP, so sv_2mortal is out of question. */
2592 if (!CvLVALUE(cx->blk_sub.cv)) {
2598 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2600 if (gimme == G_SCALAR) {
2604 /* Temporaries are bad unless they happen to be elements
2605 * of a tied hash or array */
2606 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2607 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2613 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2614 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2615 : "a readonly value" : "a temporary");
2617 else { /* Can be a localized value
2618 * subject to deletion. */
2619 PL_tmps_stack[++PL_tmps_ix] = *mark;
2620 SvREFCNT_inc_void(*mark);
2623 else { /* Should not happen? */
2629 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2630 (MARK > SP ? "Empty array" : "Array"));
2634 else if (gimme == G_ARRAY) {
2635 EXTEND_MORTAL(SP - newsp);
2636 for (mark = newsp + 1; mark <= SP; mark++) {
2637 if (*mark != &PL_sv_undef
2638 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2639 /* Might be flattened array after $#array = */
2646 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2647 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2650 /* Can be a localized value subject to deletion. */
2651 PL_tmps_stack[++PL_tmps_ix] = *mark;
2652 SvREFCNT_inc_void(*mark);
2658 if (gimme == G_SCALAR) {
2662 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2664 *MARK = SvREFCNT_inc(TOPs);
2669 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2671 *MARK = sv_mortalcopy(sv);
2676 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2680 *MARK = &PL_sv_undef;
2684 else if (gimme == G_ARRAY) {
2686 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2687 if (!SvTEMP(*MARK)) {
2688 *MARK = sv_mortalcopy(*MARK);
2689 TAINT_NOT; /* Each item is independent */
2698 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2699 PL_curpm = newpm; /* ... and pop $1 et al */
2702 return cx->blk_sub.retop;
2710 register PERL_CONTEXT *cx;
2712 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2715 DIE(aTHX_ "Not a CODE reference");
2716 switch (SvTYPE(sv)) {
2717 /* This is overwhelming the most common case: */
2719 if (!isGV_with_GP(sv))
2720 DIE(aTHX_ "Not a CODE reference");
2721 if (!(cv = GvCVu((const GV *)sv))) {
2723 cv = sv_2cv(sv, &stash, &gv, 0);
2732 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2734 SP = PL_stack_base + POPMARK;
2739 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2740 tryAMAGICunDEREF(to_cv);
2745 sym = SvPV_nomg_const(sv, len);
2747 DIE(aTHX_ PL_no_usym, "a subroutine");
2748 if (PL_op->op_private & HINT_STRICT_REFS)
2749 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2750 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2753 cv = MUTABLE_CV(SvRV(sv));
2754 if (SvTYPE(cv) == SVt_PVCV)
2759 DIE(aTHX_ "Not a CODE reference");
2760 /* This is the second most common case: */
2762 cv = MUTABLE_CV(sv);
2770 if (!CvROOT(cv) && !CvXSUB(cv)) {
2774 /* anonymous or undef'd function leaves us no recourse */
2775 if (CvANON(cv) || !(gv = CvGV(cv)))
2776 DIE(aTHX_ "Undefined subroutine called");
2778 /* autoloaded stub? */
2779 if (cv != GvCV(gv)) {
2782 /* should call AUTOLOAD now? */
2785 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2792 sub_name = sv_newmortal();
2793 gv_efullname3(sub_name, gv, NULL);
2794 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2798 DIE(aTHX_ "Not a CODE reference");
2803 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2804 Perl_get_db_sub(aTHX_ &sv, cv);
2806 PL_curcopdb = PL_curcop;
2808 /* check for lsub that handles lvalue subroutines */
2809 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2810 /* if lsub not found then fall back to DB::sub */
2811 if (!cv) cv = GvCV(PL_DBsub);
2813 cv = GvCV(PL_DBsub);
2816 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2817 DIE(aTHX_ "No DB::sub routine defined");
2820 if (!(CvISXSUB(cv))) {
2821 /* This path taken at least 75% of the time */
2823 register I32 items = SP - MARK;
2824 AV* const padlist = CvPADLIST(cv);
2825 PUSHBLOCK(cx, CXt_SUB, MARK);
2827 cx->blk_sub.retop = PL_op->op_next;
2829 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2830 * that eval'' ops within this sub know the correct lexical space.
2831 * Owing the speed considerations, we choose instead to search for
2832 * the cv using find_runcv() when calling doeval().
2834 if (CvDEPTH(cv) >= 2) {
2835 PERL_STACK_OVERFLOW_CHECK();
2836 pad_push(padlist, CvDEPTH(cv));
2839 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2841 AV *const av = MUTABLE_AV(PAD_SVl(0));
2843 /* @_ is normally not REAL--this should only ever
2844 * happen when DB::sub() calls things that modify @_ */
2849 cx->blk_sub.savearray = GvAV(PL_defgv);
2850 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2851 CX_CURPAD_SAVE(cx->blk_sub);
2852 cx->blk_sub.argarray = av;
2855 if (items > AvMAX(av) + 1) {
2856 SV **ary = AvALLOC(av);
2857 if (AvARRAY(av) != ary) {
2858 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2861 if (items > AvMAX(av) + 1) {
2862 AvMAX(av) = items - 1;
2863 Renew(ary,items,SV*);
2868 Copy(MARK,AvARRAY(av),items,SV*);
2869 AvFILLp(av) = items - 1;
2877 /* warning must come *after* we fully set up the context
2878 * stuff so that __WARN__ handlers can safely dounwind()
2881 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2882 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2883 sub_crush_depth(cv);
2884 RETURNOP(CvSTART(cv));
2887 I32 markix = TOPMARK;
2892 /* Need to copy @_ to stack. Alternative may be to
2893 * switch stack to @_, and copy return values
2894 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2895 AV * const av = GvAV(PL_defgv);
2896 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2899 /* Mark is at the end of the stack. */
2901 Copy(AvARRAY(av), SP + 1, items, SV*);
2906 /* We assume first XSUB in &DB::sub is the called one. */
2908 SAVEVPTR(PL_curcop);
2909 PL_curcop = PL_curcopdb;
2912 /* Do we need to open block here? XXXX */
2914 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2916 CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
2918 /* Enforce some sanity in scalar context. */
2919 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2920 if (markix > PL_stack_sp - PL_stack_base)
2921 *(PL_stack_base + markix) = &PL_sv_undef;
2923 *(PL_stack_base + markix) = *PL_stack_sp;
2924 PL_stack_sp = PL_stack_base + markix;
2932 Perl_sub_crush_depth(pTHX_ CV *cv)
2934 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2937 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2939 SV* const tmpstr = sv_newmortal();
2940 gv_efullname3(tmpstr, CvGV(cv), NULL);
2941 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2950 SV* const elemsv = POPs;
2951 IV elem = SvIV(elemsv);
2952 AV *const av = MUTABLE_AV(POPs);
2953 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2954 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2955 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2956 bool preeminent = TRUE;
2959 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2960 Perl_warner(aTHX_ packWARN(WARN_MISC),
2961 "Use of reference \"%"SVf"\" as array index",
2964 elem -= CopARYBASE_get(PL_curcop);
2965 if (SvTYPE(av) != SVt_PVAV)
2972 /* If we can determine whether the element exist,
2973 * Try to preserve the existenceness of a tied array
2974 * element by using EXISTS and DELETE if possible.
2975 * Fallback to FETCH and STORE otherwise. */
2976 if (SvCANEXISTDELETE(av))
2977 preeminent = av_exists(av, elem);
2980 svp = av_fetch(av, elem, lval && !defer);
2982 #ifdef PERL_MALLOC_WRAP
2983 if (SvUOK(elemsv)) {
2984 const UV uv = SvUV(elemsv);
2985 elem = uv > IV_MAX ? IV_MAX : uv;
2987 else if (SvNOK(elemsv))
2988 elem = (IV)SvNV(elemsv);
2990 static const char oom_array_extend[] =
2991 "Out of memory during array extend"; /* Duplicated in av.c */
2992 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2995 if (!svp || *svp == &PL_sv_undef) {
2998 DIE(aTHX_ PL_no_aelem, elem);
2999 lv = sv_newmortal();
3000 sv_upgrade(lv, SVt_PVLV);
3002 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3003 LvTARG(lv) = SvREFCNT_inc_simple(av);
3004 LvTARGOFF(lv) = elem;
3011 save_aelem(av, elem, svp);
3013 SAVEADELETE(av, elem);
3015 else if (PL_op->op_private & OPpDEREF)
3016 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3018 sv = (svp ? *svp : &PL_sv_undef);
3019 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3026 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3028 PERL_ARGS_ASSERT_VIVIFY_REF;
3033 Perl_croak_no_modify(aTHX);
3034 prepare_SV_for_RV(sv);
3037 SvRV_set(sv, newSV(0));
3040 SvRV_set(sv, MUTABLE_SV(newAV()));
3043 SvRV_set(sv, MUTABLE_SV(newHV()));
3054 SV* const sv = TOPs;
3057 SV* const rsv = SvRV(sv);
3058 if (SvTYPE(rsv) == SVt_PVCV) {
3064 SETs(method_common(sv, NULL));
3071 SV* const sv = cSVOP_sv;
3072 U32 hash = SvSHARED_HASH(sv);
3074 XPUSHs(method_common(sv, &hash));
3079 S_method_common(pTHX_ SV* meth, U32* hashp)
3085 const char* packname = NULL;
3088 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3090 PERL_ARGS_ASSERT_METHOD_COMMON;
3093 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3098 ob = MUTABLE_SV(SvRV(sv));
3102 /* this isn't a reference */
3103 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3104 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3106 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3113 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3114 !(ob=MUTABLE_SV(GvIO(iogv))))
3116 /* this isn't the name of a filehandle either */
3118 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3119 ? !isIDFIRST_utf8((U8*)packname)
3120 : !isIDFIRST(*packname)
3123 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3125 SvOK(sv) ? "without a package or object reference"
3126 : "on an undefined value");
3128 /* assume it's a package name */
3129 stash = gv_stashpvn(packname, packlen, 0);
3133 SV* const ref = newSViv(PTR2IV(stash));
3134 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3138 /* it _is_ a filehandle name -- replace with a reference */
3139 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3142 /* if we got here, ob should be a reference or a glob */
3143 if (!ob || !(SvOBJECT(ob)
3144 || (SvTYPE(ob) == SVt_PVGV
3146 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3149 const char * const name = SvPV_nolen_const(meth);
3150 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3151 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3155 stash = SvSTASH(ob);
3158 /* NOTE: stash may be null, hope hv_fetch_ent and
3159 gv_fetchmethod can cope (it seems they can) */
3161 /* shortcut for simple names */
3163 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3165 gv = MUTABLE_GV(HeVAL(he));
3166 if (isGV(gv) && GvCV(gv) &&
3167 (!GvCVGEN(gv) || GvCVGEN(gv)
3168 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3169 return MUTABLE_SV(GvCV(gv));
3173 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3174 SvPV_nolen_const(meth),
3175 GV_AUTOLOAD | GV_CROAK);
3179 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3184 * c-indentation-style: bsd
3186 * indent-tabs-mode: t
3189 * ex: set ts=8 sts=4 sw=4 noet: