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 if (PL_delaymagic & DM_UID) {
1095 #ifdef HAS_SETRESUID
1096 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1097 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1100 # ifdef HAS_SETREUID
1101 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1102 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1105 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1106 (void)setruid(PL_uid);
1107 PL_delaymagic &= ~DM_RUID;
1109 # endif /* HAS_SETRUID */
1111 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1112 (void)seteuid(PL_euid);
1113 PL_delaymagic &= ~DM_EUID;
1115 # endif /* HAS_SETEUID */
1116 if (PL_delaymagic & DM_UID) {
1117 if (PL_uid != PL_euid)
1118 DIE(aTHX_ "No setreuid available");
1119 (void)PerlProc_setuid(PL_uid);
1121 # endif /* HAS_SETREUID */
1122 #endif /* HAS_SETRESUID */
1123 PL_uid = PerlProc_getuid();
1124 PL_euid = PerlProc_geteuid();
1126 if (PL_delaymagic & DM_GID) {
1127 #ifdef HAS_SETRESGID
1128 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1129 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1132 # ifdef HAS_SETREGID
1133 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1134 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1137 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1138 (void)setrgid(PL_gid);
1139 PL_delaymagic &= ~DM_RGID;
1141 # endif /* HAS_SETRGID */
1143 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1144 (void)setegid(PL_egid);
1145 PL_delaymagic &= ~DM_EGID;
1147 # endif /* HAS_SETEGID */
1148 if (PL_delaymagic & DM_GID) {
1149 if (PL_gid != PL_egid)
1150 DIE(aTHX_ "No setregid available");
1151 (void)PerlProc_setgid(PL_gid);
1153 # endif /* HAS_SETREGID */
1154 #endif /* HAS_SETRESGID */
1155 PL_gid = PerlProc_getgid();
1156 PL_egid = PerlProc_getegid();
1158 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1162 if (gimme == G_VOID)
1163 SP = firstrelem - 1;
1164 else if (gimme == G_SCALAR) {
1167 SETi(lastrelem - firstrelem + 1 - duplicates);
1174 /* at this point we have removed the duplicate key/value
1175 * pairs from the stack, but the remaining values may be
1176 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1177 * the (a 2), but the stack now probably contains
1178 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1179 * obliterates the earlier key. So refresh all values. */
1180 lastrelem -= duplicates;
1181 relem = firsthashrelem;
1182 while (relem < lastrelem) {
1185 he = hv_fetch_ent(hash, sv, 0, 0);
1186 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1192 SP = firstrelem + (lastlelem - firstlelem);
1193 lelem = firstlelem + (relem - firstrelem);
1195 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1204 register PMOP * const pm = cPMOP;
1205 REGEXP * rx = PM_GETRE(pm);
1206 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1207 SV * const rv = sv_newmortal();
1209 SvUPGRADE(rv, SVt_IV);
1210 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1211 loathe to use it here, but it seems to be the right fix. Or close.
1212 The key part appears to be that it's essential for pp_qr to return a new
1213 object (SV), which implies that there needs to be an effective way to
1214 generate a new SV from the existing SV that is pre-compiled in the
1216 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1220 HV *const stash = gv_stashsv(pkg, GV_ADD);
1222 (void)sv_bless(rv, stash);
1225 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1227 SvTAINTED_on(SvRV(rv));
1236 register PMOP *pm = cPMOP;
1238 register const char *t;
1239 register const char *s;
1242 U8 r_flags = REXEC_CHECKED;
1243 const char *truebase; /* Start of string */
1244 register REGEXP *rx = PM_GETRE(pm);
1246 const I32 gimme = GIMME;
1249 const I32 oldsave = PL_savestack_ix;
1250 I32 update_minmatch = 1;
1251 I32 had_zerolen = 0;
1254 if (PL_op->op_flags & OPf_STACKED)
1256 else if (PL_op->op_private & OPpTARGET_MY)
1263 PUTBACK; /* EVAL blocks need stack_sp. */
1264 /* Skip get-magic if this is a qr// clone, because regcomp has
1266 s = ((struct regexp *)SvANY(rx))->mother_re
1267 ? SvPV_nomg_const(TARG, len)
1268 : SvPV_const(TARG, len);
1270 DIE(aTHX_ "panic: pp_match");
1272 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1273 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1276 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1278 /* PMdf_USED is set after a ?? matches once */
1281 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1283 pm->op_pmflags & PMf_USED
1287 if (gimme == G_ARRAY)
1294 /* empty pattern special-cased to use last successful pattern if possible */
1295 if (!RX_PRELEN(rx) && PL_curpm) {
1300 if (RX_MINLEN(rx) > (I32)len)
1305 /* XXXX What part of this is needed with true \G-support? */
1306 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1307 RX_OFFS(rx)[0].start = -1;
1308 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1309 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1310 if (mg && mg->mg_len >= 0) {
1311 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1314 r_flags |= REXEC_IGNOREPOS;
1315 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1316 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1319 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1320 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1321 update_minmatch = 0;
1325 /* XXX: comment out !global get safe $1 vars after a
1326 match, BUT be aware that this leads to dramatic slowdowns on
1327 /g matches against large strings. So far a solution to this problem
1328 appears to be quite tricky.
1329 Test for the unsafe vars are TODO for now. */
1330 if ( (!global && RX_NPARENS(rx))
1331 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1332 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1333 r_flags |= REXEC_COPY_STR;
1335 r_flags |= REXEC_SCREAM;
1338 if (global && RX_OFFS(rx)[0].start != -1) {
1339 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1340 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1342 if (update_minmatch++)
1343 minmatch = had_zerolen;
1345 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1346 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1347 /* FIXME - can PL_bostr be made const char *? */
1348 PL_bostr = (char *)truebase;
1349 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1353 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1355 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1356 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1357 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1358 && (r_flags & REXEC_SCREAM)))
1359 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1362 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1363 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1367 if (dynpm->op_pmflags & PMf_ONCE) {
1369 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1371 dynpm->op_pmflags |= PMf_USED;
1377 RX_MATCH_TAINTED_on(rx);
1378 TAINT_IF(RX_MATCH_TAINTED(rx));
1379 if (gimme == G_ARRAY) {
1380 const I32 nparens = RX_NPARENS(rx);
1381 I32 i = (global && !nparens) ? 1 : 0;
1383 SPAGAIN; /* EVAL blocks could move the stack. */
1384 EXTEND(SP, nparens + i);
1385 EXTEND_MORTAL(nparens + i);
1386 for (i = !i; i <= nparens; i++) {
1387 PUSHs(sv_newmortal());
1388 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1389 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1390 s = RX_OFFS(rx)[i].start + truebase;
1391 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1392 len < 0 || len > strend - s)
1393 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1394 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1395 (long) i, (long) RX_OFFS(rx)[i].start,
1396 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1397 sv_setpvn(*SP, s, len);
1398 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1403 if (dynpm->op_pmflags & PMf_CONTINUE) {
1405 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1406 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408 #ifdef PERL_OLD_COPY_ON_WRITE
1410 sv_force_normal_flags(TARG, 0);
1412 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1413 &PL_vtbl_mglob, NULL, 0);
1415 if (RX_OFFS(rx)[0].start != -1) {
1416 mg->mg_len = RX_OFFS(rx)[0].end;
1417 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1418 mg->mg_flags |= MGf_MINMATCH;
1420 mg->mg_flags &= ~MGf_MINMATCH;
1423 had_zerolen = (RX_OFFS(rx)[0].start != -1
1424 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1425 == (UV)RX_OFFS(rx)[0].end));
1426 PUTBACK; /* EVAL blocks may use stack */
1427 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1432 LEAVE_SCOPE(oldsave);
1438 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1439 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1443 #ifdef PERL_OLD_COPY_ON_WRITE
1445 sv_force_normal_flags(TARG, 0);
1447 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1448 &PL_vtbl_mglob, NULL, 0);
1450 if (RX_OFFS(rx)[0].start != -1) {
1451 mg->mg_len = RX_OFFS(rx)[0].end;
1452 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1453 mg->mg_flags |= MGf_MINMATCH;
1455 mg->mg_flags &= ~MGf_MINMATCH;
1458 LEAVE_SCOPE(oldsave);
1462 yup: /* Confirmed by INTUIT */
1464 RX_MATCH_TAINTED_on(rx);
1465 TAINT_IF(RX_MATCH_TAINTED(rx));
1467 if (dynpm->op_pmflags & PMf_ONCE) {
1469 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1471 dynpm->op_pmflags |= PMf_USED;
1474 if (RX_MATCH_COPIED(rx))
1475 Safefree(RX_SUBBEG(rx));
1476 RX_MATCH_COPIED_off(rx);
1477 RX_SUBBEG(rx) = NULL;
1479 /* FIXME - should rx->subbeg be const char *? */
1480 RX_SUBBEG(rx) = (char *) truebase;
1481 RX_OFFS(rx)[0].start = s - truebase;
1482 if (RX_MATCH_UTF8(rx)) {
1483 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1484 RX_OFFS(rx)[0].end = t - truebase;
1487 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1489 RX_SUBLEN(rx) = strend - truebase;
1492 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1494 #ifdef PERL_OLD_COPY_ON_WRITE
1495 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1497 PerlIO_printf(Perl_debug_log,
1498 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1499 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1502 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1504 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1505 assert (SvPOKp(RX_SAVED_COPY(rx)));
1510 RX_SUBBEG(rx) = savepvn(t, strend - t);
1511 #ifdef PERL_OLD_COPY_ON_WRITE
1512 RX_SAVED_COPY(rx) = NULL;
1515 RX_SUBLEN(rx) = strend - t;
1516 RX_MATCH_COPIED_on(rx);
1517 off = RX_OFFS(rx)[0].start = s - t;
1518 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1520 else { /* startp/endp are used by @- @+. */
1521 RX_OFFS(rx)[0].start = s - truebase;
1522 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1524 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1526 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1527 LEAVE_SCOPE(oldsave);
1532 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1533 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1534 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1539 LEAVE_SCOPE(oldsave);
1540 if (gimme == G_ARRAY)
1546 Perl_do_readline(pTHX)
1548 dVAR; dSP; dTARGETSTACKED;
1553 register IO * const io = GvIO(PL_last_in_gv);
1554 register const I32 type = PL_op->op_type;
1555 const I32 gimme = GIMME_V;
1558 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1560 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1561 if (gimme == G_SCALAR) {
1563 SvSetSV_nosteal(TARG, TOPs);
1573 if (IoFLAGS(io) & IOf_ARGV) {
1574 if (IoFLAGS(io) & IOf_START) {
1576 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1577 IoFLAGS(io) &= ~IOf_START;
1578 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1579 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1580 SvSETMAGIC(GvSV(PL_last_in_gv));
1585 fp = nextargv(PL_last_in_gv);
1586 if (!fp) { /* Note: fp != IoIFP(io) */
1587 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1590 else if (type == OP_GLOB)
1591 fp = Perl_start_glob(aTHX_ POPs, io);
1593 else if (type == OP_GLOB)
1595 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1596 report_wrongway_fh(PL_last_in_gv, '>');
1600 if ((!io || !(IoFLAGS(io) & IOf_START))
1601 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1603 if (type == OP_GLOB)
1604 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1605 "glob failed (can't start child: %s)",
1608 report_evil_fh(PL_last_in_gv);
1610 if (gimme == G_SCALAR) {
1611 /* undef TARG, and push that undefined value */
1612 if (type != OP_RCATLINE) {
1613 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1621 if (gimme == G_SCALAR) {
1623 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1626 if (type == OP_RCATLINE)
1627 SvPV_force_nomg_nolen(sv);
1631 else if (isGV_with_GP(sv)) {
1632 SvPV_force_nomg_nolen(sv);
1634 SvUPGRADE(sv, SVt_PV);
1635 tmplen = SvLEN(sv); /* remember if already alloced */
1636 if (!tmplen && !SvREADONLY(sv)) {
1637 /* try short-buffering it. Please update t/op/readline.t
1638 * if you change the growth length.
1643 if (type == OP_RCATLINE && SvOK(sv)) {
1645 SvPV_force_nomg_nolen(sv);
1651 sv = sv_2mortal(newSV(80));
1655 /* This should not be marked tainted if the fp is marked clean */
1656 #define MAYBE_TAINT_LINE(io, sv) \
1657 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1662 /* delay EOF state for a snarfed empty file */
1663 #define SNARF_EOF(gimme,rs,io,sv) \
1664 (gimme != G_SCALAR || SvCUR(sv) \
1665 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1669 if (!sv_gets(sv, fp, offset)
1671 || SNARF_EOF(gimme, PL_rs, io, sv)
1672 || PerlIO_error(fp)))
1674 PerlIO_clearerr(fp);
1675 if (IoFLAGS(io) & IOf_ARGV) {
1676 fp = nextargv(PL_last_in_gv);
1679 (void)do_close(PL_last_in_gv, FALSE);
1681 else if (type == OP_GLOB) {
1682 if (!do_close(PL_last_in_gv, FALSE)) {
1683 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1684 "glob failed (child exited with status %d%s)",
1685 (int)(STATUS_CURRENT >> 8),
1686 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1689 if (gimme == G_SCALAR) {
1690 if (type != OP_RCATLINE) {
1691 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1697 MAYBE_TAINT_LINE(io, sv);
1700 MAYBE_TAINT_LINE(io, sv);
1702 IoFLAGS(io) |= IOf_NOLINE;
1706 if (type == OP_GLOB) {
1709 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1710 char * const tmps = SvEND(sv) - 1;
1711 if (*tmps == *SvPVX_const(PL_rs)) {
1713 SvCUR_set(sv, SvCUR(sv) - 1);
1716 for (t1 = SvPVX_const(sv); *t1; t1++)
1717 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1718 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1720 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1721 (void)POPs; /* Unmatched wildcard? Chuck it... */
1724 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1725 if (ckWARN(WARN_UTF8)) {
1726 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1727 const STRLEN len = SvCUR(sv) - offset;
1730 if (!is_utf8_string_loc(s, len, &f))
1731 /* Emulate :encoding(utf8) warning in the same case. */
1732 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1733 "utf8 \"\\x%02X\" does not map to Unicode",
1734 f < (U8*)SvEND(sv) ? *f : 0);
1737 if (gimme == G_ARRAY) {
1738 if (SvLEN(sv) - SvCUR(sv) > 20) {
1739 SvPV_shrink_to_cur(sv);
1741 sv = sv_2mortal(newSV(80));
1744 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1745 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1746 const STRLEN new_len
1747 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1748 SvPV_renew(sv, new_len);
1759 SV * const keysv = POPs;
1760 HV * const hv = MUTABLE_HV(POPs);
1761 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1762 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1764 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1765 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1766 bool preeminent = TRUE;
1768 if (SvTYPE(hv) != SVt_PVHV)
1775 /* If we can determine whether the element exist,
1776 * Try to preserve the existenceness of a tied hash
1777 * element by using EXISTS and DELETE if possible.
1778 * Fallback to FETCH and STORE otherwise. */
1779 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1780 preeminent = hv_exists_ent(hv, keysv, 0);
1783 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1784 svp = he ? &HeVAL(he) : NULL;
1786 if (!svp || !*svp || *svp == &PL_sv_undef) {
1790 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1792 lv = sv_newmortal();
1793 sv_upgrade(lv, SVt_PVLV);
1795 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1796 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1797 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1803 if (HvNAME_get(hv) && isGV(*svp))
1804 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1805 else if (preeminent)
1806 save_helem_flags(hv, keysv, svp,
1807 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1809 SAVEHDELETE(hv, keysv);
1811 else if (PL_op->op_private & OPpDEREF) {
1812 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1816 sv = (svp && *svp ? *svp : &PL_sv_undef);
1817 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1818 * was to make C<local $tied{foo} = $tied{foo}> possible.
1819 * However, it seems no longer to be needed for that purpose, and
1820 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1821 * would loop endlessly since the pos magic is getting set on the
1822 * mortal copy and lost. However, the copy has the effect of
1823 * triggering the get magic, and losing it altogether made things like
1824 * c<$tied{foo};> in void context no longer do get magic, which some
1825 * code relied on. Also, delayed triggering of magic on @+ and friends
1826 * meant the original regex may be out of scope by now. So as a
1827 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1828 * being called too many times). */
1829 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1838 register PERL_CONTEXT *cx;
1841 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1842 bool av_is_stack = FALSE;
1845 cx = &cxstack[cxstack_ix];
1846 if (!CxTYPE_is_LOOP(cx))
1847 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1849 itersvp = CxITERVAR(cx);
1850 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1851 /* string increment */
1852 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1853 SV *end = cx->blk_loop.state_u.lazysv.end;
1854 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1855 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1857 const char *max = SvPV_const(end, maxlen);
1858 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1859 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1860 /* safe to reuse old SV */
1861 sv_setsv(*itersvp, cur);
1865 /* we need a fresh SV every time so that loop body sees a
1866 * completely new SV for closures/references to work as
1869 *itersvp = newSVsv(cur);
1870 SvREFCNT_dec(oldsv);
1872 if (strEQ(SvPVX_const(cur), max))
1873 sv_setiv(cur, 0); /* terminate next time */
1880 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1881 /* integer increment */
1882 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1885 /* don't risk potential race */
1886 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1887 /* safe to reuse old SV */
1888 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1892 /* we need a fresh SV every time so that loop body sees a
1893 * completely new SV for closures/references to work as they
1896 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1897 SvREFCNT_dec(oldsv);
1900 /* Handle end of range at IV_MAX */
1901 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1902 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1904 cx->blk_loop.state_u.lazyiv.cur++;
1905 cx->blk_loop.state_u.lazyiv.end++;
1912 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1913 av = cx->blk_loop.state_u.ary.ary;
1918 if (PL_op->op_private & OPpITER_REVERSED) {
1919 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1920 ? cx->blk_loop.resetsp + 1 : 0))
1923 if (SvMAGICAL(av) || AvREIFY(av)) {
1924 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1925 sv = svp ? *svp : NULL;
1928 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1932 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1936 if (SvMAGICAL(av) || AvREIFY(av)) {
1937 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1938 sv = svp ? *svp : NULL;
1941 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1945 if (sv && SvIS_FREED(sv)) {
1947 Perl_croak(aTHX_ "Use of freed value in iteration");
1952 SvREFCNT_inc_simple_void_NN(sv);
1956 if (!av_is_stack && sv == &PL_sv_undef) {
1957 SV *lv = newSV_type(SVt_PVLV);
1959 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1960 LvTARG(lv) = SvREFCNT_inc_simple(av);
1961 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1962 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1968 SvREFCNT_dec(oldsv);
1974 A description of how taint works in pattern matching and substitution.
1976 While the pattern is being assembled/concatenated and then compiled,
1977 PL_tainted will get set if any component of the pattern is tainted, e.g.
1978 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1979 is set on the pattern if PL_tainted is set.
1981 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1982 the pattern is marked as tainted. This means that subsequent usage, such
1983 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1985 During execution of a pattern, locale-variant ops such as ALNUML set the
1986 local flag RF_tainted. At the end of execution, the engine sets the
1987 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1990 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1991 of $1 et al to indicate whether the returned value should be tainted.
1992 It is the responsibility of the caller of the pattern (i.e. pp_match,
1993 pp_subst etc) to set this flag for any other circumstances where $1 needs
1996 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1998 There are three possible sources of taint
2000 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2001 * the replacement string (or expression under /e)
2003 There are four destinations of taint and they are affected by the sources
2004 according to the rules below:
2006 * the return value (not including /r):
2007 tainted by the source string and pattern, but only for the
2008 number-of-iterations case; boolean returns aren't tainted;
2009 * the modified string (or modified copy under /r):
2010 tainted by the source string, pattern, and replacement strings;
2012 tainted by the pattern, and under 'use re "taint"', by the source
2014 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2015 should always be unset before executing subsequent code.
2017 The overall action of pp_subst is:
2019 * at the start, set bits in rxtainted indicating the taint status of
2020 the various sources.
2022 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2023 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2024 pattern has subsequently become tainted via locale ops.
2026 * If control is being passed to pp_substcont to execute a /e block,
2027 save rxtainted in the CXt_SUBST block, for future use by
2030 * Whenever control is being returned to perl code (either by falling
2031 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2032 use the flag bits in rxtainted to make all the appropriate types of
2033 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2034 et al will appear tainted.
2036 pp_match is just a simpler version of the above.
2043 register PMOP *pm = cPMOP;
2055 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2056 See "how taint works" above */
2059 register REGEXP *rx = PM_GETRE(pm);
2061 int force_on_match = 0;
2062 const I32 oldsave = PL_savestack_ix;
2064 bool doutf8 = FALSE;
2065 #ifdef PERL_OLD_COPY_ON_WRITE
2069 /* known replacement string? */
2070 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2074 if (PL_op->op_flags & OPf_STACKED)
2076 else if (PL_op->op_private & OPpTARGET_MY)
2083 #ifdef PERL_OLD_COPY_ON_WRITE
2084 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2085 because they make integers such as 256 "false". */
2086 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089 sv_force_normal_flags(TARG,0);
2091 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2092 #ifdef PERL_OLD_COPY_ON_WRITE
2095 && (SvREADONLY(TARG)
2096 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2097 || SvTYPE(TARG) > SVt_PVLV)
2098 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2099 Perl_croak_no_modify(aTHX);
2103 s = SvPV_mutable(TARG, len);
2104 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2107 /* only replace once? */
2108 once = !(rpm->op_pmflags & PMf_GLOBAL);
2110 /* See "how taint works" above */
2113 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2114 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2115 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2116 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2117 ? SUBST_TAINT_BOOLRET : 0));
2121 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2125 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2128 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2129 maxiters = 2 * slen + 10; /* We can match twice at each
2130 position, once with zero-length,
2131 second time with non-zero. */
2133 if (!RX_PRELEN(rx) && PL_curpm) {
2137 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2138 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2139 ? REXEC_COPY_STR : 0;
2141 r_flags |= REXEC_SCREAM;
2144 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2146 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2150 /* How to do it in subst? */
2151 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2153 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2154 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2155 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2156 && (r_flags & REXEC_SCREAM))))
2161 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2162 r_flags | REXEC_CHECKED))
2166 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2167 LEAVE_SCOPE(oldsave);
2171 /* known replacement string? */
2173 if (SvTAINTED(dstr))
2174 rxtainted |= SUBST_TAINT_REPL;
2176 /* Upgrade the source if the replacement is utf8 but the source is not,
2177 * but only if it matched; see
2178 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2180 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2181 char * const orig_pvx = SvPVX(TARG);
2182 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2184 /* If the lengths are the same, the pattern contains only
2185 * invariants, can keep going; otherwise, various internal markers
2186 * could be off, so redo */
2187 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2192 /* replacement needing upgrading? */
2193 if (DO_UTF8(TARG) && !doutf8) {
2194 nsv = sv_newmortal();
2197 sv_recode_to_utf8(nsv, PL_encoding);
2199 sv_utf8_upgrade(nsv);
2200 c = SvPV_const(nsv, clen);
2204 c = SvPV_const(dstr, clen);
2205 doutf8 = DO_UTF8(dstr);
2213 /* can do inplace substitution? */
2215 #ifdef PERL_OLD_COPY_ON_WRITE
2218 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2219 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2220 && (!doutf8 || SvUTF8(TARG))
2221 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2224 #ifdef PERL_OLD_COPY_ON_WRITE
2225 if (SvIsCOW(TARG)) {
2226 assert (!force_on_match);
2230 if (force_on_match) {
2232 s = SvPV_force(TARG, len);
2237 SvSCREAM_off(TARG); /* disable possible screamer */
2239 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2240 rxtainted |= SUBST_TAINT_PAT;
2241 m = orig + RX_OFFS(rx)[0].start;
2242 d = orig + RX_OFFS(rx)[0].end;
2244 if (m - s > strend - d) { /* faster to shorten from end */
2246 Copy(c, m, clen, char);
2251 Move(d, m, i, char);
2255 SvCUR_set(TARG, m - s);
2257 else if ((i = m - s)) { /* faster from front */
2260 Move(s, d - i, i, char);
2263 Copy(c, m, clen, char);
2268 Copy(c, d, clen, char);
2278 if (iters++ > maxiters)
2279 DIE(aTHX_ "Substitution loop");
2280 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2281 rxtainted |= SUBST_TAINT_PAT;
2282 m = RX_OFFS(rx)[0].start + orig;
2285 Move(s, d, i, char);
2289 Copy(c, d, clen, char);
2292 s = RX_OFFS(rx)[0].end + orig;
2293 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2295 /* don't match same null twice */
2296 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2299 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2300 Move(s, d, i+1, char); /* include the NUL */
2307 if (force_on_match) {
2309 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2310 /* I feel that it should be possible to avoid this mortal copy
2311 given that the code below copies into a new destination.
2312 However, I suspect it isn't worth the complexity of
2313 unravelling the C<goto force_it> for the small number of
2314 cases where it would be viable to drop into the copy code. */
2315 TARG = sv_2mortal(newSVsv(TARG));
2317 s = SvPV_force(TARG, len);
2320 #ifdef PERL_OLD_COPY_ON_WRITE
2323 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2324 rxtainted |= SUBST_TAINT_PAT;
2325 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2328 register PERL_CONTEXT *cx;
2330 /* note that a whole bunch of local vars are saved here for
2331 * use by pp_substcont: here's a list of them in case you're
2332 * searching for places in this sub that uses a particular var:
2333 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2334 * s m strend rx once */
2336 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2338 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2340 if (iters++ > maxiters)
2341 DIE(aTHX_ "Substitution loop");
2342 if (RX_MATCH_TAINTED(rx))
2343 rxtainted |= SUBST_TAINT_PAT;
2344 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2347 orig = RX_SUBBEG(rx);
2349 strend = s + (strend - m);
2351 m = RX_OFFS(rx)[0].start + orig;
2352 if (doutf8 && !SvUTF8(dstr))
2353 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2355 sv_catpvn(dstr, s, m-s);
2356 s = RX_OFFS(rx)[0].end + orig;
2358 sv_catpvn(dstr, c, clen);
2361 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2362 TARG, NULL, r_flags));
2363 if (doutf8 && !DO_UTF8(TARG))
2364 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2366 sv_catpvn(dstr, s, strend - s);
2368 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2369 /* From here on down we're using the copy, and leaving the original
2375 #ifdef PERL_OLD_COPY_ON_WRITE
2376 /* The match may make the string COW. If so, brilliant, because
2377 that's just saved us one malloc, copy and free - the regexp has
2378 donated the old buffer, and we malloc an entirely new one, rather
2379 than the regexp malloc()ing a buffer and copying our original,
2380 only for us to throw it away here during the substitution. */
2381 if (SvIsCOW(TARG)) {
2382 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2388 SvPV_set(TARG, SvPVX(dstr));
2389 SvCUR_set(TARG, SvCUR(dstr));
2390 SvLEN_set(TARG, SvLEN(dstr));
2391 doutf8 |= DO_UTF8(dstr);
2392 SvPV_set(dstr, NULL);
2399 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2400 (void)SvPOK_only_UTF8(TARG);
2405 /* See "how taint works" above */
2407 if ((rxtainted & SUBST_TAINT_PAT) ||
2408 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2409 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2411 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2413 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2414 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2416 SvTAINTED_on(TOPs); /* taint return value */
2418 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2420 /* needed for mg_set below */
2422 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2425 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2427 LEAVE_SCOPE(oldsave);
2436 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2437 ++*PL_markstack_ptr;
2439 LEAVE_with_name("grep_item"); /* exit inner scope */
2442 if (PL_stack_base + *PL_markstack_ptr > SP) {
2444 const I32 gimme = GIMME_V;
2446 LEAVE_with_name("grep"); /* exit outer scope */
2447 (void)POPMARK; /* pop src */
2448 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2449 (void)POPMARK; /* pop dst */
2450 SP = PL_stack_base + POPMARK; /* pop original mark */
2451 if (gimme == G_SCALAR) {
2452 if (PL_op->op_private & OPpGREP_LEX) {
2453 SV* const sv = sv_newmortal();
2454 sv_setiv(sv, items);
2462 else if (gimme == G_ARRAY)
2469 ENTER_with_name("grep_item"); /* enter inner scope */
2472 src = PL_stack_base[*PL_markstack_ptr];
2474 if (PL_op->op_private & OPpGREP_LEX)
2475 PAD_SVl(PL_op->op_targ) = src;
2479 RETURNOP(cLOGOP->op_other);
2490 register PERL_CONTEXT *cx;
2493 if (CxMULTICALL(&cxstack[cxstack_ix]))
2497 cxstack_ix++; /* temporarily protect top context */
2500 if (gimme == G_SCALAR) {
2503 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2504 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2505 && !SvMAGICAL(TOPs)) {
2506 *MARK = SvREFCNT_inc(TOPs);
2511 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2513 *MARK = sv_mortalcopy(sv);
2517 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2518 && !SvMAGICAL(TOPs)) {
2522 *MARK = sv_mortalcopy(TOPs);
2526 *MARK = &PL_sv_undef;
2530 else if (gimme == G_ARRAY) {
2531 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2532 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2533 || SvMAGICAL(*MARK)) {
2534 *MARK = sv_mortalcopy(*MARK);
2535 TAINT_NOT; /* Each item is independent */
2543 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2544 PL_curpm = newpm; /* ... and pop $1 et al */
2547 return cx->blk_sub.retop;
2555 register PERL_CONTEXT *cx;
2557 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2560 DIE(aTHX_ "Not a CODE reference");
2561 switch (SvTYPE(sv)) {
2562 /* This is overwhelming the most common case: */
2565 if (!(cv = GvCVu((const GV *)sv))) {
2567 cv = sv_2cv(sv, &stash, &gv, 0);
2576 if(isGV_with_GP(sv)) goto we_have_a_glob;
2579 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2581 SP = PL_stack_base + POPMARK;
2589 sv = amagic_deref_call(sv, to_cv_amg);
2590 /* Don't SPAGAIN here. */
2596 sym = SvPV_nomg_const(sv, len);
2598 DIE(aTHX_ PL_no_usym, "a subroutine");
2599 if (PL_op->op_private & HINT_STRICT_REFS)
2600 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2601 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2604 cv = MUTABLE_CV(SvRV(sv));
2605 if (SvTYPE(cv) == SVt_PVCV)
2610 DIE(aTHX_ "Not a CODE reference");
2611 /* This is the second most common case: */
2613 cv = MUTABLE_CV(sv);
2621 if (CvCLONE(cv) && ! CvCLONED(cv))
2622 DIE(aTHX_ "Closure prototype called");
2623 if (!CvROOT(cv) && !CvXSUB(cv)) {
2627 /* anonymous or undef'd function leaves us no recourse */
2628 if (CvANON(cv) || !(gv = CvGV(cv)))
2629 DIE(aTHX_ "Undefined subroutine called");
2631 /* autoloaded stub? */
2632 if (cv != GvCV(gv)) {
2635 /* should call AUTOLOAD now? */
2638 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2639 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2645 sub_name = sv_newmortal();
2646 gv_efullname3(sub_name, gv, NULL);
2647 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2651 DIE(aTHX_ "Not a CODE reference");
2656 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2657 Perl_get_db_sub(aTHX_ &sv, cv);
2659 PL_curcopdb = PL_curcop;
2661 /* check for lsub that handles lvalue subroutines */
2662 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2663 /* if lsub not found then fall back to DB::sub */
2664 if (!cv) cv = GvCV(PL_DBsub);
2666 cv = GvCV(PL_DBsub);
2669 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2670 DIE(aTHX_ "No DB::sub routine defined");
2673 if (!(CvISXSUB(cv))) {
2674 /* This path taken at least 75% of the time */
2676 register I32 items = SP - MARK;
2677 AV* const padlist = CvPADLIST(cv);
2678 PUSHBLOCK(cx, CXt_SUB, MARK);
2680 cx->blk_sub.retop = PL_op->op_next;
2682 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2683 * that eval'' ops within this sub know the correct lexical space.
2684 * Owing the speed considerations, we choose instead to search for
2685 * the cv using find_runcv() when calling doeval().
2687 if (CvDEPTH(cv) >= 2) {
2688 PERL_STACK_OVERFLOW_CHECK();
2689 pad_push(padlist, CvDEPTH(cv));
2692 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2694 AV *const av = MUTABLE_AV(PAD_SVl(0));
2696 /* @_ is normally not REAL--this should only ever
2697 * happen when DB::sub() calls things that modify @_ */
2702 cx->blk_sub.savearray = GvAV(PL_defgv);
2703 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2704 CX_CURPAD_SAVE(cx->blk_sub);
2705 cx->blk_sub.argarray = av;
2708 if (items > AvMAX(av) + 1) {
2709 SV **ary = AvALLOC(av);
2710 if (AvARRAY(av) != ary) {
2711 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2714 if (items > AvMAX(av) + 1) {
2715 AvMAX(av) = items - 1;
2716 Renew(ary,items,SV*);
2721 Copy(MARK,AvARRAY(av),items,SV*);
2722 AvFILLp(av) = items - 1;
2730 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2732 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2733 /* warning must come *after* we fully set up the context
2734 * stuff so that __WARN__ handlers can safely dounwind()
2737 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2738 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2739 sub_crush_depth(cv);
2740 RETURNOP(CvSTART(cv));
2743 I32 markix = TOPMARK;
2748 /* Need to copy @_ to stack. Alternative may be to
2749 * switch stack to @_, and copy return values
2750 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2751 AV * const av = GvAV(PL_defgv);
2752 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2755 /* Mark is at the end of the stack. */
2757 Copy(AvARRAY(av), SP + 1, items, SV*);
2762 /* We assume first XSUB in &DB::sub is the called one. */
2764 SAVEVPTR(PL_curcop);
2765 PL_curcop = PL_curcopdb;
2768 /* Do we need to open block here? XXXX */
2770 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2772 CvXSUB(cv)(aTHX_ cv);
2774 /* Enforce some sanity in scalar context. */
2775 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2776 if (markix > PL_stack_sp - PL_stack_base)
2777 *(PL_stack_base + markix) = &PL_sv_undef;
2779 *(PL_stack_base + markix) = *PL_stack_sp;
2780 PL_stack_sp = PL_stack_base + markix;
2788 Perl_sub_crush_depth(pTHX_ CV *cv)
2790 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2793 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2795 SV* const tmpstr = sv_newmortal();
2796 gv_efullname3(tmpstr, CvGV(cv), NULL);
2797 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2806 SV* const elemsv = POPs;
2807 IV elem = SvIV(elemsv);
2808 AV *const av = MUTABLE_AV(POPs);
2809 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2810 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2811 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2812 bool preeminent = TRUE;
2815 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2816 Perl_warner(aTHX_ packWARN(WARN_MISC),
2817 "Use of reference \"%"SVf"\" as array index",
2819 if (SvTYPE(av) != SVt_PVAV)
2826 /* If we can determine whether the element exist,
2827 * Try to preserve the existenceness of a tied array
2828 * element by using EXISTS and DELETE if possible.
2829 * Fallback to FETCH and STORE otherwise. */
2830 if (SvCANEXISTDELETE(av))
2831 preeminent = av_exists(av, elem);
2834 svp = av_fetch(av, elem, lval && !defer);
2836 #ifdef PERL_MALLOC_WRAP
2837 if (SvUOK(elemsv)) {
2838 const UV uv = SvUV(elemsv);
2839 elem = uv > IV_MAX ? IV_MAX : uv;
2841 else if (SvNOK(elemsv))
2842 elem = (IV)SvNV(elemsv);
2844 static const char oom_array_extend[] =
2845 "Out of memory during array extend"; /* Duplicated in av.c */
2846 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2849 if (!svp || *svp == &PL_sv_undef) {
2852 DIE(aTHX_ PL_no_aelem, elem);
2853 lv = sv_newmortal();
2854 sv_upgrade(lv, SVt_PVLV);
2856 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2857 LvTARG(lv) = SvREFCNT_inc_simple(av);
2858 LvTARGOFF(lv) = elem;
2865 save_aelem(av, elem, svp);
2867 SAVEADELETE(av, elem);
2869 else if (PL_op->op_private & OPpDEREF) {
2870 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2874 sv = (svp ? *svp : &PL_sv_undef);
2875 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2882 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2884 PERL_ARGS_ASSERT_VIVIFY_REF;
2889 Perl_croak_no_modify(aTHX);
2890 prepare_SV_for_RV(sv);
2893 SvRV_set(sv, newSV(0));
2896 SvRV_set(sv, MUTABLE_SV(newAV()));
2899 SvRV_set(sv, MUTABLE_SV(newHV()));
2906 if (SvGMAGICAL(sv)) {
2907 /* copy the sv without magic to prevent magic from being
2909 SV* msv = sv_newmortal();
2910 sv_setsv_nomg(msv, sv);
2919 SV* const sv = TOPs;
2922 SV* const rsv = SvRV(sv);
2923 if (SvTYPE(rsv) == SVt_PVCV) {
2929 SETs(method_common(sv, NULL));
2936 SV* const sv = cSVOP_sv;
2937 U32 hash = SvSHARED_HASH(sv);
2939 XPUSHs(method_common(sv, &hash));
2944 S_method_common(pTHX_ SV* meth, U32* hashp)
2951 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2953 PERL_ARGS_ASSERT_METHOD_COMMON;
2956 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2961 ob = MUTABLE_SV(SvRV(sv));
2965 const char * packname = NULL;
2966 bool packname_is_utf8 = FALSE;
2968 /* this isn't a reference */
2969 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2970 const HE* const he =
2971 (const HE *)hv_common_key_len(
2972 PL_stashcache, packname,
2973 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2977 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2984 !(iogv = gv_fetchpvn_flags(
2985 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2987 !(ob=MUTABLE_SV(GvIO(iogv))))
2989 /* this isn't the name of a filehandle either */
2991 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2992 ? !isIDFIRST_utf8((U8*)packname)
2993 : !isIDFIRST_L1((U8)*packname)
2996 /* diag_listed_as: Can't call method "%s" without a package or object reference */
2997 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2999 SvOK(sv) ? "without a package or object reference"
3000 : "on an undefined value");
3002 /* assume it's a package name */
3003 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3007 SV* const ref = newSViv(PTR2IV(stash));
3008 (void)hv_store(PL_stashcache, packname,
3009 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3013 /* it _is_ a filehandle name -- replace with a reference */
3014 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3017 /* if we got here, ob should be a reference or a glob */
3018 if (!ob || !(SvOBJECT(ob)
3019 || (SvTYPE(ob) == SVt_PVGV
3021 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3024 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3025 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3026 ? newSVpvs_flags("DOES", SVs_TEMP)
3030 stash = SvSTASH(ob);
3033 /* NOTE: stash may be null, hope hv_fetch_ent and
3034 gv_fetchmethod can cope (it seems they can) */
3036 /* shortcut for simple names */
3038 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3040 gv = MUTABLE_GV(HeVAL(he));
3041 if (isGV(gv) && GvCV(gv) &&
3042 (!GvCVGEN(gv) || GvCVGEN(gv)
3043 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3044 return MUTABLE_SV(GvCV(gv));
3048 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3049 meth, GV_AUTOLOAD | GV_CROAK);
3053 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3058 * c-indentation-style: bsd
3060 * indent-tabs-mode: t
3063 * ex: set ts=8 sts=4 sw=4 noet: