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(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(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)
365 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
366 Perl_croak_no_modify(aTHX);
367 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
368 && SvIVX(TOPs) != IV_MAX)
370 SvIV_set(TOPs, SvIVX(TOPs) + 1);
371 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
373 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
386 if (PL_op->op_type == OP_OR)
388 RETURNOP(cLOGOP->op_other);
397 const int op_type = PL_op->op_type;
398 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
403 if (!sv || !SvANY(sv)) {
404 if (op_type == OP_DOR)
406 RETURNOP(cLOGOP->op_other);
412 if (!sv || !SvANY(sv))
417 switch (SvTYPE(sv)) {
419 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
423 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
427 if (CvROOT(sv) || CvXSUB(sv))
440 if(op_type == OP_DOR)
442 RETURNOP(cLOGOP->op_other);
444 /* assuming OP_DEFINED */
452 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
453 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
457 useleft = USE_LEFT(svl);
458 #ifdef PERL_PRESERVE_IVUV
459 /* We must see if we can perform the addition with integers if possible,
460 as the integer code detects overflow while the NV code doesn't.
461 If either argument hasn't had a numeric conversion yet attempt to get
462 the IV. It's important to do this now, rather than just assuming that
463 it's not IOK as a PV of "9223372036854775806" may not take well to NV
464 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
465 integer in case the second argument is IV=9223372036854775806
466 We can (now) rely on sv_2iv to do the right thing, only setting the
467 public IOK flag if the value in the NV (or PV) slot is truly integer.
469 A side effect is that this also aggressively prefers integer maths over
470 fp maths for integer values.
472 How to detect overflow?
474 C 99 section 6.2.6.1 says
476 The range of nonnegative values of a signed integer type is a subrange
477 of the corresponding unsigned integer type, and the representation of
478 the same value in each type is the same. A computation involving
479 unsigned operands can never overflow, because a result that cannot be
480 represented by the resulting unsigned integer type is reduced modulo
481 the number that is one greater than the largest value that can be
482 represented by the resulting type.
486 which I read as "unsigned ints wrap."
488 signed integer overflow seems to be classed as "exception condition"
490 If an exceptional condition occurs during the evaluation of an
491 expression (that is, if the result is not mathematically defined or not
492 in the range of representable values for its type), the behavior is
495 (6.5, the 5th paragraph)
497 I had assumed that on 2s complement machines signed arithmetic would
498 wrap, hence coded pp_add and pp_subtract on the assumption that
499 everything perl builds on would be happy. After much wailing and
500 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
501 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
502 unsigned code below is actually shorter than the old code. :-)
505 SvIV_please_nomg(svr);
508 /* Unless the left argument is integer in range we are going to have to
509 use NV maths. Hence only attempt to coerce the right argument if
510 we know the left is integer. */
518 /* left operand is undef, treat as zero. + 0 is identity,
519 Could SETi or SETu right now, but space optimise by not adding
520 lots of code to speed up what is probably a rarish case. */
522 /* Left operand is defined, so is it IV? */
523 SvIV_please_nomg(svl);
525 if ((auvok = SvUOK(svl)))
528 register const IV aiv = SvIVX(svl);
531 auvok = 1; /* Now acting as a sign flag. */
532 } else { /* 2s complement assumption for IV_MIN */
540 bool result_good = 0;
543 bool buvok = SvUOK(svr);
548 register const IV biv = SvIVX(svr);
555 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
556 else "IV" now, independent of how it came in.
557 if a, b represents positive, A, B negative, a maps to -A etc
562 all UV maths. negate result if A negative.
563 add if signs same, subtract if signs differ. */
569 /* Must get smaller */
575 /* result really should be -(auv-buv). as its negation
576 of true value, need to swap our result flag */
593 if (result <= (UV)IV_MIN)
596 /* result valid, but out of range for IV. */
601 } /* Overflow, drop through to NVs. */
606 NV value = SvNV_nomg(svr);
609 /* left operand is undef, treat as zero. + 0.0 is identity. */
613 SETn( value + SvNV_nomg(svl) );
621 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
622 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
623 const U32 lval = PL_op->op_flags & OPf_MOD;
624 SV** const svp = av_fetch(av, PL_op->op_private, lval);
625 SV *sv = (svp ? *svp : &PL_sv_undef);
627 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
635 dVAR; dSP; dMARK; dTARGET;
637 do_join(TARG, *MARK, MARK, SP);
648 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
649 * will be enough to hold an OP*.
651 SV* const sv = sv_newmortal();
652 sv_upgrade(sv, SVt_PVLV);
654 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
657 XPUSHs(MUTABLE_SV(PL_op));
662 /* Oversized hot code. */
666 dVAR; dSP; dMARK; dORIGMARK;
670 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
674 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
677 if (MARK == ORIGMARK) {
678 /* If using default handle then we need to make space to
679 * pass object as 1st arg, so move other args up ...
683 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
686 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
688 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
689 | (PL_op->op_type == OP_SAY
690 ? TIED_METHOD_SAY : 0)), sp - mark);
693 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
694 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
697 SETERRNO(EBADF,RMS_IFI);
700 else if (!(fp = IoOFP(io))) {
702 report_wrongway_fh(gv, '<');
705 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
709 SV * const ofs = GvSV(PL_ofsgv); /* $, */
711 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
713 if (!do_print(*MARK, fp))
717 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
718 if (!do_print(GvSV(PL_ofsgv), fp)) {
727 if (!do_print(*MARK, fp))
735 if (PL_op->op_type == OP_SAY) {
736 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
739 else if (PL_ors_sv && SvOK(PL_ors_sv))
740 if (!do_print(PL_ors_sv, fp)) /* $\ */
743 if (IoFLAGS(io) & IOf_FLUSH)
744 if (PerlIO_flush(fp) == EOF)
754 XPUSHs(&PL_sv_undef);
761 const I32 gimme = GIMME_V;
762 static const char an_array[] = "an ARRAY";
763 static const char a_hash[] = "a HASH";
764 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
765 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
770 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
774 if (SvTYPE(sv) != type)
775 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
776 if (PL_op->op_flags & OPf_REF) {
780 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
781 const I32 flags = is_lvalue_sub();
782 if (flags && !(flags & OPpENTERSUB_INARGS)) {
783 if (gimme != G_ARRAY)
784 goto croak_cant_return;
789 else if (PL_op->op_flags & OPf_MOD
790 && PL_op->op_private & OPpLVAL_INTRO)
791 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
794 if (SvTYPE(sv) == type) {
795 if (PL_op->op_flags & OPf_REF) {
800 if (gimme != G_ARRAY)
801 goto croak_cant_return;
809 if (!isGV_with_GP(sv)) {
810 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
818 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
819 if (PL_op->op_private & OPpLVAL_INTRO)
820 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
821 if (PL_op->op_flags & OPf_REF) {
825 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
826 const I32 flags = is_lvalue_sub();
827 if (flags && !(flags & OPpENTERSUB_INARGS)) {
828 if (gimme != G_ARRAY)
829 goto croak_cant_return;
838 AV *const av = MUTABLE_AV(sv);
839 /* The guts of pp_rv2av, with no intending change to preserve history
840 (until such time as we get tools that can do blame annotation across
841 whitespace changes. */
842 if (gimme == G_ARRAY) {
843 const I32 maxarg = AvFILL(av) + 1;
844 (void)POPs; /* XXXX May be optimized away? */
846 if (SvRMAGICAL(av)) {
848 for (i=0; i < (U32)maxarg; i++) {
849 SV ** const svp = av_fetch(av, i, FALSE);
850 /* See note in pp_helem, and bug id #27839 */
852 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
857 Copy(AvARRAY(av), SP+1, maxarg, SV*);
861 else if (gimme == G_SCALAR) {
863 const I32 maxarg = AvFILL(av) + 1;
867 /* The guts of pp_rv2hv */
868 if (gimme == G_ARRAY) { /* array wanted */
870 return Perl_do_kv(aTHX);
872 else if (gimme == G_SCALAR) {
874 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
882 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
883 is_pp_rv2av ? "array" : "hash");
888 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
892 PERL_ARGS_ASSERT_DO_ODDBALL;
898 if (ckWARN(WARN_MISC)) {
900 if (relem == firstrelem &&
902 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
903 SvTYPE(SvRV(*relem)) == SVt_PVHV))
905 err = "Reference found where even-sized list expected";
908 err = "Odd number of elements in hash assignment";
909 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
913 didstore = hv_store_ent(hash,*relem,tmpstr,0);
914 if (SvMAGICAL(hash)) {
915 if (SvSMAGICAL(tmpstr))
927 SV **lastlelem = PL_stack_sp;
928 SV **lastrelem = PL_stack_base + POPMARK;
929 SV **firstrelem = PL_stack_base + POPMARK + 1;
930 SV **firstlelem = lastrelem + 1;
943 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
945 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
948 /* If there's a common identifier on both sides we have to take
949 * special care that assigning the identifier on the left doesn't
950 * clobber a value on the right that's used later in the list.
951 * Don't bother if LHS is just an empty hash or array.
954 if ( (PL_op->op_private & OPpASSIGN_COMMON)
956 firstlelem != lastlelem
957 || ! ((sv = *firstlelem))
959 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
960 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
961 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
964 EXTEND_MORTAL(lastrelem - firstrelem + 1);
965 for (relem = firstrelem; relem <= lastrelem; relem++) {
967 TAINT_NOT; /* Each item is independent */
969 /* Dear TODO test in t/op/sort.t, I love you.
970 (It's relying on a panic, not a "semi-panic" from newSVsv()
971 and then an assertion failure below.) */
972 if (SvIS_FREED(sv)) {
973 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
976 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
977 and we need a second copy of a temp here. */
978 *relem = sv_2mortal(newSVsv(sv));
988 while (lelem <= lastlelem) {
989 TAINT_NOT; /* Each item stands on its own, taintwise. */
991 switch (SvTYPE(sv)) {
993 ary = MUTABLE_AV(sv);
994 magic = SvMAGICAL(ary) != 0;
996 av_extend(ary, lastrelem - relem);
998 while (relem <= lastrelem) { /* gobble up all the rest */
1002 sv_setsv(sv, *relem);
1004 didstore = av_store(ary,i++,sv);
1013 if (PL_delaymagic & DM_ARRAY_ISA)
1014 SvSETMAGIC(MUTABLE_SV(ary));
1016 case SVt_PVHV: { /* normal hash */
1018 SV** topelem = relem;
1020 hash = MUTABLE_HV(sv);
1021 magic = SvMAGICAL(hash) != 0;
1023 firsthashrelem = relem;
1025 while (relem < lastrelem) { /* gobble up all the rest */
1027 sv = *relem ? *relem : &PL_sv_no;
1031 sv_setsv(tmpstr,*relem); /* value */
1033 if (gimme != G_VOID) {
1034 if (hv_exists_ent(hash, sv, 0))
1035 /* key overwrites an existing entry */
1038 if (gimme == G_ARRAY) {
1039 /* copy element back: possibly to an earlier
1040 * stack location if we encountered dups earlier */
1042 *topelem++ = tmpstr;
1045 didstore = hv_store_ent(hash,sv,tmpstr,0);
1047 if (SvSMAGICAL(tmpstr))
1054 if (relem == lastrelem) {
1055 do_oddball(hash, relem, firstrelem);
1061 if (SvIMMORTAL(sv)) {
1062 if (relem <= lastrelem)
1066 if (relem <= lastrelem) {
1068 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1069 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1072 packWARN(WARN_MISC),
1073 "Useless assignment to a temporary"
1075 sv_setsv(sv, *relem);
1079 sv_setsv(sv, &PL_sv_undef);
1084 if (PL_delaymagic & ~DM_DELAY) {
1085 if (PL_delaymagic & DM_UID) {
1086 #ifdef HAS_SETRESUID
1087 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1088 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1091 # ifdef HAS_SETREUID
1092 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1093 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1096 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1097 (void)setruid(PL_uid);
1098 PL_delaymagic &= ~DM_RUID;
1100 # endif /* HAS_SETRUID */
1102 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1103 (void)seteuid(PL_euid);
1104 PL_delaymagic &= ~DM_EUID;
1106 # endif /* HAS_SETEUID */
1107 if (PL_delaymagic & DM_UID) {
1108 if (PL_uid != PL_euid)
1109 DIE(aTHX_ "No setreuid available");
1110 (void)PerlProc_setuid(PL_uid);
1112 # endif /* HAS_SETREUID */
1113 #endif /* HAS_SETRESUID */
1114 PL_uid = PerlProc_getuid();
1115 PL_euid = PerlProc_geteuid();
1117 if (PL_delaymagic & DM_GID) {
1118 #ifdef HAS_SETRESGID
1119 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1120 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1123 # ifdef HAS_SETREGID
1124 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1125 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1128 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1129 (void)setrgid(PL_gid);
1130 PL_delaymagic &= ~DM_RGID;
1132 # endif /* HAS_SETRGID */
1134 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1135 (void)setegid(PL_egid);
1136 PL_delaymagic &= ~DM_EGID;
1138 # endif /* HAS_SETEGID */
1139 if (PL_delaymagic & DM_GID) {
1140 if (PL_gid != PL_egid)
1141 DIE(aTHX_ "No setregid available");
1142 (void)PerlProc_setgid(PL_gid);
1144 # endif /* HAS_SETREGID */
1145 #endif /* HAS_SETRESGID */
1146 PL_gid = PerlProc_getgid();
1147 PL_egid = PerlProc_getegid();
1149 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1153 if (gimme == G_VOID)
1154 SP = firstrelem - 1;
1155 else if (gimme == G_SCALAR) {
1158 SETi(lastrelem - firstrelem + 1 - duplicates);
1165 /* at this point we have removed the duplicate key/value
1166 * pairs from the stack, but the remaining values may be
1167 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1168 * the (a 2), but the stack now probably contains
1169 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1170 * obliterates the earlier key. So refresh all values. */
1171 lastrelem -= duplicates;
1172 relem = firsthashrelem;
1173 while (relem < lastrelem) {
1176 he = hv_fetch_ent(hash, sv, 0, 0);
1177 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1183 SP = firstrelem + (lastlelem - firstlelem);
1184 lelem = firstlelem + (relem - firstrelem);
1186 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1195 register PMOP * const pm = cPMOP;
1196 REGEXP * rx = PM_GETRE(pm);
1197 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1198 SV * const rv = sv_newmortal();
1200 SvUPGRADE(rv, SVt_IV);
1201 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1202 loathe to use it here, but it seems to be the right fix. Or close.
1203 The key part appears to be that it's essential for pp_qr to return a new
1204 object (SV), which implies that there needs to be an effective way to
1205 generate a new SV from the existing SV that is pre-compiled in the
1207 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1211 HV *const stash = gv_stashsv(pkg, GV_ADD);
1213 (void)sv_bless(rv, stash);
1216 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1218 SvTAINTED_on(SvRV(rv));
1227 register PMOP *pm = cPMOP;
1229 register const char *t;
1230 register const char *s;
1233 U8 r_flags = REXEC_CHECKED;
1234 const char *truebase; /* Start of string */
1235 register REGEXP *rx = PM_GETRE(pm);
1237 const I32 gimme = GIMME;
1240 const I32 oldsave = PL_savestack_ix;
1241 I32 update_minmatch = 1;
1242 I32 had_zerolen = 0;
1245 if (PL_op->op_flags & OPf_STACKED)
1247 else if (PL_op->op_private & OPpTARGET_MY)
1254 PUTBACK; /* EVAL blocks need stack_sp. */
1255 /* Skip get-magic if this is a qr// clone, because regcomp has
1257 s = ((struct regexp *)SvANY(rx))->mother_re
1258 ? SvPV_nomg_const(TARG, len)
1259 : SvPV_const(TARG, len);
1261 DIE(aTHX_ "panic: pp_match");
1263 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1264 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1267 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1269 /* PMdf_USED is set after a ?? matches once */
1272 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1274 pm->op_pmflags & PMf_USED
1278 if (gimme == G_ARRAY)
1285 /* empty pattern special-cased to use last successful pattern if possible */
1286 if (!RX_PRELEN(rx) && PL_curpm) {
1291 if (RX_MINLEN(rx) > (I32)len)
1296 /* XXXX What part of this is needed with true \G-support? */
1297 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1298 RX_OFFS(rx)[0].start = -1;
1299 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1300 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1301 if (mg && mg->mg_len >= 0) {
1302 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1303 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1304 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1305 r_flags |= REXEC_IGNOREPOS;
1306 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1307 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1310 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1311 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1312 update_minmatch = 0;
1316 /* XXX: comment out !global get safe $1 vars after a
1317 match, BUT be aware that this leads to dramatic slowdowns on
1318 /g matches against large strings. So far a solution to this problem
1319 appears to be quite tricky.
1320 Test for the unsafe vars are TODO for now. */
1321 if ( (!global && RX_NPARENS(rx))
1322 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1323 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1324 r_flags |= REXEC_COPY_STR;
1326 r_flags |= REXEC_SCREAM;
1329 if (global && RX_OFFS(rx)[0].start != -1) {
1330 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1331 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1333 if (update_minmatch++)
1334 minmatch = had_zerolen;
1336 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1337 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1338 /* FIXME - can PL_bostr be made const char *? */
1339 PL_bostr = (char *)truebase;
1340 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1344 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1346 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1347 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1348 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1349 && (r_flags & REXEC_SCREAM)))
1350 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1353 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1354 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1358 if (dynpm->op_pmflags & PMf_ONCE) {
1360 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1362 dynpm->op_pmflags |= PMf_USED;
1368 RX_MATCH_TAINTED_on(rx);
1369 TAINT_IF(RX_MATCH_TAINTED(rx));
1370 if (gimme == G_ARRAY) {
1371 const I32 nparens = RX_NPARENS(rx);
1372 I32 i = (global && !nparens) ? 1 : 0;
1374 SPAGAIN; /* EVAL blocks could move the stack. */
1375 EXTEND(SP, nparens + i);
1376 EXTEND_MORTAL(nparens + i);
1377 for (i = !i; i <= nparens; i++) {
1378 PUSHs(sv_newmortal());
1379 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1380 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1381 s = RX_OFFS(rx)[i].start + truebase;
1382 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1383 len < 0 || len > strend - s)
1384 DIE(aTHX_ "panic: pp_match start/end pointers");
1385 sv_setpvn(*SP, s, len);
1386 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1391 if (dynpm->op_pmflags & PMf_CONTINUE) {
1393 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1394 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1396 #ifdef PERL_OLD_COPY_ON_WRITE
1398 sv_force_normal_flags(TARG, 0);
1400 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1401 &PL_vtbl_mglob, NULL, 0);
1403 if (RX_OFFS(rx)[0].start != -1) {
1404 mg->mg_len = RX_OFFS(rx)[0].end;
1405 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1406 mg->mg_flags |= MGf_MINMATCH;
1408 mg->mg_flags &= ~MGf_MINMATCH;
1411 had_zerolen = (RX_OFFS(rx)[0].start != -1
1412 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1413 == (UV)RX_OFFS(rx)[0].end));
1414 PUTBACK; /* EVAL blocks may use stack */
1415 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1420 LEAVE_SCOPE(oldsave);
1426 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1427 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1431 #ifdef PERL_OLD_COPY_ON_WRITE
1433 sv_force_normal_flags(TARG, 0);
1435 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1436 &PL_vtbl_mglob, NULL, 0);
1438 if (RX_OFFS(rx)[0].start != -1) {
1439 mg->mg_len = RX_OFFS(rx)[0].end;
1440 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1441 mg->mg_flags |= MGf_MINMATCH;
1443 mg->mg_flags &= ~MGf_MINMATCH;
1446 LEAVE_SCOPE(oldsave);
1450 yup: /* Confirmed by INTUIT */
1452 RX_MATCH_TAINTED_on(rx);
1453 TAINT_IF(RX_MATCH_TAINTED(rx));
1455 if (dynpm->op_pmflags & PMf_ONCE) {
1457 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1459 dynpm->op_pmflags |= PMf_USED;
1462 if (RX_MATCH_COPIED(rx))
1463 Safefree(RX_SUBBEG(rx));
1464 RX_MATCH_COPIED_off(rx);
1465 RX_SUBBEG(rx) = NULL;
1467 /* FIXME - should rx->subbeg be const char *? */
1468 RX_SUBBEG(rx) = (char *) truebase;
1469 RX_OFFS(rx)[0].start = s - truebase;
1470 if (RX_MATCH_UTF8(rx)) {
1471 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1472 RX_OFFS(rx)[0].end = t - truebase;
1475 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1477 RX_SUBLEN(rx) = strend - truebase;
1480 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1482 #ifdef PERL_OLD_COPY_ON_WRITE
1483 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1485 PerlIO_printf(Perl_debug_log,
1486 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1487 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1490 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1492 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1493 assert (SvPOKp(RX_SAVED_COPY(rx)));
1498 RX_SUBBEG(rx) = savepvn(t, strend - t);
1499 #ifdef PERL_OLD_COPY_ON_WRITE
1500 RX_SAVED_COPY(rx) = NULL;
1503 RX_SUBLEN(rx) = strend - t;
1504 RX_MATCH_COPIED_on(rx);
1505 off = RX_OFFS(rx)[0].start = s - t;
1506 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1508 else { /* startp/endp are used by @- @+. */
1509 RX_OFFS(rx)[0].start = s - truebase;
1510 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1512 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1514 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1515 LEAVE_SCOPE(oldsave);
1520 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1521 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1522 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1527 LEAVE_SCOPE(oldsave);
1528 if (gimme == G_ARRAY)
1534 Perl_do_readline(pTHX)
1536 dVAR; dSP; dTARGETSTACKED;
1541 register IO * const io = GvIO(PL_last_in_gv);
1542 register const I32 type = PL_op->op_type;
1543 const I32 gimme = GIMME_V;
1546 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1548 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1549 if (gimme == G_SCALAR) {
1551 SvSetSV_nosteal(TARG, TOPs);
1561 if (IoFLAGS(io) & IOf_ARGV) {
1562 if (IoFLAGS(io) & IOf_START) {
1564 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1565 IoFLAGS(io) &= ~IOf_START;
1566 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1567 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1568 SvSETMAGIC(GvSV(PL_last_in_gv));
1573 fp = nextargv(PL_last_in_gv);
1574 if (!fp) { /* Note: fp != IoIFP(io) */
1575 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1578 else if (type == OP_GLOB)
1579 fp = Perl_start_glob(aTHX_ POPs, io);
1581 else if (type == OP_GLOB)
1583 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1584 report_wrongway_fh(PL_last_in_gv, '>');
1588 if ((!io || !(IoFLAGS(io) & IOf_START))
1589 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1591 if (type == OP_GLOB)
1592 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1593 "glob failed (can't start child: %s)",
1596 report_evil_fh(PL_last_in_gv);
1598 if (gimme == G_SCALAR) {
1599 /* undef TARG, and push that undefined value */
1600 if (type != OP_RCATLINE) {
1601 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1609 if (gimme == G_SCALAR) {
1611 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1614 if (type == OP_RCATLINE)
1615 SvPV_force_nolen(sv);
1619 else if (isGV_with_GP(sv)) {
1620 SvPV_force_nolen(sv);
1622 SvUPGRADE(sv, SVt_PV);
1623 tmplen = SvLEN(sv); /* remember if already alloced */
1624 if (!tmplen && !SvREADONLY(sv)) {
1625 /* try short-buffering it. Please update t/op/readline.t
1626 * if you change the growth length.
1631 if (type == OP_RCATLINE && SvOK(sv)) {
1633 SvPV_force_nolen(sv);
1639 sv = sv_2mortal(newSV(80));
1643 /* This should not be marked tainted if the fp is marked clean */
1644 #define MAYBE_TAINT_LINE(io, sv) \
1645 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1650 /* delay EOF state for a snarfed empty file */
1651 #define SNARF_EOF(gimme,rs,io,sv) \
1652 (gimme != G_SCALAR || SvCUR(sv) \
1653 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1657 if (!sv_gets(sv, fp, offset)
1659 || SNARF_EOF(gimme, PL_rs, io, sv)
1660 || PerlIO_error(fp)))
1662 PerlIO_clearerr(fp);
1663 if (IoFLAGS(io) & IOf_ARGV) {
1664 fp = nextargv(PL_last_in_gv);
1667 (void)do_close(PL_last_in_gv, FALSE);
1669 else if (type == OP_GLOB) {
1670 if (!do_close(PL_last_in_gv, FALSE)) {
1671 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1672 "glob failed (child exited with status %d%s)",
1673 (int)(STATUS_CURRENT >> 8),
1674 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1677 if (gimme == G_SCALAR) {
1678 if (type != OP_RCATLINE) {
1679 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1685 MAYBE_TAINT_LINE(io, sv);
1688 MAYBE_TAINT_LINE(io, sv);
1690 IoFLAGS(io) |= IOf_NOLINE;
1694 if (type == OP_GLOB) {
1697 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1698 char * const tmps = SvEND(sv) - 1;
1699 if (*tmps == *SvPVX_const(PL_rs)) {
1701 SvCUR_set(sv, SvCUR(sv) - 1);
1704 for (t1 = SvPVX_const(sv); *t1; t1++)
1705 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1706 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1708 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1709 (void)POPs; /* Unmatched wildcard? Chuck it... */
1712 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1713 if (ckWARN(WARN_UTF8)) {
1714 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1715 const STRLEN len = SvCUR(sv) - offset;
1718 if (!is_utf8_string_loc(s, len, &f))
1719 /* Emulate :encoding(utf8) warning in the same case. */
1720 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1721 "utf8 \"\\x%02X\" does not map to Unicode",
1722 f < (U8*)SvEND(sv) ? *f : 0);
1725 if (gimme == G_ARRAY) {
1726 if (SvLEN(sv) - SvCUR(sv) > 20) {
1727 SvPV_shrink_to_cur(sv);
1729 sv = sv_2mortal(newSV(80));
1732 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1733 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1734 const STRLEN new_len
1735 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1736 SvPV_renew(sv, new_len);
1747 SV * const keysv = POPs;
1748 HV * const hv = MUTABLE_HV(POPs);
1749 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1750 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1752 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1753 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1754 bool preeminent = TRUE;
1756 if (SvTYPE(hv) != SVt_PVHV)
1763 /* If we can determine whether the element exist,
1764 * Try to preserve the existenceness of a tied hash
1765 * element by using EXISTS and DELETE if possible.
1766 * Fallback to FETCH and STORE otherwise. */
1767 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1768 preeminent = hv_exists_ent(hv, keysv, 0);
1771 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1772 svp = he ? &HeVAL(he) : NULL;
1774 if (!svp || *svp == &PL_sv_undef) {
1778 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1780 lv = sv_newmortal();
1781 sv_upgrade(lv, SVt_PVLV);
1783 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1784 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1785 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1791 if (HvNAME_get(hv) && isGV(*svp))
1792 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1793 else if (preeminent)
1794 save_helem_flags(hv, keysv, svp,
1795 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1797 SAVEHDELETE(hv, keysv);
1799 else if (PL_op->op_private & OPpDEREF) {
1800 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1804 sv = (svp ? *svp : &PL_sv_undef);
1805 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1806 * was to make C<local $tied{foo} = $tied{foo}> possible.
1807 * However, it seems no longer to be needed for that purpose, and
1808 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1809 * would loop endlessly since the pos magic is getting set on the
1810 * mortal copy and lost. However, the copy has the effect of
1811 * triggering the get magic, and losing it altogether made things like
1812 * c<$tied{foo};> in void context no longer do get magic, which some
1813 * code relied on. Also, delayed triggering of magic on @+ and friends
1814 * meant the original regex may be out of scope by now. So as a
1815 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1816 * being called too many times). */
1817 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1826 register PERL_CONTEXT *cx;
1829 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1830 bool av_is_stack = FALSE;
1833 cx = &cxstack[cxstack_ix];
1834 if (!CxTYPE_is_LOOP(cx))
1835 DIE(aTHX_ "panic: pp_iter");
1837 itersvp = CxITERVAR(cx);
1838 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1839 /* string increment */
1840 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1841 SV *end = cx->blk_loop.state_u.lazysv.end;
1842 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1843 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1845 const char *max = SvPV_const(end, maxlen);
1846 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1847 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1848 /* safe to reuse old SV */
1849 sv_setsv(*itersvp, cur);
1853 /* we need a fresh SV every time so that loop body sees a
1854 * completely new SV for closures/references to work as
1857 *itersvp = newSVsv(cur);
1858 SvREFCNT_dec(oldsv);
1860 if (strEQ(SvPVX_const(cur), max))
1861 sv_setiv(cur, 0); /* terminate next time */
1868 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1869 /* integer increment */
1870 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1873 /* don't risk potential race */
1874 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1875 /* safe to reuse old SV */
1876 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1880 /* we need a fresh SV every time so that loop body sees a
1881 * completely new SV for closures/references to work as they
1884 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1885 SvREFCNT_dec(oldsv);
1888 /* Handle end of range at IV_MAX */
1889 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1890 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1892 cx->blk_loop.state_u.lazyiv.cur++;
1893 cx->blk_loop.state_u.lazyiv.end++;
1900 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1901 av = cx->blk_loop.state_u.ary.ary;
1906 if (PL_op->op_private & OPpITER_REVERSED) {
1907 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1908 ? cx->blk_loop.resetsp + 1 : 0))
1911 if (SvMAGICAL(av) || AvREIFY(av)) {
1912 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1913 sv = svp ? *svp : NULL;
1916 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1920 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1924 if (SvMAGICAL(av) || AvREIFY(av)) {
1925 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1926 sv = svp ? *svp : NULL;
1929 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1933 if (sv && SvIS_FREED(sv)) {
1935 Perl_croak(aTHX_ "Use of freed value in iteration");
1940 SvREFCNT_inc_simple_void_NN(sv);
1944 if (!av_is_stack && sv == &PL_sv_undef) {
1945 SV *lv = newSV_type(SVt_PVLV);
1947 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1948 LvTARG(lv) = SvREFCNT_inc_simple(av);
1949 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1950 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1956 SvREFCNT_dec(oldsv);
1962 A description of how taint works in pattern matching and substitution.
1964 While the pattern is being assembled/concatenated and them compiled,
1965 PL_tainted will get set if any component of the pattern is tainted, e.g.
1966 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1967 is set on the pattern if PL_tainted is set.
1969 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1970 the pattern is marked as tainted. This means that subsequent usage, such
1971 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1973 During execution of a pattern, locale-variant ops such as ALNUML set the
1974 local flag RF_tainted. At the end of execution, the engine sets the
1975 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
1978 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
1979 of $1 et al to indicate whether the returned value should be tainted.
1980 It is the responsibility of the caller of the pattern (i.e. pp_match,
1981 pp_subst etc) to set this flag for any other circumstances where $1 needs
1984 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
1986 There are three possible sources of taint
1988 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
1989 * the replacement string (or expression under /e)
1991 There are four destinations of taint and they are affected by the sources
1992 according to the rules below:
1994 * the return value (not including /r):
1995 tainted by the source string and pattern, but only for the
1996 number-of-iterations case; boolean returns aren't tainted;
1997 * the modified string (or modified copy under /r):
1998 tainted by the source string, pattern, and replacement strings;
2000 tainted by the pattern, and under 'use re "taint"', by the source
2002 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2003 should always be unset before executing subsequent code.
2005 The overall action of pp_subst is:
2007 * at the start, set bits in rxtainted indicating the taint status of
2008 the various sources.
2010 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2011 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2012 pattern has subsequently become tainted via locale ops.
2014 * If control is being passed to pp_substcont to execute a /e block,
2015 save rxtainted in the CXt_SUBST block, for future use by
2018 * Whenever control is being returned to perl code (either by falling
2019 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2020 use the flag bits in rxtainted to make all the appropriate types of
2021 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2022 et al will appear tainted.
2024 pp_match is just a simpler version of the above.
2031 register PMOP *pm = cPMOP;
2043 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2044 See "how taint works" above */
2047 register REGEXP *rx = PM_GETRE(pm);
2049 int force_on_match = 0;
2050 const I32 oldsave = PL_savestack_ix;
2052 bool doutf8 = FALSE;
2053 #ifdef PERL_OLD_COPY_ON_WRITE
2057 /* known replacement string? */
2058 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2062 if (PL_op->op_flags & OPf_STACKED)
2064 else if (PL_op->op_private & OPpTARGET_MY)
2071 #ifdef PERL_OLD_COPY_ON_WRITE
2072 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2073 because they make integers such as 256 "false". */
2074 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2077 sv_force_normal_flags(TARG,0);
2079 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2080 #ifdef PERL_OLD_COPY_ON_WRITE
2083 && (SvREADONLY(TARG)
2084 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2085 || SvTYPE(TARG) > SVt_PVLV)
2086 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2087 Perl_croak_no_modify(aTHX);
2091 s = SvPV_mutable(TARG, len);
2092 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2095 /* only replace once? */
2096 once = !(rpm->op_pmflags & PMf_GLOBAL);
2098 /* See "how taint works" above */
2101 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2102 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2103 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2104 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2105 ? SUBST_TAINT_BOOLRET : 0));
2109 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2113 DIE(aTHX_ "panic: pp_subst");
2116 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2117 maxiters = 2 * slen + 10; /* We can match twice at each
2118 position, once with zero-length,
2119 second time with non-zero. */
2121 if (!RX_PRELEN(rx) && PL_curpm) {
2125 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2126 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2127 ? REXEC_COPY_STR : 0;
2129 r_flags |= REXEC_SCREAM;
2132 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2134 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2138 /* How to do it in subst? */
2139 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2141 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2142 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2143 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2144 && (r_flags & REXEC_SCREAM))))
2149 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2150 r_flags | REXEC_CHECKED))
2154 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2155 LEAVE_SCOPE(oldsave);
2159 /* known replacement string? */
2161 if (SvTAINTED(dstr))
2162 rxtainted |= SUBST_TAINT_REPL;
2164 /* Upgrade the source if the replacement is utf8 but the source is not,
2165 * but only if it matched; see
2166 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2168 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2169 char * const orig_pvx = SvPVX(TARG);
2170 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2172 /* If the lengths are the same, the pattern contains only
2173 * invariants, can keep going; otherwise, various internal markers
2174 * could be off, so redo */
2175 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2180 /* replacement needing upgrading? */
2181 if (DO_UTF8(TARG) && !doutf8) {
2182 nsv = sv_newmortal();
2185 sv_recode_to_utf8(nsv, PL_encoding);
2187 sv_utf8_upgrade(nsv);
2188 c = SvPV_const(nsv, clen);
2192 c = SvPV_const(dstr, clen);
2193 doutf8 = DO_UTF8(dstr);
2201 /* can do inplace substitution? */
2203 #ifdef PERL_OLD_COPY_ON_WRITE
2206 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2207 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2208 && (!doutf8 || SvUTF8(TARG))
2209 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2212 #ifdef PERL_OLD_COPY_ON_WRITE
2213 if (SvIsCOW(TARG)) {
2214 assert (!force_on_match);
2218 if (force_on_match) {
2220 s = SvPV_force(TARG, len);
2225 SvSCREAM_off(TARG); /* disable possible screamer */
2227 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2228 rxtainted |= SUBST_TAINT_PAT;
2229 m = orig + RX_OFFS(rx)[0].start;
2230 d = orig + RX_OFFS(rx)[0].end;
2232 if (m - s > strend - d) { /* faster to shorten from end */
2234 Copy(c, m, clen, char);
2239 Move(d, m, i, char);
2243 SvCUR_set(TARG, m - s);
2245 else if ((i = m - s)) { /* faster from front */
2248 Move(s, d - i, i, char);
2251 Copy(c, m, clen, char);
2256 Copy(c, d, clen, char);
2266 if (iters++ > maxiters)
2267 DIE(aTHX_ "Substitution loop");
2268 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2269 rxtainted |= SUBST_TAINT_PAT;
2270 m = RX_OFFS(rx)[0].start + orig;
2273 Move(s, d, i, char);
2277 Copy(c, d, clen, char);
2280 s = RX_OFFS(rx)[0].end + orig;
2281 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2283 /* don't match same null twice */
2284 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2287 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2288 Move(s, d, i+1, char); /* include the NUL */
2295 if (force_on_match) {
2297 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2298 /* I feel that it should be possible to avoid this mortal copy
2299 given that the code below copies into a new destination.
2300 However, I suspect it isn't worth the complexity of
2301 unravelling the C<goto force_it> for the small number of
2302 cases where it would be viable to drop into the copy code. */
2303 TARG = sv_2mortal(newSVsv(TARG));
2305 s = SvPV_force(TARG, len);
2308 #ifdef PERL_OLD_COPY_ON_WRITE
2311 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2312 rxtainted |= SUBST_TAINT_PAT;
2313 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2316 register PERL_CONTEXT *cx;
2318 /* note that a whole bunch of local vars are saved here for
2319 * use by pp_substcont: here's a list of them in case you're
2320 * searching for places in this sub that uses a particular var:
2321 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2322 * s m strend rx once */
2324 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2326 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2328 if (iters++ > maxiters)
2329 DIE(aTHX_ "Substitution loop");
2330 if (RX_MATCH_TAINTED(rx))
2331 rxtainted |= SUBST_TAINT_PAT;
2332 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2335 orig = RX_SUBBEG(rx);
2337 strend = s + (strend - m);
2339 m = RX_OFFS(rx)[0].start + orig;
2340 if (doutf8 && !SvUTF8(dstr))
2341 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2343 sv_catpvn(dstr, s, m-s);
2344 s = RX_OFFS(rx)[0].end + orig;
2346 sv_catpvn(dstr, c, clen);
2349 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2350 TARG, NULL, r_flags));
2351 if (doutf8 && !DO_UTF8(TARG))
2352 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2354 sv_catpvn(dstr, s, strend - s);
2356 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2357 /* From here on down we're using the copy, and leaving the original
2363 #ifdef PERL_OLD_COPY_ON_WRITE
2364 /* The match may make the string COW. If so, brilliant, because
2365 that's just saved us one malloc, copy and free - the regexp has
2366 donated the old buffer, and we malloc an entirely new one, rather
2367 than the regexp malloc()ing a buffer and copying our original,
2368 only for us to throw it away here during the substitution. */
2369 if (SvIsCOW(TARG)) {
2370 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2376 SvPV_set(TARG, SvPVX(dstr));
2377 SvCUR_set(TARG, SvCUR(dstr));
2378 SvLEN_set(TARG, SvLEN(dstr));
2379 doutf8 |= DO_UTF8(dstr);
2380 SvPV_set(dstr, NULL);
2387 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2388 (void)SvPOK_only_UTF8(TARG);
2393 /* See "how taint works" above */
2395 if ((rxtainted & SUBST_TAINT_PAT) ||
2396 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2397 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2399 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2401 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2402 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2404 SvTAINTED_on(TOPs); /* taint return value */
2406 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2408 /* needed for mg_set below */
2410 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2413 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2415 LEAVE_SCOPE(oldsave);
2424 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2425 ++*PL_markstack_ptr;
2427 LEAVE_with_name("grep_item"); /* exit inner scope */
2430 if (PL_stack_base + *PL_markstack_ptr > SP) {
2432 const I32 gimme = GIMME_V;
2434 LEAVE_with_name("grep"); /* exit outer scope */
2435 (void)POPMARK; /* pop src */
2436 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2437 (void)POPMARK; /* pop dst */
2438 SP = PL_stack_base + POPMARK; /* pop original mark */
2439 if (gimme == G_SCALAR) {
2440 if (PL_op->op_private & OPpGREP_LEX) {
2441 SV* const sv = sv_newmortal();
2442 sv_setiv(sv, items);
2450 else if (gimme == G_ARRAY)
2457 ENTER_with_name("grep_item"); /* enter inner scope */
2460 src = PL_stack_base[*PL_markstack_ptr];
2462 if (PL_op->op_private & OPpGREP_LEX)
2463 PAD_SVl(PL_op->op_targ) = src;
2467 RETURNOP(cLOGOP->op_other);
2478 register PERL_CONTEXT *cx;
2481 if (CxMULTICALL(&cxstack[cxstack_ix]))
2485 cxstack_ix++; /* temporarily protect top context */
2488 if (gimme == G_SCALAR) {
2491 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2492 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2493 *MARK = SvREFCNT_inc(TOPs);
2498 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2500 *MARK = sv_mortalcopy(sv);
2504 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2508 *MARK = sv_mortalcopy(TOPs);
2512 *MARK = &PL_sv_undef;
2516 else if (gimme == G_ARRAY) {
2517 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2518 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
2519 *MARK = sv_mortalcopy(*MARK);
2520 TAINT_NOT; /* Each item is independent */
2528 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2529 PL_curpm = newpm; /* ... and pop $1 et al */
2532 return cx->blk_sub.retop;
2540 register PERL_CONTEXT *cx;
2542 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2545 DIE(aTHX_ "Not a CODE reference");
2546 switch (SvTYPE(sv)) {
2547 /* This is overwhelming the most common case: */
2549 if (!isGV_with_GP(sv))
2550 DIE(aTHX_ "Not a CODE reference");
2552 if (!(cv = GvCVu((const GV *)sv))) {
2554 cv = sv_2cv(sv, &stash, &gv, 0);
2563 if(isGV_with_GP(sv)) goto we_have_a_glob;
2566 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2568 SP = PL_stack_base + POPMARK;
2576 sv = amagic_deref_call(sv, to_cv_amg);
2577 /* Don't SPAGAIN here. */
2583 sym = SvPV_nomg_const(sv, len);
2585 DIE(aTHX_ PL_no_usym, "a subroutine");
2586 if (PL_op->op_private & HINT_STRICT_REFS)
2587 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2588 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2591 cv = MUTABLE_CV(SvRV(sv));
2592 if (SvTYPE(cv) == SVt_PVCV)
2597 DIE(aTHX_ "Not a CODE reference");
2598 /* This is the second most common case: */
2600 cv = MUTABLE_CV(sv);
2608 if (CvCLONE(cv) && ! CvCLONED(cv))
2609 DIE(aTHX_ "Closure prototype called");
2610 if (!CvROOT(cv) && !CvXSUB(cv)) {
2614 /* anonymous or undef'd function leaves us no recourse */
2615 if (CvANON(cv) || !(gv = CvGV(cv)))
2616 DIE(aTHX_ "Undefined subroutine called");
2618 /* autoloaded stub? */
2619 if (cv != GvCV(gv)) {
2622 /* should call AUTOLOAD now? */
2625 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2632 sub_name = sv_newmortal();
2633 gv_efullname3(sub_name, gv, NULL);
2634 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2638 DIE(aTHX_ "Not a CODE reference");
2643 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2644 Perl_get_db_sub(aTHX_ &sv, cv);
2646 PL_curcopdb = PL_curcop;
2648 /* check for lsub that handles lvalue subroutines */
2649 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2650 /* if lsub not found then fall back to DB::sub */
2651 if (!cv) cv = GvCV(PL_DBsub);
2653 cv = GvCV(PL_DBsub);
2656 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2657 DIE(aTHX_ "No DB::sub routine defined");
2660 if (!(CvISXSUB(cv))) {
2661 /* This path taken at least 75% of the time */
2663 register I32 items = SP - MARK;
2664 AV* const padlist = CvPADLIST(cv);
2665 PUSHBLOCK(cx, CXt_SUB, MARK);
2667 cx->blk_sub.retop = PL_op->op_next;
2669 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2670 * that eval'' ops within this sub know the correct lexical space.
2671 * Owing the speed considerations, we choose instead to search for
2672 * the cv using find_runcv() when calling doeval().
2674 if (CvDEPTH(cv) >= 2) {
2675 PERL_STACK_OVERFLOW_CHECK();
2676 pad_push(padlist, CvDEPTH(cv));
2679 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2681 AV *const av = MUTABLE_AV(PAD_SVl(0));
2683 /* @_ is normally not REAL--this should only ever
2684 * happen when DB::sub() calls things that modify @_ */
2689 cx->blk_sub.savearray = GvAV(PL_defgv);
2690 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2691 CX_CURPAD_SAVE(cx->blk_sub);
2692 cx->blk_sub.argarray = av;
2695 if (items > AvMAX(av) + 1) {
2696 SV **ary = AvALLOC(av);
2697 if (AvARRAY(av) != ary) {
2698 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2701 if (items > AvMAX(av) + 1) {
2702 AvMAX(av) = items - 1;
2703 Renew(ary,items,SV*);
2708 Copy(MARK,AvARRAY(av),items,SV*);
2709 AvFILLp(av) = items - 1;
2717 /* warning must come *after* we fully set up the context
2718 * stuff so that __WARN__ handlers can safely dounwind()
2721 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2722 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2723 sub_crush_depth(cv);
2724 RETURNOP(CvSTART(cv));
2727 I32 markix = TOPMARK;
2732 /* Need to copy @_ to stack. Alternative may be to
2733 * switch stack to @_, and copy return values
2734 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2735 AV * const av = GvAV(PL_defgv);
2736 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2739 /* Mark is at the end of the stack. */
2741 Copy(AvARRAY(av), SP + 1, items, SV*);
2746 /* We assume first XSUB in &DB::sub is the called one. */
2748 SAVEVPTR(PL_curcop);
2749 PL_curcop = PL_curcopdb;
2752 /* Do we need to open block here? XXXX */
2754 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2756 CvXSUB(cv)(aTHX_ cv);
2758 /* Enforce some sanity in scalar context. */
2759 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2760 if (markix > PL_stack_sp - PL_stack_base)
2761 *(PL_stack_base + markix) = &PL_sv_undef;
2763 *(PL_stack_base + markix) = *PL_stack_sp;
2764 PL_stack_sp = PL_stack_base + markix;
2772 Perl_sub_crush_depth(pTHX_ CV *cv)
2774 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2777 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2779 SV* const tmpstr = sv_newmortal();
2780 gv_efullname3(tmpstr, CvGV(cv), NULL);
2781 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2790 SV* const elemsv = POPs;
2791 IV elem = SvIV(elemsv);
2792 AV *const av = MUTABLE_AV(POPs);
2793 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2794 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2795 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2796 bool preeminent = TRUE;
2799 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2800 Perl_warner(aTHX_ packWARN(WARN_MISC),
2801 "Use of reference \"%"SVf"\" as array index",
2804 elem -= CopARYBASE_get(PL_curcop);
2805 if (SvTYPE(av) != SVt_PVAV)
2812 /* If we can determine whether the element exist,
2813 * Try to preserve the existenceness of a tied array
2814 * element by using EXISTS and DELETE if possible.
2815 * Fallback to FETCH and STORE otherwise. */
2816 if (SvCANEXISTDELETE(av))
2817 preeminent = av_exists(av, elem);
2820 svp = av_fetch(av, elem, lval && !defer);
2822 #ifdef PERL_MALLOC_WRAP
2823 if (SvUOK(elemsv)) {
2824 const UV uv = SvUV(elemsv);
2825 elem = uv > IV_MAX ? IV_MAX : uv;
2827 else if (SvNOK(elemsv))
2828 elem = (IV)SvNV(elemsv);
2830 static const char oom_array_extend[] =
2831 "Out of memory during array extend"; /* Duplicated in av.c */
2832 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2835 if (!svp || *svp == &PL_sv_undef) {
2838 DIE(aTHX_ PL_no_aelem, elem);
2839 lv = sv_newmortal();
2840 sv_upgrade(lv, SVt_PVLV);
2842 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2843 LvTARG(lv) = SvREFCNT_inc_simple(av);
2844 LvTARGOFF(lv) = elem;
2851 save_aelem(av, elem, svp);
2853 SAVEADELETE(av, elem);
2855 else if (PL_op->op_private & OPpDEREF) {
2856 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2860 sv = (svp ? *svp : &PL_sv_undef);
2861 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2868 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2870 PERL_ARGS_ASSERT_VIVIFY_REF;
2875 Perl_croak_no_modify(aTHX);
2876 prepare_SV_for_RV(sv);
2879 SvRV_set(sv, newSV(0));
2882 SvRV_set(sv, MUTABLE_SV(newAV()));
2885 SvRV_set(sv, MUTABLE_SV(newHV()));
2891 if (SvGMAGICAL(sv)) {
2892 /* copy the sv without magic to prevent magic from being
2894 SV* msv = sv_newmortal();
2895 sv_setsv_nomg(msv, sv);
2904 SV* const sv = TOPs;
2907 SV* const rsv = SvRV(sv);
2908 if (SvTYPE(rsv) == SVt_PVCV) {
2914 SETs(method_common(sv, NULL));
2921 SV* const sv = cSVOP_sv;
2922 U32 hash = SvSHARED_HASH(sv);
2924 XPUSHs(method_common(sv, &hash));
2929 S_method_common(pTHX_ SV* meth, U32* hashp)
2935 const char* packname = NULL;
2938 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2940 PERL_ARGS_ASSERT_METHOD_COMMON;
2943 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2948 ob = MUTABLE_SV(SvRV(sv));
2951 bool packname_is_utf8 = FALSE;
2953 /* this isn't a reference */
2954 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2955 const HE* const he =
2956 (const HE *)hv_common_key_len(
2957 PL_stashcache, packname,
2958 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2962 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2969 !(iogv = gv_fetchpvn_flags(
2970 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2972 !(ob=MUTABLE_SV(GvIO(iogv))))
2974 /* this isn't the name of a filehandle either */
2976 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2977 ? !isIDFIRST_utf8((U8*)packname)
2978 : !isIDFIRST(*packname)
2981 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
2983 SvOK(sv) ? "without a package or object reference"
2984 : "on an undefined value");
2986 /* assume it's a package name */
2987 stash = gv_stashpvn(packname, packlen, 0);
2991 SV* const ref = newSViv(PTR2IV(stash));
2992 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
2996 /* it _is_ a filehandle name -- replace with a reference */
2997 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3000 /* if we got here, ob should be a reference or a glob */
3001 if (!ob || !(SvOBJECT(ob)
3002 || (SvTYPE(ob) == SVt_PVGV
3004 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3007 const char * const name = SvPV_nolen_const(meth);
3008 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3009 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3013 stash = SvSTASH(ob);
3016 /* NOTE: stash may be null, hope hv_fetch_ent and
3017 gv_fetchmethod can cope (it seems they can) */
3019 /* shortcut for simple names */
3021 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3023 gv = MUTABLE_GV(HeVAL(he));
3024 if (isGV(gv) && GvCV(gv) &&
3025 (!GvCVGEN(gv) || GvCVGEN(gv)
3026 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3027 return MUTABLE_SV(GvCV(gv));
3031 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3032 SvPV_nolen_const(meth),
3033 GV_AUTOLOAD | GV_CROAK);
3037 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3042 * c-indentation-style: bsd
3044 * indent-tabs-mode: t
3047 * ex: set ts=8 sts=4 sw=4 noet: