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) && SvROK(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;
825 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
828 if (SvTYPE(sv) != type)
829 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
830 if (PL_op->op_flags & OPf_REF) {
835 if (gimme != G_ARRAY)
836 goto croak_cant_return;
840 else if (PL_op->op_flags & OPf_MOD
841 && PL_op->op_private & OPpLVAL_INTRO)
842 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
845 if (SvTYPE(sv) == type) {
846 if (PL_op->op_flags & OPf_REF) {
851 if (gimme != G_ARRAY)
852 goto croak_cant_return;
860 if (!isGV_with_GP(sv)) {
861 if (SvGMAGICAL(sv)) {
866 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
874 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
875 if (PL_op->op_private & OPpLVAL_INTRO)
876 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
877 if (PL_op->op_flags & OPf_REF) {
882 if (gimme != G_ARRAY)
883 goto croak_cant_return;
891 AV *const av = MUTABLE_AV(sv);
892 /* The guts of pp_rv2av, with no intenting change to preserve history
893 (until such time as we get tools that can do blame annotation across
894 whitespace changes. */
895 if (gimme == G_ARRAY) {
896 const I32 maxarg = AvFILL(av) + 1;
897 (void)POPs; /* XXXX May be optimized away? */
899 if (SvRMAGICAL(av)) {
901 for (i=0; i < (U32)maxarg; i++) {
902 SV ** const svp = av_fetch(av, i, FALSE);
903 /* See note in pp_helem, and bug id #27839 */
905 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
910 Copy(AvARRAY(av), SP+1, maxarg, SV*);
914 else if (gimme == G_SCALAR) {
916 const I32 maxarg = AvFILL(av) + 1;
920 /* The guts of pp_rv2hv */
921 if (gimme == G_ARRAY) { /* array wanted */
925 else if (gimme == G_SCALAR) {
927 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
935 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
936 is_pp_rv2av ? "array" : "hash");
941 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
945 PERL_ARGS_ASSERT_DO_ODDBALL;
951 if (ckWARN(WARN_MISC)) {
953 if (relem == firstrelem &&
955 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
956 SvTYPE(SvRV(*relem)) == SVt_PVHV))
958 err = "Reference found where even-sized list expected";
961 err = "Odd number of elements in hash assignment";
962 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
966 didstore = hv_store_ent(hash,*relem,tmpstr,0);
967 if (SvMAGICAL(hash)) {
968 if (SvSMAGICAL(tmpstr))
980 SV **lastlelem = PL_stack_sp;
981 SV **lastrelem = PL_stack_base + POPMARK;
982 SV **firstrelem = PL_stack_base + POPMARK + 1;
983 SV **firstlelem = lastrelem + 1;
996 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
998 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1001 /* If there's a common identifier on both sides we have to take
1002 * special care that assigning the identifier on the left doesn't
1003 * clobber a value on the right that's used later in the list.
1005 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1006 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1007 for (relem = firstrelem; relem <= lastrelem; relem++) {
1008 if ((sv = *relem)) {
1009 TAINT_NOT; /* Each item is independent */
1011 /* Dear TODO test in t/op/sort.t, I love you.
1012 (It's relying on a panic, not a "semi-panic" from newSVsv()
1013 and then an assertion failure below.) */
1014 if (SvIS_FREED(sv)) {
1015 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1018 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1019 and we need a second copy of a temp here. */
1020 *relem = sv_2mortal(newSVsv(sv));
1030 while (lelem <= lastlelem) {
1031 TAINT_NOT; /* Each item stands on its own, taintwise. */
1033 switch (SvTYPE(sv)) {
1035 ary = MUTABLE_AV(sv);
1036 magic = SvMAGICAL(ary) != 0;
1038 av_extend(ary, lastrelem - relem);
1040 while (relem <= lastrelem) { /* gobble up all the rest */
1044 sv_setsv(sv, *relem);
1046 didstore = av_store(ary,i++,sv);
1048 if (SvSMAGICAL(sv)) {
1049 /* More magic can happen in the mg_set callback, so we
1050 * backup the delaymagic for now. */
1051 U16 dmbak = PL_delaymagic;
1054 PL_delaymagic = dmbak;
1061 if (PL_delaymagic & DM_ARRAY)
1062 SvSETMAGIC(MUTABLE_SV(ary));
1064 case SVt_PVHV: { /* normal hash */
1067 hash = MUTABLE_HV(sv);
1068 magic = SvMAGICAL(hash) != 0;
1070 firsthashrelem = relem;
1072 while (relem < lastrelem) { /* gobble up all the rest */
1074 sv = *relem ? *relem : &PL_sv_no;
1078 sv_setsv(tmpstr,*relem); /* value */
1079 *(relem++) = tmpstr;
1080 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1081 /* key overwrites an existing entry */
1083 didstore = hv_store_ent(hash,sv,tmpstr,0);
1085 if (SvSMAGICAL(tmpstr)) {
1086 U16 dmbak = PL_delaymagic;
1089 PL_delaymagic = dmbak;
1096 if (relem == lastrelem) {
1097 do_oddball(hash, relem, firstrelem);
1103 if (SvIMMORTAL(sv)) {
1104 if (relem <= lastrelem)
1108 if (relem <= lastrelem) {
1109 sv_setsv(sv, *relem);
1113 sv_setsv(sv, &PL_sv_undef);
1115 if (SvSMAGICAL(sv)) {
1116 U16 dmbak = PL_delaymagic;
1119 PL_delaymagic = dmbak;
1124 if (PL_delaymagic & ~DM_DELAY) {
1125 if (PL_delaymagic & DM_UID) {
1126 #ifdef HAS_SETRESUID
1127 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1128 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1131 # ifdef HAS_SETREUID
1132 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1133 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1136 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1137 (void)setruid(PL_uid);
1138 PL_delaymagic &= ~DM_RUID;
1140 # endif /* HAS_SETRUID */
1142 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1143 (void)seteuid(PL_euid);
1144 PL_delaymagic &= ~DM_EUID;
1146 # endif /* HAS_SETEUID */
1147 if (PL_delaymagic & DM_UID) {
1148 if (PL_uid != PL_euid)
1149 DIE(aTHX_ "No setreuid available");
1150 (void)PerlProc_setuid(PL_uid);
1152 # endif /* HAS_SETREUID */
1153 #endif /* HAS_SETRESUID */
1154 PL_uid = PerlProc_getuid();
1155 PL_euid = PerlProc_geteuid();
1157 if (PL_delaymagic & DM_GID) {
1158 #ifdef HAS_SETRESGID
1159 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1160 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1163 # ifdef HAS_SETREGID
1164 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1165 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1168 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1169 (void)setrgid(PL_gid);
1170 PL_delaymagic &= ~DM_RGID;
1172 # endif /* HAS_SETRGID */
1174 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1175 (void)setegid(PL_egid);
1176 PL_delaymagic &= ~DM_EGID;
1178 # endif /* HAS_SETEGID */
1179 if (PL_delaymagic & DM_GID) {
1180 if (PL_gid != PL_egid)
1181 DIE(aTHX_ "No setregid available");
1182 (void)PerlProc_setgid(PL_gid);
1184 # endif /* HAS_SETREGID */
1185 #endif /* HAS_SETRESGID */
1186 PL_gid = PerlProc_getgid();
1187 PL_egid = PerlProc_getegid();
1189 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1193 if (gimme == G_VOID)
1194 SP = firstrelem - 1;
1195 else if (gimme == G_SCALAR) {
1198 SETi(lastrelem - firstrelem + 1 - duplicates);
1205 /* Removes from the stack the entries which ended up as
1206 * duplicated keys in the hash (fix for [perl #24380]) */
1207 Move(firsthashrelem + duplicates,
1208 firsthashrelem, duplicates, SV**);
1209 lastrelem -= duplicates;
1214 SP = firstrelem + (lastlelem - firstlelem);
1215 lelem = firstlelem + (relem - firstrelem);
1217 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1226 register PMOP * const pm = cPMOP;
1227 REGEXP * rx = PM_GETRE(pm);
1228 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1229 SV * const rv = sv_newmortal();
1231 SvUPGRADE(rv, SVt_IV);
1232 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1233 loathe to use it here, but it seems to be the right fix. Or close.
1234 The key part appears to be that it's essential for pp_qr to return a new
1235 object (SV), which implies that there needs to be an effective way to
1236 generate a new SV from the existing SV that is pre-compiled in the
1238 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1242 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1244 (void)sv_bless(rv, stash);
1247 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1256 register PMOP *pm = cPMOP;
1258 register const char *t;
1259 register const char *s;
1262 U8 r_flags = REXEC_CHECKED;
1263 const char *truebase; /* Start of string */
1264 register REGEXP *rx = PM_GETRE(pm);
1266 const I32 gimme = GIMME;
1269 const I32 oldsave = PL_savestack_ix;
1270 I32 update_minmatch = 1;
1271 I32 had_zerolen = 0;
1274 if (PL_op->op_flags & OPf_STACKED)
1276 else if (PL_op->op_private & OPpTARGET_MY)
1283 PUTBACK; /* EVAL blocks need stack_sp. */
1284 /* Skip get-magic if this is a qr// clone, because regcomp has
1286 s = ((struct regexp *)SvANY(rx))->mother_re
1287 ? SvPV_nomg_const(TARG, len)
1288 : SvPV_const(TARG, len);
1290 DIE(aTHX_ "panic: pp_match");
1292 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1293 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1296 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1298 /* PMdf_USED is set after a ?? matches once */
1301 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1303 pm->op_pmflags & PMf_USED
1307 if (gimme == G_ARRAY)
1314 /* empty pattern special-cased to use last successful pattern if possible */
1315 if (!RX_PRELEN(rx) && PL_curpm) {
1320 if (RX_MINLEN(rx) > (I32)len)
1325 /* XXXX What part of this is needed with true \G-support? */
1326 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1327 RX_OFFS(rx)[0].start = -1;
1328 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1329 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1330 if (mg && mg->mg_len >= 0) {
1331 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1332 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1333 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1334 r_flags |= REXEC_IGNOREPOS;
1335 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1336 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1339 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1340 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1341 update_minmatch = 0;
1345 /* XXX: comment out !global get safe $1 vars after a
1346 match, BUT be aware that this leads to dramatic slowdowns on
1347 /g matches against large strings. So far a solution to this problem
1348 appears to be quite tricky.
1349 Test for the unsafe vars are TODO for now. */
1350 if (( !global && RX_NPARENS(rx))
1351 || SvTEMP(TARG) || PL_sawampersand ||
1352 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1353 r_flags |= REXEC_COPY_STR;
1355 r_flags |= REXEC_SCREAM;
1358 if (global && RX_OFFS(rx)[0].start != -1) {
1359 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1360 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1362 if (update_minmatch++)
1363 minmatch = had_zerolen;
1365 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1366 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1367 /* FIXME - can PL_bostr be made const char *? */
1368 PL_bostr = (char *)truebase;
1369 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1373 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1375 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1376 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1377 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1378 && (r_flags & REXEC_SCREAM)))
1379 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1382 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1383 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1386 if (dynpm->op_pmflags & PMf_ONCE) {
1388 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1390 dynpm->op_pmflags |= PMf_USED;
1401 RX_MATCH_TAINTED_on(rx);
1402 TAINT_IF(RX_MATCH_TAINTED(rx));
1403 if (gimme == G_ARRAY) {
1404 const I32 nparens = RX_NPARENS(rx);
1405 I32 i = (global && !nparens) ? 1 : 0;
1407 SPAGAIN; /* EVAL blocks could move the stack. */
1408 EXTEND(SP, nparens + i);
1409 EXTEND_MORTAL(nparens + i);
1410 for (i = !i; i <= nparens; i++) {
1411 PUSHs(sv_newmortal());
1412 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1413 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1414 s = RX_OFFS(rx)[i].start + truebase;
1415 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1416 len < 0 || len > strend - s)
1417 DIE(aTHX_ "panic: pp_match start/end pointers");
1418 sv_setpvn(*SP, s, len);
1419 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1424 if (dynpm->op_pmflags & PMf_CONTINUE) {
1426 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1427 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1429 #ifdef PERL_OLD_COPY_ON_WRITE
1431 sv_force_normal_flags(TARG, 0);
1433 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1434 &PL_vtbl_mglob, NULL, 0);
1436 if (RX_OFFS(rx)[0].start != -1) {
1437 mg->mg_len = RX_OFFS(rx)[0].end;
1438 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1439 mg->mg_flags |= MGf_MINMATCH;
1441 mg->mg_flags &= ~MGf_MINMATCH;
1444 had_zerolen = (RX_OFFS(rx)[0].start != -1
1445 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1446 == (UV)RX_OFFS(rx)[0].end));
1447 PUTBACK; /* EVAL blocks may use stack */
1448 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1453 LEAVE_SCOPE(oldsave);
1459 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1460 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1464 #ifdef PERL_OLD_COPY_ON_WRITE
1466 sv_force_normal_flags(TARG, 0);
1468 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1469 &PL_vtbl_mglob, NULL, 0);
1471 if (RX_OFFS(rx)[0].start != -1) {
1472 mg->mg_len = RX_OFFS(rx)[0].end;
1473 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1474 mg->mg_flags |= MGf_MINMATCH;
1476 mg->mg_flags &= ~MGf_MINMATCH;
1479 LEAVE_SCOPE(oldsave);
1483 yup: /* Confirmed by INTUIT */
1485 RX_MATCH_TAINTED_on(rx);
1486 TAINT_IF(RX_MATCH_TAINTED(rx));
1488 if (dynpm->op_pmflags & PMf_ONCE) {
1490 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1492 dynpm->op_pmflags |= PMf_USED;
1495 if (RX_MATCH_COPIED(rx))
1496 Safefree(RX_SUBBEG(rx));
1497 RX_MATCH_COPIED_off(rx);
1498 RX_SUBBEG(rx) = NULL;
1500 /* FIXME - should rx->subbeg be const char *? */
1501 RX_SUBBEG(rx) = (char *) truebase;
1502 RX_OFFS(rx)[0].start = s - truebase;
1503 if (RX_MATCH_UTF8(rx)) {
1504 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1505 RX_OFFS(rx)[0].end = t - truebase;
1508 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1510 RX_SUBLEN(rx) = strend - truebase;
1513 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1515 #ifdef PERL_OLD_COPY_ON_WRITE
1516 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1518 PerlIO_printf(Perl_debug_log,
1519 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1520 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1523 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1525 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1526 assert (SvPOKp(RX_SAVED_COPY(rx)));
1531 RX_SUBBEG(rx) = savepvn(t, strend - t);
1532 #ifdef PERL_OLD_COPY_ON_WRITE
1533 RX_SAVED_COPY(rx) = NULL;
1536 RX_SUBLEN(rx) = strend - t;
1537 RX_MATCH_COPIED_on(rx);
1538 off = RX_OFFS(rx)[0].start = s - t;
1539 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1541 else { /* startp/endp are used by @- @+. */
1542 RX_OFFS(rx)[0].start = s - truebase;
1543 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1545 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1547 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1548 LEAVE_SCOPE(oldsave);
1553 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1554 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1555 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1560 LEAVE_SCOPE(oldsave);
1561 if (gimme == G_ARRAY)
1567 Perl_do_readline(pTHX)
1569 dVAR; dSP; dTARGETSTACKED;
1574 register IO * const io = GvIO(PL_last_in_gv);
1575 register const I32 type = PL_op->op_type;
1576 const I32 gimme = GIMME_V;
1579 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1582 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1584 ENTER_with_name("call_READLINE");
1585 call_method("READLINE", gimme);
1586 LEAVE_with_name("call_READLINE");
1588 if (gimme == G_SCALAR) {
1589 SV* const result = POPs;
1590 SvSetSV_nosteal(TARG, result);
1600 if (IoFLAGS(io) & IOf_ARGV) {
1601 if (IoFLAGS(io) & IOf_START) {
1603 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1604 IoFLAGS(io) &= ~IOf_START;
1605 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1606 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1607 SvSETMAGIC(GvSV(PL_last_in_gv));
1612 fp = nextargv(PL_last_in_gv);
1613 if (!fp) { /* Note: fp != IoIFP(io) */
1614 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1617 else if (type == OP_GLOB)
1618 fp = Perl_start_glob(aTHX_ POPs, io);
1620 else if (type == OP_GLOB)
1622 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1623 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1627 if ((!io || !(IoFLAGS(io) & IOf_START))
1628 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1630 if (type == OP_GLOB)
1631 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1632 "glob failed (can't start child: %s)",
1635 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1637 if (gimme == G_SCALAR) {
1638 /* undef TARG, and push that undefined value */
1639 if (type != OP_RCATLINE) {
1640 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1648 if (gimme == G_SCALAR) {
1650 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1653 if (type == OP_RCATLINE)
1654 SvPV_force_nolen(sv);
1658 else if (isGV_with_GP(sv)) {
1659 SvPV_force_nolen(sv);
1661 SvUPGRADE(sv, SVt_PV);
1662 tmplen = SvLEN(sv); /* remember if already alloced */
1663 if (!tmplen && !SvREADONLY(sv))
1664 Sv_Grow(sv, 80); /* try short-buffering it */
1666 if (type == OP_RCATLINE && SvOK(sv)) {
1668 SvPV_force_nolen(sv);
1674 sv = sv_2mortal(newSV(80));
1678 /* This should not be marked tainted if the fp is marked clean */
1679 #define MAYBE_TAINT_LINE(io, sv) \
1680 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1685 /* delay EOF state for a snarfed empty file */
1686 #define SNARF_EOF(gimme,rs,io,sv) \
1687 (gimme != G_SCALAR || SvCUR(sv) \
1688 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1692 if (!sv_gets(sv, fp, offset)
1694 || SNARF_EOF(gimme, PL_rs, io, sv)
1695 || PerlIO_error(fp)))
1697 PerlIO_clearerr(fp);
1698 if (IoFLAGS(io) & IOf_ARGV) {
1699 fp = nextargv(PL_last_in_gv);
1702 (void)do_close(PL_last_in_gv, FALSE);
1704 else if (type == OP_GLOB) {
1705 if (!do_close(PL_last_in_gv, FALSE)) {
1706 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1707 "glob failed (child exited with status %d%s)",
1708 (int)(STATUS_CURRENT >> 8),
1709 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1712 if (gimme == G_SCALAR) {
1713 if (type != OP_RCATLINE) {
1714 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1720 MAYBE_TAINT_LINE(io, sv);
1723 MAYBE_TAINT_LINE(io, sv);
1725 IoFLAGS(io) |= IOf_NOLINE;
1729 if (type == OP_GLOB) {
1732 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1733 char * const tmps = SvEND(sv) - 1;
1734 if (*tmps == *SvPVX_const(PL_rs)) {
1736 SvCUR_set(sv, SvCUR(sv) - 1);
1739 for (t1 = SvPVX_const(sv); *t1; t1++)
1740 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1741 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1743 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1744 (void)POPs; /* Unmatched wildcard? Chuck it... */
1747 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1748 if (ckWARN(WARN_UTF8)) {
1749 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1750 const STRLEN len = SvCUR(sv) - offset;
1753 if (!is_utf8_string_loc(s, len, &f))
1754 /* Emulate :encoding(utf8) warning in the same case. */
1755 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1756 "utf8 \"\\x%02X\" does not map to Unicode",
1757 f < (U8*)SvEND(sv) ? *f : 0);
1760 if (gimme == G_ARRAY) {
1761 if (SvLEN(sv) - SvCUR(sv) > 20) {
1762 SvPV_shrink_to_cur(sv);
1764 sv = sv_2mortal(newSV(80));
1767 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1768 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1769 const STRLEN new_len
1770 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1771 SvPV_renew(sv, new_len);
1780 register PERL_CONTEXT *cx;
1781 I32 gimme = OP_GIMME(PL_op, -1);
1784 if (cxstack_ix >= 0) {
1785 /* If this flag is set, we're just inside a return, so we should
1786 * store the caller's context */
1787 gimme = (PL_op->op_flags & OPf_SPECIAL)
1789 : cxstack[cxstack_ix].blk_gimme;
1794 ENTER_with_name("block");
1797 PUSHBLOCK(cx, CXt_BLOCK, SP);
1807 SV * const keysv = POPs;
1808 HV * const hv = MUTABLE_HV(POPs);
1809 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1810 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1812 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1813 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1814 bool preeminent = TRUE;
1816 if (SvTYPE(hv) != SVt_PVHV)
1823 /* If we can determine whether the element exist,
1824 * Try to preserve the existenceness of a tied hash
1825 * element by using EXISTS and DELETE if possible.
1826 * Fallback to FETCH and STORE otherwise. */
1827 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1828 preeminent = hv_exists_ent(hv, keysv, 0);
1831 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1832 svp = he ? &HeVAL(he) : NULL;
1834 if (!svp || *svp == &PL_sv_undef) {
1838 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1840 lv = sv_newmortal();
1841 sv_upgrade(lv, SVt_PVLV);
1843 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1844 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1845 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1851 if (HvNAME_get(hv) && isGV(*svp))
1852 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1853 else if (preeminent)
1854 save_helem_flags(hv, keysv, svp,
1855 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1857 SAVEHDELETE(hv, keysv);
1859 else if (PL_op->op_private & OPpDEREF)
1860 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1862 sv = (svp ? *svp : &PL_sv_undef);
1863 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1864 * was to make C<local $tied{foo} = $tied{foo}> possible.
1865 * However, it seems no longer to be needed for that purpose, and
1866 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1867 * would loop endlessly since the pos magic is getting set on the
1868 * mortal copy and lost. However, the copy has the effect of
1869 * triggering the get magic, and losing it altogether made things like
1870 * c<$tied{foo};> in void context no longer do get magic, which some
1871 * code relied on. Also, delayed triggering of magic on @+ and friends
1872 * meant the original regex may be out of scope by now. So as a
1873 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1874 * being called too many times). */
1875 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1884 register PERL_CONTEXT *cx;
1889 if (PL_op->op_flags & OPf_SPECIAL) {
1890 cx = &cxstack[cxstack_ix];
1891 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1896 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1899 if (gimme == G_VOID)
1901 else if (gimme == G_SCALAR) {
1905 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1908 *MARK = sv_mortalcopy(TOPs);
1911 *MARK = &PL_sv_undef;
1915 else if (gimme == G_ARRAY) {
1916 /* in case LEAVE wipes old return values */
1918 for (mark = newsp + 1; mark <= SP; mark++) {
1919 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1920 *mark = sv_mortalcopy(*mark);
1921 TAINT_NOT; /* Each item is independent */
1925 PL_curpm = newpm; /* Don't pop $1 et al till now */
1927 LEAVE_with_name("block");
1935 register PERL_CONTEXT *cx;
1938 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1939 bool av_is_stack = FALSE;
1942 cx = &cxstack[cxstack_ix];
1943 if (!CxTYPE_is_LOOP(cx))
1944 DIE(aTHX_ "panic: pp_iter");
1946 itersvp = CxITERVAR(cx);
1947 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1948 /* string increment */
1949 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1950 SV *end = cx->blk_loop.state_u.lazysv.end;
1951 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1952 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1954 const char *max = SvPV_const(end, maxlen);
1955 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1956 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1957 /* safe to reuse old SV */
1958 sv_setsv(*itersvp, cur);
1962 /* we need a fresh SV every time so that loop body sees a
1963 * completely new SV for closures/references to work as
1966 *itersvp = newSVsv(cur);
1967 SvREFCNT_dec(oldsv);
1969 if (strEQ(SvPVX_const(cur), max))
1970 sv_setiv(cur, 0); /* terminate next time */
1977 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1978 /* integer increment */
1979 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1982 /* don't risk potential race */
1983 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1984 /* safe to reuse old SV */
1985 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1989 /* we need a fresh SV every time so that loop body sees a
1990 * completely new SV for closures/references to work as they
1993 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1994 SvREFCNT_dec(oldsv);
1997 /* Handle end of range at IV_MAX */
1998 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1999 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2001 cx->blk_loop.state_u.lazyiv.cur++;
2002 cx->blk_loop.state_u.lazyiv.end++;
2009 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2010 av = cx->blk_loop.state_u.ary.ary;
2015 if (PL_op->op_private & OPpITER_REVERSED) {
2016 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2017 ? cx->blk_loop.resetsp + 1 : 0))
2020 if (SvMAGICAL(av) || AvREIFY(av)) {
2021 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2022 sv = svp ? *svp : NULL;
2025 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2029 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2033 if (SvMAGICAL(av) || AvREIFY(av)) {
2034 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2035 sv = svp ? *svp : NULL;
2038 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2042 if (sv && SvIS_FREED(sv)) {
2044 Perl_croak(aTHX_ "Use of freed value in iteration");
2049 SvREFCNT_inc_simple_void_NN(sv);
2053 if (!av_is_stack && sv == &PL_sv_undef) {
2054 SV *lv = newSV_type(SVt_PVLV);
2056 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2057 LvTARG(lv) = SvREFCNT_inc_simple(av);
2058 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2059 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2065 SvREFCNT_dec(oldsv);
2073 register PMOP *pm = cPMOP;
2088 register REGEXP *rx = PM_GETRE(pm);
2090 int force_on_match = 0;
2091 const I32 oldsave = PL_savestack_ix;
2093 bool doutf8 = FALSE;
2095 #ifdef PERL_OLD_COPY_ON_WRITE
2099 /* known replacement string? */
2100 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2104 if (PL_op->op_flags & OPf_STACKED)
2106 else if (PL_op->op_private & OPpTARGET_MY)
2113 #ifdef PERL_OLD_COPY_ON_WRITE
2114 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2115 because they make integers such as 256 "false". */
2116 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2119 sv_force_normal_flags(TARG,0);
2122 #ifdef PERL_OLD_COPY_ON_WRITE
2126 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2127 || SvTYPE(TARG) > SVt_PVLV)
2128 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2129 DIE(aTHX_ "%s", PL_no_modify);
2133 s = SvPV_mutable(TARG, len);
2134 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2136 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2137 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2142 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2146 DIE(aTHX_ "panic: pp_subst");
2149 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2150 maxiters = 2 * slen + 10; /* We can match twice at each
2151 position, once with zero-length,
2152 second time with non-zero. */
2154 if (!RX_PRELEN(rx) && PL_curpm) {
2158 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2159 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2160 ? REXEC_COPY_STR : 0;
2162 r_flags |= REXEC_SCREAM;
2165 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2167 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2171 /* How to do it in subst? */
2172 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2174 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2175 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2176 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2177 && (r_flags & REXEC_SCREAM))))
2182 /* only replace once? */
2183 once = !(rpm->op_pmflags & PMf_GLOBAL);
2184 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2185 r_flags | REXEC_CHECKED);
2186 /* known replacement string? */
2189 /* Upgrade the source if the replacement is utf8 but the source is not,
2190 * but only if it matched; see
2191 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2193 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2194 const STRLEN new_len = sv_utf8_upgrade(TARG);
2196 /* If the lengths are the same, the pattern contains only
2197 * invariants, can keep going; otherwise, various internal markers
2198 * could be off, so redo */
2199 if (new_len != len) {
2204 /* replacement needing upgrading? */
2205 if (DO_UTF8(TARG) && !doutf8) {
2206 nsv = sv_newmortal();
2209 sv_recode_to_utf8(nsv, PL_encoding);
2211 sv_utf8_upgrade(nsv);
2212 c = SvPV_const(nsv, clen);
2216 c = SvPV_const(dstr, clen);
2217 doutf8 = DO_UTF8(dstr);
2225 /* can do inplace substitution? */
2227 #ifdef PERL_OLD_COPY_ON_WRITE
2230 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2231 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2232 && (!doutf8 || SvUTF8(TARG))) {
2237 LEAVE_SCOPE(oldsave);
2240 #ifdef PERL_OLD_COPY_ON_WRITE
2241 if (SvIsCOW(TARG)) {
2242 assert (!force_on_match);
2246 if (force_on_match) {
2248 s = SvPV_force(TARG, len);
2253 SvSCREAM_off(TARG); /* disable possible screamer */
2255 rxtainted |= RX_MATCH_TAINTED(rx);
2256 m = orig + RX_OFFS(rx)[0].start;
2257 d = orig + RX_OFFS(rx)[0].end;
2259 if (m - s > strend - d) { /* faster to shorten from end */
2261 Copy(c, m, clen, char);
2266 Move(d, m, i, char);
2270 SvCUR_set(TARG, m - s);
2272 else if ((i = m - s)) { /* faster from front */
2275 Move(s, d - i, i, char);
2278 Copy(c, m, clen, char);
2283 Copy(c, d, clen, char);
2288 TAINT_IF(rxtainted & 1);
2294 if (iters++ > maxiters)
2295 DIE(aTHX_ "Substitution loop");
2296 rxtainted |= RX_MATCH_TAINTED(rx);
2297 m = RX_OFFS(rx)[0].start + orig;
2300 Move(s, d, i, char);
2304 Copy(c, d, clen, char);
2307 s = RX_OFFS(rx)[0].end + orig;
2308 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2310 /* don't match same null twice */
2311 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2314 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2315 Move(s, d, i+1, char); /* include the NUL */
2317 TAINT_IF(rxtainted & 1);
2321 (void)SvPOK_only_UTF8(TARG);
2322 TAINT_IF(rxtainted);
2323 if (SvSMAGICAL(TARG)) {
2331 LEAVE_SCOPE(oldsave);
2337 if (force_on_match) {
2339 s = SvPV_force(TARG, len);
2342 #ifdef PERL_OLD_COPY_ON_WRITE
2345 rxtainted |= RX_MATCH_TAINTED(rx);
2346 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2350 register PERL_CONTEXT *cx;
2353 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2355 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2357 if (iters++ > maxiters)
2358 DIE(aTHX_ "Substitution loop");
2359 rxtainted |= RX_MATCH_TAINTED(rx);
2360 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2363 orig = RX_SUBBEG(rx);
2365 strend = s + (strend - m);
2367 m = RX_OFFS(rx)[0].start + orig;
2368 if (doutf8 && !SvUTF8(dstr))
2369 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2371 sv_catpvn(dstr, s, m-s);
2372 s = RX_OFFS(rx)[0].end + orig;
2374 sv_catpvn(dstr, c, clen);
2377 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2378 TARG, NULL, r_flags));
2379 if (doutf8 && !DO_UTF8(TARG))
2380 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2382 sv_catpvn(dstr, s, strend - s);
2384 #ifdef PERL_OLD_COPY_ON_WRITE
2385 /* The match may make the string COW. If so, brilliant, because that's
2386 just saved us one malloc, copy and free - the regexp has donated
2387 the old buffer, and we malloc an entirely new one, rather than the
2388 regexp malloc()ing a buffer and copying our original, only for
2389 us to throw it away here during the substitution. */
2390 if (SvIsCOW(TARG)) {
2391 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2397 SvPV_set(TARG, SvPVX(dstr));
2398 SvCUR_set(TARG, SvCUR(dstr));
2399 SvLEN_set(TARG, SvLEN(dstr));
2400 doutf8 |= DO_UTF8(dstr);
2401 SvPV_set(dstr, NULL);
2403 TAINT_IF(rxtainted & 1);
2407 (void)SvPOK_only(TARG);
2410 TAINT_IF(rxtainted);
2413 LEAVE_SCOPE(oldsave);
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);
2732 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2734 SP = PL_stack_base + POPMARK;
2737 if (SvGMAGICAL(sv)) {
2742 sym = SvPVX_const(sv);
2750 sym = SvPV_const(sv, len);
2753 DIE(aTHX_ PL_no_usym, "a subroutine");
2754 if (PL_op->op_private & HINT_STRICT_REFS)
2755 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2756 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2761 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2762 tryAMAGICunDEREF(to_cv);
2764 cv = MUTABLE_CV(SvRV(sv));
2765 if (SvTYPE(cv) == SVt_PVCV)
2770 DIE(aTHX_ "Not a CODE reference");
2771 /* This is the second most common case: */
2773 cv = MUTABLE_CV(sv);
2781 if (!CvROOT(cv) && !CvXSUB(cv)) {
2785 /* anonymous or undef'd function leaves us no recourse */
2786 if (CvANON(cv) || !(gv = CvGV(cv)))
2787 DIE(aTHX_ "Undefined subroutine called");
2789 /* autoloaded stub? */
2790 if (cv != GvCV(gv)) {
2793 /* should call AUTOLOAD now? */
2796 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2803 sub_name = sv_newmortal();
2804 gv_efullname3(sub_name, gv, NULL);
2805 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2809 DIE(aTHX_ "Not a CODE reference");
2814 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2815 Perl_get_db_sub(aTHX_ &sv, cv);
2817 PL_curcopdb = PL_curcop;
2819 /* check for lsub that handles lvalue subroutines */
2820 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2821 /* if lsub not found then fall back to DB::sub */
2822 if (!cv) cv = GvCV(PL_DBsub);
2824 cv = GvCV(PL_DBsub);
2827 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2828 DIE(aTHX_ "No DB::sub routine defined");
2831 if (!(CvISXSUB(cv))) {
2832 /* This path taken at least 75% of the time */
2834 register I32 items = SP - MARK;
2835 AV* const padlist = CvPADLIST(cv);
2836 PUSHBLOCK(cx, CXt_SUB, MARK);
2838 cx->blk_sub.retop = PL_op->op_next;
2840 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2841 * that eval'' ops within this sub know the correct lexical space.
2842 * Owing the speed considerations, we choose instead to search for
2843 * the cv using find_runcv() when calling doeval().
2845 if (CvDEPTH(cv) >= 2) {
2846 PERL_STACK_OVERFLOW_CHECK();
2847 pad_push(padlist, CvDEPTH(cv));
2850 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2852 AV *const av = MUTABLE_AV(PAD_SVl(0));
2854 /* @_ is normally not REAL--this should only ever
2855 * happen when DB::sub() calls things that modify @_ */
2860 cx->blk_sub.savearray = GvAV(PL_defgv);
2861 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2862 CX_CURPAD_SAVE(cx->blk_sub);
2863 cx->blk_sub.argarray = av;
2866 if (items > AvMAX(av) + 1) {
2867 SV **ary = AvALLOC(av);
2868 if (AvARRAY(av) != ary) {
2869 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2872 if (items > AvMAX(av) + 1) {
2873 AvMAX(av) = items - 1;
2874 Renew(ary,items,SV*);
2879 Copy(MARK,AvARRAY(av),items,SV*);
2880 AvFILLp(av) = items - 1;
2888 /* warning must come *after* we fully set up the context
2889 * stuff so that __WARN__ handlers can safely dounwind()
2892 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2893 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2894 sub_crush_depth(cv);
2895 RETURNOP(CvSTART(cv));
2898 I32 markix = TOPMARK;
2903 /* Need to copy @_ to stack. Alternative may be to
2904 * switch stack to @_, and copy return values
2905 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2906 AV * const av = GvAV(PL_defgv);
2907 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2910 /* Mark is at the end of the stack. */
2912 Copy(AvARRAY(av), SP + 1, items, SV*);
2917 /* We assume first XSUB in &DB::sub is the called one. */
2919 SAVEVPTR(PL_curcop);
2920 PL_curcop = PL_curcopdb;
2923 /* Do we need to open block here? XXXX */
2925 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2927 CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
2929 /* Enforce some sanity in scalar context. */
2930 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2931 if (markix > PL_stack_sp - PL_stack_base)
2932 *(PL_stack_base + markix) = &PL_sv_undef;
2934 *(PL_stack_base + markix) = *PL_stack_sp;
2935 PL_stack_sp = PL_stack_base + markix;
2943 Perl_sub_crush_depth(pTHX_ CV *cv)
2945 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2948 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2950 SV* const tmpstr = sv_newmortal();
2951 gv_efullname3(tmpstr, CvGV(cv), NULL);
2952 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2961 SV* const elemsv = POPs;
2962 IV elem = SvIV(elemsv);
2963 AV *const av = MUTABLE_AV(POPs);
2964 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2965 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2966 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2967 bool preeminent = TRUE;
2970 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2971 Perl_warner(aTHX_ packWARN(WARN_MISC),
2972 "Use of reference \"%"SVf"\" as array index",
2975 elem -= CopARYBASE_get(PL_curcop);
2976 if (SvTYPE(av) != SVt_PVAV)
2983 /* If we can determine whether the element exist,
2984 * Try to preserve the existenceness of a tied array
2985 * element by using EXISTS and DELETE if possible.
2986 * Fallback to FETCH and STORE otherwise. */
2987 if (SvCANEXISTDELETE(av))
2988 preeminent = av_exists(av, elem);
2991 svp = av_fetch(av, elem, lval && !defer);
2993 #ifdef PERL_MALLOC_WRAP
2994 if (SvUOK(elemsv)) {
2995 const UV uv = SvUV(elemsv);
2996 elem = uv > IV_MAX ? IV_MAX : uv;
2998 else if (SvNOK(elemsv))
2999 elem = (IV)SvNV(elemsv);
3001 static const char oom_array_extend[] =
3002 "Out of memory during array extend"; /* Duplicated in av.c */
3003 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3006 if (!svp || *svp == &PL_sv_undef) {
3009 DIE(aTHX_ PL_no_aelem, elem);
3010 lv = sv_newmortal();
3011 sv_upgrade(lv, SVt_PVLV);
3013 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3014 LvTARG(lv) = SvREFCNT_inc_simple(av);
3015 LvTARGOFF(lv) = elem;
3022 save_aelem(av, elem, svp);
3024 SAVEADELETE(av, elem);
3026 else if (PL_op->op_private & OPpDEREF)
3027 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3029 sv = (svp ? *svp : &PL_sv_undef);
3030 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3037 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3039 PERL_ARGS_ASSERT_VIVIFY_REF;
3044 Perl_croak(aTHX_ "%s", PL_no_modify);
3045 prepare_SV_for_RV(sv);
3048 SvRV_set(sv, newSV(0));
3051 SvRV_set(sv, MUTABLE_SV(newAV()));
3054 SvRV_set(sv, MUTABLE_SV(newHV()));
3065 SV* const sv = TOPs;
3068 SV* const rsv = SvRV(sv);
3069 if (SvTYPE(rsv) == SVt_PVCV) {
3075 SETs(method_common(sv, NULL));
3082 SV* const sv = cSVOP_sv;
3083 U32 hash = SvSHARED_HASH(sv);
3085 XPUSHs(method_common(sv, &hash));
3090 S_method_common(pTHX_ SV* meth, U32* hashp)
3096 const char* packname = NULL;
3099 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3101 PERL_ARGS_ASSERT_METHOD_COMMON;
3104 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3109 ob = MUTABLE_SV(SvRV(sv));
3113 /* this isn't a reference */
3114 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3115 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3117 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3124 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3125 !(ob=MUTABLE_SV(GvIO(iogv))))
3127 /* this isn't the name of a filehandle either */
3129 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3130 ? !isIDFIRST_utf8((U8*)packname)
3131 : !isIDFIRST(*packname)
3134 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3136 SvOK(sv) ? "without a package or object reference"
3137 : "on an undefined value");
3139 /* assume it's a package name */
3140 stash = gv_stashpvn(packname, packlen, 0);
3144 SV* const ref = newSViv(PTR2IV(stash));
3145 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3149 /* it _is_ a filehandle name -- replace with a reference */
3150 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3153 /* if we got here, ob should be a reference or a glob */
3154 if (!ob || !(SvOBJECT(ob)
3155 || (SvTYPE(ob) == SVt_PVGV
3157 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3160 const char * const name = SvPV_nolen_const(meth);
3161 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3162 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3166 stash = SvSTASH(ob);
3169 /* NOTE: stash may be null, hope hv_fetch_ent and
3170 gv_fetchmethod can cope (it seems they can) */
3172 /* shortcut for simple names */
3174 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3176 gv = MUTABLE_GV(HeVAL(he));
3177 if (isGV(gv) && GvCV(gv) &&
3178 (!GvCVGEN(gv) || GvCVGEN(gv)
3179 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3180 return MUTABLE_SV(GvCV(gv));
3184 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3185 SvPV_nolen_const(meth),
3186 GV_AUTOLOAD | GV_CROAK);
3190 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3195 * c-indentation-style: bsd
3197 * indent-tabs-mode: t
3200 * ex: set ts=8 sts=4 sw=4 noet: