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. */
81 PUSHMARK(PL_stack_sp);
96 XPUSHs(MUTABLE_SV(cGVOP_gv));
107 if (PL_op->op_type == OP_AND)
109 RETURNOP(cLOGOP->op_other);
115 dVAR; dSP; dPOPTOPssrl;
117 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
118 SV * const temp = left;
119 left = right; right = temp;
121 if (PL_tainting && PL_tainted && !SvTAINTED(left))
123 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
124 SV * const cv = SvRV(left);
125 const U32 cv_type = SvTYPE(cv);
126 const bool is_gv = isGV_with_GP(right);
127 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
133 /* Can do the optimisation if right (LVALUE) is not a typeglob,
134 left (RVALUE) is a reference to something, and we're in void
136 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
137 /* Is the target symbol table currently empty? */
138 GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
139 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
140 /* Good. Create a new proxy constant subroutine in the target.
141 The gv becomes a(nother) reference to the constant. */
142 SV *const value = SvRV(cv);
144 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
145 SvPCS_IMPORTED_on(gv);
147 SvREFCNT_inc_simple_void(value);
153 /* Need to fix things up. */
155 /* Need to fix GV. */
156 right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
160 /* We've been returned a constant rather than a full subroutine,
161 but they expect a subroutine reference to apply. */
163 ENTER_with_name("sassign_coderef");
164 SvREFCNT_inc_void(SvRV(cv));
165 /* newCONSTSUB takes a reference count on the passed in SV
166 from us. We set the name to NULL, otherwise we get into
167 all sorts of fun as the reference to our new sub is
168 donated to the GV that we're about to assign to.
170 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
173 LEAVE_with_name("sassign_coderef");
175 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
177 First: ops for \&{"BONK"}; return us the constant in the
179 Second: ops for *{"BONK"} cause that symbol table entry
180 (and our reference to it) to be upgraded from RV
182 Thirdly: We get here. cv is actually PVGV now, and its
183 GvCV() is actually the subroutine we're looking for
185 So change the reference so that it points to the subroutine
186 of that typeglob, as that's what they were after all along.
188 GV *const upgraded = MUTABLE_GV(cv);
189 CV *const source = GvCV(upgraded);
192 assert(CvFLAGS(source) & CVf_CONST);
194 SvREFCNT_inc_void(source);
195 SvREFCNT_dec(upgraded);
196 SvRV_set(left, MUTABLE_SV(source));
202 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
203 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
206 packWARN(WARN_MISC), "Useless assignment to a temporary"
208 SvSetMagicSV(right, left);
218 RETURNOP(cLOGOP->op_other);
220 RETURNOP(cLOGOP->op_next);
227 TAINT_NOT; /* Each statement is presumed innocent */
228 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
230 if (!(PL_op->op_flags & OPf_SPECIAL)) {
231 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
239 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
244 const char *rpv = NULL;
246 bool rcopied = FALSE;
248 if (TARG == right && right != left) { /* $r = $l.$r */
249 rpv = SvPV_nomg_const(right, rlen);
250 rbyte = !DO_UTF8(right);
251 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
252 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
256 if (TARG != left) { /* not $l .= $r */
258 const char* const lpv = SvPV_nomg_const(left, llen);
259 lbyte = !DO_UTF8(left);
260 sv_setpvn(TARG, lpv, llen);
266 else { /* $l .= $r */
268 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
269 report_uninit(right);
272 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
273 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
280 /* $r.$r: do magic twice: tied might return different 2nd time */
282 rpv = SvPV_nomg_const(right, rlen);
283 rbyte = !DO_UTF8(right);
285 if (lbyte != rbyte) {
286 /* sv_utf8_upgrade_nomg() may reallocate the stack */
289 sv_utf8_upgrade_nomg(TARG);
292 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
293 sv_utf8_upgrade_nomg(right);
294 rpv = SvPV_nomg_const(right, rlen);
298 sv_catpvn_nomg(TARG, rpv, rlen);
309 if (PL_op->op_flags & OPf_MOD) {
310 if (PL_op->op_private & OPpLVAL_INTRO)
311 if (!(PL_op->op_private & OPpPAD_STATE))
312 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
313 if (PL_op->op_private & OPpDEREF) {
315 TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
328 tryAMAGICunTARGET(iter_amg, 0, 0);
329 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
331 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
332 if (!isGV_with_GP(PL_last_in_gv)) {
333 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
334 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
337 XPUSHs(MUTABLE_SV(PL_last_in_gv));
340 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
343 return do_readline();
351 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
355 (SvIOK_notUV(left) && SvIOK_notUV(right))
356 ? (SvIVX(left) == SvIVX(right))
357 : ( do_ncmp(left, right) == 0)
366 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
367 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
368 Perl_croak_no_modify(aTHX);
369 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
370 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
372 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
373 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
375 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
376 if (inc) sv_inc(TOPs);
389 if (PL_op->op_type == OP_OR)
391 RETURNOP(cLOGOP->op_other);
400 const int op_type = PL_op->op_type;
401 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
406 if (!sv || !SvANY(sv)) {
407 if (op_type == OP_DOR)
409 RETURNOP(cLOGOP->op_other);
415 if (!sv || !SvANY(sv))
420 switch (SvTYPE(sv)) {
422 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
426 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
430 if (CvROOT(sv) || CvXSUB(sv))
443 if(op_type == OP_DOR)
445 RETURNOP(cLOGOP->op_other);
447 /* assuming OP_DEFINED */
455 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
456 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
460 useleft = USE_LEFT(svl);
461 #ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
472 A side effect is that this also aggressively prefers integer maths over
473 fp maths for integer values.
475 How to detect overflow?
477 C 99 section 6.2.6.1 says
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
489 which I read as "unsigned ints wrap."
491 signed integer overflow seems to be classed as "exception condition"
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
498 (6.5, the 5th paragraph)
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
508 SvIV_please_nomg(svr);
511 /* Unless the left argument is integer in range we are going to have to
512 use NV maths. Hence only attempt to coerce the right argument if
513 we know the left is integer. */
521 /* left operand is undef, treat as zero. + 0 is identity,
522 Could SETi or SETu right now, but space optimise by not adding
523 lots of code to speed up what is probably a rarish case. */
525 /* Left operand is defined, so is it IV? */
526 SvIV_please_nomg(svl);
528 if ((auvok = SvUOK(svl)))
531 register const IV aiv = SvIVX(svl);
534 auvok = 1; /* Now acting as a sign flag. */
535 } else { /* 2s complement assumption for IV_MIN */
543 bool result_good = 0;
546 bool buvok = SvUOK(svr);
551 register const IV biv = SvIVX(svr);
558 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
559 else "IV" now, independent of how it came in.
560 if a, b represents positive, A, B negative, a maps to -A etc
565 all UV maths. negate result if A negative.
566 add if signs same, subtract if signs differ. */
572 /* Must get smaller */
578 /* result really should be -(auv-buv). as its negation
579 of true value, need to swap our result flag */
596 if (result <= (UV)IV_MIN)
599 /* result valid, but out of range for IV. */
604 } /* Overflow, drop through to NVs. */
609 NV value = SvNV_nomg(svr);
612 /* left operand is undef, treat as zero. + 0.0 is identity. */
616 SETn( value + SvNV_nomg(svl) );
624 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
625 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
626 const U32 lval = PL_op->op_flags & OPf_MOD;
627 SV** const svp = av_fetch(av, PL_op->op_private, lval);
628 SV *sv = (svp ? *svp : &PL_sv_undef);
630 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
638 dVAR; dSP; dMARK; dTARGET;
640 do_join(TARG, *MARK, MARK, SP);
651 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
652 * will be enough to hold an OP*.
654 SV* const sv = sv_newmortal();
655 sv_upgrade(sv, SVt_PVLV);
657 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
660 XPUSHs(MUTABLE_SV(PL_op));
665 /* Oversized hot code. */
669 dVAR; dSP; dMARK; dORIGMARK;
673 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
677 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
680 if (MARK == ORIGMARK) {
681 /* If using default handle then we need to make space to
682 * pass object as 1st arg, so move other args up ...
686 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
689 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
691 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
692 | (PL_op->op_type == OP_SAY
693 ? TIED_METHOD_SAY : 0)), sp - mark);
696 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
697 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
700 SETERRNO(EBADF,RMS_IFI);
703 else if (!(fp = IoOFP(io))) {
705 report_wrongway_fh(gv, '<');
708 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
712 SV * const ofs = GvSV(PL_ofsgv); /* $, */
714 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
716 if (!do_print(*MARK, fp))
720 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
721 if (!do_print(GvSV(PL_ofsgv), fp)) {
730 if (!do_print(*MARK, fp))
738 if (PL_op->op_type == OP_SAY) {
739 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
742 else if (PL_ors_sv && SvOK(PL_ors_sv))
743 if (!do_print(PL_ors_sv, fp)) /* $\ */
746 if (IoFLAGS(io) & IOf_FLUSH)
747 if (PerlIO_flush(fp) == EOF)
757 XPUSHs(&PL_sv_undef);
764 const I32 gimme = GIMME_V;
765 static const char an_array[] = "an ARRAY";
766 static const char a_hash[] = "a HASH";
767 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
768 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
773 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
776 if (SvTYPE(sv) != type)
777 /* diag_listed_as: Not an ARRAY reference */
778 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
779 if (PL_op->op_flags & OPf_REF) {
783 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
784 const I32 flags = is_lvalue_sub();
785 if (flags && !(flags & OPpENTERSUB_INARGS)) {
786 if (gimme != G_ARRAY)
787 goto croak_cant_return;
792 else if (PL_op->op_flags & OPf_MOD
793 && PL_op->op_private & OPpLVAL_INTRO)
794 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
797 if (SvTYPE(sv) == type) {
798 if (PL_op->op_flags & OPf_REF) {
803 if (gimme != G_ARRAY)
804 goto croak_cant_return;
812 if (!isGV_with_GP(sv)) {
813 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
821 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
822 if (PL_op->op_private & OPpLVAL_INTRO)
823 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
824 if (PL_op->op_flags & OPf_REF) {
828 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
829 const I32 flags = is_lvalue_sub();
830 if (flags && !(flags & OPpENTERSUB_INARGS)) {
831 if (gimme != G_ARRAY)
832 goto croak_cant_return;
841 AV *const av = MUTABLE_AV(sv);
842 /* The guts of pp_rv2av, with no intending change to preserve history
843 (until such time as we get tools that can do blame annotation across
844 whitespace changes. */
845 if (gimme == G_ARRAY) {
846 const I32 maxarg = AvFILL(av) + 1;
847 (void)POPs; /* XXXX May be optimized away? */
849 if (SvRMAGICAL(av)) {
851 for (i=0; i < (U32)maxarg; i++) {
852 SV ** const svp = av_fetch(av, i, FALSE);
853 /* See note in pp_helem, and bug id #27839 */
855 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
860 Copy(AvARRAY(av), SP+1, maxarg, SV*);
864 else if (gimme == G_SCALAR) {
866 const I32 maxarg = AvFILL(av) + 1;
870 /* The guts of pp_rv2hv */
871 if (gimme == G_ARRAY) { /* array wanted */
873 return Perl_do_kv(aTHX);
875 else if (gimme == G_SCALAR) {
877 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
885 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
886 is_pp_rv2av ? "array" : "hash");
891 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
895 PERL_ARGS_ASSERT_DO_ODDBALL;
901 if (ckWARN(WARN_MISC)) {
903 if (relem == firstrelem &&
905 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
906 SvTYPE(SvRV(*relem)) == SVt_PVHV))
908 err = "Reference found where even-sized list expected";
911 err = "Odd number of elements in hash assignment";
912 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
916 didstore = hv_store_ent(hash,*relem,tmpstr,0);
917 if (SvMAGICAL(hash)) {
918 if (SvSMAGICAL(tmpstr))
930 SV **lastlelem = PL_stack_sp;
931 SV **lastrelem = PL_stack_base + POPMARK;
932 SV **firstrelem = PL_stack_base + POPMARK + 1;
933 SV **firstlelem = lastrelem + 1;
946 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
948 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
951 /* If there's a common identifier on both sides we have to take
952 * special care that assigning the identifier on the left doesn't
953 * clobber a value on the right that's used later in the list.
954 * Don't bother if LHS is just an empty hash or array.
957 if ( (PL_op->op_private & OPpASSIGN_COMMON)
959 firstlelem != lastlelem
960 || ! ((sv = *firstlelem))
962 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
963 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
964 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
967 EXTEND_MORTAL(lastrelem - firstrelem + 1);
968 for (relem = firstrelem; relem <= lastrelem; relem++) {
970 TAINT_NOT; /* Each item is independent */
972 /* Dear TODO test in t/op/sort.t, I love you.
973 (It's relying on a panic, not a "semi-panic" from newSVsv()
974 and then an assertion failure below.) */
975 if (SvIS_FREED(sv)) {
976 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
979 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
980 and we need a second copy of a temp here. */
981 *relem = sv_2mortal(newSVsv(sv));
991 while (lelem <= lastlelem) {
992 TAINT_NOT; /* Each item stands on its own, taintwise. */
994 switch (SvTYPE(sv)) {
996 ary = MUTABLE_AV(sv);
997 magic = SvMAGICAL(ary) != 0;
999 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1001 av_extend(ary, lastrelem - relem);
1003 while (relem <= lastrelem) { /* gobble up all the rest */
1007 sv_setsv(sv, *relem);
1009 didstore = av_store(ary,i++,sv);
1018 if (PL_delaymagic & DM_ARRAY_ISA)
1019 SvSETMAGIC(MUTABLE_SV(ary));
1022 case SVt_PVHV: { /* normal hash */
1024 SV** topelem = relem;
1026 hash = MUTABLE_HV(sv);
1027 magic = SvMAGICAL(hash) != 0;
1029 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1031 firsthashrelem = relem;
1033 while (relem < lastrelem) { /* gobble up all the rest */
1035 sv = *relem ? *relem : &PL_sv_no;
1039 sv_setsv(tmpstr,*relem); /* value */
1041 if (gimme != G_VOID) {
1042 if (hv_exists_ent(hash, sv, 0))
1043 /* key overwrites an existing entry */
1046 if (gimme == G_ARRAY) {
1047 /* copy element back: possibly to an earlier
1048 * stack location if we encountered dups earlier */
1050 *topelem++ = tmpstr;
1053 didstore = hv_store_ent(hash,sv,tmpstr,0);
1055 if (SvSMAGICAL(tmpstr))
1062 if (relem == lastrelem) {
1063 do_oddball(hash, relem, firstrelem);
1070 if (SvIMMORTAL(sv)) {
1071 if (relem <= lastrelem)
1075 if (relem <= lastrelem) {
1077 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1078 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1081 packWARN(WARN_MISC),
1082 "Useless assignment to a temporary"
1084 sv_setsv(sv, *relem);
1088 sv_setsv(sv, &PL_sv_undef);
1093 if (PL_delaymagic & ~DM_DELAY) {
1094 /* Will be used to set PL_tainting below */
1095 UV tmp_uid = PerlProc_getuid();
1096 UV tmp_euid = PerlProc_geteuid();
1097 UV tmp_gid = PerlProc_getgid();
1098 UV tmp_egid = PerlProc_getegid();
1100 if (PL_delaymagic & DM_UID) {
1101 #ifdef HAS_SETRESUID
1102 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1103 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1106 # ifdef HAS_SETREUID
1107 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1108 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1111 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1112 (void)setruid(PL_delaymagic_uid);
1113 PL_delaymagic &= ~DM_RUID;
1115 # endif /* HAS_SETRUID */
1117 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1118 (void)seteuid(PL_delaymagic_euid);
1119 PL_delaymagic &= ~DM_EUID;
1121 # endif /* HAS_SETEUID */
1122 if (PL_delaymagic & DM_UID) {
1123 if (PL_delaymagic_uid != PL_delaymagic_euid)
1124 DIE(aTHX_ "No setreuid available");
1125 (void)PerlProc_setuid(PL_delaymagic_uid);
1127 # endif /* HAS_SETREUID */
1128 #endif /* HAS_SETRESUID */
1129 tmp_uid = PerlProc_getuid();
1130 tmp_euid = PerlProc_geteuid();
1132 if (PL_delaymagic & DM_GID) {
1133 #ifdef HAS_SETRESGID
1134 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1135 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1138 # ifdef HAS_SETREGID
1139 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1140 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1143 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1144 (void)setrgid(PL_delaymagic_gid);
1145 PL_delaymagic &= ~DM_RGID;
1147 # endif /* HAS_SETRGID */
1149 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1150 (void)setegid(PL_delaymagic_egid);
1151 PL_delaymagic &= ~DM_EGID;
1153 # endif /* HAS_SETEGID */
1154 if (PL_delaymagic & DM_GID) {
1155 if (PL_delaymagic_gid != PL_delaymagic_egid)
1156 DIE(aTHX_ "No setregid available");
1157 (void)PerlProc_setgid(PL_delaymagic_gid);
1159 # endif /* HAS_SETREGID */
1160 #endif /* HAS_SETRESGID */
1161 tmp_gid = PerlProc_getgid();
1162 tmp_egid = PerlProc_getegid();
1164 PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
1168 if (gimme == G_VOID)
1169 SP = firstrelem - 1;
1170 else if (gimme == G_SCALAR) {
1173 SETi(lastrelem - firstrelem + 1 - duplicates);
1180 /* at this point we have removed the duplicate key/value
1181 * pairs from the stack, but the remaining values may be
1182 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1183 * the (a 2), but the stack now probably contains
1184 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1185 * obliterates the earlier key. So refresh all values. */
1186 lastrelem -= duplicates;
1187 relem = firsthashrelem;
1188 while (relem < lastrelem) {
1191 he = hv_fetch_ent(hash, sv, 0, 0);
1192 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1198 SP = firstrelem + (lastlelem - firstlelem);
1199 lelem = firstlelem + (relem - firstrelem);
1201 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1210 register PMOP * const pm = cPMOP;
1211 REGEXP * rx = PM_GETRE(pm);
1212 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1213 SV * const rv = sv_newmortal();
1215 SvUPGRADE(rv, SVt_IV);
1216 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1217 loathe to use it here, but it seems to be the right fix. Or close.
1218 The key part appears to be that it's essential for pp_qr to return a new
1219 object (SV), which implies that there needs to be an effective way to
1220 generate a new SV from the existing SV that is pre-compiled in the
1222 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1226 HV *const stash = gv_stashsv(pkg, GV_ADD);
1228 (void)sv_bless(rv, stash);
1231 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1233 SvTAINTED_on(SvRV(rv));
1242 register PMOP *pm = cPMOP;
1244 register const char *t;
1245 register const char *s;
1248 U8 r_flags = REXEC_CHECKED;
1249 const char *truebase; /* Start of string */
1250 register REGEXP *rx = PM_GETRE(pm);
1252 const I32 gimme = GIMME;
1255 const I32 oldsave = PL_savestack_ix;
1256 I32 update_minmatch = 1;
1257 I32 had_zerolen = 0;
1260 if (PL_op->op_flags & OPf_STACKED)
1262 else if (PL_op->op_private & OPpTARGET_MY)
1269 PUTBACK; /* EVAL blocks need stack_sp. */
1270 /* Skip get-magic if this is a qr// clone, because regcomp has
1272 s = ((struct regexp *)SvANY(rx))->mother_re
1273 ? SvPV_nomg_const(TARG, len)
1274 : SvPV_const(TARG, len);
1276 DIE(aTHX_ "panic: pp_match");
1278 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1279 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1282 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1284 /* PMdf_USED is set after a ?? matches once */
1287 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1289 pm->op_pmflags & PMf_USED
1293 if (gimme == G_ARRAY)
1300 /* empty pattern special-cased to use last successful pattern if possible */
1301 if (!RX_PRELEN(rx) && PL_curpm) {
1306 if (RX_MINLEN(rx) > (I32)len)
1311 /* XXXX What part of this is needed with true \G-support? */
1312 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1313 RX_OFFS(rx)[0].start = -1;
1314 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1315 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1316 if (mg && mg->mg_len >= 0) {
1317 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1318 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1319 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1320 r_flags |= REXEC_IGNOREPOS;
1321 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1322 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1325 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1326 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1327 update_minmatch = 0;
1331 /* XXX: comment out !global get safe $1 vars after a
1332 match, BUT be aware that this leads to dramatic slowdowns on
1333 /g matches against large strings. So far a solution to this problem
1334 appears to be quite tricky.
1335 Test for the unsafe vars are TODO for now. */
1336 if ( (!global && RX_NPARENS(rx))
1337 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1338 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1339 r_flags |= REXEC_COPY_STR;
1341 r_flags |= REXEC_SCREAM;
1344 if (global && RX_OFFS(rx)[0].start != -1) {
1345 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1346 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1348 if (update_minmatch++)
1349 minmatch = had_zerolen;
1351 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1352 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1353 /* FIXME - can PL_bostr be made const char *? */
1354 PL_bostr = (char *)truebase;
1355 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1359 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1361 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1362 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1363 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1364 && (r_flags & REXEC_SCREAM)))
1365 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1368 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1369 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1373 if (dynpm->op_pmflags & PMf_ONCE) {
1375 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1377 dynpm->op_pmflags |= PMf_USED;
1383 RX_MATCH_TAINTED_on(rx);
1384 TAINT_IF(RX_MATCH_TAINTED(rx));
1385 if (gimme == G_ARRAY) {
1386 const I32 nparens = RX_NPARENS(rx);
1387 I32 i = (global && !nparens) ? 1 : 0;
1389 SPAGAIN; /* EVAL blocks could move the stack. */
1390 EXTEND(SP, nparens + i);
1391 EXTEND_MORTAL(nparens + i);
1392 for (i = !i; i <= nparens; i++) {
1393 PUSHs(sv_newmortal());
1394 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1395 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1396 s = RX_OFFS(rx)[i].start + truebase;
1397 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1398 len < 0 || len > strend - s)
1399 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1400 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1401 (long) i, (long) RX_OFFS(rx)[i].start,
1402 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1403 sv_setpvn(*SP, s, len);
1404 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1409 if (dynpm->op_pmflags & PMf_CONTINUE) {
1411 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1412 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1414 #ifdef PERL_OLD_COPY_ON_WRITE
1416 sv_force_normal_flags(TARG, 0);
1418 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1419 &PL_vtbl_mglob, NULL, 0);
1421 if (RX_OFFS(rx)[0].start != -1) {
1422 mg->mg_len = RX_OFFS(rx)[0].end;
1423 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1424 mg->mg_flags |= MGf_MINMATCH;
1426 mg->mg_flags &= ~MGf_MINMATCH;
1429 had_zerolen = (RX_OFFS(rx)[0].start != -1
1430 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1431 == (UV)RX_OFFS(rx)[0].end));
1432 PUTBACK; /* EVAL blocks may use stack */
1433 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1438 LEAVE_SCOPE(oldsave);
1444 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1445 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1449 #ifdef PERL_OLD_COPY_ON_WRITE
1451 sv_force_normal_flags(TARG, 0);
1453 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1454 &PL_vtbl_mglob, NULL, 0);
1456 if (RX_OFFS(rx)[0].start != -1) {
1457 mg->mg_len = RX_OFFS(rx)[0].end;
1458 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1459 mg->mg_flags |= MGf_MINMATCH;
1461 mg->mg_flags &= ~MGf_MINMATCH;
1464 LEAVE_SCOPE(oldsave);
1468 yup: /* Confirmed by INTUIT */
1470 RX_MATCH_TAINTED_on(rx);
1471 TAINT_IF(RX_MATCH_TAINTED(rx));
1473 if (dynpm->op_pmflags & PMf_ONCE) {
1475 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1477 dynpm->op_pmflags |= PMf_USED;
1480 if (RX_MATCH_COPIED(rx))
1481 Safefree(RX_SUBBEG(rx));
1482 RX_MATCH_COPIED_off(rx);
1483 RX_SUBBEG(rx) = NULL;
1485 /* FIXME - should rx->subbeg be const char *? */
1486 RX_SUBBEG(rx) = (char *) truebase;
1487 RX_OFFS(rx)[0].start = s - truebase;
1488 if (RX_MATCH_UTF8(rx)) {
1489 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1490 RX_OFFS(rx)[0].end = t - truebase;
1493 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1495 RX_SUBLEN(rx) = strend - truebase;
1498 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1500 #ifdef PERL_OLD_COPY_ON_WRITE
1501 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1503 PerlIO_printf(Perl_debug_log,
1504 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1505 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1508 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1510 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1511 assert (SvPOKp(RX_SAVED_COPY(rx)));
1516 RX_SUBBEG(rx) = savepvn(t, strend - t);
1517 #ifdef PERL_OLD_COPY_ON_WRITE
1518 RX_SAVED_COPY(rx) = NULL;
1521 RX_SUBLEN(rx) = strend - t;
1522 RX_MATCH_COPIED_on(rx);
1523 off = RX_OFFS(rx)[0].start = s - t;
1524 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1526 else { /* startp/endp are used by @- @+. */
1527 RX_OFFS(rx)[0].start = s - truebase;
1528 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1530 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1532 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1533 LEAVE_SCOPE(oldsave);
1538 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1539 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1540 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1545 LEAVE_SCOPE(oldsave);
1546 if (gimme == G_ARRAY)
1552 Perl_do_readline(pTHX)
1554 dVAR; dSP; dTARGETSTACKED;
1559 register IO * const io = GvIO(PL_last_in_gv);
1560 register const I32 type = PL_op->op_type;
1561 const I32 gimme = GIMME_V;
1564 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1566 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1567 if (gimme == G_SCALAR) {
1569 SvSetSV_nosteal(TARG, TOPs);
1579 if (IoFLAGS(io) & IOf_ARGV) {
1580 if (IoFLAGS(io) & IOf_START) {
1582 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1583 IoFLAGS(io) &= ~IOf_START;
1584 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1585 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1586 SvSETMAGIC(GvSV(PL_last_in_gv));
1591 fp = nextargv(PL_last_in_gv);
1592 if (!fp) { /* Note: fp != IoIFP(io) */
1593 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1596 else if (type == OP_GLOB)
1597 fp = Perl_start_glob(aTHX_ POPs, io);
1599 else if (type == OP_GLOB)
1601 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1602 report_wrongway_fh(PL_last_in_gv, '>');
1606 if ((!io || !(IoFLAGS(io) & IOf_START))
1607 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1609 if (type == OP_GLOB)
1610 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1611 "glob failed (can't start child: %s)",
1614 report_evil_fh(PL_last_in_gv);
1616 if (gimme == G_SCALAR) {
1617 /* undef TARG, and push that undefined value */
1618 if (type != OP_RCATLINE) {
1619 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1627 if (gimme == G_SCALAR) {
1629 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1632 if (type == OP_RCATLINE)
1633 SvPV_force_nomg_nolen(sv);
1637 else if (isGV_with_GP(sv)) {
1638 SvPV_force_nomg_nolen(sv);
1640 SvUPGRADE(sv, SVt_PV);
1641 tmplen = SvLEN(sv); /* remember if already alloced */
1642 if (!tmplen && !SvREADONLY(sv)) {
1643 /* try short-buffering it. Please update t/op/readline.t
1644 * if you change the growth length.
1649 if (type == OP_RCATLINE && SvOK(sv)) {
1651 SvPV_force_nomg_nolen(sv);
1657 sv = sv_2mortal(newSV(80));
1661 /* This should not be marked tainted if the fp is marked clean */
1662 #define MAYBE_TAINT_LINE(io, sv) \
1663 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1668 /* delay EOF state for a snarfed empty file */
1669 #define SNARF_EOF(gimme,rs,io,sv) \
1670 (gimme != G_SCALAR || SvCUR(sv) \
1671 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1675 if (!sv_gets(sv, fp, offset)
1677 || SNARF_EOF(gimme, PL_rs, io, sv)
1678 || PerlIO_error(fp)))
1680 PerlIO_clearerr(fp);
1681 if (IoFLAGS(io) & IOf_ARGV) {
1682 fp = nextargv(PL_last_in_gv);
1685 (void)do_close(PL_last_in_gv, FALSE);
1687 else if (type == OP_GLOB) {
1688 if (!do_close(PL_last_in_gv, FALSE)) {
1689 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1690 "glob failed (child exited with status %d%s)",
1691 (int)(STATUS_CURRENT >> 8),
1692 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1695 if (gimme == G_SCALAR) {
1696 if (type != OP_RCATLINE) {
1697 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1703 MAYBE_TAINT_LINE(io, sv);
1706 MAYBE_TAINT_LINE(io, sv);
1708 IoFLAGS(io) |= IOf_NOLINE;
1712 if (type == OP_GLOB) {
1715 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1716 char * const tmps = SvEND(sv) - 1;
1717 if (*tmps == *SvPVX_const(PL_rs)) {
1719 SvCUR_set(sv, SvCUR(sv) - 1);
1722 for (t1 = SvPVX_const(sv); *t1; t1++)
1723 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1724 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1726 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1727 (void)POPs; /* Unmatched wildcard? Chuck it... */
1730 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1731 if (ckWARN(WARN_UTF8)) {
1732 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1733 const STRLEN len = SvCUR(sv) - offset;
1736 if (!is_utf8_string_loc(s, len, &f))
1737 /* Emulate :encoding(utf8) warning in the same case. */
1738 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1739 "utf8 \"\\x%02X\" does not map to Unicode",
1740 f < (U8*)SvEND(sv) ? *f : 0);
1743 if (gimme == G_ARRAY) {
1744 if (SvLEN(sv) - SvCUR(sv) > 20) {
1745 SvPV_shrink_to_cur(sv);
1747 sv = sv_2mortal(newSV(80));
1750 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1751 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1752 const STRLEN new_len
1753 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1754 SvPV_renew(sv, new_len);
1765 SV * const keysv = POPs;
1766 HV * const hv = MUTABLE_HV(POPs);
1767 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1768 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1770 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1771 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1772 bool preeminent = TRUE;
1774 if (SvTYPE(hv) != SVt_PVHV)
1781 /* If we can determine whether the element exist,
1782 * Try to preserve the existenceness of a tied hash
1783 * element by using EXISTS and DELETE if possible.
1784 * Fallback to FETCH and STORE otherwise. */
1785 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1786 preeminent = hv_exists_ent(hv, keysv, 0);
1789 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1790 svp = he ? &HeVAL(he) : NULL;
1792 if (!svp || !*svp || *svp == &PL_sv_undef) {
1796 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1798 lv = sv_newmortal();
1799 sv_upgrade(lv, SVt_PVLV);
1801 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1802 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1803 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1809 if (HvNAME_get(hv) && isGV(*svp))
1810 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1811 else if (preeminent)
1812 save_helem_flags(hv, keysv, svp,
1813 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1815 SAVEHDELETE(hv, keysv);
1817 else if (PL_op->op_private & OPpDEREF) {
1818 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1822 sv = (svp && *svp ? *svp : &PL_sv_undef);
1823 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1824 * was to make C<local $tied{foo} = $tied{foo}> possible.
1825 * However, it seems no longer to be needed for that purpose, and
1826 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1827 * would loop endlessly since the pos magic is getting set on the
1828 * mortal copy and lost. However, the copy has the effect of
1829 * triggering the get magic, and losing it altogether made things like
1830 * c<$tied{foo};> in void context no longer do get magic, which some
1831 * code relied on. Also, delayed triggering of magic on @+ and friends
1832 * meant the original regex may be out of scope by now. So as a
1833 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1834 * being called too many times). */
1835 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1844 register PERL_CONTEXT *cx;
1847 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1848 bool av_is_stack = FALSE;
1851 cx = &cxstack[cxstack_ix];
1852 if (!CxTYPE_is_LOOP(cx))
1853 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1855 itersvp = CxITERVAR(cx);
1856 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1857 /* string increment */
1858 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1859 SV *end = cx->blk_loop.state_u.lazysv.end;
1860 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1861 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1863 const char *max = SvPV_const(end, maxlen);
1864 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1865 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1866 /* safe to reuse old SV */
1867 sv_setsv(*itersvp, cur);
1871 /* we need a fresh SV every time so that loop body sees a
1872 * completely new SV for closures/references to work as
1875 *itersvp = newSVsv(cur);
1876 SvREFCNT_dec(oldsv);
1878 if (strEQ(SvPVX_const(cur), max))
1879 sv_setiv(cur, 0); /* terminate next time */
1886 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1887 /* integer increment */
1888 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1891 /* don't risk potential race */
1892 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1893 /* safe to reuse old SV */
1894 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1898 /* we need a fresh SV every time so that loop body sees a
1899 * completely new SV for closures/references to work as they
1902 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1903 SvREFCNT_dec(oldsv);
1906 /* Handle end of range at IV_MAX */
1907 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1908 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1910 cx->blk_loop.state_u.lazyiv.cur++;
1911 cx->blk_loop.state_u.lazyiv.end++;
1918 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1919 av = cx->blk_loop.state_u.ary.ary;
1924 if (PL_op->op_private & OPpITER_REVERSED) {
1925 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1926 ? cx->blk_loop.resetsp + 1 : 0))
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 (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1942 if (SvMAGICAL(av) || AvREIFY(av)) {
1943 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1944 sv = svp ? *svp : NULL;
1947 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1951 if (sv && SvIS_FREED(sv)) {
1953 Perl_croak(aTHX_ "Use of freed value in iteration");
1958 SvREFCNT_inc_simple_void_NN(sv);
1962 if (!av_is_stack && sv == &PL_sv_undef) {
1963 SV *lv = newSV_type(SVt_PVLV);
1965 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1966 LvTARG(lv) = SvREFCNT_inc_simple(av);
1967 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1968 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1974 SvREFCNT_dec(oldsv);
1980 A description of how taint works in pattern matching and substitution.
1982 While the pattern is being assembled/concatenated and then compiled,
1983 PL_tainted will get set if any component of the pattern is tainted, e.g.
1984 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1985 is set on the pattern if PL_tainted is set.
1987 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1988 the pattern is marked as tainted. This means that subsequent usage, such
1989 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1991 During execution of a pattern, locale-variant ops such as ALNUML set the
1992 local flag RF_tainted. At the end of execution, the engine sets the
1993 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1996 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1997 of $1 et al to indicate whether the returned value should be tainted.
1998 It is the responsibility of the caller of the pattern (i.e. pp_match,
1999 pp_subst etc) to set this flag for any other circumstances where $1 needs
2002 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2004 There are three possible sources of taint
2006 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2007 * the replacement string (or expression under /e)
2009 There are four destinations of taint and they are affected by the sources
2010 according to the rules below:
2012 * the return value (not including /r):
2013 tainted by the source string and pattern, but only for the
2014 number-of-iterations case; boolean returns aren't tainted;
2015 * the modified string (or modified copy under /r):
2016 tainted by the source string, pattern, and replacement strings;
2018 tainted by the pattern, and under 'use re "taint"', by the source
2020 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2021 should always be unset before executing subsequent code.
2023 The overall action of pp_subst is:
2025 * at the start, set bits in rxtainted indicating the taint status of
2026 the various sources.
2028 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2029 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2030 pattern has subsequently become tainted via locale ops.
2032 * If control is being passed to pp_substcont to execute a /e block,
2033 save rxtainted in the CXt_SUBST block, for future use by
2036 * Whenever control is being returned to perl code (either by falling
2037 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2038 use the flag bits in rxtainted to make all the appropriate types of
2039 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2040 et al will appear tainted.
2042 pp_match is just a simpler version of the above.
2049 register PMOP *pm = cPMOP;
2061 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2062 See "how taint works" above */
2065 register REGEXP *rx = PM_GETRE(pm);
2067 int force_on_match = 0;
2068 const I32 oldsave = PL_savestack_ix;
2070 bool doutf8 = FALSE;
2071 #ifdef PERL_OLD_COPY_ON_WRITE
2075 /* known replacement string? */
2076 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2080 if (PL_op->op_flags & OPf_STACKED)
2082 else if (PL_op->op_private & OPpTARGET_MY)
2089 #ifdef PERL_OLD_COPY_ON_WRITE
2090 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2091 because they make integers such as 256 "false". */
2092 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2095 sv_force_normal_flags(TARG,0);
2097 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2098 #ifdef PERL_OLD_COPY_ON_WRITE
2101 && (SvREADONLY(TARG)
2102 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2103 || SvTYPE(TARG) > SVt_PVLV)
2104 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2105 Perl_croak_no_modify(aTHX);
2109 s = SvPV_mutable(TARG, len);
2110 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2113 /* only replace once? */
2114 once = !(rpm->op_pmflags & PMf_GLOBAL);
2116 /* See "how taint works" above */
2119 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2120 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2121 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2122 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2123 ? SUBST_TAINT_BOOLRET : 0));
2127 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2131 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2134 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2135 maxiters = 2 * slen + 10; /* We can match twice at each
2136 position, once with zero-length,
2137 second time with non-zero. */
2139 if (!RX_PRELEN(rx) && PL_curpm) {
2143 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2144 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2145 ? REXEC_COPY_STR : 0;
2147 r_flags |= REXEC_SCREAM;
2150 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2152 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2156 /* How to do it in subst? */
2157 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2159 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2160 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2161 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2162 && (r_flags & REXEC_SCREAM))))
2167 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2168 r_flags | REXEC_CHECKED))
2172 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2173 LEAVE_SCOPE(oldsave);
2177 /* known replacement string? */
2179 if (SvTAINTED(dstr))
2180 rxtainted |= SUBST_TAINT_REPL;
2182 /* Upgrade the source if the replacement is utf8 but the source is not,
2183 * but only if it matched; see
2184 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2186 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2187 char * const orig_pvx = SvPVX(TARG);
2188 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2190 /* If the lengths are the same, the pattern contains only
2191 * invariants, can keep going; otherwise, various internal markers
2192 * could be off, so redo */
2193 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2198 /* replacement needing upgrading? */
2199 if (DO_UTF8(TARG) && !doutf8) {
2200 nsv = sv_newmortal();
2203 sv_recode_to_utf8(nsv, PL_encoding);
2205 sv_utf8_upgrade(nsv);
2206 c = SvPV_const(nsv, clen);
2210 c = SvPV_const(dstr, clen);
2211 doutf8 = DO_UTF8(dstr);
2219 /* can do inplace substitution? */
2221 #ifdef PERL_OLD_COPY_ON_WRITE
2224 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2225 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2226 && (!doutf8 || SvUTF8(TARG))
2227 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2230 #ifdef PERL_OLD_COPY_ON_WRITE
2231 if (SvIsCOW(TARG)) {
2232 assert (!force_on_match);
2236 if (force_on_match) {
2238 s = SvPV_force(TARG, len);
2243 SvSCREAM_off(TARG); /* disable possible screamer */
2245 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2246 rxtainted |= SUBST_TAINT_PAT;
2247 m = orig + RX_OFFS(rx)[0].start;
2248 d = orig + RX_OFFS(rx)[0].end;
2250 if (m - s > strend - d) { /* faster to shorten from end */
2252 Copy(c, m, clen, char);
2257 Move(d, m, i, char);
2261 SvCUR_set(TARG, m - s);
2263 else if ((i = m - s)) { /* faster from front */
2266 Move(s, d - i, i, char);
2269 Copy(c, m, clen, char);
2274 Copy(c, d, clen, char);
2284 if (iters++ > maxiters)
2285 DIE(aTHX_ "Substitution loop");
2286 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2287 rxtainted |= SUBST_TAINT_PAT;
2288 m = RX_OFFS(rx)[0].start + orig;
2291 Move(s, d, i, char);
2295 Copy(c, d, clen, char);
2298 s = RX_OFFS(rx)[0].end + orig;
2299 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2301 /* don't match same null twice */
2302 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2305 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2306 Move(s, d, i+1, char); /* include the NUL */
2313 if (force_on_match) {
2315 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2316 /* I feel that it should be possible to avoid this mortal copy
2317 given that the code below copies into a new destination.
2318 However, I suspect it isn't worth the complexity of
2319 unravelling the C<goto force_it> for the small number of
2320 cases where it would be viable to drop into the copy code. */
2321 TARG = sv_2mortal(newSVsv(TARG));
2323 s = SvPV_force(TARG, len);
2326 #ifdef PERL_OLD_COPY_ON_WRITE
2329 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2330 rxtainted |= SUBST_TAINT_PAT;
2331 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2334 register PERL_CONTEXT *cx;
2336 /* note that a whole bunch of local vars are saved here for
2337 * use by pp_substcont: here's a list of them in case you're
2338 * searching for places in this sub that uses a particular var:
2339 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2340 * s m strend rx once */
2342 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2344 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2346 if (iters++ > maxiters)
2347 DIE(aTHX_ "Substitution loop");
2348 if (RX_MATCH_TAINTED(rx))
2349 rxtainted |= SUBST_TAINT_PAT;
2350 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2353 orig = RX_SUBBEG(rx);
2355 strend = s + (strend - m);
2357 m = RX_OFFS(rx)[0].start + orig;
2358 if (doutf8 && !SvUTF8(dstr))
2359 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2361 sv_catpvn(dstr, s, m-s);
2362 s = RX_OFFS(rx)[0].end + orig;
2364 sv_catpvn(dstr, c, clen);
2367 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2368 TARG, NULL, r_flags));
2369 if (doutf8 && !DO_UTF8(TARG))
2370 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2372 sv_catpvn(dstr, s, strend - s);
2374 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2375 /* From here on down we're using the copy, and leaving the original
2381 #ifdef PERL_OLD_COPY_ON_WRITE
2382 /* The match may make the string COW. If so, brilliant, because
2383 that's just saved us one malloc, copy and free - the regexp has
2384 donated the old buffer, and we malloc an entirely new one, rather
2385 than the regexp malloc()ing a buffer and copying our original,
2386 only for us to throw it away here during the substitution. */
2387 if (SvIsCOW(TARG)) {
2388 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2394 SvPV_set(TARG, SvPVX(dstr));
2395 SvCUR_set(TARG, SvCUR(dstr));
2396 SvLEN_set(TARG, SvLEN(dstr));
2397 doutf8 |= DO_UTF8(dstr);
2398 SvPV_set(dstr, NULL);
2405 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2406 (void)SvPOK_only_UTF8(TARG);
2411 /* See "how taint works" above */
2413 if ((rxtainted & SUBST_TAINT_PAT) ||
2414 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2415 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2417 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2419 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2420 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2422 SvTAINTED_on(TOPs); /* taint return value */
2424 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2426 /* needed for mg_set below */
2428 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2431 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2433 LEAVE_SCOPE(oldsave);
2442 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2443 ++*PL_markstack_ptr;
2445 LEAVE_with_name("grep_item"); /* exit inner scope */
2448 if (PL_stack_base + *PL_markstack_ptr > SP) {
2450 const I32 gimme = GIMME_V;
2452 LEAVE_with_name("grep"); /* exit outer scope */
2453 (void)POPMARK; /* pop src */
2454 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2455 (void)POPMARK; /* pop dst */
2456 SP = PL_stack_base + POPMARK; /* pop original mark */
2457 if (gimme == G_SCALAR) {
2458 if (PL_op->op_private & OPpGREP_LEX) {
2459 SV* const sv = sv_newmortal();
2460 sv_setiv(sv, items);
2468 else if (gimme == G_ARRAY)
2475 ENTER_with_name("grep_item"); /* enter inner scope */
2478 src = PL_stack_base[*PL_markstack_ptr];
2480 if (PL_op->op_private & OPpGREP_LEX)
2481 PAD_SVl(PL_op->op_targ) = src;
2485 RETURNOP(cLOGOP->op_other);
2496 register PERL_CONTEXT *cx;
2499 if (CxMULTICALL(&cxstack[cxstack_ix]))
2503 cxstack_ix++; /* temporarily protect top context */
2506 if (gimme == G_SCALAR) {
2509 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2510 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2511 && !SvMAGICAL(TOPs)) {
2512 *MARK = SvREFCNT_inc(TOPs);
2517 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2519 *MARK = sv_mortalcopy(sv);
2523 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2524 && !SvMAGICAL(TOPs)) {
2528 *MARK = sv_mortalcopy(TOPs);
2532 *MARK = &PL_sv_undef;
2536 else if (gimme == G_ARRAY) {
2537 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2538 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2539 || SvMAGICAL(*MARK)) {
2540 *MARK = sv_mortalcopy(*MARK);
2541 TAINT_NOT; /* Each item is independent */
2549 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2550 PL_curpm = newpm; /* ... and pop $1 et al */
2553 return cx->blk_sub.retop;
2561 register PERL_CONTEXT *cx;
2563 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2566 DIE(aTHX_ "Not a CODE reference");
2567 switch (SvTYPE(sv)) {
2568 /* This is overwhelming the most common case: */
2571 if (!(cv = GvCVu((const GV *)sv))) {
2573 cv = sv_2cv(sv, &stash, &gv, 0);
2582 if(isGV_with_GP(sv)) goto we_have_a_glob;
2585 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2587 SP = PL_stack_base + POPMARK;
2595 sv = amagic_deref_call(sv, to_cv_amg);
2596 /* Don't SPAGAIN here. */
2602 sym = SvPV_nomg_const(sv, len);
2604 DIE(aTHX_ PL_no_usym, "a subroutine");
2605 if (PL_op->op_private & HINT_STRICT_REFS)
2606 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2607 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2610 cv = MUTABLE_CV(SvRV(sv));
2611 if (SvTYPE(cv) == SVt_PVCV)
2616 DIE(aTHX_ "Not a CODE reference");
2617 /* This is the second most common case: */
2619 cv = MUTABLE_CV(sv);
2627 if (CvCLONE(cv) && ! CvCLONED(cv))
2628 DIE(aTHX_ "Closure prototype called");
2629 if (!CvROOT(cv) && !CvXSUB(cv)) {
2633 /* anonymous or undef'd function leaves us no recourse */
2634 if (CvANON(cv) || !(gv = CvGV(cv)))
2635 DIE(aTHX_ "Undefined subroutine called");
2637 /* autoloaded stub? */
2638 if (cv != GvCV(gv)) {
2641 /* should call AUTOLOAD now? */
2644 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2645 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2651 sub_name = sv_newmortal();
2652 gv_efullname3(sub_name, gv, NULL);
2653 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2657 DIE(aTHX_ "Not a CODE reference");
2662 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2663 Perl_get_db_sub(aTHX_ &sv, cv);
2665 PL_curcopdb = PL_curcop;
2667 /* check for lsub that handles lvalue subroutines */
2668 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2669 /* if lsub not found then fall back to DB::sub */
2670 if (!cv) cv = GvCV(PL_DBsub);
2672 cv = GvCV(PL_DBsub);
2675 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2676 DIE(aTHX_ "No DB::sub routine defined");
2679 if (!(CvISXSUB(cv))) {
2680 /* This path taken at least 75% of the time */
2682 register I32 items = SP - MARK;
2683 AV* const padlist = CvPADLIST(cv);
2684 PUSHBLOCK(cx, CXt_SUB, MARK);
2686 cx->blk_sub.retop = PL_op->op_next;
2688 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2689 * that eval'' ops within this sub know the correct lexical space.
2690 * Owing the speed considerations, we choose instead to search for
2691 * the cv using find_runcv() when calling doeval().
2693 if (CvDEPTH(cv) >= 2) {
2694 PERL_STACK_OVERFLOW_CHECK();
2695 pad_push(padlist, CvDEPTH(cv));
2698 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2700 AV *const av = MUTABLE_AV(PAD_SVl(0));
2702 /* @_ is normally not REAL--this should only ever
2703 * happen when DB::sub() calls things that modify @_ */
2708 cx->blk_sub.savearray = GvAV(PL_defgv);
2709 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2710 CX_CURPAD_SAVE(cx->blk_sub);
2711 cx->blk_sub.argarray = av;
2714 if (items > AvMAX(av) + 1) {
2715 SV **ary = AvALLOC(av);
2716 if (AvARRAY(av) != ary) {
2717 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2720 if (items > AvMAX(av) + 1) {
2721 AvMAX(av) = items - 1;
2722 Renew(ary,items,SV*);
2727 Copy(MARK,AvARRAY(av),items,SV*);
2728 AvFILLp(av) = items - 1;
2736 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2738 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2739 /* warning must come *after* we fully set up the context
2740 * stuff so that __WARN__ handlers can safely dounwind()
2743 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2744 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2745 sub_crush_depth(cv);
2746 RETURNOP(CvSTART(cv));
2749 I32 markix = TOPMARK;
2754 /* Need to copy @_ to stack. Alternative may be to
2755 * switch stack to @_, and copy return values
2756 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2757 AV * const av = GvAV(PL_defgv);
2758 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2761 /* Mark is at the end of the stack. */
2763 Copy(AvARRAY(av), SP + 1, items, SV*);
2768 /* We assume first XSUB in &DB::sub is the called one. */
2770 SAVEVPTR(PL_curcop);
2771 PL_curcop = PL_curcopdb;
2774 /* Do we need to open block here? XXXX */
2776 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2778 CvXSUB(cv)(aTHX_ cv);
2780 /* Enforce some sanity in scalar context. */
2781 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2782 if (markix > PL_stack_sp - PL_stack_base)
2783 *(PL_stack_base + markix) = &PL_sv_undef;
2785 *(PL_stack_base + markix) = *PL_stack_sp;
2786 PL_stack_sp = PL_stack_base + markix;
2794 Perl_sub_crush_depth(pTHX_ CV *cv)
2796 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2799 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2801 SV* const tmpstr = sv_newmortal();
2802 gv_efullname3(tmpstr, CvGV(cv), NULL);
2803 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2812 SV* const elemsv = POPs;
2813 IV elem = SvIV(elemsv);
2814 AV *const av = MUTABLE_AV(POPs);
2815 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2816 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2817 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2818 bool preeminent = TRUE;
2821 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2822 Perl_warner(aTHX_ packWARN(WARN_MISC),
2823 "Use of reference \"%"SVf"\" as array index",
2825 if (SvTYPE(av) != SVt_PVAV)
2832 /* If we can determine whether the element exist,
2833 * Try to preserve the existenceness of a tied array
2834 * element by using EXISTS and DELETE if possible.
2835 * Fallback to FETCH and STORE otherwise. */
2836 if (SvCANEXISTDELETE(av))
2837 preeminent = av_exists(av, elem);
2840 svp = av_fetch(av, elem, lval && !defer);
2842 #ifdef PERL_MALLOC_WRAP
2843 if (SvUOK(elemsv)) {
2844 const UV uv = SvUV(elemsv);
2845 elem = uv > IV_MAX ? IV_MAX : uv;
2847 else if (SvNOK(elemsv))
2848 elem = (IV)SvNV(elemsv);
2850 static const char oom_array_extend[] =
2851 "Out of memory during array extend"; /* Duplicated in av.c */
2852 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2855 if (!svp || *svp == &PL_sv_undef) {
2858 DIE(aTHX_ PL_no_aelem, elem);
2859 lv = sv_newmortal();
2860 sv_upgrade(lv, SVt_PVLV);
2862 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2863 LvTARG(lv) = SvREFCNT_inc_simple(av);
2864 LvTARGOFF(lv) = elem;
2871 save_aelem(av, elem, svp);
2873 SAVEADELETE(av, elem);
2875 else if (PL_op->op_private & OPpDEREF) {
2876 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2880 sv = (svp ? *svp : &PL_sv_undef);
2881 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2888 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2890 PERL_ARGS_ASSERT_VIVIFY_REF;
2895 Perl_croak_no_modify(aTHX);
2896 prepare_SV_for_RV(sv);
2899 SvRV_set(sv, newSV(0));
2902 SvRV_set(sv, MUTABLE_SV(newAV()));
2905 SvRV_set(sv, MUTABLE_SV(newHV()));
2912 if (SvGMAGICAL(sv)) {
2913 /* copy the sv without magic to prevent magic from being
2915 SV* msv = sv_newmortal();
2916 sv_setsv_nomg(msv, sv);
2925 SV* const sv = TOPs;
2928 SV* const rsv = SvRV(sv);
2929 if (SvTYPE(rsv) == SVt_PVCV) {
2935 SETs(method_common(sv, NULL));
2942 SV* const sv = cSVOP_sv;
2943 U32 hash = SvSHARED_HASH(sv);
2945 XPUSHs(method_common(sv, &hash));
2950 S_method_common(pTHX_ SV* meth, U32* hashp)
2957 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2959 PERL_ARGS_ASSERT_METHOD_COMMON;
2962 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2967 ob = MUTABLE_SV(SvRV(sv));
2971 const char * packname = NULL;
2972 bool packname_is_utf8 = FALSE;
2974 /* this isn't a reference */
2975 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2976 const HE* const he =
2977 (const HE *)hv_common_key_len(
2978 PL_stashcache, packname,
2979 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2983 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2990 !(iogv = gv_fetchpvn_flags(
2991 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2993 !(ob=MUTABLE_SV(GvIO(iogv))))
2995 /* this isn't the name of a filehandle either */
2997 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2998 ? !isIDFIRST_utf8((U8*)packname)
2999 : !isIDFIRST_L1((U8)*packname)
3002 /* diag_listed_as: Can't call method "%s" without a package or object reference */
3003 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3005 SvOK(sv) ? "without a package or object reference"
3006 : "on an undefined value");
3008 /* assume it's a package name */
3009 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3013 SV* const ref = newSViv(PTR2IV(stash));
3014 (void)hv_store(PL_stashcache, packname,
3015 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3019 /* it _is_ a filehandle name -- replace with a reference */
3020 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3023 /* if we got here, ob should be a reference or a glob */
3024 if (!ob || !(SvOBJECT(ob)
3025 || (SvTYPE(ob) == SVt_PVGV
3027 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3030 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3031 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3032 ? newSVpvs_flags("DOES", SVs_TEMP)
3036 stash = SvSTASH(ob);
3039 /* NOTE: stash may be null, hope hv_fetch_ent and
3040 gv_fetchmethod can cope (it seems they can) */
3042 /* shortcut for simple names */
3044 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3046 gv = MUTABLE_GV(HeVAL(he));
3047 if (isGV(gv) && GvCV(gv) &&
3048 (!GvCVGEN(gv) || GvCVGEN(gv)
3049 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3050 return MUTABLE_SV(GvCV(gv));
3054 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3055 meth, GV_AUTOLOAD | GV_CROAK);
3059 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3064 * c-indentation-style: bsd
3066 * indent-tabs-mode: t
3069 * ex: set ts=8 sts=4 sw=4 noet: