3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
51 PL_curcop = (COP*)PL_op;
52 TAINT_NOT; /* Each statement is presumed innocent */
53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
64 if (PL_op->op_private & OPpLVAL_INTRO)
65 PUSHs(save_scalar(cGVOP_gv));
67 PUSHs(GvSVn(cGVOP_gv));
77 /* This is sometimes called directly by pp_coreargs and pp_grepstart. */
81 PUSHMARK(PL_stack_sp);
92 /* no PUTBACK, SETs doesn't inc/dec SP */
99 XPUSHs(MUTABLE_SV(cGVOP_gv));
108 /* SP is not used to remove a variable that is saved across the
109 sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine
110 register or load/store vs direct mem ops macro is introduced, this
111 should be a define block between direct PL_stack_sp and dSP operations,
112 presently, using PL_stack_sp is bias towards CISC cpus */
113 SV * const sv = *PL_stack_sp;
117 if (PL_op->op_type == OP_AND)
119 return cLOGOP->op_other;
127 /* sassign keeps its args in the optree traditionally backwards.
128 So we pop them differently.
130 SV *left = POPs; SV *right = TOPs;
132 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
133 SV * const temp = left;
134 left = right; right = temp;
136 if (TAINTING_get && TAINT_get && !SvTAINTED(right))
138 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
139 SV * const cv = SvRV(right);
140 const U32 cv_type = SvTYPE(cv);
141 const bool is_gv = isGV_with_GP(left);
142 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
148 /* Can do the optimisation if left (LVALUE) is not a typeglob,
149 right (RVALUE) is a reference to something, and we're in void
151 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
152 /* Is the target symbol table currently empty? */
153 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
154 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
155 /* Good. Create a new proxy constant subroutine in the target.
156 The gv becomes a(nother) reference to the constant. */
157 SV *const value = SvRV(cv);
159 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
160 SvPCS_IMPORTED_on(gv);
162 SvREFCNT_inc_simple_void(value);
168 /* Need to fix things up. */
170 /* Need to fix GV. */
171 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
175 /* We've been returned a constant rather than a full subroutine,
176 but they expect a subroutine reference to apply. */
178 ENTER_with_name("sassign_coderef");
179 SvREFCNT_inc_void(SvRV(cv));
180 /* newCONSTSUB takes a reference count on the passed in SV
181 from us. We set the name to NULL, otherwise we get into
182 all sorts of fun as the reference to our new sub is
183 donated to the GV that we're about to assign to.
185 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
188 LEAVE_with_name("sassign_coderef");
190 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
192 First: ops for \&{"BONK"}; return us the constant in the
194 Second: ops for *{"BONK"} cause that symbol table entry
195 (and our reference to it) to be upgraded from RV
197 Thirdly: We get here. cv is actually PVGV now, and its
198 GvCV() is actually the subroutine we're looking for
200 So change the reference so that it points to the subroutine
201 of that typeglob, as that's what they were after all along.
203 GV *const upgraded = MUTABLE_GV(cv);
204 CV *const source = GvCV(upgraded);
207 assert(CvFLAGS(source) & CVf_CONST);
209 SvREFCNT_inc_void(source);
210 SvREFCNT_dec_NN(upgraded);
211 SvRV_set(right, MUTABLE_SV(source));
217 SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
218 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
221 packWARN(WARN_MISC), "Useless assignment to a temporary"
223 SvSetMagicSV(left, right);
233 RETURNOP(cLOGOP->op_other);
235 RETURNOP(cLOGOP->op_next);
242 TAINT_NOT; /* Each statement is presumed innocent */
243 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
245 if (!(PL_op->op_flags & OPf_SPECIAL)) {
246 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
247 LEAVE_SCOPE(oldsave);
254 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
259 const char *rpv = NULL;
261 bool rcopied = FALSE;
263 if (TARG == right && right != left) { /* $r = $l.$r */
264 rpv = SvPV_nomg_const(right, rlen);
265 rbyte = !DO_UTF8(right);
266 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
267 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
271 if (TARG != left) { /* not $l .= $r */
273 const char* const lpv = SvPV_nomg_const(left, llen);
274 lbyte = !DO_UTF8(left);
275 sv_setpvn(TARG, lpv, llen);
281 else { /* $l .= $r */
283 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
284 report_uninit(right);
287 SvPV_force_nomg_nolen(left);
288 lbyte = !DO_UTF8(left);
295 /* $r.$r: do magic twice: tied might return different 2nd time */
297 rpv = SvPV_nomg_const(right, rlen);
298 rbyte = !DO_UTF8(right);
300 if (lbyte != rbyte) {
301 /* sv_utf8_upgrade_nomg() may reallocate the stack */
304 sv_utf8_upgrade_nomg(TARG);
307 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
308 sv_utf8_upgrade_nomg(right);
309 rpv = SvPV_nomg_const(right, rlen);
313 sv_catpvn_nomg(TARG, rpv, rlen);
320 /* push the elements of av onto the stack.
321 * XXX Note that padav has similar code but without the mg_get().
322 * I suspect that the mg_get is no longer needed, but while padav
323 * differs, it can't share this function */
326 S_pushav(pTHX_ AV* const av)
329 const I32 maxarg = AvFILL(av) + 1;
331 if (SvRMAGICAL(av)) {
333 for (i=0; i < (U32)maxarg; i++) {
334 SV ** const svp = av_fetch(av, i, FALSE);
335 /* See note in pp_helem, and bug id #27839 */
337 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
342 Copy(AvARRAY(av), SP+1, maxarg, SV*);
349 /* ($lex1,@lex2,...) or my ($lex1,@lex2,...) */
354 PADOFFSET base = PL_op->op_targ;
355 int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
357 if (PL_op->op_flags & OPf_SPECIAL) {
358 /* fake the RHS of my ($x,$y,..) = @_ */
360 S_pushav(aTHX_ GvAVn(PL_defgv));
364 /* note, this is only skipped for compile-time-known void cxt */
365 if ((PL_op->op_flags & OPf_WANT) != OPf_WANT_VOID) {
368 for (i = 0; i <count; i++)
369 *++SP = PAD_SV(base+i);
371 if (PL_op->op_private & OPpLVAL_INTRO) {
372 SV **svp = &(PAD_SVl(base));
373 const UV payload = (UV)(
374 (base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
375 | (count << SAVE_TIGHT_SHIFT)
376 | SAVEt_CLEARPADRANGE);
377 assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
378 assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
385 for (i = 0; i <count; i++)
386 SvPADSTALE_off(*svp++); /* mark lexical as active */
397 OP * const op = PL_op;
398 /* access PL_curpad once */
399 SV ** const padentry = &(PAD_SVl(op->op_targ));
404 PUTBACK; /* no pop/push after this, TOPs ok */
406 if (op->op_flags & OPf_MOD) {
407 if (op->op_private & OPpLVAL_INTRO)
408 if (!(op->op_private & OPpPAD_STATE))
409 save_clearsv(padentry);
410 if (op->op_private & OPpDEREF) {
411 /* TOPs is equivalent to TARG here. Using TOPs (SP) rather
412 than TARG reduces the scope of TARG, so it does not
413 span the call to save_clearsv, resulting in smaller
415 TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF);
428 tryAMAGICunTARGETlist(iter_amg, 0);
429 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
431 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
432 if (!isGV_with_GP(PL_last_in_gv)) {
433 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
434 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
437 XPUSHs(MUTABLE_SV(PL_last_in_gv));
440 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
443 return do_readline();
451 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
455 (SvIOK_notUV(left) && SvIOK_notUV(right))
456 ? (SvIVX(left) == SvIVX(right))
457 : ( do_ncmp(left, right) == 0)
466 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
467 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
468 Perl_croak_no_modify();
469 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
470 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
472 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
473 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
475 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
476 if (inc) sv_inc(TOPs);
489 if (PL_op->op_type == OP_OR)
491 RETURNOP(cLOGOP->op_other);
500 const int op_type = PL_op->op_type;
501 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
506 if (!sv || !SvANY(sv)) {
507 if (op_type == OP_DOR)
509 RETURNOP(cLOGOP->op_other);
515 if (!sv || !SvANY(sv))
520 switch (SvTYPE(sv)) {
522 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
526 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
530 if (CvROOT(sv) || CvXSUB(sv))
543 if(op_type == OP_DOR)
545 RETURNOP(cLOGOP->op_other);
547 /* assuming OP_DEFINED */
555 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
556 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
560 useleft = USE_LEFT(svl);
561 #ifdef PERL_PRESERVE_IVUV
562 /* We must see if we can perform the addition with integers if possible,
563 as the integer code detects overflow while the NV code doesn't.
564 If either argument hasn't had a numeric conversion yet attempt to get
565 the IV. It's important to do this now, rather than just assuming that
566 it's not IOK as a PV of "9223372036854775806" may not take well to NV
567 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
568 integer in case the second argument is IV=9223372036854775806
569 We can (now) rely on sv_2iv to do the right thing, only setting the
570 public IOK flag if the value in the NV (or PV) slot is truly integer.
572 A side effect is that this also aggressively prefers integer maths over
573 fp maths for integer values.
575 How to detect overflow?
577 C 99 section 6.2.6.1 says
579 The range of nonnegative values of a signed integer type is a subrange
580 of the corresponding unsigned integer type, and the representation of
581 the same value in each type is the same. A computation involving
582 unsigned operands can never overflow, because a result that cannot be
583 represented by the resulting unsigned integer type is reduced modulo
584 the number that is one greater than the largest value that can be
585 represented by the resulting type.
589 which I read as "unsigned ints wrap."
591 signed integer overflow seems to be classed as "exception condition"
593 If an exceptional condition occurs during the evaluation of an
594 expression (that is, if the result is not mathematically defined or not
595 in the range of representable values for its type), the behavior is
598 (6.5, the 5th paragraph)
600 I had assumed that on 2s complement machines signed arithmetic would
601 wrap, hence coded pp_add and pp_subtract on the assumption that
602 everything perl builds on would be happy. After much wailing and
603 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
604 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
605 unsigned code below is actually shorter than the old code. :-)
608 if (SvIV_please_nomg(svr)) {
609 /* Unless the left argument is integer in range we are going to have to
610 use NV maths. Hence only attempt to coerce the right argument if
611 we know the left is integer. */
619 /* left operand is undef, treat as zero. + 0 is identity,
620 Could SETi or SETu right now, but space optimise by not adding
621 lots of code to speed up what is probably a rarish case. */
623 /* Left operand is defined, so is it IV? */
624 if (SvIV_please_nomg(svl)) {
625 if ((auvok = SvUOK(svl)))
628 const IV aiv = SvIVX(svl);
631 auvok = 1; /* Now acting as a sign flag. */
632 } else { /* 2s complement assumption for IV_MIN */
640 bool result_good = 0;
643 bool buvok = SvUOK(svr);
648 const IV biv = SvIVX(svr);
655 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
656 else "IV" now, independent of how it came in.
657 if a, b represents positive, A, B negative, a maps to -A etc
662 all UV maths. negate result if A negative.
663 add if signs same, subtract if signs differ. */
669 /* Must get smaller */
675 /* result really should be -(auv-buv). as its negation
676 of true value, need to swap our result flag */
693 if (result <= (UV)IV_MIN)
696 /* result valid, but out of range for IV. */
701 } /* Overflow, drop through to NVs. */
706 NV value = SvNV_nomg(svr);
709 /* left operand is undef, treat as zero. + 0.0 is identity. */
713 SETn( value + SvNV_nomg(svl) );
721 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
722 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
723 const U32 lval = PL_op->op_flags & OPf_MOD;
724 SV** const svp = av_fetch(av, PL_op->op_private, lval);
725 SV *sv = (svp ? *svp : &PL_sv_undef);
727 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
735 dVAR; dSP; dMARK; dTARGET;
737 do_join(TARG, *MARK, MARK, SP);
748 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
749 * will be enough to hold an OP*.
751 SV* const sv = sv_newmortal();
752 sv_upgrade(sv, SVt_PVLV);
754 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
757 XPUSHs(MUTABLE_SV(PL_op));
762 /* Oversized hot code. */
766 dVAR; dSP; dMARK; dORIGMARK;
770 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
774 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
777 if (MARK == ORIGMARK) {
778 /* If using default handle then we need to make space to
779 * pass object as 1st arg, so move other args up ...
783 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
786 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
788 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
789 | (PL_op->op_type == OP_SAY
790 ? TIED_METHOD_SAY : 0)), sp - mark);
793 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
794 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
797 SETERRNO(EBADF,RMS_IFI);
800 else if (!(fp = IoOFP(io))) {
802 report_wrongway_fh(gv, '<');
805 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
809 SV * const ofs = GvSV(PL_ofsgv); /* $, */
811 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
813 if (!do_print(*MARK, fp))
817 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
818 if (!do_print(GvSV(PL_ofsgv), fp)) {
827 if (!do_print(*MARK, fp))
835 if (PL_op->op_type == OP_SAY) {
836 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
839 else if (PL_ors_sv && SvOK(PL_ors_sv))
840 if (!do_print(PL_ors_sv, fp)) /* $\ */
843 if (IoFLAGS(io) & IOf_FLUSH)
844 if (PerlIO_flush(fp) == EOF)
854 XPUSHs(&PL_sv_undef);
861 const I32 gimme = GIMME_V;
862 static const char an_array[] = "an ARRAY";
863 static const char a_hash[] = "a HASH";
864 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
865 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
870 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
873 if (SvTYPE(sv) != type)
874 /* diag_listed_as: Not an ARRAY reference */
875 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
876 else if (PL_op->op_flags & OPf_MOD
877 && PL_op->op_private & OPpLVAL_INTRO)
878 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
880 else if (SvTYPE(sv) != type) {
883 if (!isGV_with_GP(sv)) {
884 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
892 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
893 if (PL_op->op_private & OPpLVAL_INTRO)
894 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
896 if (PL_op->op_flags & OPf_REF) {
900 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
901 const I32 flags = is_lvalue_sub();
902 if (flags && !(flags & OPpENTERSUB_INARGS)) {
903 if (gimme != G_ARRAY)
904 goto croak_cant_return;
911 AV *const av = MUTABLE_AV(sv);
912 /* The guts of pp_rv2av, with no intending change to preserve history
913 (until such time as we get tools that can do blame annotation across
914 whitespace changes. */
915 if (gimme == G_ARRAY) {
921 else if (gimme == G_SCALAR) {
923 const I32 maxarg = AvFILL(av) + 1;
927 /* The guts of pp_rv2hv */
928 if (gimme == G_ARRAY) { /* array wanted */
930 return Perl_do_kv(aTHX);
932 else if ((PL_op->op_private & OPpTRUEBOOL
933 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
934 && block_gimme() == G_VOID ))
935 && (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
936 SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
937 else if (gimme == G_SCALAR) {
939 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
947 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
948 is_pp_rv2av ? "array" : "hash");
953 S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
957 PERL_ARGS_ASSERT_DO_ODDBALL;
960 if (ckWARN(WARN_MISC)) {
962 if (oddkey == firstkey &&
964 (SvTYPE(SvRV(*oddkey)) == SVt_PVAV ||
965 SvTYPE(SvRV(*oddkey)) == SVt_PVHV))
967 err = "Reference found where even-sized list expected";
970 err = "Odd number of elements in hash assignment";
971 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
980 SV **lastlelem = PL_stack_sp;
981 SV **lastrelem = PL_stack_base + POPMARK;
982 SV **firstrelem = PL_stack_base + POPMARK + 1;
983 SV **firstlelem = lastrelem + 1;
997 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
999 if (gimme == G_ARRAY)
1000 lval = PL_op->op_flags & OPf_MOD || LVRET;
1002 /* If there's a common identifier on both sides we have to take
1003 * special care that assigning the identifier on the left doesn't
1004 * clobber a value on the right that's used later in the list.
1005 * Don't bother if LHS is just an empty hash or array.
1008 if ( (PL_op->op_private & OPpASSIGN_COMMON)
1010 firstlelem != lastlelem
1011 || ! ((sv = *firstlelem))
1013 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
1014 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
1015 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
1018 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1019 for (relem = firstrelem; relem <= lastrelem; relem++) {
1020 if ((sv = *relem)) {
1021 TAINT_NOT; /* Each item is independent */
1023 /* Dear TODO test in t/op/sort.t, I love you.
1024 (It's relying on a panic, not a "semi-panic" from newSVsv()
1025 and then an assertion failure below.) */
1026 if (SvIS_FREED(sv)) {
1027 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
1030 /* Not newSVsv(), as it does not allow copy-on-write,
1031 resulting in wasteful copies. We need a second copy of
1032 a temp here, hence the SV_NOSTEAL. */
1033 *relem = sv_mortalcopy_flags(sv,SV_GMAGIC|SV_DO_COW_SVSETSV
1044 while (lelem <= lastlelem) {
1045 TAINT_NOT; /* Each item stands on its own, taintwise. */
1047 switch (SvTYPE(sv)) {
1049 ary = MUTABLE_AV(sv);
1050 magic = SvMAGICAL(ary) != 0;
1052 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1054 av_extend(ary, lastrelem - relem);
1056 while (relem <= lastrelem) { /* gobble up all the rest */
1059 SvGETMAGIC(*relem); /* before newSV, in case it dies */
1061 sv_setsv_nomg(sv, *relem);
1063 didstore = av_store(ary,i++,sv);
1072 if (PL_delaymagic & DM_ARRAY_ISA)
1073 SvSETMAGIC(MUTABLE_SV(ary));
1076 case SVt_PVHV: { /* normal hash */
1080 SV** topelem = relem;
1081 SV **firsthashrelem = relem;
1083 hash = MUTABLE_HV(sv);
1084 magic = SvMAGICAL(hash) != 0;
1086 odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
1088 do_oddball(lastrelem, firsthashrelem);
1089 /* we have firstlelem to reuse, it's not needed anymore
1091 *(lastrelem+1) = &PL_sv_undef;
1095 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1097 while (relem < lastrelem+odd) { /* gobble up all the rest */
1100 /* Copy the key if aassign is called in lvalue context,
1101 to avoid having the next op modify our rhs. Copy
1102 it also if it is gmagical, lest it make the
1103 hv_store_ent call below croak, leaking the value. */
1104 sv = lval || SvGMAGICAL(*relem)
1105 ? sv_mortalcopy(*relem)
1111 sv_setsv_nomg(tmpstr,*relem++); /* value */
1112 if (gimme == G_ARRAY) {
1113 if (hv_exists_ent(hash, sv, 0))
1114 /* key overwrites an existing entry */
1117 /* copy element back: possibly to an earlier
1118 * stack location if we encountered dups earlier,
1119 * possibly to a later stack location if odd */
1121 *topelem++ = tmpstr;
1124 didstore = hv_store_ent(hash,sv,tmpstr,0);
1126 if (!didstore) sv_2mortal(tmpstr);
1132 if (duplicates && gimme == G_ARRAY) {
1133 /* at this point we have removed the duplicate key/value
1134 * pairs from the stack, but the remaining values may be
1135 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1136 * the (a 2), but the stack now probably contains
1137 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1138 * obliterates the earlier key. So refresh all values. */
1139 lastrelem -= duplicates;
1140 relem = firsthashrelem;
1141 while (relem < lastrelem+odd) {
1143 he = hv_fetch_ent(hash, *relem++, 0, 0);
1144 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1147 if (odd && gimme == G_ARRAY) lastrelem++;
1151 if (SvIMMORTAL(sv)) {
1152 if (relem <= lastrelem)
1156 if (relem <= lastrelem) {
1158 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1159 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1162 packWARN(WARN_MISC),
1163 "Useless assignment to a temporary"
1165 sv_setsv(sv, *relem);
1169 sv_setsv(sv, &PL_sv_undef);
1174 if (PL_delaymagic & ~DM_DELAY) {
1175 /* Will be used to set PL_tainting below */
1176 UV tmp_uid = PerlProc_getuid();
1177 UV tmp_euid = PerlProc_geteuid();
1178 UV tmp_gid = PerlProc_getgid();
1179 UV tmp_egid = PerlProc_getegid();
1181 if (PL_delaymagic & DM_UID) {
1182 #ifdef HAS_SETRESUID
1183 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1184 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1187 # ifdef HAS_SETREUID
1188 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1189 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1192 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1193 (void)setruid(PL_delaymagic_uid);
1194 PL_delaymagic &= ~DM_RUID;
1196 # endif /* HAS_SETRUID */
1198 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1199 (void)seteuid(PL_delaymagic_euid);
1200 PL_delaymagic &= ~DM_EUID;
1202 # endif /* HAS_SETEUID */
1203 if (PL_delaymagic & DM_UID) {
1204 if (PL_delaymagic_uid != PL_delaymagic_euid)
1205 DIE(aTHX_ "No setreuid available");
1206 (void)PerlProc_setuid(PL_delaymagic_uid);
1208 # endif /* HAS_SETREUID */
1209 #endif /* HAS_SETRESUID */
1210 tmp_uid = PerlProc_getuid();
1211 tmp_euid = PerlProc_geteuid();
1213 if (PL_delaymagic & DM_GID) {
1214 #ifdef HAS_SETRESGID
1215 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1216 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1219 # ifdef HAS_SETREGID
1220 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1221 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1224 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1225 (void)setrgid(PL_delaymagic_gid);
1226 PL_delaymagic &= ~DM_RGID;
1228 # endif /* HAS_SETRGID */
1230 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1231 (void)setegid(PL_delaymagic_egid);
1232 PL_delaymagic &= ~DM_EGID;
1234 # endif /* HAS_SETEGID */
1235 if (PL_delaymagic & DM_GID) {
1236 if (PL_delaymagic_gid != PL_delaymagic_egid)
1237 DIE(aTHX_ "No setregid available");
1238 (void)PerlProc_setgid(PL_delaymagic_gid);
1240 # endif /* HAS_SETREGID */
1241 #endif /* HAS_SETRESGID */
1242 tmp_gid = PerlProc_getgid();
1243 tmp_egid = PerlProc_getegid();
1245 TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) );
1246 #ifdef NO_TAINT_SUPPORT
1247 PERL_UNUSED_VAR(tmp_uid);
1248 PERL_UNUSED_VAR(tmp_euid);
1249 PERL_UNUSED_VAR(tmp_gid);
1250 PERL_UNUSED_VAR(tmp_egid);
1255 if (gimme == G_VOID)
1256 SP = firstrelem - 1;
1257 else if (gimme == G_SCALAR) {
1260 SETi(lastrelem - firstrelem + 1);
1264 /* note that in this case *firstlelem may have been overwritten
1265 by sv_undef in the odd hash case */
1268 SP = firstrelem + (lastlelem - firstlelem);
1269 lelem = firstlelem + (relem - firstrelem);
1271 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1281 PMOP * const pm = cPMOP;
1282 REGEXP * rx = PM_GETRE(pm);
1283 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1284 SV * const rv = sv_newmortal();
1288 SvUPGRADE(rv, SVt_IV);
1289 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1290 loathe to use it here, but it seems to be the right fix. Or close.
1291 The key part appears to be that it's essential for pp_qr to return a new
1292 object (SV), which implies that there needs to be an effective way to
1293 generate a new SV from the existing SV that is pre-compiled in the
1295 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1298 cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
1299 if ((cv = *cvp) && CvCLONE(*cvp)) {
1300 *cvp = cv_clone(cv);
1301 SvREFCNT_dec_NN(cv);
1305 HV *const stash = gv_stashsv(pkg, GV_ADD);
1306 SvREFCNT_dec_NN(pkg);
1307 (void)sv_bless(rv, stash);
1310 if (RX_ISTAINTED(rx)) {
1312 SvTAINTED_on(SvRV(rv));
1327 U8 r_flags = REXEC_CHECKED;
1328 const char *truebase; /* Start of string */
1329 REGEXP *rx = PM_GETRE(pm);
1331 const I32 gimme = GIMME;
1334 const I32 oldsave = PL_savestack_ix;
1335 I32 update_minmatch = 1;
1336 I32 had_zerolen = 0;
1339 if (PL_op->op_flags & OPf_STACKED)
1341 else if (PL_op->op_private & OPpTARGET_MY)
1348 PUTBACK; /* EVAL blocks need stack_sp. */
1349 /* Skip get-magic if this is a qr// clone, because regcomp has
1351 s = ReANY(rx)->mother_re
1352 ? SvPV_nomg_const(TARG, len)
1353 : SvPV_const(TARG, len);
1355 DIE(aTHX_ "panic: pp_match");
1357 rxtainted = (RX_ISTAINTED(rx) ||
1358 (TAINT_get && (pm->op_pmflags & PMf_RETAINT)));
1361 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1363 /* We need to know this in case we fail out early - pos() must be reset */
1364 global = dynpm->op_pmflags & PMf_GLOBAL;
1366 /* PMdf_USED is set after a ?? matches once */
1369 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1371 pm->op_pmflags & PMf_USED
1374 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1378 /* empty pattern special-cased to use last successful pattern if
1379 possible, except for qr// */
1380 if (!ReANY(rx)->mother_re && !RX_PRELEN(rx)
1386 if (RX_MINLEN(rx) > (I32)len) {
1387 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
1393 /* XXXX What part of this is needed with true \G-support? */
1395 RX_OFFS(rx)[0].start = -1;
1396 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1397 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398 if (mg && mg->mg_len >= 0) {
1399 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1400 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1401 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1402 r_flags |= REXEC_IGNOREPOS;
1403 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1404 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1407 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1408 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1409 update_minmatch = 0;
1413 #ifdef PERL_SAWAMPERSAND
1416 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
1420 r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE);
1421 /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer
1422 * only on the first iteration. Therefore we need to copy $' as well
1423 * as $&, to make the rest of the string available for captures in
1424 * subsequent iterations */
1425 if (! (global && gimme == G_ARRAY))
1426 r_flags |= REXEC_COPY_SKIP_POST;
1430 if (global && RX_OFFS(rx)[0].start != -1) {
1431 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1432 if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1433 DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
1436 if (update_minmatch++)
1437 minmatch = had_zerolen;
1439 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1440 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1441 /* FIXME - can PL_bostr be made const char *? */
1442 PL_bostr = (char *)truebase;
1443 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1447 #ifdef PERL_SAWAMPERSAND
1448 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1450 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1451 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1455 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1456 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1460 if (dynpm->op_pmflags & PMf_ONCE) {
1462 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1464 dynpm->op_pmflags |= PMf_USED;
1470 RX_MATCH_TAINTED_on(rx);
1471 TAINT_IF(RX_MATCH_TAINTED(rx));
1472 if (gimme == G_ARRAY) {
1473 const I32 nparens = RX_NPARENS(rx);
1474 I32 i = (global && !nparens) ? 1 : 0;
1476 SPAGAIN; /* EVAL blocks could move the stack. */
1477 EXTEND(SP, nparens + i);
1478 EXTEND_MORTAL(nparens + i);
1479 for (i = !i; i <= nparens; i++) {
1480 PUSHs(sv_newmortal());
1481 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1482 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1483 s = RX_OFFS(rx)[i].start + truebase;
1484 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1485 len < 0 || len > strend - s)
1486 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1487 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1488 (long) i, (long) RX_OFFS(rx)[i].start,
1489 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1490 sv_setpvn(*SP, s, len);
1491 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1496 if (dynpm->op_pmflags & PMf_CONTINUE) {
1498 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1499 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1501 #ifdef PERL_OLD_COPY_ON_WRITE
1503 sv_force_normal_flags(TARG, 0);
1505 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1506 &PL_vtbl_mglob, NULL, 0);
1508 if (RX_OFFS(rx)[0].start != -1) {
1509 mg->mg_len = RX_OFFS(rx)[0].end;
1510 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1511 mg->mg_flags |= MGf_MINMATCH;
1513 mg->mg_flags &= ~MGf_MINMATCH;
1516 had_zerolen = (RX_OFFS(rx)[0].start != -1
1517 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1518 == (UV)RX_OFFS(rx)[0].end));
1519 PUTBACK; /* EVAL blocks may use stack */
1520 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1525 LEAVE_SCOPE(oldsave);
1531 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1532 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1536 #ifdef PERL_OLD_COPY_ON_WRITE
1538 sv_force_normal_flags(TARG, 0);
1540 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1541 &PL_vtbl_mglob, NULL, 0);
1543 if (RX_OFFS(rx)[0].start != -1) {
1544 mg->mg_len = RX_OFFS(rx)[0].end;
1545 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1546 mg->mg_flags |= MGf_MINMATCH;
1548 mg->mg_flags &= ~MGf_MINMATCH;
1551 LEAVE_SCOPE(oldsave);
1555 #ifdef PERL_SAWAMPERSAND
1556 yup: /* Confirmed by INTUIT */
1559 RX_MATCH_TAINTED_on(rx);
1560 TAINT_IF(RX_MATCH_TAINTED(rx));
1562 if (dynpm->op_pmflags & PMf_ONCE) {
1564 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1566 dynpm->op_pmflags |= PMf_USED;
1569 if (RX_MATCH_COPIED(rx))
1570 Safefree(RX_SUBBEG(rx));
1571 RX_MATCH_COPIED_off(rx);
1572 RX_SUBBEG(rx) = NULL;
1574 /* FIXME - should rx->subbeg be const char *? */
1575 RX_SUBBEG(rx) = (char *) truebase;
1576 RX_SUBOFFSET(rx) = 0;
1577 RX_SUBCOFFSET(rx) = 0;
1578 RX_OFFS(rx)[0].start = s - truebase;
1579 if (RX_MATCH_UTF8(rx)) {
1580 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1581 RX_OFFS(rx)[0].end = t - truebase;
1584 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1586 RX_SUBLEN(rx) = strend - truebase;
1589 #ifdef PERL_SAWAMPERSAND
1590 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1595 if (SvCANCOW(TARG)) {
1597 PerlIO_printf(Perl_debug_log,
1598 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1599 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1602 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1604 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1605 assert (SvPOKp(RX_SAVED_COPY(rx)));
1610 RX_SUBBEG(rx) = savepvn(t, strend - t);
1612 RX_SAVED_COPY(rx) = NULL;
1615 RX_SUBLEN(rx) = strend - t;
1616 RX_SUBOFFSET(rx) = 0;
1617 RX_SUBCOFFSET(rx) = 0;
1618 RX_MATCH_COPIED_on(rx);
1619 off = RX_OFFS(rx)[0].start = s - t;
1620 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1622 #ifdef PERL_SAWAMPERSAND
1623 else { /* startp/endp are used by @- @+. */
1624 RX_OFFS(rx)[0].start = s - truebase;
1625 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1628 /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1629 assert(!RX_NPARENS(rx));
1630 RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
1631 LEAVE_SCOPE(oldsave);
1636 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1637 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1638 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1643 LEAVE_SCOPE(oldsave);
1644 if (gimme == G_ARRAY)
1650 Perl_do_readline(pTHX)
1652 dVAR; dSP; dTARGETSTACKED;
1657 IO * const io = GvIO(PL_last_in_gv);
1658 const I32 type = PL_op->op_type;
1659 const I32 gimme = GIMME_V;
1662 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1664 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1665 if (gimme == G_SCALAR) {
1667 SvSetSV_nosteal(TARG, TOPs);
1677 if (IoFLAGS(io) & IOf_ARGV) {
1678 if (IoFLAGS(io) & IOf_START) {
1680 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1681 IoFLAGS(io) &= ~IOf_START;
1682 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1683 SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
1684 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1685 SvSETMAGIC(GvSV(PL_last_in_gv));
1690 fp = nextargv(PL_last_in_gv);
1691 if (!fp) { /* Note: fp != IoIFP(io) */
1692 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1695 else if (type == OP_GLOB)
1696 fp = Perl_start_glob(aTHX_ POPs, io);
1698 else if (type == OP_GLOB)
1700 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1701 report_wrongway_fh(PL_last_in_gv, '>');
1705 if ((!io || !(IoFLAGS(io) & IOf_START))
1706 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1708 if (type == OP_GLOB)
1709 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1710 "glob failed (can't start child: %s)",
1713 report_evil_fh(PL_last_in_gv);
1715 if (gimme == G_SCALAR) {
1716 /* undef TARG, and push that undefined value */
1717 if (type != OP_RCATLINE) {
1718 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1726 if (gimme == G_SCALAR) {
1728 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1731 if (type == OP_RCATLINE)
1732 SvPV_force_nomg_nolen(sv);
1736 else if (isGV_with_GP(sv)) {
1737 SvPV_force_nomg_nolen(sv);
1739 SvUPGRADE(sv, SVt_PV);
1740 tmplen = SvLEN(sv); /* remember if already alloced */
1741 if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) {
1742 /* try short-buffering it. Please update t/op/readline.t
1743 * if you change the growth length.
1748 if (type == OP_RCATLINE && SvOK(sv)) {
1750 SvPV_force_nomg_nolen(sv);
1756 sv = sv_2mortal(newSV(80));
1760 /* This should not be marked tainted if the fp is marked clean */
1761 #define MAYBE_TAINT_LINE(io, sv) \
1762 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1767 /* delay EOF state for a snarfed empty file */
1768 #define SNARF_EOF(gimme,rs,io,sv) \
1769 (gimme != G_SCALAR || SvCUR(sv) \
1770 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1774 if (!sv_gets(sv, fp, offset)
1776 || SNARF_EOF(gimme, PL_rs, io, sv)
1777 || PerlIO_error(fp)))
1779 PerlIO_clearerr(fp);
1780 if (IoFLAGS(io) & IOf_ARGV) {
1781 fp = nextargv(PL_last_in_gv);
1784 (void)do_close(PL_last_in_gv, FALSE);
1786 else if (type == OP_GLOB) {
1787 if (!do_close(PL_last_in_gv, FALSE)) {
1788 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1789 "glob failed (child exited with status %d%s)",
1790 (int)(STATUS_CURRENT >> 8),
1791 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1794 if (gimme == G_SCALAR) {
1795 if (type != OP_RCATLINE) {
1796 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1802 MAYBE_TAINT_LINE(io, sv);
1805 MAYBE_TAINT_LINE(io, sv);
1807 IoFLAGS(io) |= IOf_NOLINE;
1811 if (type == OP_GLOB) {
1814 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1815 char * const tmps = SvEND(sv) - 1;
1816 if (*tmps == *SvPVX_const(PL_rs)) {
1818 SvCUR_set(sv, SvCUR(sv) - 1);
1821 for (t1 = SvPVX_const(sv); *t1; t1++)
1822 if (!isALPHANUMERIC(*t1) &&
1823 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1825 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1826 (void)POPs; /* Unmatched wildcard? Chuck it... */
1829 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1830 if (ckWARN(WARN_UTF8)) {
1831 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1832 const STRLEN len = SvCUR(sv) - offset;
1835 if (!is_utf8_string_loc(s, len, &f))
1836 /* Emulate :encoding(utf8) warning in the same case. */
1837 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1838 "utf8 \"\\x%02X\" does not map to Unicode",
1839 f < (U8*)SvEND(sv) ? *f : 0);
1842 if (gimme == G_ARRAY) {
1843 if (SvLEN(sv) - SvCUR(sv) > 20) {
1844 SvPV_shrink_to_cur(sv);
1846 sv = sv_2mortal(newSV(80));
1849 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1850 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1851 const STRLEN new_len
1852 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1853 SvPV_renew(sv, new_len);
1864 SV * const keysv = POPs;
1865 HV * const hv = MUTABLE_HV(POPs);
1866 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1867 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1869 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1870 bool preeminent = TRUE;
1872 if (SvTYPE(hv) != SVt_PVHV)
1879 /* If we can determine whether the element exist,
1880 * Try to preserve the existenceness of a tied hash
1881 * element by using EXISTS and DELETE if possible.
1882 * Fallback to FETCH and STORE otherwise. */
1883 if (SvCANEXISTDELETE(hv))
1884 preeminent = hv_exists_ent(hv, keysv, 0);
1887 he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1888 svp = he ? &HeVAL(he) : NULL;
1890 if (!svp || !*svp || *svp == &PL_sv_undef) {
1894 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1896 lv = sv_newmortal();
1897 sv_upgrade(lv, SVt_PVLV);
1899 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1900 SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */
1901 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1907 if (HvNAME_get(hv) && isGV(*svp))
1908 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1909 else if (preeminent)
1910 save_helem_flags(hv, keysv, svp,
1911 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1913 SAVEHDELETE(hv, keysv);
1915 else if (PL_op->op_private & OPpDEREF) {
1916 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1920 sv = (svp && *svp ? *svp : &PL_sv_undef);
1921 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1922 * was to make C<local $tied{foo} = $tied{foo}> possible.
1923 * However, it seems no longer to be needed for that purpose, and
1924 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1925 * would loop endlessly since the pos magic is getting set on the
1926 * mortal copy and lost. However, the copy has the effect of
1927 * triggering the get magic, and losing it altogether made things like
1928 * c<$tied{foo};> in void context no longer do get magic, which some
1929 * code relied on. Also, delayed triggering of magic on @+ and friends
1930 * meant the original regex may be out of scope by now. So as a
1931 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1932 * being called too many times). */
1933 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1947 cx = &cxstack[cxstack_ix];
1948 itersvp = CxITERVAR(cx);
1950 switch (CxTYPE(cx)) {
1952 case CXt_LOOP_LAZYSV: /* string increment */
1954 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1955 SV *end = cx->blk_loop.state_u.lazysv.end;
1956 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1957 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1959 const char *max = SvPV_const(end, maxlen);
1960 if (SvNIOK(cur) || SvCUR(cur) > maxlen)
1964 if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1965 /* safe to reuse old SV */
1966 sv_setsv(oldsv, cur);
1970 /* we need a fresh SV every time so that loop body sees a
1971 * completely new SV for closures/references to work as
1973 *itersvp = newSVsv(cur);
1974 SvREFCNT_dec_NN(oldsv);
1976 if (strEQ(SvPVX_const(cur), max))
1977 sv_setiv(cur, 0); /* terminate next time */
1983 case CXt_LOOP_LAZYIV: /* integer increment */
1985 IV cur = cx->blk_loop.state_u.lazyiv.cur;
1986 if (cur > cx->blk_loop.state_u.lazyiv.end)
1990 /* don't risk potential race */
1991 if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
1992 /* safe to reuse old SV */
1993 sv_setiv(oldsv, cur);
1997 /* we need a fresh SV every time so that loop body sees a
1998 * completely new SV for closures/references to work as they
2000 *itersvp = newSViv(cur);
2001 SvREFCNT_dec_NN(oldsv);
2004 if (cur == IV_MAX) {
2005 /* Handle end of range at IV_MAX */
2006 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
2008 ++cx->blk_loop.state_u.lazyiv.cur;
2012 case CXt_LOOP_FOR: /* iterate array */
2015 AV *av = cx->blk_loop.state_u.ary.ary;
2017 bool av_is_stack = FALSE;
2024 if (PL_op->op_private & OPpITER_REVERSED) {
2025 ix = --cx->blk_loop.state_u.ary.ix;
2026 if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
2030 ix = ++cx->blk_loop.state_u.ary.ix;
2031 if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
2035 if (SvMAGICAL(av) || AvREIFY(av)) {
2036 SV * const * const svp = av_fetch(av, ix, FALSE);
2037 sv = svp ? *svp : NULL;
2040 sv = AvARRAY(av)[ix];
2044 if (SvIS_FREED(sv)) {
2046 Perl_croak(aTHX_ "Use of freed value in iteration");
2049 SvREFCNT_inc_simple_void_NN(sv);
2054 if (!av_is_stack && sv == &PL_sv_undef) {
2055 SV *lv = newSV_type(SVt_PVLV);
2057 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2058 LvTARG(lv) = SvREFCNT_inc_simple(av);
2060 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2066 SvREFCNT_dec(oldsv);
2071 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
2077 A description of how taint works in pattern matching and substitution.
2079 This is all conditional on NO_TAINT_SUPPORT not being defined. Under
2080 NO_TAINT_SUPPORT, taint-related operations should become no-ops.
2082 While the pattern is being assembled/concatenated and then compiled,
2083 PL_tainted will get set (via TAINT_set) if any component of the pattern
2084 is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
2085 the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
2088 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
2089 the pattern is marked as tainted. This means that subsequent usage, such
2090 as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
2091 on the new pattern too.
2093 At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
2094 regex is cleared; during execution, locale-variant ops such as POSIXL may
2095 set RXf_TAINTED_SEEN.
2097 RXf_TAINTED_SEEN is used post-execution by the get magic code
2098 of $1 et al to indicate whether the returned value should be tainted.
2099 It is the responsibility of the caller of the pattern (i.e. pp_match,
2100 pp_subst etc) to set this flag for any other circumstances where $1 needs
2103 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2105 There are three possible sources of taint
2107 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2108 * the replacement string (or expression under /e)
2110 There are four destinations of taint and they are affected by the sources
2111 according to the rules below:
2113 * the return value (not including /r):
2114 tainted by the source string and pattern, but only for the
2115 number-of-iterations case; boolean returns aren't tainted;
2116 * the modified string (or modified copy under /r):
2117 tainted by the source string, pattern, and replacement strings;
2119 tainted by the pattern, and under 'use re "taint"', by the source
2121 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2122 should always be unset before executing subsequent code.
2124 The overall action of pp_subst is:
2126 * at the start, set bits in rxtainted indicating the taint status of
2127 the various sources.
2129 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2130 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2131 pattern has subsequently become tainted via locale ops.
2133 * If control is being passed to pp_substcont to execute a /e block,
2134 save rxtainted in the CXt_SUBST block, for future use by
2137 * Whenever control is being returned to perl code (either by falling
2138 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2139 use the flag bits in rxtainted to make all the appropriate types of
2140 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2141 et al will appear tainted.
2143 pp_match is just a simpler version of the above.
2162 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2163 See "how taint works" above */
2166 REGEXP *rx = PM_GETRE(pm);
2168 int force_on_match = 0;
2169 const I32 oldsave = PL_savestack_ix;
2171 bool doutf8 = FALSE; /* whether replacement is in utf8 */
2176 /* known replacement string? */
2177 SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2181 if (PL_op->op_flags & OPf_STACKED)
2183 else if (PL_op->op_private & OPpTARGET_MY)
2190 SvGETMAGIC(TARG); /* must come before cow check */
2192 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2193 because they make integers such as 256 "false". */
2194 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2197 sv_force_normal_flags(TARG,0);
2199 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2203 && (SvREADONLY(TARG)
2204 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2205 || SvTYPE(TARG) > SVt_PVLV)
2206 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2207 Perl_croak_no_modify();
2210 s = SvPV_nomg(TARG, len);
2211 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
2214 /* only replace once? */
2215 once = !(rpm->op_pmflags & PMf_GLOBAL);
2217 /* See "how taint works" above */
2220 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2221 | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0)
2222 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2223 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2224 ? SUBST_TAINT_BOOLRET : 0));
2228 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2232 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2235 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2236 maxiters = 2 * slen + 10; /* We can match twice at each
2237 position, once with zero-length,
2238 second time with non-zero. */
2240 if (!RX_PRELEN(rx) && PL_curpm
2241 && !ReANY(rx)->mother_re) {
2246 #ifdef PERL_SAWAMPERSAND
2247 r_flags = ( RX_NPARENS(rx)
2249 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY))
2254 r_flags = REXEC_COPY_STR;
2258 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2260 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2264 /* How to do it in subst? */
2265 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2267 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2272 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2273 r_flags | REXEC_CHECKED))
2277 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2278 LEAVE_SCOPE(oldsave);
2284 /* known replacement string? */
2286 /* replacement needing upgrading? */
2287 if (DO_UTF8(TARG) && !doutf8) {
2288 nsv = sv_newmortal();
2291 sv_recode_to_utf8(nsv, PL_encoding);
2293 sv_utf8_upgrade(nsv);
2294 c = SvPV_const(nsv, clen);
2298 c = SvPV_const(dstr, clen);
2299 doutf8 = DO_UTF8(dstr);
2302 if (SvTAINTED(dstr))
2303 rxtainted |= SUBST_TAINT_REPL;
2310 /* can do inplace substitution? */
2315 && (I32)clen <= RX_MINLENRET(rx)
2316 && (once || !(r_flags & REXEC_COPY_STR))
2317 && !(RX_EXTFLAGS(rx) & RXf_NO_INPLACE_SUBST)
2318 && (!doutf8 || SvUTF8(TARG))
2319 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2323 if (SvIsCOW(TARG)) {
2324 if (!force_on_match)
2326 assert(SvVOK(TARG));
2329 if (force_on_match) {
2331 s = SvPV_force_nomg(TARG, len);
2336 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2337 rxtainted |= SUBST_TAINT_PAT;
2338 m = orig + RX_OFFS(rx)[0].start;
2339 d = orig + RX_OFFS(rx)[0].end;
2341 if (m - s > strend - d) { /* faster to shorten from end */
2343 Copy(c, m, clen, char);
2348 Move(d, m, i, char);
2352 SvCUR_set(TARG, m - s);
2354 else if ((i = m - s)) { /* faster from front */
2357 Move(s, d - i, i, char);
2360 Copy(c, m, clen, char);
2365 Copy(c, d, clen, char);
2375 if (iters++ > maxiters)
2376 DIE(aTHX_ "Substitution loop");
2377 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2378 rxtainted |= SUBST_TAINT_PAT;
2379 m = RX_OFFS(rx)[0].start + orig;
2382 Move(s, d, i, char);
2386 Copy(c, d, clen, char);
2389 s = RX_OFFS(rx)[0].end + orig;
2390 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2392 /* don't match same null twice */
2393 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2396 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2397 Move(s, d, i+1, char); /* include the NUL */
2406 if (force_on_match) {
2408 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2409 /* I feel that it should be possible to avoid this mortal copy
2410 given that the code below copies into a new destination.
2411 However, I suspect it isn't worth the complexity of
2412 unravelling the C<goto force_it> for the small number of
2413 cases where it would be viable to drop into the copy code. */
2414 TARG = sv_2mortal(newSVsv(TARG));
2416 s = SvPV_force_nomg(TARG, len);
2422 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2423 rxtainted |= SUBST_TAINT_PAT;
2425 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2429 /* note that a whole bunch of local vars are saved here for
2430 * use by pp_substcont: here's a list of them in case you're
2431 * searching for places in this sub that uses a particular var:
2432 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2433 * s m strend rx once */
2435 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2437 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2440 if (iters++ > maxiters)
2441 DIE(aTHX_ "Substitution loop");
2442 if (RX_MATCH_TAINTED(rx))
2443 rxtainted |= SUBST_TAINT_PAT;
2444 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2447 assert(RX_SUBOFFSET(rx) == 0);
2448 orig = RX_SUBBEG(rx);
2450 strend = s + (strend - m);
2452 m = RX_OFFS(rx)[0].start + orig;
2453 sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG));
2454 s = RX_OFFS(rx)[0].end + orig;
2456 /* replacement already stringified */
2458 sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8);
2463 if (!nsv) nsv = sv_newmortal();
2464 sv_copypv(nsv, repl);
2465 if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
2466 sv_catsv(dstr, nsv);
2468 else sv_catsv(dstr, repl);
2469 if (SvTAINTED(repl))
2470 rxtainted |= SUBST_TAINT_REPL;
2474 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2475 TARG, NULL, r_flags));
2476 sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
2478 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2479 /* From here on down we're using the copy, and leaving the original
2486 /* The match may make the string COW. If so, brilliant, because
2487 that's just saved us one malloc, copy and free - the regexp has
2488 donated the old buffer, and we malloc an entirely new one, rather
2489 than the regexp malloc()ing a buffer and copying our original,
2490 only for us to throw it away here during the substitution. */
2491 if (SvIsCOW(TARG)) {
2492 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2498 SvPV_set(TARG, SvPVX(dstr));
2499 SvCUR_set(TARG, SvCUR(dstr));
2500 SvLEN_set(TARG, SvLEN(dstr));
2501 SvFLAGS(TARG) |= SvUTF8(dstr);
2502 SvPV_set(dstr, NULL);
2509 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2510 (void)SvPOK_only_UTF8(TARG);
2513 /* See "how taint works" above */
2515 if ((rxtainted & SUBST_TAINT_PAT) ||
2516 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2517 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2519 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2521 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2522 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2524 SvTAINTED_on(TOPs); /* taint return value */
2526 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2528 /* needed for mg_set below */
2530 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
2534 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2536 LEAVE_SCOPE(oldsave);
2545 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2546 ++*PL_markstack_ptr;
2548 LEAVE_with_name("grep_item"); /* exit inner scope */
2551 if (PL_stack_base + *PL_markstack_ptr > SP) {
2553 const I32 gimme = GIMME_V;
2555 LEAVE_with_name("grep"); /* exit outer scope */
2556 (void)POPMARK; /* pop src */
2557 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2558 (void)POPMARK; /* pop dst */
2559 SP = PL_stack_base + POPMARK; /* pop original mark */
2560 if (gimme == G_SCALAR) {
2561 if (PL_op->op_private & OPpGREP_LEX) {
2562 SV* const sv = sv_newmortal();
2563 sv_setiv(sv, items);
2571 else if (gimme == G_ARRAY)
2578 ENTER_with_name("grep_item"); /* enter inner scope */
2581 src = PL_stack_base[*PL_markstack_ptr];
2583 if (PL_op->op_private & OPpGREP_LEX)
2584 PAD_SVl(PL_op->op_targ) = src;
2588 RETURNOP(cLOGOP->op_other);
2602 if (CxMULTICALL(&cxstack[cxstack_ix]))
2606 cxstack_ix++; /* temporarily protect top context */
2609 if (gimme == G_SCALAR) {
2612 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2613 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2614 && !SvMAGICAL(TOPs)) {
2615 *MARK = SvREFCNT_inc(TOPs);
2620 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2622 *MARK = sv_mortalcopy(sv);
2623 SvREFCNT_dec_NN(sv);
2626 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2627 && !SvMAGICAL(TOPs)) {
2631 *MARK = sv_mortalcopy(TOPs);
2635 *MARK = &PL_sv_undef;
2639 else if (gimme == G_ARRAY) {
2640 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2641 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2642 || SvMAGICAL(*MARK)) {
2643 *MARK = sv_mortalcopy(*MARK);
2644 TAINT_NOT; /* Each item is independent */
2652 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2653 PL_curpm = newpm; /* ... and pop $1 et al */
2656 return cx->blk_sub.retop;
2666 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2669 DIE(aTHX_ "Not a CODE reference");
2670 switch (SvTYPE(sv)) {
2671 /* This is overwhelming the most common case: */
2674 if (!(cv = GvCVu((const GV *)sv))) {
2676 cv = sv_2cv(sv, &stash, &gv, 0);
2685 if(isGV_with_GP(sv)) goto we_have_a_glob;
2688 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2690 SP = PL_stack_base + POPMARK;
2698 sv = amagic_deref_call(sv, to_cv_amg);
2699 /* Don't SPAGAIN here. */
2706 DIE(aTHX_ PL_no_usym, "a subroutine");
2707 sym = SvPV_nomg_const(sv, len);
2708 if (PL_op->op_private & HINT_STRICT_REFS)
2709 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2710 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2713 cv = MUTABLE_CV(SvRV(sv));
2714 if (SvTYPE(cv) == SVt_PVCV)
2719 DIE(aTHX_ "Not a CODE reference");
2720 /* This is the second most common case: */
2722 cv = MUTABLE_CV(sv);
2730 if (CvCLONE(cv) && ! CvCLONED(cv))
2731 DIE(aTHX_ "Closure prototype called");
2732 if (!CvROOT(cv) && !CvXSUB(cv)) {
2736 /* anonymous or undef'd function leaves us no recourse */
2737 if (CvANON(cv) || !(gv = CvGV(cv))) {
2739 DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
2740 HEKfARG(CvNAME_HEK(cv)));
2741 DIE(aTHX_ "Undefined subroutine called");
2744 /* autoloaded stub? */
2745 if (cv != GvCV(gv)) {
2748 /* should call AUTOLOAD now? */
2751 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2752 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2758 sub_name = sv_newmortal();
2759 gv_efullname3(sub_name, gv, NULL);
2760 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2769 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2770 Perl_get_db_sub(aTHX_ &sv, cv);
2772 PL_curcopdb = PL_curcop;
2774 /* check for lsub that handles lvalue subroutines */
2775 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2776 /* if lsub not found then fall back to DB::sub */
2777 if (!cv) cv = GvCV(PL_DBsub);
2779 cv = GvCV(PL_DBsub);
2782 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2783 DIE(aTHX_ "No DB::sub routine defined");
2786 if (!(CvISXSUB(cv))) {
2787 /* This path taken at least 75% of the time */
2789 I32 items = SP - MARK;
2790 PADLIST * const padlist = CvPADLIST(cv);
2791 PUSHBLOCK(cx, CXt_SUB, MARK);
2793 cx->blk_sub.retop = PL_op->op_next;
2795 if (CvDEPTH(cv) >= 2) {
2796 PERL_STACK_OVERFLOW_CHECK();
2797 pad_push(padlist, CvDEPTH(cv));
2800 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2802 AV *const av = MUTABLE_AV(PAD_SVl(0));
2804 /* @_ is normally not REAL--this should only ever
2805 * happen when DB::sub() calls things that modify @_ */
2810 cx->blk_sub.savearray = GvAV(PL_defgv);
2811 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2812 CX_CURPAD_SAVE(cx->blk_sub);
2813 cx->blk_sub.argarray = av;
2816 if (items - 1 > AvMAX(av)) {
2817 SV **ary = AvALLOC(av);
2818 AvMAX(av) = items - 1;
2819 Renew(ary, items, SV*);
2824 Copy(MARK,AvARRAY(av),items,SV*);
2825 AvFILLp(av) = items - 1;
2833 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2835 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2836 /* warning must come *after* we fully set up the context
2837 * stuff so that __WARN__ handlers can safely dounwind()
2840 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2841 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2842 sub_crush_depth(cv);
2843 RETURNOP(CvSTART(cv));
2846 I32 markix = TOPMARK;
2851 /* Need to copy @_ to stack. Alternative may be to
2852 * switch stack to @_, and copy return values
2853 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2854 AV * const av = GvAV(PL_defgv);
2855 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2858 /* Mark is at the end of the stack. */
2860 Copy(AvARRAY(av), SP + 1, items, SV*);
2865 /* We assume first XSUB in &DB::sub is the called one. */
2867 SAVEVPTR(PL_curcop);
2868 PL_curcop = PL_curcopdb;
2871 /* Do we need to open block here? XXXX */
2873 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2875 CvXSUB(cv)(aTHX_ cv);
2877 /* Enforce some sanity in scalar context. */
2878 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2879 if (markix > PL_stack_sp - PL_stack_base)
2880 *(PL_stack_base + markix) = &PL_sv_undef;
2882 *(PL_stack_base + markix) = *PL_stack_sp;
2883 PL_stack_sp = PL_stack_base + markix;
2891 Perl_sub_crush_depth(pTHX_ CV *cv)
2893 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2896 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2898 SV* const tmpstr = sv_newmortal();
2899 gv_efullname3(tmpstr, CvGV(cv), NULL);
2900 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2909 SV* const elemsv = POPs;
2910 IV elem = SvIV(elemsv);
2911 AV *const av = MUTABLE_AV(POPs);
2912 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2913 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2914 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2915 bool preeminent = TRUE;
2918 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2919 Perl_warner(aTHX_ packWARN(WARN_MISC),
2920 "Use of reference \"%"SVf"\" as array index",
2922 if (SvTYPE(av) != SVt_PVAV)
2929 /* If we can determine whether the element exist,
2930 * Try to preserve the existenceness of a tied array
2931 * element by using EXISTS and DELETE if possible.
2932 * Fallback to FETCH and STORE otherwise. */
2933 if (SvCANEXISTDELETE(av))
2934 preeminent = av_exists(av, elem);
2937 svp = av_fetch(av, elem, lval && !defer);
2939 #ifdef PERL_MALLOC_WRAP
2940 if (SvUOK(elemsv)) {
2941 const UV uv = SvUV(elemsv);
2942 elem = uv > IV_MAX ? IV_MAX : uv;
2944 else if (SvNOK(elemsv))
2945 elem = (IV)SvNV(elemsv);
2947 static const char oom_array_extend[] =
2948 "Out of memory during array extend"; /* Duplicated in av.c */
2949 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2952 if (!svp || *svp == &PL_sv_undef) {
2955 DIE(aTHX_ PL_no_aelem, elem);
2956 lv = sv_newmortal();
2957 sv_upgrade(lv, SVt_PVLV);
2959 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2960 LvTARG(lv) = SvREFCNT_inc_simple(av);
2961 LvTARGOFF(lv) = elem;
2968 save_aelem(av, elem, svp);
2970 SAVEADELETE(av, elem);
2972 else if (PL_op->op_private & OPpDEREF) {
2973 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2977 sv = (svp ? *svp : &PL_sv_undef);
2978 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2985 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2987 PERL_ARGS_ASSERT_VIVIFY_REF;
2992 Perl_croak_no_modify();
2993 prepare_SV_for_RV(sv);
2996 SvRV_set(sv, newSV(0));
2999 SvRV_set(sv, MUTABLE_SV(newAV()));
3002 SvRV_set(sv, MUTABLE_SV(newHV()));
3009 if (SvGMAGICAL(sv)) {
3010 /* copy the sv without magic to prevent magic from being
3012 SV* msv = sv_newmortal();
3013 sv_setsv_nomg(msv, sv);
3022 SV* const sv = TOPs;
3025 SV* const rsv = SvRV(sv);
3026 if (SvTYPE(rsv) == SVt_PVCV) {
3032 SETs(method_common(sv, NULL));
3039 SV* const sv = cSVOP_sv;
3040 U32 hash = SvSHARED_HASH(sv);
3042 XPUSHs(method_common(sv, &hash));
3047 S_method_common(pTHX_ SV* meth, U32* hashp)
3054 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
3055 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
3056 "package or object reference", SVfARG(meth)),
3058 : *(PL_stack_base + TOPMARK + 1);
3060 PERL_ARGS_ASSERT_METHOD_COMMON;
3064 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3069 ob = MUTABLE_SV(SvRV(sv));
3070 else if (!SvOK(sv)) goto undefined;
3072 /* this isn't a reference */
3075 const char * const packname = SvPV_nomg_const(sv, packlen);
3076 const bool packname_is_utf8 = !!SvUTF8(sv);
3077 const HE* const he =
3078 (const HE *)hv_common(
3079 PL_stashcache, NULL, packname, packlen,
3080 packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
3084 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3085 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
3090 if (!(iogv = gv_fetchpvn_flags(
3091 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
3093 !(ob=MUTABLE_SV(GvIO(iogv))))
3095 /* this isn't the name of a filehandle either */
3098 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" "
3099 "without a package or object reference",
3102 /* assume it's a package name */
3103 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3107 SV* const ref = newSViv(PTR2IV(stash));
3108 (void)hv_store(PL_stashcache, packname,
3109 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3110 DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
3115 /* it _is_ a filehandle name -- replace with a reference */
3116 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3119 /* if we got here, ob should be a reference or a glob */
3120 if (!ob || !(SvOBJECT(ob)
3121 || (SvTYPE(ob) == SVt_PVGV
3123 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3126 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3127 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3128 ? newSVpvs_flags("DOES", SVs_TEMP)
3132 stash = SvSTASH(ob);
3135 /* NOTE: stash may be null, hope hv_fetch_ent and
3136 gv_fetchmethod can cope (it seems they can) */
3138 /* shortcut for simple names */
3140 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3142 gv = MUTABLE_GV(HeVAL(he));
3143 if (isGV(gv) && GvCV(gv) &&
3144 (!GvCVGEN(gv) || GvCVGEN(gv)
3145 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3146 return MUTABLE_SV(GvCV(gv));
3150 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3151 meth, GV_AUTOLOAD | GV_CROAK);
3155 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3160 * c-indentation-style: bsd
3162 * indent-tabs-mode: nil
3165 * ex: set ts=8 sts=4 sw=4 et: