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.
993 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
994 EXTEND_MORTAL(lastrelem - firstrelem + 1);
995 for (relem = firstrelem; relem <= lastrelem; relem++) {
997 TAINT_NOT; /* Each item is independent */
999 /* Dear TODO test in t/op/sort.t, I love you.
1000 (It's relying on a panic, not a "semi-panic" from newSVsv()
1001 and then an assertion failure below.) */
1002 if (SvIS_FREED(sv)) {
1003 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1006 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
1007 and we need a second copy of a temp here. */
1008 *relem = sv_2mortal(newSVsv(sv));
1018 while (lelem <= lastlelem) {
1019 TAINT_NOT; /* Each item stands on its own, taintwise. */
1021 switch (SvTYPE(sv)) {
1023 ary = MUTABLE_AV(sv);
1024 magic = SvMAGICAL(ary) != 0;
1026 av_extend(ary, lastrelem - relem);
1028 while (relem <= lastrelem) { /* gobble up all the rest */
1032 sv_setsv(sv, *relem);
1034 didstore = av_store(ary,i++,sv);
1043 if (PL_delaymagic & DM_ARRAY_ISA)
1044 SvSETMAGIC(MUTABLE_SV(ary));
1046 case SVt_PVHV: { /* normal hash */
1048 SV** topelem = relem;
1050 hash = MUTABLE_HV(sv);
1051 magic = SvMAGICAL(hash) != 0;
1053 firsthashrelem = relem;
1055 while (relem < lastrelem) { /* gobble up all the rest */
1057 sv = *relem ? *relem : &PL_sv_no;
1061 sv_setsv(tmpstr,*relem); /* value */
1063 if (gimme != G_VOID) {
1064 if (hv_exists_ent(hash, sv, 0))
1065 /* key overwrites an existing entry */
1068 if (gimme == G_ARRAY) {
1069 /* copy element back: possibly to an earlier
1070 * stack location if we encountered dups earlier */
1072 *topelem++ = tmpstr;
1075 didstore = hv_store_ent(hash,sv,tmpstr,0);
1077 if (SvSMAGICAL(tmpstr))
1084 if (relem == lastrelem) {
1085 do_oddball(hash, relem, firstrelem);
1091 if (SvIMMORTAL(sv)) {
1092 if (relem <= lastrelem)
1096 if (relem <= lastrelem) {
1097 sv_setsv(sv, *relem);
1101 sv_setsv(sv, &PL_sv_undef);
1106 if (PL_delaymagic & ~DM_DELAY) {
1107 if (PL_delaymagic & DM_UID) {
1108 #ifdef HAS_SETRESUID
1109 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1110 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1113 # ifdef HAS_SETREUID
1114 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1115 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1118 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1119 (void)setruid(PL_uid);
1120 PL_delaymagic &= ~DM_RUID;
1122 # endif /* HAS_SETRUID */
1124 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1125 (void)seteuid(PL_euid);
1126 PL_delaymagic &= ~DM_EUID;
1128 # endif /* HAS_SETEUID */
1129 if (PL_delaymagic & DM_UID) {
1130 if (PL_uid != PL_euid)
1131 DIE(aTHX_ "No setreuid available");
1132 (void)PerlProc_setuid(PL_uid);
1134 # endif /* HAS_SETREUID */
1135 #endif /* HAS_SETRESUID */
1136 PL_uid = PerlProc_getuid();
1137 PL_euid = PerlProc_geteuid();
1139 if (PL_delaymagic & DM_GID) {
1140 #ifdef HAS_SETRESGID
1141 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1142 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1145 # ifdef HAS_SETREGID
1146 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1147 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1150 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1151 (void)setrgid(PL_gid);
1152 PL_delaymagic &= ~DM_RGID;
1154 # endif /* HAS_SETRGID */
1156 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1157 (void)setegid(PL_egid);
1158 PL_delaymagic &= ~DM_EGID;
1160 # endif /* HAS_SETEGID */
1161 if (PL_delaymagic & DM_GID) {
1162 if (PL_gid != PL_egid)
1163 DIE(aTHX_ "No setregid available");
1164 (void)PerlProc_setgid(PL_gid);
1166 # endif /* HAS_SETREGID */
1167 #endif /* HAS_SETRESGID */
1168 PL_gid = PerlProc_getgid();
1169 PL_egid = PerlProc_getegid();
1171 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1175 if (gimme == G_VOID)
1176 SP = firstrelem - 1;
1177 else if (gimme == G_SCALAR) {
1180 SETi(lastrelem - firstrelem + 1 - duplicates);
1187 /* at this point we have removed the duplicate key/value
1188 * pairs from the stack, but the remaining values may be
1189 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1190 * the (a 2), but the stack now probably contains
1191 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1192 * obliterates the earlier key. So refresh all values. */
1193 lastrelem -= duplicates;
1194 relem = firsthashrelem;
1195 while (relem < lastrelem) {
1198 he = hv_fetch_ent(hash, sv, 0, 0);
1199 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1205 SP = firstrelem + (lastlelem - firstlelem);
1206 lelem = firstlelem + (relem - firstrelem);
1208 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1217 register PMOP * const pm = cPMOP;
1218 REGEXP * rx = PM_GETRE(pm);
1219 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1220 SV * const rv = sv_newmortal();
1222 SvUPGRADE(rv, SVt_IV);
1223 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1224 loathe to use it here, but it seems to be the right fix. Or close.
1225 The key part appears to be that it's essential for pp_qr to return a new
1226 object (SV), which implies that there needs to be an effective way to
1227 generate a new SV from the existing SV that is pre-compiled in the
1229 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1233 HV *const stash = gv_stashsv(pkg, GV_ADD);
1235 (void)sv_bless(rv, stash);
1238 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1240 SvTAINTED_on(SvRV(rv));
1249 register PMOP *pm = cPMOP;
1251 register const char *t;
1252 register const char *s;
1255 U8 r_flags = REXEC_CHECKED;
1256 const char *truebase; /* Start of string */
1257 register REGEXP *rx = PM_GETRE(pm);
1259 const I32 gimme = GIMME;
1262 const I32 oldsave = PL_savestack_ix;
1263 I32 update_minmatch = 1;
1264 I32 had_zerolen = 0;
1267 if (PL_op->op_flags & OPf_STACKED)
1269 else if (PL_op->op_private & OPpTARGET_MY)
1276 PUTBACK; /* EVAL blocks need stack_sp. */
1277 /* Skip get-magic if this is a qr// clone, because regcomp has
1279 s = ((struct regexp *)SvANY(rx))->mother_re
1280 ? SvPV_nomg_const(TARG, len)
1281 : SvPV_const(TARG, len);
1283 DIE(aTHX_ "panic: pp_match");
1285 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1286 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1289 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1291 /* PMdf_USED is set after a ?? matches once */
1294 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1296 pm->op_pmflags & PMf_USED
1300 if (gimme == G_ARRAY)
1307 /* empty pattern special-cased to use last successful pattern if possible */
1308 if (!RX_PRELEN(rx) && PL_curpm) {
1313 if (RX_MINLEN(rx) > (I32)len)
1318 /* XXXX What part of this is needed with true \G-support? */
1319 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1320 RX_OFFS(rx)[0].start = -1;
1321 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1322 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1323 if (mg && mg->mg_len >= 0) {
1324 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1325 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1326 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1327 r_flags |= REXEC_IGNOREPOS;
1328 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1329 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1332 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1333 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1334 update_minmatch = 0;
1338 /* XXX: comment out !global get safe $1 vars after a
1339 match, BUT be aware that this leads to dramatic slowdowns on
1340 /g matches against large strings. So far a solution to this problem
1341 appears to be quite tricky.
1342 Test for the unsafe vars are TODO for now. */
1343 if ( (!global && RX_NPARENS(rx))
1344 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1345 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1346 r_flags |= REXEC_COPY_STR;
1348 r_flags |= REXEC_SCREAM;
1351 if (global && RX_OFFS(rx)[0].start != -1) {
1352 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1353 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1355 if (update_minmatch++)
1356 minmatch = had_zerolen;
1358 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1359 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1360 /* FIXME - can PL_bostr be made const char *? */
1361 PL_bostr = (char *)truebase;
1362 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1366 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1368 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1369 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1370 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1371 && (r_flags & REXEC_SCREAM)))
1372 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1375 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1376 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1379 if (dynpm->op_pmflags & PMf_ONCE) {
1381 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1383 dynpm->op_pmflags |= PMf_USED;
1394 RX_MATCH_TAINTED_on(rx);
1395 TAINT_IF(RX_MATCH_TAINTED(rx));
1396 if (gimme == G_ARRAY) {
1397 const I32 nparens = RX_NPARENS(rx);
1398 I32 i = (global && !nparens) ? 1 : 0;
1400 SPAGAIN; /* EVAL blocks could move the stack. */
1401 EXTEND(SP, nparens + i);
1402 EXTEND_MORTAL(nparens + i);
1403 for (i = !i; i <= nparens; i++) {
1404 PUSHs(sv_newmortal());
1405 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1406 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1407 s = RX_OFFS(rx)[i].start + truebase;
1408 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1409 len < 0 || len > strend - s)
1410 DIE(aTHX_ "panic: pp_match start/end pointers");
1411 sv_setpvn(*SP, s, len);
1412 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1417 if (dynpm->op_pmflags & PMf_CONTINUE) {
1419 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1420 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1422 #ifdef PERL_OLD_COPY_ON_WRITE
1424 sv_force_normal_flags(TARG, 0);
1426 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1427 &PL_vtbl_mglob, NULL, 0);
1429 if (RX_OFFS(rx)[0].start != -1) {
1430 mg->mg_len = RX_OFFS(rx)[0].end;
1431 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1432 mg->mg_flags |= MGf_MINMATCH;
1434 mg->mg_flags &= ~MGf_MINMATCH;
1437 had_zerolen = (RX_OFFS(rx)[0].start != -1
1438 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1439 == (UV)RX_OFFS(rx)[0].end));
1440 PUTBACK; /* EVAL blocks may use stack */
1441 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1446 LEAVE_SCOPE(oldsave);
1452 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1453 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1457 #ifdef PERL_OLD_COPY_ON_WRITE
1459 sv_force_normal_flags(TARG, 0);
1461 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1462 &PL_vtbl_mglob, NULL, 0);
1464 if (RX_OFFS(rx)[0].start != -1) {
1465 mg->mg_len = RX_OFFS(rx)[0].end;
1466 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1467 mg->mg_flags |= MGf_MINMATCH;
1469 mg->mg_flags &= ~MGf_MINMATCH;
1472 LEAVE_SCOPE(oldsave);
1476 yup: /* Confirmed by INTUIT */
1478 RX_MATCH_TAINTED_on(rx);
1479 TAINT_IF(RX_MATCH_TAINTED(rx));
1481 if (dynpm->op_pmflags & PMf_ONCE) {
1483 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1485 dynpm->op_pmflags |= PMf_USED;
1488 if (RX_MATCH_COPIED(rx))
1489 Safefree(RX_SUBBEG(rx));
1490 RX_MATCH_COPIED_off(rx);
1491 RX_SUBBEG(rx) = NULL;
1493 /* FIXME - should rx->subbeg be const char *? */
1494 RX_SUBBEG(rx) = (char *) truebase;
1495 RX_OFFS(rx)[0].start = s - truebase;
1496 if (RX_MATCH_UTF8(rx)) {
1497 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1498 RX_OFFS(rx)[0].end = t - truebase;
1501 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1503 RX_SUBLEN(rx) = strend - truebase;
1506 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1508 #ifdef PERL_OLD_COPY_ON_WRITE
1509 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1511 PerlIO_printf(Perl_debug_log,
1512 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1513 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1516 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1518 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1519 assert (SvPOKp(RX_SAVED_COPY(rx)));
1524 RX_SUBBEG(rx) = savepvn(t, strend - t);
1525 #ifdef PERL_OLD_COPY_ON_WRITE
1526 RX_SAVED_COPY(rx) = NULL;
1529 RX_SUBLEN(rx) = strend - t;
1530 RX_MATCH_COPIED_on(rx);
1531 off = RX_OFFS(rx)[0].start = s - t;
1532 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1534 else { /* startp/endp are used by @- @+. */
1535 RX_OFFS(rx)[0].start = s - truebase;
1536 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1538 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1540 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1541 LEAVE_SCOPE(oldsave);
1546 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1547 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1548 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1553 LEAVE_SCOPE(oldsave);
1554 if (gimme == G_ARRAY)
1560 Perl_do_readline(pTHX)
1562 dVAR; dSP; dTARGETSTACKED;
1567 register IO * const io = GvIO(PL_last_in_gv);
1568 register const I32 type = PL_op->op_type;
1569 const I32 gimme = GIMME_V;
1572 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1574 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1575 if (gimme == G_SCALAR) {
1577 SvSetSV_nosteal(TARG, TOPs);
1587 if (IoFLAGS(io) & IOf_ARGV) {
1588 if (IoFLAGS(io) & IOf_START) {
1590 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1591 IoFLAGS(io) &= ~IOf_START;
1592 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1593 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1594 SvSETMAGIC(GvSV(PL_last_in_gv));
1599 fp = nextargv(PL_last_in_gv);
1600 if (!fp) { /* Note: fp != IoIFP(io) */
1601 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1604 else if (type == OP_GLOB)
1605 fp = Perl_start_glob(aTHX_ POPs, io);
1607 else if (type == OP_GLOB)
1609 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1610 report_wrongway_fh(PL_last_in_gv, '>');
1614 if ((!io || !(IoFLAGS(io) & IOf_START))
1615 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1617 if (type == OP_GLOB)
1618 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1619 "glob failed (can't start child: %s)",
1622 report_evil_fh(PL_last_in_gv);
1624 if (gimme == G_SCALAR) {
1625 /* undef TARG, and push that undefined value */
1626 if (type != OP_RCATLINE) {
1627 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1635 if (gimme == G_SCALAR) {
1637 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1640 if (type == OP_RCATLINE)
1641 SvPV_force_nolen(sv);
1645 else if (isGV_with_GP(sv)) {
1646 SvPV_force_nolen(sv);
1648 SvUPGRADE(sv, SVt_PV);
1649 tmplen = SvLEN(sv); /* remember if already alloced */
1650 if (!tmplen && !SvREADONLY(sv)) {
1651 /* try short-buffering it. Please update t/op/readline.t
1652 * if you change the growth length.
1657 if (type == OP_RCATLINE && SvOK(sv)) {
1659 SvPV_force_nolen(sv);
1665 sv = sv_2mortal(newSV(80));
1669 /* This should not be marked tainted if the fp is marked clean */
1670 #define MAYBE_TAINT_LINE(io, sv) \
1671 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1676 /* delay EOF state for a snarfed empty file */
1677 #define SNARF_EOF(gimme,rs,io,sv) \
1678 (gimme != G_SCALAR || SvCUR(sv) \
1679 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1683 if (!sv_gets(sv, fp, offset)
1685 || SNARF_EOF(gimme, PL_rs, io, sv)
1686 || PerlIO_error(fp)))
1688 PerlIO_clearerr(fp);
1689 if (IoFLAGS(io) & IOf_ARGV) {
1690 fp = nextargv(PL_last_in_gv);
1693 (void)do_close(PL_last_in_gv, FALSE);
1695 else if (type == OP_GLOB) {
1696 if (!do_close(PL_last_in_gv, FALSE)) {
1697 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1698 "glob failed (child exited with status %d%s)",
1699 (int)(STATUS_CURRENT >> 8),
1700 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1703 if (gimme == G_SCALAR) {
1704 if (type != OP_RCATLINE) {
1705 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1711 MAYBE_TAINT_LINE(io, sv);
1714 MAYBE_TAINT_LINE(io, sv);
1716 IoFLAGS(io) |= IOf_NOLINE;
1720 if (type == OP_GLOB) {
1723 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1724 char * const tmps = SvEND(sv) - 1;
1725 if (*tmps == *SvPVX_const(PL_rs)) {
1727 SvCUR_set(sv, SvCUR(sv) - 1);
1730 for (t1 = SvPVX_const(sv); *t1; t1++)
1731 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1732 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1734 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1735 (void)POPs; /* Unmatched wildcard? Chuck it... */
1738 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1739 if (ckWARN(WARN_UTF8)) {
1740 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1741 const STRLEN len = SvCUR(sv) - offset;
1744 if (!is_utf8_string_loc(s, len, &f))
1745 /* Emulate :encoding(utf8) warning in the same case. */
1746 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1747 "utf8 \"\\x%02X\" does not map to Unicode",
1748 f < (U8*)SvEND(sv) ? *f : 0);
1751 if (gimme == G_ARRAY) {
1752 if (SvLEN(sv) - SvCUR(sv) > 20) {
1753 SvPV_shrink_to_cur(sv);
1755 sv = sv_2mortal(newSV(80));
1758 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1759 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1760 const STRLEN new_len
1761 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1762 SvPV_renew(sv, new_len);
1771 register PERL_CONTEXT *cx;
1772 I32 gimme = OP_GIMME(PL_op, -1);
1775 if (cxstack_ix >= 0) {
1776 /* If this flag is set, we're just inside a return, so we should
1777 * store the caller's context */
1778 gimme = (PL_op->op_flags & OPf_SPECIAL)
1780 : cxstack[cxstack_ix].blk_gimme;
1785 ENTER_with_name("block");
1788 PUSHBLOCK(cx, CXt_BLOCK, SP);
1798 SV * const keysv = POPs;
1799 HV * const hv = MUTABLE_HV(POPs);
1800 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1801 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1803 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1804 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1805 bool preeminent = TRUE;
1807 if (SvTYPE(hv) != SVt_PVHV)
1814 /* If we can determine whether the element exist,
1815 * Try to preserve the existenceness of a tied hash
1816 * element by using EXISTS and DELETE if possible.
1817 * Fallback to FETCH and STORE otherwise. */
1818 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1819 preeminent = hv_exists_ent(hv, keysv, 0);
1822 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1823 svp = he ? &HeVAL(he) : NULL;
1825 if (!svp || *svp == &PL_sv_undef) {
1829 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1831 lv = sv_newmortal();
1832 sv_upgrade(lv, SVt_PVLV);
1834 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1835 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1836 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1842 if (HvNAME_get(hv) && isGV(*svp))
1843 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1844 else if (preeminent)
1845 save_helem_flags(hv, keysv, svp,
1846 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1848 SAVEHDELETE(hv, keysv);
1850 else if (PL_op->op_private & OPpDEREF)
1851 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1853 sv = (svp ? *svp : &PL_sv_undef);
1854 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1855 * was to make C<local $tied{foo} = $tied{foo}> possible.
1856 * However, it seems no longer to be needed for that purpose, and
1857 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1858 * would loop endlessly since the pos magic is getting set on the
1859 * mortal copy and lost. However, the copy has the effect of
1860 * triggering the get magic, and losing it altogether made things like
1861 * c<$tied{foo};> in void context no longer do get magic, which some
1862 * code relied on. Also, delayed triggering of magic on @+ and friends
1863 * meant the original regex may be out of scope by now. So as a
1864 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1865 * being called too many times). */
1866 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1875 register PERL_CONTEXT *cx;
1880 if (PL_op->op_flags & OPf_SPECIAL) {
1881 cx = &cxstack[cxstack_ix];
1882 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1887 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1890 if (gimme == G_VOID)
1892 else if (gimme == G_SCALAR) {
1896 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1899 *MARK = sv_mortalcopy(TOPs);
1902 *MARK = &PL_sv_undef;
1906 else if (gimme == G_ARRAY) {
1907 /* in case LEAVE wipes old return values */
1909 for (mark = newsp + 1; mark <= SP; mark++) {
1910 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1911 *mark = sv_mortalcopy(*mark);
1912 TAINT_NOT; /* Each item is independent */
1916 PL_curpm = newpm; /* Don't pop $1 et al till now */
1918 LEAVE_with_name("block");
1926 register PERL_CONTEXT *cx;
1929 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1930 bool av_is_stack = FALSE;
1933 cx = &cxstack[cxstack_ix];
1934 if (!CxTYPE_is_LOOP(cx))
1935 DIE(aTHX_ "panic: pp_iter");
1937 itersvp = CxITERVAR(cx);
1938 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1939 /* string increment */
1940 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1941 SV *end = cx->blk_loop.state_u.lazysv.end;
1942 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1943 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1945 const char *max = SvPV_const(end, maxlen);
1946 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1947 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1948 /* safe to reuse old SV */
1949 sv_setsv(*itersvp, cur);
1953 /* we need a fresh SV every time so that loop body sees a
1954 * completely new SV for closures/references to work as
1957 *itersvp = newSVsv(cur);
1958 SvREFCNT_dec(oldsv);
1960 if (strEQ(SvPVX_const(cur), max))
1961 sv_setiv(cur, 0); /* terminate next time */
1968 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1969 /* integer increment */
1970 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1973 /* don't risk potential race */
1974 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1975 /* safe to reuse old SV */
1976 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1980 /* we need a fresh SV every time so that loop body sees a
1981 * completely new SV for closures/references to work as they
1984 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1985 SvREFCNT_dec(oldsv);
1988 /* Handle end of range at IV_MAX */
1989 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1990 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1992 cx->blk_loop.state_u.lazyiv.cur++;
1993 cx->blk_loop.state_u.lazyiv.end++;
2000 assert(CxTYPE(cx) == CXt_LOOP_FOR);
2001 av = cx->blk_loop.state_u.ary.ary;
2006 if (PL_op->op_private & OPpITER_REVERSED) {
2007 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2008 ? cx->blk_loop.resetsp + 1 : 0))
2011 if (SvMAGICAL(av) || AvREIFY(av)) {
2012 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2013 sv = svp ? *svp : NULL;
2016 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2020 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2024 if (SvMAGICAL(av) || AvREIFY(av)) {
2025 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2026 sv = svp ? *svp : NULL;
2029 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2033 if (sv && SvIS_FREED(sv)) {
2035 Perl_croak(aTHX_ "Use of freed value in iteration");
2040 SvREFCNT_inc_simple_void_NN(sv);
2044 if (!av_is_stack && sv == &PL_sv_undef) {
2045 SV *lv = newSV_type(SVt_PVLV);
2047 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2048 LvTARG(lv) = SvREFCNT_inc_simple(av);
2049 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2050 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2056 SvREFCNT_dec(oldsv);
2062 A description of how taint works in pattern matching and substitution.
2064 While the pattern is being assembled/concatenated and them compiled,
2065 PL_tainted will get set if any component of the pattern is tainted, e.g.
2066 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
2067 is set on the pattern if PL_tainted is set.
2069 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2070 the pattern is marked as tainted. This means that subsequent usage, such
2071 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
2073 During execution of a pattern, locale-variant ops such as ALNUML set the
2074 local flag RF_tainted. At the end of execution, the engine sets the
2075 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2078 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2079 of $1 et al to indicate whether the returned value should be tainted.
2080 It is the responsibility of the caller of the pattern (i.e. pp_match,
2081 pp_subst etc) to set this flag for any other circumstances where $1 needs
2084 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2086 There are three possible sources of taint
2088 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2089 * the replacement string (or expression under /e)
2091 There are four destinations of taint and they are affected by the sources
2092 according to the rules below:
2094 * the return value (not including /r):
2095 tainted by the source string and pattern, but only for the
2096 number-of-iterations case; boolean returns aren't tainted;
2097 * the modified string (or modified copy under /r):
2098 tainted by the source string, pattern, and replacement strings;
2100 tainted by the pattern, and under 'use re "taint"', by the source
2102 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2103 should always be unset before executing subsequent code.
2105 The overall action of pp_subst is:
2107 * at the start, set bits in rxtainted indicating the taint status of
2108 the various sources.
2110 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2111 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2112 pattern has subsequently become tainted via locale ops.
2114 * If control is being passed to pp_substcont to execute a /e block,
2115 save rxtainted in the CXt_SUBST block, for future use by
2118 * Whenever control is being returned to perl code (either by falling
2119 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2120 use the flag bits in rxtainted to make all the appropriate types of
2121 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2122 et al will appear tainted.
2124 pp_match is just a simpler version of the above.
2131 register PMOP *pm = cPMOP;
2143 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2144 See "how taint works" above */
2147 register REGEXP *rx = PM_GETRE(pm);
2149 int force_on_match = 0;
2150 const I32 oldsave = PL_savestack_ix;
2152 bool doutf8 = FALSE;
2153 #ifdef PERL_OLD_COPY_ON_WRITE
2157 /* known replacement string? */
2158 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2162 if (PL_op->op_flags & OPf_STACKED)
2164 else if (PL_op->op_private & OPpTARGET_MY)
2171 /* In non-destructive replacement mode, duplicate target scalar so it
2172 * remains unchanged. */
2173 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2174 TARG = sv_2mortal(newSVsv(TARG));
2176 #ifdef PERL_OLD_COPY_ON_WRITE
2177 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2178 because they make integers such as 256 "false". */
2179 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2182 sv_force_normal_flags(TARG,0);
2185 #ifdef PERL_OLD_COPY_ON_WRITE
2189 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2190 || SvTYPE(TARG) > SVt_PVLV)
2191 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2192 Perl_croak_no_modify(aTHX);
2196 s = SvPV_mutable(TARG, len);
2197 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2200 /* only replace once? */
2201 once = !(rpm->op_pmflags & PMf_GLOBAL);
2203 /* See "how taint works" above */
2206 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2207 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2208 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2209 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2210 ? SUBST_TAINT_BOOLRET : 0));
2214 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2218 DIE(aTHX_ "panic: pp_subst");
2221 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2222 maxiters = 2 * slen + 10; /* We can match twice at each
2223 position, once with zero-length,
2224 second time with non-zero. */
2226 if (!RX_PRELEN(rx) && PL_curpm) {
2230 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2231 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2232 ? REXEC_COPY_STR : 0;
2234 r_flags |= REXEC_SCREAM;
2237 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2239 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2243 /* How to do it in subst? */
2244 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2246 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2247 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2248 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2249 && (r_flags & REXEC_SCREAM))))
2254 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2255 r_flags | REXEC_CHECKED))
2259 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2260 LEAVE_SCOPE(oldsave);
2264 /* known replacement string? */
2266 if (SvTAINTED(dstr))
2267 rxtainted |= SUBST_TAINT_REPL;
2269 /* Upgrade the source if the replacement is utf8 but the source is not,
2270 * but only if it matched; see
2271 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2273 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2274 char * const orig_pvx = SvPVX(TARG);
2275 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2277 /* If the lengths are the same, the pattern contains only
2278 * invariants, can keep going; otherwise, various internal markers
2279 * could be off, so redo */
2280 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2285 /* replacement needing upgrading? */
2286 if (DO_UTF8(TARG) && !doutf8) {
2287 nsv = sv_newmortal();
2290 sv_recode_to_utf8(nsv, PL_encoding);
2292 sv_utf8_upgrade(nsv);
2293 c = SvPV_const(nsv, clen);
2297 c = SvPV_const(dstr, clen);
2298 doutf8 = DO_UTF8(dstr);
2306 /* can do inplace substitution? */
2308 #ifdef PERL_OLD_COPY_ON_WRITE
2311 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2312 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2313 && (!doutf8 || SvUTF8(TARG)))
2316 #ifdef PERL_OLD_COPY_ON_WRITE
2317 if (SvIsCOW(TARG)) {
2318 assert (!force_on_match);
2322 if (force_on_match) {
2324 s = SvPV_force(TARG, len);
2329 SvSCREAM_off(TARG); /* disable possible screamer */
2331 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2332 rxtainted |= SUBST_TAINT_PAT;
2333 m = orig + RX_OFFS(rx)[0].start;
2334 d = orig + RX_OFFS(rx)[0].end;
2336 if (m - s > strend - d) { /* faster to shorten from end */
2338 Copy(c, m, clen, char);
2343 Move(d, m, i, char);
2347 SvCUR_set(TARG, m - s);
2349 else if ((i = m - s)) { /* faster from front */
2352 Move(s, d - i, i, char);
2355 Copy(c, m, clen, char);
2360 Copy(c, d, clen, char);
2366 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
2370 if (iters++ > maxiters)
2371 DIE(aTHX_ "Substitution loop");
2372 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2373 rxtainted |= SUBST_TAINT_PAT;
2374 m = RX_OFFS(rx)[0].start + orig;
2377 Move(s, d, i, char);
2381 Copy(c, d, clen, char);
2384 s = RX_OFFS(rx)[0].end + orig;
2385 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2387 /* don't match same null twice */
2388 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2391 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2392 Move(s, d, i+1, char); /* include the NUL */
2395 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2402 if (force_on_match) {
2404 s = SvPV_force(TARG, len);
2407 #ifdef PERL_OLD_COPY_ON_WRITE
2410 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2411 rxtainted |= SUBST_TAINT_PAT;
2412 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2416 register PERL_CONTEXT *cx;
2418 /* note that a whole bunch of local vars are saved here for
2419 * use by pp_substcont: here's a list of them in case you're
2420 * searching for places in this sub that uses a particular var:
2421 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2422 * s m strend rx once */
2424 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2426 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2428 if (iters++ > maxiters)
2429 DIE(aTHX_ "Substitution loop");
2430 if (RX_MATCH_TAINTED(rx))
2431 rxtainted |= SUBST_TAINT_PAT;
2432 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2435 orig = RX_SUBBEG(rx);
2437 strend = s + (strend - m);
2439 m = RX_OFFS(rx)[0].start + orig;
2440 if (doutf8 && !SvUTF8(dstr))
2441 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2443 sv_catpvn(dstr, s, m-s);
2444 s = RX_OFFS(rx)[0].end + orig;
2446 sv_catpvn(dstr, c, clen);
2449 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2450 TARG, NULL, r_flags));
2451 if (doutf8 && !DO_UTF8(TARG))
2452 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2454 sv_catpvn(dstr, s, strend - s);
2456 #ifdef PERL_OLD_COPY_ON_WRITE
2457 /* The match may make the string COW. If so, brilliant, because that's
2458 just saved us one malloc, copy and free - the regexp has donated
2459 the old buffer, and we malloc an entirely new one, rather than the
2460 regexp malloc()ing a buffer and copying our original, only for
2461 us to throw it away here during the substitution. */
2462 if (SvIsCOW(TARG)) {
2463 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2469 SvPV_set(TARG, SvPVX(dstr));
2470 SvCUR_set(TARG, SvCUR(dstr));
2471 SvLEN_set(TARG, SvLEN(dstr));
2472 doutf8 |= DO_UTF8(dstr);
2473 SvPV_set(dstr, NULL);
2476 if (rpm->op_pmflags & PMf_NONDESTRUCT)
2481 (void)SvPOK_only_UTF8(TARG);
2485 /* See "how taint works" above */
2487 if ((rxtainted & SUBST_TAINT_PAT) ||
2488 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2489 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2491 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2493 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2494 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2496 SvTAINTED_on(TOPs); /* taint return value */
2498 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2500 /* needed for mg_set below */
2502 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2505 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2507 LEAVE_SCOPE(oldsave);
2516 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2517 ++*PL_markstack_ptr;
2519 LEAVE_with_name("grep_item"); /* exit inner scope */
2522 if (PL_stack_base + *PL_markstack_ptr > SP) {
2524 const I32 gimme = GIMME_V;
2526 LEAVE_with_name("grep"); /* exit outer scope */
2527 (void)POPMARK; /* pop src */
2528 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2529 (void)POPMARK; /* pop dst */
2530 SP = PL_stack_base + POPMARK; /* pop original mark */
2531 if (gimme == G_SCALAR) {
2532 if (PL_op->op_private & OPpGREP_LEX) {
2533 SV* const sv = sv_newmortal();
2534 sv_setiv(sv, items);
2542 else if (gimme == G_ARRAY)
2549 ENTER_with_name("grep_item"); /* enter inner scope */
2552 src = PL_stack_base[*PL_markstack_ptr];
2554 if (PL_op->op_private & OPpGREP_LEX)
2555 PAD_SVl(PL_op->op_targ) = src;
2559 RETURNOP(cLOGOP->op_other);
2570 register PERL_CONTEXT *cx;
2573 if (CxMULTICALL(&cxstack[cxstack_ix]))
2577 cxstack_ix++; /* temporarily protect top context */
2580 if (gimme == G_SCALAR) {
2583 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2585 *MARK = SvREFCNT_inc(TOPs);
2590 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2592 *MARK = sv_mortalcopy(sv);
2597 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2601 *MARK = &PL_sv_undef;
2605 else if (gimme == G_ARRAY) {
2606 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2607 if (!SvTEMP(*MARK)) {
2608 *MARK = sv_mortalcopy(*MARK);
2609 TAINT_NOT; /* Each item is independent */
2617 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2618 PL_curpm = newpm; /* ... and pop $1 et al */
2621 return cx->blk_sub.retop;
2624 /* This duplicates the above code because the above code must not
2625 * get any slower by more conditions */
2633 register PERL_CONTEXT *cx;
2636 if (CxMULTICALL(&cxstack[cxstack_ix]))
2640 cxstack_ix++; /* temporarily protect top context */
2644 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2645 /* We are an argument to a function or grep().
2646 * This kind of lvalueness was legal before lvalue
2647 * subroutines too, so be backward compatible:
2648 * cannot report errors. */
2650 /* Scalar context *is* possible, on the LHS of -> only,
2651 * as in f()->meth(). But this is not an lvalue. */
2652 if (gimme == G_SCALAR)
2654 if (gimme == G_ARRAY) {
2656 /* We want an array here, but padav will have left us an arrayref for an lvalue,
2657 * so we need to expand it */
2658 if(SvTYPE(*mark) == SVt_PVAV) {
2659 AV *const av = MUTABLE_AV(*mark);
2660 const I32 maxarg = AvFILL(av) + 1;
2661 (void)POPs; /* get rid of the array ref */
2663 if (SvRMAGICAL(av)) {
2665 for (i=0; i < (U32)maxarg; i++) {
2666 SV ** const svp = av_fetch(av, i, FALSE);
2668 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2673 Copy(AvARRAY(av), SP+1, maxarg, SV*);
2678 if (!CvLVALUE(cx->blk_sub.cv))
2679 goto temporise_array;
2680 EXTEND_MORTAL(SP - newsp);
2681 for (mark = newsp + 1; mark <= SP; mark++) {
2684 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2685 *mark = sv_mortalcopy(*mark);
2687 /* Can be a localized value subject to deletion. */
2688 PL_tmps_stack[++PL_tmps_ix] = *mark;
2689 SvREFCNT_inc_void(*mark);
2694 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2695 /* Here we go for robustness, not for speed, so we change all
2696 * the refcounts so the caller gets a live guy. Cannot set
2697 * TEMP, so sv_2mortal is out of question. */
2698 if (!CvLVALUE(cx->blk_sub.cv)) {
2704 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2706 if (gimme == G_SCALAR) {
2710 /* Temporaries are bad unless they happen to have set magic
2711 * attached, such as the elements of a tied hash or array */
2712 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2713 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2716 !SvSMAGICAL(TOPs)) {
2722 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2723 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2724 : "a readonly value" : "a temporary");
2726 else { /* Can be a localized value
2727 * subject to deletion. */
2728 PL_tmps_stack[++PL_tmps_ix] = *mark;
2729 SvREFCNT_inc_void(*mark);
2732 else { /* Should not happen? */
2738 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2739 (MARK > SP ? "Empty array" : "Array"));
2743 else if (gimme == G_ARRAY) {
2744 EXTEND_MORTAL(SP - newsp);
2745 for (mark = newsp + 1; mark <= SP; mark++) {
2746 if (*mark != &PL_sv_undef
2747 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2748 /* Might be flattened array after $#array = */
2755 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2756 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2759 /* Can be a localized value subject to deletion. */
2760 PL_tmps_stack[++PL_tmps_ix] = *mark;
2761 SvREFCNT_inc_void(*mark);
2767 if (gimme == G_SCALAR) {
2771 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2773 *MARK = SvREFCNT_inc(TOPs);
2778 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2780 *MARK = sv_mortalcopy(sv);
2785 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2789 *MARK = &PL_sv_undef;
2793 else if (gimme == G_ARRAY) {
2795 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2796 if (!SvTEMP(*MARK)) {
2797 *MARK = sv_mortalcopy(*MARK);
2798 TAINT_NOT; /* Each item is independent */
2807 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2808 PL_curpm = newpm; /* ... and pop $1 et al */
2811 return cx->blk_sub.retop;
2819 register PERL_CONTEXT *cx;
2821 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2824 DIE(aTHX_ "Not a CODE reference");
2825 switch (SvTYPE(sv)) {
2826 /* This is overwhelming the most common case: */
2828 if (!isGV_with_GP(sv))
2829 DIE(aTHX_ "Not a CODE reference");
2831 if (!(cv = GvCVu((const GV *)sv))) {
2833 cv = sv_2cv(sv, &stash, &gv, 0);
2842 if(isGV_with_GP(sv)) goto we_have_a_glob;
2845 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2847 SP = PL_stack_base + POPMARK;
2855 sv = amagic_deref_call(sv, to_cv_amg);
2856 /* Don't SPAGAIN here. */
2862 sym = SvPV_nomg_const(sv, len);
2864 DIE(aTHX_ PL_no_usym, "a subroutine");
2865 if (PL_op->op_private & HINT_STRICT_REFS)
2866 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2867 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2870 cv = MUTABLE_CV(SvRV(sv));
2871 if (SvTYPE(cv) == SVt_PVCV)
2876 DIE(aTHX_ "Not a CODE reference");
2877 /* This is the second most common case: */
2879 cv = MUTABLE_CV(sv);
2887 if (CvCLONE(cv) && ! CvCLONED(cv))
2888 DIE(aTHX_ "Closure prototype called");
2889 if (!CvROOT(cv) && !CvXSUB(cv)) {
2893 /* anonymous or undef'd function leaves us no recourse */
2894 if (CvANON(cv) || !(gv = CvGV(cv)))
2895 DIE(aTHX_ "Undefined subroutine called");
2897 /* autoloaded stub? */
2898 if (cv != GvCV(gv)) {
2901 /* should call AUTOLOAD now? */
2904 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2911 sub_name = sv_newmortal();
2912 gv_efullname3(sub_name, gv, NULL);
2913 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2917 DIE(aTHX_ "Not a CODE reference");
2922 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2923 Perl_get_db_sub(aTHX_ &sv, cv);
2925 PL_curcopdb = PL_curcop;
2927 /* check for lsub that handles lvalue subroutines */
2928 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2929 /* if lsub not found then fall back to DB::sub */
2930 if (!cv) cv = GvCV(PL_DBsub);
2932 cv = GvCV(PL_DBsub);
2935 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2936 DIE(aTHX_ "No DB::sub routine defined");
2939 if (!(CvISXSUB(cv))) {
2940 /* This path taken at least 75% of the time */
2942 register I32 items = SP - MARK;
2943 AV* const padlist = CvPADLIST(cv);
2944 PUSHBLOCK(cx, CXt_SUB, MARK);
2946 cx->blk_sub.retop = PL_op->op_next;
2948 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2949 * that eval'' ops within this sub know the correct lexical space.
2950 * Owing the speed considerations, we choose instead to search for
2951 * the cv using find_runcv() when calling doeval().
2953 if (CvDEPTH(cv) >= 2) {
2954 PERL_STACK_OVERFLOW_CHECK();
2955 pad_push(padlist, CvDEPTH(cv));
2958 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2960 AV *const av = MUTABLE_AV(PAD_SVl(0));
2962 /* @_ is normally not REAL--this should only ever
2963 * happen when DB::sub() calls things that modify @_ */
2968 cx->blk_sub.savearray = GvAV(PL_defgv);
2969 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2970 CX_CURPAD_SAVE(cx->blk_sub);
2971 cx->blk_sub.argarray = av;
2974 if (items > AvMAX(av) + 1) {
2975 SV **ary = AvALLOC(av);
2976 if (AvARRAY(av) != ary) {
2977 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2980 if (items > AvMAX(av) + 1) {
2981 AvMAX(av) = items - 1;
2982 Renew(ary,items,SV*);
2987 Copy(MARK,AvARRAY(av),items,SV*);
2988 AvFILLp(av) = items - 1;
2996 /* warning must come *after* we fully set up the context
2997 * stuff so that __WARN__ handlers can safely dounwind()
3000 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
3001 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
3002 sub_crush_depth(cv);
3003 RETURNOP(CvSTART(cv));
3006 I32 markix = TOPMARK;
3011 /* Need to copy @_ to stack. Alternative may be to
3012 * switch stack to @_, and copy return values
3013 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
3014 AV * const av = GvAV(PL_defgv);
3015 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
3018 /* Mark is at the end of the stack. */
3020 Copy(AvARRAY(av), SP + 1, items, SV*);
3025 /* We assume first XSUB in &DB::sub is the called one. */
3027 SAVEVPTR(PL_curcop);
3028 PL_curcop = PL_curcopdb;
3031 /* Do we need to open block here? XXXX */
3033 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
3035 CvXSUB(cv)(aTHX_ cv);
3037 /* Enforce some sanity in scalar context. */
3038 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
3039 if (markix > PL_stack_sp - PL_stack_base)
3040 *(PL_stack_base + markix) = &PL_sv_undef;
3042 *(PL_stack_base + markix) = *PL_stack_sp;
3043 PL_stack_sp = PL_stack_base + markix;
3051 Perl_sub_crush_depth(pTHX_ CV *cv)
3053 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
3056 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
3058 SV* const tmpstr = sv_newmortal();
3059 gv_efullname3(tmpstr, CvGV(cv), NULL);
3060 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
3069 SV* const elemsv = POPs;
3070 IV elem = SvIV(elemsv);
3071 AV *const av = MUTABLE_AV(POPs);
3072 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
3073 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
3074 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3075 bool preeminent = TRUE;
3078 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3079 Perl_warner(aTHX_ packWARN(WARN_MISC),
3080 "Use of reference \"%"SVf"\" as array index",
3083 elem -= CopARYBASE_get(PL_curcop);
3084 if (SvTYPE(av) != SVt_PVAV)
3091 /* If we can determine whether the element exist,
3092 * Try to preserve the existenceness of a tied array
3093 * element by using EXISTS and DELETE if possible.
3094 * Fallback to FETCH and STORE otherwise. */
3095 if (SvCANEXISTDELETE(av))
3096 preeminent = av_exists(av, elem);
3099 svp = av_fetch(av, elem, lval && !defer);
3101 #ifdef PERL_MALLOC_WRAP
3102 if (SvUOK(elemsv)) {
3103 const UV uv = SvUV(elemsv);
3104 elem = uv > IV_MAX ? IV_MAX : uv;
3106 else if (SvNOK(elemsv))
3107 elem = (IV)SvNV(elemsv);
3109 static const char oom_array_extend[] =
3110 "Out of memory during array extend"; /* Duplicated in av.c */
3111 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3114 if (!svp || *svp == &PL_sv_undef) {
3117 DIE(aTHX_ PL_no_aelem, elem);
3118 lv = sv_newmortal();
3119 sv_upgrade(lv, SVt_PVLV);
3121 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3122 LvTARG(lv) = SvREFCNT_inc_simple(av);
3123 LvTARGOFF(lv) = elem;
3130 save_aelem(av, elem, svp);
3132 SAVEADELETE(av, elem);
3134 else if (PL_op->op_private & OPpDEREF)
3135 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3137 sv = (svp ? *svp : &PL_sv_undef);
3138 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3145 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3147 PERL_ARGS_ASSERT_VIVIFY_REF;
3152 Perl_croak_no_modify(aTHX);
3153 prepare_SV_for_RV(sv);
3156 SvRV_set(sv, newSV(0));
3159 SvRV_set(sv, MUTABLE_SV(newAV()));
3162 SvRV_set(sv, MUTABLE_SV(newHV()));
3173 SV* const sv = TOPs;
3176 SV* const rsv = SvRV(sv);
3177 if (SvTYPE(rsv) == SVt_PVCV) {
3183 SETs(method_common(sv, NULL));
3190 SV* const sv = cSVOP_sv;
3191 U32 hash = SvSHARED_HASH(sv);
3193 XPUSHs(method_common(sv, &hash));
3198 S_method_common(pTHX_ SV* meth, U32* hashp)
3204 const char* packname = NULL;
3207 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3209 PERL_ARGS_ASSERT_METHOD_COMMON;
3212 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3217 ob = MUTABLE_SV(SvRV(sv));
3221 /* this isn't a reference */
3222 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3223 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3225 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3232 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3233 !(ob=MUTABLE_SV(GvIO(iogv))))
3235 /* this isn't the name of a filehandle either */
3237 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3238 ? !isIDFIRST_utf8((U8*)packname)
3239 : !isIDFIRST(*packname)
3242 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3244 SvOK(sv) ? "without a package or object reference"
3245 : "on an undefined value");
3247 /* assume it's a package name */
3248 stash = gv_stashpvn(packname, packlen, 0);
3252 SV* const ref = newSViv(PTR2IV(stash));
3253 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3257 /* it _is_ a filehandle name -- replace with a reference */
3258 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3261 /* if we got here, ob should be a reference or a glob */
3262 if (!ob || !(SvOBJECT(ob)
3263 || (SvTYPE(ob) == SVt_PVGV
3265 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3268 const char * const name = SvPV_nolen_const(meth);
3269 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3270 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3274 stash = SvSTASH(ob);
3277 /* NOTE: stash may be null, hope hv_fetch_ent and
3278 gv_fetchmethod can cope (it seems they can) */
3280 /* shortcut for simple names */
3282 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3284 gv = MUTABLE_GV(HeVAL(he));
3285 if (isGV(gv) && GvCV(gv) &&
3286 (!GvCVGEN(gv) || GvCVGEN(gv)
3287 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3288 return MUTABLE_SV(GvCV(gv));
3292 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3293 SvPV_nolen_const(meth),
3294 GV_AUTOLOAD | GV_CROAK);
3298 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3303 * c-indentation-style: bsd
3305 * indent-tabs-mode: t
3308 * ex: set ts=8 sts=4 sw=4 noet: