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;
117 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
118 SV * const temp = left;
119 left = right; right = temp;
121 if (PL_tainting && PL_tainted && !SvTAINTED(left))
123 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
124 SV * const cv = SvRV(left);
125 const U32 cv_type = SvTYPE(cv);
126 const U32 gv_type = SvTYPE(right);
127 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
133 /* Can do the optimisation if right (LVALUE) is not a typeglob,
134 left (RVALUE) is a reference to something, and we're in void
136 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
137 /* Is the target symbol table currently empty? */
138 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
139 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
140 /* Good. Create a new proxy constant subroutine in the target.
141 The gv becomes a(nother) reference to the constant. */
142 SV *const value = SvRV(cv);
144 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
145 SvPCS_IMPORTED_on(gv);
147 SvREFCNT_inc_simple_void(value);
153 /* Need to fix things up. */
154 if (gv_type != SVt_PVGV) {
155 /* Need to fix GV. */
156 right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
160 /* We've been returned a constant rather than a full subroutine,
161 but they expect a subroutine reference to apply. */
163 ENTER_with_name("sassign_coderef");
164 SvREFCNT_inc_void(SvRV(cv));
165 /* newCONSTSUB takes a reference count on the passed in SV
166 from us. We set the name to NULL, otherwise we get into
167 all sorts of fun as the reference to our new sub is
168 donated to the GV that we're about to assign to.
170 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
173 LEAVE_with_name("sassign_coderef");
175 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
177 First: ops for \&{"BONK"}; return us the constant in the
179 Second: ops for *{"BONK"} cause that symbol table entry
180 (and our reference to it) to be upgraded from RV
182 Thirdly: We get here. cv is actually PVGV now, and its
183 GvCV() is actually the subroutine we're looking for
185 So change the reference so that it points to the subroutine
186 of that typeglob, as that's what they were after all along.
188 GV *const upgraded = MUTABLE_GV(cv);
189 CV *const source = GvCV(upgraded);
192 assert(CvFLAGS(source) & CVf_CONST);
194 SvREFCNT_inc_void(source);
195 SvREFCNT_dec(upgraded);
196 SvRV_set(left, MUTABLE_SV(source));
201 /* Allow glob assignments like *$x = ..., which, when the glob has a
202 SVf_FAKE flag, cannot be distinguished from $x = ... without looking
204 if( SvTYPE(right) == SVt_PVGV && cBINOP->op_last->op_type == OP_RV2GV
205 && (wasfake = SvFLAGS(right) & SVf_FAKE) )
206 SvFLAGS(right) &= ~SVf_FAKE;
207 SvSetMagicSV(right, left);
208 if(wasfake) SvFLAGS(right) |= SVf_FAKE;
218 RETURNOP(cLOGOP->op_other);
220 RETURNOP(cLOGOP->op_next);
228 TAINT_NOT; /* Each statement is presumed innocent */
229 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
231 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
238 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
243 const char *rpv = NULL;
245 bool rcopied = FALSE;
247 if (TARG == right && right != left) { /* $r = $l.$r */
248 rpv = SvPV_nomg_const(right, rlen);
249 rbyte = !DO_UTF8(right);
250 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
251 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
255 if (TARG != left) { /* not $l .= $r */
257 const char* const lpv = SvPV_nomg_const(left, llen);
258 lbyte = !DO_UTF8(left);
259 sv_setpvn(TARG, lpv, llen);
265 else { /* $l .= $r */
267 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
268 report_uninit(right);
271 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
272 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
279 /* $r.$r: do magic twice: tied might return different 2nd time */
281 rpv = SvPV_nomg_const(right, rlen);
282 rbyte = !DO_UTF8(right);
284 if (lbyte != rbyte) {
286 sv_utf8_upgrade_nomg(TARG);
289 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
290 sv_utf8_upgrade_nomg(right);
291 rpv = SvPV_nomg_const(right, rlen);
294 sv_catpvn_nomg(TARG, rpv, rlen);
305 if (PL_op->op_flags & OPf_MOD) {
306 if (PL_op->op_private & OPpLVAL_INTRO)
307 if (!(PL_op->op_private & OPpPAD_STATE))
308 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
309 if (PL_op->op_private & OPpDEREF) {
311 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
321 tryAMAGICunTARGET(iter, 0);
322 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
323 if (!isGV_with_GP(PL_last_in_gv)) {
324 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
325 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
328 XPUSHs(MUTABLE_SV(PL_last_in_gv));
331 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
334 return do_readline();
340 tryAMAGICbin_MG(eq_amg, AMGf_set);
341 #ifndef NV_PRESERVES_UV
342 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
344 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
348 #ifdef PERL_PRESERVE_IVUV
349 SvIV_please_nomg(TOPs);
351 /* Unless the left argument is integer in range we are going
352 to have to use NV maths. Hence only attempt to coerce the
353 right argument if we know the left is integer. */
354 SvIV_please_nomg(TOPm1s);
356 const bool auvok = SvUOK(TOPm1s);
357 const bool buvok = SvUOK(TOPs);
359 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
360 /* Casting IV to UV before comparison isn't going to matter
361 on 2s complement. On 1s complement or sign&magnitude
362 (if we have any of them) it could to make negative zero
363 differ from normal zero. As I understand it. (Need to
364 check - is negative zero implementation defined behaviour
366 const UV buv = SvUVX(POPs);
367 const UV auv = SvUVX(TOPs);
369 SETs(boolSV(auv == buv));
372 { /* ## Mixed IV,UV ## */
376 /* == is commutative so doesn't matter which is left or right */
378 /* top of stack (b) is the iv */
387 /* As uv is a UV, it's >0, so it cannot be == */
390 /* we know iv is >= 0 */
391 SETs(boolSV((UV)iv == SvUVX(uvp)));
398 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
400 if (Perl_isnan(left) || Perl_isnan(right))
402 SETs(boolSV(left == right));
405 SETs(boolSV(SvNV_nomg(TOPs) == value));
414 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
415 Perl_croak_no_modify(aTHX);
416 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
417 && SvIVX(TOPs) != IV_MAX)
419 SvIV_set(TOPs, SvIVX(TOPs) + 1);
420 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
422 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
435 if (PL_op->op_type == OP_OR)
437 RETURNOP(cLOGOP->op_other);
446 const int op_type = PL_op->op_type;
447 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
452 if (!sv || !SvANY(sv)) {
453 if (op_type == OP_DOR)
455 RETURNOP(cLOGOP->op_other);
461 if (!sv || !SvANY(sv))
466 switch (SvTYPE(sv)) {
468 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
472 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
476 if (CvROOT(sv) || CvXSUB(sv))
489 if(op_type == OP_DOR)
491 RETURNOP(cLOGOP->op_other);
493 /* assuming OP_DEFINED */
501 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
502 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
506 useleft = USE_LEFT(svl);
507 #ifdef PERL_PRESERVE_IVUV
508 /* We must see if we can perform the addition with integers if possible,
509 as the integer code detects overflow while the NV code doesn't.
510 If either argument hasn't had a numeric conversion yet attempt to get
511 the IV. It's important to do this now, rather than just assuming that
512 it's not IOK as a PV of "9223372036854775806" may not take well to NV
513 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
514 integer in case the second argument is IV=9223372036854775806
515 We can (now) rely on sv_2iv to do the right thing, only setting the
516 public IOK flag if the value in the NV (or PV) slot is truly integer.
518 A side effect is that this also aggressively prefers integer maths over
519 fp maths for integer values.
521 How to detect overflow?
523 C 99 section 6.2.6.1 says
525 The range of nonnegative values of a signed integer type is a subrange
526 of the corresponding unsigned integer type, and the representation of
527 the same value in each type is the same. A computation involving
528 unsigned operands can never overflow, because a result that cannot be
529 represented by the resulting unsigned integer type is reduced modulo
530 the number that is one greater than the largest value that can be
531 represented by the resulting type.
535 which I read as "unsigned ints wrap."
537 signed integer overflow seems to be classed as "exception condition"
539 If an exceptional condition occurs during the evaluation of an
540 expression (that is, if the result is not mathematically defined or not
541 in the range of representable values for its type), the behavior is
544 (6.5, the 5th paragraph)
546 I had assumed that on 2s complement machines signed arithmetic would
547 wrap, hence coded pp_add and pp_subtract on the assumption that
548 everything perl builds on would be happy. After much wailing and
549 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
550 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
551 unsigned code below is actually shorter than the old code. :-)
554 SvIV_please_nomg(svr);
557 /* Unless the left argument is integer in range we are going to have to
558 use NV maths. Hence only attempt to coerce the right argument if
559 we know the left is integer. */
567 /* left operand is undef, treat as zero. + 0 is identity,
568 Could SETi or SETu right now, but space optimise by not adding
569 lots of code to speed up what is probably a rarish case. */
571 /* Left operand is defined, so is it IV? */
572 SvIV_please_nomg(svl);
574 if ((auvok = SvUOK(svl)))
577 register const IV aiv = SvIVX(svl);
580 auvok = 1; /* Now acting as a sign flag. */
581 } else { /* 2s complement assumption for IV_MIN */
589 bool result_good = 0;
592 bool buvok = SvUOK(svr);
597 register const IV biv = SvIVX(svr);
604 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
605 else "IV" now, independent of how it came in.
606 if a, b represents positive, A, B negative, a maps to -A etc
611 all UV maths. negate result if A negative.
612 add if signs same, subtract if signs differ. */
618 /* Must get smaller */
624 /* result really should be -(auv-buv). as its negation
625 of true value, need to swap our result flag */
642 if (result <= (UV)IV_MIN)
645 /* result valid, but out of range for IV. */
650 } /* Overflow, drop through to NVs. */
655 NV value = SvNV_nomg(svr);
658 /* left operand is undef, treat as zero. + 0.0 is identity. */
662 SETn( value + SvNV_nomg(svl) );
670 AV * const av = PL_op->op_flags & OPf_SPECIAL
671 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
672 const U32 lval = PL_op->op_flags & OPf_MOD;
673 SV** const svp = av_fetch(av, PL_op->op_private, lval);
674 SV *sv = (svp ? *svp : &PL_sv_undef);
676 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
684 dVAR; dSP; dMARK; dTARGET;
686 do_join(TARG, *MARK, MARK, SP);
697 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
698 * will be enough to hold an OP*.
700 SV* const sv = sv_newmortal();
701 sv_upgrade(sv, SVt_PVLV);
703 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
706 XPUSHs(MUTABLE_SV(PL_op));
711 /* Oversized hot code. */
715 dVAR; dSP; dMARK; dORIGMARK;
720 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
722 if (gv && (io = GvIO(gv))
723 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
726 if (MARK == ORIGMARK) {
727 /* If using default handle then we need to make space to
728 * pass object as 1st arg, so move other args up ...
732 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
736 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
738 ENTER_with_name("call_PRINT");
739 if( PL_op->op_type == OP_SAY ) {
740 /* local $\ = "\n" */
741 SAVEGENERICSV(PL_ors_sv);
742 PL_ors_sv = newSVpvs("\n");
744 call_method("PRINT", G_SCALAR);
745 LEAVE_with_name("call_PRINT");
752 if (!(io = GvIO(gv))) {
753 if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
754 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
756 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
757 report_evil_fh(gv, io, PL_op->op_type);
758 SETERRNO(EBADF,RMS_IFI);
761 else if (!(fp = IoOFP(io))) {
762 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
764 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
765 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
766 report_evil_fh(gv, io, PL_op->op_type);
768 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
772 SV * const ofs = GvSV(PL_ofsgv); /* $, */
774 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
776 if (!do_print(*MARK, fp))
780 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
781 if (!do_print(GvSV(PL_ofsgv), fp)) {
790 if (!do_print(*MARK, fp))
798 if (PL_op->op_type == OP_SAY) {
799 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
802 else if (PL_ors_sv && SvOK(PL_ors_sv))
803 if (!do_print(PL_ors_sv, fp)) /* $\ */
806 if (IoFLAGS(io) & IOf_FLUSH)
807 if (PerlIO_flush(fp) == EOF)
817 XPUSHs(&PL_sv_undef);
824 const I32 gimme = GIMME_V;
825 static const char an_array[] = "an ARRAY";
826 static const char a_hash[] = "a HASH";
827 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
828 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
830 if (!(PL_op->op_private & OPpDEREFed))
833 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
836 if (SvTYPE(sv) != type)
837 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
838 if (PL_op->op_flags & OPf_REF) {
843 if (gimme != G_ARRAY)
844 goto croak_cant_return;
848 else if (PL_op->op_flags & OPf_MOD
849 && PL_op->op_private & OPpLVAL_INTRO)
850 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
853 if (SvTYPE(sv) == type) {
854 if (PL_op->op_flags & OPf_REF) {
859 if (gimme != G_ARRAY)
860 goto croak_cant_return;
868 if (!isGV_with_GP(sv)) {
869 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
877 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
878 if (PL_op->op_private & OPpLVAL_INTRO)
879 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
880 if (PL_op->op_flags & OPf_REF) {
885 if (gimme != G_ARRAY)
886 goto croak_cant_return;
894 AV *const av = MUTABLE_AV(sv);
895 /* The guts of pp_rv2av, with no intenting change to preserve history
896 (until such time as we get tools that can do blame annotation across
897 whitespace changes. */
898 if (gimme == G_ARRAY) {
899 const I32 maxarg = AvFILL(av) + 1;
900 (void)POPs; /* XXXX May be optimized away? */
902 if (SvRMAGICAL(av)) {
904 for (i=0; i < (U32)maxarg; i++) {
905 SV ** const svp = av_fetch(av, i, FALSE);
906 /* See note in pp_helem, and bug id #27839 */
908 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
913 Copy(AvARRAY(av), SP+1, maxarg, SV*);
917 else if (gimme == G_SCALAR) {
919 const I32 maxarg = AvFILL(av) + 1;
923 /* The guts of pp_rv2hv */
924 if (gimme == G_ARRAY) { /* array wanted */
928 else if (gimme == G_SCALAR) {
930 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
938 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
939 is_pp_rv2av ? "array" : "hash");
944 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
948 PERL_ARGS_ASSERT_DO_ODDBALL;
954 if (ckWARN(WARN_MISC)) {
956 if (relem == firstrelem &&
958 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
959 SvTYPE(SvRV(*relem)) == SVt_PVHV))
961 err = "Reference found where even-sized list expected";
964 err = "Odd number of elements in hash assignment";
965 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
969 didstore = hv_store_ent(hash,*relem,tmpstr,0);
970 if (SvMAGICAL(hash)) {
971 if (SvSMAGICAL(tmpstr))
983 SV **lastlelem = PL_stack_sp;
984 SV **lastrelem = PL_stack_base + POPMARK;
985 SV **firstrelem = PL_stack_base + POPMARK + 1;
986 SV **firstlelem = lastrelem + 1;
999 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1001 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1004 /* If there's a common identifier on both sides we have to take
1005 * special care that assigning the identifier on the left doesn't
1006 * clobber a value on the right that's used later in the list.
1008 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1009 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1010 for (relem = firstrelem; relem <= lastrelem; relem++) {
1011 if ((sv = *relem)) {
1012 TAINT_NOT; /* Each item is independent */
1014 /* Dear TODO test in t/op/sort.t, I love you.
1015 (It's relying on a panic, not a "semi-panic" from newSVsv()
1016 and then an assertion failure below.) */
1017 if (SvIS_FREED(sv)) {
1018 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1021 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1022 and we need a second copy of a temp here. */
1023 *relem = sv_2mortal(newSVsv(sv));
1033 while (lelem <= lastlelem) {
1034 TAINT_NOT; /* Each item stands on its own, taintwise. */
1036 switch (SvTYPE(sv)) {
1038 ary = MUTABLE_AV(sv);
1039 magic = SvMAGICAL(ary) != 0;
1041 av_extend(ary, lastrelem - relem);
1043 while (relem <= lastrelem) { /* gobble up all the rest */
1047 sv_setsv(sv, *relem);
1049 didstore = av_store(ary,i++,sv);
1058 if (PL_delaymagic & DM_ARRAY_ISA)
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))
1089 if (relem == lastrelem) {
1090 do_oddball(hash, relem, firstrelem);
1096 if (SvIMMORTAL(sv)) {
1097 if (relem <= lastrelem)
1101 if (relem <= lastrelem) {
1102 sv_setsv(sv, *relem);
1106 sv_setsv(sv, &PL_sv_undef);
1111 if (PL_delaymagic & ~DM_DELAY) {
1112 if (PL_delaymagic & DM_UID) {
1113 #ifdef HAS_SETRESUID
1114 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1115 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1118 # ifdef HAS_SETREUID
1119 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1120 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1123 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1124 (void)setruid(PL_uid);
1125 PL_delaymagic &= ~DM_RUID;
1127 # endif /* HAS_SETRUID */
1129 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1130 (void)seteuid(PL_euid);
1131 PL_delaymagic &= ~DM_EUID;
1133 # endif /* HAS_SETEUID */
1134 if (PL_delaymagic & DM_UID) {
1135 if (PL_uid != PL_euid)
1136 DIE(aTHX_ "No setreuid available");
1137 (void)PerlProc_setuid(PL_uid);
1139 # endif /* HAS_SETREUID */
1140 #endif /* HAS_SETRESUID */
1141 PL_uid = PerlProc_getuid();
1142 PL_euid = PerlProc_geteuid();
1144 if (PL_delaymagic & DM_GID) {
1145 #ifdef HAS_SETRESGID
1146 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1147 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1150 # ifdef HAS_SETREGID
1151 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1152 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1155 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1156 (void)setrgid(PL_gid);
1157 PL_delaymagic &= ~DM_RGID;
1159 # endif /* HAS_SETRGID */
1161 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1162 (void)setegid(PL_egid);
1163 PL_delaymagic &= ~DM_EGID;
1165 # endif /* HAS_SETEGID */
1166 if (PL_delaymagic & DM_GID) {
1167 if (PL_gid != PL_egid)
1168 DIE(aTHX_ "No setregid available");
1169 (void)PerlProc_setgid(PL_gid);
1171 # endif /* HAS_SETREGID */
1172 #endif /* HAS_SETRESGID */
1173 PL_gid = PerlProc_getgid();
1174 PL_egid = PerlProc_getegid();
1176 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1180 if (gimme == G_VOID)
1181 SP = firstrelem - 1;
1182 else if (gimme == G_SCALAR) {
1185 SETi(lastrelem - firstrelem + 1 - duplicates);
1192 /* Removes from the stack the entries which ended up as
1193 * duplicated keys in the hash (fix for [perl #24380]) */
1194 Move(firsthashrelem + duplicates,
1195 firsthashrelem, duplicates, SV**);
1196 lastrelem -= duplicates;
1201 SP = firstrelem + (lastlelem - firstlelem);
1202 lelem = firstlelem + (relem - firstrelem);
1204 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1213 register PMOP * const pm = cPMOP;
1214 REGEXP * rx = PM_GETRE(pm);
1215 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1216 SV * const rv = sv_newmortal();
1218 SvUPGRADE(rv, SVt_IV);
1219 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1220 loathe to use it here, but it seems to be the right fix. Or close.
1221 The key part appears to be that it's essential for pp_qr to return a new
1222 object (SV), which implies that there needs to be an effective way to
1223 generate a new SV from the existing SV that is pre-compiled in the
1225 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1229 HV *const stash = gv_stashsv(pkg, GV_ADD);
1231 (void)sv_bless(rv, stash);
1234 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1243 register PMOP *pm = cPMOP;
1245 register const char *t;
1246 register const char *s;
1249 U8 r_flags = REXEC_CHECKED;
1250 const char *truebase; /* Start of string */
1251 register REGEXP *rx = PM_GETRE(pm);
1253 const I32 gimme = GIMME;
1256 const I32 oldsave = PL_savestack_ix;
1257 I32 update_minmatch = 1;
1258 I32 had_zerolen = 0;
1261 if (PL_op->op_flags & OPf_STACKED)
1263 else if (PL_op->op_private & OPpTARGET_MY)
1270 PUTBACK; /* EVAL blocks need stack_sp. */
1271 /* Skip get-magic if this is a qr// clone, because regcomp has
1273 s = ((struct regexp *)SvANY(rx))->mother_re
1274 ? SvPV_nomg_const(TARG, len)
1275 : SvPV_const(TARG, len);
1277 DIE(aTHX_ "panic: pp_match");
1279 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1280 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1283 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1285 /* PMdf_USED is set after a ?? matches once */
1288 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1290 pm->op_pmflags & PMf_USED
1294 if (gimme == G_ARRAY)
1301 /* empty pattern special-cased to use last successful pattern if possible */
1302 if (!RX_PRELEN(rx) && PL_curpm) {
1307 if (RX_MINLEN(rx) > (I32)len)
1312 /* XXXX What part of this is needed with true \G-support? */
1313 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1314 RX_OFFS(rx)[0].start = -1;
1315 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1316 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1317 if (mg && mg->mg_len >= 0) {
1318 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1319 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1320 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1321 r_flags |= REXEC_IGNOREPOS;
1322 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1323 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1326 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1327 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1328 update_minmatch = 0;
1332 /* XXX: comment out !global get safe $1 vars after a
1333 match, BUT be aware that this leads to dramatic slowdowns on
1334 /g matches against large strings. So far a solution to this problem
1335 appears to be quite tricky.
1336 Test for the unsafe vars are TODO for now. */
1337 if (( !global && RX_NPARENS(rx))
1338 || SvTEMP(TARG) || PL_sawampersand ||
1339 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1340 r_flags |= REXEC_COPY_STR;
1342 r_flags |= REXEC_SCREAM;
1345 if (global && RX_OFFS(rx)[0].start != -1) {
1346 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1347 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1349 if (update_minmatch++)
1350 minmatch = had_zerolen;
1352 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1353 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1354 /* FIXME - can PL_bostr be made const char *? */
1355 PL_bostr = (char *)truebase;
1356 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1360 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1362 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1363 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1364 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1365 && (r_flags & REXEC_SCREAM)))
1366 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1369 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1370 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1373 if (dynpm->op_pmflags & PMf_ONCE) {
1375 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1377 dynpm->op_pmflags |= PMf_USED;
1388 RX_MATCH_TAINTED_on(rx);
1389 TAINT_IF(RX_MATCH_TAINTED(rx));
1390 if (gimme == G_ARRAY) {
1391 const I32 nparens = RX_NPARENS(rx);
1392 I32 i = (global && !nparens) ? 1 : 0;
1394 SPAGAIN; /* EVAL blocks could move the stack. */
1395 EXTEND(SP, nparens + i);
1396 EXTEND_MORTAL(nparens + i);
1397 for (i = !i; i <= nparens; i++) {
1398 PUSHs(sv_newmortal());
1399 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1400 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1401 s = RX_OFFS(rx)[i].start + truebase;
1402 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1403 len < 0 || len > strend - s)
1404 DIE(aTHX_ "panic: pp_match start/end pointers");
1405 sv_setpvn(*SP, s, len);
1406 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1411 if (dynpm->op_pmflags & PMf_CONTINUE) {
1413 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1414 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1416 #ifdef PERL_OLD_COPY_ON_WRITE
1418 sv_force_normal_flags(TARG, 0);
1420 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1421 &PL_vtbl_mglob, NULL, 0);
1423 if (RX_OFFS(rx)[0].start != -1) {
1424 mg->mg_len = RX_OFFS(rx)[0].end;
1425 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1426 mg->mg_flags |= MGf_MINMATCH;
1428 mg->mg_flags &= ~MGf_MINMATCH;
1431 had_zerolen = (RX_OFFS(rx)[0].start != -1
1432 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1433 == (UV)RX_OFFS(rx)[0].end));
1434 PUTBACK; /* EVAL blocks may use stack */
1435 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1440 LEAVE_SCOPE(oldsave);
1446 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1447 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1451 #ifdef PERL_OLD_COPY_ON_WRITE
1453 sv_force_normal_flags(TARG, 0);
1455 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1456 &PL_vtbl_mglob, NULL, 0);
1458 if (RX_OFFS(rx)[0].start != -1) {
1459 mg->mg_len = RX_OFFS(rx)[0].end;
1460 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1461 mg->mg_flags |= MGf_MINMATCH;
1463 mg->mg_flags &= ~MGf_MINMATCH;
1466 LEAVE_SCOPE(oldsave);
1470 yup: /* Confirmed by INTUIT */
1472 RX_MATCH_TAINTED_on(rx);
1473 TAINT_IF(RX_MATCH_TAINTED(rx));
1475 if (dynpm->op_pmflags & PMf_ONCE) {
1477 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1479 dynpm->op_pmflags |= PMf_USED;
1482 if (RX_MATCH_COPIED(rx))
1483 Safefree(RX_SUBBEG(rx));
1484 RX_MATCH_COPIED_off(rx);
1485 RX_SUBBEG(rx) = NULL;
1487 /* FIXME - should rx->subbeg be const char *? */
1488 RX_SUBBEG(rx) = (char *) truebase;
1489 RX_OFFS(rx)[0].start = s - truebase;
1490 if (RX_MATCH_UTF8(rx)) {
1491 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1492 RX_OFFS(rx)[0].end = t - truebase;
1495 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1497 RX_SUBLEN(rx) = strend - truebase;
1500 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1502 #ifdef PERL_OLD_COPY_ON_WRITE
1503 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1505 PerlIO_printf(Perl_debug_log,
1506 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1507 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1510 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1512 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1513 assert (SvPOKp(RX_SAVED_COPY(rx)));
1518 RX_SUBBEG(rx) = savepvn(t, strend - t);
1519 #ifdef PERL_OLD_COPY_ON_WRITE
1520 RX_SAVED_COPY(rx) = NULL;
1523 RX_SUBLEN(rx) = strend - t;
1524 RX_MATCH_COPIED_on(rx);
1525 off = RX_OFFS(rx)[0].start = s - t;
1526 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1528 else { /* startp/endp are used by @- @+. */
1529 RX_OFFS(rx)[0].start = s - truebase;
1530 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1532 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1534 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1535 LEAVE_SCOPE(oldsave);
1540 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1541 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1542 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1547 LEAVE_SCOPE(oldsave);
1548 if (gimme == G_ARRAY)
1554 Perl_do_readline(pTHX)
1556 dVAR; dSP; dTARGETSTACKED;
1561 register IO * const io = GvIO(PL_last_in_gv);
1562 register const I32 type = PL_op->op_type;
1563 const I32 gimme = GIMME_V;
1566 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1569 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1571 ENTER_with_name("call_READLINE");
1572 call_method("READLINE", gimme);
1573 LEAVE_with_name("call_READLINE");
1575 if (gimme == G_SCALAR) {
1576 SV* const result = POPs;
1577 SvSetSV_nosteal(TARG, result);
1587 if (IoFLAGS(io) & IOf_ARGV) {
1588 if (IoFLAGS(io) & IOf_START) {
1590 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1591 IoFLAGS(io) &= ~IOf_START;
1592 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1593 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1594 SvSETMAGIC(GvSV(PL_last_in_gv));
1599 fp = nextargv(PL_last_in_gv);
1600 if (!fp) { /* Note: fp != IoIFP(io) */
1601 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1604 else if (type == OP_GLOB)
1605 fp = Perl_start_glob(aTHX_ POPs, io);
1607 else if (type == OP_GLOB)
1609 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1610 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1614 if ((!io || !(IoFLAGS(io) & IOf_START))
1615 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1617 if (type == OP_GLOB)
1618 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1619 "glob failed (can't start child: %s)",
1622 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1624 if (gimme == G_SCALAR) {
1625 /* undef TARG, and push that undefined value */
1626 if (type != OP_RCATLINE) {
1627 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1635 if (gimme == G_SCALAR) {
1637 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1640 if (type == OP_RCATLINE)
1641 SvPV_force_nolen(sv);
1645 else if (isGV_with_GP(sv)) {
1646 SvPV_force_nolen(sv);
1648 SvUPGRADE(sv, SVt_PV);
1649 tmplen = SvLEN(sv); /* remember if already alloced */
1650 if (!tmplen && !SvREADONLY(sv)) {
1651 /* try short-buffering it. Please update t/op/readline.t
1652 * if you change the growth length.
1657 if (type == OP_RCATLINE && SvOK(sv)) {
1659 SvPV_force_nolen(sv);
1665 sv = sv_2mortal(newSV(80));
1669 /* This should not be marked tainted if the fp is marked clean */
1670 #define MAYBE_TAINT_LINE(io, sv) \
1671 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1676 /* delay EOF state for a snarfed empty file */
1677 #define SNARF_EOF(gimme,rs,io,sv) \
1678 (gimme != G_SCALAR || SvCUR(sv) \
1679 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1683 if (!sv_gets(sv, fp, offset)
1685 || SNARF_EOF(gimme, PL_rs, io, sv)
1686 || PerlIO_error(fp)))
1688 PerlIO_clearerr(fp);
1689 if (IoFLAGS(io) & IOf_ARGV) {
1690 fp = nextargv(PL_last_in_gv);
1693 (void)do_close(PL_last_in_gv, FALSE);
1695 else if (type == OP_GLOB) {
1696 if (!do_close(PL_last_in_gv, FALSE)) {
1697 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1698 "glob failed (child exited with status %d%s)",
1699 (int)(STATUS_CURRENT >> 8),
1700 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1703 if (gimme == G_SCALAR) {
1704 if (type != OP_RCATLINE) {
1705 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1711 MAYBE_TAINT_LINE(io, sv);
1714 MAYBE_TAINT_LINE(io, sv);
1716 IoFLAGS(io) |= IOf_NOLINE;
1720 if (type == OP_GLOB) {
1723 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1724 char * const tmps = SvEND(sv) - 1;
1725 if (*tmps == *SvPVX_const(PL_rs)) {
1727 SvCUR_set(sv, SvCUR(sv) - 1);
1730 for (t1 = SvPVX_const(sv); *t1; t1++)
1731 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1732 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1734 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1735 (void)POPs; /* Unmatched wildcard? Chuck it... */
1738 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1739 if (ckWARN(WARN_UTF8)) {
1740 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1741 const STRLEN len = SvCUR(sv) - offset;
1744 if (!is_utf8_string_loc(s, len, &f))
1745 /* Emulate :encoding(utf8) warning in the same case. */
1746 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1747 "utf8 \"\\x%02X\" does not map to Unicode",
1748 f < (U8*)SvEND(sv) ? *f : 0);
1751 if (gimme == G_ARRAY) {
1752 if (SvLEN(sv) - SvCUR(sv) > 20) {
1753 SvPV_shrink_to_cur(sv);
1755 sv = sv_2mortal(newSV(80));
1758 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1759 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1760 const STRLEN new_len
1761 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1762 SvPV_renew(sv, new_len);
1771 register PERL_CONTEXT *cx;
1772 I32 gimme = OP_GIMME(PL_op, -1);
1775 if (cxstack_ix >= 0) {
1776 /* If this flag is set, we're just inside a return, so we should
1777 * store the caller's context */
1778 gimme = (PL_op->op_flags & OPf_SPECIAL)
1780 : cxstack[cxstack_ix].blk_gimme;
1785 ENTER_with_name("block");
1788 PUSHBLOCK(cx, CXt_BLOCK, SP);
1798 SV * const keysv = POPs;
1799 HV * const hv = MUTABLE_HV(POPs);
1800 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1801 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1803 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1804 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1805 bool preeminent = TRUE;
1807 if (SvTYPE(hv) != SVt_PVHV)
1814 /* If we can determine whether the element exist,
1815 * Try to preserve the existenceness of a tied hash
1816 * element by using EXISTS and DELETE if possible.
1817 * Fallback to FETCH and STORE otherwise. */
1818 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1819 preeminent = hv_exists_ent(hv, keysv, 0);
1822 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1823 svp = he ? &HeVAL(he) : NULL;
1825 if (!svp || *svp == &PL_sv_undef) {
1829 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1831 lv = sv_newmortal();
1832 sv_upgrade(lv, SVt_PVLV);
1834 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1835 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1836 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1842 if (HvNAME_get(hv) && isGV(*svp))
1843 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1844 else if (preeminent)
1845 save_helem_flags(hv, keysv, svp,
1846 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1848 SAVEHDELETE(hv, keysv);
1850 else if (PL_op->op_private & OPpDEREF)
1851 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1853 sv = (svp ? *svp : &PL_sv_undef);
1854 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1855 * was to make C<local $tied{foo} = $tied{foo}> possible.
1856 * However, it seems no longer to be needed for that purpose, and
1857 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1858 * would loop endlessly since the pos magic is getting set on the
1859 * mortal copy and lost. However, the copy has the effect of
1860 * triggering the get magic, and losing it altogether made things like
1861 * c<$tied{foo};> in void context no longer do get magic, which some
1862 * code relied on. Also, delayed triggering of magic on @+ and friends
1863 * meant the original regex may be out of scope by now. So as a
1864 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1865 * being called too many times). */
1866 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1875 register PERL_CONTEXT *cx;
1880 if (PL_op->op_flags & OPf_SPECIAL) {
1881 cx = &cxstack[cxstack_ix];
1882 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1887 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1890 if (gimme == G_VOID)
1892 else if (gimme == G_SCALAR) {
1896 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1899 *MARK = sv_mortalcopy(TOPs);
1902 *MARK = &PL_sv_undef;
1906 else if (gimme == G_ARRAY) {
1907 /* in case LEAVE wipes old return values */
1909 for (mark = newsp + 1; mark <= SP; mark++) {
1910 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1911 *mark = sv_mortalcopy(*mark);
1912 TAINT_NOT; /* Each item is independent */
1916 PL_curpm = newpm; /* Don't pop $1 et al till now */
1918 LEAVE_with_name("block");
1926 register PERL_CONTEXT *cx;
1929 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1930 bool av_is_stack = FALSE;
1933 cx = &cxstack[cxstack_ix];
1934 if (!CxTYPE_is_LOOP(cx))
1935 DIE(aTHX_ "panic: pp_iter");
1937 itersvp = CxITERVAR(cx);
1938 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1939 /* string increment */
1940 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1941 SV *end = cx->blk_loop.state_u.lazysv.end;
1942 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1943 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1945 const char *max = SvPV_const(end, maxlen);
1946 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1947 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1948 /* safe to reuse old SV */
1949 sv_setsv(*itersvp, cur);
1953 /* we need a fresh SV every time so that loop body sees a
1954 * completely new SV for closures/references to work as
1957 *itersvp = newSVsv(cur);
1958 SvREFCNT_dec(oldsv);
1960 if (strEQ(SvPVX_const(cur), max))
1961 sv_setiv(cur, 0); /* terminate next time */
1968 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1969 /* integer increment */
1970 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1973 /* don't risk potential race */
1974 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1975 /* safe to reuse old SV */
1976 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1980 /* we need a fresh SV every time so that loop body sees a
1981 * completely new SV for closures/references to work as they
1984 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1985 SvREFCNT_dec(oldsv);
1988 /* Handle end of range at IV_MAX */
1989 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1990 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1992 cx->blk_loop.state_u.lazyiv.cur++;
1993 cx->blk_loop.state_u.lazyiv.end++;
2000 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2001 av = cx->blk_loop.state_u.ary.ary;
2006 if (PL_op->op_private & OPpITER_REVERSED) {
2007 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2008 ? cx->blk_loop.resetsp + 1 : 0))
2011 if (SvMAGICAL(av) || AvREIFY(av)) {
2012 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2013 sv = svp ? *svp : NULL;
2016 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2020 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2024 if (SvMAGICAL(av) || AvREIFY(av)) {
2025 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2026 sv = svp ? *svp : NULL;
2029 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2033 if (sv && SvIS_FREED(sv)) {
2035 Perl_croak(aTHX_ "Use of freed value in iteration");
2040 SvREFCNT_inc_simple_void_NN(sv);
2044 if (!av_is_stack && sv == &PL_sv_undef) {
2045 SV *lv = newSV_type(SVt_PVLV);
2047 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2048 LvTARG(lv) = SvREFCNT_inc_simple(av);
2049 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2050 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2056 SvREFCNT_dec(oldsv);
2064 register PMOP *pm = cPMOP;
2079 register REGEXP *rx = PM_GETRE(pm);
2081 int force_on_match = 0;
2082 const I32 oldsave = PL_savestack_ix;
2084 bool doutf8 = FALSE;
2086 #ifdef PERL_OLD_COPY_ON_WRITE
2090 /* known replacement string? */
2091 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2095 if (PL_op->op_flags & OPf_STACKED)
2097 else if (PL_op->op_private & OPpTARGET_MY)
2104 /* In non-destructive replacement mode, duplicate target scalar so it
2105 * remains unchanged. */
2106 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2107 TARG = newSVsv(TARG);
2109 #ifdef PERL_OLD_COPY_ON_WRITE
2110 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2111 because they make integers such as 256 "false". */
2112 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2115 sv_force_normal_flags(TARG,0);
2118 #ifdef PERL_OLD_COPY_ON_WRITE
2122 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2123 || SvTYPE(TARG) > SVt_PVLV)
2124 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2125 Perl_croak_no_modify(aTHX);
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? */
2185 /* Upgrade the source if the replacement is utf8 but the source is not,
2186 * but only if it matched; see
2187 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2189 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2190 const STRLEN new_len = sv_utf8_upgrade(TARG);
2192 /* If the lengths are the same, the pattern contains only
2193 * invariants, can keep going; otherwise, various internal markers
2194 * could be off, so redo */
2195 if (new_len != len) {
2200 /* replacement needing upgrading? */
2201 if (DO_UTF8(TARG) && !doutf8) {
2202 nsv = sv_newmortal();
2205 sv_recode_to_utf8(nsv, PL_encoding);
2207 sv_utf8_upgrade(nsv);
2208 c = SvPV_const(nsv, clen);
2212 c = SvPV_const(dstr, clen);
2213 doutf8 = DO_UTF8(dstr);
2221 /* can do inplace substitution? */
2223 #ifdef PERL_OLD_COPY_ON_WRITE
2226 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2227 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2228 && (!doutf8 || SvUTF8(TARG))) {
2232 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2236 LEAVE_SCOPE(oldsave);
2239 #ifdef PERL_OLD_COPY_ON_WRITE
2240 if (SvIsCOW(TARG)) {
2241 assert (!force_on_match);
2245 if (force_on_match) {
2247 s = SvPV_force(TARG, len);
2252 SvSCREAM_off(TARG); /* disable possible screamer */
2254 rxtainted |= RX_MATCH_TAINTED(rx);
2255 m = orig + RX_OFFS(rx)[0].start;
2256 d = orig + RX_OFFS(rx)[0].end;
2258 if (m - s > strend - d) { /* faster to shorten from end */
2260 Copy(c, m, clen, char);
2265 Move(d, m, i, char);
2269 SvCUR_set(TARG, m - s);
2271 else if ((i = m - s)) { /* faster from front */
2274 Move(s, d - i, i, char);
2277 Copy(c, m, clen, char);
2282 Copy(c, d, clen, char);
2287 TAINT_IF(rxtainted & 1);
2289 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2296 if (iters++ > maxiters)
2297 DIE(aTHX_ "Substitution loop");
2298 rxtainted |= RX_MATCH_TAINTED(rx);
2299 m = RX_OFFS(rx)[0].start + orig;
2302 Move(s, d, i, char);
2306 Copy(c, d, clen, char);
2309 s = RX_OFFS(rx)[0].end + orig;
2310 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2312 /* don't match same null twice */
2313 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2316 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2317 Move(s, d, i+1, char); /* include the NUL */
2319 TAINT_IF(rxtainted & 1);
2321 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2326 (void)SvPOK_only_UTF8(TARG);
2327 TAINT_IF(rxtainted);
2328 if (SvSMAGICAL(TARG)) {
2336 LEAVE_SCOPE(oldsave);
2342 if (force_on_match) {
2344 s = SvPV_force(TARG, len);
2347 #ifdef PERL_OLD_COPY_ON_WRITE
2350 rxtainted |= RX_MATCH_TAINTED(rx);
2351 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2355 register PERL_CONTEXT *cx;
2358 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2360 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2362 if (iters++ > maxiters)
2363 DIE(aTHX_ "Substitution loop");
2364 rxtainted |= RX_MATCH_TAINTED(rx);
2365 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2368 orig = RX_SUBBEG(rx);
2370 strend = s + (strend - m);
2372 m = RX_OFFS(rx)[0].start + orig;
2373 if (doutf8 && !SvUTF8(dstr))
2374 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2376 sv_catpvn(dstr, s, m-s);
2377 s = RX_OFFS(rx)[0].end + orig;
2379 sv_catpvn(dstr, c, clen);
2382 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2383 TARG, NULL, r_flags));
2384 if (doutf8 && !DO_UTF8(TARG))
2385 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2387 sv_catpvn(dstr, s, strend - s);
2389 #ifdef PERL_OLD_COPY_ON_WRITE
2390 /* The match may make the string COW. If so, brilliant, because that's
2391 just saved us one malloc, copy and free - the regexp has donated
2392 the old buffer, and we malloc an entirely new one, rather than the
2393 regexp malloc()ing a buffer and copying our original, only for
2394 us to throw it away here during the substitution. */
2395 if (SvIsCOW(TARG)) {
2396 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2402 SvPV_set(TARG, SvPVX(dstr));
2403 SvCUR_set(TARG, SvCUR(dstr));
2404 SvLEN_set(TARG, SvLEN(dstr));
2405 doutf8 |= DO_UTF8(dstr);
2406 SvPV_set(dstr, NULL);
2408 TAINT_IF(rxtainted & 1);
2410 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2415 (void)SvPOK_only(TARG);
2418 TAINT_IF(rxtainted);
2421 LEAVE_SCOPE(oldsave);
2429 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2433 LEAVE_SCOPE(oldsave);
2442 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2443 ++*PL_markstack_ptr;
2444 LEAVE_with_name("grep_item"); /* exit inner scope */
2447 if (PL_stack_base + *PL_markstack_ptr > SP) {
2449 const I32 gimme = GIMME_V;
2451 LEAVE_with_name("grep"); /* exit outer scope */
2452 (void)POPMARK; /* pop src */
2453 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2454 (void)POPMARK; /* pop dst */
2455 SP = PL_stack_base + POPMARK; /* pop original mark */
2456 if (gimme == G_SCALAR) {
2457 if (PL_op->op_private & OPpGREP_LEX) {
2458 SV* const sv = sv_newmortal();
2459 sv_setiv(sv, items);
2467 else if (gimme == G_ARRAY)
2474 ENTER_with_name("grep_item"); /* enter inner scope */
2477 src = PL_stack_base[*PL_markstack_ptr];
2479 if (PL_op->op_private & OPpGREP_LEX)
2480 PAD_SVl(PL_op->op_targ) = src;
2484 RETURNOP(cLOGOP->op_other);
2495 register PERL_CONTEXT *cx;
2498 if (CxMULTICALL(&cxstack[cxstack_ix]))
2502 cxstack_ix++; /* temporarily protect top context */
2505 if (gimme == G_SCALAR) {
2508 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2510 *MARK = SvREFCNT_inc(TOPs);
2515 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2517 *MARK = sv_mortalcopy(sv);
2522 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2526 *MARK = &PL_sv_undef;
2530 else if (gimme == G_ARRAY) {
2531 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2532 if (!SvTEMP(*MARK)) {
2533 *MARK = sv_mortalcopy(*MARK);
2534 TAINT_NOT; /* Each item is independent */
2542 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2543 PL_curpm = newpm; /* ... and pop $1 et al */
2546 return cx->blk_sub.retop;
2549 /* This duplicates the above code because the above code must not
2550 * get any slower by more conditions */
2558 register PERL_CONTEXT *cx;
2561 if (CxMULTICALL(&cxstack[cxstack_ix]))
2565 cxstack_ix++; /* temporarily protect top context */
2569 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2570 /* We are an argument to a function or grep().
2571 * This kind of lvalueness was legal before lvalue
2572 * subroutines too, so be backward compatible:
2573 * cannot report errors. */
2575 /* Scalar context *is* possible, on the LHS of -> only,
2576 * as in f()->meth(). But this is not an lvalue. */
2577 if (gimme == G_SCALAR)
2579 if (gimme == G_ARRAY) {
2580 if (!CvLVALUE(cx->blk_sub.cv))
2581 goto temporise_array;
2582 EXTEND_MORTAL(SP - newsp);
2583 for (mark = newsp + 1; mark <= SP; mark++) {
2586 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2587 *mark = sv_mortalcopy(*mark);
2589 /* Can be a localized value subject to deletion. */
2590 PL_tmps_stack[++PL_tmps_ix] = *mark;
2591 SvREFCNT_inc_void(*mark);
2596 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2597 /* Here we go for robustness, not for speed, so we change all
2598 * the refcounts so the caller gets a live guy. Cannot set
2599 * TEMP, so sv_2mortal is out of question. */
2600 if (!CvLVALUE(cx->blk_sub.cv)) {
2606 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2608 if (gimme == G_SCALAR) {
2612 /* Temporaries are bad unless they happen to be elements
2613 * of a tied hash or array */
2614 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2615 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2618 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2624 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2625 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2626 : "a readonly value" : "a temporary");
2628 else { /* Can be a localized value
2629 * subject to deletion. */
2630 PL_tmps_stack[++PL_tmps_ix] = *mark;
2631 SvREFCNT_inc_void(*mark);
2634 else { /* Should not happen? */
2640 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2641 (MARK > SP ? "Empty array" : "Array"));
2645 else if (gimme == G_ARRAY) {
2646 EXTEND_MORTAL(SP - newsp);
2647 for (mark = newsp + 1; mark <= SP; mark++) {
2648 if (*mark != &PL_sv_undef
2649 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2650 /* Might be flattened array after $#array = */
2657 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2658 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2661 /* Can be a localized value subject to deletion. */
2662 PL_tmps_stack[++PL_tmps_ix] = *mark;
2663 SvREFCNT_inc_void(*mark);
2669 if (gimme == G_SCALAR) {
2673 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2675 *MARK = SvREFCNT_inc(TOPs);
2680 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2682 *MARK = sv_mortalcopy(sv);
2687 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2691 *MARK = &PL_sv_undef;
2695 else if (gimme == G_ARRAY) {
2697 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2698 if (!SvTEMP(*MARK)) {
2699 *MARK = sv_mortalcopy(*MARK);
2700 TAINT_NOT; /* Each item is independent */
2709 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2710 PL_curpm = newpm; /* ... and pop $1 et al */
2713 return cx->blk_sub.retop;
2721 register PERL_CONTEXT *cx;
2723 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2726 DIE(aTHX_ "Not a CODE reference");
2727 switch (SvTYPE(sv)) {
2728 /* This is overwhelming the most common case: */
2730 if (!isGV_with_GP(sv))
2731 DIE(aTHX_ "Not a CODE reference");
2732 if (!(cv = GvCVu((const GV *)sv))) {
2734 cv = sv_2cv(sv, &stash, &gv, 0);
2743 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2745 SP = PL_stack_base + POPMARK;
2750 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2751 tryAMAGICunDEREF(to_cv);
2756 sym = SvPV_nomg_const(sv, len);
2758 DIE(aTHX_ PL_no_usym, "a subroutine");
2759 if (PL_op->op_private & HINT_STRICT_REFS)
2760 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2761 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
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_no_modify(aTHX);
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: