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 bool is_gv = isGV_with_GP(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 && !is_gv && 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. */
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( isGV_with_GP(right) && 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 dSP; SvGETMAGIC(TOPs);
322 tryAMAGICunTARGET(iter, 0);
323 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
324 if (!isGV_with_GP(PL_last_in_gv)) {
325 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
326 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
329 XPUSHs(MUTABLE_SV(PL_last_in_gv));
332 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
335 return do_readline();
341 tryAMAGICbin_MG(eq_amg, AMGf_set);
342 #ifndef NV_PRESERVES_UV
343 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
345 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
349 #ifdef PERL_PRESERVE_IVUV
350 SvIV_please_nomg(TOPs);
352 /* Unless the left argument is integer in range we are going
353 to have to use NV maths. Hence only attempt to coerce the
354 right argument if we know the left is integer. */
355 SvIV_please_nomg(TOPm1s);
357 const bool auvok = SvUOK(TOPm1s);
358 const bool buvok = SvUOK(TOPs);
360 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
361 /* Casting IV to UV before comparison isn't going to matter
362 on 2s complement. On 1s complement or sign&magnitude
363 (if we have any of them) it could to make negative zero
364 differ from normal zero. As I understand it. (Need to
365 check - is negative zero implementation defined behaviour
367 const UV buv = SvUVX(POPs);
368 const UV auv = SvUVX(TOPs);
370 SETs(boolSV(auv == buv));
373 { /* ## Mixed IV,UV ## */
377 /* == is commutative so doesn't matter which is left or right */
379 /* top of stack (b) is the iv */
388 /* As uv is a UV, it's >0, so it cannot be == */
391 /* we know iv is >= 0 */
392 SETs(boolSV((UV)iv == SvUVX(uvp)));
399 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
401 if (Perl_isnan(left) || Perl_isnan(right))
403 SETs(boolSV(left == right));
406 SETs(boolSV(SvNV_nomg(TOPs) == value));
415 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
416 Perl_croak_no_modify(aTHX);
417 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
418 && SvIVX(TOPs) != IV_MAX)
420 SvIV_set(TOPs, SvIVX(TOPs) + 1);
421 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
423 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
436 if (PL_op->op_type == OP_OR)
438 RETURNOP(cLOGOP->op_other);
447 const int op_type = PL_op->op_type;
448 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
453 if (!sv || !SvANY(sv)) {
454 if (op_type == OP_DOR)
456 RETURNOP(cLOGOP->op_other);
462 if (!sv || !SvANY(sv))
467 switch (SvTYPE(sv)) {
469 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
473 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
477 if (CvROOT(sv) || CvXSUB(sv))
490 if(op_type == OP_DOR)
492 RETURNOP(cLOGOP->op_other);
494 /* assuming OP_DEFINED */
502 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
503 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
507 useleft = USE_LEFT(svl);
508 #ifdef PERL_PRESERVE_IVUV
509 /* We must see if we can perform the addition with integers if possible,
510 as the integer code detects overflow while the NV code doesn't.
511 If either argument hasn't had a numeric conversion yet attempt to get
512 the IV. It's important to do this now, rather than just assuming that
513 it's not IOK as a PV of "9223372036854775806" may not take well to NV
514 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
515 integer in case the second argument is IV=9223372036854775806
516 We can (now) rely on sv_2iv to do the right thing, only setting the
517 public IOK flag if the value in the NV (or PV) slot is truly integer.
519 A side effect is that this also aggressively prefers integer maths over
520 fp maths for integer values.
522 How to detect overflow?
524 C 99 section 6.2.6.1 says
526 The range of nonnegative values of a signed integer type is a subrange
527 of the corresponding unsigned integer type, and the representation of
528 the same value in each type is the same. A computation involving
529 unsigned operands can never overflow, because a result that cannot be
530 represented by the resulting unsigned integer type is reduced modulo
531 the number that is one greater than the largest value that can be
532 represented by the resulting type.
536 which I read as "unsigned ints wrap."
538 signed integer overflow seems to be classed as "exception condition"
540 If an exceptional condition occurs during the evaluation of an
541 expression (that is, if the result is not mathematically defined or not
542 in the range of representable values for its type), the behavior is
545 (6.5, the 5th paragraph)
547 I had assumed that on 2s complement machines signed arithmetic would
548 wrap, hence coded pp_add and pp_subtract on the assumption that
549 everything perl builds on would be happy. After much wailing and
550 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
551 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
552 unsigned code below is actually shorter than the old code. :-)
555 SvIV_please_nomg(svr);
558 /* Unless the left argument is integer in range we are going to have to
559 use NV maths. Hence only attempt to coerce the right argument if
560 we know the left is integer. */
568 /* left operand is undef, treat as zero. + 0 is identity,
569 Could SETi or SETu right now, but space optimise by not adding
570 lots of code to speed up what is probably a rarish case. */
572 /* Left operand is defined, so is it IV? */
573 SvIV_please_nomg(svl);
575 if ((auvok = SvUOK(svl)))
578 register const IV aiv = SvIVX(svl);
581 auvok = 1; /* Now acting as a sign flag. */
582 } else { /* 2s complement assumption for IV_MIN */
590 bool result_good = 0;
593 bool buvok = SvUOK(svr);
598 register const IV biv = SvIVX(svr);
605 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
606 else "IV" now, independent of how it came in.
607 if a, b represents positive, A, B negative, a maps to -A etc
612 all UV maths. negate result if A negative.
613 add if signs same, subtract if signs differ. */
619 /* Must get smaller */
625 /* result really should be -(auv-buv). as its negation
626 of true value, need to swap our result flag */
643 if (result <= (UV)IV_MIN)
646 /* result valid, but out of range for IV. */
651 } /* Overflow, drop through to NVs. */
656 NV value = SvNV_nomg(svr);
659 /* left operand is undef, treat as zero. + 0.0 is identity. */
663 SETn( value + SvNV_nomg(svl) );
671 AV * const av = PL_op->op_flags & OPf_SPECIAL
672 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
673 const U32 lval = PL_op->op_flags & OPf_MOD;
674 SV** const svp = av_fetch(av, PL_op->op_private, lval);
675 SV *sv = (svp ? *svp : &PL_sv_undef);
677 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
685 dVAR; dSP; dMARK; dTARGET;
687 do_join(TARG, *MARK, MARK, SP);
698 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
699 * will be enough to hold an OP*.
701 SV* const sv = sv_newmortal();
702 sv_upgrade(sv, SVt_PVLV);
704 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
707 XPUSHs(MUTABLE_SV(PL_op));
712 /* Oversized hot code. */
716 dVAR; dSP; dMARK; dORIGMARK;
721 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
723 if (gv && (io = GvIO(gv))
724 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
727 if (MARK == ORIGMARK) {
728 /* If using default handle then we need to make space to
729 * pass object as 1st arg, so move other args up ...
733 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
737 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
739 ENTER_with_name("call_PRINT");
740 if( PL_op->op_type == OP_SAY ) {
741 /* local $\ = "\n" */
742 SAVEGENERICSV(PL_ors_sv);
743 PL_ors_sv = newSVpvs("\n");
745 call_method("PRINT", G_SCALAR);
746 LEAVE_with_name("call_PRINT");
753 if (!(io = GvIO(gv))) {
754 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
755 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
757 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
758 report_evil_fh(gv, io, PL_op->op_type);
759 SETERRNO(EBADF,RMS_IFI);
762 else if (!(fp = IoOFP(io))) {
763 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
765 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
766 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
767 report_evil_fh(gv, io, PL_op->op_type);
769 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
773 SV * const ofs = GvSV(PL_ofsgv); /* $, */
775 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
777 if (!do_print(*MARK, fp))
781 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
782 if (!do_print(GvSV(PL_ofsgv), fp)) {
791 if (!do_print(*MARK, fp))
799 if (PL_op->op_type == OP_SAY) {
800 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
803 else if (PL_ors_sv && SvOK(PL_ors_sv))
804 if (!do_print(PL_ors_sv, fp)) /* $\ */
807 if (IoFLAGS(io) & IOf_FLUSH)
808 if (PerlIO_flush(fp) == EOF)
818 XPUSHs(&PL_sv_undef);
825 const I32 gimme = GIMME_V;
826 static const char an_array[] = "an ARRAY";
827 static const char a_hash[] = "a HASH";
828 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
829 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
831 if (!(PL_op->op_private & OPpDEREFed))
834 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
837 if (SvTYPE(sv) != type)
838 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
839 if (PL_op->op_flags & OPf_REF) {
844 if (gimme != G_ARRAY)
845 goto croak_cant_return;
849 else if (PL_op->op_flags & OPf_MOD
850 && PL_op->op_private & OPpLVAL_INTRO)
851 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
854 if (SvTYPE(sv) == type) {
855 if (PL_op->op_flags & OPf_REF) {
860 if (gimme != G_ARRAY)
861 goto croak_cant_return;
869 if (!isGV_with_GP(sv)) {
870 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
878 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
879 if (PL_op->op_private & OPpLVAL_INTRO)
880 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
881 if (PL_op->op_flags & OPf_REF) {
886 if (gimme != G_ARRAY)
887 goto croak_cant_return;
895 AV *const av = MUTABLE_AV(sv);
896 /* The guts of pp_rv2av, with no intenting change to preserve history
897 (until such time as we get tools that can do blame annotation across
898 whitespace changes. */
899 if (gimme == G_ARRAY) {
900 const I32 maxarg = AvFILL(av) + 1;
901 (void)POPs; /* XXXX May be optimized away? */
903 if (SvRMAGICAL(av)) {
905 for (i=0; i < (U32)maxarg; i++) {
906 SV ** const svp = av_fetch(av, i, FALSE);
907 /* See note in pp_helem, and bug id #27839 */
909 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
914 Copy(AvARRAY(av), SP+1, maxarg, SV*);
918 else if (gimme == G_SCALAR) {
920 const I32 maxarg = AvFILL(av) + 1;
924 /* The guts of pp_rv2hv */
925 if (gimme == G_ARRAY) { /* array wanted */
929 else if (gimme == G_SCALAR) {
931 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
939 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
940 is_pp_rv2av ? "array" : "hash");
945 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
949 PERL_ARGS_ASSERT_DO_ODDBALL;
955 if (ckWARN(WARN_MISC)) {
957 if (relem == firstrelem &&
959 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
960 SvTYPE(SvRV(*relem)) == SVt_PVHV))
962 err = "Reference found where even-sized list expected";
965 err = "Odd number of elements in hash assignment";
966 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
970 didstore = hv_store_ent(hash,*relem,tmpstr,0);
971 if (SvMAGICAL(hash)) {
972 if (SvSMAGICAL(tmpstr))
984 SV **lastlelem = PL_stack_sp;
985 SV **lastrelem = PL_stack_base + POPMARK;
986 SV **firstrelem = PL_stack_base + POPMARK + 1;
987 SV **firstlelem = lastrelem + 1;
1000 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1002 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1005 /* If there's a common identifier on both sides we have to take
1006 * special care that assigning the identifier on the left doesn't
1007 * clobber a value on the right that's used later in the list.
1009 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1010 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1011 for (relem = firstrelem; relem <= lastrelem; relem++) {
1012 if ((sv = *relem)) {
1013 TAINT_NOT; /* Each item is independent */
1015 /* Dear TODO test in t/op/sort.t, I love you.
1016 (It's relying on a panic, not a "semi-panic" from newSVsv()
1017 and then an assertion failure below.) */
1018 if (SvIS_FREED(sv)) {
1019 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1022 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1023 and we need a second copy of a temp here. */
1024 *relem = sv_2mortal(newSVsv(sv));
1034 while (lelem <= lastlelem) {
1035 TAINT_NOT; /* Each item stands on its own, taintwise. */
1037 switch (SvTYPE(sv)) {
1039 ary = MUTABLE_AV(sv);
1040 magic = SvMAGICAL(ary) != 0;
1042 av_extend(ary, lastrelem - relem);
1044 while (relem <= lastrelem) { /* gobble up all the rest */
1048 sv_setsv(sv, *relem);
1050 didstore = av_store(ary,i++,sv);
1059 if (PL_delaymagic & DM_ARRAY_ISA)
1060 SvSETMAGIC(MUTABLE_SV(ary));
1062 case SVt_PVHV: { /* normal hash */
1064 SV** topelem = relem;
1066 hash = MUTABLE_HV(sv);
1067 magic = SvMAGICAL(hash) != 0;
1069 firsthashrelem = relem;
1071 while (relem < lastrelem) { /* gobble up all the rest */
1073 sv = *relem ? *relem : &PL_sv_no;
1077 sv_setsv(tmpstr,*relem); /* value */
1079 if (gimme != G_VOID) {
1080 if (hv_exists_ent(hash, sv, 0))
1081 /* key overwrites an existing entry */
1084 if (gimme == G_ARRAY) {
1085 /* copy element back: possibly to an earlier
1086 * stack location if we encountered dups earlier */
1088 *topelem++ = tmpstr;
1091 didstore = hv_store_ent(hash,sv,tmpstr,0);
1093 if (SvSMAGICAL(tmpstr))
1100 if (relem == lastrelem) {
1101 do_oddball(hash, relem, firstrelem);
1107 if (SvIMMORTAL(sv)) {
1108 if (relem <= lastrelem)
1112 if (relem <= lastrelem) {
1113 sv_setsv(sv, *relem);
1117 sv_setsv(sv, &PL_sv_undef);
1122 if (PL_delaymagic & ~DM_DELAY) {
1123 if (PL_delaymagic & DM_UID) {
1124 #ifdef HAS_SETRESUID
1125 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1126 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1129 # ifdef HAS_SETREUID
1130 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1131 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1134 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1135 (void)setruid(PL_uid);
1136 PL_delaymagic &= ~DM_RUID;
1138 # endif /* HAS_SETRUID */
1140 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1141 (void)seteuid(PL_euid);
1142 PL_delaymagic &= ~DM_EUID;
1144 # endif /* HAS_SETEUID */
1145 if (PL_delaymagic & DM_UID) {
1146 if (PL_uid != PL_euid)
1147 DIE(aTHX_ "No setreuid available");
1148 (void)PerlProc_setuid(PL_uid);
1150 # endif /* HAS_SETREUID */
1151 #endif /* HAS_SETRESUID */
1152 PL_uid = PerlProc_getuid();
1153 PL_euid = PerlProc_geteuid();
1155 if (PL_delaymagic & DM_GID) {
1156 #ifdef HAS_SETRESGID
1157 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1158 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1161 # ifdef HAS_SETREGID
1162 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1163 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1166 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1167 (void)setrgid(PL_gid);
1168 PL_delaymagic &= ~DM_RGID;
1170 # endif /* HAS_SETRGID */
1172 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1173 (void)setegid(PL_egid);
1174 PL_delaymagic &= ~DM_EGID;
1176 # endif /* HAS_SETEGID */
1177 if (PL_delaymagic & DM_GID) {
1178 if (PL_gid != PL_egid)
1179 DIE(aTHX_ "No setregid available");
1180 (void)PerlProc_setgid(PL_gid);
1182 # endif /* HAS_SETREGID */
1183 #endif /* HAS_SETRESGID */
1184 PL_gid = PerlProc_getgid();
1185 PL_egid = PerlProc_getegid();
1187 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1191 if (gimme == G_VOID)
1192 SP = firstrelem - 1;
1193 else if (gimme == G_SCALAR) {
1196 SETi(lastrelem - firstrelem + 1 - duplicates);
1203 /* at this point we have removed the duplicate key/value
1204 * pairs from the stack, but the remaining values may be
1205 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1206 * the (a 2), but the stack now probably contains
1207 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1208 * obliterates the earlier key. So refresh all values. */
1209 lastrelem -= duplicates;
1210 relem = firsthashrelem;
1211 while (relem < lastrelem) {
1214 he = hv_fetch_ent(hash, sv, 0, 0);
1215 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1221 SP = firstrelem + (lastlelem - firstlelem);
1222 lelem = firstlelem + (relem - firstrelem);
1224 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1233 register PMOP * const pm = cPMOP;
1234 REGEXP * rx = PM_GETRE(pm);
1235 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1236 SV * const rv = sv_newmortal();
1238 SvUPGRADE(rv, SVt_IV);
1239 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1240 loathe to use it here, but it seems to be the right fix. Or close.
1241 The key part appears to be that it's essential for pp_qr to return a new
1242 object (SV), which implies that there needs to be an effective way to
1243 generate a new SV from the existing SV that is pre-compiled in the
1245 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1249 HV *const stash = gv_stashsv(pkg, GV_ADD);
1251 (void)sv_bless(rv, stash);
1254 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1263 register PMOP *pm = cPMOP;
1265 register const char *t;
1266 register const char *s;
1269 U8 r_flags = REXEC_CHECKED;
1270 const char *truebase; /* Start of string */
1271 register REGEXP *rx = PM_GETRE(pm);
1273 const I32 gimme = GIMME;
1276 const I32 oldsave = PL_savestack_ix;
1277 I32 update_minmatch = 1;
1278 I32 had_zerolen = 0;
1281 if (PL_op->op_flags & OPf_STACKED)
1283 else if (PL_op->op_private & OPpTARGET_MY)
1290 PUTBACK; /* EVAL blocks need stack_sp. */
1291 /* Skip get-magic if this is a qr// clone, because regcomp has
1293 s = ((struct regexp *)SvANY(rx))->mother_re
1294 ? SvPV_nomg_const(TARG, len)
1295 : SvPV_const(TARG, len);
1297 DIE(aTHX_ "panic: pp_match");
1299 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1300 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1303 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1305 /* PMdf_USED is set after a ?? matches once */
1308 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1310 pm->op_pmflags & PMf_USED
1314 if (gimme == G_ARRAY)
1321 /* empty pattern special-cased to use last successful pattern if possible */
1322 if (!RX_PRELEN(rx) && PL_curpm) {
1327 if (RX_MINLEN(rx) > (I32)len)
1332 /* XXXX What part of this is needed with true \G-support? */
1333 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1334 RX_OFFS(rx)[0].start = -1;
1335 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1336 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1337 if (mg && mg->mg_len >= 0) {
1338 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1339 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1340 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1341 r_flags |= REXEC_IGNOREPOS;
1342 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1343 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1346 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1347 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1348 update_minmatch = 0;
1352 /* XXX: comment out !global get safe $1 vars after a
1353 match, BUT be aware that this leads to dramatic slowdowns on
1354 /g matches against large strings. So far a solution to this problem
1355 appears to be quite tricky.
1356 Test for the unsafe vars are TODO for now. */
1357 if ( (!global && RX_NPARENS(rx))
1358 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1359 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1360 r_flags |= REXEC_COPY_STR;
1362 r_flags |= REXEC_SCREAM;
1365 if (global && RX_OFFS(rx)[0].start != -1) {
1366 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1367 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1369 if (update_minmatch++)
1370 minmatch = had_zerolen;
1372 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1373 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1374 /* FIXME - can PL_bostr be made const char *? */
1375 PL_bostr = (char *)truebase;
1376 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1380 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1382 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1383 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1384 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1385 && (r_flags & REXEC_SCREAM)))
1386 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1389 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1390 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1393 if (dynpm->op_pmflags & PMf_ONCE) {
1395 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1397 dynpm->op_pmflags |= PMf_USED;
1408 RX_MATCH_TAINTED_on(rx);
1409 TAINT_IF(RX_MATCH_TAINTED(rx));
1410 if (gimme == G_ARRAY) {
1411 const I32 nparens = RX_NPARENS(rx);
1412 I32 i = (global && !nparens) ? 1 : 0;
1414 SPAGAIN; /* EVAL blocks could move the stack. */
1415 EXTEND(SP, nparens + i);
1416 EXTEND_MORTAL(nparens + i);
1417 for (i = !i; i <= nparens; i++) {
1418 PUSHs(sv_newmortal());
1419 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1420 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1421 s = RX_OFFS(rx)[i].start + truebase;
1422 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1423 len < 0 || len > strend - s)
1424 DIE(aTHX_ "panic: pp_match start/end pointers");
1425 sv_setpvn(*SP, s, len);
1426 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1431 if (dynpm->op_pmflags & PMf_CONTINUE) {
1433 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1434 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1436 #ifdef PERL_OLD_COPY_ON_WRITE
1438 sv_force_normal_flags(TARG, 0);
1440 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1441 &PL_vtbl_mglob, NULL, 0);
1443 if (RX_OFFS(rx)[0].start != -1) {
1444 mg->mg_len = RX_OFFS(rx)[0].end;
1445 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1446 mg->mg_flags |= MGf_MINMATCH;
1448 mg->mg_flags &= ~MGf_MINMATCH;
1451 had_zerolen = (RX_OFFS(rx)[0].start != -1
1452 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1453 == (UV)RX_OFFS(rx)[0].end));
1454 PUTBACK; /* EVAL blocks may use stack */
1455 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1460 LEAVE_SCOPE(oldsave);
1466 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1467 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1471 #ifdef PERL_OLD_COPY_ON_WRITE
1473 sv_force_normal_flags(TARG, 0);
1475 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1476 &PL_vtbl_mglob, NULL, 0);
1478 if (RX_OFFS(rx)[0].start != -1) {
1479 mg->mg_len = RX_OFFS(rx)[0].end;
1480 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1481 mg->mg_flags |= MGf_MINMATCH;
1483 mg->mg_flags &= ~MGf_MINMATCH;
1486 LEAVE_SCOPE(oldsave);
1490 yup: /* Confirmed by INTUIT */
1492 RX_MATCH_TAINTED_on(rx);
1493 TAINT_IF(RX_MATCH_TAINTED(rx));
1495 if (dynpm->op_pmflags & PMf_ONCE) {
1497 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1499 dynpm->op_pmflags |= PMf_USED;
1502 if (RX_MATCH_COPIED(rx))
1503 Safefree(RX_SUBBEG(rx));
1504 RX_MATCH_COPIED_off(rx);
1505 RX_SUBBEG(rx) = NULL;
1507 /* FIXME - should rx->subbeg be const char *? */
1508 RX_SUBBEG(rx) = (char *) truebase;
1509 RX_OFFS(rx)[0].start = s - truebase;
1510 if (RX_MATCH_UTF8(rx)) {
1511 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1512 RX_OFFS(rx)[0].end = t - truebase;
1515 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1517 RX_SUBLEN(rx) = strend - truebase;
1520 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1522 #ifdef PERL_OLD_COPY_ON_WRITE
1523 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1525 PerlIO_printf(Perl_debug_log,
1526 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1527 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1530 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1532 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1533 assert (SvPOKp(RX_SAVED_COPY(rx)));
1538 RX_SUBBEG(rx) = savepvn(t, strend - t);
1539 #ifdef PERL_OLD_COPY_ON_WRITE
1540 RX_SAVED_COPY(rx) = NULL;
1543 RX_SUBLEN(rx) = strend - t;
1544 RX_MATCH_COPIED_on(rx);
1545 off = RX_OFFS(rx)[0].start = s - t;
1546 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1548 else { /* startp/endp are used by @- @+. */
1549 RX_OFFS(rx)[0].start = s - truebase;
1550 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1552 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1554 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1555 LEAVE_SCOPE(oldsave);
1560 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1561 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1562 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1567 LEAVE_SCOPE(oldsave);
1568 if (gimme == G_ARRAY)
1574 Perl_do_readline(pTHX)
1576 dVAR; dSP; dTARGETSTACKED;
1581 register IO * const io = GvIO(PL_last_in_gv);
1582 register const I32 type = PL_op->op_type;
1583 const I32 gimme = GIMME_V;
1586 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1589 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1591 ENTER_with_name("call_READLINE");
1592 call_method("READLINE", gimme);
1593 LEAVE_with_name("call_READLINE");
1595 if (gimme == G_SCALAR) {
1596 SV* const result = POPs;
1597 SvSetSV_nosteal(TARG, result);
1607 if (IoFLAGS(io) & IOf_ARGV) {
1608 if (IoFLAGS(io) & IOf_START) {
1610 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1611 IoFLAGS(io) &= ~IOf_START;
1612 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1613 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1614 SvSETMAGIC(GvSV(PL_last_in_gv));
1619 fp = nextargv(PL_last_in_gv);
1620 if (!fp) { /* Note: fp != IoIFP(io) */
1621 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1624 else if (type == OP_GLOB)
1625 fp = Perl_start_glob(aTHX_ POPs, io);
1627 else if (type == OP_GLOB)
1629 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1630 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1634 if ((!io || !(IoFLAGS(io) & IOf_START))
1635 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1637 if (type == OP_GLOB)
1638 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1639 "glob failed (can't start child: %s)",
1642 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1644 if (gimme == G_SCALAR) {
1645 /* undef TARG, and push that undefined value */
1646 if (type != OP_RCATLINE) {
1647 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1655 if (gimme == G_SCALAR) {
1657 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1660 if (type == OP_RCATLINE)
1661 SvPV_force_nolen(sv);
1665 else if (isGV_with_GP(sv)) {
1666 SvPV_force_nolen(sv);
1668 SvUPGRADE(sv, SVt_PV);
1669 tmplen = SvLEN(sv); /* remember if already alloced */
1670 if (!tmplen && !SvREADONLY(sv)) {
1671 /* try short-buffering it. Please update t/op/readline.t
1672 * if you change the growth length.
1677 if (type == OP_RCATLINE && SvOK(sv)) {
1679 SvPV_force_nolen(sv);
1685 sv = sv_2mortal(newSV(80));
1689 /* This should not be marked tainted if the fp is marked clean */
1690 #define MAYBE_TAINT_LINE(io, sv) \
1691 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1696 /* delay EOF state for a snarfed empty file */
1697 #define SNARF_EOF(gimme,rs,io,sv) \
1698 (gimme != G_SCALAR || SvCUR(sv) \
1699 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1703 if (!sv_gets(sv, fp, offset)
1705 || SNARF_EOF(gimme, PL_rs, io, sv)
1706 || PerlIO_error(fp)))
1708 PerlIO_clearerr(fp);
1709 if (IoFLAGS(io) & IOf_ARGV) {
1710 fp = nextargv(PL_last_in_gv);
1713 (void)do_close(PL_last_in_gv, FALSE);
1715 else if (type == OP_GLOB) {
1716 if (!do_close(PL_last_in_gv, FALSE)) {
1717 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1718 "glob failed (child exited with status %d%s)",
1719 (int)(STATUS_CURRENT >> 8),
1720 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1723 if (gimme == G_SCALAR) {
1724 if (type != OP_RCATLINE) {
1725 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1731 MAYBE_TAINT_LINE(io, sv);
1734 MAYBE_TAINT_LINE(io, sv);
1736 IoFLAGS(io) |= IOf_NOLINE;
1740 if (type == OP_GLOB) {
1743 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1744 char * const tmps = SvEND(sv) - 1;
1745 if (*tmps == *SvPVX_const(PL_rs)) {
1747 SvCUR_set(sv, SvCUR(sv) - 1);
1750 for (t1 = SvPVX_const(sv); *t1; t1++)
1751 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1752 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1754 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1755 (void)POPs; /* Unmatched wildcard? Chuck it... */
1758 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1759 if (ckWARN(WARN_UTF8)) {
1760 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1761 const STRLEN len = SvCUR(sv) - offset;
1764 if (!is_utf8_string_loc(s, len, &f))
1765 /* Emulate :encoding(utf8) warning in the same case. */
1766 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1767 "utf8 \"\\x%02X\" does not map to Unicode",
1768 f < (U8*)SvEND(sv) ? *f : 0);
1771 if (gimme == G_ARRAY) {
1772 if (SvLEN(sv) - SvCUR(sv) > 20) {
1773 SvPV_shrink_to_cur(sv);
1775 sv = sv_2mortal(newSV(80));
1778 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1779 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1780 const STRLEN new_len
1781 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1782 SvPV_renew(sv, new_len);
1791 register PERL_CONTEXT *cx;
1792 I32 gimme = OP_GIMME(PL_op, -1);
1795 if (cxstack_ix >= 0) {
1796 /* If this flag is set, we're just inside a return, so we should
1797 * store the caller's context */
1798 gimme = (PL_op->op_flags & OPf_SPECIAL)
1800 : cxstack[cxstack_ix].blk_gimme;
1805 ENTER_with_name("block");
1808 PUSHBLOCK(cx, CXt_BLOCK, SP);
1818 SV * const keysv = POPs;
1819 HV * const hv = MUTABLE_HV(POPs);
1820 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1821 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1823 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1824 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1825 bool preeminent = TRUE;
1827 if (SvTYPE(hv) != SVt_PVHV)
1834 /* If we can determine whether the element exist,
1835 * Try to preserve the existenceness of a tied hash
1836 * element by using EXISTS and DELETE if possible.
1837 * Fallback to FETCH and STORE otherwise. */
1838 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1839 preeminent = hv_exists_ent(hv, keysv, 0);
1842 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1843 svp = he ? &HeVAL(he) : NULL;
1845 if (!svp || *svp == &PL_sv_undef) {
1849 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1851 lv = sv_newmortal();
1852 sv_upgrade(lv, SVt_PVLV);
1854 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1855 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1856 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1862 if (HvNAME_get(hv) && isGV(*svp))
1863 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1864 else if (preeminent)
1865 save_helem_flags(hv, keysv, svp,
1866 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1868 SAVEHDELETE(hv, keysv);
1870 else if (PL_op->op_private & OPpDEREF)
1871 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1873 sv = (svp ? *svp : &PL_sv_undef);
1874 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1875 * was to make C<local $tied{foo} = $tied{foo}> possible.
1876 * However, it seems no longer to be needed for that purpose, and
1877 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1878 * would loop endlessly since the pos magic is getting set on the
1879 * mortal copy and lost. However, the copy has the effect of
1880 * triggering the get magic, and losing it altogether made things like
1881 * c<$tied{foo};> in void context no longer do get magic, which some
1882 * code relied on. Also, delayed triggering of magic on @+ and friends
1883 * meant the original regex may be out of scope by now. So as a
1884 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1885 * being called too many times). */
1886 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1895 register PERL_CONTEXT *cx;
1900 if (PL_op->op_flags & OPf_SPECIAL) {
1901 cx = &cxstack[cxstack_ix];
1902 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1907 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1910 if (gimme == G_VOID)
1912 else if (gimme == G_SCALAR) {
1916 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1919 *MARK = sv_mortalcopy(TOPs);
1922 *MARK = &PL_sv_undef;
1926 else if (gimme == G_ARRAY) {
1927 /* in case LEAVE wipes old return values */
1929 for (mark = newsp + 1; mark <= SP; mark++) {
1930 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1931 *mark = sv_mortalcopy(*mark);
1932 TAINT_NOT; /* Each item is independent */
1936 PL_curpm = newpm; /* Don't pop $1 et al till now */
1938 LEAVE_with_name("block");
1946 register PERL_CONTEXT *cx;
1949 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1950 bool av_is_stack = FALSE;
1953 cx = &cxstack[cxstack_ix];
1954 if (!CxTYPE_is_LOOP(cx))
1955 DIE(aTHX_ "panic: pp_iter");
1957 itersvp = CxITERVAR(cx);
1958 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1959 /* string increment */
1960 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1961 SV *end = cx->blk_loop.state_u.lazysv.end;
1962 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1963 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1965 const char *max = SvPV_const(end, maxlen);
1966 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1967 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1968 /* safe to reuse old SV */
1969 sv_setsv(*itersvp, cur);
1973 /* we need a fresh SV every time so that loop body sees a
1974 * completely new SV for closures/references to work as
1977 *itersvp = newSVsv(cur);
1978 SvREFCNT_dec(oldsv);
1980 if (strEQ(SvPVX_const(cur), max))
1981 sv_setiv(cur, 0); /* terminate next time */
1988 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1989 /* integer increment */
1990 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1993 /* don't risk potential race */
1994 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1995 /* safe to reuse old SV */
1996 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
2000 /* we need a fresh SV every time so that loop body sees a
2001 * completely new SV for closures/references to work as they
2004 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
2005 SvREFCNT_dec(oldsv);
2008 /* Handle end of range at IV_MAX */
2009 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
2010 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2012 cx->blk_loop.state_u.lazyiv.cur++;
2013 cx->blk_loop.state_u.lazyiv.end++;
2020 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2021 av = cx->blk_loop.state_u.ary.ary;
2026 if (PL_op->op_private & OPpITER_REVERSED) {
2027 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2028 ? cx->blk_loop.resetsp + 1 : 0))
2031 if (SvMAGICAL(av) || AvREIFY(av)) {
2032 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2033 sv = svp ? *svp : NULL;
2036 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2040 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2044 if (SvMAGICAL(av) || AvREIFY(av)) {
2045 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2046 sv = svp ? *svp : NULL;
2049 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2053 if (sv && SvIS_FREED(sv)) {
2055 Perl_croak(aTHX_ "Use of freed value in iteration");
2060 SvREFCNT_inc_simple_void_NN(sv);
2064 if (!av_is_stack && sv == &PL_sv_undef) {
2065 SV *lv = newSV_type(SVt_PVLV);
2067 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2068 LvTARG(lv) = SvREFCNT_inc_simple(av);
2069 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2070 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2076 SvREFCNT_dec(oldsv);
2084 register PMOP *pm = cPMOP;
2099 register REGEXP *rx = PM_GETRE(pm);
2101 int force_on_match = 0;
2102 const I32 oldsave = PL_savestack_ix;
2104 bool doutf8 = FALSE;
2106 #ifdef PERL_OLD_COPY_ON_WRITE
2110 /* known replacement string? */
2111 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2115 if (PL_op->op_flags & OPf_STACKED)
2117 else if (PL_op->op_private & OPpTARGET_MY)
2124 /* In non-destructive replacement mode, duplicate target scalar so it
2125 * remains unchanged. */
2126 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2127 TARG = newSVsv(TARG);
2129 #ifdef PERL_OLD_COPY_ON_WRITE
2130 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2131 because they make integers such as 256 "false". */
2132 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2135 sv_force_normal_flags(TARG,0);
2138 #ifdef PERL_OLD_COPY_ON_WRITE
2142 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2143 || SvTYPE(TARG) > SVt_PVLV)
2144 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2145 Perl_croak_no_modify(aTHX);
2149 s = SvPV_mutable(TARG, len);
2150 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2152 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2153 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2158 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2162 DIE(aTHX_ "panic: pp_subst");
2165 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2166 maxiters = 2 * slen + 10; /* We can match twice at each
2167 position, once with zero-length,
2168 second time with non-zero. */
2170 if (!RX_PRELEN(rx) && PL_curpm) {
2174 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2175 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2176 ? REXEC_COPY_STR : 0;
2178 r_flags |= REXEC_SCREAM;
2181 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2183 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2187 /* How to do it in subst? */
2188 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2190 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2191 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2192 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2193 && (r_flags & REXEC_SCREAM))))
2198 /* only replace once? */
2199 once = !(rpm->op_pmflags & PMf_GLOBAL);
2200 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2201 r_flags | REXEC_CHECKED);
2202 /* known replacement string? */
2205 /* Upgrade the source if the replacement is utf8 but the source is not,
2206 * but only if it matched; see
2207 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2209 if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2210 const STRLEN new_len = sv_utf8_upgrade(TARG);
2212 /* If the lengths are the same, the pattern contains only
2213 * invariants, can keep going; otherwise, various internal markers
2214 * could be off, so redo */
2215 if (new_len != len) {
2220 /* replacement needing upgrading? */
2221 if (DO_UTF8(TARG) && !doutf8) {
2222 nsv = sv_newmortal();
2225 sv_recode_to_utf8(nsv, PL_encoding);
2227 sv_utf8_upgrade(nsv);
2228 c = SvPV_const(nsv, clen);
2232 c = SvPV_const(dstr, clen);
2233 doutf8 = DO_UTF8(dstr);
2241 /* can do inplace substitution? */
2243 #ifdef PERL_OLD_COPY_ON_WRITE
2246 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2247 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2248 && (!doutf8 || SvUTF8(TARG))) {
2252 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2256 LEAVE_SCOPE(oldsave);
2259 #ifdef PERL_OLD_COPY_ON_WRITE
2260 if (SvIsCOW(TARG)) {
2261 assert (!force_on_match);
2265 if (force_on_match) {
2267 s = SvPV_force(TARG, len);
2272 SvSCREAM_off(TARG); /* disable possible screamer */
2274 rxtainted |= RX_MATCH_TAINTED(rx);
2275 m = orig + RX_OFFS(rx)[0].start;
2276 d = orig + RX_OFFS(rx)[0].end;
2278 if (m - s > strend - d) { /* faster to shorten from end */
2280 Copy(c, m, clen, char);
2285 Move(d, m, i, char);
2289 SvCUR_set(TARG, m - s);
2291 else if ((i = m - s)) { /* faster from front */
2294 Move(s, d - i, i, char);
2297 Copy(c, m, clen, char);
2302 Copy(c, d, clen, char);
2307 TAINT_IF(rxtainted & 1);
2309 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2316 if (iters++ > maxiters)
2317 DIE(aTHX_ "Substitution loop");
2318 rxtainted |= RX_MATCH_TAINTED(rx);
2319 m = RX_OFFS(rx)[0].start + orig;
2322 Move(s, d, i, char);
2326 Copy(c, d, clen, char);
2329 s = RX_OFFS(rx)[0].end + orig;
2330 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2332 /* don't match same null twice */
2333 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2336 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2337 Move(s, d, i+1, char); /* include the NUL */
2339 TAINT_IF(rxtainted & 1);
2341 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2346 (void)SvPOK_only_UTF8(TARG);
2347 TAINT_IF(rxtainted);
2348 if (SvSMAGICAL(TARG)) {
2356 LEAVE_SCOPE(oldsave);
2362 if (force_on_match) {
2364 s = SvPV_force(TARG, len);
2367 #ifdef PERL_OLD_COPY_ON_WRITE
2370 rxtainted |= RX_MATCH_TAINTED(rx);
2371 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2375 register PERL_CONTEXT *cx;
2378 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2380 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2382 if (iters++ > maxiters)
2383 DIE(aTHX_ "Substitution loop");
2384 rxtainted |= RX_MATCH_TAINTED(rx);
2385 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2388 orig = RX_SUBBEG(rx);
2390 strend = s + (strend - m);
2392 m = RX_OFFS(rx)[0].start + orig;
2393 if (doutf8 && !SvUTF8(dstr))
2394 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2396 sv_catpvn(dstr, s, m-s);
2397 s = RX_OFFS(rx)[0].end + orig;
2399 sv_catpvn(dstr, c, clen);
2402 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2403 TARG, NULL, r_flags));
2404 if (doutf8 && !DO_UTF8(TARG))
2405 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2407 sv_catpvn(dstr, s, strend - s);
2409 #ifdef PERL_OLD_COPY_ON_WRITE
2410 /* The match may make the string COW. If so, brilliant, because that's
2411 just saved us one malloc, copy and free - the regexp has donated
2412 the old buffer, and we malloc an entirely new one, rather than the
2413 regexp malloc()ing a buffer and copying our original, only for
2414 us to throw it away here during the substitution. */
2415 if (SvIsCOW(TARG)) {
2416 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2422 SvPV_set(TARG, SvPVX(dstr));
2423 SvCUR_set(TARG, SvCUR(dstr));
2424 SvLEN_set(TARG, SvLEN(dstr));
2425 doutf8 |= DO_UTF8(dstr);
2426 SvPV_set(dstr, NULL);
2428 TAINT_IF(rxtainted & 1);
2430 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2435 (void)SvPOK_only(TARG);
2438 TAINT_IF(rxtainted);
2441 LEAVE_SCOPE(oldsave);
2449 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2453 LEAVE_SCOPE(oldsave);
2462 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2463 ++*PL_markstack_ptr;
2465 LEAVE_with_name("grep_item"); /* exit inner scope */
2468 if (PL_stack_base + *PL_markstack_ptr > SP) {
2470 const I32 gimme = GIMME_V;
2472 LEAVE_with_name("grep"); /* exit outer scope */
2473 (void)POPMARK; /* pop src */
2474 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2475 (void)POPMARK; /* pop dst */
2476 SP = PL_stack_base + POPMARK; /* pop original mark */
2477 if (gimme == G_SCALAR) {
2478 if (PL_op->op_private & OPpGREP_LEX) {
2479 SV* const sv = sv_newmortal();
2480 sv_setiv(sv, items);
2488 else if (gimme == G_ARRAY)
2495 ENTER_with_name("grep_item"); /* enter inner scope */
2498 src = PL_stack_base[*PL_markstack_ptr];
2500 if (PL_op->op_private & OPpGREP_LEX)
2501 PAD_SVl(PL_op->op_targ) = src;
2505 RETURNOP(cLOGOP->op_other);
2516 register PERL_CONTEXT *cx;
2519 if (CxMULTICALL(&cxstack[cxstack_ix]))
2523 cxstack_ix++; /* temporarily protect top context */
2526 if (gimme == G_SCALAR) {
2529 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2531 *MARK = SvREFCNT_inc(TOPs);
2536 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2538 *MARK = sv_mortalcopy(sv);
2543 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2547 *MARK = &PL_sv_undef;
2551 else if (gimme == G_ARRAY) {
2552 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2553 if (!SvTEMP(*MARK)) {
2554 *MARK = sv_mortalcopy(*MARK);
2555 TAINT_NOT; /* Each item is independent */
2563 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2564 PL_curpm = newpm; /* ... and pop $1 et al */
2567 return cx->blk_sub.retop;
2570 /* This duplicates the above code because the above code must not
2571 * get any slower by more conditions */
2579 register PERL_CONTEXT *cx;
2582 if (CxMULTICALL(&cxstack[cxstack_ix]))
2586 cxstack_ix++; /* temporarily protect top context */
2590 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2591 /* We are an argument to a function or grep().
2592 * This kind of lvalueness was legal before lvalue
2593 * subroutines too, so be backward compatible:
2594 * cannot report errors. */
2596 /* Scalar context *is* possible, on the LHS of -> only,
2597 * as in f()->meth(). But this is not an lvalue. */
2598 if (gimme == G_SCALAR)
2600 if (gimme == G_ARRAY) {
2601 if (!CvLVALUE(cx->blk_sub.cv))
2602 goto temporise_array;
2603 EXTEND_MORTAL(SP - newsp);
2604 for (mark = newsp + 1; mark <= SP; mark++) {
2607 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2608 *mark = sv_mortalcopy(*mark);
2610 /* Can be a localized value subject to deletion. */
2611 PL_tmps_stack[++PL_tmps_ix] = *mark;
2612 SvREFCNT_inc_void(*mark);
2617 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2618 /* Here we go for robustness, not for speed, so we change all
2619 * the refcounts so the caller gets a live guy. Cannot set
2620 * TEMP, so sv_2mortal is out of question. */
2621 if (!CvLVALUE(cx->blk_sub.cv)) {
2627 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2629 if (gimme == G_SCALAR) {
2633 /* Temporaries are bad unless they happen to have set magic
2634 * attached, such as the elements of a tied hash or array */
2635 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2636 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2639 !SvSMAGICAL(TOPs)) {
2645 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2646 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2647 : "a readonly value" : "a temporary");
2649 else { /* Can be a localized value
2650 * subject to deletion. */
2651 PL_tmps_stack[++PL_tmps_ix] = *mark;
2652 SvREFCNT_inc_void(*mark);
2655 else { /* Should not happen? */
2661 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2662 (MARK > SP ? "Empty array" : "Array"));
2666 else if (gimme == G_ARRAY) {
2667 EXTEND_MORTAL(SP - newsp);
2668 for (mark = newsp + 1; mark <= SP; mark++) {
2669 if (*mark != &PL_sv_undef
2670 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2671 /* Might be flattened array after $#array = */
2678 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2679 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2682 /* Can be a localized value subject to deletion. */
2683 PL_tmps_stack[++PL_tmps_ix] = *mark;
2684 SvREFCNT_inc_void(*mark);
2690 if (gimme == G_SCALAR) {
2694 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2696 *MARK = SvREFCNT_inc(TOPs);
2701 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2703 *MARK = sv_mortalcopy(sv);
2708 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2712 *MARK = &PL_sv_undef;
2716 else if (gimme == G_ARRAY) {
2718 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2719 if (!SvTEMP(*MARK)) {
2720 *MARK = sv_mortalcopy(*MARK);
2721 TAINT_NOT; /* Each item is independent */
2730 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2731 PL_curpm = newpm; /* ... and pop $1 et al */
2734 return cx->blk_sub.retop;
2742 register PERL_CONTEXT *cx;
2744 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2747 DIE(aTHX_ "Not a CODE reference");
2748 switch (SvTYPE(sv)) {
2749 /* This is overwhelming the most common case: */
2751 if (!isGV_with_GP(sv))
2752 DIE(aTHX_ "Not a CODE reference");
2754 if (!(cv = GvCVu((const GV *)sv))) {
2756 cv = sv_2cv(sv, &stash, &gv, 0);
2765 if(isGV_with_GP(sv)) goto we_have_a_glob;
2768 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2770 SP = PL_stack_base + POPMARK;
2775 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2776 tryAMAGICunDEREF(to_cv);
2781 sym = SvPV_nomg_const(sv, len);
2783 DIE(aTHX_ PL_no_usym, "a subroutine");
2784 if (PL_op->op_private & HINT_STRICT_REFS)
2785 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2786 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2789 cv = MUTABLE_CV(SvRV(sv));
2790 if (SvTYPE(cv) == SVt_PVCV)
2795 DIE(aTHX_ "Not a CODE reference");
2796 /* This is the second most common case: */
2798 cv = MUTABLE_CV(sv);
2806 if (!CvROOT(cv) && !CvXSUB(cv)) {
2810 /* anonymous or undef'd function leaves us no recourse */
2811 if (CvANON(cv) || !(gv = CvGV(cv)))
2812 DIE(aTHX_ "Undefined subroutine called");
2814 /* autoloaded stub? */
2815 if (cv != GvCV(gv)) {
2818 /* should call AUTOLOAD now? */
2821 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2828 sub_name = sv_newmortal();
2829 gv_efullname3(sub_name, gv, NULL);
2830 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2834 DIE(aTHX_ "Not a CODE reference");
2839 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2840 Perl_get_db_sub(aTHX_ &sv, cv);
2842 PL_curcopdb = PL_curcop;
2844 /* check for lsub that handles lvalue subroutines */
2845 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2846 /* if lsub not found then fall back to DB::sub */
2847 if (!cv) cv = GvCV(PL_DBsub);
2849 cv = GvCV(PL_DBsub);
2852 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2853 DIE(aTHX_ "No DB::sub routine defined");
2856 if (!(CvISXSUB(cv))) {
2857 /* This path taken at least 75% of the time */
2859 register I32 items = SP - MARK;
2860 AV* const padlist = CvPADLIST(cv);
2861 PUSHBLOCK(cx, CXt_SUB, MARK);
2863 cx->blk_sub.retop = PL_op->op_next;
2865 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2866 * that eval'' ops within this sub know the correct lexical space.
2867 * Owing the speed considerations, we choose instead to search for
2868 * the cv using find_runcv() when calling doeval().
2870 if (CvDEPTH(cv) >= 2) {
2871 PERL_STACK_OVERFLOW_CHECK();
2872 pad_push(padlist, CvDEPTH(cv));
2875 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2877 AV *const av = MUTABLE_AV(PAD_SVl(0));
2879 /* @_ is normally not REAL--this should only ever
2880 * happen when DB::sub() calls things that modify @_ */
2885 cx->blk_sub.savearray = GvAV(PL_defgv);
2886 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2887 CX_CURPAD_SAVE(cx->blk_sub);
2888 cx->blk_sub.argarray = av;
2891 if (items > AvMAX(av) + 1) {
2892 SV **ary = AvALLOC(av);
2893 if (AvARRAY(av) != ary) {
2894 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2897 if (items > AvMAX(av) + 1) {
2898 AvMAX(av) = items - 1;
2899 Renew(ary,items,SV*);
2904 Copy(MARK,AvARRAY(av),items,SV*);
2905 AvFILLp(av) = items - 1;
2913 /* warning must come *after* we fully set up the context
2914 * stuff so that __WARN__ handlers can safely dounwind()
2917 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2918 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2919 sub_crush_depth(cv);
2920 RETURNOP(CvSTART(cv));
2923 I32 markix = TOPMARK;
2928 /* Need to copy @_ to stack. Alternative may be to
2929 * switch stack to @_, and copy return values
2930 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2931 AV * const av = GvAV(PL_defgv);
2932 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2935 /* Mark is at the end of the stack. */
2937 Copy(AvARRAY(av), SP + 1, items, SV*);
2942 /* We assume first XSUB in &DB::sub is the called one. */
2944 SAVEVPTR(PL_curcop);
2945 PL_curcop = PL_curcopdb;
2948 /* Do we need to open block here? XXXX */
2950 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2952 CvXSUB(cv)(aTHX_ cv);
2954 /* Enforce some sanity in scalar context. */
2955 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2956 if (markix > PL_stack_sp - PL_stack_base)
2957 *(PL_stack_base + markix) = &PL_sv_undef;
2959 *(PL_stack_base + markix) = *PL_stack_sp;
2960 PL_stack_sp = PL_stack_base + markix;
2968 Perl_sub_crush_depth(pTHX_ CV *cv)
2970 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2973 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2975 SV* const tmpstr = sv_newmortal();
2976 gv_efullname3(tmpstr, CvGV(cv), NULL);
2977 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2986 SV* const elemsv = POPs;
2987 IV elem = SvIV(elemsv);
2988 AV *const av = MUTABLE_AV(POPs);
2989 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2990 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2991 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2992 bool preeminent = TRUE;
2995 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2996 Perl_warner(aTHX_ packWARN(WARN_MISC),
2997 "Use of reference \"%"SVf"\" as array index",
3000 elem -= CopARYBASE_get(PL_curcop);
3001 if (SvTYPE(av) != SVt_PVAV)
3008 /* If we can determine whether the element exist,
3009 * Try to preserve the existenceness of a tied array
3010 * element by using EXISTS and DELETE if possible.
3011 * Fallback to FETCH and STORE otherwise. */
3012 if (SvCANEXISTDELETE(av))
3013 preeminent = av_exists(av, elem);
3016 svp = av_fetch(av, elem, lval && !defer);
3018 #ifdef PERL_MALLOC_WRAP
3019 if (SvUOK(elemsv)) {
3020 const UV uv = SvUV(elemsv);
3021 elem = uv > IV_MAX ? IV_MAX : uv;
3023 else if (SvNOK(elemsv))
3024 elem = (IV)SvNV(elemsv);
3026 static const char oom_array_extend[] =
3027 "Out of memory during array extend"; /* Duplicated in av.c */
3028 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3031 if (!svp || *svp == &PL_sv_undef) {
3034 DIE(aTHX_ PL_no_aelem, elem);
3035 lv = sv_newmortal();
3036 sv_upgrade(lv, SVt_PVLV);
3038 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3039 LvTARG(lv) = SvREFCNT_inc_simple(av);
3040 LvTARGOFF(lv) = elem;
3047 save_aelem(av, elem, svp);
3049 SAVEADELETE(av, elem);
3051 else if (PL_op->op_private & OPpDEREF)
3052 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3054 sv = (svp ? *svp : &PL_sv_undef);
3055 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3062 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3064 PERL_ARGS_ASSERT_VIVIFY_REF;
3069 Perl_croak_no_modify(aTHX);
3070 prepare_SV_for_RV(sv);
3073 SvRV_set(sv, newSV(0));
3076 SvRV_set(sv, MUTABLE_SV(newAV()));
3079 SvRV_set(sv, MUTABLE_SV(newHV()));
3090 SV* const sv = TOPs;
3093 SV* const rsv = SvRV(sv);
3094 if (SvTYPE(rsv) == SVt_PVCV) {
3100 SETs(method_common(sv, NULL));
3107 SV* const sv = cSVOP_sv;
3108 U32 hash = SvSHARED_HASH(sv);
3110 XPUSHs(method_common(sv, &hash));
3115 S_method_common(pTHX_ SV* meth, U32* hashp)
3121 const char* packname = NULL;
3124 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3126 PERL_ARGS_ASSERT_METHOD_COMMON;
3129 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3134 ob = MUTABLE_SV(SvRV(sv));
3138 /* this isn't a reference */
3139 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3140 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3142 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3149 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3150 !(ob=MUTABLE_SV(GvIO(iogv))))
3152 /* this isn't the name of a filehandle either */
3154 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3155 ? !isIDFIRST_utf8((U8*)packname)
3156 : !isIDFIRST(*packname)
3159 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3161 SvOK(sv) ? "without a package or object reference"
3162 : "on an undefined value");
3164 /* assume it's a package name */
3165 stash = gv_stashpvn(packname, packlen, 0);
3169 SV* const ref = newSViv(PTR2IV(stash));
3170 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3174 /* it _is_ a filehandle name -- replace with a reference */
3175 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3178 /* if we got here, ob should be a reference or a glob */
3179 if (!ob || !(SvOBJECT(ob)
3180 || (SvTYPE(ob) == SVt_PVGV
3182 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3185 const char * const name = SvPV_nolen_const(meth);
3186 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3187 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3191 stash = SvSTASH(ob);
3194 /* NOTE: stash may be null, hope hv_fetch_ent and
3195 gv_fetchmethod can cope (it seems they can) */
3197 /* shortcut for simple names */
3199 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3201 gv = MUTABLE_GV(HeVAL(he));
3202 if (isGV(gv) && GvCV(gv) &&
3203 (!GvCVGEN(gv) || GvCVGEN(gv)
3204 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3205 return MUTABLE_SV(GvCV(gv));
3209 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3210 SvPV_nolen_const(meth),
3211 GV_AUTOLOAD | GV_CROAK);
3215 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3220 * c-indentation-style: bsd
3222 * indent-tabs-mode: t
3225 * ex: set ts=8 sts=4 sw=4 noet: