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(concat,opASSIGN);
235 const char *rpv = NULL;
237 bool rcopied = FALSE;
239 if (TARG == right && right != left) {
240 /* mg_get(right) may happen here ... */
241 rpv = SvPV_const(right, rlen);
242 rbyte = !DO_UTF8(right);
243 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
244 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
250 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
251 lbyte = !DO_UTF8(left);
252 sv_setpvn(TARG, lpv, llen);
258 else { /* TARG == left */
260 SvGETMAGIC(left); /* or mg_get(left) may happen here */
262 if (left == right && ckWARN(WARN_UNINITIALIZED))
263 report_uninit(right);
266 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
267 lbyte = !DO_UTF8(left);
272 /* or mg_get(right) may happen here */
274 rpv = SvPV_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_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();
332 dVAR; dSP; tryAMAGICbinSET(eq,0);
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
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. */
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(TOPn == value));
406 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
407 DIE(aTHX_ "%s", PL_no_modify);
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(add,opASSIGN);
495 svl = sv_2num(TOPm1s);
497 useleft = USE_LEFT(svl);
498 #ifdef PERL_PRESERVE_IVUV
499 /* We must see if we can perform the addition with integers if possible,
500 as the integer code detects overflow while the NV code doesn't.
501 If either argument hasn't had a numeric conversion yet attempt to get
502 the IV. It's important to do this now, rather than just assuming that
503 it's not IOK as a PV of "9223372036854775806" may not take well to NV
504 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
505 integer in case the second argument is IV=9223372036854775806
506 We can (now) rely on sv_2iv to do the right thing, only setting the
507 public IOK flag if the value in the NV (or PV) slot is truly integer.
509 A side effect is that this also aggressively prefers integer maths over
510 fp maths for integer values.
512 How to detect overflow?
514 C 99 section 6.2.6.1 says
516 The range of nonnegative values of a signed integer type is a subrange
517 of the corresponding unsigned integer type, and the representation of
518 the same value in each type is the same. A computation involving
519 unsigned operands can never overflow, because a result that cannot be
520 represented by the resulting unsigned integer type is reduced modulo
521 the number that is one greater than the largest value that can be
522 represented by the resulting type.
526 which I read as "unsigned ints wrap."
528 signed integer overflow seems to be classed as "exception condition"
530 If an exceptional condition occurs during the evaluation of an
531 expression (that is, if the result is not mathematically defined or not
532 in the range of representable values for its type), the behavior is
535 (6.5, the 5th paragraph)
537 I had assumed that on 2s complement machines signed arithmetic would
538 wrap, hence coded pp_add and pp_subtract on the assumption that
539 everything perl builds on would be happy. After much wailing and
540 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
541 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
542 unsigned code below is actually shorter than the old code. :-)
547 /* Unless the left argument is integer in range we are going to have to
548 use NV maths. Hence only attempt to coerce the right argument if
549 we know the left is integer. */
557 /* left operand is undef, treat as zero. + 0 is identity,
558 Could SETi or SETu right now, but space optimise by not adding
559 lots of code to speed up what is probably a rarish case. */
561 /* Left operand is defined, so is it IV? */
564 if ((auvok = SvUOK(svl)))
567 register const IV aiv = SvIVX(svl);
570 auvok = 1; /* Now acting as a sign flag. */
571 } else { /* 2s complement assumption for IV_MIN */
579 bool result_good = 0;
582 bool buvok = SvUOK(svr);
587 register const IV biv = SvIVX(svr);
594 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
595 else "IV" now, independent of how it came in.
596 if a, b represents positive, A, B negative, a maps to -A etc
601 all UV maths. negate result if A negative.
602 add if signs same, subtract if signs differ. */
608 /* Must get smaller */
614 /* result really should be -(auv-buv). as its negation
615 of true value, need to swap our result flag */
632 if (result <= (UV)IV_MIN)
635 /* result valid, but out of range for IV. */
640 } /* Overflow, drop through to NVs. */
645 NV value = SvNV(svr);
648 /* left operand is undef, treat as zero. + 0.0 is identity. */
652 SETn( value + SvNV(svl) );
660 AV * const av = PL_op->op_flags & OPf_SPECIAL
661 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
662 const U32 lval = PL_op->op_flags & OPf_MOD;
663 SV** const svp = av_fetch(av, PL_op->op_private, lval);
664 SV *sv = (svp ? *svp : &PL_sv_undef);
666 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
674 dVAR; dSP; dMARK; dTARGET;
676 do_join(TARG, *MARK, MARK, SP);
687 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
688 * will be enough to hold an OP*.
690 SV* const sv = sv_newmortal();
691 sv_upgrade(sv, SVt_PVLV);
693 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
696 XPUSHs(MUTABLE_SV(PL_op));
701 /* Oversized hot code. */
705 dVAR; dSP; dMARK; dORIGMARK;
710 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
712 if (gv && (io = GvIO(gv))
713 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
716 if (MARK == ORIGMARK) {
717 /* If using default handle then we need to make space to
718 * pass object as 1st arg, so move other args up ...
722 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
726 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
728 ENTER_with_name("call_PRINT");
729 if( PL_op->op_type == OP_SAY ) {
730 /* local $\ = "\n" */
731 SAVEGENERICSV(PL_ors_sv);
732 PL_ors_sv = newSVpvs("\n");
734 call_method("PRINT", G_SCALAR);
735 LEAVE_with_name("call_PRINT");
742 if (!(io = GvIO(gv))) {
743 if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
744 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
746 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
747 report_evil_fh(gv, io, PL_op->op_type);
748 SETERRNO(EBADF,RMS_IFI);
751 else if (!(fp = IoOFP(io))) {
752 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
754 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
755 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
756 report_evil_fh(gv, io, PL_op->op_type);
758 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
762 SV * const ofs = GvSV(PL_ofsgv); /* $, */
764 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
766 if (!do_print(*MARK, fp))
770 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
771 if (!do_print(GvSV(PL_ofsgv), fp)) {
780 if (!do_print(*MARK, fp))
788 if (PL_op->op_type == OP_SAY) {
789 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
792 else if (PL_ors_sv && SvOK(PL_ors_sv))
793 if (!do_print(PL_ors_sv, fp)) /* $\ */
796 if (IoFLAGS(io) & IOf_FLUSH)
797 if (PerlIO_flush(fp) == EOF)
807 XPUSHs(&PL_sv_undef);
814 const I32 gimme = GIMME_V;
815 static const char an_array[] = "an ARRAY";
816 static const char a_hash[] = "a HASH";
817 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
818 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
822 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
825 if (SvTYPE(sv) != type)
826 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
827 if (PL_op->op_flags & OPf_REF) {
832 if (gimme != G_ARRAY)
833 goto croak_cant_return;
837 else if (PL_op->op_flags & OPf_MOD
838 && PL_op->op_private & OPpLVAL_INTRO)
839 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
842 if (SvTYPE(sv) == type) {
843 if (PL_op->op_flags & OPf_REF) {
848 if (gimme != G_ARRAY)
849 goto croak_cant_return;
857 if (!isGV_with_GP(sv)) {
858 if (SvGMAGICAL(sv)) {
863 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
871 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
872 if (PL_op->op_private & OPpLVAL_INTRO)
873 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
874 if (PL_op->op_flags & OPf_REF) {
879 if (gimme != G_ARRAY)
880 goto croak_cant_return;
888 AV *const av = MUTABLE_AV(sv);
889 /* The guts of pp_rv2av, with no intenting change to preserve history
890 (until such time as we get tools that can do blame annotation across
891 whitespace changes. */
892 if (gimme == G_ARRAY) {
893 const I32 maxarg = AvFILL(av) + 1;
894 (void)POPs; /* XXXX May be optimized away? */
896 if (SvRMAGICAL(av)) {
898 for (i=0; i < (U32)maxarg; i++) {
899 SV ** const svp = av_fetch(av, i, FALSE);
900 /* See note in pp_helem, and bug id #27839 */
902 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
907 Copy(AvARRAY(av), SP+1, maxarg, SV*);
911 else if (gimme == G_SCALAR) {
913 const I32 maxarg = AvFILL(av) + 1;
917 /* The guts of pp_rv2hv */
918 if (gimme == G_ARRAY) { /* array wanted */
922 else if (gimme == G_SCALAR) {
924 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
932 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
933 is_pp_rv2av ? "array" : "hash");
938 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
942 PERL_ARGS_ASSERT_DO_ODDBALL;
948 if (ckWARN(WARN_MISC)) {
950 if (relem == firstrelem &&
952 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
953 SvTYPE(SvRV(*relem)) == SVt_PVHV))
955 err = "Reference found where even-sized list expected";
958 err = "Odd number of elements in hash assignment";
959 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
963 didstore = hv_store_ent(hash,*relem,tmpstr,0);
964 if (SvMAGICAL(hash)) {
965 if (SvSMAGICAL(tmpstr))
977 SV **lastlelem = PL_stack_sp;
978 SV **lastrelem = PL_stack_base + POPMARK;
979 SV **firstrelem = PL_stack_base + POPMARK + 1;
980 SV **firstlelem = lastrelem + 1;
993 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
995 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
998 /* If there's a common identifier on both sides we have to take
999 * special care that assigning the identifier on the left doesn't
1000 * clobber a value on the right that's used later in the list.
1002 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1003 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1004 for (relem = firstrelem; relem <= lastrelem; relem++) {
1005 if ((sv = *relem)) {
1006 TAINT_NOT; /* Each item is independent */
1008 /* Dear TODO test in t/op/sort.t, I love you.
1009 (It's relying on a panic, not a "semi-panic" from newSVsv()
1010 and then an assertion failure below.) */
1011 if (SvIS_FREED(sv)) {
1012 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1015 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1016 and we need a second copy of a temp here. */
1017 *relem = sv_2mortal(newSVsv(sv));
1027 while (lelem <= lastlelem) {
1028 TAINT_NOT; /* Each item stands on its own, taintwise. */
1030 switch (SvTYPE(sv)) {
1032 ary = MUTABLE_AV(sv);
1033 magic = SvMAGICAL(ary) != 0;
1035 av_extend(ary, lastrelem - relem);
1037 while (relem <= lastrelem) { /* gobble up all the rest */
1041 sv_setsv(sv, *relem);
1043 didstore = av_store(ary,i++,sv);
1045 if (SvSMAGICAL(sv)) {
1046 /* More magic can happen in the mg_set callback, so we
1047 * backup the delaymagic for now. */
1048 U16 dmbak = PL_delaymagic;
1051 PL_delaymagic = dmbak;
1058 if (PL_delaymagic & DM_ARRAY)
1059 SvSETMAGIC(MUTABLE_SV(ary));
1061 case SVt_PVHV: { /* normal hash */
1064 hash = MUTABLE_HV(sv);
1065 magic = SvMAGICAL(hash) != 0;
1067 firsthashrelem = relem;
1069 while (relem < lastrelem) { /* gobble up all the rest */
1071 sv = *relem ? *relem : &PL_sv_no;
1075 sv_setsv(tmpstr,*relem); /* value */
1076 *(relem++) = tmpstr;
1077 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1078 /* key overwrites an existing entry */
1080 didstore = hv_store_ent(hash,sv,tmpstr,0);
1082 if (SvSMAGICAL(tmpstr)) {
1083 U16 dmbak = PL_delaymagic;
1086 PL_delaymagic = dmbak;
1093 if (relem == lastrelem) {
1094 do_oddball(hash, relem, firstrelem);
1100 if (SvIMMORTAL(sv)) {
1101 if (relem <= lastrelem)
1105 if (relem <= lastrelem) {
1106 sv_setsv(sv, *relem);
1110 sv_setsv(sv, &PL_sv_undef);
1112 if (SvSMAGICAL(sv)) {
1113 U16 dmbak = PL_delaymagic;
1116 PL_delaymagic = dmbak;
1121 if (PL_delaymagic & ~DM_DELAY) {
1122 if (PL_delaymagic & DM_UID) {
1123 #ifdef HAS_SETRESUID
1124 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1125 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1128 # ifdef HAS_SETREUID
1129 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1130 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1133 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1134 (void)setruid(PL_uid);
1135 PL_delaymagic &= ~DM_RUID;
1137 # endif /* HAS_SETRUID */
1139 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1140 (void)seteuid(PL_euid);
1141 PL_delaymagic &= ~DM_EUID;
1143 # endif /* HAS_SETEUID */
1144 if (PL_delaymagic & DM_UID) {
1145 if (PL_uid != PL_euid)
1146 DIE(aTHX_ "No setreuid available");
1147 (void)PerlProc_setuid(PL_uid);
1149 # endif /* HAS_SETREUID */
1150 #endif /* HAS_SETRESUID */
1151 PL_uid = PerlProc_getuid();
1152 PL_euid = PerlProc_geteuid();
1154 if (PL_delaymagic & DM_GID) {
1155 #ifdef HAS_SETRESGID
1156 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1157 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1160 # ifdef HAS_SETREGID
1161 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1162 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1165 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1166 (void)setrgid(PL_gid);
1167 PL_delaymagic &= ~DM_RGID;
1169 # endif /* HAS_SETRGID */
1171 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1172 (void)setegid(PL_egid);
1173 PL_delaymagic &= ~DM_EGID;
1175 # endif /* HAS_SETEGID */
1176 if (PL_delaymagic & DM_GID) {
1177 if (PL_gid != PL_egid)
1178 DIE(aTHX_ "No setregid available");
1179 (void)PerlProc_setgid(PL_gid);
1181 # endif /* HAS_SETREGID */
1182 #endif /* HAS_SETRESGID */
1183 PL_gid = PerlProc_getgid();
1184 PL_egid = PerlProc_getegid();
1186 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1190 if (gimme == G_VOID)
1191 SP = firstrelem - 1;
1192 else if (gimme == G_SCALAR) {
1195 SETi(lastrelem - firstrelem + 1 - duplicates);
1202 /* Removes from the stack the entries which ended up as
1203 * duplicated keys in the hash (fix for [perl #24380]) */
1204 Move(firsthashrelem + duplicates,
1205 firsthashrelem, duplicates, SV**);
1206 lastrelem -= duplicates;
1211 SP = firstrelem + (lastlelem - firstlelem);
1212 lelem = firstlelem + (relem - firstrelem);
1214 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1223 register PMOP * const pm = cPMOP;
1224 REGEXP * rx = PM_GETRE(pm);
1225 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1226 SV * const rv = sv_newmortal();
1228 SvUPGRADE(rv, SVt_IV);
1229 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1230 loathe to use it here, but it seems to be the right fix. Or close.
1231 The key part appears to be that it's essential for pp_qr to return a new
1232 object (SV), which implies that there needs to be an effective way to
1233 generate a new SV from the existing SV that is pre-compiled in the
1235 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1239 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1241 (void)sv_bless(rv, stash);
1244 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1253 register PMOP *pm = cPMOP;
1255 register const char *t;
1256 register const char *s;
1259 U8 r_flags = REXEC_CHECKED;
1260 const char *truebase; /* Start of string */
1261 register REGEXP *rx = PM_GETRE(pm);
1263 const I32 gimme = GIMME;
1266 const I32 oldsave = PL_savestack_ix;
1267 I32 update_minmatch = 1;
1268 I32 had_zerolen = 0;
1271 if (PL_op->op_flags & OPf_STACKED)
1273 else if (PL_op->op_private & OPpTARGET_MY)
1280 PUTBACK; /* EVAL blocks need stack_sp. */
1281 /* Skip get-magic if this is a qr// clone, because regcomp has
1283 s = ((struct regexp *)SvANY(rx))->mother_re
1284 ? SvPV_nomg_const(TARG, len)
1285 : SvPV_const(TARG, len);
1287 DIE(aTHX_ "panic: pp_match");
1289 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1290 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1293 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1295 /* PMdf_USED is set after a ?? matches once */
1298 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1300 pm->op_pmflags & PMf_USED
1304 if (gimme == G_ARRAY)
1311 /* empty pattern special-cased to use last successful pattern if possible */
1312 if (!RX_PRELEN(rx) && PL_curpm) {
1317 if (RX_MINLEN(rx) > (I32)len)
1322 /* XXXX What part of this is needed with true \G-support? */
1323 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1324 RX_OFFS(rx)[0].start = -1;
1325 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1326 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1327 if (mg && mg->mg_len >= 0) {
1328 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1329 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1330 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1331 r_flags |= REXEC_IGNOREPOS;
1332 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1333 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1336 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1337 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1338 update_minmatch = 0;
1342 /* XXX: comment out !global get safe $1 vars after a
1343 match, BUT be aware that this leads to dramatic slowdowns on
1344 /g matches against large strings. So far a solution to this problem
1345 appears to be quite tricky.
1346 Test for the unsafe vars are TODO for now. */
1347 if (( !global && RX_NPARENS(rx))
1348 || SvTEMP(TARG) || PL_sawampersand ||
1349 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1350 r_flags |= REXEC_COPY_STR;
1352 r_flags |= REXEC_SCREAM;
1355 if (global && RX_OFFS(rx)[0].start != -1) {
1356 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1357 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1359 if (update_minmatch++)
1360 minmatch = had_zerolen;
1362 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1363 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1364 /* FIXME - can PL_bostr be made const char *? */
1365 PL_bostr = (char *)truebase;
1366 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1370 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1372 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1373 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1374 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1375 && (r_flags & REXEC_SCREAM)))
1376 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1379 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1380 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1383 if (dynpm->op_pmflags & PMf_ONCE) {
1385 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1387 dynpm->op_pmflags |= PMf_USED;
1398 RX_MATCH_TAINTED_on(rx);
1399 TAINT_IF(RX_MATCH_TAINTED(rx));
1400 if (gimme == G_ARRAY) {
1401 const I32 nparens = RX_NPARENS(rx);
1402 I32 i = (global && !nparens) ? 1 : 0;
1404 SPAGAIN; /* EVAL blocks could move the stack. */
1405 EXTEND(SP, nparens + i);
1406 EXTEND_MORTAL(nparens + i);
1407 for (i = !i; i <= nparens; i++) {
1408 PUSHs(sv_newmortal());
1409 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1410 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1411 s = RX_OFFS(rx)[i].start + truebase;
1412 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1413 len < 0 || len > strend - s)
1414 DIE(aTHX_ "panic: pp_match start/end pointers");
1415 sv_setpvn(*SP, s, len);
1416 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1421 if (dynpm->op_pmflags & PMf_CONTINUE) {
1423 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1424 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1426 #ifdef PERL_OLD_COPY_ON_WRITE
1428 sv_force_normal_flags(TARG, 0);
1430 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1431 &PL_vtbl_mglob, NULL, 0);
1433 if (RX_OFFS(rx)[0].start != -1) {
1434 mg->mg_len = RX_OFFS(rx)[0].end;
1435 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1436 mg->mg_flags |= MGf_MINMATCH;
1438 mg->mg_flags &= ~MGf_MINMATCH;
1441 had_zerolen = (RX_OFFS(rx)[0].start != -1
1442 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1443 == (UV)RX_OFFS(rx)[0].end));
1444 PUTBACK; /* EVAL blocks may use stack */
1445 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1450 LEAVE_SCOPE(oldsave);
1456 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1457 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1461 #ifdef PERL_OLD_COPY_ON_WRITE
1463 sv_force_normal_flags(TARG, 0);
1465 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1466 &PL_vtbl_mglob, NULL, 0);
1468 if (RX_OFFS(rx)[0].start != -1) {
1469 mg->mg_len = RX_OFFS(rx)[0].end;
1470 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1471 mg->mg_flags |= MGf_MINMATCH;
1473 mg->mg_flags &= ~MGf_MINMATCH;
1476 LEAVE_SCOPE(oldsave);
1480 yup: /* Confirmed by INTUIT */
1482 RX_MATCH_TAINTED_on(rx);
1483 TAINT_IF(RX_MATCH_TAINTED(rx));
1485 if (dynpm->op_pmflags & PMf_ONCE) {
1487 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1489 dynpm->op_pmflags |= PMf_USED;
1492 if (RX_MATCH_COPIED(rx))
1493 Safefree(RX_SUBBEG(rx));
1494 RX_MATCH_COPIED_off(rx);
1495 RX_SUBBEG(rx) = NULL;
1497 /* FIXME - should rx->subbeg be const char *? */
1498 RX_SUBBEG(rx) = (char *) truebase;
1499 RX_OFFS(rx)[0].start = s - truebase;
1500 if (RX_MATCH_UTF8(rx)) {
1501 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1502 RX_OFFS(rx)[0].end = t - truebase;
1505 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1507 RX_SUBLEN(rx) = strend - truebase;
1510 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1512 #ifdef PERL_OLD_COPY_ON_WRITE
1513 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1515 PerlIO_printf(Perl_debug_log,
1516 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1517 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1520 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1522 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1523 assert (SvPOKp(RX_SAVED_COPY(rx)));
1528 RX_SUBBEG(rx) = savepvn(t, strend - t);
1529 #ifdef PERL_OLD_COPY_ON_WRITE
1530 RX_SAVED_COPY(rx) = NULL;
1533 RX_SUBLEN(rx) = strend - t;
1534 RX_MATCH_COPIED_on(rx);
1535 off = RX_OFFS(rx)[0].start = s - t;
1536 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1538 else { /* startp/endp are used by @- @+. */
1539 RX_OFFS(rx)[0].start = s - truebase;
1540 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1542 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1544 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1545 LEAVE_SCOPE(oldsave);
1550 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1551 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1552 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1557 LEAVE_SCOPE(oldsave);
1558 if (gimme == G_ARRAY)
1564 Perl_do_readline(pTHX)
1566 dVAR; dSP; dTARGETSTACKED;
1571 register IO * const io = GvIO(PL_last_in_gv);
1572 register const I32 type = PL_op->op_type;
1573 const I32 gimme = GIMME_V;
1576 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1579 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1581 ENTER_with_name("call_READLINE");
1582 call_method("READLINE", gimme);
1583 LEAVE_with_name("call_READLINE");
1585 if (gimme == G_SCALAR) {
1586 SV* const result = POPs;
1587 SvSetSV_nosteal(TARG, result);
1597 if (IoFLAGS(io) & IOf_ARGV) {
1598 if (IoFLAGS(io) & IOf_START) {
1600 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1601 IoFLAGS(io) &= ~IOf_START;
1602 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1603 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1604 SvSETMAGIC(GvSV(PL_last_in_gv));
1609 fp = nextargv(PL_last_in_gv);
1610 if (!fp) { /* Note: fp != IoIFP(io) */
1611 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1614 else if (type == OP_GLOB)
1615 fp = Perl_start_glob(aTHX_ POPs, io);
1617 else if (type == OP_GLOB)
1619 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1620 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1624 if ((!io || !(IoFLAGS(io) & IOf_START))
1625 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1627 if (type == OP_GLOB)
1628 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1629 "glob failed (can't start child: %s)",
1632 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1634 if (gimme == G_SCALAR) {
1635 /* undef TARG, and push that undefined value */
1636 if (type != OP_RCATLINE) {
1637 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1645 if (gimme == G_SCALAR) {
1647 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1650 if (type == OP_RCATLINE)
1651 SvPV_force_nolen(sv);
1655 else if (isGV_with_GP(sv)) {
1656 SvPV_force_nolen(sv);
1658 SvUPGRADE(sv, SVt_PV);
1659 tmplen = SvLEN(sv); /* remember if already alloced */
1660 if (!tmplen && !SvREADONLY(sv))
1661 Sv_Grow(sv, 80); /* try short-buffering it */
1663 if (type == OP_RCATLINE && SvOK(sv)) {
1665 SvPV_force_nolen(sv);
1671 sv = sv_2mortal(newSV(80));
1675 /* This should not be marked tainted if the fp is marked clean */
1676 #define MAYBE_TAINT_LINE(io, sv) \
1677 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1682 /* delay EOF state for a snarfed empty file */
1683 #define SNARF_EOF(gimme,rs,io,sv) \
1684 (gimme != G_SCALAR || SvCUR(sv) \
1685 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1689 if (!sv_gets(sv, fp, offset)
1691 || SNARF_EOF(gimme, PL_rs, io, sv)
1692 || PerlIO_error(fp)))
1694 PerlIO_clearerr(fp);
1695 if (IoFLAGS(io) & IOf_ARGV) {
1696 fp = nextargv(PL_last_in_gv);
1699 (void)do_close(PL_last_in_gv, FALSE);
1701 else if (type == OP_GLOB) {
1702 if (!do_close(PL_last_in_gv, FALSE)) {
1703 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1704 "glob failed (child exited with status %d%s)",
1705 (int)(STATUS_CURRENT >> 8),
1706 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1709 if (gimme == G_SCALAR) {
1710 if (type != OP_RCATLINE) {
1711 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1717 MAYBE_TAINT_LINE(io, sv);
1720 MAYBE_TAINT_LINE(io, sv);
1722 IoFLAGS(io) |= IOf_NOLINE;
1726 if (type == OP_GLOB) {
1729 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1730 char * const tmps = SvEND(sv) - 1;
1731 if (*tmps == *SvPVX_const(PL_rs)) {
1733 SvCUR_set(sv, SvCUR(sv) - 1);
1736 for (t1 = SvPVX_const(sv); *t1; t1++)
1737 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1738 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1740 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1741 (void)POPs; /* Unmatched wildcard? Chuck it... */
1744 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1745 if (ckWARN(WARN_UTF8)) {
1746 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1747 const STRLEN len = SvCUR(sv) - offset;
1750 if (!is_utf8_string_loc(s, len, &f))
1751 /* Emulate :encoding(utf8) warning in the same case. */
1752 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1753 "utf8 \"\\x%02X\" does not map to Unicode",
1754 f < (U8*)SvEND(sv) ? *f : 0);
1757 if (gimme == G_ARRAY) {
1758 if (SvLEN(sv) - SvCUR(sv) > 20) {
1759 SvPV_shrink_to_cur(sv);
1761 sv = sv_2mortal(newSV(80));
1764 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1765 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1766 const STRLEN new_len
1767 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1768 SvPV_renew(sv, new_len);
1777 register PERL_CONTEXT *cx;
1778 I32 gimme = OP_GIMME(PL_op, -1);
1781 if (cxstack_ix >= 0) {
1782 /* If this flag is set, we're just inside a return, so we should
1783 * store the caller's context */
1784 gimme = (PL_op->op_flags & OPf_SPECIAL)
1786 : cxstack[cxstack_ix].blk_gimme;
1791 ENTER_with_name("block");
1794 PUSHBLOCK(cx, CXt_BLOCK, SP);
1804 SV * const keysv = POPs;
1805 HV * const hv = MUTABLE_HV(POPs);
1806 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1807 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1809 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1810 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1811 bool preeminent = TRUE;
1813 if (SvTYPE(hv) != SVt_PVHV)
1820 /* If we can determine whether the element exist,
1821 * Try to preserve the existenceness of a tied hash
1822 * element by using EXISTS and DELETE if possible.
1823 * Fallback to FETCH and STORE otherwise. */
1824 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1825 preeminent = hv_exists_ent(hv, keysv, 0);
1828 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1829 svp = he ? &HeVAL(he) : NULL;
1831 if (!svp || *svp == &PL_sv_undef) {
1835 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1837 lv = sv_newmortal();
1838 sv_upgrade(lv, SVt_PVLV);
1840 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1841 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1842 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1848 if (HvNAME_get(hv) && isGV(*svp))
1849 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1850 else if (preeminent)
1851 save_helem_flags(hv, keysv, svp,
1852 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1854 SAVEHDELETE(hv, keysv);
1856 else if (PL_op->op_private & OPpDEREF)
1857 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1859 sv = (svp ? *svp : &PL_sv_undef);
1860 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1861 * was to make C<local $tied{foo} = $tied{foo}> possible.
1862 * However, it seems no longer to be needed for that purpose, and
1863 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1864 * would loop endlessly since the pos magic is getting set on the
1865 * mortal copy and lost. However, the copy has the effect of
1866 * triggering the get magic, and losing it altogether made things like
1867 * c<$tied{foo};> in void context no longer do get magic, which some
1868 * code relied on. Also, delayed triggering of magic on @+ and friends
1869 * meant the original regex may be out of scope by now. So as a
1870 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1871 * being called too many times). */
1872 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1881 register PERL_CONTEXT *cx;
1886 if (PL_op->op_flags & OPf_SPECIAL) {
1887 cx = &cxstack[cxstack_ix];
1888 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1893 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1896 if (gimme == G_VOID)
1898 else if (gimme == G_SCALAR) {
1902 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1905 *MARK = sv_mortalcopy(TOPs);
1908 *MARK = &PL_sv_undef;
1912 else if (gimme == G_ARRAY) {
1913 /* in case LEAVE wipes old return values */
1915 for (mark = newsp + 1; mark <= SP; mark++) {
1916 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1917 *mark = sv_mortalcopy(*mark);
1918 TAINT_NOT; /* Each item is independent */
1922 PL_curpm = newpm; /* Don't pop $1 et al till now */
1924 LEAVE_with_name("block");
1932 register PERL_CONTEXT *cx;
1935 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1936 bool av_is_stack = FALSE;
1939 cx = &cxstack[cxstack_ix];
1940 if (!CxTYPE_is_LOOP(cx))
1941 DIE(aTHX_ "panic: pp_iter");
1943 itersvp = CxITERVAR(cx);
1944 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1945 /* string increment */
1946 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1947 SV *end = cx->blk_loop.state_u.lazysv.end;
1948 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1949 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1951 const char *max = SvPV_const(end, maxlen);
1952 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1953 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1954 /* safe to reuse old SV */
1955 sv_setsv(*itersvp, cur);
1959 /* we need a fresh SV every time so that loop body sees a
1960 * completely new SV for closures/references to work as
1963 *itersvp = newSVsv(cur);
1964 SvREFCNT_dec(oldsv);
1966 if (strEQ(SvPVX_const(cur), max))
1967 sv_setiv(cur, 0); /* terminate next time */
1974 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1975 /* integer increment */
1976 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1979 /* don't risk potential race */
1980 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1981 /* safe to reuse old SV */
1982 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1986 /* we need a fresh SV every time so that loop body sees a
1987 * completely new SV for closures/references to work as they
1990 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1991 SvREFCNT_dec(oldsv);
1994 /* Handle end of range at IV_MAX */
1995 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1996 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1998 cx->blk_loop.state_u.lazyiv.cur++;
1999 cx->blk_loop.state_u.lazyiv.end++;
2006 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2007 av = cx->blk_loop.state_u.ary.ary;
2012 if (PL_op->op_private & OPpITER_REVERSED) {
2013 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2014 ? cx->blk_loop.resetsp + 1 : 0))
2017 if (SvMAGICAL(av) || AvREIFY(av)) {
2018 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2019 sv = svp ? *svp : NULL;
2022 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2026 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2030 if (SvMAGICAL(av) || AvREIFY(av)) {
2031 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2032 sv = svp ? *svp : NULL;
2035 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2039 if (sv && SvIS_FREED(sv)) {
2041 Perl_croak(aTHX_ "Use of freed value in iteration");
2046 SvREFCNT_inc_simple_void_NN(sv);
2050 if (!av_is_stack && sv == &PL_sv_undef) {
2051 SV *lv = newSV_type(SVt_PVLV);
2053 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2054 LvTARG(lv) = SvREFCNT_inc_simple(av);
2055 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2056 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2062 SvREFCNT_dec(oldsv);
2070 register PMOP *pm = cPMOP;
2085 register REGEXP *rx = PM_GETRE(pm);
2087 int force_on_match = 0;
2088 const I32 oldsave = PL_savestack_ix;
2090 bool doutf8 = FALSE;
2092 #ifdef PERL_OLD_COPY_ON_WRITE
2096 /* known replacement string? */
2097 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2101 if (PL_op->op_flags & OPf_STACKED)
2103 else if (PL_op->op_private & OPpTARGET_MY)
2110 #ifdef PERL_OLD_COPY_ON_WRITE
2111 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2112 because they make integers such as 256 "false". */
2113 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2116 sv_force_normal_flags(TARG,0);
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2123 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2124 || SvTYPE(TARG) > SVt_PVLV)
2125 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2126 DIE(aTHX_ "%s", PL_no_modify);
2129 s = SvPV_mutable(TARG, len);
2130 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2132 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2133 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2138 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2142 DIE(aTHX_ "panic: pp_subst");
2145 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2146 maxiters = 2 * slen + 10; /* We can match twice at each
2147 position, once with zero-length,
2148 second time with non-zero. */
2150 if (!RX_PRELEN(rx) && PL_curpm) {
2154 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2155 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2156 ? REXEC_COPY_STR : 0;
2158 r_flags |= REXEC_SCREAM;
2161 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2163 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2167 /* How to do it in subst? */
2168 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2170 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2171 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2172 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2173 && (r_flags & REXEC_SCREAM))))
2178 /* only replace once? */
2179 once = !(rpm->op_pmflags & PMf_GLOBAL);
2180 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2181 r_flags | REXEC_CHECKED);
2182 /* known replacement string? */
2184 /* replacement needing upgrading? */
2185 if (DO_UTF8(TARG) && !doutf8) {
2186 nsv = sv_newmortal();
2189 sv_recode_to_utf8(nsv, PL_encoding);
2191 sv_utf8_upgrade(nsv);
2192 c = SvPV_const(nsv, clen);
2196 c = SvPV_const(dstr, clen);
2197 doutf8 = DO_UTF8(dstr);
2205 /* can do inplace substitution? */
2207 #ifdef PERL_OLD_COPY_ON_WRITE
2210 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2211 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2212 && (!doutf8 || SvUTF8(TARG))) {
2217 LEAVE_SCOPE(oldsave);
2220 #ifdef PERL_OLD_COPY_ON_WRITE
2221 if (SvIsCOW(TARG)) {
2222 assert (!force_on_match);
2226 if (force_on_match) {
2228 s = SvPV_force(TARG, len);
2233 SvSCREAM_off(TARG); /* disable possible screamer */
2235 rxtainted |= RX_MATCH_TAINTED(rx);
2236 m = orig + RX_OFFS(rx)[0].start;
2237 d = orig + RX_OFFS(rx)[0].end;
2239 if (m - s > strend - d) { /* faster to shorten from end */
2241 Copy(c, m, clen, char);
2246 Move(d, m, i, char);
2250 SvCUR_set(TARG, m - s);
2252 else if ((i = m - s)) { /* faster from front */
2255 Move(s, d - i, i, char);
2258 Copy(c, m, clen, char);
2263 Copy(c, d, clen, char);
2268 TAINT_IF(rxtainted & 1);
2274 if (iters++ > maxiters)
2275 DIE(aTHX_ "Substitution loop");
2276 rxtainted |= RX_MATCH_TAINTED(rx);
2277 m = RX_OFFS(rx)[0].start + orig;
2280 Move(s, d, i, char);
2284 Copy(c, d, clen, char);
2287 s = RX_OFFS(rx)[0].end + orig;
2288 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2290 /* don't match same null twice */
2291 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2294 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2295 Move(s, d, i+1, char); /* include the NUL */
2297 TAINT_IF(rxtainted & 1);
2301 (void)SvPOK_only_UTF8(TARG);
2302 TAINT_IF(rxtainted);
2303 if (SvSMAGICAL(TARG)) {
2311 LEAVE_SCOPE(oldsave);
2317 if (force_on_match) {
2319 s = SvPV_force(TARG, len);
2322 #ifdef PERL_OLD_COPY_ON_WRITE
2325 rxtainted |= RX_MATCH_TAINTED(rx);
2326 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2330 register PERL_CONTEXT *cx;
2333 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2335 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2337 if (iters++ > maxiters)
2338 DIE(aTHX_ "Substitution loop");
2339 rxtainted |= RX_MATCH_TAINTED(rx);
2340 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2343 orig = RX_SUBBEG(rx);
2345 strend = s + (strend - m);
2347 m = RX_OFFS(rx)[0].start + orig;
2348 if (doutf8 && !SvUTF8(dstr))
2349 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2351 sv_catpvn(dstr, s, m-s);
2352 s = RX_OFFS(rx)[0].end + orig;
2354 sv_catpvn(dstr, c, clen);
2357 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2358 TARG, NULL, r_flags));
2359 if (doutf8 && !DO_UTF8(TARG))
2360 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2362 sv_catpvn(dstr, s, strend - s);
2364 #ifdef PERL_OLD_COPY_ON_WRITE
2365 /* The match may make the string COW. If so, brilliant, because that's
2366 just saved us one malloc, copy and free - the regexp has donated
2367 the old buffer, and we malloc an entirely new one, rather than the
2368 regexp malloc()ing a buffer and copying our original, only for
2369 us to throw it away here during the substitution. */
2370 if (SvIsCOW(TARG)) {
2371 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2377 SvPV_set(TARG, SvPVX(dstr));
2378 SvCUR_set(TARG, SvCUR(dstr));
2379 SvLEN_set(TARG, SvLEN(dstr));
2380 doutf8 |= DO_UTF8(dstr);
2381 SvPV_set(dstr, NULL);
2383 TAINT_IF(rxtainted & 1);
2387 (void)SvPOK_only(TARG);
2390 TAINT_IF(rxtainted);
2393 LEAVE_SCOPE(oldsave);
2402 LEAVE_SCOPE(oldsave);
2411 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2412 ++*PL_markstack_ptr;
2413 LEAVE_with_name("grep_item"); /* exit inner scope */
2416 if (PL_stack_base + *PL_markstack_ptr > SP) {
2418 const I32 gimme = GIMME_V;
2420 LEAVE_with_name("grep"); /* exit outer scope */
2421 (void)POPMARK; /* pop src */
2422 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2423 (void)POPMARK; /* pop dst */
2424 SP = PL_stack_base + POPMARK; /* pop original mark */
2425 if (gimme == G_SCALAR) {
2426 if (PL_op->op_private & OPpGREP_LEX) {
2427 SV* const sv = sv_newmortal();
2428 sv_setiv(sv, items);
2436 else if (gimme == G_ARRAY)
2443 ENTER_with_name("grep_item"); /* enter inner scope */
2446 src = PL_stack_base[*PL_markstack_ptr];
2448 if (PL_op->op_private & OPpGREP_LEX)
2449 PAD_SVl(PL_op->op_targ) = src;
2453 RETURNOP(cLOGOP->op_other);
2464 register PERL_CONTEXT *cx;
2467 if (CxMULTICALL(&cxstack[cxstack_ix]))
2471 cxstack_ix++; /* temporarily protect top context */
2474 if (gimme == G_SCALAR) {
2477 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2479 *MARK = SvREFCNT_inc(TOPs);
2484 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2486 *MARK = sv_mortalcopy(sv);
2491 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2495 *MARK = &PL_sv_undef;
2499 else if (gimme == G_ARRAY) {
2500 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2501 if (!SvTEMP(*MARK)) {
2502 *MARK = sv_mortalcopy(*MARK);
2503 TAINT_NOT; /* Each item is independent */
2511 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2512 PL_curpm = newpm; /* ... and pop $1 et al */
2515 return cx->blk_sub.retop;
2518 /* This duplicates the above code because the above code must not
2519 * get any slower by more conditions */
2527 register PERL_CONTEXT *cx;
2530 if (CxMULTICALL(&cxstack[cxstack_ix]))
2534 cxstack_ix++; /* temporarily protect top context */
2538 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2539 /* We are an argument to a function or grep().
2540 * This kind of lvalueness was legal before lvalue
2541 * subroutines too, so be backward compatible:
2542 * cannot report errors. */
2544 /* Scalar context *is* possible, on the LHS of -> only,
2545 * as in f()->meth(). But this is not an lvalue. */
2546 if (gimme == G_SCALAR)
2548 if (gimme == G_ARRAY) {
2549 if (!CvLVALUE(cx->blk_sub.cv))
2550 goto temporise_array;
2551 EXTEND_MORTAL(SP - newsp);
2552 for (mark = newsp + 1; mark <= SP; mark++) {
2555 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2556 *mark = sv_mortalcopy(*mark);
2558 /* Can be a localized value subject to deletion. */
2559 PL_tmps_stack[++PL_tmps_ix] = *mark;
2560 SvREFCNT_inc_void(*mark);
2565 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2566 /* Here we go for robustness, not for speed, so we change all
2567 * the refcounts so the caller gets a live guy. Cannot set
2568 * TEMP, so sv_2mortal is out of question. */
2569 if (!CvLVALUE(cx->blk_sub.cv)) {
2575 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2577 if (gimme == G_SCALAR) {
2581 /* Temporaries are bad unless they happen to be elements
2582 * of a tied hash or array */
2583 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2584 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2590 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2591 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2592 : "a readonly value" : "a temporary");
2594 else { /* Can be a localized value
2595 * subject to deletion. */
2596 PL_tmps_stack[++PL_tmps_ix] = *mark;
2597 SvREFCNT_inc_void(*mark);
2600 else { /* Should not happen? */
2606 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2607 (MARK > SP ? "Empty array" : "Array"));
2611 else if (gimme == G_ARRAY) {
2612 EXTEND_MORTAL(SP - newsp);
2613 for (mark = newsp + 1; mark <= SP; mark++) {
2614 if (*mark != &PL_sv_undef
2615 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2616 /* Might be flattened array after $#array = */
2623 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2624 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2627 /* Can be a localized value subject to deletion. */
2628 PL_tmps_stack[++PL_tmps_ix] = *mark;
2629 SvREFCNT_inc_void(*mark);
2635 if (gimme == G_SCALAR) {
2639 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2641 *MARK = SvREFCNT_inc(TOPs);
2646 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2648 *MARK = sv_mortalcopy(sv);
2653 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2657 *MARK = &PL_sv_undef;
2661 else if (gimme == G_ARRAY) {
2663 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2664 if (!SvTEMP(*MARK)) {
2665 *MARK = sv_mortalcopy(*MARK);
2666 TAINT_NOT; /* Each item is independent */
2675 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2676 PL_curpm = newpm; /* ... and pop $1 et al */
2679 return cx->blk_sub.retop;
2687 register PERL_CONTEXT *cx;
2689 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2692 DIE(aTHX_ "Not a CODE reference");
2693 switch (SvTYPE(sv)) {
2694 /* This is overwhelming the most common case: */
2696 if (!isGV_with_GP(sv))
2697 DIE(aTHX_ "Not a CODE reference");
2698 if (!(cv = GvCVu((const GV *)sv))) {
2700 cv = sv_2cv(sv, &stash, &gv, 0);
2712 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2714 SP = PL_stack_base + POPMARK;
2717 if (SvGMAGICAL(sv)) {
2722 sym = SvPVX_const(sv);
2730 sym = SvPV_const(sv, len);
2733 DIE(aTHX_ PL_no_usym, "a subroutine");
2734 if (PL_op->op_private & HINT_STRICT_REFS)
2735 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2736 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2741 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2742 tryAMAGICunDEREF(to_cv);
2744 cv = MUTABLE_CV(SvRV(sv));
2745 if (SvTYPE(cv) == SVt_PVCV)
2750 DIE(aTHX_ "Not a CODE reference");
2751 /* This is the second most common case: */
2753 cv = MUTABLE_CV(sv);
2761 if (!CvROOT(cv) && !CvXSUB(cv)) {
2765 /* anonymous or undef'd function leaves us no recourse */
2766 if (CvANON(cv) || !(gv = CvGV(cv)))
2767 DIE(aTHX_ "Undefined subroutine called");
2769 /* autoloaded stub? */
2770 if (cv != GvCV(gv)) {
2773 /* should call AUTOLOAD now? */
2776 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2783 sub_name = sv_newmortal();
2784 gv_efullname3(sub_name, gv, NULL);
2785 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2789 DIE(aTHX_ "Not a CODE reference");
2794 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2795 Perl_get_db_sub(aTHX_ &sv, cv);
2797 PL_curcopdb = PL_curcop;
2799 /* check for lsub that handles lvalue subroutines */
2800 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2801 /* if lsub not found then fall back to DB::sub */
2802 if (!cv) cv = GvCV(PL_DBsub);
2804 cv = GvCV(PL_DBsub);
2807 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2808 DIE(aTHX_ "No DB::sub routine defined");
2811 if (!(CvISXSUB(cv))) {
2812 /* This path taken at least 75% of the time */
2814 register I32 items = SP - MARK;
2815 AV* const padlist = CvPADLIST(cv);
2816 PUSHBLOCK(cx, CXt_SUB, MARK);
2818 cx->blk_sub.retop = PL_op->op_next;
2820 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2821 * that eval'' ops within this sub know the correct lexical space.
2822 * Owing the speed considerations, we choose instead to search for
2823 * the cv using find_runcv() when calling doeval().
2825 if (CvDEPTH(cv) >= 2) {
2826 PERL_STACK_OVERFLOW_CHECK();
2827 pad_push(padlist, CvDEPTH(cv));
2830 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2832 AV *const av = MUTABLE_AV(PAD_SVl(0));
2834 /* @_ is normally not REAL--this should only ever
2835 * happen when DB::sub() calls things that modify @_ */
2840 cx->blk_sub.savearray = GvAV(PL_defgv);
2841 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2842 CX_CURPAD_SAVE(cx->blk_sub);
2843 cx->blk_sub.argarray = av;
2846 if (items > AvMAX(av) + 1) {
2847 SV **ary = AvALLOC(av);
2848 if (AvARRAY(av) != ary) {
2849 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2852 if (items > AvMAX(av) + 1) {
2853 AvMAX(av) = items - 1;
2854 Renew(ary,items,SV*);
2859 Copy(MARK,AvARRAY(av),items,SV*);
2860 AvFILLp(av) = items - 1;
2868 /* warning must come *after* we fully set up the context
2869 * stuff so that __WARN__ handlers can safely dounwind()
2872 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2873 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2874 sub_crush_depth(cv);
2875 RETURNOP(CvSTART(cv));
2878 I32 markix = TOPMARK;
2883 /* Need to copy @_ to stack. Alternative may be to
2884 * switch stack to @_, and copy return values
2885 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2886 AV * const av = GvAV(PL_defgv);
2887 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2890 /* Mark is at the end of the stack. */
2892 Copy(AvARRAY(av), SP + 1, items, SV*);
2897 /* We assume first XSUB in &DB::sub is the called one. */
2899 SAVEVPTR(PL_curcop);
2900 PL_curcop = PL_curcopdb;
2903 /* Do we need to open block here? XXXX */
2905 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2907 CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
2909 /* Enforce some sanity in scalar context. */
2910 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2911 if (markix > PL_stack_sp - PL_stack_base)
2912 *(PL_stack_base + markix) = &PL_sv_undef;
2914 *(PL_stack_base + markix) = *PL_stack_sp;
2915 PL_stack_sp = PL_stack_base + markix;
2923 Perl_sub_crush_depth(pTHX_ CV *cv)
2925 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2928 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2930 SV* const tmpstr = sv_newmortal();
2931 gv_efullname3(tmpstr, CvGV(cv), NULL);
2932 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2941 SV* const elemsv = POPs;
2942 IV elem = SvIV(elemsv);
2943 AV *const av = MUTABLE_AV(POPs);
2944 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2945 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2946 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2947 bool preeminent = TRUE;
2950 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2951 Perl_warner(aTHX_ packWARN(WARN_MISC),
2952 "Use of reference \"%"SVf"\" as array index",
2955 elem -= CopARYBASE_get(PL_curcop);
2956 if (SvTYPE(av) != SVt_PVAV)
2963 /* If we can determine whether the element exist,
2964 * Try to preserve the existenceness of a tied array
2965 * element by using EXISTS and DELETE if possible.
2966 * Fallback to FETCH and STORE otherwise. */
2967 if (SvCANEXISTDELETE(av))
2968 preeminent = av_exists(av, elem);
2971 svp = av_fetch(av, elem, lval && !defer);
2973 #ifdef PERL_MALLOC_WRAP
2974 if (SvUOK(elemsv)) {
2975 const UV uv = SvUV(elemsv);
2976 elem = uv > IV_MAX ? IV_MAX : uv;
2978 else if (SvNOK(elemsv))
2979 elem = (IV)SvNV(elemsv);
2981 static const char oom_array_extend[] =
2982 "Out of memory during array extend"; /* Duplicated in av.c */
2983 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2986 if (!svp || *svp == &PL_sv_undef) {
2989 DIE(aTHX_ PL_no_aelem, elem);
2990 lv = sv_newmortal();
2991 sv_upgrade(lv, SVt_PVLV);
2993 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2994 LvTARG(lv) = SvREFCNT_inc_simple(av);
2995 LvTARGOFF(lv) = elem;
3002 save_aelem(av, elem, svp);
3004 SAVEADELETE(av, elem);
3006 else if (PL_op->op_private & OPpDEREF)
3007 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3009 sv = (svp ? *svp : &PL_sv_undef);
3010 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3017 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3019 PERL_ARGS_ASSERT_VIVIFY_REF;
3024 Perl_croak(aTHX_ "%s", PL_no_modify);
3025 prepare_SV_for_RV(sv);
3028 SvRV_set(sv, newSV(0));
3031 SvRV_set(sv, MUTABLE_SV(newAV()));
3034 SvRV_set(sv, MUTABLE_SV(newHV()));
3045 SV* const sv = TOPs;
3048 SV* const rsv = SvRV(sv);
3049 if (SvTYPE(rsv) == SVt_PVCV) {
3055 SETs(method_common(sv, NULL));
3062 SV* const sv = cSVOP_sv;
3063 U32 hash = SvSHARED_HASH(sv);
3065 XPUSHs(method_common(sv, &hash));
3070 S_method_common(pTHX_ SV* meth, U32* hashp)
3076 const char* packname = NULL;
3079 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3081 PERL_ARGS_ASSERT_METHOD_COMMON;
3084 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3089 ob = MUTABLE_SV(SvRV(sv));
3093 /* this isn't a reference */
3094 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3095 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3097 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3104 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3105 !(ob=MUTABLE_SV(GvIO(iogv))))
3107 /* this isn't the name of a filehandle either */
3109 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3110 ? !isIDFIRST_utf8((U8*)packname)
3111 : !isIDFIRST(*packname)
3114 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3116 SvOK(sv) ? "without a package or object reference"
3117 : "on an undefined value");
3119 /* assume it's a package name */
3120 stash = gv_stashpvn(packname, packlen, 0);
3124 SV* const ref = newSViv(PTR2IV(stash));
3125 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3129 /* it _is_ a filehandle name -- replace with a reference */
3130 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3133 /* if we got here, ob should be a reference or a glob */
3134 if (!ob || !(SvOBJECT(ob)
3135 || (SvTYPE(ob) == SVt_PVGV
3137 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3140 const char * const name = SvPV_nolen_const(meth);
3141 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3142 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3146 stash = SvSTASH(ob);
3149 /* NOTE: stash may be null, hope hv_fetch_ent and
3150 gv_fetchmethod can cope (it seems they can) */
3152 /* shortcut for simple names */
3154 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3156 gv = MUTABLE_GV(HeVAL(he));
3157 if (isGV(gv) && GvCV(gv) &&
3158 (!GvCVGEN(gv) || GvCVGEN(gv)
3159 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3160 return MUTABLE_SV(GvCV(gv));
3164 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3165 SvPV_nolen_const(meth),
3166 GV_AUTOLOAD | GV_CROAK);
3170 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3175 * c-indentation-style: bsd
3177 * indent-tabs-mode: t
3180 * ex: set ts=8 sts=4 sw=4 noet: