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 */
249 const char* const lpv = SvPV_nomg_const(left, llen);
250 lbyte = !DO_UTF8(left);
251 sv_setpvn(TARG, lpv, llen);
257 else { /* TARG == left */
260 if (left == right && ckWARN(WARN_UNINITIALIZED))
261 report_uninit(right);
264 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
265 lbyte = !DO_UTF8(left);
272 /* $a.$a: 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) {
279 sv_utf8_upgrade_nomg(TARG);
282 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
283 sv_utf8_upgrade_nomg(right);
284 rpv = SvPV_nomg_const(right, rlen);
287 sv_catpvn_nomg(TARG, rpv, rlen);
298 if (PL_op->op_flags & OPf_MOD) {
299 if (PL_op->op_private & OPpLVAL_INTRO)
300 if (!(PL_op->op_private & OPpPAD_STATE))
301 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
302 if (PL_op->op_private & OPpDEREF) {
304 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
314 tryAMAGICunTARGET(iter, 0);
315 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
316 if (!isGV_with_GP(PL_last_in_gv)) {
317 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
318 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
321 XPUSHs(MUTABLE_SV(PL_last_in_gv));
324 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
327 return do_readline();
333 tryAMAGICbin_MG(eq_amg, AMGf_set);
334 #ifndef NV_PRESERVES_UV
335 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
337 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
341 #ifdef PERL_PRESERVE_IVUV
342 SvIV_please_nomg(TOPs);
344 /* Unless the left argument is integer in range we are going
345 to have to use NV maths. Hence only attempt to coerce the
346 right argument if we know the left is integer. */
347 SvIV_please_nomg(TOPm1s);
349 const bool auvok = SvUOK(TOPm1s);
350 const bool buvok = SvUOK(TOPs);
352 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
353 /* Casting IV to UV before comparison isn't going to matter
354 on 2s complement. On 1s complement or sign&magnitude
355 (if we have any of them) it could to make negative zero
356 differ from normal zero. As I understand it. (Need to
357 check - is negative zero implementation defined behaviour
359 const UV buv = SvUVX(POPs);
360 const UV auv = SvUVX(TOPs);
362 SETs(boolSV(auv == buv));
365 { /* ## Mixed IV,UV ## */
369 /* == is commutative so doesn't matter which is left or right */
371 /* top of stack (b) is the iv */
380 /* As uv is a UV, it's >0, so it cannot be == */
383 /* we know iv is >= 0 */
384 SETs(boolSV((UV)iv == SvUVX(uvp)));
391 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
393 if (Perl_isnan(left) || Perl_isnan(right))
395 SETs(boolSV(left == right));
398 SETs(boolSV(SvNV_nomg(TOPs) == value));
407 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
408 DIE(aTHX_ "%s", PL_no_modify);
409 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
410 && SvIVX(TOPs) != IV_MAX)
412 SvIV_set(TOPs, SvIVX(TOPs) + 1);
413 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
415 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
428 if (PL_op->op_type == OP_OR)
430 RETURNOP(cLOGOP->op_other);
439 const int op_type = PL_op->op_type;
440 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
445 if (!sv || !SvANY(sv)) {
446 if (op_type == OP_DOR)
448 RETURNOP(cLOGOP->op_other);
454 if (!sv || !SvANY(sv))
459 switch (SvTYPE(sv)) {
461 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
465 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
469 if (CvROOT(sv) || CvXSUB(sv))
482 if(op_type == OP_DOR)
484 RETURNOP(cLOGOP->op_other);
486 /* assuming OP_DEFINED */
494 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
495 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
499 useleft = USE_LEFT(svl);
500 #ifdef PERL_PRESERVE_IVUV
501 /* We must see if we can perform the addition with integers if possible,
502 as the integer code detects overflow while the NV code doesn't.
503 If either argument hasn't had a numeric conversion yet attempt to get
504 the IV. It's important to do this now, rather than just assuming that
505 it's not IOK as a PV of "9223372036854775806" may not take well to NV
506 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
507 integer in case the second argument is IV=9223372036854775806
508 We can (now) rely on sv_2iv to do the right thing, only setting the
509 public IOK flag if the value in the NV (or PV) slot is truly integer.
511 A side effect is that this also aggressively prefers integer maths over
512 fp maths for integer values.
514 How to detect overflow?
516 C 99 section 6.2.6.1 says
518 The range of nonnegative values of a signed integer type is a subrange
519 of the corresponding unsigned integer type, and the representation of
520 the same value in each type is the same. A computation involving
521 unsigned operands can never overflow, because a result that cannot be
522 represented by the resulting unsigned integer type is reduced modulo
523 the number that is one greater than the largest value that can be
524 represented by the resulting type.
528 which I read as "unsigned ints wrap."
530 signed integer overflow seems to be classed as "exception condition"
532 If an exceptional condition occurs during the evaluation of an
533 expression (that is, if the result is not mathematically defined or not
534 in the range of representable values for its type), the behavior is
537 (6.5, the 5th paragraph)
539 I had assumed that on 2s complement machines signed arithmetic would
540 wrap, hence coded pp_add and pp_subtract on the assumption that
541 everything perl builds on would be happy. After much wailing and
542 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
543 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
544 unsigned code below is actually shorter than the old code. :-)
547 SvIV_please_nomg(svr);
550 /* Unless the left argument is integer in range we are going to have to
551 use NV maths. Hence only attempt to coerce the right argument if
552 we know the left is integer. */
560 /* left operand is undef, treat as zero. + 0 is identity,
561 Could SETi or SETu right now, but space optimise by not adding
562 lots of code to speed up what is probably a rarish case. */
564 /* Left operand is defined, so is it IV? */
565 SvIV_please_nomg(svl);
567 if ((auvok = SvUOK(svl)))
570 register const IV aiv = SvIVX(svl);
573 auvok = 1; /* Now acting as a sign flag. */
574 } else { /* 2s complement assumption for IV_MIN */
582 bool result_good = 0;
585 bool buvok = SvUOK(svr);
590 register const IV biv = SvIVX(svr);
597 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
598 else "IV" now, independent of how it came in.
599 if a, b represents positive, A, B negative, a maps to -A etc
604 all UV maths. negate result if A negative.
605 add if signs same, subtract if signs differ. */
611 /* Must get smaller */
617 /* result really should be -(auv-buv). as its negation
618 of true value, need to swap our result flag */
635 if (result <= (UV)IV_MIN)
638 /* result valid, but out of range for IV. */
643 } /* Overflow, drop through to NVs. */
648 NV value = SvNV_nomg(svr);
651 /* left operand is undef, treat as zero. + 0.0 is identity. */
655 SETn( value + SvNV_nomg(svl) );
663 AV * const av = PL_op->op_flags & OPf_SPECIAL
664 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
665 const U32 lval = PL_op->op_flags & OPf_MOD;
666 SV** const svp = av_fetch(av, PL_op->op_private, lval);
667 SV *sv = (svp ? *svp : &PL_sv_undef);
669 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
677 dVAR; dSP; dMARK; dTARGET;
679 do_join(TARG, *MARK, MARK, SP);
690 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
691 * will be enough to hold an OP*.
693 SV* const sv = sv_newmortal();
694 sv_upgrade(sv, SVt_PVLV);
696 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
699 XPUSHs(MUTABLE_SV(PL_op));
704 /* Oversized hot code. */
708 dVAR; dSP; dMARK; dORIGMARK;
713 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
715 if (gv && (io = GvIO(gv))
716 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
719 if (MARK == ORIGMARK) {
720 /* If using default handle then we need to make space to
721 * pass object as 1st arg, so move other args up ...
725 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
729 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
731 ENTER_with_name("call_PRINT");
732 if( PL_op->op_type == OP_SAY ) {
733 /* local $\ = "\n" */
734 SAVEGENERICSV(PL_ors_sv);
735 PL_ors_sv = newSVpvs("\n");
737 call_method("PRINT", G_SCALAR);
738 LEAVE_with_name("call_PRINT");
745 if (!(io = GvIO(gv))) {
746 if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
747 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
749 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
750 report_evil_fh(gv, io, PL_op->op_type);
751 SETERRNO(EBADF,RMS_IFI);
754 else if (!(fp = IoOFP(io))) {
755 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
757 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
758 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
759 report_evil_fh(gv, io, PL_op->op_type);
761 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
765 SV * const ofs = GvSV(PL_ofsgv); /* $, */
767 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
769 if (!do_print(*MARK, fp))
773 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
774 if (!do_print(GvSV(PL_ofsgv), fp)) {
783 if (!do_print(*MARK, fp))
791 if (PL_op->op_type == OP_SAY) {
792 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
795 else if (PL_ors_sv && SvOK(PL_ors_sv))
796 if (!do_print(PL_ors_sv, fp)) /* $\ */
799 if (IoFLAGS(io) & IOf_FLUSH)
800 if (PerlIO_flush(fp) == EOF)
810 XPUSHs(&PL_sv_undef);
817 const I32 gimme = GIMME_V;
818 static const char an_array[] = "an ARRAY";
819 static const char a_hash[] = "a HASH";
820 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
821 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
823 if (!(PL_op->op_private & OPpDEREFed))
826 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
829 if (SvTYPE(sv) != type)
830 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
831 if (PL_op->op_flags & OPf_REF) {
836 if (gimme != G_ARRAY)
837 goto croak_cant_return;
841 else if (PL_op->op_flags & OPf_MOD
842 && PL_op->op_private & OPpLVAL_INTRO)
843 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
846 if (SvTYPE(sv) == type) {
847 if (PL_op->op_flags & OPf_REF) {
852 if (gimme != G_ARRAY)
853 goto croak_cant_return;
861 if (!isGV_with_GP(sv)) {
862 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
870 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
871 if (PL_op->op_private & OPpLVAL_INTRO)
872 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
873 if (PL_op->op_flags & OPf_REF) {
878 if (gimme != G_ARRAY)
879 goto croak_cant_return;
887 AV *const av = MUTABLE_AV(sv);
888 /* The guts of pp_rv2av, with no intenting change to preserve history
889 (until such time as we get tools that can do blame annotation across
890 whitespace changes. */
891 if (gimme == G_ARRAY) {
892 const I32 maxarg = AvFILL(av) + 1;
893 (void)POPs; /* XXXX May be optimized away? */
895 if (SvRMAGICAL(av)) {
897 for (i=0; i < (U32)maxarg; i++) {
898 SV ** const svp = av_fetch(av, i, FALSE);
899 /* See note in pp_helem, and bug id #27839 */
901 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
906 Copy(AvARRAY(av), SP+1, maxarg, SV*);
910 else if (gimme == G_SCALAR) {
912 const I32 maxarg = AvFILL(av) + 1;
916 /* The guts of pp_rv2hv */
917 if (gimme == G_ARRAY) { /* array wanted */
921 else if (gimme == G_SCALAR) {
923 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
931 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
932 is_pp_rv2av ? "array" : "hash");
937 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
941 PERL_ARGS_ASSERT_DO_ODDBALL;
947 if (ckWARN(WARN_MISC)) {
949 if (relem == firstrelem &&
951 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
952 SvTYPE(SvRV(*relem)) == SVt_PVHV))
954 err = "Reference found where even-sized list expected";
957 err = "Odd number of elements in hash assignment";
958 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
962 didstore = hv_store_ent(hash,*relem,tmpstr,0);
963 if (SvMAGICAL(hash)) {
964 if (SvSMAGICAL(tmpstr))
976 SV **lastlelem = PL_stack_sp;
977 SV **lastrelem = PL_stack_base + POPMARK;
978 SV **firstrelem = PL_stack_base + POPMARK + 1;
979 SV **firstlelem = lastrelem + 1;
992 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
994 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
997 /* If there's a common identifier on both sides we have to take
998 * special care that assigning the identifier on the left doesn't
999 * clobber a value on the right that's used later in the list.
1001 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1002 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1003 for (relem = firstrelem; relem <= lastrelem; relem++) {
1004 if ((sv = *relem)) {
1005 TAINT_NOT; /* Each item is independent */
1007 /* Dear TODO test in t/op/sort.t, I love you.
1008 (It's relying on a panic, not a "semi-panic" from newSVsv()
1009 and then an assertion failure below.) */
1010 if (SvIS_FREED(sv)) {
1011 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1014 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1015 and we need a second copy of a temp here. */
1016 *relem = sv_2mortal(newSVsv(sv));
1026 while (lelem <= lastlelem) {
1027 TAINT_NOT; /* Each item stands on its own, taintwise. */
1029 switch (SvTYPE(sv)) {
1031 ary = MUTABLE_AV(sv);
1032 magic = SvMAGICAL(ary) != 0;
1034 av_extend(ary, lastrelem - relem);
1036 while (relem <= lastrelem) { /* gobble up all the rest */
1040 sv_setsv(sv, *relem);
1042 didstore = av_store(ary,i++,sv);
1051 if (PL_delaymagic & DM_ARRAY_ISA)
1052 SvSETMAGIC(MUTABLE_SV(ary));
1054 case SVt_PVHV: { /* normal hash */
1057 hash = MUTABLE_HV(sv);
1058 magic = SvMAGICAL(hash) != 0;
1060 firsthashrelem = relem;
1062 while (relem < lastrelem) { /* gobble up all the rest */
1064 sv = *relem ? *relem : &PL_sv_no;
1068 sv_setsv(tmpstr,*relem); /* value */
1069 *(relem++) = tmpstr;
1070 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1071 /* key overwrites an existing entry */
1073 didstore = hv_store_ent(hash,sv,tmpstr,0);
1075 if (SvSMAGICAL(tmpstr))
1082 if (relem == lastrelem) {
1083 do_oddball(hash, relem, firstrelem);
1089 if (SvIMMORTAL(sv)) {
1090 if (relem <= lastrelem)
1094 if (relem <= lastrelem) {
1095 sv_setsv(sv, *relem);
1099 sv_setsv(sv, &PL_sv_undef);
1104 if (PL_delaymagic & ~DM_DELAY) {
1105 if (PL_delaymagic & DM_UID) {
1106 #ifdef HAS_SETRESUID
1107 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1108 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1111 # ifdef HAS_SETREUID
1112 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1113 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1116 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1117 (void)setruid(PL_uid);
1118 PL_delaymagic &= ~DM_RUID;
1120 # endif /* HAS_SETRUID */
1122 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1123 (void)seteuid(PL_euid);
1124 PL_delaymagic &= ~DM_EUID;
1126 # endif /* HAS_SETEUID */
1127 if (PL_delaymagic & DM_UID) {
1128 if (PL_uid != PL_euid)
1129 DIE(aTHX_ "No setreuid available");
1130 (void)PerlProc_setuid(PL_uid);
1132 # endif /* HAS_SETREUID */
1133 #endif /* HAS_SETRESUID */
1134 PL_uid = PerlProc_getuid();
1135 PL_euid = PerlProc_geteuid();
1137 if (PL_delaymagic & DM_GID) {
1138 #ifdef HAS_SETRESGID
1139 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1140 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1143 # ifdef HAS_SETREGID
1144 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1145 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1148 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1149 (void)setrgid(PL_gid);
1150 PL_delaymagic &= ~DM_RGID;
1152 # endif /* HAS_SETRGID */
1154 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1155 (void)setegid(PL_egid);
1156 PL_delaymagic &= ~DM_EGID;
1158 # endif /* HAS_SETEGID */
1159 if (PL_delaymagic & DM_GID) {
1160 if (PL_gid != PL_egid)
1161 DIE(aTHX_ "No setregid available");
1162 (void)PerlProc_setgid(PL_gid);
1164 # endif /* HAS_SETREGID */
1165 #endif /* HAS_SETRESGID */
1166 PL_gid = PerlProc_getgid();
1167 PL_egid = PerlProc_getegid();
1169 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1173 if (gimme == G_VOID)
1174 SP = firstrelem - 1;
1175 else if (gimme == G_SCALAR) {
1178 SETi(lastrelem - firstrelem + 1 - duplicates);
1185 /* Removes from the stack the entries which ended up as
1186 * duplicated keys in the hash (fix for [perl #24380]) */
1187 Move(firsthashrelem + duplicates,
1188 firsthashrelem, duplicates, SV**);
1189 lastrelem -= duplicates;
1194 SP = firstrelem + (lastlelem - firstlelem);
1195 lelem = firstlelem + (relem - firstrelem);
1197 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1206 register PMOP * const pm = cPMOP;
1207 REGEXP * rx = PM_GETRE(pm);
1208 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1209 SV * const rv = sv_newmortal();
1211 SvUPGRADE(rv, SVt_IV);
1212 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1213 loathe to use it here, but it seems to be the right fix. Or close.
1214 The key part appears to be that it's essential for pp_qr to return a new
1215 object (SV), which implies that there needs to be an effective way to
1216 generate a new SV from the existing SV that is pre-compiled in the
1218 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1222 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1224 (void)sv_bless(rv, stash);
1227 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1236 register PMOP *pm = cPMOP;
1238 register const char *t;
1239 register const char *s;
1242 U8 r_flags = REXEC_CHECKED;
1243 const char *truebase; /* Start of string */
1244 register REGEXP *rx = PM_GETRE(pm);
1246 const I32 gimme = GIMME;
1249 const I32 oldsave = PL_savestack_ix;
1250 I32 update_minmatch = 1;
1251 I32 had_zerolen = 0;
1254 if (PL_op->op_flags & OPf_STACKED)
1256 else if (PL_op->op_private & OPpTARGET_MY)
1263 PUTBACK; /* EVAL blocks need stack_sp. */
1264 /* Skip get-magic if this is a qr// clone, because regcomp has
1266 s = ((struct regexp *)SvANY(rx))->mother_re
1267 ? SvPV_nomg_const(TARG, len)
1268 : SvPV_const(TARG, len);
1270 DIE(aTHX_ "panic: pp_match");
1272 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1273 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1276 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1278 /* PMdf_USED is set after a ?? matches once */
1281 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1283 pm->op_pmflags & PMf_USED
1287 if (gimme == G_ARRAY)
1294 /* empty pattern special-cased to use last successful pattern if possible */
1295 if (!RX_PRELEN(rx) && PL_curpm) {
1300 if (RX_MINLEN(rx) > (I32)len)
1305 /* XXXX What part of this is needed with true \G-support? */
1306 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1307 RX_OFFS(rx)[0].start = -1;
1308 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1309 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1310 if (mg && mg->mg_len >= 0) {
1311 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1314 r_flags |= REXEC_IGNOREPOS;
1315 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1316 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1319 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1320 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1321 update_minmatch = 0;
1325 /* XXX: comment out !global get safe $1 vars after a
1326 match, BUT be aware that this leads to dramatic slowdowns on
1327 /g matches against large strings. So far a solution to this problem
1328 appears to be quite tricky.
1329 Test for the unsafe vars are TODO for now. */
1330 if (( !global && RX_NPARENS(rx))
1331 || SvTEMP(TARG) || PL_sawampersand ||
1332 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1333 r_flags |= REXEC_COPY_STR;
1335 r_flags |= REXEC_SCREAM;
1338 if (global && RX_OFFS(rx)[0].start != -1) {
1339 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1340 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1342 if (update_minmatch++)
1343 minmatch = had_zerolen;
1345 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1346 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1347 /* FIXME - can PL_bostr be made const char *? */
1348 PL_bostr = (char *)truebase;
1349 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1353 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1355 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1356 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1357 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1358 && (r_flags & REXEC_SCREAM)))
1359 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1362 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1363 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1366 if (dynpm->op_pmflags & PMf_ONCE) {
1368 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1370 dynpm->op_pmflags |= PMf_USED;
1381 RX_MATCH_TAINTED_on(rx);
1382 TAINT_IF(RX_MATCH_TAINTED(rx));
1383 if (gimme == G_ARRAY) {
1384 const I32 nparens = RX_NPARENS(rx);
1385 I32 i = (global && !nparens) ? 1 : 0;
1387 SPAGAIN; /* EVAL blocks could move the stack. */
1388 EXTEND(SP, nparens + i);
1389 EXTEND_MORTAL(nparens + i);
1390 for (i = !i; i <= nparens; i++) {
1391 PUSHs(sv_newmortal());
1392 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1393 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1394 s = RX_OFFS(rx)[i].start + truebase;
1395 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1396 len < 0 || len > strend - s)
1397 DIE(aTHX_ "panic: pp_match start/end pointers");
1398 sv_setpvn(*SP, s, len);
1399 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1404 if (dynpm->op_pmflags & PMf_CONTINUE) {
1406 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1407 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1409 #ifdef PERL_OLD_COPY_ON_WRITE
1411 sv_force_normal_flags(TARG, 0);
1413 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1414 &PL_vtbl_mglob, NULL, 0);
1416 if (RX_OFFS(rx)[0].start != -1) {
1417 mg->mg_len = RX_OFFS(rx)[0].end;
1418 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1419 mg->mg_flags |= MGf_MINMATCH;
1421 mg->mg_flags &= ~MGf_MINMATCH;
1424 had_zerolen = (RX_OFFS(rx)[0].start != -1
1425 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1426 == (UV)RX_OFFS(rx)[0].end));
1427 PUTBACK; /* EVAL blocks may use stack */
1428 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1433 LEAVE_SCOPE(oldsave);
1439 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1440 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1444 #ifdef PERL_OLD_COPY_ON_WRITE
1446 sv_force_normal_flags(TARG, 0);
1448 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1449 &PL_vtbl_mglob, NULL, 0);
1451 if (RX_OFFS(rx)[0].start != -1) {
1452 mg->mg_len = RX_OFFS(rx)[0].end;
1453 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1454 mg->mg_flags |= MGf_MINMATCH;
1456 mg->mg_flags &= ~MGf_MINMATCH;
1459 LEAVE_SCOPE(oldsave);
1463 yup: /* Confirmed by INTUIT */
1465 RX_MATCH_TAINTED_on(rx);
1466 TAINT_IF(RX_MATCH_TAINTED(rx));
1468 if (dynpm->op_pmflags & PMf_ONCE) {
1470 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1472 dynpm->op_pmflags |= PMf_USED;
1475 if (RX_MATCH_COPIED(rx))
1476 Safefree(RX_SUBBEG(rx));
1477 RX_MATCH_COPIED_off(rx);
1478 RX_SUBBEG(rx) = NULL;
1480 /* FIXME - should rx->subbeg be const char *? */
1481 RX_SUBBEG(rx) = (char *) truebase;
1482 RX_OFFS(rx)[0].start = s - truebase;
1483 if (RX_MATCH_UTF8(rx)) {
1484 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1485 RX_OFFS(rx)[0].end = t - truebase;
1488 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1490 RX_SUBLEN(rx) = strend - truebase;
1493 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1495 #ifdef PERL_OLD_COPY_ON_WRITE
1496 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1498 PerlIO_printf(Perl_debug_log,
1499 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1500 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1503 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1505 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1506 assert (SvPOKp(RX_SAVED_COPY(rx)));
1511 RX_SUBBEG(rx) = savepvn(t, strend - t);
1512 #ifdef PERL_OLD_COPY_ON_WRITE
1513 RX_SAVED_COPY(rx) = NULL;
1516 RX_SUBLEN(rx) = strend - t;
1517 RX_MATCH_COPIED_on(rx);
1518 off = RX_OFFS(rx)[0].start = s - t;
1519 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1521 else { /* startp/endp are used by @- @+. */
1522 RX_OFFS(rx)[0].start = s - truebase;
1523 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1525 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1527 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1528 LEAVE_SCOPE(oldsave);
1533 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1534 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1535 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1540 LEAVE_SCOPE(oldsave);
1541 if (gimme == G_ARRAY)
1547 Perl_do_readline(pTHX)
1549 dVAR; dSP; dTARGETSTACKED;
1554 register IO * const io = GvIO(PL_last_in_gv);
1555 register const I32 type = PL_op->op_type;
1556 const I32 gimme = GIMME_V;
1559 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1562 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1564 ENTER_with_name("call_READLINE");
1565 call_method("READLINE", gimme);
1566 LEAVE_with_name("call_READLINE");
1568 if (gimme == G_SCALAR) {
1569 SV* const result = POPs;
1570 SvSetSV_nosteal(TARG, result);
1580 if (IoFLAGS(io) & IOf_ARGV) {
1581 if (IoFLAGS(io) & IOf_START) {
1583 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1584 IoFLAGS(io) &= ~IOf_START;
1585 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1586 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1587 SvSETMAGIC(GvSV(PL_last_in_gv));
1592 fp = nextargv(PL_last_in_gv);
1593 if (!fp) { /* Note: fp != IoIFP(io) */
1594 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1597 else if (type == OP_GLOB)
1598 fp = Perl_start_glob(aTHX_ POPs, io);
1600 else if (type == OP_GLOB)
1602 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1603 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1607 if ((!io || !(IoFLAGS(io) & IOf_START))
1608 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1610 if (type == OP_GLOB)
1611 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1612 "glob failed (can't start child: %s)",
1615 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1617 if (gimme == G_SCALAR) {
1618 /* undef TARG, and push that undefined value */
1619 if (type != OP_RCATLINE) {
1620 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1628 if (gimme == G_SCALAR) {
1630 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1633 if (type == OP_RCATLINE)
1634 SvPV_force_nolen(sv);
1638 else if (isGV_with_GP(sv)) {
1639 SvPV_force_nolen(sv);
1641 SvUPGRADE(sv, SVt_PV);
1642 tmplen = SvLEN(sv); /* remember if already alloced */
1643 if (!tmplen && !SvREADONLY(sv))
1644 Sv_Grow(sv, 80); /* try short-buffering it */
1646 if (type == OP_RCATLINE && SvOK(sv)) {
1648 SvPV_force_nolen(sv);
1654 sv = sv_2mortal(newSV(80));
1658 /* This should not be marked tainted if the fp is marked clean */
1659 #define MAYBE_TAINT_LINE(io, sv) \
1660 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1665 /* delay EOF state for a snarfed empty file */
1666 #define SNARF_EOF(gimme,rs,io,sv) \
1667 (gimme != G_SCALAR || SvCUR(sv) \
1668 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1672 if (!sv_gets(sv, fp, offset)
1674 || SNARF_EOF(gimme, PL_rs, io, sv)
1675 || PerlIO_error(fp)))
1677 PerlIO_clearerr(fp);
1678 if (IoFLAGS(io) & IOf_ARGV) {
1679 fp = nextargv(PL_last_in_gv);
1682 (void)do_close(PL_last_in_gv, FALSE);
1684 else if (type == OP_GLOB) {
1685 if (!do_close(PL_last_in_gv, FALSE)) {
1686 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1687 "glob failed (child exited with status %d%s)",
1688 (int)(STATUS_CURRENT >> 8),
1689 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1692 if (gimme == G_SCALAR) {
1693 if (type != OP_RCATLINE) {
1694 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1700 MAYBE_TAINT_LINE(io, sv);
1703 MAYBE_TAINT_LINE(io, sv);
1705 IoFLAGS(io) |= IOf_NOLINE;
1709 if (type == OP_GLOB) {
1712 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1713 char * const tmps = SvEND(sv) - 1;
1714 if (*tmps == *SvPVX_const(PL_rs)) {
1716 SvCUR_set(sv, SvCUR(sv) - 1);
1719 for (t1 = SvPVX_const(sv); *t1; t1++)
1720 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1721 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1723 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1724 (void)POPs; /* Unmatched wildcard? Chuck it... */
1727 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1728 if (ckWARN(WARN_UTF8)) {
1729 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1730 const STRLEN len = SvCUR(sv) - offset;
1733 if (!is_utf8_string_loc(s, len, &f))
1734 /* Emulate :encoding(utf8) warning in the same case. */
1735 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1736 "utf8 \"\\x%02X\" does not map to Unicode",
1737 f < (U8*)SvEND(sv) ? *f : 0);
1740 if (gimme == G_ARRAY) {
1741 if (SvLEN(sv) - SvCUR(sv) > 20) {
1742 SvPV_shrink_to_cur(sv);
1744 sv = sv_2mortal(newSV(80));
1747 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1748 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1749 const STRLEN new_len
1750 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1751 SvPV_renew(sv, new_len);
1760 register PERL_CONTEXT *cx;
1761 I32 gimme = OP_GIMME(PL_op, -1);
1764 if (cxstack_ix >= 0) {
1765 /* If this flag is set, we're just inside a return, so we should
1766 * store the caller's context */
1767 gimme = (PL_op->op_flags & OPf_SPECIAL)
1769 : cxstack[cxstack_ix].blk_gimme;
1774 ENTER_with_name("block");
1777 PUSHBLOCK(cx, CXt_BLOCK, SP);
1787 SV * const keysv = POPs;
1788 HV * const hv = MUTABLE_HV(POPs);
1789 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1790 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1792 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1793 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1794 bool preeminent = TRUE;
1796 if (SvTYPE(hv) != SVt_PVHV)
1803 /* If we can determine whether the element exist,
1804 * Try to preserve the existenceness of a tied hash
1805 * element by using EXISTS and DELETE if possible.
1806 * Fallback to FETCH and STORE otherwise. */
1807 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1808 preeminent = hv_exists_ent(hv, keysv, 0);
1811 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1812 svp = he ? &HeVAL(he) : NULL;
1814 if (!svp || *svp == &PL_sv_undef) {
1818 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1820 lv = sv_newmortal();
1821 sv_upgrade(lv, SVt_PVLV);
1823 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1824 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1825 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1831 if (HvNAME_get(hv) && isGV(*svp))
1832 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1833 else if (preeminent)
1834 save_helem_flags(hv, keysv, svp,
1835 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1837 SAVEHDELETE(hv, keysv);
1839 else if (PL_op->op_private & OPpDEREF)
1840 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1842 sv = (svp ? *svp : &PL_sv_undef);
1843 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1844 * was to make C<local $tied{foo} = $tied{foo}> possible.
1845 * However, it seems no longer to be needed for that purpose, and
1846 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1847 * would loop endlessly since the pos magic is getting set on the
1848 * mortal copy and lost. However, the copy has the effect of
1849 * triggering the get magic, and losing it altogether made things like
1850 * c<$tied{foo};> in void context no longer do get magic, which some
1851 * code relied on. Also, delayed triggering of magic on @+ and friends
1852 * meant the original regex may be out of scope by now. So as a
1853 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1854 * being called too many times). */
1855 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1864 register PERL_CONTEXT *cx;
1869 if (PL_op->op_flags & OPf_SPECIAL) {
1870 cx = &cxstack[cxstack_ix];
1871 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1876 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1879 if (gimme == G_VOID)
1881 else if (gimme == G_SCALAR) {
1885 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1888 *MARK = sv_mortalcopy(TOPs);
1891 *MARK = &PL_sv_undef;
1895 else if (gimme == G_ARRAY) {
1896 /* in case LEAVE wipes old return values */
1898 for (mark = newsp + 1; mark <= SP; mark++) {
1899 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1900 *mark = sv_mortalcopy(*mark);
1901 TAINT_NOT; /* Each item is independent */
1905 PL_curpm = newpm; /* Don't pop $1 et al till now */
1907 LEAVE_with_name("block");
1915 register PERL_CONTEXT *cx;
1918 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1919 bool av_is_stack = FALSE;
1922 cx = &cxstack[cxstack_ix];
1923 if (!CxTYPE_is_LOOP(cx))
1924 DIE(aTHX_ "panic: pp_iter");
1926 itersvp = CxITERVAR(cx);
1927 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1928 /* string increment */
1929 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1930 SV *end = cx->blk_loop.state_u.lazysv.end;
1931 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1932 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1934 const char *max = SvPV_const(end, maxlen);
1935 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1936 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1937 /* safe to reuse old SV */
1938 sv_setsv(*itersvp, cur);
1942 /* we need a fresh SV every time so that loop body sees a
1943 * completely new SV for closures/references to work as
1946 *itersvp = newSVsv(cur);
1947 SvREFCNT_dec(oldsv);
1949 if (strEQ(SvPVX_const(cur), max))
1950 sv_setiv(cur, 0); /* terminate next time */
1957 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1958 /* integer increment */
1959 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1962 /* don't risk potential race */
1963 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1964 /* safe to reuse old SV */
1965 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1969 /* we need a fresh SV every time so that loop body sees a
1970 * completely new SV for closures/references to work as they
1973 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1974 SvREFCNT_dec(oldsv);
1977 /* Handle end of range at IV_MAX */
1978 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1979 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1981 cx->blk_loop.state_u.lazyiv.cur++;
1982 cx->blk_loop.state_u.lazyiv.end++;
1989 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1990 av = cx->blk_loop.state_u.ary.ary;
1995 if (PL_op->op_private & OPpITER_REVERSED) {
1996 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1997 ? cx->blk_loop.resetsp + 1 : 0))
2000 if (SvMAGICAL(av) || AvREIFY(av)) {
2001 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2002 sv = svp ? *svp : NULL;
2005 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2009 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2013 if (SvMAGICAL(av) || AvREIFY(av)) {
2014 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2015 sv = svp ? *svp : NULL;
2018 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2022 if (sv && SvIS_FREED(sv)) {
2024 Perl_croak(aTHX_ "Use of freed value in iteration");
2029 SvREFCNT_inc_simple_void_NN(sv);
2033 if (!av_is_stack && sv == &PL_sv_undef) {
2034 SV *lv = newSV_type(SVt_PVLV);
2036 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2037 LvTARG(lv) = SvREFCNT_inc_simple(av);
2038 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2039 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2045 SvREFCNT_dec(oldsv);
2053 register PMOP *pm = cPMOP;
2068 register REGEXP *rx = PM_GETRE(pm);
2070 int force_on_match = 0;
2071 const I32 oldsave = PL_savestack_ix;
2073 bool doutf8 = FALSE;
2075 #ifdef PERL_OLD_COPY_ON_WRITE
2079 /* known replacement string? */
2080 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2084 if (PL_op->op_flags & OPf_STACKED)
2086 else if (PL_op->op_private & OPpTARGET_MY)
2093 /* In non-destructive replacement mode, duplicate target scalar so it
2094 * remains unchanged. */
2095 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2096 TARG = newSVsv(TARG);
2098 #ifdef PERL_OLD_COPY_ON_WRITE
2099 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2100 because they make integers such as 256 "false". */
2101 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2104 sv_force_normal_flags(TARG,0);
2107 #ifdef PERL_OLD_COPY_ON_WRITE
2111 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2112 || SvTYPE(TARG) > SVt_PVLV)
2113 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2114 DIE(aTHX_ "%s", PL_no_modify);
2118 s = SvPV_mutable(TARG, len);
2119 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2121 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2122 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2127 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2131 DIE(aTHX_ "panic: pp_subst");
2134 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2135 maxiters = 2 * slen + 10; /* We can match twice at each
2136 position, once with zero-length,
2137 second time with non-zero. */
2139 if (!RX_PRELEN(rx) && PL_curpm) {
2143 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2144 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2145 ? REXEC_COPY_STR : 0;
2147 r_flags |= REXEC_SCREAM;
2150 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2152 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2156 /* How to do it in subst? */
2157 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2159 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2160 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2161 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2162 && (r_flags & REXEC_SCREAM))))
2167 /* only replace once? */
2168 once = !(rpm->op_pmflags & PMf_GLOBAL);
2169 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2170 r_flags | REXEC_CHECKED);
2171 /* known replacement string? */
2174 /* Upgrade the source if the replacement is utf8 but the source is not,
2175 * but only if it matched; see
2176 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2178 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2179 const STRLEN new_len = sv_utf8_upgrade(TARG);
2181 /* If the lengths are the same, the pattern contains only
2182 * invariants, can keep going; otherwise, various internal markers
2183 * could be off, so redo */
2184 if (new_len != len) {
2189 /* replacement needing upgrading? */
2190 if (DO_UTF8(TARG) && !doutf8) {
2191 nsv = sv_newmortal();
2194 sv_recode_to_utf8(nsv, PL_encoding);
2196 sv_utf8_upgrade(nsv);
2197 c = SvPV_const(nsv, clen);
2201 c = SvPV_const(dstr, clen);
2202 doutf8 = DO_UTF8(dstr);
2210 /* can do inplace substitution? */
2212 #ifdef PERL_OLD_COPY_ON_WRITE
2215 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2216 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2217 && (!doutf8 || SvUTF8(TARG))) {
2221 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2225 LEAVE_SCOPE(oldsave);
2228 #ifdef PERL_OLD_COPY_ON_WRITE
2229 if (SvIsCOW(TARG)) {
2230 assert (!force_on_match);
2234 if (force_on_match) {
2236 s = SvPV_force(TARG, len);
2241 SvSCREAM_off(TARG); /* disable possible screamer */
2243 rxtainted |= RX_MATCH_TAINTED(rx);
2244 m = orig + RX_OFFS(rx)[0].start;
2245 d = orig + RX_OFFS(rx)[0].end;
2247 if (m - s > strend - d) { /* faster to shorten from end */
2249 Copy(c, m, clen, char);
2254 Move(d, m, i, char);
2258 SvCUR_set(TARG, m - s);
2260 else if ((i = m - s)) { /* faster from front */
2263 Move(s, d - i, i, char);
2266 Copy(c, m, clen, char);
2271 Copy(c, d, clen, char);
2276 TAINT_IF(rxtainted & 1);
2278 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2285 if (iters++ > maxiters)
2286 DIE(aTHX_ "Substitution loop");
2287 rxtainted |= RX_MATCH_TAINTED(rx);
2288 m = RX_OFFS(rx)[0].start + orig;
2291 Move(s, d, i, char);
2295 Copy(c, d, clen, char);
2298 s = RX_OFFS(rx)[0].end + orig;
2299 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2301 /* don't match same null twice */
2302 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2305 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2306 Move(s, d, i+1, char); /* include the NUL */
2308 TAINT_IF(rxtainted & 1);
2310 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2315 (void)SvPOK_only_UTF8(TARG);
2316 TAINT_IF(rxtainted);
2317 if (SvSMAGICAL(TARG)) {
2325 LEAVE_SCOPE(oldsave);
2331 if (force_on_match) {
2333 s = SvPV_force(TARG, len);
2336 #ifdef PERL_OLD_COPY_ON_WRITE
2339 rxtainted |= RX_MATCH_TAINTED(rx);
2340 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2344 register PERL_CONTEXT *cx;
2347 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2349 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2351 if (iters++ > maxiters)
2352 DIE(aTHX_ "Substitution loop");
2353 rxtainted |= RX_MATCH_TAINTED(rx);
2354 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2357 orig = RX_SUBBEG(rx);
2359 strend = s + (strend - m);
2361 m = RX_OFFS(rx)[0].start + orig;
2362 if (doutf8 && !SvUTF8(dstr))
2363 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2365 sv_catpvn(dstr, s, m-s);
2366 s = RX_OFFS(rx)[0].end + orig;
2368 sv_catpvn(dstr, c, clen);
2371 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2372 TARG, NULL, r_flags));
2373 if (doutf8 && !DO_UTF8(TARG))
2374 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2376 sv_catpvn(dstr, s, strend - s);
2378 #ifdef PERL_OLD_COPY_ON_WRITE
2379 /* The match may make the string COW. If so, brilliant, because that's
2380 just saved us one malloc, copy and free - the regexp has donated
2381 the old buffer, and we malloc an entirely new one, rather than the
2382 regexp malloc()ing a buffer and copying our original, only for
2383 us to throw it away here during the substitution. */
2384 if (SvIsCOW(TARG)) {
2385 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2391 SvPV_set(TARG, SvPVX(dstr));
2392 SvCUR_set(TARG, SvCUR(dstr));
2393 SvLEN_set(TARG, SvLEN(dstr));
2394 doutf8 |= DO_UTF8(dstr);
2395 SvPV_set(dstr, NULL);
2397 TAINT_IF(rxtainted & 1);
2399 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2404 (void)SvPOK_only(TARG);
2407 TAINT_IF(rxtainted);
2410 LEAVE_SCOPE(oldsave);
2418 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2422 LEAVE_SCOPE(oldsave);
2431 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2432 ++*PL_markstack_ptr;
2433 LEAVE_with_name("grep_item"); /* exit inner scope */
2436 if (PL_stack_base + *PL_markstack_ptr > SP) {
2438 const I32 gimme = GIMME_V;
2440 LEAVE_with_name("grep"); /* exit outer scope */
2441 (void)POPMARK; /* pop src */
2442 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2443 (void)POPMARK; /* pop dst */
2444 SP = PL_stack_base + POPMARK; /* pop original mark */
2445 if (gimme == G_SCALAR) {
2446 if (PL_op->op_private & OPpGREP_LEX) {
2447 SV* const sv = sv_newmortal();
2448 sv_setiv(sv, items);
2456 else if (gimme == G_ARRAY)
2463 ENTER_with_name("grep_item"); /* enter inner scope */
2466 src = PL_stack_base[*PL_markstack_ptr];
2468 if (PL_op->op_private & OPpGREP_LEX)
2469 PAD_SVl(PL_op->op_targ) = src;
2473 RETURNOP(cLOGOP->op_other);
2484 register PERL_CONTEXT *cx;
2487 if (CxMULTICALL(&cxstack[cxstack_ix]))
2491 cxstack_ix++; /* temporarily protect top context */
2494 if (gimme == G_SCALAR) {
2497 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2499 *MARK = SvREFCNT_inc(TOPs);
2504 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2506 *MARK = sv_mortalcopy(sv);
2511 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2515 *MARK = &PL_sv_undef;
2519 else if (gimme == G_ARRAY) {
2520 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2521 if (!SvTEMP(*MARK)) {
2522 *MARK = sv_mortalcopy(*MARK);
2523 TAINT_NOT; /* Each item is independent */
2531 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2532 PL_curpm = newpm; /* ... and pop $1 et al */
2535 return cx->blk_sub.retop;
2538 /* This duplicates the above code because the above code must not
2539 * get any slower by more conditions */
2547 register PERL_CONTEXT *cx;
2550 if (CxMULTICALL(&cxstack[cxstack_ix]))
2554 cxstack_ix++; /* temporarily protect top context */
2558 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2559 /* We are an argument to a function or grep().
2560 * This kind of lvalueness was legal before lvalue
2561 * subroutines too, so be backward compatible:
2562 * cannot report errors. */
2564 /* Scalar context *is* possible, on the LHS of -> only,
2565 * as in f()->meth(). But this is not an lvalue. */
2566 if (gimme == G_SCALAR)
2568 if (gimme == G_ARRAY) {
2569 if (!CvLVALUE(cx->blk_sub.cv))
2570 goto temporise_array;
2571 EXTEND_MORTAL(SP - newsp);
2572 for (mark = newsp + 1; mark <= SP; mark++) {
2575 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2576 *mark = sv_mortalcopy(*mark);
2578 /* Can be a localized value subject to deletion. */
2579 PL_tmps_stack[++PL_tmps_ix] = *mark;
2580 SvREFCNT_inc_void(*mark);
2585 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2586 /* Here we go for robustness, not for speed, so we change all
2587 * the refcounts so the caller gets a live guy. Cannot set
2588 * TEMP, so sv_2mortal is out of question. */
2589 if (!CvLVALUE(cx->blk_sub.cv)) {
2595 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2597 if (gimme == G_SCALAR) {
2601 /* Temporaries are bad unless they happen to be elements
2602 * of a tied hash or array */
2603 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2604 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2610 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2611 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2612 : "a readonly value" : "a temporary");
2614 else { /* Can be a localized value
2615 * subject to deletion. */
2616 PL_tmps_stack[++PL_tmps_ix] = *mark;
2617 SvREFCNT_inc_void(*mark);
2620 else { /* Should not happen? */
2626 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2627 (MARK > SP ? "Empty array" : "Array"));
2631 else if (gimme == G_ARRAY) {
2632 EXTEND_MORTAL(SP - newsp);
2633 for (mark = newsp + 1; mark <= SP; mark++) {
2634 if (*mark != &PL_sv_undef
2635 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2636 /* Might be flattened array after $#array = */
2643 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2644 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2647 /* Can be a localized value subject to deletion. */
2648 PL_tmps_stack[++PL_tmps_ix] = *mark;
2649 SvREFCNT_inc_void(*mark);
2655 if (gimme == G_SCALAR) {
2659 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2661 *MARK = SvREFCNT_inc(TOPs);
2666 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2668 *MARK = sv_mortalcopy(sv);
2673 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2677 *MARK = &PL_sv_undef;
2681 else if (gimme == G_ARRAY) {
2683 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2684 if (!SvTEMP(*MARK)) {
2685 *MARK = sv_mortalcopy(*MARK);
2686 TAINT_NOT; /* Each item is independent */
2695 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2696 PL_curpm = newpm; /* ... and pop $1 et al */
2699 return cx->blk_sub.retop;
2707 register PERL_CONTEXT *cx;
2709 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2712 DIE(aTHX_ "Not a CODE reference");
2713 switch (SvTYPE(sv)) {
2714 /* This is overwhelming the most common case: */
2716 if (!isGV_with_GP(sv))
2717 DIE(aTHX_ "Not a CODE reference");
2718 if (!(cv = GvCVu((const GV *)sv))) {
2720 cv = sv_2cv(sv, &stash, &gv, 0);
2729 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2731 SP = PL_stack_base + POPMARK;
2736 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2737 tryAMAGICunDEREF(to_cv);
2742 sym = SvPV_nomg_const(sv, len);
2744 DIE(aTHX_ PL_no_usym, "a subroutine");
2745 if (PL_op->op_private & HINT_STRICT_REFS)
2746 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2747 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2750 cv = MUTABLE_CV(SvRV(sv));
2751 if (SvTYPE(cv) == SVt_PVCV)
2756 DIE(aTHX_ "Not a CODE reference");
2757 /* This is the second most common case: */
2759 cv = MUTABLE_CV(sv);
2767 if (!CvROOT(cv) && !CvXSUB(cv)) {
2771 /* anonymous or undef'd function leaves us no recourse */
2772 if (CvANON(cv) || !(gv = CvGV(cv)))
2773 DIE(aTHX_ "Undefined subroutine called");
2775 /* autoloaded stub? */
2776 if (cv != GvCV(gv)) {
2779 /* should call AUTOLOAD now? */
2782 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2789 sub_name = sv_newmortal();
2790 gv_efullname3(sub_name, gv, NULL);
2791 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2795 DIE(aTHX_ "Not a CODE reference");
2800 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2801 Perl_get_db_sub(aTHX_ &sv, cv);
2803 PL_curcopdb = PL_curcop;
2805 /* check for lsub that handles lvalue subroutines */
2806 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2807 /* if lsub not found then fall back to DB::sub */
2808 if (!cv) cv = GvCV(PL_DBsub);
2810 cv = GvCV(PL_DBsub);
2813 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2814 DIE(aTHX_ "No DB::sub routine defined");
2817 if (!(CvISXSUB(cv))) {
2818 /* This path taken at least 75% of the time */
2820 register I32 items = SP - MARK;
2821 AV* const padlist = CvPADLIST(cv);
2822 PUSHBLOCK(cx, CXt_SUB, MARK);
2824 cx->blk_sub.retop = PL_op->op_next;
2826 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2827 * that eval'' ops within this sub know the correct lexical space.
2828 * Owing the speed considerations, we choose instead to search for
2829 * the cv using find_runcv() when calling doeval().
2831 if (CvDEPTH(cv) >= 2) {
2832 PERL_STACK_OVERFLOW_CHECK();
2833 pad_push(padlist, CvDEPTH(cv));
2836 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2838 AV *const av = MUTABLE_AV(PAD_SVl(0));
2840 /* @_ is normally not REAL--this should only ever
2841 * happen when DB::sub() calls things that modify @_ */
2846 cx->blk_sub.savearray = GvAV(PL_defgv);
2847 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2848 CX_CURPAD_SAVE(cx->blk_sub);
2849 cx->blk_sub.argarray = av;
2852 if (items > AvMAX(av) + 1) {
2853 SV **ary = AvALLOC(av);
2854 if (AvARRAY(av) != ary) {
2855 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2858 if (items > AvMAX(av) + 1) {
2859 AvMAX(av) = items - 1;
2860 Renew(ary,items,SV*);
2865 Copy(MARK,AvARRAY(av),items,SV*);
2866 AvFILLp(av) = items - 1;
2874 /* warning must come *after* we fully set up the context
2875 * stuff so that __WARN__ handlers can safely dounwind()
2878 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2879 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2880 sub_crush_depth(cv);
2881 RETURNOP(CvSTART(cv));
2884 I32 markix = TOPMARK;
2889 /* Need to copy @_ to stack. Alternative may be to
2890 * switch stack to @_, and copy return values
2891 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2892 AV * const av = GvAV(PL_defgv);
2893 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2896 /* Mark is at the end of the stack. */
2898 Copy(AvARRAY(av), SP + 1, items, SV*);
2903 /* We assume first XSUB in &DB::sub is the called one. */
2905 SAVEVPTR(PL_curcop);
2906 PL_curcop = PL_curcopdb;
2909 /* Do we need to open block here? XXXX */
2911 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2913 CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
2915 /* Enforce some sanity in scalar context. */
2916 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2917 if (markix > PL_stack_sp - PL_stack_base)
2918 *(PL_stack_base + markix) = &PL_sv_undef;
2920 *(PL_stack_base + markix) = *PL_stack_sp;
2921 PL_stack_sp = PL_stack_base + markix;
2929 Perl_sub_crush_depth(pTHX_ CV *cv)
2931 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2934 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2936 SV* const tmpstr = sv_newmortal();
2937 gv_efullname3(tmpstr, CvGV(cv), NULL);
2938 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2947 SV* const elemsv = POPs;
2948 IV elem = SvIV(elemsv);
2949 AV *const av = MUTABLE_AV(POPs);
2950 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2951 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2952 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2953 bool preeminent = TRUE;
2956 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2957 Perl_warner(aTHX_ packWARN(WARN_MISC),
2958 "Use of reference \"%"SVf"\" as array index",
2961 elem -= CopARYBASE_get(PL_curcop);
2962 if (SvTYPE(av) != SVt_PVAV)
2969 /* If we can determine whether the element exist,
2970 * Try to preserve the existenceness of a tied array
2971 * element by using EXISTS and DELETE if possible.
2972 * Fallback to FETCH and STORE otherwise. */
2973 if (SvCANEXISTDELETE(av))
2974 preeminent = av_exists(av, elem);
2977 svp = av_fetch(av, elem, lval && !defer);
2979 #ifdef PERL_MALLOC_WRAP
2980 if (SvUOK(elemsv)) {
2981 const UV uv = SvUV(elemsv);
2982 elem = uv > IV_MAX ? IV_MAX : uv;
2984 else if (SvNOK(elemsv))
2985 elem = (IV)SvNV(elemsv);
2987 static const char oom_array_extend[] =
2988 "Out of memory during array extend"; /* Duplicated in av.c */
2989 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2992 if (!svp || *svp == &PL_sv_undef) {
2995 DIE(aTHX_ PL_no_aelem, elem);
2996 lv = sv_newmortal();
2997 sv_upgrade(lv, SVt_PVLV);
2999 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3000 LvTARG(lv) = SvREFCNT_inc_simple(av);
3001 LvTARGOFF(lv) = elem;
3008 save_aelem(av, elem, svp);
3010 SAVEADELETE(av, elem);
3012 else if (PL_op->op_private & OPpDEREF)
3013 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3015 sv = (svp ? *svp : &PL_sv_undef);
3016 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3023 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3025 PERL_ARGS_ASSERT_VIVIFY_REF;
3030 Perl_croak(aTHX_ "%s", PL_no_modify);
3031 prepare_SV_for_RV(sv);
3034 SvRV_set(sv, newSV(0));
3037 SvRV_set(sv, MUTABLE_SV(newAV()));
3040 SvRV_set(sv, MUTABLE_SV(newHV()));
3051 SV* const sv = TOPs;
3054 SV* const rsv = SvRV(sv);
3055 if (SvTYPE(rsv) == SVt_PVCV) {
3061 SETs(method_common(sv, NULL));
3068 SV* const sv = cSVOP_sv;
3069 U32 hash = SvSHARED_HASH(sv);
3071 XPUSHs(method_common(sv, &hash));
3076 S_method_common(pTHX_ SV* meth, U32* hashp)
3082 const char* packname = NULL;
3085 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3087 PERL_ARGS_ASSERT_METHOD_COMMON;
3090 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3095 ob = MUTABLE_SV(SvRV(sv));
3099 /* this isn't a reference */
3100 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3101 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3103 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3110 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3111 !(ob=MUTABLE_SV(GvIO(iogv))))
3113 /* this isn't the name of a filehandle either */
3115 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3116 ? !isIDFIRST_utf8((U8*)packname)
3117 : !isIDFIRST(*packname)
3120 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3122 SvOK(sv) ? "without a package or object reference"
3123 : "on an undefined value");
3125 /* assume it's a package name */
3126 stash = gv_stashpvn(packname, packlen, 0);
3130 SV* const ref = newSViv(PTR2IV(stash));
3131 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3135 /* it _is_ a filehandle name -- replace with a reference */
3136 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3139 /* if we got here, ob should be a reference or a glob */
3140 if (!ob || !(SvOBJECT(ob)
3141 || (SvTYPE(ob) == SVt_PVGV
3143 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3146 const char * const name = SvPV_nolen_const(meth);
3147 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3148 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3152 stash = SvSTASH(ob);
3155 /* NOTE: stash may be null, hope hv_fetch_ent and
3156 gv_fetchmethod can cope (it seems they can) */
3158 /* shortcut for simple names */
3160 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3162 gv = MUTABLE_GV(HeVAL(he));
3163 if (isGV(gv) && GvCV(gv) &&
3164 (!GvCVGEN(gv) || GvCVGEN(gv)
3165 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3166 return MUTABLE_SV(GvCV(gv));
3170 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3171 SvPV_nolen_const(meth),
3172 GV_AUTOLOAD | GV_CROAK);
3176 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3181 * c-indentation-style: bsd
3183 * indent-tabs-mode: t
3186 * ex: set ts=8 sts=4 sw=4 noet: