3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
51 PL_curcop = (COP*)PL_op;
52 TAINT_NOT; /* Each statement is presumed innocent */
53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
64 if (PL_op->op_private & OPpLVAL_INTRO)
65 PUSHs(save_scalar(cGVOP_gv));
67 PUSHs(GvSVn(cGVOP_gv));
80 PUSHMARK(PL_stack_sp);
95 XPUSHs(MUTABLE_SV(cGVOP_gv));
106 if (PL_op->op_type == OP_AND)
108 RETURNOP(cLOGOP->op_other);
114 dVAR; dSP; dPOPTOPssrl;
116 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
117 SV * const temp = left;
118 left = right; right = temp;
120 if (PL_tainting && PL_tainted && !SvTAINTED(left))
122 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
123 SV * const cv = SvRV(left);
124 const U32 cv_type = SvTYPE(cv);
125 const bool is_gv = isGV_with_GP(right);
126 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
132 /* Can do the optimisation if right (LVALUE) is not a typeglob,
133 left (RVALUE) is a reference to something, and we're in void
135 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
136 /* Is the target symbol table currently empty? */
137 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
138 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
139 /* Good. Create a new proxy constant subroutine in the target.
140 The gv becomes a(nother) reference to the constant. */
141 SV *const value = SvRV(cv);
143 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
144 SvPCS_IMPORTED_on(gv);
146 SvREFCNT_inc_simple_void(value);
152 /* Need to fix things up. */
154 /* Need to fix GV. */
155 right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
159 /* We've been returned a constant rather than a full subroutine,
160 but they expect a subroutine reference to apply. */
162 ENTER_with_name("sassign_coderef");
163 SvREFCNT_inc_void(SvRV(cv));
164 /* newCONSTSUB takes a reference count on the passed in SV
165 from us. We set the name to NULL, otherwise we get into
166 all sorts of fun as the reference to our new sub is
167 donated to the GV that we're about to assign to.
169 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
172 LEAVE_with_name("sassign_coderef");
174 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
176 First: ops for \&{"BONK"}; return us the constant in the
178 Second: ops for *{"BONK"} cause that symbol table entry
179 (and our reference to it) to be upgraded from RV
181 Thirdly: We get here. cv is actually PVGV now, and its
182 GvCV() is actually the subroutine we're looking for
184 So change the reference so that it points to the subroutine
185 of that typeglob, as that's what they were after all along.
187 GV *const upgraded = MUTABLE_GV(cv);
188 CV *const source = GvCV(upgraded);
191 assert(CvFLAGS(source) & CVf_CONST);
193 SvREFCNT_inc_void(source);
194 SvREFCNT_dec(upgraded);
195 SvRV_set(left, MUTABLE_SV(source));
201 SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
202 (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
205 packWARN(WARN_MISC), "Useless assignment to a temporary"
207 SvSetMagicSV(right, left);
217 RETURNOP(cLOGOP->op_other);
219 RETURNOP(cLOGOP->op_next);
226 TAINT_NOT; /* Each statement is presumed innocent */
227 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
229 if (!(PL_op->op_flags & OPf_SPECIAL)) {
230 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
231 LEAVE_SCOPE(oldsave);
238 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
243 const char *rpv = NULL;
245 bool rcopied = FALSE;
247 if (TARG == right && right != left) { /* $r = $l.$r */
248 rpv = SvPV_nomg_const(right, rlen);
249 rbyte = !DO_UTF8(right);
250 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
251 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
255 if (TARG != left) { /* not $l .= $r */
257 const char* const lpv = SvPV_nomg_const(left, llen);
258 lbyte = !DO_UTF8(left);
259 sv_setpvn(TARG, lpv, llen);
265 else { /* $l .= $r */
267 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
268 report_uninit(right);
271 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
272 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
279 /* $r.$r: do magic twice: tied might return different 2nd time */
281 rpv = SvPV_nomg_const(right, rlen);
282 rbyte = !DO_UTF8(right);
284 if (lbyte != rbyte) {
285 /* sv_utf8_upgrade_nomg() may reallocate the stack */
288 sv_utf8_upgrade_nomg(TARG);
291 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
292 sv_utf8_upgrade_nomg(right);
293 rpv = SvPV_nomg_const(right, rlen);
297 sv_catpvn_nomg(TARG, rpv, rlen);
308 if (PL_op->op_flags & OPf_MOD) {
309 if (PL_op->op_private & OPpLVAL_INTRO)
310 if (!(PL_op->op_private & OPpPAD_STATE))
311 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
312 if (PL_op->op_private & OPpDEREF) {
314 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
324 dSP; SvGETMAGIC(TOPs);
325 tryAMAGICunTARGET(iter_amg, 0, 0);
326 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
327 if (!isGV_with_GP(PL_last_in_gv)) {
328 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
329 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
332 XPUSHs(MUTABLE_SV(PL_last_in_gv));
335 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
338 return do_readline();
346 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
350 (SvIOK_notUV(left) && SvIOK_notUV(right))
351 ? (SvIVX(left) == SvIVX(right))
352 : ( do_ncmp(left, right) == 0)
360 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
361 Perl_croak_no_modify(aTHX);
362 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
363 && SvIVX(TOPs) != IV_MAX)
365 SvIV_set(TOPs, SvIVX(TOPs) + 1);
366 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
368 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
381 if (PL_op->op_type == OP_OR)
383 RETURNOP(cLOGOP->op_other);
392 const int op_type = PL_op->op_type;
393 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
398 if (!sv || !SvANY(sv)) {
399 if (op_type == OP_DOR)
401 RETURNOP(cLOGOP->op_other);
407 if (!sv || !SvANY(sv))
412 switch (SvTYPE(sv)) {
414 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
418 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
422 if (CvROOT(sv) || CvXSUB(sv))
435 if(op_type == OP_DOR)
437 RETURNOP(cLOGOP->op_other);
439 /* assuming OP_DEFINED */
447 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
448 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
452 useleft = USE_LEFT(svl);
453 #ifdef PERL_PRESERVE_IVUV
454 /* We must see if we can perform the addition with integers if possible,
455 as the integer code detects overflow while the NV code doesn't.
456 If either argument hasn't had a numeric conversion yet attempt to get
457 the IV. It's important to do this now, rather than just assuming that
458 it's not IOK as a PV of "9223372036854775806" may not take well to NV
459 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
460 integer in case the second argument is IV=9223372036854775806
461 We can (now) rely on sv_2iv to do the right thing, only setting the
462 public IOK flag if the value in the NV (or PV) slot is truly integer.
464 A side effect is that this also aggressively prefers integer maths over
465 fp maths for integer values.
467 How to detect overflow?
469 C 99 section 6.2.6.1 says
471 The range of nonnegative values of a signed integer type is a subrange
472 of the corresponding unsigned integer type, and the representation of
473 the same value in each type is the same. A computation involving
474 unsigned operands can never overflow, because a result that cannot be
475 represented by the resulting unsigned integer type is reduced modulo
476 the number that is one greater than the largest value that can be
477 represented by the resulting type.
481 which I read as "unsigned ints wrap."
483 signed integer overflow seems to be classed as "exception condition"
485 If an exceptional condition occurs during the evaluation of an
486 expression (that is, if the result is not mathematically defined or not
487 in the range of representable values for its type), the behavior is
490 (6.5, the 5th paragraph)
492 I had assumed that on 2s complement machines signed arithmetic would
493 wrap, hence coded pp_add and pp_subtract on the assumption that
494 everything perl builds on would be happy. After much wailing and
495 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
496 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
497 unsigned code below is actually shorter than the old code. :-)
500 SvIV_please_nomg(svr);
503 /* Unless the left argument is integer in range we are going to have to
504 use NV maths. Hence only attempt to coerce the right argument if
505 we know the left is integer. */
513 /* left operand is undef, treat as zero. + 0 is identity,
514 Could SETi or SETu right now, but space optimise by not adding
515 lots of code to speed up what is probably a rarish case. */
517 /* Left operand is defined, so is it IV? */
518 SvIV_please_nomg(svl);
520 if ((auvok = SvUOK(svl)))
523 register const IV aiv = SvIVX(svl);
526 auvok = 1; /* Now acting as a sign flag. */
527 } else { /* 2s complement assumption for IV_MIN */
535 bool result_good = 0;
538 bool buvok = SvUOK(svr);
543 register const IV biv = SvIVX(svr);
550 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
551 else "IV" now, independent of how it came in.
552 if a, b represents positive, A, B negative, a maps to -A etc
557 all UV maths. negate result if A negative.
558 add if signs same, subtract if signs differ. */
564 /* Must get smaller */
570 /* result really should be -(auv-buv). as its negation
571 of true value, need to swap our result flag */
588 if (result <= (UV)IV_MIN)
591 /* result valid, but out of range for IV. */
596 } /* Overflow, drop through to NVs. */
601 NV value = SvNV_nomg(svr);
604 /* left operand is undef, treat as zero. + 0.0 is identity. */
608 SETn( value + SvNV_nomg(svl) );
616 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
617 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
618 const U32 lval = PL_op->op_flags & OPf_MOD;
619 SV** const svp = av_fetch(av, PL_op->op_private, lval);
620 SV *sv = (svp ? *svp : &PL_sv_undef);
622 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
630 dVAR; dSP; dMARK; dTARGET;
632 do_join(TARG, *MARK, MARK, SP);
643 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
644 * will be enough to hold an OP*.
646 SV* const sv = sv_newmortal();
647 sv_upgrade(sv, SVt_PVLV);
649 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
652 XPUSHs(MUTABLE_SV(PL_op));
657 /* Oversized hot code. */
661 dVAR; dSP; dMARK; dORIGMARK;
665 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
669 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
672 if (MARK == ORIGMARK) {
673 /* If using default handle then we need to make space to
674 * pass object as 1st arg, so move other args up ...
678 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
681 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
683 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
684 | (PL_op->op_type == OP_SAY
685 ? TIED_METHOD_SAY : 0)), sp - mark);
688 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
689 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
692 SETERRNO(EBADF,RMS_IFI);
695 else if (!(fp = IoOFP(io))) {
697 report_wrongway_fh(gv, '<');
700 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
704 SV * const ofs = GvSV(PL_ofsgv); /* $, */
706 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
708 if (!do_print(*MARK, fp))
712 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
713 if (!do_print(GvSV(PL_ofsgv), fp)) {
722 if (!do_print(*MARK, fp))
730 if (PL_op->op_type == OP_SAY) {
731 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
734 else if (PL_ors_sv && SvOK(PL_ors_sv))
735 if (!do_print(PL_ors_sv, fp)) /* $\ */
738 if (IoFLAGS(io) & IOf_FLUSH)
739 if (PerlIO_flush(fp) == EOF)
749 XPUSHs(&PL_sv_undef);
756 const I32 gimme = GIMME_V;
757 static const char an_array[] = "an ARRAY";
758 static const char a_hash[] = "a HASH";
759 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
760 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
762 if (!(PL_op->op_private & OPpDEREFed))
766 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
770 if (SvTYPE(sv) != type)
771 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
772 if (PL_op->op_flags & OPf_REF) {
776 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
777 const I32 flags = is_lvalue_sub();
778 if (flags && !(flags & OPpENTERSUB_INARGS)) {
779 if (gimme != G_ARRAY)
780 goto croak_cant_return;
785 else if (PL_op->op_flags & OPf_MOD
786 && PL_op->op_private & OPpLVAL_INTRO)
787 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
790 if (SvTYPE(sv) == type) {
791 if (PL_op->op_flags & OPf_REF) {
796 if (gimme != G_ARRAY)
797 goto croak_cant_return;
805 if (!isGV_with_GP(sv)) {
806 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
814 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
815 if (PL_op->op_private & OPpLVAL_INTRO)
816 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
817 if (PL_op->op_flags & OPf_REF) {
821 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
822 const I32 flags = is_lvalue_sub();
823 if (flags && !(flags & OPpENTERSUB_INARGS)) {
824 if (gimme != G_ARRAY)
825 goto croak_cant_return;
834 AV *const av = MUTABLE_AV(sv);
835 /* The guts of pp_rv2av, with no intending change to preserve history
836 (until such time as we get tools that can do blame annotation across
837 whitespace changes. */
838 if (gimme == G_ARRAY) {
839 const I32 maxarg = AvFILL(av) + 1;
840 (void)POPs; /* XXXX May be optimized away? */
842 if (SvRMAGICAL(av)) {
844 for (i=0; i < (U32)maxarg; i++) {
845 SV ** const svp = av_fetch(av, i, FALSE);
846 /* See note in pp_helem, and bug id #27839 */
848 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
853 Copy(AvARRAY(av), SP+1, maxarg, SV*);
857 else if (gimme == G_SCALAR) {
859 const I32 maxarg = AvFILL(av) + 1;
863 /* The guts of pp_rv2hv */
864 if (gimme == G_ARRAY) { /* array wanted */
866 return Perl_do_kv(aTHX);
868 else if (gimme == G_SCALAR) {
870 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
878 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
879 is_pp_rv2av ? "array" : "hash");
884 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
888 PERL_ARGS_ASSERT_DO_ODDBALL;
894 if (ckWARN(WARN_MISC)) {
896 if (relem == firstrelem &&
898 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
899 SvTYPE(SvRV(*relem)) == SVt_PVHV))
901 err = "Reference found where even-sized list expected";
904 err = "Odd number of elements in hash assignment";
905 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
909 didstore = hv_store_ent(hash,*relem,tmpstr,0);
910 if (SvMAGICAL(hash)) {
911 if (SvSMAGICAL(tmpstr))
923 SV **lastlelem = PL_stack_sp;
924 SV **lastrelem = PL_stack_base + POPMARK;
925 SV **firstrelem = PL_stack_base + POPMARK + 1;
926 SV **firstlelem = lastrelem + 1;
939 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
941 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
944 /* If there's a common identifier on both sides we have to take
945 * special care that assigning the identifier on the left doesn't
946 * clobber a value on the right that's used later in the list.
947 * Don't bother if LHS is just an empty hash or array.
950 if ( (PL_op->op_private & OPpASSIGN_COMMON)
952 firstlelem != lastlelem
953 || ! ((sv = *firstlelem))
955 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
956 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
957 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
960 EXTEND_MORTAL(lastrelem - firstrelem + 1);
961 for (relem = firstrelem; relem <= lastrelem; relem++) {
963 TAINT_NOT; /* Each item is independent */
965 /* Dear TODO test in t/op/sort.t, I love you.
966 (It's relying on a panic, not a "semi-panic" from newSVsv()
967 and then an assertion failure below.) */
968 if (SvIS_FREED(sv)) {
969 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
972 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
973 and we need a second copy of a temp here. */
974 *relem = sv_2mortal(newSVsv(sv));
984 while (lelem <= lastlelem) {
985 TAINT_NOT; /* Each item stands on its own, taintwise. */
987 switch (SvTYPE(sv)) {
989 ary = MUTABLE_AV(sv);
990 magic = SvMAGICAL(ary) != 0;
992 av_extend(ary, lastrelem - relem);
994 while (relem <= lastrelem) { /* gobble up all the rest */
998 sv_setsv(sv, *relem);
1000 didstore = av_store(ary,i++,sv);
1009 if (PL_delaymagic & DM_ARRAY_ISA)
1010 SvSETMAGIC(MUTABLE_SV(ary));
1012 case SVt_PVHV: { /* normal hash */
1014 SV** topelem = relem;
1016 hash = MUTABLE_HV(sv);
1017 magic = SvMAGICAL(hash) != 0;
1019 firsthashrelem = relem;
1021 while (relem < lastrelem) { /* gobble up all the rest */
1023 sv = *relem ? *relem : &PL_sv_no;
1027 sv_setsv(tmpstr,*relem); /* value */
1029 if (gimme != G_VOID) {
1030 if (hv_exists_ent(hash, sv, 0))
1031 /* key overwrites an existing entry */
1034 if (gimme == G_ARRAY) {
1035 /* copy element back: possibly to an earlier
1036 * stack location if we encountered dups earlier */
1038 *topelem++ = tmpstr;
1041 didstore = hv_store_ent(hash,sv,tmpstr,0);
1043 if (SvSMAGICAL(tmpstr))
1050 if (relem == lastrelem) {
1051 do_oddball(hash, relem, firstrelem);
1057 if (SvIMMORTAL(sv)) {
1058 if (relem <= lastrelem)
1062 if (relem <= lastrelem) {
1064 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1065 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1068 packWARN(WARN_MISC),
1069 "Useless assignment to a temporary"
1071 sv_setsv(sv, *relem);
1075 sv_setsv(sv, &PL_sv_undef);
1080 if (PL_delaymagic & ~DM_DELAY) {
1081 if (PL_delaymagic & DM_UID) {
1082 #ifdef HAS_SETRESUID
1083 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1084 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1087 # ifdef HAS_SETREUID
1088 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1089 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1092 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1093 (void)setruid(PL_uid);
1094 PL_delaymagic &= ~DM_RUID;
1096 # endif /* HAS_SETRUID */
1098 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1099 (void)seteuid(PL_euid);
1100 PL_delaymagic &= ~DM_EUID;
1102 # endif /* HAS_SETEUID */
1103 if (PL_delaymagic & DM_UID) {
1104 if (PL_uid != PL_euid)
1105 DIE(aTHX_ "No setreuid available");
1106 (void)PerlProc_setuid(PL_uid);
1108 # endif /* HAS_SETREUID */
1109 #endif /* HAS_SETRESUID */
1110 PL_uid = PerlProc_getuid();
1111 PL_euid = PerlProc_geteuid();
1113 if (PL_delaymagic & DM_GID) {
1114 #ifdef HAS_SETRESGID
1115 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1116 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1119 # ifdef HAS_SETREGID
1120 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1121 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1124 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1125 (void)setrgid(PL_gid);
1126 PL_delaymagic &= ~DM_RGID;
1128 # endif /* HAS_SETRGID */
1130 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1131 (void)setegid(PL_egid);
1132 PL_delaymagic &= ~DM_EGID;
1134 # endif /* HAS_SETEGID */
1135 if (PL_delaymagic & DM_GID) {
1136 if (PL_gid != PL_egid)
1137 DIE(aTHX_ "No setregid available");
1138 (void)PerlProc_setgid(PL_gid);
1140 # endif /* HAS_SETREGID */
1141 #endif /* HAS_SETRESGID */
1142 PL_gid = PerlProc_getgid();
1143 PL_egid = PerlProc_getegid();
1145 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1149 if (gimme == G_VOID)
1150 SP = firstrelem - 1;
1151 else if (gimme == G_SCALAR) {
1154 SETi(lastrelem - firstrelem + 1 - duplicates);
1161 /* at this point we have removed the duplicate key/value
1162 * pairs from the stack, but the remaining values may be
1163 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1164 * the (a 2), but the stack now probably contains
1165 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1166 * obliterates the earlier key. So refresh all values. */
1167 lastrelem -= duplicates;
1168 relem = firsthashrelem;
1169 while (relem < lastrelem) {
1172 he = hv_fetch_ent(hash, sv, 0, 0);
1173 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1179 SP = firstrelem + (lastlelem - firstlelem);
1180 lelem = firstlelem + (relem - firstrelem);
1182 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1191 register PMOP * const pm = cPMOP;
1192 REGEXP * rx = PM_GETRE(pm);
1193 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1194 SV * const rv = sv_newmortal();
1196 SvUPGRADE(rv, SVt_IV);
1197 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1198 loathe to use it here, but it seems to be the right fix. Or close.
1199 The key part appears to be that it's essential for pp_qr to return a new
1200 object (SV), which implies that there needs to be an effective way to
1201 generate a new SV from the existing SV that is pre-compiled in the
1203 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1207 HV *const stash = gv_stashsv(pkg, GV_ADD);
1209 (void)sv_bless(rv, stash);
1212 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1214 SvTAINTED_on(SvRV(rv));
1223 register PMOP *pm = cPMOP;
1225 register const char *t;
1226 register const char *s;
1229 U8 r_flags = REXEC_CHECKED;
1230 const char *truebase; /* Start of string */
1231 register REGEXP *rx = PM_GETRE(pm);
1233 const I32 gimme = GIMME;
1236 const I32 oldsave = PL_savestack_ix;
1237 I32 update_minmatch = 1;
1238 I32 had_zerolen = 0;
1241 if (PL_op->op_flags & OPf_STACKED)
1243 else if (PL_op->op_private & OPpTARGET_MY)
1250 PUTBACK; /* EVAL blocks need stack_sp. */
1251 /* Skip get-magic if this is a qr// clone, because regcomp has
1253 s = ((struct regexp *)SvANY(rx))->mother_re
1254 ? SvPV_nomg_const(TARG, len)
1255 : SvPV_const(TARG, len);
1257 DIE(aTHX_ "panic: pp_match");
1259 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1260 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1263 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1265 /* PMdf_USED is set after a ?? matches once */
1268 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1270 pm->op_pmflags & PMf_USED
1274 if (gimme == G_ARRAY)
1281 /* empty pattern special-cased to use last successful pattern if possible */
1282 if (!RX_PRELEN(rx) && PL_curpm) {
1287 if (RX_MINLEN(rx) > (I32)len)
1292 /* XXXX What part of this is needed with true \G-support? */
1293 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1294 RX_OFFS(rx)[0].start = -1;
1295 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1296 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1297 if (mg && mg->mg_len >= 0) {
1298 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1299 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1300 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1301 r_flags |= REXEC_IGNOREPOS;
1302 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1303 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1306 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1307 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1308 update_minmatch = 0;
1312 /* XXX: comment out !global get safe $1 vars after a
1313 match, BUT be aware that this leads to dramatic slowdowns on
1314 /g matches against large strings. So far a solution to this problem
1315 appears to be quite tricky.
1316 Test for the unsafe vars are TODO for now. */
1317 if ( (!global && RX_NPARENS(rx))
1318 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1319 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1320 r_flags |= REXEC_COPY_STR;
1322 r_flags |= REXEC_SCREAM;
1325 if (global && RX_OFFS(rx)[0].start != -1) {
1326 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1327 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1329 if (update_minmatch++)
1330 minmatch = had_zerolen;
1332 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1333 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1334 /* FIXME - can PL_bostr be made const char *? */
1335 PL_bostr = (char *)truebase;
1336 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1340 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1342 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1343 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1344 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1345 && (r_flags & REXEC_SCREAM)))
1346 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1349 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1350 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1354 if (dynpm->op_pmflags & PMf_ONCE) {
1356 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1358 dynpm->op_pmflags |= PMf_USED;
1364 RX_MATCH_TAINTED_on(rx);
1365 TAINT_IF(RX_MATCH_TAINTED(rx));
1366 if (gimme == G_ARRAY) {
1367 const I32 nparens = RX_NPARENS(rx);
1368 I32 i = (global && !nparens) ? 1 : 0;
1370 SPAGAIN; /* EVAL blocks could move the stack. */
1371 EXTEND(SP, nparens + i);
1372 EXTEND_MORTAL(nparens + i);
1373 for (i = !i; i <= nparens; i++) {
1374 PUSHs(sv_newmortal());
1375 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1376 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1377 s = RX_OFFS(rx)[i].start + truebase;
1378 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1379 len < 0 || len > strend - s)
1380 DIE(aTHX_ "panic: pp_match start/end pointers");
1381 sv_setpvn(*SP, s, len);
1382 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1387 if (dynpm->op_pmflags & PMf_CONTINUE) {
1389 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1390 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1392 #ifdef PERL_OLD_COPY_ON_WRITE
1394 sv_force_normal_flags(TARG, 0);
1396 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1397 &PL_vtbl_mglob, NULL, 0);
1399 if (RX_OFFS(rx)[0].start != -1) {
1400 mg->mg_len = RX_OFFS(rx)[0].end;
1401 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1402 mg->mg_flags |= MGf_MINMATCH;
1404 mg->mg_flags &= ~MGf_MINMATCH;
1407 had_zerolen = (RX_OFFS(rx)[0].start != -1
1408 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1409 == (UV)RX_OFFS(rx)[0].end));
1410 PUTBACK; /* EVAL blocks may use stack */
1411 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1416 LEAVE_SCOPE(oldsave);
1422 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1423 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1427 #ifdef PERL_OLD_COPY_ON_WRITE
1429 sv_force_normal_flags(TARG, 0);
1431 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1432 &PL_vtbl_mglob, NULL, 0);
1434 if (RX_OFFS(rx)[0].start != -1) {
1435 mg->mg_len = RX_OFFS(rx)[0].end;
1436 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1437 mg->mg_flags |= MGf_MINMATCH;
1439 mg->mg_flags &= ~MGf_MINMATCH;
1442 LEAVE_SCOPE(oldsave);
1446 yup: /* Confirmed by INTUIT */
1448 RX_MATCH_TAINTED_on(rx);
1449 TAINT_IF(RX_MATCH_TAINTED(rx));
1451 if (dynpm->op_pmflags & PMf_ONCE) {
1453 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1455 dynpm->op_pmflags |= PMf_USED;
1458 if (RX_MATCH_COPIED(rx))
1459 Safefree(RX_SUBBEG(rx));
1460 RX_MATCH_COPIED_off(rx);
1461 RX_SUBBEG(rx) = NULL;
1463 /* FIXME - should rx->subbeg be const char *? */
1464 RX_SUBBEG(rx) = (char *) truebase;
1465 RX_OFFS(rx)[0].start = s - truebase;
1466 if (RX_MATCH_UTF8(rx)) {
1467 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1468 RX_OFFS(rx)[0].end = t - truebase;
1471 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1473 RX_SUBLEN(rx) = strend - truebase;
1476 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1478 #ifdef PERL_OLD_COPY_ON_WRITE
1479 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1481 PerlIO_printf(Perl_debug_log,
1482 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1483 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1486 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1488 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1489 assert (SvPOKp(RX_SAVED_COPY(rx)));
1494 RX_SUBBEG(rx) = savepvn(t, strend - t);
1495 #ifdef PERL_OLD_COPY_ON_WRITE
1496 RX_SAVED_COPY(rx) = NULL;
1499 RX_SUBLEN(rx) = strend - t;
1500 RX_MATCH_COPIED_on(rx);
1501 off = RX_OFFS(rx)[0].start = s - t;
1502 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1504 else { /* startp/endp are used by @- @+. */
1505 RX_OFFS(rx)[0].start = s - truebase;
1506 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1508 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1510 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1511 LEAVE_SCOPE(oldsave);
1516 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1517 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1518 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1523 LEAVE_SCOPE(oldsave);
1524 if (gimme == G_ARRAY)
1530 Perl_do_readline(pTHX)
1532 dVAR; dSP; dTARGETSTACKED;
1537 register IO * const io = GvIO(PL_last_in_gv);
1538 register const I32 type = PL_op->op_type;
1539 const I32 gimme = GIMME_V;
1542 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1544 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1545 if (gimme == G_SCALAR) {
1547 SvSetSV_nosteal(TARG, TOPs);
1557 if (IoFLAGS(io) & IOf_ARGV) {
1558 if (IoFLAGS(io) & IOf_START) {
1560 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1561 IoFLAGS(io) &= ~IOf_START;
1562 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1563 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1564 SvSETMAGIC(GvSV(PL_last_in_gv));
1569 fp = nextargv(PL_last_in_gv);
1570 if (!fp) { /* Note: fp != IoIFP(io) */
1571 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1574 else if (type == OP_GLOB)
1575 fp = Perl_start_glob(aTHX_ POPs, io);
1577 else if (type == OP_GLOB)
1579 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1580 report_wrongway_fh(PL_last_in_gv, '>');
1584 if ((!io || !(IoFLAGS(io) & IOf_START))
1585 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1587 if (type == OP_GLOB)
1588 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1589 "glob failed (can't start child: %s)",
1592 report_evil_fh(PL_last_in_gv);
1594 if (gimme == G_SCALAR) {
1595 /* undef TARG, and push that undefined value */
1596 if (type != OP_RCATLINE) {
1597 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1605 if (gimme == G_SCALAR) {
1607 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1610 if (type == OP_RCATLINE)
1611 SvPV_force_nolen(sv);
1615 else if (isGV_with_GP(sv)) {
1616 SvPV_force_nolen(sv);
1618 SvUPGRADE(sv, SVt_PV);
1619 tmplen = SvLEN(sv); /* remember if already alloced */
1620 if (!tmplen && !SvREADONLY(sv)) {
1621 /* try short-buffering it. Please update t/op/readline.t
1622 * if you change the growth length.
1627 if (type == OP_RCATLINE && SvOK(sv)) {
1629 SvPV_force_nolen(sv);
1635 sv = sv_2mortal(newSV(80));
1639 /* This should not be marked tainted if the fp is marked clean */
1640 #define MAYBE_TAINT_LINE(io, sv) \
1641 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1646 /* delay EOF state for a snarfed empty file */
1647 #define SNARF_EOF(gimme,rs,io,sv) \
1648 (gimme != G_SCALAR || SvCUR(sv) \
1649 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1653 if (!sv_gets(sv, fp, offset)
1655 || SNARF_EOF(gimme, PL_rs, io, sv)
1656 || PerlIO_error(fp)))
1658 PerlIO_clearerr(fp);
1659 if (IoFLAGS(io) & IOf_ARGV) {
1660 fp = nextargv(PL_last_in_gv);
1663 (void)do_close(PL_last_in_gv, FALSE);
1665 else if (type == OP_GLOB) {
1666 if (!do_close(PL_last_in_gv, FALSE)) {
1667 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1668 "glob failed (child exited with status %d%s)",
1669 (int)(STATUS_CURRENT >> 8),
1670 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1673 if (gimme == G_SCALAR) {
1674 if (type != OP_RCATLINE) {
1675 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1681 MAYBE_TAINT_LINE(io, sv);
1684 MAYBE_TAINT_LINE(io, sv);
1686 IoFLAGS(io) |= IOf_NOLINE;
1690 if (type == OP_GLOB) {
1693 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1694 char * const tmps = SvEND(sv) - 1;
1695 if (*tmps == *SvPVX_const(PL_rs)) {
1697 SvCUR_set(sv, SvCUR(sv) - 1);
1700 for (t1 = SvPVX_const(sv); *t1; t1++)
1701 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1702 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1704 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1705 (void)POPs; /* Unmatched wildcard? Chuck it... */
1708 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1709 if (ckWARN(WARN_UTF8)) {
1710 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1711 const STRLEN len = SvCUR(sv) - offset;
1714 if (!is_utf8_string_loc(s, len, &f))
1715 /* Emulate :encoding(utf8) warning in the same case. */
1716 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1717 "utf8 \"\\x%02X\" does not map to Unicode",
1718 f < (U8*)SvEND(sv) ? *f : 0);
1721 if (gimme == G_ARRAY) {
1722 if (SvLEN(sv) - SvCUR(sv) > 20) {
1723 SvPV_shrink_to_cur(sv);
1725 sv = sv_2mortal(newSV(80));
1728 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1729 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1730 const STRLEN new_len
1731 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1732 SvPV_renew(sv, new_len);
1743 SV * const keysv = POPs;
1744 HV * const hv = MUTABLE_HV(POPs);
1745 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1746 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1748 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1749 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1750 bool preeminent = TRUE;
1752 if (SvTYPE(hv) != SVt_PVHV)
1759 /* If we can determine whether the element exist,
1760 * Try to preserve the existenceness of a tied hash
1761 * element by using EXISTS and DELETE if possible.
1762 * Fallback to FETCH and STORE otherwise. */
1763 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1764 preeminent = hv_exists_ent(hv, keysv, 0);
1767 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1768 svp = he ? &HeVAL(he) : NULL;
1770 if (!svp || *svp == &PL_sv_undef) {
1774 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1776 lv = sv_newmortal();
1777 sv_upgrade(lv, SVt_PVLV);
1779 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1780 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1781 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1787 if (HvNAME_get(hv) && isGV(*svp))
1788 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1789 else if (preeminent)
1790 save_helem_flags(hv, keysv, svp,
1791 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1793 SAVEHDELETE(hv, keysv);
1795 else if (PL_op->op_private & OPpDEREF)
1796 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1798 sv = (svp ? *svp : &PL_sv_undef);
1799 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1800 * was to make C<local $tied{foo} = $tied{foo}> possible.
1801 * However, it seems no longer to be needed for that purpose, and
1802 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1803 * would loop endlessly since the pos magic is getting set on the
1804 * mortal copy and lost. However, the copy has the effect of
1805 * triggering the get magic, and losing it altogether made things like
1806 * c<$tied{foo};> in void context no longer do get magic, which some
1807 * code relied on. Also, delayed triggering of magic on @+ and friends
1808 * meant the original regex may be out of scope by now. So as a
1809 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1810 * being called too many times). */
1811 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1820 register PERL_CONTEXT *cx;
1823 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1824 bool av_is_stack = FALSE;
1827 cx = &cxstack[cxstack_ix];
1828 if (!CxTYPE_is_LOOP(cx))
1829 DIE(aTHX_ "panic: pp_iter");
1831 itersvp = CxITERVAR(cx);
1832 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1833 /* string increment */
1834 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1835 SV *end = cx->blk_loop.state_u.lazysv.end;
1836 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1837 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1839 const char *max = SvPV_const(end, maxlen);
1840 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1841 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1842 /* safe to reuse old SV */
1843 sv_setsv(*itersvp, cur);
1847 /* we need a fresh SV every time so that loop body sees a
1848 * completely new SV for closures/references to work as
1851 *itersvp = newSVsv(cur);
1852 SvREFCNT_dec(oldsv);
1854 if (strEQ(SvPVX_const(cur), max))
1855 sv_setiv(cur, 0); /* terminate next time */
1862 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1863 /* integer increment */
1864 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1867 /* don't risk potential race */
1868 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1869 /* safe to reuse old SV */
1870 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1874 /* we need a fresh SV every time so that loop body sees a
1875 * completely new SV for closures/references to work as they
1878 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1879 SvREFCNT_dec(oldsv);
1882 /* Handle end of range at IV_MAX */
1883 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1884 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1886 cx->blk_loop.state_u.lazyiv.cur++;
1887 cx->blk_loop.state_u.lazyiv.end++;
1894 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1895 av = cx->blk_loop.state_u.ary.ary;
1900 if (PL_op->op_private & OPpITER_REVERSED) {
1901 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1902 ? cx->blk_loop.resetsp + 1 : 0))
1905 if (SvMAGICAL(av) || AvREIFY(av)) {
1906 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1907 sv = svp ? *svp : NULL;
1910 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1914 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1918 if (SvMAGICAL(av) || AvREIFY(av)) {
1919 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1920 sv = svp ? *svp : NULL;
1923 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1927 if (sv && SvIS_FREED(sv)) {
1929 Perl_croak(aTHX_ "Use of freed value in iteration");
1934 SvREFCNT_inc_simple_void_NN(sv);
1938 if (!av_is_stack && sv == &PL_sv_undef) {
1939 SV *lv = newSV_type(SVt_PVLV);
1941 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1942 LvTARG(lv) = SvREFCNT_inc_simple(av);
1943 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1944 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1950 SvREFCNT_dec(oldsv);
1956 A description of how taint works in pattern matching and substitution.
1958 While the pattern is being assembled/concatenated and them compiled,
1959 PL_tainted will get set if any component of the pattern is tainted, e.g.
1960 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1961 is set on the pattern if PL_tainted is set.
1963 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1964 the pattern is marked as tainted. This means that subsequent usage, such
1965 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1967 During execution of a pattern, locale-variant ops such as ALNUML set the
1968 local flag RF_tainted. At the end of execution, the engine sets the
1969 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1972 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1973 of $1 et al to indicate whether the returned value should be tainted.
1974 It is the responsibility of the caller of the pattern (i.e. pp_match,
1975 pp_subst etc) to set this flag for any other circumstances where $1 needs
1978 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1980 There are three possible sources of taint
1982 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1983 * the replacement string (or expression under /e)
1985 There are four destinations of taint and they are affected by the sources
1986 according to the rules below:
1988 * the return value (not including /r):
1989 tainted by the source string and pattern, but only for the
1990 number-of-iterations case; boolean returns aren't tainted;
1991 * the modified string (or modified copy under /r):
1992 tainted by the source string, pattern, and replacement strings;
1994 tainted by the pattern, and under 'use re "taint"', by the source
1996 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
1997 should always be unset before executing subsequent code.
1999 The overall action of pp_subst is:
2001 * at the start, set bits in rxtainted indicating the taint status of
2002 the various sources.
2004 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2005 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2006 pattern has subsequently become tainted via locale ops.
2008 * If control is being passed to pp_substcont to execute a /e block,
2009 save rxtainted in the CXt_SUBST block, for future use by
2012 * Whenever control is being returned to perl code (either by falling
2013 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2014 use the flag bits in rxtainted to make all the appropriate types of
2015 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2016 et al will appear tainted.
2018 pp_match is just a simpler version of the above.
2025 register PMOP *pm = cPMOP;
2037 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2038 See "how taint works" above */
2041 register REGEXP *rx = PM_GETRE(pm);
2043 int force_on_match = 0;
2044 const I32 oldsave = PL_savestack_ix;
2046 bool doutf8 = FALSE;
2047 #ifdef PERL_OLD_COPY_ON_WRITE
2051 /* known replacement string? */
2052 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2056 if (PL_op->op_flags & OPf_STACKED)
2058 else if (PL_op->op_private & OPpTARGET_MY)
2065 #ifdef PERL_OLD_COPY_ON_WRITE
2066 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2067 because they make integers such as 256 "false". */
2068 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2071 sv_force_normal_flags(TARG,0);
2073 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2074 #ifdef PERL_OLD_COPY_ON_WRITE
2077 && (SvREADONLY(TARG)
2078 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2079 || SvTYPE(TARG) > SVt_PVLV)
2080 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2081 Perl_croak_no_modify(aTHX);
2085 s = SvPV_mutable(TARG, len);
2086 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2089 /* only replace once? */
2090 once = !(rpm->op_pmflags & PMf_GLOBAL);
2092 /* See "how taint works" above */
2095 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2096 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2097 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2098 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2099 ? SUBST_TAINT_BOOLRET : 0));
2103 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2107 DIE(aTHX_ "panic: pp_subst");
2110 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2111 maxiters = 2 * slen + 10; /* We can match twice at each
2112 position, once with zero-length,
2113 second time with non-zero. */
2115 if (!RX_PRELEN(rx) && PL_curpm) {
2119 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2120 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2121 ? REXEC_COPY_STR : 0;
2123 r_flags |= REXEC_SCREAM;
2126 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2128 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2132 /* How to do it in subst? */
2133 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2135 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2136 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2137 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2138 && (r_flags & REXEC_SCREAM))))
2143 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2144 r_flags | REXEC_CHECKED))
2148 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2149 LEAVE_SCOPE(oldsave);
2153 /* known replacement string? */
2155 if (SvTAINTED(dstr))
2156 rxtainted |= SUBST_TAINT_REPL;
2158 /* Upgrade the source if the replacement is utf8 but the source is not,
2159 * but only if it matched; see
2160 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2162 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2163 char * const orig_pvx = SvPVX(TARG);
2164 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2166 /* If the lengths are the same, the pattern contains only
2167 * invariants, can keep going; otherwise, various internal markers
2168 * could be off, so redo */
2169 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2174 /* replacement needing upgrading? */
2175 if (DO_UTF8(TARG) && !doutf8) {
2176 nsv = sv_newmortal();
2179 sv_recode_to_utf8(nsv, PL_encoding);
2181 sv_utf8_upgrade(nsv);
2182 c = SvPV_const(nsv, clen);
2186 c = SvPV_const(dstr, clen);
2187 doutf8 = DO_UTF8(dstr);
2195 /* can do inplace substitution? */
2197 #ifdef PERL_OLD_COPY_ON_WRITE
2200 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2201 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2202 && (!doutf8 || SvUTF8(TARG))
2203 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2206 #ifdef PERL_OLD_COPY_ON_WRITE
2207 if (SvIsCOW(TARG)) {
2208 assert (!force_on_match);
2212 if (force_on_match) {
2214 s = SvPV_force(TARG, len);
2219 SvSCREAM_off(TARG); /* disable possible screamer */
2221 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2222 rxtainted |= SUBST_TAINT_PAT;
2223 m = orig + RX_OFFS(rx)[0].start;
2224 d = orig + RX_OFFS(rx)[0].end;
2226 if (m - s > strend - d) { /* faster to shorten from end */
2228 Copy(c, m, clen, char);
2233 Move(d, m, i, char);
2237 SvCUR_set(TARG, m - s);
2239 else if ((i = m - s)) { /* faster from front */
2242 Move(s, d - i, i, char);
2245 Copy(c, m, clen, char);
2250 Copy(c, d, clen, char);
2260 if (iters++ > maxiters)
2261 DIE(aTHX_ "Substitution loop");
2262 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2263 rxtainted |= SUBST_TAINT_PAT;
2264 m = RX_OFFS(rx)[0].start + orig;
2267 Move(s, d, i, char);
2271 Copy(c, d, clen, char);
2274 s = RX_OFFS(rx)[0].end + orig;
2275 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2277 /* don't match same null twice */
2278 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2281 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2282 Move(s, d, i+1, char); /* include the NUL */
2289 if (force_on_match) {
2291 s = SvPV_force(TARG, len);
2294 #ifdef PERL_OLD_COPY_ON_WRITE
2297 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2298 rxtainted |= SUBST_TAINT_PAT;
2299 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2302 register PERL_CONTEXT *cx;
2304 /* note that a whole bunch of local vars are saved here for
2305 * use by pp_substcont: here's a list of them in case you're
2306 * searching for places in this sub that uses a particular var:
2307 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2308 * s m strend rx once */
2310 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2312 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2314 if (iters++ > maxiters)
2315 DIE(aTHX_ "Substitution loop");
2316 if (RX_MATCH_TAINTED(rx))
2317 rxtainted |= SUBST_TAINT_PAT;
2318 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2321 orig = RX_SUBBEG(rx);
2323 strend = s + (strend - m);
2325 m = RX_OFFS(rx)[0].start + orig;
2326 if (doutf8 && !SvUTF8(dstr))
2327 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2329 sv_catpvn(dstr, s, m-s);
2330 s = RX_OFFS(rx)[0].end + orig;
2332 sv_catpvn(dstr, c, clen);
2335 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2336 TARG, NULL, r_flags));
2337 if (doutf8 && !DO_UTF8(TARG))
2338 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2340 sv_catpvn(dstr, s, strend - s);
2342 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2343 /* From here on down we're using the copy, and leaving the original
2349 #ifdef PERL_OLD_COPY_ON_WRITE
2350 /* The match may make the string COW. If so, brilliant, because
2351 that's just saved us one malloc, copy and free - the regexp has
2352 donated the old buffer, and we malloc an entirely new one, rather
2353 than the regexp malloc()ing a buffer and copying our original,
2354 only for us to throw it away here during the substitution. */
2355 if (SvIsCOW(TARG)) {
2356 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2362 SvPV_set(TARG, SvPVX(dstr));
2363 SvCUR_set(TARG, SvCUR(dstr));
2364 SvLEN_set(TARG, SvLEN(dstr));
2365 doutf8 |= DO_UTF8(dstr);
2366 SvPV_set(dstr, NULL);
2373 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2374 (void)SvPOK_only_UTF8(TARG);
2379 /* See "how taint works" above */
2381 if ((rxtainted & SUBST_TAINT_PAT) ||
2382 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2383 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2385 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2387 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2388 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2390 SvTAINTED_on(TOPs); /* taint return value */
2392 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2394 /* needed for mg_set below */
2396 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2399 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2401 LEAVE_SCOPE(oldsave);
2410 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2411 ++*PL_markstack_ptr;
2413 LEAVE_with_name("grep_item"); /* exit inner scope */
2416 if (PL_stack_base + *PL_markstack_ptr > SP) {
2418 const I32 gimme = GIMME_V;
2420 LEAVE_with_name("grep"); /* exit outer scope */
2421 (void)POPMARK; /* pop src */
2422 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2423 (void)POPMARK; /* pop dst */
2424 SP = PL_stack_base + POPMARK; /* pop original mark */
2425 if (gimme == G_SCALAR) {
2426 if (PL_op->op_private & OPpGREP_LEX) {
2427 SV* const sv = sv_newmortal();
2428 sv_setiv(sv, items);
2436 else if (gimme == G_ARRAY)
2443 ENTER_with_name("grep_item"); /* enter inner scope */
2446 src = PL_stack_base[*PL_markstack_ptr];
2448 if (PL_op->op_private & OPpGREP_LEX)
2449 PAD_SVl(PL_op->op_targ) = src;
2453 RETURNOP(cLOGOP->op_other);
2464 register PERL_CONTEXT *cx;
2468 if (CxMULTICALL(&cxstack[cxstack_ix]))
2472 cxstack_ix++; /* temporarily protect top context */
2473 gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
2476 if (gimme == G_SCALAR) {
2479 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2480 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2481 *MARK = SvREFCNT_inc(TOPs);
2484 if (gmagic) SvGETMAGIC(*MARK);
2487 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2489 *MARK = sv_mortalcopy(sv);
2493 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2495 if (gmagic) SvGETMAGIC(TOPs);
2498 *MARK = sv_mortalcopy(TOPs);
2502 *MARK = &PL_sv_undef;
2506 else if (gimme == G_ARRAY) {
2507 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2508 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
2509 *MARK = sv_mortalcopy(*MARK);
2510 TAINT_NOT; /* Each item is independent */
2518 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2519 PL_curpm = newpm; /* ... and pop $1 et al */
2522 return cx->blk_sub.retop;
2530 register PERL_CONTEXT *cx;
2532 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2535 DIE(aTHX_ "Not a CODE reference");
2536 switch (SvTYPE(sv)) {
2537 /* This is overwhelming the most common case: */
2539 if (!isGV_with_GP(sv))
2540 DIE(aTHX_ "Not a CODE reference");
2542 if (!(cv = GvCVu((const GV *)sv))) {
2544 cv = sv_2cv(sv, &stash, &gv, 0);
2553 if(isGV_with_GP(sv)) goto we_have_a_glob;
2556 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2558 SP = PL_stack_base + POPMARK;
2566 sv = amagic_deref_call(sv, to_cv_amg);
2567 /* Don't SPAGAIN here. */
2573 sym = SvPV_nomg_const(sv, len);
2575 DIE(aTHX_ PL_no_usym, "a subroutine");
2576 if (PL_op->op_private & HINT_STRICT_REFS)
2577 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2578 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2581 cv = MUTABLE_CV(SvRV(sv));
2582 if (SvTYPE(cv) == SVt_PVCV)
2587 DIE(aTHX_ "Not a CODE reference");
2588 /* This is the second most common case: */
2590 cv = MUTABLE_CV(sv);
2598 if (CvCLONE(cv) && ! CvCLONED(cv))
2599 DIE(aTHX_ "Closure prototype called");
2600 if (!CvROOT(cv) && !CvXSUB(cv)) {
2604 /* anonymous or undef'd function leaves us no recourse */
2605 if (CvANON(cv) || !(gv = CvGV(cv)))
2606 DIE(aTHX_ "Undefined subroutine called");
2608 /* autoloaded stub? */
2609 if (cv != GvCV(gv)) {
2612 /* should call AUTOLOAD now? */
2615 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2622 sub_name = sv_newmortal();
2623 gv_efullname3(sub_name, gv, NULL);
2624 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2628 DIE(aTHX_ "Not a CODE reference");
2633 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2634 Perl_get_db_sub(aTHX_ &sv, cv);
2636 PL_curcopdb = PL_curcop;
2638 /* check for lsub that handles lvalue subroutines */
2639 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2640 /* if lsub not found then fall back to DB::sub */
2641 if (!cv) cv = GvCV(PL_DBsub);
2643 cv = GvCV(PL_DBsub);
2646 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2647 DIE(aTHX_ "No DB::sub routine defined");
2650 if (!(CvISXSUB(cv))) {
2651 /* This path taken at least 75% of the time */
2653 register I32 items = SP - MARK;
2654 AV* const padlist = CvPADLIST(cv);
2655 PUSHBLOCK(cx, CXt_SUB, MARK);
2657 cx->blk_sub.retop = PL_op->op_next;
2659 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2660 * that eval'' ops within this sub know the correct lexical space.
2661 * Owing the speed considerations, we choose instead to search for
2662 * the cv using find_runcv() when calling doeval().
2664 if (CvDEPTH(cv) >= 2) {
2665 PERL_STACK_OVERFLOW_CHECK();
2666 pad_push(padlist, CvDEPTH(cv));
2669 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2671 AV *const av = MUTABLE_AV(PAD_SVl(0));
2673 /* @_ is normally not REAL--this should only ever
2674 * happen when DB::sub() calls things that modify @_ */
2679 cx->blk_sub.savearray = GvAV(PL_defgv);
2680 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2681 CX_CURPAD_SAVE(cx->blk_sub);
2682 cx->blk_sub.argarray = av;
2685 if (items > AvMAX(av) + 1) {
2686 SV **ary = AvALLOC(av);
2687 if (AvARRAY(av) != ary) {
2688 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2691 if (items > AvMAX(av) + 1) {
2692 AvMAX(av) = items - 1;
2693 Renew(ary,items,SV*);
2698 Copy(MARK,AvARRAY(av),items,SV*);
2699 AvFILLp(av) = items - 1;
2707 /* warning must come *after* we fully set up the context
2708 * stuff so that __WARN__ handlers can safely dounwind()
2711 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2712 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2713 sub_crush_depth(cv);
2714 RETURNOP(CvSTART(cv));
2717 I32 markix = TOPMARK;
2722 /* Need to copy @_ to stack. Alternative may be to
2723 * switch stack to @_, and copy return values
2724 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2725 AV * const av = GvAV(PL_defgv);
2726 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2729 /* Mark is at the end of the stack. */
2731 Copy(AvARRAY(av), SP + 1, items, SV*);
2736 /* We assume first XSUB in &DB::sub is the called one. */
2738 SAVEVPTR(PL_curcop);
2739 PL_curcop = PL_curcopdb;
2742 /* Do we need to open block here? XXXX */
2744 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2746 CvXSUB(cv)(aTHX_ cv);
2748 /* Enforce some sanity in scalar context. */
2749 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2750 if (markix > PL_stack_sp - PL_stack_base)
2751 *(PL_stack_base + markix) = &PL_sv_undef;
2753 *(PL_stack_base + markix) = *PL_stack_sp;
2754 PL_stack_sp = PL_stack_base + markix;
2762 Perl_sub_crush_depth(pTHX_ CV *cv)
2764 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2767 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2769 SV* const tmpstr = sv_newmortal();
2770 gv_efullname3(tmpstr, CvGV(cv), NULL);
2771 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2780 SV* const elemsv = POPs;
2781 IV elem = SvIV(elemsv);
2782 AV *const av = MUTABLE_AV(POPs);
2783 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2784 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2785 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2786 bool preeminent = TRUE;
2789 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2790 Perl_warner(aTHX_ packWARN(WARN_MISC),
2791 "Use of reference \"%"SVf"\" as array index",
2794 elem -= CopARYBASE_get(PL_curcop);
2795 if (SvTYPE(av) != SVt_PVAV)
2802 /* If we can determine whether the element exist,
2803 * Try to preserve the existenceness of a tied array
2804 * element by using EXISTS and DELETE if possible.
2805 * Fallback to FETCH and STORE otherwise. */
2806 if (SvCANEXISTDELETE(av))
2807 preeminent = av_exists(av, elem);
2810 svp = av_fetch(av, elem, lval && !defer);
2812 #ifdef PERL_MALLOC_WRAP
2813 if (SvUOK(elemsv)) {
2814 const UV uv = SvUV(elemsv);
2815 elem = uv > IV_MAX ? IV_MAX : uv;
2817 else if (SvNOK(elemsv))
2818 elem = (IV)SvNV(elemsv);
2820 static const char oom_array_extend[] =
2821 "Out of memory during array extend"; /* Duplicated in av.c */
2822 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2825 if (!svp || *svp == &PL_sv_undef) {
2828 DIE(aTHX_ PL_no_aelem, elem);
2829 lv = sv_newmortal();
2830 sv_upgrade(lv, SVt_PVLV);
2832 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2833 LvTARG(lv) = SvREFCNT_inc_simple(av);
2834 LvTARGOFF(lv) = elem;
2841 save_aelem(av, elem, svp);
2843 SAVEADELETE(av, elem);
2845 else if (PL_op->op_private & OPpDEREF)
2846 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2848 sv = (svp ? *svp : &PL_sv_undef);
2849 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2856 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2858 PERL_ARGS_ASSERT_VIVIFY_REF;
2863 Perl_croak_no_modify(aTHX);
2864 prepare_SV_for_RV(sv);
2867 SvRV_set(sv, newSV(0));
2870 SvRV_set(sv, MUTABLE_SV(newAV()));
2873 SvRV_set(sv, MUTABLE_SV(newHV()));
2884 SV* const sv = TOPs;
2887 SV* const rsv = SvRV(sv);
2888 if (SvTYPE(rsv) == SVt_PVCV) {
2894 SETs(method_common(sv, NULL));
2901 SV* const sv = cSVOP_sv;
2902 U32 hash = SvSHARED_HASH(sv);
2904 XPUSHs(method_common(sv, &hash));
2909 S_method_common(pTHX_ SV* meth, U32* hashp)
2915 const char* packname = NULL;
2918 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2920 PERL_ARGS_ASSERT_METHOD_COMMON;
2923 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2928 ob = MUTABLE_SV(SvRV(sv));
2932 /* this isn't a reference */
2933 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2934 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2936 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2943 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2944 !(ob=MUTABLE_SV(GvIO(iogv))))
2946 /* this isn't the name of a filehandle either */
2948 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2949 ? !isIDFIRST_utf8((U8*)packname)
2950 : !isIDFIRST(*packname)
2953 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2955 SvOK(sv) ? "without a package or object reference"
2956 : "on an undefined value");
2958 /* assume it's a package name */
2959 stash = gv_stashpvn(packname, packlen, 0);
2963 SV* const ref = newSViv(PTR2IV(stash));
2964 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
2968 /* it _is_ a filehandle name -- replace with a reference */
2969 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
2972 /* if we got here, ob should be a reference or a glob */
2973 if (!ob || !(SvOBJECT(ob)
2974 || (SvTYPE(ob) == SVt_PVGV
2976 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
2979 const char * const name = SvPV_nolen_const(meth);
2980 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2981 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
2985 stash = SvSTASH(ob);
2988 /* NOTE: stash may be null, hope hv_fetch_ent and
2989 gv_fetchmethod can cope (it seems they can) */
2991 /* shortcut for simple names */
2993 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
2995 gv = MUTABLE_GV(HeVAL(he));
2996 if (isGV(gv) && GvCV(gv) &&
2997 (!GvCVGEN(gv) || GvCVGEN(gv)
2998 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
2999 return MUTABLE_SV(GvCV(gv));
3003 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3004 SvPV_nolen_const(meth),
3005 GV_AUTOLOAD | GV_CROAK);
3009 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3014 * c-indentation-style: bsd
3016 * indent-tabs-mode: t
3019 * ex: set ts=8 sts=4 sw=4 noet: