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));
77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
81 PUSHMARK(PL_stack_sp);
96 XPUSHs(MUTABLE_SV(cGVOP_gv));
107 if (PL_op->op_type == OP_AND)
109 RETURNOP(cLOGOP->op_other);
116 /* sassign keeps its args in the optree traditionally backwards.
117 So we pop them differently.
119 SV *left = POPs; SV *right = TOPs;
121 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
122 SV * const temp = left;
123 left = right; right = temp;
125 if (PL_tainting && PL_tainted && !SvTAINTED(right))
127 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
128 SV * const cv = SvRV(right);
129 const U32 cv_type = SvTYPE(cv);
130 const bool is_gv = isGV_with_GP(left);
131 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
137 /* Can do the optimisation if left (LVALUE) is not a typeglob,
138 right (RVALUE) is a reference to something, and we're in void
140 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
141 /* Is the target symbol table currently empty? */
142 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
143 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
144 /* Good. Create a new proxy constant subroutine in the target.
145 The gv becomes a(nother) reference to the constant. */
146 SV *const value = SvRV(cv);
148 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
149 SvPCS_IMPORTED_on(gv);
151 SvREFCNT_inc_simple_void(value);
157 /* Need to fix things up. */
159 /* Need to fix GV. */
160 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
164 /* We've been returned a constant rather than a full subroutine,
165 but they expect a subroutine reference to apply. */
167 ENTER_with_name("sassign_coderef");
168 SvREFCNT_inc_void(SvRV(cv));
169 /* newCONSTSUB takes a reference count on the passed in SV
170 from us. We set the name to NULL, otherwise we get into
171 all sorts of fun as the reference to our new sub is
172 donated to the GV that we're about to assign to.
174 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
177 LEAVE_with_name("sassign_coderef");
179 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
181 First: ops for \&{"BONK"}; return us the constant in the
183 Second: ops for *{"BONK"} cause that symbol table entry
184 (and our reference to it) to be upgraded from RV
186 Thirdly: We get here. cv is actually PVGV now, and its
187 GvCV() is actually the subroutine we're looking for
189 So change the reference so that it points to the subroutine
190 of that typeglob, as that's what they were after all along.
192 GV *const upgraded = MUTABLE_GV(cv);
193 CV *const source = GvCV(upgraded);
196 assert(CvFLAGS(source) & CVf_CONST);
198 SvREFCNT_inc_void(source);
199 SvREFCNT_dec(upgraded);
200 SvRV_set(right, MUTABLE_SV(source));
206 SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
207 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
210 packWARN(WARN_MISC), "Useless assignment to a temporary"
212 SvSetMagicSV(left, right);
222 RETURNOP(cLOGOP->op_other);
224 RETURNOP(cLOGOP->op_next);
231 TAINT_NOT; /* Each statement is presumed innocent */
232 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
234 if (!(PL_op->op_flags & OPf_SPECIAL)) {
235 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
236 LEAVE_SCOPE(oldsave);
243 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
248 const char *rpv = NULL;
250 bool rcopied = FALSE;
252 if (TARG == right && right != left) { /* $r = $l.$r */
253 rpv = SvPV_nomg_const(right, rlen);
254 rbyte = !DO_UTF8(right);
255 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
256 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
260 if (TARG != left) { /* not $l .= $r */
262 const char* const lpv = SvPV_nomg_const(left, llen);
263 lbyte = !DO_UTF8(left);
264 sv_setpvn(TARG, lpv, llen);
270 else { /* $l .= $r */
272 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
273 report_uninit(right);
276 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
277 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
284 /* $r.$r: do magic twice: tied might return different 2nd time */
286 rpv = SvPV_nomg_const(right, rlen);
287 rbyte = !DO_UTF8(right);
289 if (lbyte != rbyte) {
290 /* sv_utf8_upgrade_nomg() may reallocate the stack */
293 sv_utf8_upgrade_nomg(TARG);
296 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
297 sv_utf8_upgrade_nomg(right);
298 rpv = SvPV_nomg_const(right, rlen);
302 sv_catpvn_nomg(TARG, rpv, rlen);
313 if (PL_op->op_flags & OPf_MOD) {
314 if (PL_op->op_private & OPpLVAL_INTRO)
315 if (!(PL_op->op_private & OPpPAD_STATE))
316 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
317 if (PL_op->op_private & OPpDEREF) {
319 TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
332 tryAMAGICunTARGETlist(iter_amg, 0, 0);
333 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
335 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
336 if (!isGV_with_GP(PL_last_in_gv)) {
337 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
338 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
341 XPUSHs(MUTABLE_SV(PL_last_in_gv));
344 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
347 return do_readline();
355 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
359 (SvIOK_notUV(left) && SvIOK_notUV(right))
360 ? (SvIVX(left) == SvIVX(right))
361 : ( do_ncmp(left, right) == 0)
370 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
371 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
372 Perl_croak_no_modify(aTHX);
373 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
374 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
376 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
377 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
379 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
380 if (inc) sv_inc(TOPs);
393 if (PL_op->op_type == OP_OR)
395 RETURNOP(cLOGOP->op_other);
404 const int op_type = PL_op->op_type;
405 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
410 if (!sv || !SvANY(sv)) {
411 if (op_type == OP_DOR)
413 RETURNOP(cLOGOP->op_other);
419 if (!sv || !SvANY(sv))
424 switch (SvTYPE(sv)) {
426 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
430 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
434 if (CvROOT(sv) || CvXSUB(sv))
447 if(op_type == OP_DOR)
449 RETURNOP(cLOGOP->op_other);
451 /* assuming OP_DEFINED */
459 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
460 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
464 useleft = USE_LEFT(svl);
465 #ifdef PERL_PRESERVE_IVUV
466 /* We must see if we can perform the addition with integers if possible,
467 as the integer code detects overflow while the NV code doesn't.
468 If either argument hasn't had a numeric conversion yet attempt to get
469 the IV. It's important to do this now, rather than just assuming that
470 it's not IOK as a PV of "9223372036854775806" may not take well to NV
471 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
472 integer in case the second argument is IV=9223372036854775806
473 We can (now) rely on sv_2iv to do the right thing, only setting the
474 public IOK flag if the value in the NV (or PV) slot is truly integer.
476 A side effect is that this also aggressively prefers integer maths over
477 fp maths for integer values.
479 How to detect overflow?
481 C 99 section 6.2.6.1 says
483 The range of nonnegative values of a signed integer type is a subrange
484 of the corresponding unsigned integer type, and the representation of
485 the same value in each type is the same. A computation involving
486 unsigned operands can never overflow, because a result that cannot be
487 represented by the resulting unsigned integer type is reduced modulo
488 the number that is one greater than the largest value that can be
489 represented by the resulting type.
493 which I read as "unsigned ints wrap."
495 signed integer overflow seems to be classed as "exception condition"
497 If an exceptional condition occurs during the evaluation of an
498 expression (that is, if the result is not mathematically defined or not
499 in the range of representable values for its type), the behavior is
502 (6.5, the 5th paragraph)
504 I had assumed that on 2s complement machines signed arithmetic would
505 wrap, hence coded pp_add and pp_subtract on the assumption that
506 everything perl builds on would be happy. After much wailing and
507 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
508 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
509 unsigned code below is actually shorter than the old code. :-)
512 if (SvIV_please_nomg(svr)) {
513 /* Unless the left argument is integer in range we are going to have to
514 use NV maths. Hence only attempt to coerce the right argument if
515 we know the left is integer. */
523 /* left operand is undef, treat as zero. + 0 is identity,
524 Could SETi or SETu right now, but space optimise by not adding
525 lots of code to speed up what is probably a rarish case. */
527 /* Left operand is defined, so is it IV? */
528 if (SvIV_please_nomg(svl)) {
529 if ((auvok = SvUOK(svl)))
532 const IV aiv = SvIVX(svl);
535 auvok = 1; /* Now acting as a sign flag. */
536 } else { /* 2s complement assumption for IV_MIN */
544 bool result_good = 0;
547 bool buvok = SvUOK(svr);
552 const IV biv = SvIVX(svr);
559 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
560 else "IV" now, independent of how it came in.
561 if a, b represents positive, A, B negative, a maps to -A etc
566 all UV maths. negate result if A negative.
567 add if signs same, subtract if signs differ. */
573 /* Must get smaller */
579 /* result really should be -(auv-buv). as its negation
580 of true value, need to swap our result flag */
597 if (result <= (UV)IV_MIN)
600 /* result valid, but out of range for IV. */
605 } /* Overflow, drop through to NVs. */
610 NV value = SvNV_nomg(svr);
613 /* left operand is undef, treat as zero. + 0.0 is identity. */
617 SETn( value + SvNV_nomg(svl) );
625 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
626 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
627 const U32 lval = PL_op->op_flags & OPf_MOD;
628 SV** const svp = av_fetch(av, PL_op->op_private, lval);
629 SV *sv = (svp ? *svp : &PL_sv_undef);
631 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
639 dVAR; dSP; dMARK; dTARGET;
641 do_join(TARG, *MARK, MARK, SP);
652 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
653 * will be enough to hold an OP*.
655 SV* const sv = sv_newmortal();
656 sv_upgrade(sv, SVt_PVLV);
658 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
661 XPUSHs(MUTABLE_SV(PL_op));
666 /* Oversized hot code. */
670 dVAR; dSP; dMARK; dORIGMARK;
674 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
678 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
681 if (MARK == ORIGMARK) {
682 /* If using default handle then we need to make space to
683 * pass object as 1st arg, so move other args up ...
687 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
690 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
692 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
693 | (PL_op->op_type == OP_SAY
694 ? TIED_METHOD_SAY : 0)), sp - mark);
697 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
698 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
701 SETERRNO(EBADF,RMS_IFI);
704 else if (!(fp = IoOFP(io))) {
706 report_wrongway_fh(gv, '<');
709 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
713 SV * const ofs = GvSV(PL_ofsgv); /* $, */
715 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
717 if (!do_print(*MARK, fp))
721 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
722 if (!do_print(GvSV(PL_ofsgv), fp)) {
731 if (!do_print(*MARK, fp))
739 if (PL_op->op_type == OP_SAY) {
740 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
743 else if (PL_ors_sv && SvOK(PL_ors_sv))
744 if (!do_print(PL_ors_sv, fp)) /* $\ */
747 if (IoFLAGS(io) & IOf_FLUSH)
748 if (PerlIO_flush(fp) == EOF)
758 XPUSHs(&PL_sv_undef);
765 const I32 gimme = GIMME_V;
766 static const char an_array[] = "an ARRAY";
767 static const char a_hash[] = "a HASH";
768 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
769 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
774 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
777 if (SvTYPE(sv) != type)
778 /* diag_listed_as: Not an ARRAY reference */
779 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
780 else if (PL_op->op_flags & OPf_MOD
781 && PL_op->op_private & OPpLVAL_INTRO)
782 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
784 else if (SvTYPE(sv) != type) {
787 if (!isGV_with_GP(sv)) {
788 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
796 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
797 if (PL_op->op_private & OPpLVAL_INTRO)
798 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
800 if (PL_op->op_flags & OPf_REF) {
804 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
805 const I32 flags = is_lvalue_sub();
806 if (flags && !(flags & OPpENTERSUB_INARGS)) {
807 if (gimme != G_ARRAY)
808 goto croak_cant_return;
815 AV *const av = MUTABLE_AV(sv);
816 /* The guts of pp_rv2av, with no intending change to preserve history
817 (until such time as we get tools that can do blame annotation across
818 whitespace changes. */
819 if (gimme == G_ARRAY) {
820 const I32 maxarg = AvFILL(av) + 1;
821 (void)POPs; /* XXXX May be optimized away? */
823 if (SvRMAGICAL(av)) {
825 for (i=0; i < (U32)maxarg; i++) {
826 SV ** const svp = av_fetch(av, i, FALSE);
827 /* See note in pp_helem, and bug id #27839 */
829 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
834 Copy(AvARRAY(av), SP+1, maxarg, SV*);
838 else if (gimme == G_SCALAR) {
840 const I32 maxarg = AvFILL(av) + 1;
844 /* The guts of pp_rv2hv */
845 if (gimme == G_ARRAY) { /* array wanted */
847 return Perl_do_kv(aTHX);
849 else if ((PL_op->op_private & OPpTRUEBOOL
850 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
851 && block_gimme() == G_VOID ))
852 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
853 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
854 else if (gimme == G_SCALAR) {
856 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
864 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
865 is_pp_rv2av ? "array" : "hash");
870 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
874 PERL_ARGS_ASSERT_DO_ODDBALL;
880 if (ckWARN(WARN_MISC)) {
882 if (relem == firstrelem &&
884 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
885 SvTYPE(SvRV(*relem)) == SVt_PVHV))
887 err = "Reference found where even-sized list expected";
890 err = "Odd number of elements in hash assignment";
891 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
895 didstore = hv_store_ent(hash,*relem,tmpstr,0);
896 if (SvMAGICAL(hash)) {
897 if (SvSMAGICAL(tmpstr))
909 SV **lastlelem = PL_stack_sp;
910 SV **lastrelem = PL_stack_base + POPMARK;
911 SV **firstrelem = PL_stack_base + POPMARK + 1;
912 SV **firstlelem = lastrelem + 1;
925 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
927 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
930 /* If there's a common identifier on both sides we have to take
931 * special care that assigning the identifier on the left doesn't
932 * clobber a value on the right that's used later in the list.
933 * Don't bother if LHS is just an empty hash or array.
936 if ( (PL_op->op_private & OPpASSIGN_COMMON)
938 firstlelem != lastlelem
939 || ! ((sv = *firstlelem))
941 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
942 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
943 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
946 EXTEND_MORTAL(lastrelem - firstrelem + 1);
947 for (relem = firstrelem; relem <= lastrelem; relem++) {
949 TAINT_NOT; /* Each item is independent */
951 /* Dear TODO test in t/op/sort.t, I love you.
952 (It's relying on a panic, not a "semi-panic" from newSVsv()
953 and then an assertion failure below.) */
954 if (SvIS_FREED(sv)) {
955 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
958 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
959 and we need a second copy of a temp here. */
960 *relem = sv_2mortal(newSVsv(sv));
970 while (lelem <= lastlelem) {
971 TAINT_NOT; /* Each item stands on its own, taintwise. */
973 switch (SvTYPE(sv)) {
975 ary = MUTABLE_AV(sv);
976 magic = SvMAGICAL(ary) != 0;
978 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
980 av_extend(ary, lastrelem - relem);
982 while (relem <= lastrelem) { /* gobble up all the rest */
986 sv_setsv(sv, *relem);
988 didstore = av_store(ary,i++,sv);
997 if (PL_delaymagic & DM_ARRAY_ISA)
998 SvSETMAGIC(MUTABLE_SV(ary));
1001 case SVt_PVHV: { /* normal hash */
1003 SV** topelem = relem;
1005 hash = MUTABLE_HV(sv);
1006 magic = SvMAGICAL(hash) != 0;
1008 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1010 firsthashrelem = relem;
1012 while (relem < lastrelem) { /* gobble up all the rest */
1014 sv = *relem ? *relem : &PL_sv_no;
1018 sv_setsv(tmpstr,*relem); /* value */
1020 if (gimme != G_VOID) {
1021 if (hv_exists_ent(hash, sv, 0))
1022 /* key overwrites an existing entry */
1025 if (gimme == G_ARRAY) {
1026 /* copy element back: possibly to an earlier
1027 * stack location if we encountered dups earlier */
1029 *topelem++ = tmpstr;
1032 didstore = hv_store_ent(hash,sv,tmpstr,0);
1034 if (SvSMAGICAL(tmpstr))
1041 if (relem == lastrelem) {
1042 do_oddball(hash, relem, firstrelem);
1049 if (SvIMMORTAL(sv)) {
1050 if (relem <= lastrelem)
1054 if (relem <= lastrelem) {
1056 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1057 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1060 packWARN(WARN_MISC),
1061 "Useless assignment to a temporary"
1063 sv_setsv(sv, *relem);
1067 sv_setsv(sv, &PL_sv_undef);
1072 if (PL_delaymagic & ~DM_DELAY) {
1073 /* Will be used to set PL_tainting below */
1074 UV tmp_uid = PerlProc_getuid();
1075 UV tmp_euid = PerlProc_geteuid();
1076 UV tmp_gid = PerlProc_getgid();
1077 UV tmp_egid = PerlProc_getegid();
1079 if (PL_delaymagic & DM_UID) {
1080 #ifdef HAS_SETRESUID
1081 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1082 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1085 # ifdef HAS_SETREUID
1086 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1087 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1090 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1091 (void)setruid(PL_delaymagic_uid);
1092 PL_delaymagic &= ~DM_RUID;
1094 # endif /* HAS_SETRUID */
1096 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1097 (void)seteuid(PL_delaymagic_euid);
1098 PL_delaymagic &= ~DM_EUID;
1100 # endif /* HAS_SETEUID */
1101 if (PL_delaymagic & DM_UID) {
1102 if (PL_delaymagic_uid != PL_delaymagic_euid)
1103 DIE(aTHX_ "No setreuid available");
1104 (void)PerlProc_setuid(PL_delaymagic_uid);
1106 # endif /* HAS_SETREUID */
1107 #endif /* HAS_SETRESUID */
1108 tmp_uid = PerlProc_getuid();
1109 tmp_euid = PerlProc_geteuid();
1111 if (PL_delaymagic & DM_GID) {
1112 #ifdef HAS_SETRESGID
1113 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1114 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1117 # ifdef HAS_SETREGID
1118 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1119 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1122 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1123 (void)setrgid(PL_delaymagic_gid);
1124 PL_delaymagic &= ~DM_RGID;
1126 # endif /* HAS_SETRGID */
1128 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1129 (void)setegid(PL_delaymagic_egid);
1130 PL_delaymagic &= ~DM_EGID;
1132 # endif /* HAS_SETEGID */
1133 if (PL_delaymagic & DM_GID) {
1134 if (PL_delaymagic_gid != PL_delaymagic_egid)
1135 DIE(aTHX_ "No setregid available");
1136 (void)PerlProc_setgid(PL_delaymagic_gid);
1138 # endif /* HAS_SETREGID */
1139 #endif /* HAS_SETRESGID */
1140 tmp_gid = PerlProc_getgid();
1141 tmp_egid = PerlProc_getegid();
1143 PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
1147 if (gimme == G_VOID)
1148 SP = firstrelem - 1;
1149 else if (gimme == G_SCALAR) {
1152 SETi(lastrelem - firstrelem + 1 - duplicates);
1159 /* at this point we have removed the duplicate key/value
1160 * pairs from the stack, but the remaining values may be
1161 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1162 * the (a 2), but the stack now probably contains
1163 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1164 * obliterates the earlier key. So refresh all values. */
1165 lastrelem -= duplicates;
1166 relem = firsthashrelem;
1167 while (relem < lastrelem) {
1170 he = hv_fetch_ent(hash, sv, 0, 0);
1171 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1177 SP = firstrelem + (lastlelem - firstlelem);
1178 lelem = firstlelem + (relem - firstrelem);
1180 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1189 PMOP * const pm = cPMOP;
1190 REGEXP * rx = PM_GETRE(pm);
1191 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1192 SV * const rv = sv_newmortal();
1196 SvUPGRADE(rv, SVt_IV);
1197 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1198 loathe to use it here, but it seems to be the right fix. Or close.
1199 The key part appears to be that it's essential for pp_qr to return a new
1200 object (SV), which implies that there needs to be an effective way to
1201 generate a new SV from the existing SV that is pre-compiled in the
1203 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1206 cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
1207 if ((cv = *cvp) && CvCLONE(*cvp)) {
1208 *cvp = cv_clone(cv);
1213 HV *const stash = gv_stashsv(pkg, GV_ADD);
1215 (void)sv_bless(rv, stash);
1218 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1220 SvTAINTED_on(SvRV(rv));
1235 U8 r_flags = REXEC_CHECKED;
1236 const char *truebase; /* Start of string */
1237 REGEXP *rx = PM_GETRE(pm);
1239 const I32 gimme = GIMME;
1242 const I32 oldsave = PL_savestack_ix;
1243 I32 update_minmatch = 1;
1244 I32 had_zerolen = 0;
1247 if (PL_op->op_flags & OPf_STACKED)
1249 else if (PL_op->op_private & OPpTARGET_MY)
1256 PUTBACK; /* EVAL blocks need stack_sp. */
1257 /* Skip get-magic if this is a qr// clone, because regcomp has
1259 s = ((struct regexp *)SvANY(rx))->mother_re
1260 ? SvPV_nomg_const(TARG, len)
1261 : SvPV_const(TARG, len);
1263 DIE(aTHX_ "panic: pp_match");
1265 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1266 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1269 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1271 /* PMdf_USED is set after a ?? matches once */
1274 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1276 pm->op_pmflags & PMf_USED
1279 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1282 if (gimme == G_ARRAY)
1289 /* empty pattern special-cased to use last successful pattern if possible */
1290 if (!RX_PRELEN(rx) && PL_curpm) {
1295 if (RX_MINLEN(rx) > (I32)len) {
1296 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
1302 /* XXXX What part of this is needed with true \G-support? */
1303 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1304 RX_OFFS(rx)[0].start = -1;
1305 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1306 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1307 if (mg && mg->mg_len >= 0) {
1308 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1309 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1310 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1311 r_flags |= REXEC_IGNOREPOS;
1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1316 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1317 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1318 update_minmatch = 0;
1322 /* XXX: comment out !global get safe $1 vars after a
1323 match, BUT be aware that this leads to dramatic slowdowns on
1324 /g matches against large strings. So far a solution to this problem
1325 appears to be quite tricky.
1326 Test for the unsafe vars are TODO for now. */
1327 if ( (!global && RX_NPARENS(rx))
1328 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1329 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1330 r_flags |= REXEC_COPY_STR;
1333 if (global && RX_OFFS(rx)[0].start != -1) {
1334 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1335 if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1336 DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
1339 if (update_minmatch++)
1340 minmatch = had_zerolen;
1342 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1343 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1344 /* FIXME - can PL_bostr be made const char *? */
1345 PL_bostr = (char *)truebase;
1346 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1350 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1352 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1353 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1356 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1357 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1361 if (dynpm->op_pmflags & PMf_ONCE) {
1363 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1365 dynpm->op_pmflags |= PMf_USED;
1371 RX_MATCH_TAINTED_on(rx);
1372 TAINT_IF(RX_MATCH_TAINTED(rx));
1373 if (gimme == G_ARRAY) {
1374 const I32 nparens = RX_NPARENS(rx);
1375 I32 i = (global && !nparens) ? 1 : 0;
1377 SPAGAIN; /* EVAL blocks could move the stack. */
1378 EXTEND(SP, nparens + i);
1379 EXTEND_MORTAL(nparens + i);
1380 for (i = !i; i <= nparens; i++) {
1381 PUSHs(sv_newmortal());
1382 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1383 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1384 s = RX_OFFS(rx)[i].start + truebase;
1385 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1386 len < 0 || len > strend - s)
1387 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1388 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1389 (long) i, (long) RX_OFFS(rx)[i].start,
1390 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1391 sv_setpvn(*SP, s, len);
1392 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1397 if (dynpm->op_pmflags & PMf_CONTINUE) {
1399 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1400 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1402 #ifdef PERL_OLD_COPY_ON_WRITE
1404 sv_force_normal_flags(TARG, 0);
1406 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1407 &PL_vtbl_mglob, NULL, 0);
1409 if (RX_OFFS(rx)[0].start != -1) {
1410 mg->mg_len = RX_OFFS(rx)[0].end;
1411 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1412 mg->mg_flags |= MGf_MINMATCH;
1414 mg->mg_flags &= ~MGf_MINMATCH;
1417 had_zerolen = (RX_OFFS(rx)[0].start != -1
1418 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1419 == (UV)RX_OFFS(rx)[0].end));
1420 PUTBACK; /* EVAL blocks may use stack */
1421 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1426 LEAVE_SCOPE(oldsave);
1432 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1433 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1437 #ifdef PERL_OLD_COPY_ON_WRITE
1439 sv_force_normal_flags(TARG, 0);
1441 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1442 &PL_vtbl_mglob, NULL, 0);
1444 if (RX_OFFS(rx)[0].start != -1) {
1445 mg->mg_len = RX_OFFS(rx)[0].end;
1446 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1447 mg->mg_flags |= MGf_MINMATCH;
1449 mg->mg_flags &= ~MGf_MINMATCH;
1452 LEAVE_SCOPE(oldsave);
1456 yup: /* Confirmed by INTUIT */
1458 RX_MATCH_TAINTED_on(rx);
1459 TAINT_IF(RX_MATCH_TAINTED(rx));
1461 if (dynpm->op_pmflags & PMf_ONCE) {
1463 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1465 dynpm->op_pmflags |= PMf_USED;
1468 if (RX_MATCH_COPIED(rx))
1469 Safefree(RX_SUBBEG(rx));
1470 RX_MATCH_COPIED_off(rx);
1471 RX_SUBBEG(rx) = NULL;
1473 /* FIXME - should rx->subbeg be const char *? */
1474 RX_SUBBEG(rx) = (char *) truebase;
1475 RX_OFFS(rx)[0].start = s - truebase;
1476 if (RX_MATCH_UTF8(rx)) {
1477 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1478 RX_OFFS(rx)[0].end = t - truebase;
1481 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1483 RX_SUBLEN(rx) = strend - truebase;
1486 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1488 #ifdef PERL_OLD_COPY_ON_WRITE
1489 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1491 PerlIO_printf(Perl_debug_log,
1492 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1493 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1496 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1498 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1499 assert (SvPOKp(RX_SAVED_COPY(rx)));
1504 RX_SUBBEG(rx) = savepvn(t, strend - t);
1505 #ifdef PERL_OLD_COPY_ON_WRITE
1506 RX_SAVED_COPY(rx) = NULL;
1509 RX_SUBLEN(rx) = strend - t;
1510 RX_MATCH_COPIED_on(rx);
1511 off = RX_OFFS(rx)[0].start = s - t;
1512 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1514 else { /* startp/endp are used by @- @+. */
1515 RX_OFFS(rx)[0].start = s - truebase;
1516 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1518 /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1519 assert(!RX_NPARENS(rx));
1520 RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
1521 LEAVE_SCOPE(oldsave);
1526 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1527 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1528 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1533 LEAVE_SCOPE(oldsave);
1534 if (gimme == G_ARRAY)
1540 Perl_do_readline(pTHX)
1542 dVAR; dSP; dTARGETSTACKED;
1547 IO * const io = GvIO(PL_last_in_gv);
1548 const I32 type = PL_op->op_type;
1549 const I32 gimme = GIMME_V;
1552 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1554 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1555 if (gimme == G_SCALAR) {
1557 SvSetSV_nosteal(TARG, TOPs);
1567 if (IoFLAGS(io) & IOf_ARGV) {
1568 if (IoFLAGS(io) & IOf_START) {
1570 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1571 IoFLAGS(io) &= ~IOf_START;
1572 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1573 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1574 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1575 SvSETMAGIC(GvSV(PL_last_in_gv));
1580 fp = nextargv(PL_last_in_gv);
1581 if (!fp) { /* Note: fp != IoIFP(io) */
1582 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1585 else if (type == OP_GLOB)
1586 fp = Perl_start_glob(aTHX_ POPs, io);
1588 else if (type == OP_GLOB)
1590 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1591 report_wrongway_fh(PL_last_in_gv, '>');
1595 if ((!io || !(IoFLAGS(io) & IOf_START))
1596 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1598 if (type == OP_GLOB)
1599 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1600 "glob failed (can't start child: %s)",
1603 report_evil_fh(PL_last_in_gv);
1605 if (gimme == G_SCALAR) {
1606 /* undef TARG, and push that undefined value */
1607 if (type != OP_RCATLINE) {
1608 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1616 if (gimme == G_SCALAR) {
1618 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1621 if (type == OP_RCATLINE)
1622 SvPV_force_nomg_nolen(sv);
1626 else if (isGV_with_GP(sv)) {
1627 SvPV_force_nomg_nolen(sv);
1629 SvUPGRADE(sv, SVt_PV);
1630 tmplen = SvLEN(sv); /* remember if already alloced */
1631 if (!tmplen && !SvREADONLY(sv)) {
1632 /* try short-buffering it. Please update t/op/readline.t
1633 * if you change the growth length.
1638 if (type == OP_RCATLINE && SvOK(sv)) {
1640 SvPV_force_nomg_nolen(sv);
1646 sv = sv_2mortal(newSV(80));
1650 /* This should not be marked tainted if the fp is marked clean */
1651 #define MAYBE_TAINT_LINE(io, sv) \
1652 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1657 /* delay EOF state for a snarfed empty file */
1658 #define SNARF_EOF(gimme,rs,io,sv) \
1659 (gimme != G_SCALAR || SvCUR(sv) \
1660 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1664 if (!sv_gets(sv, fp, offset)
1666 || SNARF_EOF(gimme, PL_rs, io, sv)
1667 || PerlIO_error(fp)))
1669 PerlIO_clearerr(fp);
1670 if (IoFLAGS(io) & IOf_ARGV) {
1671 fp = nextargv(PL_last_in_gv);
1674 (void)do_close(PL_last_in_gv, FALSE);
1676 else if (type == OP_GLOB) {
1677 if (!do_close(PL_last_in_gv, FALSE)) {
1678 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1679 "glob failed (child exited with status %d%s)",
1680 (int)(STATUS_CURRENT >> 8),
1681 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1684 if (gimme == G_SCALAR) {
1685 if (type != OP_RCATLINE) {
1686 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1692 MAYBE_TAINT_LINE(io, sv);
1695 MAYBE_TAINT_LINE(io, sv);
1697 IoFLAGS(io) |= IOf_NOLINE;
1701 if (type == OP_GLOB) {
1704 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1705 char * const tmps = SvEND(sv) - 1;
1706 if (*tmps == *SvPVX_const(PL_rs)) {
1708 SvCUR_set(sv, SvCUR(sv) - 1);
1711 for (t1 = SvPVX_const(sv); *t1; t1++)
1712 if (!isALNUMC(*t1) &&
1713 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1715 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1716 (void)POPs; /* Unmatched wildcard? Chuck it... */
1719 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1720 if (ckWARN(WARN_UTF8)) {
1721 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1722 const STRLEN len = SvCUR(sv) - offset;
1725 if (!is_utf8_string_loc(s, len, &f))
1726 /* Emulate :encoding(utf8) warning in the same case. */
1727 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1728 "utf8 \"\\x%02X\" does not map to Unicode",
1729 f < (U8*)SvEND(sv) ? *f : 0);
1732 if (gimme == G_ARRAY) {
1733 if (SvLEN(sv) - SvCUR(sv) > 20) {
1734 SvPV_shrink_to_cur(sv);
1736 sv = sv_2mortal(newSV(80));
1739 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1740 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1741 const STRLEN new_len
1742 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1743 SvPV_renew(sv, new_len);
1754 SV * const keysv = POPs;
1755 HV * const hv = MUTABLE_HV(POPs);
1756 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1757 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1759 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1760 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1761 bool preeminent = TRUE;
1763 if (SvTYPE(hv) != SVt_PVHV)
1770 /* If we can determine whether the element exist,
1771 * Try to preserve the existenceness of a tied hash
1772 * element by using EXISTS and DELETE if possible.
1773 * Fallback to FETCH and STORE otherwise. */
1774 if (SvCANEXISTDELETE(hv))
1775 preeminent = hv_exists_ent(hv, keysv, 0);
1778 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1779 svp = he ? &HeVAL(he) : NULL;
1781 if (!svp || !*svp || *svp == &PL_sv_undef) {
1785 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1787 lv = sv_newmortal();
1788 sv_upgrade(lv, SVt_PVLV);
1790 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1791 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1792 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1798 if (HvNAME_get(hv) && isGV(*svp))
1799 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1800 else if (preeminent)
1801 save_helem_flags(hv, keysv, svp,
1802 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1804 SAVEHDELETE(hv, keysv);
1806 else if (PL_op->op_private & OPpDEREF) {
1807 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1811 sv = (svp && *svp ? *svp : &PL_sv_undef);
1812 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1813 * was to make C<local $tied{foo} = $tied{foo}> possible.
1814 * However, it seems no longer to be needed for that purpose, and
1815 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1816 * would loop endlessly since the pos magic is getting set on the
1817 * mortal copy and lost. However, the copy has the effect of
1818 * triggering the get magic, and losing it altogether made things like
1819 * c<$tied{foo};> in void context no longer do get magic, which some
1820 * code relied on. Also, delayed triggering of magic on @+ and friends
1821 * meant the original regex may be out of scope by now. So as a
1822 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1823 * being called too many times). */
1824 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1836 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1837 bool av_is_stack = FALSE;
1840 cx = &cxstack[cxstack_ix];
1841 if (!CxTYPE_is_LOOP(cx))
1842 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1844 itersvp = CxITERVAR(cx);
1845 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1846 /* string increment */
1847 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1848 SV *end = cx->blk_loop.state_u.lazysv.end;
1849 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1850 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1852 const char *max = SvPV_const(end, maxlen);
1853 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1854 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1855 /* safe to reuse old SV */
1856 sv_setsv(*itersvp, cur);
1860 /* we need a fresh SV every time so that loop body sees a
1861 * completely new SV for closures/references to work as
1864 *itersvp = newSVsv(cur);
1865 SvREFCNT_dec(oldsv);
1867 if (strEQ(SvPVX_const(cur), max))
1868 sv_setiv(cur, 0); /* terminate next time */
1875 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1876 /* integer increment */
1877 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1880 /* don't risk potential race */
1881 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1882 /* safe to reuse old SV */
1883 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
1887 /* we need a fresh SV every time so that loop body sees a
1888 * completely new SV for closures/references to work as they
1891 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
1892 SvREFCNT_dec(oldsv);
1895 if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
1896 /* Handle end of range at IV_MAX */
1897 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1899 ++cx->blk_loop.state_u.lazyiv.cur;
1905 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1906 av = cx->blk_loop.state_u.ary.ary;
1911 if (PL_op->op_private & OPpITER_REVERSED) {
1912 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1913 ? cx->blk_loop.resetsp + 1 : 0))
1916 if (SvMAGICAL(av) || AvREIFY(av)) {
1917 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1918 sv = svp ? *svp : NULL;
1921 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1925 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1929 if (SvMAGICAL(av) || AvREIFY(av)) {
1930 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1931 sv = svp ? *svp : NULL;
1934 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1938 if (sv && SvIS_FREED(sv)) {
1940 Perl_croak(aTHX_ "Use of freed value in iteration");
1945 SvREFCNT_inc_simple_void_NN(sv);
1949 if (!av_is_stack && sv == &PL_sv_undef) {
1950 SV *lv = newSV_type(SVt_PVLV);
1952 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1953 LvTARG(lv) = SvREFCNT_inc_simple(av);
1954 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1955 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1961 SvREFCNT_dec(oldsv);
1967 A description of how taint works in pattern matching and substitution.
1969 While the pattern is being assembled/concatenated and then compiled,
1970 PL_tainted will get set if any component of the pattern is tainted, e.g.
1971 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1972 is set on the pattern if PL_tainted is set.
1974 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1975 the pattern is marked as tainted. This means that subsequent usage, such
1976 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1978 During execution of a pattern, locale-variant ops such as ALNUML set the
1979 local flag RF_tainted. At the end of execution, the engine sets the
1980 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1983 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1984 of $1 et al to indicate whether the returned value should be tainted.
1985 It is the responsibility of the caller of the pattern (i.e. pp_match,
1986 pp_subst etc) to set this flag for any other circumstances where $1 needs
1989 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1991 There are three possible sources of taint
1993 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1994 * the replacement string (or expression under /e)
1996 There are four destinations of taint and they are affected by the sources
1997 according to the rules below:
1999 * the return value (not including /r):
2000 tainted by the source string and pattern, but only for the
2001 number-of-iterations case; boolean returns aren't tainted;
2002 * the modified string (or modified copy under /r):
2003 tainted by the source string, pattern, and replacement strings;
2005 tainted by the pattern, and under 'use re "taint"', by the source
2007 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2008 should always be unset before executing subsequent code.
2010 The overall action of pp_subst is:
2012 * at the start, set bits in rxtainted indicating the taint status of
2013 the various sources.
2015 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2016 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2017 pattern has subsequently become tainted via locale ops.
2019 * If control is being passed to pp_substcont to execute a /e block,
2020 save rxtainted in the CXt_SUBST block, for future use by
2023 * Whenever control is being returned to perl code (either by falling
2024 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2025 use the flag bits in rxtainted to make all the appropriate types of
2026 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2027 et al will appear tainted.
2029 pp_match is just a simpler version of the above.
2048 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2049 See "how taint works" above */
2052 REGEXP *rx = PM_GETRE(pm);
2054 int force_on_match = 0;
2055 const I32 oldsave = PL_savestack_ix;
2057 bool doutf8 = FALSE;
2058 #ifdef PERL_OLD_COPY_ON_WRITE
2062 /* known replacement string? */
2063 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2067 if (PL_op->op_flags & OPf_STACKED)
2069 else if (PL_op->op_private & OPpTARGET_MY)
2076 #ifdef PERL_OLD_COPY_ON_WRITE
2077 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2078 because they make integers such as 256 "false". */
2079 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2082 sv_force_normal_flags(TARG,0);
2084 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2085 #ifdef PERL_OLD_COPY_ON_WRITE
2088 && (SvREADONLY(TARG)
2089 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2090 || SvTYPE(TARG) > SVt_PVLV)
2091 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2092 Perl_croak_no_modify(aTHX);
2096 s = SvPV_mutable(TARG, len);
2097 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2100 /* only replace once? */
2101 once = !(rpm->op_pmflags & PMf_GLOBAL);
2103 /* See "how taint works" above */
2106 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2107 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2108 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2109 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2110 ? SUBST_TAINT_BOOLRET : 0));
2114 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2118 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2121 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2122 maxiters = 2 * slen + 10; /* We can match twice at each
2123 position, once with zero-length,
2124 second time with non-zero. */
2126 if (!RX_PRELEN(rx) && PL_curpm) {
2130 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2131 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2132 ? REXEC_COPY_STR : 0;
2135 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2137 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2141 /* How to do it in subst? */
2142 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2144 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2149 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2150 r_flags | REXEC_CHECKED))
2154 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2155 LEAVE_SCOPE(oldsave);
2159 /* known replacement string? */
2161 if (SvTAINTED(dstr))
2162 rxtainted |= SUBST_TAINT_REPL;
2164 /* Upgrade the source if the replacement is utf8 but the source is not,
2165 * but only if it matched; see
2166 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2168 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2169 char * const orig_pvx = SvPVX(TARG);
2170 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2172 /* If the lengths are the same, the pattern contains only
2173 * invariants, can keep going; otherwise, various internal markers
2174 * could be off, so redo */
2175 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2180 /* replacement needing upgrading? */
2181 if (DO_UTF8(TARG) && !doutf8) {
2182 nsv = sv_newmortal();
2185 sv_recode_to_utf8(nsv, PL_encoding);
2187 sv_utf8_upgrade(nsv);
2188 c = SvPV_const(nsv, clen);
2192 c = SvPV_const(dstr, clen);
2193 doutf8 = DO_UTF8(dstr);
2201 /* can do inplace substitution? */
2203 #ifdef PERL_OLD_COPY_ON_WRITE
2206 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2207 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2208 && (!doutf8 || SvUTF8(TARG))
2209 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2212 #ifdef PERL_OLD_COPY_ON_WRITE
2213 if (SvIsCOW(TARG)) {
2214 assert (!force_on_match);
2218 if (force_on_match) {
2220 s = SvPV_force(TARG, len);
2226 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2227 rxtainted |= SUBST_TAINT_PAT;
2228 m = orig + RX_OFFS(rx)[0].start;
2229 d = orig + RX_OFFS(rx)[0].end;
2231 if (m - s > strend - d) { /* faster to shorten from end */
2233 Copy(c, m, clen, char);
2238 Move(d, m, i, char);
2242 SvCUR_set(TARG, m - s);
2244 else if ((i = m - s)) { /* faster from front */
2247 Move(s, d - i, i, char);
2250 Copy(c, m, clen, char);
2255 Copy(c, d, clen, char);
2265 if (iters++ > maxiters)
2266 DIE(aTHX_ "Substitution loop");
2267 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2268 rxtainted |= SUBST_TAINT_PAT;
2269 m = RX_OFFS(rx)[0].start + orig;
2272 Move(s, d, i, char);
2276 Copy(c, d, clen, char);
2279 s = RX_OFFS(rx)[0].end + orig;
2280 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2282 /* don't match same null twice */
2283 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2286 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2287 Move(s, d, i+1, char); /* include the NUL */
2294 if (force_on_match) {
2296 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2297 /* I feel that it should be possible to avoid this mortal copy
2298 given that the code below copies into a new destination.
2299 However, I suspect it isn't worth the complexity of
2300 unravelling the C<goto force_it> for the small number of
2301 cases where it would be viable to drop into the copy code. */
2302 TARG = sv_2mortal(newSVsv(TARG));
2304 s = SvPV_force(TARG, len);
2307 #ifdef PERL_OLD_COPY_ON_WRITE
2310 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2311 rxtainted |= SUBST_TAINT_PAT;
2312 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2317 /* note that a whole bunch of local vars are saved here for
2318 * use by pp_substcont: here's a list of them in case you're
2319 * searching for places in this sub that uses a particular var:
2320 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2321 * s m strend rx once */
2323 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2325 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2327 if (iters++ > maxiters)
2328 DIE(aTHX_ "Substitution loop");
2329 if (RX_MATCH_TAINTED(rx))
2330 rxtainted |= SUBST_TAINT_PAT;
2331 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2334 orig = RX_SUBBEG(rx);
2336 strend = s + (strend - m);
2338 m = RX_OFFS(rx)[0].start + orig;
2339 if (doutf8 && !SvUTF8(dstr))
2340 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
2342 sv_catpvn_nomg(dstr, s, m-s);
2343 s = RX_OFFS(rx)[0].end + orig;
2345 sv_catpvn_nomg(dstr, c, clen);
2348 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2349 TARG, NULL, r_flags));
2350 if (doutf8 && !DO_UTF8(TARG))
2351 sv_catpvn_nomg_utf8_upgrade(dstr, s, strend - s, nsv);
2353 sv_catpvn_nomg(dstr, s, strend - s);
2355 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2356 /* From here on down we're using the copy, and leaving the original
2362 #ifdef PERL_OLD_COPY_ON_WRITE
2363 /* The match may make the string COW. If so, brilliant, because
2364 that's just saved us one malloc, copy and free - the regexp has
2365 donated the old buffer, and we malloc an entirely new one, rather
2366 than the regexp malloc()ing a buffer and copying our original,
2367 only for us to throw it away here during the substitution. */
2368 if (SvIsCOW(TARG)) {
2369 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2375 SvPV_set(TARG, SvPVX(dstr));
2376 SvCUR_set(TARG, SvCUR(dstr));
2377 SvLEN_set(TARG, SvLEN(dstr));
2378 doutf8 |= DO_UTF8(dstr);
2379 SvPV_set(dstr, NULL);
2386 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2387 (void)SvPOK_only_UTF8(TARG);
2392 /* See "how taint works" above */
2394 if ((rxtainted & SUBST_TAINT_PAT) ||
2395 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2396 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2398 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2400 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2401 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2403 SvTAINTED_on(TOPs); /* taint return value */
2405 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2407 /* needed for mg_set below */
2409 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2412 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2414 LEAVE_SCOPE(oldsave);
2423 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2424 ++*PL_markstack_ptr;
2426 LEAVE_with_name("grep_item"); /* exit inner scope */
2429 if (PL_stack_base + *PL_markstack_ptr > SP) {
2431 const I32 gimme = GIMME_V;
2433 LEAVE_with_name("grep"); /* exit outer scope */
2434 (void)POPMARK; /* pop src */
2435 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2436 (void)POPMARK; /* pop dst */
2437 SP = PL_stack_base + POPMARK; /* pop original mark */
2438 if (gimme == G_SCALAR) {
2439 if (PL_op->op_private & OPpGREP_LEX) {
2440 SV* const sv = sv_newmortal();
2441 sv_setiv(sv, items);
2449 else if (gimme == G_ARRAY)
2456 ENTER_with_name("grep_item"); /* enter inner scope */
2459 src = PL_stack_base[*PL_markstack_ptr];
2461 if (PL_op->op_private & OPpGREP_LEX)
2462 PAD_SVl(PL_op->op_targ) = src;
2466 RETURNOP(cLOGOP->op_other);
2480 if (CxMULTICALL(&cxstack[cxstack_ix]))
2484 cxstack_ix++; /* temporarily protect top context */
2487 if (gimme == G_SCALAR) {
2490 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2491 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2492 && !SvMAGICAL(TOPs)) {
2493 *MARK = SvREFCNT_inc(TOPs);
2498 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2500 *MARK = sv_mortalcopy(sv);
2504 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2505 && !SvMAGICAL(TOPs)) {
2509 *MARK = sv_mortalcopy(TOPs);
2513 *MARK = &PL_sv_undef;
2517 else if (gimme == G_ARRAY) {
2518 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2519 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2520 || SvMAGICAL(*MARK)) {
2521 *MARK = sv_mortalcopy(*MARK);
2522 TAINT_NOT; /* Each item is independent */
2530 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2531 PL_curpm = newpm; /* ... and pop $1 et al */
2534 return cx->blk_sub.retop;
2544 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2547 DIE(aTHX_ "Not a CODE reference");
2548 switch (SvTYPE(sv)) {
2549 /* This is overwhelming the most common case: */
2552 if (!(cv = GvCVu((const GV *)sv))) {
2554 cv = sv_2cv(sv, &stash, &gv, 0);
2563 if(isGV_with_GP(sv)) goto we_have_a_glob;
2566 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2568 SP = PL_stack_base + POPMARK;
2576 sv = amagic_deref_call(sv, to_cv_amg);
2577 /* Don't SPAGAIN here. */
2584 DIE(aTHX_ PL_no_usym, "a subroutine");
2585 sym = SvPV_nomg_const(sv, len);
2586 if (PL_op->op_private & HINT_STRICT_REFS)
2587 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2588 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2591 cv = MUTABLE_CV(SvRV(sv));
2592 if (SvTYPE(cv) == SVt_PVCV)
2597 DIE(aTHX_ "Not a CODE reference");
2598 /* This is the second most common case: */
2600 cv = MUTABLE_CV(sv);
2608 if (CvCLONE(cv) && ! CvCLONED(cv))
2609 DIE(aTHX_ "Closure prototype called");
2610 if (!CvROOT(cv) && !CvXSUB(cv)) {
2614 /* anonymous or undef'd function leaves us no recourse */
2615 if (CvANON(cv) || !(gv = CvGV(cv)))
2616 DIE(aTHX_ "Undefined subroutine called");
2618 /* autoloaded stub? */
2619 if (cv != GvCV(gv)) {
2622 /* should call AUTOLOAD now? */
2625 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2626 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2632 sub_name = sv_newmortal();
2633 gv_efullname3(sub_name, gv, NULL);
2634 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2643 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2644 Perl_get_db_sub(aTHX_ &sv, cv);
2646 PL_curcopdb = PL_curcop;
2648 /* check for lsub that handles lvalue subroutines */
2649 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2650 /* if lsub not found then fall back to DB::sub */
2651 if (!cv) cv = GvCV(PL_DBsub);
2653 cv = GvCV(PL_DBsub);
2656 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2657 DIE(aTHX_ "No DB::sub routine defined");
2660 if (!(CvISXSUB(cv))) {
2661 /* This path taken at least 75% of the time */
2663 I32 items = SP - MARK;
2664 PADLIST * const padlist = CvPADLIST(cv);
2665 PUSHBLOCK(cx, CXt_SUB, MARK);
2667 cx->blk_sub.retop = PL_op->op_next;
2669 if (CvDEPTH(cv) >= 2) {
2670 PERL_STACK_OVERFLOW_CHECK();
2671 pad_push(padlist, CvDEPTH(cv));
2674 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2676 AV *const av = MUTABLE_AV(PAD_SVl(0));
2678 /* @_ is normally not REAL--this should only ever
2679 * happen when DB::sub() calls things that modify @_ */
2684 cx->blk_sub.savearray = GvAV(PL_defgv);
2685 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2686 CX_CURPAD_SAVE(cx->blk_sub);
2687 cx->blk_sub.argarray = av;
2690 if (items > AvMAX(av) + 1) {
2691 SV **ary = AvALLOC(av);
2692 if (AvARRAY(av) != ary) {
2693 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2696 if (items > AvMAX(av) + 1) {
2697 AvMAX(av) = items - 1;
2698 Renew(ary,items,SV*);
2703 Copy(MARK,AvARRAY(av),items,SV*);
2704 AvFILLp(av) = items - 1;
2712 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2714 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2715 /* warning must come *after* we fully set up the context
2716 * stuff so that __WARN__ handlers can safely dounwind()
2719 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2720 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2721 sub_crush_depth(cv);
2722 RETURNOP(CvSTART(cv));
2725 I32 markix = TOPMARK;
2730 /* Need to copy @_ to stack. Alternative may be to
2731 * switch stack to @_, and copy return values
2732 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2733 AV * const av = GvAV(PL_defgv);
2734 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2737 /* Mark is at the end of the stack. */
2739 Copy(AvARRAY(av), SP + 1, items, SV*);
2744 /* We assume first XSUB in &DB::sub is the called one. */
2746 SAVEVPTR(PL_curcop);
2747 PL_curcop = PL_curcopdb;
2750 /* Do we need to open block here? XXXX */
2752 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2754 CvXSUB(cv)(aTHX_ cv);
2756 /* Enforce some sanity in scalar context. */
2757 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2758 if (markix > PL_stack_sp - PL_stack_base)
2759 *(PL_stack_base + markix) = &PL_sv_undef;
2761 *(PL_stack_base + markix) = *PL_stack_sp;
2762 PL_stack_sp = PL_stack_base + markix;
2770 Perl_sub_crush_depth(pTHX_ CV *cv)
2772 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2775 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2777 SV* const tmpstr = sv_newmortal();
2778 gv_efullname3(tmpstr, CvGV(cv), NULL);
2779 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2788 SV* const elemsv = POPs;
2789 IV elem = SvIV(elemsv);
2790 AV *const av = MUTABLE_AV(POPs);
2791 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2792 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2793 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2794 bool preeminent = TRUE;
2797 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2798 Perl_warner(aTHX_ packWARN(WARN_MISC),
2799 "Use of reference \"%"SVf"\" as array index",
2801 if (SvTYPE(av) != SVt_PVAV)
2808 /* If we can determine whether the element exist,
2809 * Try to preserve the existenceness of a tied array
2810 * element by using EXISTS and DELETE if possible.
2811 * Fallback to FETCH and STORE otherwise. */
2812 if (SvCANEXISTDELETE(av))
2813 preeminent = av_exists(av, elem);
2816 svp = av_fetch(av, elem, lval && !defer);
2818 #ifdef PERL_MALLOC_WRAP
2819 if (SvUOK(elemsv)) {
2820 const UV uv = SvUV(elemsv);
2821 elem = uv > IV_MAX ? IV_MAX : uv;
2823 else if (SvNOK(elemsv))
2824 elem = (IV)SvNV(elemsv);
2826 static const char oom_array_extend[] =
2827 "Out of memory during array extend"; /* Duplicated in av.c */
2828 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2831 if (!svp || *svp == &PL_sv_undef) {
2834 DIE(aTHX_ PL_no_aelem, elem);
2835 lv = sv_newmortal();
2836 sv_upgrade(lv, SVt_PVLV);
2838 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2839 LvTARG(lv) = SvREFCNT_inc_simple(av);
2840 LvTARGOFF(lv) = elem;
2847 save_aelem(av, elem, svp);
2849 SAVEADELETE(av, elem);
2851 else if (PL_op->op_private & OPpDEREF) {
2852 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2856 sv = (svp ? *svp : &PL_sv_undef);
2857 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2864 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2866 PERL_ARGS_ASSERT_VIVIFY_REF;
2871 Perl_croak_no_modify(aTHX);
2872 prepare_SV_for_RV(sv);
2875 SvRV_set(sv, newSV(0));
2878 SvRV_set(sv, MUTABLE_SV(newAV()));
2881 SvRV_set(sv, MUTABLE_SV(newHV()));
2888 if (SvGMAGICAL(sv)) {
2889 /* copy the sv without magic to prevent magic from being
2891 SV* msv = sv_newmortal();
2892 sv_setsv_nomg(msv, sv);
2901 SV* const sv = TOPs;
2904 SV* const rsv = SvRV(sv);
2905 if (SvTYPE(rsv) == SVt_PVCV) {
2911 SETs(method_common(sv, NULL));
2918 SV* const sv = cSVOP_sv;
2919 U32 hash = SvSHARED_HASH(sv);
2921 XPUSHs(method_common(sv, &hash));
2926 S_method_common(pTHX_ SV* meth, U32* hashp)
2933 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2934 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2935 "package or object reference", SVfARG(meth)),
2937 : *(PL_stack_base + TOPMARK + 1);
2939 PERL_ARGS_ASSERT_METHOD_COMMON;
2942 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2947 ob = MUTABLE_SV(SvRV(sv));
2951 const char * packname = NULL;
2952 bool packname_is_utf8 = FALSE;
2954 /* this isn't a reference */
2955 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2956 const HE* const he =
2957 (const HE *)hv_common_key_len(
2958 PL_stashcache, packname,
2959 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2963 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2970 !(iogv = gv_fetchpvn_flags(
2971 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2973 !(ob=MUTABLE_SV(GvIO(iogv))))
2975 /* this isn't the name of a filehandle either */
2977 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2978 ? !isIDFIRST_utf8((U8*)packname)
2979 : !isIDFIRST_L1((U8)*packname)
2982 /* diag_listed_as: Can't call method "%s" without a package or object reference */
2983 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2985 SvOK(sv) ? "without a package or object reference"
2986 : "on an undefined value");
2988 /* assume it's a package name */
2989 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
2993 SV* const ref = newSViv(PTR2IV(stash));
2994 (void)hv_store(PL_stashcache, packname,
2995 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
2999 /* it _is_ a filehandle name -- replace with a reference */
3000 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3003 /* if we got here, ob should be a reference or a glob */
3004 if (!ob || !(SvOBJECT(ob)
3005 || (SvTYPE(ob) == SVt_PVGV
3007 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3010 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3011 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3012 ? newSVpvs_flags("DOES", SVs_TEMP)
3016 stash = SvSTASH(ob);
3019 /* NOTE: stash may be null, hope hv_fetch_ent and
3020 gv_fetchmethod can cope (it seems they can) */
3022 /* shortcut for simple names */
3024 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3026 gv = MUTABLE_GV(HeVAL(he));
3027 if (isGV(gv) && GvCV(gv) &&
3028 (!GvCVGEN(gv) || GvCVGEN(gv)
3029 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3030 return MUTABLE_SV(GvCV(gv));
3034 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3035 meth, GV_AUTOLOAD | GV_CROAK);
3039 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3044 * c-indentation-style: bsd
3046 * indent-tabs-mode: nil
3049 * ex: set ts=8 sts=4 sw=4 et: