3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
51 PL_curcop = (COP*)PL_op;
52 TAINT_NOT; /* Each statement is presumed innocent */
53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
64 if (PL_op->op_private & OPpLVAL_INTRO)
65 PUSHs(save_scalar(cGVOP_gv));
67 PUSHs(GvSVn(cGVOP_gv));
80 PUSHMARK(PL_stack_sp);
95 XPUSHs(MUTABLE_SV(cGVOP_gv));
106 if (PL_op->op_type == OP_AND)
108 RETURNOP(cLOGOP->op_other);
114 dVAR; dSP; dPOPTOPssrl;
116 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
117 SV * const temp = left;
118 left = right; right = temp;
120 if (PL_tainting && PL_tainted && !SvTAINTED(left))
122 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
123 SV * const cv = SvRV(left);
124 const U32 cv_type = SvTYPE(cv);
125 const bool is_gv = isGV_with_GP(right);
126 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
132 /* Can do the optimisation if right (LVALUE) is not a typeglob,
133 left (RVALUE) is a reference to something, and we're in void
135 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
136 /* Is the target symbol table currently empty? */
137 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
138 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
139 /* Good. Create a new proxy constant subroutine in the target.
140 The gv becomes a(nother) reference to the constant. */
141 SV *const value = SvRV(cv);
143 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
144 SvPCS_IMPORTED_on(gv);
146 SvREFCNT_inc_simple_void(value);
152 /* Need to fix things up. */
154 /* Need to fix GV. */
155 right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
159 /* We've been returned a constant rather than a full subroutine,
160 but they expect a subroutine reference to apply. */
162 ENTER_with_name("sassign_coderef");
163 SvREFCNT_inc_void(SvRV(cv));
164 /* newCONSTSUB takes a reference count on the passed in SV
165 from us. We set the name to NULL, otherwise we get into
166 all sorts of fun as the reference to our new sub is
167 donated to the GV that we're about to assign to.
169 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
172 LEAVE_with_name("sassign_coderef");
174 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
176 First: ops for \&{"BONK"}; return us the constant in the
178 Second: ops for *{"BONK"} cause that symbol table entry
179 (and our reference to it) to be upgraded from RV
181 Thirdly: We get here. cv is actually PVGV now, and its
182 GvCV() is actually the subroutine we're looking for
184 So change the reference so that it points to the subroutine
185 of that typeglob, as that's what they were after all along.
187 GV *const upgraded = MUTABLE_GV(cv);
188 CV *const source = GvCV(upgraded);
191 assert(CvFLAGS(source) & CVf_CONST);
193 SvREFCNT_inc_void(source);
194 SvREFCNT_dec(upgraded);
195 SvRV_set(left, MUTABLE_SV(source));
200 SvSetMagicSV(right, left);
210 RETURNOP(cLOGOP->op_other);
212 RETURNOP(cLOGOP->op_next);
219 TAINT_NOT; /* Each statement is presumed innocent */
220 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
222 if (!(PL_op->op_flags & OPf_SPECIAL)) {
223 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
224 LEAVE_SCOPE(oldsave);
231 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
236 const char *rpv = NULL;
238 bool rcopied = FALSE;
240 if (TARG == right && right != left) { /* $r = $l.$r */
241 rpv = SvPV_nomg_const(right, rlen);
242 rbyte = !DO_UTF8(right);
243 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
244 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
248 if (TARG != left) { /* not $l .= $r */
250 const char* const lpv = SvPV_nomg_const(left, llen);
251 lbyte = !DO_UTF8(left);
252 sv_setpvn(TARG, lpv, llen);
258 else { /* $l .= $r */
260 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
261 report_uninit(right);
264 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
265 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
272 /* $r.$r: do magic twice: tied might return different 2nd time */
274 rpv = SvPV_nomg_const(right, rlen);
275 rbyte = !DO_UTF8(right);
277 if (lbyte != rbyte) {
278 /* sv_utf8_upgrade_nomg() may reallocate the stack */
281 sv_utf8_upgrade_nomg(TARG);
284 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
285 sv_utf8_upgrade_nomg(right);
286 rpv = SvPV_nomg_const(right, rlen);
290 sv_catpvn_nomg(TARG, rpv, rlen);
301 if (PL_op->op_flags & OPf_MOD) {
302 if (PL_op->op_private & OPpLVAL_INTRO)
303 if (!(PL_op->op_private & OPpPAD_STATE))
304 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
305 if (PL_op->op_private & OPpDEREF) {
307 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
317 dSP; SvGETMAGIC(TOPs);
318 tryAMAGICunTARGET(iter_amg, 0, 0);
319 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
320 if (!isGV_with_GP(PL_last_in_gv)) {
321 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
322 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
325 XPUSHs(MUTABLE_SV(PL_last_in_gv));
328 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
331 return do_readline();
337 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
338 #ifndef NV_PRESERVES_UV
339 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
341 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
345 #ifdef PERL_PRESERVE_IVUV
346 SvIV_please_nomg(TOPs);
348 /* Unless the left argument is integer in range we are going
349 to have to use NV maths. Hence only attempt to coerce the
350 right argument if we know the left is integer. */
351 SvIV_please_nomg(TOPm1s);
353 const bool auvok = SvUOK(TOPm1s);
354 const bool buvok = SvUOK(TOPs);
356 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
357 /* Casting IV to UV before comparison isn't going to matter
358 on 2s complement. On 1s complement or sign&magnitude
359 (if we have any of them) it could to make negative zero
360 differ from normal zero. As I understand it. (Need to
361 check - is negative zero implementation defined behaviour
363 const UV buv = SvUVX(POPs);
364 const UV auv = SvUVX(TOPs);
366 SETs(boolSV(auv == buv));
369 { /* ## Mixed IV,UV ## */
373 /* == is commutative so doesn't matter which is left or right */
375 /* top of stack (b) is the iv */
384 /* As uv is a UV, it's >0, so it cannot be == */
387 /* we know iv is >= 0 */
388 SETs(boolSV((UV)iv == SvUVX(uvp)));
395 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
397 if (Perl_isnan(left) || Perl_isnan(right))
399 SETs(boolSV(left == right));
402 SETs(boolSV(SvNV_nomg(TOPs) == value));
411 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
412 Perl_croak_no_modify(aTHX);
413 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
414 && SvIVX(TOPs) != IV_MAX)
416 SvIV_set(TOPs, SvIVX(TOPs) + 1);
417 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
419 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
432 if (PL_op->op_type == OP_OR)
434 RETURNOP(cLOGOP->op_other);
443 const int op_type = PL_op->op_type;
444 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
449 if (!sv || !SvANY(sv)) {
450 if (op_type == OP_DOR)
452 RETURNOP(cLOGOP->op_other);
458 if (!sv || !SvANY(sv))
463 switch (SvTYPE(sv)) {
465 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
469 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
473 if (CvROOT(sv) || CvXSUB(sv))
486 if(op_type == OP_DOR)
488 RETURNOP(cLOGOP->op_other);
490 /* assuming OP_DEFINED */
498 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
499 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
503 useleft = USE_LEFT(svl);
504 #ifdef PERL_PRESERVE_IVUV
505 /* We must see if we can perform the addition with integers if possible,
506 as the integer code detects overflow while the NV code doesn't.
507 If either argument hasn't had a numeric conversion yet attempt to get
508 the IV. It's important to do this now, rather than just assuming that
509 it's not IOK as a PV of "9223372036854775806" may not take well to NV
510 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
511 integer in case the second argument is IV=9223372036854775806
512 We can (now) rely on sv_2iv to do the right thing, only setting the
513 public IOK flag if the value in the NV (or PV) slot is truly integer.
515 A side effect is that this also aggressively prefers integer maths over
516 fp maths for integer values.
518 How to detect overflow?
520 C 99 section 6.2.6.1 says
522 The range of nonnegative values of a signed integer type is a subrange
523 of the corresponding unsigned integer type, and the representation of
524 the same value in each type is the same. A computation involving
525 unsigned operands can never overflow, because a result that cannot be
526 represented by the resulting unsigned integer type is reduced modulo
527 the number that is one greater than the largest value that can be
528 represented by the resulting type.
532 which I read as "unsigned ints wrap."
534 signed integer overflow seems to be classed as "exception condition"
536 If an exceptional condition occurs during the evaluation of an
537 expression (that is, if the result is not mathematically defined or not
538 in the range of representable values for its type), the behavior is
541 (6.5, the 5th paragraph)
543 I had assumed that on 2s complement machines signed arithmetic would
544 wrap, hence coded pp_add and pp_subtract on the assumption that
545 everything perl builds on would be happy. After much wailing and
546 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
547 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
548 unsigned code below is actually shorter than the old code. :-)
551 SvIV_please_nomg(svr);
554 /* Unless the left argument is integer in range we are going to have to
555 use NV maths. Hence only attempt to coerce the right argument if
556 we know the left is integer. */
564 /* left operand is undef, treat as zero. + 0 is identity,
565 Could SETi or SETu right now, but space optimise by not adding
566 lots of code to speed up what is probably a rarish case. */
568 /* Left operand is defined, so is it IV? */
569 SvIV_please_nomg(svl);
571 if ((auvok = SvUOK(svl)))
574 register const IV aiv = SvIVX(svl);
577 auvok = 1; /* Now acting as a sign flag. */
578 } else { /* 2s complement assumption for IV_MIN */
586 bool result_good = 0;
589 bool buvok = SvUOK(svr);
594 register const IV biv = SvIVX(svr);
601 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
602 else "IV" now, independent of how it came in.
603 if a, b represents positive, A, B negative, a maps to -A etc
608 all UV maths. negate result if A negative.
609 add if signs same, subtract if signs differ. */
615 /* Must get smaller */
621 /* result really should be -(auv-buv). as its negation
622 of true value, need to swap our result flag */
639 if (result <= (UV)IV_MIN)
642 /* result valid, but out of range for IV. */
647 } /* Overflow, drop through to NVs. */
652 NV value = SvNV_nomg(svr);
655 /* left operand is undef, treat as zero. + 0.0 is identity. */
659 SETn( value + SvNV_nomg(svl) );
667 AV * const av = PL_op->op_flags & OPf_SPECIAL
668 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
669 const U32 lval = PL_op->op_flags & OPf_MOD;
670 SV** const svp = av_fetch(av, PL_op->op_private, lval);
671 SV *sv = (svp ? *svp : &PL_sv_undef);
673 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
681 dVAR; dSP; dMARK; dTARGET;
683 do_join(TARG, *MARK, MARK, SP);
694 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
695 * will be enough to hold an OP*.
697 SV* const sv = sv_newmortal();
698 sv_upgrade(sv, SVt_PVLV);
700 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
703 XPUSHs(MUTABLE_SV(PL_op));
708 /* Oversized hot code. */
712 dVAR; dSP; dMARK; dORIGMARK;
716 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
720 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
723 if (MARK == ORIGMARK) {
724 /* If using default handle then we need to make space to
725 * pass object as 1st arg, so move other args up ...
729 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
732 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
734 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
735 | (PL_op->op_type == OP_SAY
736 ? TIED_METHOD_SAY : 0)), sp - mark);
739 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
740 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
743 SETERRNO(EBADF,RMS_IFI);
746 else if (!(fp = IoOFP(io))) {
748 report_wrongway_fh(gv, '<');
751 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
755 SV * const ofs = GvSV(PL_ofsgv); /* $, */
757 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
759 if (!do_print(*MARK, fp))
763 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
764 if (!do_print(GvSV(PL_ofsgv), fp)) {
773 if (!do_print(*MARK, fp))
781 if (PL_op->op_type == OP_SAY) {
782 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
785 else if (PL_ors_sv && SvOK(PL_ors_sv))
786 if (!do_print(PL_ors_sv, fp)) /* $\ */
789 if (IoFLAGS(io) & IOf_FLUSH)
790 if (PerlIO_flush(fp) == EOF)
800 XPUSHs(&PL_sv_undef);
807 const I32 gimme = GIMME_V;
808 static const char an_array[] = "an ARRAY";
809 static const char a_hash[] = "a HASH";
810 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
811 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
813 if (!(PL_op->op_private & OPpDEREFed))
817 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
821 if (SvTYPE(sv) != type)
822 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
823 if (PL_op->op_flags & OPf_REF) {
828 if (gimme != G_ARRAY)
829 goto croak_cant_return;
833 else if (PL_op->op_flags & OPf_MOD
834 && PL_op->op_private & OPpLVAL_INTRO)
835 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
838 if (SvTYPE(sv) == type) {
839 if (PL_op->op_flags & OPf_REF) {
844 if (gimme != G_ARRAY)
845 goto croak_cant_return;
853 if (!isGV_with_GP(sv)) {
854 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
862 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
863 if (PL_op->op_private & OPpLVAL_INTRO)
864 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
865 if (PL_op->op_flags & OPf_REF) {
870 if (gimme != G_ARRAY)
871 goto croak_cant_return;
879 AV *const av = MUTABLE_AV(sv);
880 /* The guts of pp_rv2av, with no intending change to preserve history
881 (until such time as we get tools that can do blame annotation across
882 whitespace changes. */
883 if (gimme == G_ARRAY) {
884 const I32 maxarg = AvFILL(av) + 1;
885 (void)POPs; /* XXXX May be optimized away? */
887 if (SvRMAGICAL(av)) {
889 for (i=0; i < (U32)maxarg; i++) {
890 SV ** const svp = av_fetch(av, i, FALSE);
891 /* See note in pp_helem, and bug id #27839 */
893 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
898 Copy(AvARRAY(av), SP+1, maxarg, SV*);
902 else if (gimme == G_SCALAR) {
904 const I32 maxarg = AvFILL(av) + 1;
908 /* The guts of pp_rv2hv */
909 if (gimme == G_ARRAY) { /* array wanted */
911 return Perl_do_kv(aTHX);
913 else if (gimme == G_SCALAR) {
915 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
923 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
924 is_pp_rv2av ? "array" : "hash");
929 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
933 PERL_ARGS_ASSERT_DO_ODDBALL;
939 if (ckWARN(WARN_MISC)) {
941 if (relem == firstrelem &&
943 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
944 SvTYPE(SvRV(*relem)) == SVt_PVHV))
946 err = "Reference found where even-sized list expected";
949 err = "Odd number of elements in hash assignment";
950 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
954 didstore = hv_store_ent(hash,*relem,tmpstr,0);
955 if (SvMAGICAL(hash)) {
956 if (SvSMAGICAL(tmpstr))
968 SV **lastlelem = PL_stack_sp;
969 SV **lastrelem = PL_stack_base + POPMARK;
970 SV **firstrelem = PL_stack_base + POPMARK + 1;
971 SV **firstlelem = lastrelem + 1;
984 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
986 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
989 /* If there's a common identifier on both sides we have to take
990 * special care that assigning the identifier on the left doesn't
991 * clobber a value on the right that's used later in the list.
992 * Don't bother if LHS is just an empty hash or array.
995 if ( (PL_op->op_private & OPpASSIGN_COMMON)
997 firstlelem != lastlelem
998 || ! ((sv = *firstlelem))
1000 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1001 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1002 || (SvTYPE(sv) == SVt_PVHV && HvKEYS((HV*)sv) != 0)
1005 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1006 for (relem = firstrelem; relem <= lastrelem; relem++) {
1007 if ((sv = *relem)) {
1008 TAINT_NOT; /* Each item is independent */
1010 /* Dear TODO test in t/op/sort.t, I love you.
1011 (It's relying on a panic, not a "semi-panic" from newSVsv()
1012 and then an assertion failure below.) */
1013 if (SvIS_FREED(sv)) {
1014 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1017 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1018 and we need a second copy of a temp here. */
1019 *relem = sv_2mortal(newSVsv(sv));
1029 while (lelem <= lastlelem) {
1030 TAINT_NOT; /* Each item stands on its own, taintwise. */
1032 switch (SvTYPE(sv)) {
1034 ary = MUTABLE_AV(sv);
1035 magic = SvMAGICAL(ary) != 0;
1037 av_extend(ary, lastrelem - relem);
1039 while (relem <= lastrelem) { /* gobble up all the rest */
1043 sv_setsv(sv, *relem);
1045 didstore = av_store(ary,i++,sv);
1054 if (PL_delaymagic & DM_ARRAY_ISA)
1055 SvSETMAGIC(MUTABLE_SV(ary));
1057 case SVt_PVHV: { /* normal hash */
1059 SV** topelem = relem;
1061 hash = MUTABLE_HV(sv);
1062 magic = SvMAGICAL(hash) != 0;
1064 firsthashrelem = relem;
1066 while (relem < lastrelem) { /* gobble up all the rest */
1068 sv = *relem ? *relem : &PL_sv_no;
1072 sv_setsv(tmpstr,*relem); /* value */
1074 if (gimme != G_VOID) {
1075 if (hv_exists_ent(hash, sv, 0))
1076 /* key overwrites an existing entry */
1079 if (gimme == G_ARRAY) {
1080 /* copy element back: possibly to an earlier
1081 * stack location if we encountered dups earlier */
1083 *topelem++ = tmpstr;
1086 didstore = hv_store_ent(hash,sv,tmpstr,0);
1088 if (SvSMAGICAL(tmpstr))
1095 if (relem == lastrelem) {
1096 do_oddball(hash, relem, firstrelem);
1102 if (SvIMMORTAL(sv)) {
1103 if (relem <= lastrelem)
1107 if (relem <= lastrelem) {
1108 sv_setsv(sv, *relem);
1112 sv_setsv(sv, &PL_sv_undef);
1117 if (PL_delaymagic & ~DM_DELAY) {
1118 if (PL_delaymagic & DM_UID) {
1119 #ifdef HAS_SETRESUID
1120 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1121 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1124 # ifdef HAS_SETREUID
1125 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1126 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1129 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1130 (void)setruid(PL_uid);
1131 PL_delaymagic &= ~DM_RUID;
1133 # endif /* HAS_SETRUID */
1135 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1136 (void)seteuid(PL_euid);
1137 PL_delaymagic &= ~DM_EUID;
1139 # endif /* HAS_SETEUID */
1140 if (PL_delaymagic & DM_UID) {
1141 if (PL_uid != PL_euid)
1142 DIE(aTHX_ "No setreuid available");
1143 (void)PerlProc_setuid(PL_uid);
1145 # endif /* HAS_SETREUID */
1146 #endif /* HAS_SETRESUID */
1147 PL_uid = PerlProc_getuid();
1148 PL_euid = PerlProc_geteuid();
1150 if (PL_delaymagic & DM_GID) {
1151 #ifdef HAS_SETRESGID
1152 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1153 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1156 # ifdef HAS_SETREGID
1157 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1158 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1161 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1162 (void)setrgid(PL_gid);
1163 PL_delaymagic &= ~DM_RGID;
1165 # endif /* HAS_SETRGID */
1167 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1168 (void)setegid(PL_egid);
1169 PL_delaymagic &= ~DM_EGID;
1171 # endif /* HAS_SETEGID */
1172 if (PL_delaymagic & DM_GID) {
1173 if (PL_gid != PL_egid)
1174 DIE(aTHX_ "No setregid available");
1175 (void)PerlProc_setgid(PL_gid);
1177 # endif /* HAS_SETREGID */
1178 #endif /* HAS_SETRESGID */
1179 PL_gid = PerlProc_getgid();
1180 PL_egid = PerlProc_getegid();
1182 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1186 if (gimme == G_VOID)
1187 SP = firstrelem - 1;
1188 else if (gimme == G_SCALAR) {
1191 SETi(lastrelem - firstrelem + 1 - duplicates);
1198 /* at this point we have removed the duplicate key/value
1199 * pairs from the stack, but the remaining values may be
1200 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1201 * the (a 2), but the stack now probably contains
1202 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1203 * obliterates the earlier key. So refresh all values. */
1204 lastrelem -= duplicates;
1205 relem = firsthashrelem;
1206 while (relem < lastrelem) {
1209 he = hv_fetch_ent(hash, sv, 0, 0);
1210 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1216 SP = firstrelem + (lastlelem - firstlelem);
1217 lelem = firstlelem + (relem - firstrelem);
1219 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1228 register PMOP * const pm = cPMOP;
1229 REGEXP * rx = PM_GETRE(pm);
1230 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1231 SV * const rv = sv_newmortal();
1233 SvUPGRADE(rv, SVt_IV);
1234 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1235 loathe to use it here, but it seems to be the right fix. Or close.
1236 The key part appears to be that it's essential for pp_qr to return a new
1237 object (SV), which implies that there needs to be an effective way to
1238 generate a new SV from the existing SV that is pre-compiled in the
1240 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1244 HV *const stash = gv_stashsv(pkg, GV_ADD);
1246 (void)sv_bless(rv, stash);
1249 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1251 SvTAINTED_on(SvRV(rv));
1260 register PMOP *pm = cPMOP;
1262 register const char *t;
1263 register const char *s;
1266 U8 r_flags = REXEC_CHECKED;
1267 const char *truebase; /* Start of string */
1268 register REGEXP *rx = PM_GETRE(pm);
1270 const I32 gimme = GIMME;
1273 const I32 oldsave = PL_savestack_ix;
1274 I32 update_minmatch = 1;
1275 I32 had_zerolen = 0;
1278 if (PL_op->op_flags & OPf_STACKED)
1280 else if (PL_op->op_private & OPpTARGET_MY)
1287 PUTBACK; /* EVAL blocks need stack_sp. */
1288 /* Skip get-magic if this is a qr// clone, because regcomp has
1290 s = ((struct regexp *)SvANY(rx))->mother_re
1291 ? SvPV_nomg_const(TARG, len)
1292 : SvPV_const(TARG, len);
1294 DIE(aTHX_ "panic: pp_match");
1296 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1297 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1300 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1302 /* PMdf_USED is set after a ?? matches once */
1305 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1307 pm->op_pmflags & PMf_USED
1311 if (gimme == G_ARRAY)
1318 /* empty pattern special-cased to use last successful pattern if possible */
1319 if (!RX_PRELEN(rx) && PL_curpm) {
1324 if (RX_MINLEN(rx) > (I32)len)
1329 /* XXXX What part of this is needed with true \G-support? */
1330 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1331 RX_OFFS(rx)[0].start = -1;
1332 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1333 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1334 if (mg && mg->mg_len >= 0) {
1335 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1336 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1337 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1338 r_flags |= REXEC_IGNOREPOS;
1339 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1340 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1343 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1344 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1345 update_minmatch = 0;
1349 /* XXX: comment out !global get safe $1 vars after a
1350 match, BUT be aware that this leads to dramatic slowdowns on
1351 /g matches against large strings. So far a solution to this problem
1352 appears to be quite tricky.
1353 Test for the unsafe vars are TODO for now. */
1354 if ( (!global && RX_NPARENS(rx))
1355 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1356 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1357 r_flags |= REXEC_COPY_STR;
1359 r_flags |= REXEC_SCREAM;
1362 if (global && RX_OFFS(rx)[0].start != -1) {
1363 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1364 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1366 if (update_minmatch++)
1367 minmatch = had_zerolen;
1369 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1370 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1371 /* FIXME - can PL_bostr be made const char *? */
1372 PL_bostr = (char *)truebase;
1373 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1377 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1379 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1380 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1381 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1382 && (r_flags & REXEC_SCREAM)))
1383 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1386 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1387 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1390 if (dynpm->op_pmflags & PMf_ONCE) {
1392 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1394 dynpm->op_pmflags |= PMf_USED;
1405 RX_MATCH_TAINTED_on(rx);
1406 TAINT_IF(RX_MATCH_TAINTED(rx));
1407 if (gimme == G_ARRAY) {
1408 const I32 nparens = RX_NPARENS(rx);
1409 I32 i = (global && !nparens) ? 1 : 0;
1411 SPAGAIN; /* EVAL blocks could move the stack. */
1412 EXTEND(SP, nparens + i);
1413 EXTEND_MORTAL(nparens + i);
1414 for (i = !i; i <= nparens; i++) {
1415 PUSHs(sv_newmortal());
1416 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1417 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1418 s = RX_OFFS(rx)[i].start + truebase;
1419 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1420 len < 0 || len > strend - s)
1421 DIE(aTHX_ "panic: pp_match start/end pointers");
1422 sv_setpvn(*SP, s, len);
1423 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1428 if (dynpm->op_pmflags & PMf_CONTINUE) {
1430 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1431 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1433 #ifdef PERL_OLD_COPY_ON_WRITE
1435 sv_force_normal_flags(TARG, 0);
1437 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1438 &PL_vtbl_mglob, NULL, 0);
1440 if (RX_OFFS(rx)[0].start != -1) {
1441 mg->mg_len = RX_OFFS(rx)[0].end;
1442 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1443 mg->mg_flags |= MGf_MINMATCH;
1445 mg->mg_flags &= ~MGf_MINMATCH;
1448 had_zerolen = (RX_OFFS(rx)[0].start != -1
1449 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1450 == (UV)RX_OFFS(rx)[0].end));
1451 PUTBACK; /* EVAL blocks may use stack */
1452 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1457 LEAVE_SCOPE(oldsave);
1463 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1464 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1468 #ifdef PERL_OLD_COPY_ON_WRITE
1470 sv_force_normal_flags(TARG, 0);
1472 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1473 &PL_vtbl_mglob, NULL, 0);
1475 if (RX_OFFS(rx)[0].start != -1) {
1476 mg->mg_len = RX_OFFS(rx)[0].end;
1477 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1478 mg->mg_flags |= MGf_MINMATCH;
1480 mg->mg_flags &= ~MGf_MINMATCH;
1483 LEAVE_SCOPE(oldsave);
1487 yup: /* Confirmed by INTUIT */
1489 RX_MATCH_TAINTED_on(rx);
1490 TAINT_IF(RX_MATCH_TAINTED(rx));
1492 if (dynpm->op_pmflags & PMf_ONCE) {
1494 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1496 dynpm->op_pmflags |= PMf_USED;
1499 if (RX_MATCH_COPIED(rx))
1500 Safefree(RX_SUBBEG(rx));
1501 RX_MATCH_COPIED_off(rx);
1502 RX_SUBBEG(rx) = NULL;
1504 /* FIXME - should rx->subbeg be const char *? */
1505 RX_SUBBEG(rx) = (char *) truebase;
1506 RX_OFFS(rx)[0].start = s - truebase;
1507 if (RX_MATCH_UTF8(rx)) {
1508 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1509 RX_OFFS(rx)[0].end = t - truebase;
1512 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1514 RX_SUBLEN(rx) = strend - truebase;
1517 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1519 #ifdef PERL_OLD_COPY_ON_WRITE
1520 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1522 PerlIO_printf(Perl_debug_log,
1523 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1524 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1527 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1529 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1530 assert (SvPOKp(RX_SAVED_COPY(rx)));
1535 RX_SUBBEG(rx) = savepvn(t, strend - t);
1536 #ifdef PERL_OLD_COPY_ON_WRITE
1537 RX_SAVED_COPY(rx) = NULL;
1540 RX_SUBLEN(rx) = strend - t;
1541 RX_MATCH_COPIED_on(rx);
1542 off = RX_OFFS(rx)[0].start = s - t;
1543 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1545 else { /* startp/endp are used by @- @+. */
1546 RX_OFFS(rx)[0].start = s - truebase;
1547 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1549 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1551 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1552 LEAVE_SCOPE(oldsave);
1557 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1558 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1559 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1564 LEAVE_SCOPE(oldsave);
1565 if (gimme == G_ARRAY)
1571 Perl_do_readline(pTHX)
1573 dVAR; dSP; dTARGETSTACKED;
1578 register IO * const io = GvIO(PL_last_in_gv);
1579 register const I32 type = PL_op->op_type;
1580 const I32 gimme = GIMME_V;
1583 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1585 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1586 if (gimme == G_SCALAR) {
1588 SvSetSV_nosteal(TARG, TOPs);
1598 if (IoFLAGS(io) & IOf_ARGV) {
1599 if (IoFLAGS(io) & IOf_START) {
1601 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1602 IoFLAGS(io) &= ~IOf_START;
1603 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1604 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1605 SvSETMAGIC(GvSV(PL_last_in_gv));
1610 fp = nextargv(PL_last_in_gv);
1611 if (!fp) { /* Note: fp != IoIFP(io) */
1612 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1615 else if (type == OP_GLOB)
1616 fp = Perl_start_glob(aTHX_ POPs, io);
1618 else if (type == OP_GLOB)
1620 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1621 report_wrongway_fh(PL_last_in_gv, '>');
1625 if ((!io || !(IoFLAGS(io) & IOf_START))
1626 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1628 if (type == OP_GLOB)
1629 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1630 "glob failed (can't start child: %s)",
1633 report_evil_fh(PL_last_in_gv);
1635 if (gimme == G_SCALAR) {
1636 /* undef TARG, and push that undefined value */
1637 if (type != OP_RCATLINE) {
1638 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1646 if (gimme == G_SCALAR) {
1648 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1651 if (type == OP_RCATLINE)
1652 SvPV_force_nolen(sv);
1656 else if (isGV_with_GP(sv)) {
1657 SvPV_force_nolen(sv);
1659 SvUPGRADE(sv, SVt_PV);
1660 tmplen = SvLEN(sv); /* remember if already alloced */
1661 if (!tmplen && !SvREADONLY(sv)) {
1662 /* try short-buffering it. Please update t/op/readline.t
1663 * if you change the growth length.
1668 if (type == OP_RCATLINE && SvOK(sv)) {
1670 SvPV_force_nolen(sv);
1676 sv = sv_2mortal(newSV(80));
1680 /* This should not be marked tainted if the fp is marked clean */
1681 #define MAYBE_TAINT_LINE(io, sv) \
1682 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1687 /* delay EOF state for a snarfed empty file */
1688 #define SNARF_EOF(gimme,rs,io,sv) \
1689 (gimme != G_SCALAR || SvCUR(sv) \
1690 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1694 if (!sv_gets(sv, fp, offset)
1696 || SNARF_EOF(gimme, PL_rs, io, sv)
1697 || PerlIO_error(fp)))
1699 PerlIO_clearerr(fp);
1700 if (IoFLAGS(io) & IOf_ARGV) {
1701 fp = nextargv(PL_last_in_gv);
1704 (void)do_close(PL_last_in_gv, FALSE);
1706 else if (type == OP_GLOB) {
1707 if (!do_close(PL_last_in_gv, FALSE)) {
1708 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1709 "glob failed (child exited with status %d%s)",
1710 (int)(STATUS_CURRENT >> 8),
1711 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1714 if (gimme == G_SCALAR) {
1715 if (type != OP_RCATLINE) {
1716 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1722 MAYBE_TAINT_LINE(io, sv);
1725 MAYBE_TAINT_LINE(io, sv);
1727 IoFLAGS(io) |= IOf_NOLINE;
1731 if (type == OP_GLOB) {
1734 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1735 char * const tmps = SvEND(sv) - 1;
1736 if (*tmps == *SvPVX_const(PL_rs)) {
1738 SvCUR_set(sv, SvCUR(sv) - 1);
1741 for (t1 = SvPVX_const(sv); *t1; t1++)
1742 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1743 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1745 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1746 (void)POPs; /* Unmatched wildcard? Chuck it... */
1749 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1750 if (ckWARN(WARN_UTF8)) {
1751 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1752 const STRLEN len = SvCUR(sv) - offset;
1755 if (!is_utf8_string_loc(s, len, &f))
1756 /* Emulate :encoding(utf8) warning in the same case. */
1757 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1758 "utf8 \"\\x%02X\" does not map to Unicode",
1759 f < (U8*)SvEND(sv) ? *f : 0);
1762 if (gimme == G_ARRAY) {
1763 if (SvLEN(sv) - SvCUR(sv) > 20) {
1764 SvPV_shrink_to_cur(sv);
1766 sv = sv_2mortal(newSV(80));
1769 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1770 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1771 const STRLEN new_len
1772 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1773 SvPV_renew(sv, new_len);
1782 register PERL_CONTEXT *cx;
1783 I32 gimme = OP_GIMME(PL_op, -1);
1786 if (cxstack_ix >= 0) {
1787 /* If this flag is set, we're just inside a return, so we should
1788 * store the caller's context */
1789 gimme = (PL_op->op_flags & OPf_SPECIAL)
1791 : cxstack[cxstack_ix].blk_gimme;
1796 ENTER_with_name("block");
1799 PUSHBLOCK(cx, CXt_BLOCK, SP);
1809 SV * const keysv = POPs;
1810 HV * const hv = MUTABLE_HV(POPs);
1811 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1812 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1814 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1815 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1816 bool preeminent = TRUE;
1818 if (SvTYPE(hv) != SVt_PVHV)
1825 /* If we can determine whether the element exist,
1826 * Try to preserve the existenceness of a tied hash
1827 * element by using EXISTS and DELETE if possible.
1828 * Fallback to FETCH and STORE otherwise. */
1829 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1830 preeminent = hv_exists_ent(hv, keysv, 0);
1833 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1834 svp = he ? &HeVAL(he) : NULL;
1836 if (!svp || *svp == &PL_sv_undef) {
1840 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1842 lv = sv_newmortal();
1843 sv_upgrade(lv, SVt_PVLV);
1845 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1846 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1847 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1853 if (HvNAME_get(hv) && isGV(*svp))
1854 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1855 else if (preeminent)
1856 save_helem_flags(hv, keysv, svp,
1857 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1859 SAVEHDELETE(hv, keysv);
1861 else if (PL_op->op_private & OPpDEREF)
1862 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1864 sv = (svp ? *svp : &PL_sv_undef);
1865 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1866 * was to make C<local $tied{foo} = $tied{foo}> possible.
1867 * However, it seems no longer to be needed for that purpose, and
1868 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1869 * would loop endlessly since the pos magic is getting set on the
1870 * mortal copy and lost. However, the copy has the effect of
1871 * triggering the get magic, and losing it altogether made things like
1872 * c<$tied{foo};> in void context no longer do get magic, which some
1873 * code relied on. Also, delayed triggering of magic on @+ and friends
1874 * meant the original regex may be out of scope by now. So as a
1875 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1876 * being called too many times). */
1877 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1886 register PERL_CONTEXT *cx;
1891 if (PL_op->op_flags & OPf_SPECIAL) {
1892 cx = &cxstack[cxstack_ix];
1893 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1898 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1901 if (gimme == G_VOID)
1903 else if (gimme == G_SCALAR) {
1907 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1910 *MARK = sv_mortalcopy(TOPs);
1913 *MARK = &PL_sv_undef;
1917 else if (gimme == G_ARRAY) {
1918 /* in case LEAVE wipes old return values */
1920 for (mark = newsp + 1; mark <= SP; mark++) {
1921 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1922 *mark = sv_mortalcopy(*mark);
1923 TAINT_NOT; /* Each item is independent */
1927 PL_curpm = newpm; /* Don't pop $1 et al till now */
1929 LEAVE_with_name("block");
1937 register PERL_CONTEXT *cx;
1940 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1941 bool av_is_stack = FALSE;
1944 cx = &cxstack[cxstack_ix];
1945 if (!CxTYPE_is_LOOP(cx))
1946 DIE(aTHX_ "panic: pp_iter");
1948 itersvp = CxITERVAR(cx);
1949 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1950 /* string increment */
1951 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1952 SV *end = cx->blk_loop.state_u.lazysv.end;
1953 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1954 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1956 const char *max = SvPV_const(end, maxlen);
1957 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1958 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1959 /* safe to reuse old SV */
1960 sv_setsv(*itersvp, cur);
1964 /* we need a fresh SV every time so that loop body sees a
1965 * completely new SV for closures/references to work as
1968 *itersvp = newSVsv(cur);
1969 SvREFCNT_dec(oldsv);
1971 if (strEQ(SvPVX_const(cur), max))
1972 sv_setiv(cur, 0); /* terminate next time */
1979 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1980 /* integer increment */
1981 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1984 /* don't risk potential race */
1985 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1986 /* safe to reuse old SV */
1987 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1991 /* we need a fresh SV every time so that loop body sees a
1992 * completely new SV for closures/references to work as they
1995 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1996 SvREFCNT_dec(oldsv);
1999 /* Handle end of range at IV_MAX */
2000 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
2001 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2003 cx->blk_loop.state_u.lazyiv.cur++;
2004 cx->blk_loop.state_u.lazyiv.end++;
2011 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2012 av = cx->blk_loop.state_u.ary.ary;
2017 if (PL_op->op_private & OPpITER_REVERSED) {
2018 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2019 ? cx->blk_loop.resetsp + 1 : 0))
2022 if (SvMAGICAL(av) || AvREIFY(av)) {
2023 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2024 sv = svp ? *svp : NULL;
2027 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2031 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2035 if (SvMAGICAL(av) || AvREIFY(av)) {
2036 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2037 sv = svp ? *svp : NULL;
2040 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2044 if (sv && SvIS_FREED(sv)) {
2046 Perl_croak(aTHX_ "Use of freed value in iteration");
2051 SvREFCNT_inc_simple_void_NN(sv);
2055 if (!av_is_stack && sv == &PL_sv_undef) {
2056 SV *lv = newSV_type(SVt_PVLV);
2058 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2059 LvTARG(lv) = SvREFCNT_inc_simple(av);
2060 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2061 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2067 SvREFCNT_dec(oldsv);
2073 A description of how taint works in pattern matching and substitution.
2075 While the pattern is being assembled/concatenated and them compiled,
2076 PL_tainted will get set if any component of the pattern is tainted, e.g.
2077 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
2078 is set on the pattern if PL_tainted is set.
2080 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2081 the pattern is marked as tainted. This means that subsequent usage, such
2082 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
2084 During execution of a pattern, locale-variant ops such as ALNUML set the
2085 local flag RF_tainted. At the end of execution, the engine sets the
2086 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2089 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2090 of $1 et al to indicate whether the returned value should be tainted.
2091 It is the responsibility of the caller of the pattern (i.e. pp_match,
2092 pp_subst etc) to set this flag for any other circumstances where $1 needs
2095 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2097 There are three possible sources of taint
2099 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2100 * the replacement string (or expression under /e)
2102 There are four destinations of taint and they are affected by the sources
2103 according to the rules below:
2105 * the return value (not including /r):
2106 tainted by the source string and pattern, but only for the
2107 number-of-iterations case; boolean returns aren't tainted;
2108 * the modified string (or modified copy under /r):
2109 tainted by the source string, pattern, and replacement strings;
2111 tainted by the pattern, and under 'use re "taint"', by the source
2113 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2114 should always be unset before executing subsequent code.
2116 The overall action of pp_subst is:
2118 * at the start, set bits in rxtainted indicating the taint status of
2119 the various sources.
2121 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2122 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2123 pattern has subsequently become tainted via locale ops.
2125 * If control is being passed to pp_substcont to execute a /e block,
2126 save rxtainted in the CXt_SUBST block, for future use by
2129 * Whenever control is being returned to perl code (either by falling
2130 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2131 use the flag bits in rxtainted to make all the appropriate types of
2132 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2133 et al will appear tainted.
2135 pp_match is just a simpler version of the above.
2142 register PMOP *pm = cPMOP;
2154 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2155 See "how taint works" above */
2158 register REGEXP *rx = PM_GETRE(pm);
2160 int force_on_match = 0;
2161 const I32 oldsave = PL_savestack_ix;
2163 bool doutf8 = FALSE;
2164 #ifdef PERL_OLD_COPY_ON_WRITE
2168 /* known replacement string? */
2169 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2173 if (PL_op->op_flags & OPf_STACKED)
2175 else if (PL_op->op_private & OPpTARGET_MY)
2182 /* In non-destructive replacement mode, duplicate target scalar so it
2183 * remains unchanged. */
2184 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2185 TARG = sv_2mortal(newSVsv(TARG));
2187 #ifdef PERL_OLD_COPY_ON_WRITE
2188 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2189 because they make integers such as 256 "false". */
2190 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2193 sv_force_normal_flags(TARG,0);
2196 #ifdef PERL_OLD_COPY_ON_WRITE
2200 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2201 || SvTYPE(TARG) > SVt_PVLV)
2202 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2203 Perl_croak_no_modify(aTHX);
2207 s = SvPV_mutable(TARG, len);
2208 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2211 /* only replace once? */
2212 once = !(rpm->op_pmflags & PMf_GLOBAL);
2214 /* See "how taint works" above */
2217 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2218 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2219 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2220 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2221 ? SUBST_TAINT_BOOLRET : 0));
2225 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2229 DIE(aTHX_ "panic: pp_subst");
2232 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2233 maxiters = 2 * slen + 10; /* We can match twice at each
2234 position, once with zero-length,
2235 second time with non-zero. */
2237 if (!RX_PRELEN(rx) && PL_curpm) {
2241 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2242 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2243 ? REXEC_COPY_STR : 0;
2245 r_flags |= REXEC_SCREAM;
2248 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2250 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2254 /* How to do it in subst? */
2255 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2257 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2258 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2259 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2260 && (r_flags & REXEC_SCREAM))))
2265 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2266 r_flags | REXEC_CHECKED))
2270 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2271 LEAVE_SCOPE(oldsave);
2275 /* known replacement string? */
2277 if (SvTAINTED(dstr))
2278 rxtainted |= SUBST_TAINT_REPL;
2280 /* Upgrade the source if the replacement is utf8 but the source is not,
2281 * but only if it matched; see
2282 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2284 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2285 char * const orig_pvx = SvPVX(TARG);
2286 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2288 /* If the lengths are the same, the pattern contains only
2289 * invariants, can keep going; otherwise, various internal markers
2290 * could be off, so redo */
2291 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2296 /* replacement needing upgrading? */
2297 if (DO_UTF8(TARG) && !doutf8) {
2298 nsv = sv_newmortal();
2301 sv_recode_to_utf8(nsv, PL_encoding);
2303 sv_utf8_upgrade(nsv);
2304 c = SvPV_const(nsv, clen);
2308 c = SvPV_const(dstr, clen);
2309 doutf8 = DO_UTF8(dstr);
2317 /* can do inplace substitution? */
2319 #ifdef PERL_OLD_COPY_ON_WRITE
2322 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2323 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2324 && (!doutf8 || SvUTF8(TARG)))
2327 #ifdef PERL_OLD_COPY_ON_WRITE
2328 if (SvIsCOW(TARG)) {
2329 assert (!force_on_match);
2333 if (force_on_match) {
2335 s = SvPV_force(TARG, len);
2340 SvSCREAM_off(TARG); /* disable possible screamer */
2342 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2343 rxtainted |= SUBST_TAINT_PAT;
2344 m = orig + RX_OFFS(rx)[0].start;
2345 d = orig + RX_OFFS(rx)[0].end;
2347 if (m - s > strend - d) { /* faster to shorten from end */
2349 Copy(c, m, clen, char);
2354 Move(d, m, i, char);
2358 SvCUR_set(TARG, m - s);
2360 else if ((i = m - s)) { /* faster from front */
2363 Move(s, d - i, i, char);
2366 Copy(c, m, clen, char);
2371 Copy(c, d, clen, char);
2377 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
2381 if (iters++ > maxiters)
2382 DIE(aTHX_ "Substitution loop");
2383 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2384 rxtainted |= SUBST_TAINT_PAT;
2385 m = RX_OFFS(rx)[0].start + orig;
2388 Move(s, d, i, char);
2392 Copy(c, d, clen, char);
2395 s = RX_OFFS(rx)[0].end + orig;
2396 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2398 /* don't match same null twice */
2399 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2402 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2403 Move(s, d, i+1, char); /* include the NUL */
2406 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2413 if (force_on_match) {
2415 s = SvPV_force(TARG, len);
2418 #ifdef PERL_OLD_COPY_ON_WRITE
2421 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2422 rxtainted |= SUBST_TAINT_PAT;
2423 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2427 register PERL_CONTEXT *cx;
2429 /* note that a whole bunch of local vars are saved here for
2430 * use by pp_substcont: here's a list of them in case you're
2431 * searching for places in this sub that uses a particular var:
2432 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2433 * s m strend rx once */
2435 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2437 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2439 if (iters++ > maxiters)
2440 DIE(aTHX_ "Substitution loop");
2441 if (RX_MATCH_TAINTED(rx))
2442 rxtainted |= SUBST_TAINT_PAT;
2443 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2446 orig = RX_SUBBEG(rx);
2448 strend = s + (strend - m);
2450 m = RX_OFFS(rx)[0].start + orig;
2451 if (doutf8 && !SvUTF8(dstr))
2452 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2454 sv_catpvn(dstr, s, m-s);
2455 s = RX_OFFS(rx)[0].end + orig;
2457 sv_catpvn(dstr, c, clen);
2460 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2461 TARG, NULL, r_flags));
2462 if (doutf8 && !DO_UTF8(TARG))
2463 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2465 sv_catpvn(dstr, s, strend - s);
2467 #ifdef PERL_OLD_COPY_ON_WRITE
2468 /* The match may make the string COW. If so, brilliant, because that's
2469 just saved us one malloc, copy and free - the regexp has donated
2470 the old buffer, and we malloc an entirely new one, rather than the
2471 regexp malloc()ing a buffer and copying our original, only for
2472 us to throw it away here during the substitution. */
2473 if (SvIsCOW(TARG)) {
2474 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2480 SvPV_set(TARG, SvPVX(dstr));
2481 SvCUR_set(TARG, SvCUR(dstr));
2482 SvLEN_set(TARG, SvLEN(dstr));
2483 doutf8 |= DO_UTF8(dstr);
2484 SvPV_set(dstr, NULL);
2487 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2492 (void)SvPOK_only_UTF8(TARG);
2496 /* See "how taint works" above */
2498 if ((rxtainted & SUBST_TAINT_PAT) ||
2499 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2500 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2502 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2504 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2505 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2507 SvTAINTED_on(TOPs); /* taint return value */
2509 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2511 /* needed for mg_set below */
2513 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2516 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2518 LEAVE_SCOPE(oldsave);
2527 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2528 ++*PL_markstack_ptr;
2530 LEAVE_with_name("grep_item"); /* exit inner scope */
2533 if (PL_stack_base + *PL_markstack_ptr > SP) {
2535 const I32 gimme = GIMME_V;
2537 LEAVE_with_name("grep"); /* exit outer scope */
2538 (void)POPMARK; /* pop src */
2539 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2540 (void)POPMARK; /* pop dst */
2541 SP = PL_stack_base + POPMARK; /* pop original mark */
2542 if (gimme == G_SCALAR) {
2543 if (PL_op->op_private & OPpGREP_LEX) {
2544 SV* const sv = sv_newmortal();
2545 sv_setiv(sv, items);
2553 else if (gimme == G_ARRAY)
2560 ENTER_with_name("grep_item"); /* enter inner scope */
2563 src = PL_stack_base[*PL_markstack_ptr];
2565 if (PL_op->op_private & OPpGREP_LEX)
2566 PAD_SVl(PL_op->op_targ) = src;
2570 RETURNOP(cLOGOP->op_other);
2581 register PERL_CONTEXT *cx;
2584 if (CxMULTICALL(&cxstack[cxstack_ix]))
2588 cxstack_ix++; /* temporarily protect top context */
2591 if (gimme == G_SCALAR) {
2594 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2596 *MARK = SvREFCNT_inc(TOPs);
2601 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2603 *MARK = sv_mortalcopy(sv);
2608 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2612 *MARK = &PL_sv_undef;
2616 else if (gimme == G_ARRAY) {
2617 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2618 if (!SvTEMP(*MARK)) {
2619 *MARK = sv_mortalcopy(*MARK);
2620 TAINT_NOT; /* Each item is independent */
2628 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2629 PL_curpm = newpm; /* ... and pop $1 et al */
2632 return cx->blk_sub.retop;
2635 /* This duplicates the above code because the above code must not
2636 * get any slower by more conditions */
2644 register PERL_CONTEXT *cx;
2647 if (CxMULTICALL(&cxstack[cxstack_ix]))
2651 cxstack_ix++; /* temporarily protect top context */
2655 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2656 /* We are an argument to a function or grep().
2657 * This kind of lvalueness was legal before lvalue
2658 * subroutines too, so be backward compatible:
2659 * cannot report errors. */
2661 /* Scalar context *is* possible, on the LHS of -> only,
2662 * as in f()->meth(). But this is not an lvalue. */
2663 if (gimme == G_SCALAR)
2665 if (gimme == G_ARRAY) {
2667 /* We want an array here, but padav will have left us an arrayref for an lvalue,
2668 * so we need to expand it */
2669 if(SvTYPE(*mark) == SVt_PVAV) {
2670 AV *const av = MUTABLE_AV(*mark);
2671 const I32 maxarg = AvFILL(av) + 1;
2672 (void)POPs; /* get rid of the array ref */
2674 if (SvRMAGICAL(av)) {
2676 for (i=0; i < (U32)maxarg; i++) {
2677 SV ** const svp = av_fetch(av, i, FALSE);
2679 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2684 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2689 if (!CvLVALUE(cx->blk_sub.cv))
2690 goto temporise_array;
2691 EXTEND_MORTAL(SP - newsp);
2692 for (mark = newsp + 1; mark <= SP; mark++) {
2695 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2696 *mark = sv_mortalcopy(*mark);
2698 /* Can be a localized value subject to deletion. */
2699 PL_tmps_stack[++PL_tmps_ix] = *mark;
2700 SvREFCNT_inc_void(*mark);
2705 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2706 /* Here we go for robustness, not for speed, so we change all
2707 * the refcounts so the caller gets a live guy. Cannot set
2708 * TEMP, so sv_2mortal is out of question. */
2709 if (!CvLVALUE(cx->blk_sub.cv)) {
2715 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2717 if (gimme == G_SCALAR) {
2721 /* Temporaries are bad unless they happen to have set magic
2722 * attached, such as the elements of a tied hash or array */
2723 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2724 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2727 !SvSMAGICAL(TOPs)) {
2733 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2734 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2735 : "a readonly value" : "a temporary");
2737 else { /* Can be a localized value
2738 * subject to deletion. */
2739 PL_tmps_stack[++PL_tmps_ix] = *mark;
2740 SvREFCNT_inc_void(*mark);
2743 else { /* Should not happen? */
2749 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2750 (MARK > SP ? "Empty array" : "Array"));
2754 else if (gimme == G_ARRAY) {
2755 EXTEND_MORTAL(SP - newsp);
2756 for (mark = newsp + 1; mark <= SP; mark++) {
2757 if (*mark != &PL_sv_undef
2758 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2759 /* Might be flattened array after $#array = */
2766 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2767 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2770 /* Can be a localized value subject to deletion. */
2771 PL_tmps_stack[++PL_tmps_ix] = *mark;
2772 SvREFCNT_inc_void(*mark);
2778 if (gimme == G_SCALAR) {
2782 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2784 *MARK = SvREFCNT_inc(TOPs);
2789 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2791 *MARK = sv_mortalcopy(sv);
2796 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2800 *MARK = &PL_sv_undef;
2804 else if (gimme == G_ARRAY) {
2806 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2807 if (!SvTEMP(*MARK)) {
2808 *MARK = sv_mortalcopy(*MARK);
2809 TAINT_NOT; /* Each item is independent */
2818 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2819 PL_curpm = newpm; /* ... and pop $1 et al */
2822 return cx->blk_sub.retop;
2830 register PERL_CONTEXT *cx;
2832 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2835 DIE(aTHX_ "Not a CODE reference");
2836 switch (SvTYPE(sv)) {
2837 /* This is overwhelming the most common case: */
2839 if (!isGV_with_GP(sv))
2840 DIE(aTHX_ "Not a CODE reference");
2842 if (!(cv = GvCVu((const GV *)sv))) {
2844 cv = sv_2cv(sv, &stash, &gv, 0);
2853 if(isGV_with_GP(sv)) goto we_have_a_glob;
2856 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2858 SP = PL_stack_base + POPMARK;
2866 sv = amagic_deref_call(sv, to_cv_amg);
2867 /* Don't SPAGAIN here. */
2873 sym = SvPV_nomg_const(sv, len);
2875 DIE(aTHX_ PL_no_usym, "a subroutine");
2876 if (PL_op->op_private & HINT_STRICT_REFS)
2877 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2878 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2881 cv = MUTABLE_CV(SvRV(sv));
2882 if (SvTYPE(cv) == SVt_PVCV)
2887 DIE(aTHX_ "Not a CODE reference");
2888 /* This is the second most common case: */
2890 cv = MUTABLE_CV(sv);
2898 if (CvCLONE(cv) && ! CvCLONED(cv))
2899 DIE(aTHX_ "Closure prototype called");
2900 if (!CvROOT(cv) && !CvXSUB(cv)) {
2904 /* anonymous or undef'd function leaves us no recourse */
2905 if (CvANON(cv) || !(gv = CvGV(cv)))
2906 DIE(aTHX_ "Undefined subroutine called");
2908 /* autoloaded stub? */
2909 if (cv != GvCV(gv)) {
2912 /* should call AUTOLOAD now? */
2915 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2922 sub_name = sv_newmortal();
2923 gv_efullname3(sub_name, gv, NULL);
2924 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2928 DIE(aTHX_ "Not a CODE reference");
2933 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2934 Perl_get_db_sub(aTHX_ &sv, cv);
2936 PL_curcopdb = PL_curcop;
2938 /* check for lsub that handles lvalue subroutines */
2939 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2940 /* if lsub not found then fall back to DB::sub */
2941 if (!cv) cv = GvCV(PL_DBsub);
2943 cv = GvCV(PL_DBsub);
2946 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2947 DIE(aTHX_ "No DB::sub routine defined");
2950 if (!(CvISXSUB(cv))) {
2951 /* This path taken at least 75% of the time */
2953 register I32 items = SP - MARK;
2954 AV* const padlist = CvPADLIST(cv);
2955 PUSHBLOCK(cx, CXt_SUB, MARK);
2957 cx->blk_sub.retop = PL_op->op_next;
2959 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2960 * that eval'' ops within this sub know the correct lexical space.
2961 * Owing the speed considerations, we choose instead to search for
2962 * the cv using find_runcv() when calling doeval().
2964 if (CvDEPTH(cv) >= 2) {
2965 PERL_STACK_OVERFLOW_CHECK();
2966 pad_push(padlist, CvDEPTH(cv));
2969 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2971 AV *const av = MUTABLE_AV(PAD_SVl(0));
2973 /* @_ is normally not REAL--this should only ever
2974 * happen when DB::sub() calls things that modify @_ */
2979 cx->blk_sub.savearray = GvAV(PL_defgv);
2980 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2981 CX_CURPAD_SAVE(cx->blk_sub);
2982 cx->blk_sub.argarray = av;
2985 if (items > AvMAX(av) + 1) {
2986 SV **ary = AvALLOC(av);
2987 if (AvARRAY(av) != ary) {
2988 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2991 if (items > AvMAX(av) + 1) {
2992 AvMAX(av) = items - 1;
2993 Renew(ary,items,SV*);
2998 Copy(MARK,AvARRAY(av),items,SV*);
2999 AvFILLp(av) = items - 1;
3007 /* warning must come *after* we fully set up the context
3008 * stuff so that __WARN__ handlers can safely dounwind()
3011 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3012 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3013 sub_crush_depth(cv);
3014 RETURNOP(CvSTART(cv));
3017 I32 markix = TOPMARK;
3022 /* Need to copy @_ to stack. Alternative may be to
3023 * switch stack to @_, and copy return values
3024 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3025 AV * const av = GvAV(PL_defgv);
3026 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
3029 /* Mark is at the end of the stack. */
3031 Copy(AvARRAY(av), SP + 1, items, SV*);
3036 /* We assume first XSUB in &DB::sub is the called one. */
3038 SAVEVPTR(PL_curcop);
3039 PL_curcop = PL_curcopdb;
3042 /* Do we need to open block here? XXXX */
3044 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3046 CvXSUB(cv)(aTHX_ cv);
3048 /* Enforce some sanity in scalar context. */
3049 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3050 if (markix > PL_stack_sp - PL_stack_base)
3051 *(PL_stack_base + markix) = &PL_sv_undef;
3053 *(PL_stack_base + markix) = *PL_stack_sp;
3054 PL_stack_sp = PL_stack_base + markix;
3062 Perl_sub_crush_depth(pTHX_ CV *cv)
3064 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3067 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3069 SV* const tmpstr = sv_newmortal();
3070 gv_efullname3(tmpstr, CvGV(cv), NULL);
3071 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3080 SV* const elemsv = POPs;
3081 IV elem = SvIV(elemsv);
3082 AV *const av = MUTABLE_AV(POPs);
3083 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3084 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3085 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3086 bool preeminent = TRUE;
3089 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3090 Perl_warner(aTHX_ packWARN(WARN_MISC),
3091 "Use of reference \"%"SVf"\" as array index",
3094 elem -= CopARYBASE_get(PL_curcop);
3095 if (SvTYPE(av) != SVt_PVAV)
3102 /* If we can determine whether the element exist,
3103 * Try to preserve the existenceness of a tied array
3104 * element by using EXISTS and DELETE if possible.
3105 * Fallback to FETCH and STORE otherwise. */
3106 if (SvCANEXISTDELETE(av))
3107 preeminent = av_exists(av, elem);
3110 svp = av_fetch(av, elem, lval && !defer);
3112 #ifdef PERL_MALLOC_WRAP
3113 if (SvUOK(elemsv)) {
3114 const UV uv = SvUV(elemsv);
3115 elem = uv > IV_MAX ? IV_MAX : uv;
3117 else if (SvNOK(elemsv))
3118 elem = (IV)SvNV(elemsv);
3120 static const char oom_array_extend[] =
3121 "Out of memory during array extend"; /* Duplicated in av.c */
3122 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3125 if (!svp || *svp == &PL_sv_undef) {
3128 DIE(aTHX_ PL_no_aelem, elem);
3129 lv = sv_newmortal();
3130 sv_upgrade(lv, SVt_PVLV);
3132 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3133 LvTARG(lv) = SvREFCNT_inc_simple(av);
3134 LvTARGOFF(lv) = elem;
3141 save_aelem(av, elem, svp);
3143 SAVEADELETE(av, elem);
3145 else if (PL_op->op_private & OPpDEREF)
3146 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3148 sv = (svp ? *svp : &PL_sv_undef);
3149 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3156 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3158 PERL_ARGS_ASSERT_VIVIFY_REF;
3163 Perl_croak_no_modify(aTHX);
3164 prepare_SV_for_RV(sv);
3167 SvRV_set(sv, newSV(0));
3170 SvRV_set(sv, MUTABLE_SV(newAV()));
3173 SvRV_set(sv, MUTABLE_SV(newHV()));
3184 SV* const sv = TOPs;
3187 SV* const rsv = SvRV(sv);
3188 if (SvTYPE(rsv) == SVt_PVCV) {
3194 SETs(method_common(sv, NULL));
3201 SV* const sv = cSVOP_sv;
3202 U32 hash = SvSHARED_HASH(sv);
3204 XPUSHs(method_common(sv, &hash));
3209 S_method_common(pTHX_ SV* meth, U32* hashp)
3215 const char* packname = NULL;
3218 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3220 PERL_ARGS_ASSERT_METHOD_COMMON;
3223 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3228 ob = MUTABLE_SV(SvRV(sv));
3232 /* this isn't a reference */
3233 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3234 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3236 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3243 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3244 !(ob=MUTABLE_SV(GvIO(iogv))))
3246 /* this isn't the name of a filehandle either */
3248 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3249 ? !isIDFIRST_utf8((U8*)packname)
3250 : !isIDFIRST(*packname)
3253 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3255 SvOK(sv) ? "without a package or object reference"
3256 : "on an undefined value");
3258 /* assume it's a package name */
3259 stash = gv_stashpvn(packname, packlen, 0);
3263 SV* const ref = newSViv(PTR2IV(stash));
3264 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3268 /* it _is_ a filehandle name -- replace with a reference */
3269 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3272 /* if we got here, ob should be a reference or a glob */
3273 if (!ob || !(SvOBJECT(ob)
3274 || (SvTYPE(ob) == SVt_PVGV
3276 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3279 const char * const name = SvPV_nolen_const(meth);
3280 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3281 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3285 stash = SvSTASH(ob);
3288 /* NOTE: stash may be null, hope hv_fetch_ent and
3289 gv_fetchmethod can cope (it seems they can) */
3291 /* shortcut for simple names */
3293 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3295 gv = MUTABLE_GV(HeVAL(he));
3296 if (isGV(gv) && GvCV(gv) &&
3297 (!GvCVGEN(gv) || GvCVGEN(gv)
3298 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3299 return MUTABLE_SV(GvCV(gv));
3303 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3304 SvPV_nolen_const(meth),
3305 GV_AUTOLOAD | GV_CROAK);
3309 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3314 * c-indentation-style: bsd
3316 * indent-tabs-mode: t
3319 * ex: set ts=8 sts=4 sw=4 noet: