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);
116 /* sassign keeps its args in the optree traditionally backwards.
117 So we pop them differently.
119 SV *left = POPs; SV *right = TOPs;
121 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
122 SV * const temp = left;
123 left = right; right = temp;
125 if (PL_tainting && PL_tainted && !SvTAINTED(right))
127 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
128 SV * const cv = SvRV(right);
129 const U32 cv_type = SvTYPE(cv);
130 const bool is_gv = isGV_with_GP(left);
131 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
137 /* Can do the optimisation if left (LVALUE) is not a typeglob,
138 right (RVALUE) is a reference to something, and we're in void
140 if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
141 /* Is the target symbol table currently empty? */
142 GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV);
143 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
144 /* Good. Create a new proxy constant subroutine in the target.
145 The gv becomes a(nother) reference to the constant. */
146 SV *const value = SvRV(cv);
148 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
149 SvPCS_IMPORTED_on(gv);
151 SvREFCNT_inc_simple_void(value);
157 /* Need to fix things up. */
159 /* Need to fix GV. */
160 left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV));
164 /* We've been returned a constant rather than a full subroutine,
165 but they expect a subroutine reference to apply. */
167 ENTER_with_name("sassign_coderef");
168 SvREFCNT_inc_void(SvRV(cv));
169 /* newCONSTSUB takes a reference count on the passed in SV
170 from us. We set the name to NULL, otherwise we get into
171 all sorts of fun as the reference to our new sub is
172 donated to the GV that we're about to assign to.
174 SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL,
177 LEAVE_with_name("sassign_coderef");
179 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
181 First: ops for \&{"BONK"}; return us the constant in the
183 Second: ops for *{"BONK"} cause that symbol table entry
184 (and our reference to it) to be upgraded from RV
186 Thirdly: We get here. cv is actually PVGV now, and its
187 GvCV() is actually the subroutine we're looking for
189 So change the reference so that it points to the subroutine
190 of that typeglob, as that's what they were after all along.
192 GV *const upgraded = MUTABLE_GV(cv);
193 CV *const source = GvCV(upgraded);
196 assert(CvFLAGS(source) & CVf_CONST);
198 SvREFCNT_inc_void(source);
199 SvREFCNT_dec(upgraded);
200 SvRV_set(right, MUTABLE_SV(source));
206 SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
207 (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
210 packWARN(WARN_MISC), "Useless assignment to a temporary"
212 SvSetMagicSV(left, right);
222 RETURNOP(cLOGOP->op_other);
224 RETURNOP(cLOGOP->op_next);
231 TAINT_NOT; /* Each statement is presumed innocent */
232 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
234 if (!(PL_op->op_flags & OPf_SPECIAL)) {
235 I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
236 LEAVE_SCOPE(oldsave);
243 dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
248 const char *rpv = NULL;
250 bool rcopied = FALSE;
252 if (TARG == right && right != left) { /* $r = $l.$r */
253 rpv = SvPV_nomg_const(right, rlen);
254 rbyte = !DO_UTF8(right);
255 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
256 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
260 if (TARG != left) { /* not $l .= $r */
262 const char* const lpv = SvPV_nomg_const(left, llen);
263 lbyte = !DO_UTF8(left);
264 sv_setpvn(TARG, lpv, llen);
270 else { /* $l .= $r */
272 if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
273 report_uninit(right);
276 lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
277 ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
284 /* $r.$r: do magic twice: tied might return different 2nd time */
286 rpv = SvPV_nomg_const(right, rlen);
287 rbyte = !DO_UTF8(right);
289 if (lbyte != rbyte) {
290 /* sv_utf8_upgrade_nomg() may reallocate the stack */
293 sv_utf8_upgrade_nomg(TARG);
296 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
297 sv_utf8_upgrade_nomg(right);
298 rpv = SvPV_nomg_const(right, rlen);
302 sv_catpvn_nomg(TARG, rpv, rlen);
313 if (PL_op->op_flags & OPf_MOD) {
314 if (PL_op->op_private & OPpLVAL_INTRO)
315 if (!(PL_op->op_private & OPpPAD_STATE))
316 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
317 if (PL_op->op_private & OPpDEREF) {
319 TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
332 tryAMAGICunTARGETlist(iter_amg, 0, 0);
333 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
335 else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
336 if (!isGV_with_GP(PL_last_in_gv)) {
337 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
338 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
341 XPUSHs(MUTABLE_SV(PL_last_in_gv));
344 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
347 return do_readline();
355 tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
359 (SvIOK_notUV(left) && SvIOK_notUV(right))
360 ? (SvIVX(left) == SvIVX(right))
361 : ( do_ncmp(left, right) == 0)
370 PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
371 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
372 Perl_croak_no_modify(aTHX);
373 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
374 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
376 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
377 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
379 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
380 if (inc) sv_inc(TOPs);
393 if (PL_op->op_type == OP_OR)
395 RETURNOP(cLOGOP->op_other);
404 const int op_type = PL_op->op_type;
405 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
410 if (!sv || !SvANY(sv)) {
411 if (op_type == OP_DOR)
413 RETURNOP(cLOGOP->op_other);
419 if (!sv || !SvANY(sv))
424 switch (SvTYPE(sv)) {
426 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
430 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
434 if (CvROOT(sv) || CvXSUB(sv))
447 if(op_type == OP_DOR)
449 RETURNOP(cLOGOP->op_other);
451 /* assuming OP_DEFINED */
459 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
460 tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
464 useleft = USE_LEFT(svl);
465 #ifdef PERL_PRESERVE_IVUV
466 /* We must see if we can perform the addition with integers if possible,
467 as the integer code detects overflow while the NV code doesn't.
468 If either argument hasn't had a numeric conversion yet attempt to get
469 the IV. It's important to do this now, rather than just assuming that
470 it's not IOK as a PV of "9223372036854775806" may not take well to NV
471 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
472 integer in case the second argument is IV=9223372036854775806
473 We can (now) rely on sv_2iv to do the right thing, only setting the
474 public IOK flag if the value in the NV (or PV) slot is truly integer.
476 A side effect is that this also aggressively prefers integer maths over
477 fp maths for integer values.
479 How to detect overflow?
481 C 99 section 6.2.6.1 says
483 The range of nonnegative values of a signed integer type is a subrange
484 of the corresponding unsigned integer type, and the representation of
485 the same value in each type is the same. A computation involving
486 unsigned operands can never overflow, because a result that cannot be
487 represented by the resulting unsigned integer type is reduced modulo
488 the number that is one greater than the largest value that can be
489 represented by the resulting type.
493 which I read as "unsigned ints wrap."
495 signed integer overflow seems to be classed as "exception condition"
497 If an exceptional condition occurs during the evaluation of an
498 expression (that is, if the result is not mathematically defined or not
499 in the range of representable values for its type), the behavior is
502 (6.5, the 5th paragraph)
504 I had assumed that on 2s complement machines signed arithmetic would
505 wrap, hence coded pp_add and pp_subtract on the assumption that
506 everything perl builds on would be happy. After much wailing and
507 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
508 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
509 unsigned code below is actually shorter than the old code. :-)
512 if (SvIV_please_nomg(svr)) {
513 /* Unless the left argument is integer in range we are going to have to
514 use NV maths. Hence only attempt to coerce the right argument if
515 we know the left is integer. */
523 /* left operand is undef, treat as zero. + 0 is identity,
524 Could SETi or SETu right now, but space optimise by not adding
525 lots of code to speed up what is probably a rarish case. */
527 /* Left operand is defined, so is it IV? */
528 if (SvIV_please_nomg(svl)) {
529 if ((auvok = SvUOK(svl)))
532 register const IV aiv = SvIVX(svl);
535 auvok = 1; /* Now acting as a sign flag. */
536 } else { /* 2s complement assumption for IV_MIN */
544 bool result_good = 0;
547 bool buvok = SvUOK(svr);
552 register const IV biv = SvIVX(svr);
559 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
560 else "IV" now, independent of how it came in.
561 if a, b represents positive, A, B negative, a maps to -A etc
566 all UV maths. negate result if A negative.
567 add if signs same, subtract if signs differ. */
573 /* Must get smaller */
579 /* result really should be -(auv-buv). as its negation
580 of true value, need to swap our result flag */
597 if (result <= (UV)IV_MIN)
600 /* result valid, but out of range for IV. */
605 } /* Overflow, drop through to NVs. */
610 NV value = SvNV_nomg(svr);
613 /* left operand is undef, treat as zero. + 0.0 is identity. */
617 SETn( value + SvNV_nomg(svl) );
625 AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
626 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
627 const U32 lval = PL_op->op_flags & OPf_MOD;
628 SV** const svp = av_fetch(av, PL_op->op_private, lval);
629 SV *sv = (svp ? *svp : &PL_sv_undef);
631 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
639 dVAR; dSP; dMARK; dTARGET;
641 do_join(TARG, *MARK, MARK, SP);
652 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
653 * will be enough to hold an OP*.
655 SV* const sv = sv_newmortal();
656 sv_upgrade(sv, SVt_PVLV);
658 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
661 XPUSHs(MUTABLE_SV(PL_op));
666 /* Oversized hot code. */
670 dVAR; dSP; dMARK; dORIGMARK;
674 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
678 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
681 if (MARK == ORIGMARK) {
682 /* If using default handle then we need to make space to
683 * pass object as 1st arg, so move other args up ...
687 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
690 return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
692 (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
693 | (PL_op->op_type == OP_SAY
694 ? TIED_METHOD_SAY : 0)), sp - mark);
697 if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
698 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
701 SETERRNO(EBADF,RMS_IFI);
704 else if (!(fp = IoOFP(io))) {
706 report_wrongway_fh(gv, '<');
709 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
713 SV * const ofs = GvSV(PL_ofsgv); /* $, */
715 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
717 if (!do_print(*MARK, fp))
721 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
722 if (!do_print(GvSV(PL_ofsgv), fp)) {
731 if (!do_print(*MARK, fp))
739 if (PL_op->op_type == OP_SAY) {
740 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
743 else if (PL_ors_sv && SvOK(PL_ors_sv))
744 if (!do_print(PL_ors_sv, fp)) /* $\ */
747 if (IoFLAGS(io) & IOf_FLUSH)
748 if (PerlIO_flush(fp) == EOF)
758 XPUSHs(&PL_sv_undef);
765 const I32 gimme = GIMME_V;
766 static const char an_array[] = "an ARRAY";
767 static const char a_hash[] = "a HASH";
768 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
769 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
774 sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
777 if (SvTYPE(sv) != type)
778 /* diag_listed_as: Not an ARRAY reference */
779 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
780 if (PL_op->op_flags & OPf_REF) {
784 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
785 const I32 flags = is_lvalue_sub();
786 if (flags && !(flags & OPpENTERSUB_INARGS)) {
787 if (gimme != G_ARRAY)
788 goto croak_cant_return;
793 else if (PL_op->op_flags & OPf_MOD
794 && PL_op->op_private & OPpLVAL_INTRO)
795 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
798 if (SvTYPE(sv) == type) {
799 if (PL_op->op_flags & OPf_REF) {
804 if (gimme != G_ARRAY)
805 goto croak_cant_return;
813 if (!isGV_with_GP(sv)) {
814 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
822 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
823 if (PL_op->op_private & OPpLVAL_INTRO)
824 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
825 if (PL_op->op_flags & OPf_REF) {
829 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
830 const I32 flags = is_lvalue_sub();
831 if (flags && !(flags & OPpENTERSUB_INARGS)) {
832 if (gimme != G_ARRAY)
833 goto croak_cant_return;
842 AV *const av = MUTABLE_AV(sv);
843 /* The guts of pp_rv2av, with no intending change to preserve history
844 (until such time as we get tools that can do blame annotation across
845 whitespace changes. */
846 if (gimme == G_ARRAY) {
847 const I32 maxarg = AvFILL(av) + 1;
848 (void)POPs; /* XXXX May be optimized away? */
850 if (SvRMAGICAL(av)) {
852 for (i=0; i < (U32)maxarg; i++) {
853 SV ** const svp = av_fetch(av, i, FALSE);
854 /* See note in pp_helem, and bug id #27839 */
856 ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
861 Copy(AvARRAY(av), SP+1, maxarg, SV*);
865 else if (gimme == G_SCALAR) {
867 const I32 maxarg = AvFILL(av) + 1;
871 /* The guts of pp_rv2hv */
872 if (gimme == G_ARRAY) { /* array wanted */
874 return Perl_do_kv(aTHX);
876 else if (gimme == G_SCALAR) {
878 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
886 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
887 is_pp_rv2av ? "array" : "hash");
892 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
896 PERL_ARGS_ASSERT_DO_ODDBALL;
902 if (ckWARN(WARN_MISC)) {
904 if (relem == firstrelem &&
906 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
907 SvTYPE(SvRV(*relem)) == SVt_PVHV))
909 err = "Reference found where even-sized list expected";
912 err = "Odd number of elements in hash assignment";
913 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
917 didstore = hv_store_ent(hash,*relem,tmpstr,0);
918 if (SvMAGICAL(hash)) {
919 if (SvSMAGICAL(tmpstr))
931 SV **lastlelem = PL_stack_sp;
932 SV **lastrelem = PL_stack_base + POPMARK;
933 SV **firstrelem = PL_stack_base + POPMARK + 1;
934 SV **firstlelem = lastrelem + 1;
947 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
949 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
952 /* If there's a common identifier on both sides we have to take
953 * special care that assigning the identifier on the left doesn't
954 * clobber a value on the right that's used later in the list.
955 * Don't bother if LHS is just an empty hash or array.
958 if ( (PL_op->op_private & OPpASSIGN_COMMON)
960 firstlelem != lastlelem
961 || ! ((sv = *firstlelem))
963 || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
964 || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
965 || (SvTYPE(sv) == SVt_PVHV && HvUSEDKEYS((HV*)sv) != 0)
968 EXTEND_MORTAL(lastrelem - firstrelem + 1);
969 for (relem = firstrelem; relem <= lastrelem; relem++) {
971 TAINT_NOT; /* Each item is independent */
973 /* Dear TODO test in t/op/sort.t, I love you.
974 (It's relying on a panic, not a "semi-panic" from newSVsv()
975 and then an assertion failure below.) */
976 if (SvIS_FREED(sv)) {
977 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
980 /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
981 and we need a second copy of a temp here. */
982 *relem = sv_2mortal(newSVsv(sv));
992 while (lelem <= lastlelem) {
993 TAINT_NOT; /* Each item stands on its own, taintwise. */
995 switch (SvTYPE(sv)) {
997 ary = MUTABLE_AV(sv);
998 magic = SvMAGICAL(ary) != 0;
1000 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1002 av_extend(ary, lastrelem - relem);
1004 while (relem <= lastrelem) { /* gobble up all the rest */
1008 sv_setsv(sv, *relem);
1010 didstore = av_store(ary,i++,sv);
1019 if (PL_delaymagic & DM_ARRAY_ISA)
1020 SvSETMAGIC(MUTABLE_SV(ary));
1023 case SVt_PVHV: { /* normal hash */
1025 SV** topelem = relem;
1027 hash = MUTABLE_HV(sv);
1028 magic = SvMAGICAL(hash) != 0;
1030 SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
1032 firsthashrelem = relem;
1034 while (relem < lastrelem) { /* gobble up all the rest */
1036 sv = *relem ? *relem : &PL_sv_no;
1040 sv_setsv(tmpstr,*relem); /* value */
1042 if (gimme != G_VOID) {
1043 if (hv_exists_ent(hash, sv, 0))
1044 /* key overwrites an existing entry */
1047 if (gimme == G_ARRAY) {
1048 /* copy element back: possibly to an earlier
1049 * stack location if we encountered dups earlier */
1051 *topelem++ = tmpstr;
1054 didstore = hv_store_ent(hash,sv,tmpstr,0);
1056 if (SvSMAGICAL(tmpstr))
1063 if (relem == lastrelem) {
1064 do_oddball(hash, relem, firstrelem);
1071 if (SvIMMORTAL(sv)) {
1072 if (relem <= lastrelem)
1076 if (relem <= lastrelem) {
1078 SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
1079 (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
1082 packWARN(WARN_MISC),
1083 "Useless assignment to a temporary"
1085 sv_setsv(sv, *relem);
1089 sv_setsv(sv, &PL_sv_undef);
1094 if (PL_delaymagic & ~DM_DELAY) {
1095 /* Will be used to set PL_tainting below */
1096 UV tmp_uid = PerlProc_getuid();
1097 UV tmp_euid = PerlProc_geteuid();
1098 UV tmp_gid = PerlProc_getgid();
1099 UV tmp_egid = PerlProc_getegid();
1101 if (PL_delaymagic & DM_UID) {
1102 #ifdef HAS_SETRESUID
1103 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1104 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
1107 # ifdef HAS_SETREUID
1108 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
1109 (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
1112 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1113 (void)setruid(PL_delaymagic_uid);
1114 PL_delaymagic &= ~DM_RUID;
1116 # endif /* HAS_SETRUID */
1118 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1119 (void)seteuid(PL_delaymagic_euid);
1120 PL_delaymagic &= ~DM_EUID;
1122 # endif /* HAS_SETEUID */
1123 if (PL_delaymagic & DM_UID) {
1124 if (PL_delaymagic_uid != PL_delaymagic_euid)
1125 DIE(aTHX_ "No setreuid available");
1126 (void)PerlProc_setuid(PL_delaymagic_uid);
1128 # endif /* HAS_SETREUID */
1129 #endif /* HAS_SETRESUID */
1130 tmp_uid = PerlProc_getuid();
1131 tmp_euid = PerlProc_geteuid();
1133 if (PL_delaymagic & DM_GID) {
1134 #ifdef HAS_SETRESGID
1135 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1136 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
1139 # ifdef HAS_SETREGID
1140 (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
1141 (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
1144 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1145 (void)setrgid(PL_delaymagic_gid);
1146 PL_delaymagic &= ~DM_RGID;
1148 # endif /* HAS_SETRGID */
1150 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1151 (void)setegid(PL_delaymagic_egid);
1152 PL_delaymagic &= ~DM_EGID;
1154 # endif /* HAS_SETEGID */
1155 if (PL_delaymagic & DM_GID) {
1156 if (PL_delaymagic_gid != PL_delaymagic_egid)
1157 DIE(aTHX_ "No setregid available");
1158 (void)PerlProc_setgid(PL_delaymagic_gid);
1160 # endif /* HAS_SETREGID */
1161 #endif /* HAS_SETRESGID */
1162 tmp_gid = PerlProc_getgid();
1163 tmp_egid = PerlProc_getegid();
1165 PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid));
1169 if (gimme == G_VOID)
1170 SP = firstrelem - 1;
1171 else if (gimme == G_SCALAR) {
1174 SETi(lastrelem - firstrelem + 1 - duplicates);
1181 /* at this point we have removed the duplicate key/value
1182 * pairs from the stack, but the remaining values may be
1183 * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1184 * the (a 2), but the stack now probably contains
1185 * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1186 * obliterates the earlier key. So refresh all values. */
1187 lastrelem -= duplicates;
1188 relem = firsthashrelem;
1189 while (relem < lastrelem) {
1192 he = hv_fetch_ent(hash, sv, 0, 0);
1193 *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1199 SP = firstrelem + (lastlelem - firstlelem);
1200 lelem = firstlelem + (relem - firstrelem);
1202 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1211 register PMOP * const pm = cPMOP;
1212 REGEXP * rx = PM_GETRE(pm);
1213 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1214 SV * const rv = sv_newmortal();
1218 SvUPGRADE(rv, SVt_IV);
1219 /* For a subroutine describing itself as "This is a hacky workaround" I'm
1220 loathe to use it here, but it seems to be the right fix. Or close.
1221 The key part appears to be that it's essential for pp_qr to return a new
1222 object (SV), which implies that there needs to be an effective way to
1223 generate a new SV from the existing SV that is pre-compiled in the
1225 SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1228 cvp = &( ((struct regexp*)SvANY(SvRV(rv)))->qr_anoncv);
1229 if ((cv = *cvp) && CvCLONE(*cvp)) {
1230 *cvp = cv_clone(cv);
1235 HV *const stash = gv_stashsv(pkg, GV_ADD);
1237 (void)sv_bless(rv, stash);
1240 if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
1242 SvTAINTED_on(SvRV(rv));
1251 register PMOP *pm = cPMOP;
1253 register const char *t;
1254 register const char *s;
1257 U8 r_flags = REXEC_CHECKED;
1258 const char *truebase; /* Start of string */
1259 register REGEXP *rx = PM_GETRE(pm);
1261 const I32 gimme = GIMME;
1264 const I32 oldsave = PL_savestack_ix;
1265 I32 update_minmatch = 1;
1266 I32 had_zerolen = 0;
1269 if (PL_op->op_flags & OPf_STACKED)
1271 else if (PL_op->op_private & OPpTARGET_MY)
1278 PUTBACK; /* EVAL blocks need stack_sp. */
1279 /* Skip get-magic if this is a qr// clone, because regcomp has
1281 s = ((struct regexp *)SvANY(rx))->mother_re
1282 ? SvPV_nomg_const(TARG, len)
1283 : SvPV_const(TARG, len);
1285 DIE(aTHX_ "panic: pp_match");
1287 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1288 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1291 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1293 /* PMdf_USED is set after a ?? matches once */
1296 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1298 pm->op_pmflags & PMf_USED
1301 DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
1304 if (gimme == G_ARRAY)
1311 /* empty pattern special-cased to use last successful pattern if possible */
1312 if (!RX_PRELEN(rx) && PL_curpm) {
1317 if (RX_MINLEN(rx) > (I32)len) {
1318 DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
1324 /* XXXX What part of this is needed with true \G-support? */
1325 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1326 RX_OFFS(rx)[0].start = -1;
1327 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1328 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1329 if (mg && mg->mg_len >= 0) {
1330 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1331 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1332 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1333 r_flags |= REXEC_IGNOREPOS;
1334 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1335 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1338 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1339 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1340 update_minmatch = 0;
1344 /* XXX: comment out !global get safe $1 vars after a
1345 match, BUT be aware that this leads to dramatic slowdowns on
1346 /g matches against large strings. So far a solution to this problem
1347 appears to be quite tricky.
1348 Test for the unsafe vars are TODO for now. */
1349 if ( (!global && RX_NPARENS(rx))
1350 || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1351 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1352 r_flags |= REXEC_COPY_STR;
1355 if (global && RX_OFFS(rx)[0].start != -1) {
1356 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1357 if ((s + RX_MINLEN(rx)) > strend || s < truebase) {
1358 DEBUG_r(PerlIO_printf(Perl_debug_log, "Regex match can't succeed, so not even tried\n"));
1361 if (update_minmatch++)
1362 minmatch = had_zerolen;
1364 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1365 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1366 /* FIXME - can PL_bostr be made const char *? */
1367 PL_bostr = (char *)truebase;
1368 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1372 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1374 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1375 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1378 if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1379 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1383 if (dynpm->op_pmflags & PMf_ONCE) {
1385 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1387 dynpm->op_pmflags |= PMf_USED;
1393 RX_MATCH_TAINTED_on(rx);
1394 TAINT_IF(RX_MATCH_TAINTED(rx));
1395 if (gimme == G_ARRAY) {
1396 const I32 nparens = RX_NPARENS(rx);
1397 I32 i = (global && !nparens) ? 1 : 0;
1399 SPAGAIN; /* EVAL blocks could move the stack. */
1400 EXTEND(SP, nparens + i);
1401 EXTEND_MORTAL(nparens + i);
1402 for (i = !i; i <= nparens; i++) {
1403 PUSHs(sv_newmortal());
1404 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1405 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1406 s = RX_OFFS(rx)[i].start + truebase;
1407 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1408 len < 0 || len > strend - s)
1409 DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
1410 "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
1411 (long) i, (long) RX_OFFS(rx)[i].start,
1412 (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
1413 sv_setpvn(*SP, s, len);
1414 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1419 if (dynpm->op_pmflags & PMf_CONTINUE) {
1421 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1422 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1424 #ifdef PERL_OLD_COPY_ON_WRITE
1426 sv_force_normal_flags(TARG, 0);
1428 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1429 &PL_vtbl_mglob, NULL, 0);
1431 if (RX_OFFS(rx)[0].start != -1) {
1432 mg->mg_len = RX_OFFS(rx)[0].end;
1433 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1434 mg->mg_flags |= MGf_MINMATCH;
1436 mg->mg_flags &= ~MGf_MINMATCH;
1439 had_zerolen = (RX_OFFS(rx)[0].start != -1
1440 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1441 == (UV)RX_OFFS(rx)[0].end));
1442 PUTBACK; /* EVAL blocks may use stack */
1443 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1448 LEAVE_SCOPE(oldsave);
1454 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1455 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1459 #ifdef PERL_OLD_COPY_ON_WRITE
1461 sv_force_normal_flags(TARG, 0);
1463 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1464 &PL_vtbl_mglob, NULL, 0);
1466 if (RX_OFFS(rx)[0].start != -1) {
1467 mg->mg_len = RX_OFFS(rx)[0].end;
1468 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1469 mg->mg_flags |= MGf_MINMATCH;
1471 mg->mg_flags &= ~MGf_MINMATCH;
1474 LEAVE_SCOPE(oldsave);
1478 yup: /* Confirmed by INTUIT */
1480 RX_MATCH_TAINTED_on(rx);
1481 TAINT_IF(RX_MATCH_TAINTED(rx));
1483 if (dynpm->op_pmflags & PMf_ONCE) {
1485 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1487 dynpm->op_pmflags |= PMf_USED;
1490 if (RX_MATCH_COPIED(rx))
1491 Safefree(RX_SUBBEG(rx));
1492 RX_MATCH_COPIED_off(rx);
1493 RX_SUBBEG(rx) = NULL;
1495 /* FIXME - should rx->subbeg be const char *? */
1496 RX_SUBBEG(rx) = (char *) truebase;
1497 RX_OFFS(rx)[0].start = s - truebase;
1498 if (RX_MATCH_UTF8(rx)) {
1499 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1500 RX_OFFS(rx)[0].end = t - truebase;
1503 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1505 RX_SUBLEN(rx) = strend - truebase;
1508 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1510 #ifdef PERL_OLD_COPY_ON_WRITE
1511 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1513 PerlIO_printf(Perl_debug_log,
1514 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1515 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1518 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1520 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1521 assert (SvPOKp(RX_SAVED_COPY(rx)));
1526 RX_SUBBEG(rx) = savepvn(t, strend - t);
1527 #ifdef PERL_OLD_COPY_ON_WRITE
1528 RX_SAVED_COPY(rx) = NULL;
1531 RX_SUBLEN(rx) = strend - t;
1532 RX_MATCH_COPIED_on(rx);
1533 off = RX_OFFS(rx)[0].start = s - t;
1534 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1536 else { /* startp/endp are used by @- @+. */
1537 RX_OFFS(rx)[0].start = s - truebase;
1538 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1540 /* match via INTUIT shouldn't have any captures. Let @-, @+, $^N know */
1541 assert(!RX_NPARENS(rx));
1542 RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;
1543 LEAVE_SCOPE(oldsave);
1548 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1549 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1550 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1555 LEAVE_SCOPE(oldsave);
1556 if (gimme == G_ARRAY)
1562 Perl_do_readline(pTHX)
1564 dVAR; dSP; dTARGETSTACKED;
1569 register IO * const io = GvIO(PL_last_in_gv);
1570 register const I32 type = PL_op->op_type;
1571 const I32 gimme = GIMME_V;
1574 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1576 Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
1577 if (gimme == G_SCALAR) {
1579 SvSetSV_nosteal(TARG, TOPs);
1589 if (IoFLAGS(io) & IOf_ARGV) {
1590 if (IoFLAGS(io) & IOf_START) {
1592 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1593 IoFLAGS(io) &= ~IOf_START;
1594 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1595 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1596 SvSETMAGIC(GvSV(PL_last_in_gv));
1601 fp = nextargv(PL_last_in_gv);
1602 if (!fp) { /* Note: fp != IoIFP(io) */
1603 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1606 else if (type == OP_GLOB)
1607 fp = Perl_start_glob(aTHX_ POPs, io);
1609 else if (type == OP_GLOB)
1611 else if (IoTYPE(io) == IoTYPE_WRONLY) {
1612 report_wrongway_fh(PL_last_in_gv, '>');
1616 if ((!io || !(IoFLAGS(io) & IOf_START))
1617 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1619 if (type == OP_GLOB)
1620 Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
1621 "glob failed (can't start child: %s)",
1624 report_evil_fh(PL_last_in_gv);
1626 if (gimme == G_SCALAR) {
1627 /* undef TARG, and push that undefined value */
1628 if (type != OP_RCATLINE) {
1629 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1637 if (gimme == G_SCALAR) {
1639 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1642 if (type == OP_RCATLINE)
1643 SvPV_force_nomg_nolen(sv);
1647 else if (isGV_with_GP(sv)) {
1648 SvPV_force_nomg_nolen(sv);
1650 SvUPGRADE(sv, SVt_PV);
1651 tmplen = SvLEN(sv); /* remember if already alloced */
1652 if (!tmplen && !SvREADONLY(sv)) {
1653 /* try short-buffering it. Please update t/op/readline.t
1654 * if you change the growth length.
1659 if (type == OP_RCATLINE && SvOK(sv)) {
1661 SvPV_force_nomg_nolen(sv);
1667 sv = sv_2mortal(newSV(80));
1671 /* This should not be marked tainted if the fp is marked clean */
1672 #define MAYBE_TAINT_LINE(io, sv) \
1673 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1678 /* delay EOF state for a snarfed empty file */
1679 #define SNARF_EOF(gimme,rs,io,sv) \
1680 (gimme != G_SCALAR || SvCUR(sv) \
1681 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1685 if (!sv_gets(sv, fp, offset)
1687 || SNARF_EOF(gimme, PL_rs, io, sv)
1688 || PerlIO_error(fp)))
1690 PerlIO_clearerr(fp);
1691 if (IoFLAGS(io) & IOf_ARGV) {
1692 fp = nextargv(PL_last_in_gv);
1695 (void)do_close(PL_last_in_gv, FALSE);
1697 else if (type == OP_GLOB) {
1698 if (!do_close(PL_last_in_gv, FALSE)) {
1699 Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1700 "glob failed (child exited with status %d%s)",
1701 (int)(STATUS_CURRENT >> 8),
1702 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1705 if (gimme == G_SCALAR) {
1706 if (type != OP_RCATLINE) {
1707 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1713 MAYBE_TAINT_LINE(io, sv);
1716 MAYBE_TAINT_LINE(io, sv);
1718 IoFLAGS(io) |= IOf_NOLINE;
1722 if (type == OP_GLOB) {
1725 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1726 char * const tmps = SvEND(sv) - 1;
1727 if (*tmps == *SvPVX_const(PL_rs)) {
1729 SvCUR_set(sv, SvCUR(sv) - 1);
1732 for (t1 = SvPVX_const(sv); *t1; t1++)
1733 if (!isALNUMC(*t1) &&
1734 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1736 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1737 (void)POPs; /* Unmatched wildcard? Chuck it... */
1740 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1741 if (ckWARN(WARN_UTF8)) {
1742 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1743 const STRLEN len = SvCUR(sv) - offset;
1746 if (!is_utf8_string_loc(s, len, &f))
1747 /* Emulate :encoding(utf8) warning in the same case. */
1748 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1749 "utf8 \"\\x%02X\" does not map to Unicode",
1750 f < (U8*)SvEND(sv) ? *f : 0);
1753 if (gimme == G_ARRAY) {
1754 if (SvLEN(sv) - SvCUR(sv) > 20) {
1755 SvPV_shrink_to_cur(sv);
1757 sv = sv_2mortal(newSV(80));
1760 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1761 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1762 const STRLEN new_len
1763 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1764 SvPV_renew(sv, new_len);
1775 SV * const keysv = POPs;
1776 HV * const hv = MUTABLE_HV(POPs);
1777 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1778 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1780 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1781 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1782 bool preeminent = TRUE;
1784 if (SvTYPE(hv) != SVt_PVHV)
1791 /* If we can determine whether the element exist,
1792 * Try to preserve the existenceness of a tied hash
1793 * element by using EXISTS and DELETE if possible.
1794 * Fallback to FETCH and STORE otherwise. */
1795 if (SvCANEXISTDELETE(hv))
1796 preeminent = hv_exists_ent(hv, keysv, 0);
1799 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1800 svp = he ? &HeVAL(he) : NULL;
1802 if (!svp || !*svp || *svp == &PL_sv_undef) {
1806 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1808 lv = sv_newmortal();
1809 sv_upgrade(lv, SVt_PVLV);
1811 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1812 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1813 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1819 if (HvNAME_get(hv) && isGV(*svp))
1820 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1821 else if (preeminent)
1822 save_helem_flags(hv, keysv, svp,
1823 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1825 SAVEHDELETE(hv, keysv);
1827 else if (PL_op->op_private & OPpDEREF) {
1828 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
1832 sv = (svp && *svp ? *svp : &PL_sv_undef);
1833 /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1834 * was to make C<local $tied{foo} = $tied{foo}> possible.
1835 * However, it seems no longer to be needed for that purpose, and
1836 * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1837 * would loop endlessly since the pos magic is getting set on the
1838 * mortal copy and lost. However, the copy has the effect of
1839 * triggering the get magic, and losing it altogether made things like
1840 * c<$tied{foo};> in void context no longer do get magic, which some
1841 * code relied on. Also, delayed triggering of magic on @+ and friends
1842 * meant the original regex may be out of scope by now. So as a
1843 * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1844 * being called too many times). */
1845 if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1854 register PERL_CONTEXT *cx;
1857 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1858 bool av_is_stack = FALSE;
1861 cx = &cxstack[cxstack_ix];
1862 if (!CxTYPE_is_LOOP(cx))
1863 DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
1865 itersvp = CxITERVAR(cx);
1866 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1867 /* string increment */
1868 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1869 SV *end = cx->blk_loop.state_u.lazysv.end;
1870 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1871 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1873 const char *max = SvPV_const(end, maxlen);
1874 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1875 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1876 /* safe to reuse old SV */
1877 sv_setsv(*itersvp, cur);
1881 /* we need a fresh SV every time so that loop body sees a
1882 * completely new SV for closures/references to work as
1885 *itersvp = newSVsv(cur);
1886 SvREFCNT_dec(oldsv);
1888 if (strEQ(SvPVX_const(cur), max))
1889 sv_setiv(cur, 0); /* terminate next time */
1896 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1897 /* integer increment */
1898 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1901 /* don't risk potential race */
1902 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1903 /* safe to reuse old SV */
1904 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur);
1908 /* we need a fresh SV every time so that loop body sees a
1909 * completely new SV for closures/references to work as they
1912 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur);
1913 SvREFCNT_dec(oldsv);
1916 if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) {
1917 /* Handle end of range at IV_MAX */
1918 cx->blk_loop.state_u.lazyiv.end = IV_MIN;
1920 ++cx->blk_loop.state_u.lazyiv.cur;
1926 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1927 av = cx->blk_loop.state_u.ary.ary;
1932 if (PL_op->op_private & OPpITER_REVERSED) {
1933 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1934 ? cx->blk_loop.resetsp + 1 : 0))
1937 if (SvMAGICAL(av) || AvREIFY(av)) {
1938 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1939 sv = svp ? *svp : NULL;
1942 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1946 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1950 if (SvMAGICAL(av) || AvREIFY(av)) {
1951 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1952 sv = svp ? *svp : NULL;
1955 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1959 if (sv && SvIS_FREED(sv)) {
1961 Perl_croak(aTHX_ "Use of freed value in iteration");
1966 SvREFCNT_inc_simple_void_NN(sv);
1970 if (!av_is_stack && sv == &PL_sv_undef) {
1971 SV *lv = newSV_type(SVt_PVLV);
1973 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1974 LvTARG(lv) = SvREFCNT_inc_simple(av);
1975 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
1976 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1982 SvREFCNT_dec(oldsv);
1988 A description of how taint works in pattern matching and substitution.
1990 While the pattern is being assembled/concatenated and then compiled,
1991 PL_tainted will get set if any component of the pattern is tainted, e.g.
1992 /.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
1993 is set on the pattern if PL_tainted is set.
1995 When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
1996 the pattern is marked as tainted. This means that subsequent usage, such
1997 as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
1999 During execution of a pattern, locale-variant ops such as ALNUML set the
2000 local flag RF_tainted. At the end of execution, the engine sets the
2001 RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
2004 In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
2005 of $1 et al to indicate whether the returned value should be tainted.
2006 It is the responsibility of the caller of the pattern (i.e. pp_match,
2007 pp_subst etc) to set this flag for any other circumstances where $1 needs
2010 The taint behaviour of pp_subst (and pp_substcont) is quite complex.
2012 There are three possible sources of taint
2014 * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
2015 * the replacement string (or expression under /e)
2017 There are four destinations of taint and they are affected by the sources
2018 according to the rules below:
2020 * the return value (not including /r):
2021 tainted by the source string and pattern, but only for the
2022 number-of-iterations case; boolean returns aren't tainted;
2023 * the modified string (or modified copy under /r):
2024 tainted by the source string, pattern, and replacement strings;
2026 tainted by the pattern, and under 'use re "taint"', by the source
2028 * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
2029 should always be unset before executing subsequent code.
2031 The overall action of pp_subst is:
2033 * at the start, set bits in rxtainted indicating the taint status of
2034 the various sources.
2036 * After each pattern execution, update the SUBST_TAINT_PAT bit in
2037 rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
2038 pattern has subsequently become tainted via locale ops.
2040 * If control is being passed to pp_substcont to execute a /e block,
2041 save rxtainted in the CXt_SUBST block, for future use by
2044 * Whenever control is being returned to perl code (either by falling
2045 off the "end" of pp_subst/pp_substcont, or by entering a /e block),
2046 use the flag bits in rxtainted to make all the appropriate types of
2047 destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
2048 et al will appear tainted.
2050 pp_match is just a simpler version of the above.
2057 register PMOP *pm = cPMOP;
2069 U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
2070 See "how taint works" above */
2073 register REGEXP *rx = PM_GETRE(pm);
2075 int force_on_match = 0;
2076 const I32 oldsave = PL_savestack_ix;
2078 bool doutf8 = FALSE;
2079 #ifdef PERL_OLD_COPY_ON_WRITE
2083 /* known replacement string? */
2084 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2088 if (PL_op->op_flags & OPf_STACKED)
2090 else if (PL_op->op_private & OPpTARGET_MY)
2097 #ifdef PERL_OLD_COPY_ON_WRITE
2098 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2099 because they make integers such as 256 "false". */
2100 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2103 sv_force_normal_flags(TARG,0);
2105 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
2106 #ifdef PERL_OLD_COPY_ON_WRITE
2109 && (SvREADONLY(TARG)
2110 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2111 || SvTYPE(TARG) > SVt_PVLV)
2112 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2113 Perl_croak_no_modify(aTHX);
2117 s = SvPV_mutable(TARG, len);
2118 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2121 /* only replace once? */
2122 once = !(rpm->op_pmflags & PMf_GLOBAL);
2124 /* See "how taint works" above */
2127 (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
2128 | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
2129 | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
2130 | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2131 ? SUBST_TAINT_BOOLRET : 0));
2135 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2139 DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
2142 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2143 maxiters = 2 * slen + 10; /* We can match twice at each
2144 position, once with zero-length,
2145 second time with non-zero. */
2147 if (!RX_PRELEN(rx) && PL_curpm) {
2151 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2152 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2153 ? REXEC_COPY_STR : 0;
2156 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2158 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2162 /* How to do it in subst? */
2163 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2165 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY))
2170 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2171 r_flags | REXEC_CHECKED))
2175 PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
2176 LEAVE_SCOPE(oldsave);
2180 /* known replacement string? */
2182 if (SvTAINTED(dstr))
2183 rxtainted |= SUBST_TAINT_REPL;
2185 /* Upgrade the source if the replacement is utf8 but the source is not,
2186 * but only if it matched; see
2187 * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2189 if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2190 char * const orig_pvx = SvPVX(TARG);
2191 const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
2193 /* If the lengths are the same, the pattern contains only
2194 * invariants, can keep going; otherwise, various internal markers
2195 * could be off, so redo */
2196 if (new_len != len || orig_pvx != SvPVX(TARG)) {
2201 /* replacement needing upgrading? */
2202 if (DO_UTF8(TARG) && !doutf8) {
2203 nsv = sv_newmortal();
2206 sv_recode_to_utf8(nsv, PL_encoding);
2208 sv_utf8_upgrade(nsv);
2209 c = SvPV_const(nsv, clen);
2213 c = SvPV_const(dstr, clen);
2214 doutf8 = DO_UTF8(dstr);
2222 /* can do inplace substitution? */
2224 #ifdef PERL_OLD_COPY_ON_WRITE
2227 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2228 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2229 && (!doutf8 || SvUTF8(TARG))
2230 && !(rpm->op_pmflags & PMf_NONDESTRUCT))
2233 #ifdef PERL_OLD_COPY_ON_WRITE
2234 if (SvIsCOW(TARG)) {
2235 assert (!force_on_match);
2239 if (force_on_match) {
2241 s = SvPV_force(TARG, len);
2247 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2248 rxtainted |= SUBST_TAINT_PAT;
2249 m = orig + RX_OFFS(rx)[0].start;
2250 d = orig + RX_OFFS(rx)[0].end;
2252 if (m - s > strend - d) { /* faster to shorten from end */
2254 Copy(c, m, clen, char);
2259 Move(d, m, i, char);
2263 SvCUR_set(TARG, m - s);
2265 else if ((i = m - s)) { /* faster from front */
2268 Move(s, d - i, i, char);
2271 Copy(c, m, clen, char);
2276 Copy(c, d, clen, char);
2286 if (iters++ > maxiters)
2287 DIE(aTHX_ "Substitution loop");
2288 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2289 rxtainted |= SUBST_TAINT_PAT;
2290 m = RX_OFFS(rx)[0].start + orig;
2293 Move(s, d, i, char);
2297 Copy(c, d, clen, char);
2300 s = RX_OFFS(rx)[0].end + orig;
2301 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2303 /* don't match same null twice */
2304 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2307 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2308 Move(s, d, i+1, char); /* include the NUL */
2315 if (force_on_match) {
2317 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2318 /* I feel that it should be possible to avoid this mortal copy
2319 given that the code below copies into a new destination.
2320 However, I suspect it isn't worth the complexity of
2321 unravelling the C<goto force_it> for the small number of
2322 cases where it would be viable to drop into the copy code. */
2323 TARG = sv_2mortal(newSVsv(TARG));
2325 s = SvPV_force(TARG, len);
2328 #ifdef PERL_OLD_COPY_ON_WRITE
2331 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
2332 rxtainted |= SUBST_TAINT_PAT;
2333 dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
2336 register PERL_CONTEXT *cx;
2338 /* note that a whole bunch of local vars are saved here for
2339 * use by pp_substcont: here's a list of them in case you're
2340 * searching for places in this sub that uses a particular var:
2341 * iters maxiters r_flags oldsave rxtainted orig dstr targ
2342 * s m strend rx once */
2344 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2346 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2348 if (iters++ > maxiters)
2349 DIE(aTHX_ "Substitution loop");
2350 if (RX_MATCH_TAINTED(rx))
2351 rxtainted |= SUBST_TAINT_PAT;
2352 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2355 orig = RX_SUBBEG(rx);
2357 strend = s + (strend - m);
2359 m = RX_OFFS(rx)[0].start + orig;
2360 if (doutf8 && !SvUTF8(dstr))
2361 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2363 sv_catpvn(dstr, s, m-s);
2364 s = RX_OFFS(rx)[0].end + orig;
2366 sv_catpvn(dstr, c, clen);
2369 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2370 TARG, NULL, r_flags));
2371 if (doutf8 && !DO_UTF8(TARG))
2372 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2374 sv_catpvn(dstr, s, strend - s);
2376 if (rpm->op_pmflags & PMf_NONDESTRUCT) {
2377 /* From here on down we're using the copy, and leaving the original
2383 #ifdef PERL_OLD_COPY_ON_WRITE
2384 /* The match may make the string COW. If so, brilliant, because
2385 that's just saved us one malloc, copy and free - the regexp has
2386 donated the old buffer, and we malloc an entirely new one, rather
2387 than the regexp malloc()ing a buffer and copying our original,
2388 only for us to throw it away here during the substitution. */
2389 if (SvIsCOW(TARG)) {
2390 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2396 SvPV_set(TARG, SvPVX(dstr));
2397 SvCUR_set(TARG, SvCUR(dstr));
2398 SvLEN_set(TARG, SvLEN(dstr));
2399 doutf8 |= DO_UTF8(dstr);
2400 SvPV_set(dstr, NULL);
2407 if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
2408 (void)SvPOK_only_UTF8(TARG);
2413 /* See "how taint works" above */
2415 if ((rxtainted & SUBST_TAINT_PAT) ||
2416 ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
2417 (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
2419 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
2421 if (!(rxtainted & SUBST_TAINT_BOOLRET)
2422 && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
2424 SvTAINTED_on(TOPs); /* taint return value */
2426 SvTAINTED_off(TOPs); /* may have got tainted earlier */
2428 /* needed for mg_set below */
2430 cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
2433 SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
2435 LEAVE_SCOPE(oldsave);
2444 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2445 ++*PL_markstack_ptr;
2447 LEAVE_with_name("grep_item"); /* exit inner scope */
2450 if (PL_stack_base + *PL_markstack_ptr > SP) {
2452 const I32 gimme = GIMME_V;
2454 LEAVE_with_name("grep"); /* exit outer scope */
2455 (void)POPMARK; /* pop src */
2456 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2457 (void)POPMARK; /* pop dst */
2458 SP = PL_stack_base + POPMARK; /* pop original mark */
2459 if (gimme == G_SCALAR) {
2460 if (PL_op->op_private & OPpGREP_LEX) {
2461 SV* const sv = sv_newmortal();
2462 sv_setiv(sv, items);
2470 else if (gimme == G_ARRAY)
2477 ENTER_with_name("grep_item"); /* enter inner scope */
2480 src = PL_stack_base[*PL_markstack_ptr];
2482 if (PL_op->op_private & OPpGREP_LEX)
2483 PAD_SVl(PL_op->op_targ) = src;
2487 RETURNOP(cLOGOP->op_other);
2498 register PERL_CONTEXT *cx;
2501 if (CxMULTICALL(&cxstack[cxstack_ix]))
2505 cxstack_ix++; /* temporarily protect top context */
2508 if (gimme == G_SCALAR) {
2511 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2512 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2513 && !SvMAGICAL(TOPs)) {
2514 *MARK = SvREFCNT_inc(TOPs);
2519 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2521 *MARK = sv_mortalcopy(sv);
2525 else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2526 && !SvMAGICAL(TOPs)) {
2530 *MARK = sv_mortalcopy(TOPs);
2534 *MARK = &PL_sv_undef;
2538 else if (gimme == G_ARRAY) {
2539 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2540 if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1
2541 || SvMAGICAL(*MARK)) {
2542 *MARK = sv_mortalcopy(*MARK);
2543 TAINT_NOT; /* Each item is independent */
2551 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2552 PL_curpm = newpm; /* ... and pop $1 et al */
2555 return cx->blk_sub.retop;
2563 register PERL_CONTEXT *cx;
2565 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2568 DIE(aTHX_ "Not a CODE reference");
2569 switch (SvTYPE(sv)) {
2570 /* This is overwhelming the most common case: */
2573 if (!(cv = GvCVu((const GV *)sv))) {
2575 cv = sv_2cv(sv, &stash, &gv, 0);
2584 if(isGV_with_GP(sv)) goto we_have_a_glob;
2587 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2589 SP = PL_stack_base + POPMARK;
2597 sv = amagic_deref_call(sv, to_cv_amg);
2598 /* Don't SPAGAIN here. */
2604 sym = SvPV_nomg_const(sv, len);
2606 DIE(aTHX_ PL_no_usym, "a subroutine");
2607 if (PL_op->op_private & HINT_STRICT_REFS)
2608 DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
2609 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2612 cv = MUTABLE_CV(SvRV(sv));
2613 if (SvTYPE(cv) == SVt_PVCV)
2618 DIE(aTHX_ "Not a CODE reference");
2619 /* This is the second most common case: */
2621 cv = MUTABLE_CV(sv);
2629 if (CvCLONE(cv) && ! CvCLONED(cv))
2630 DIE(aTHX_ "Closure prototype called");
2631 if (!CvROOT(cv) && !CvXSUB(cv)) {
2635 /* anonymous or undef'd function leaves us no recourse */
2636 if (CvANON(cv) || !(gv = CvGV(cv)))
2637 DIE(aTHX_ "Undefined subroutine called");
2639 /* autoloaded stub? */
2640 if (cv != GvCV(gv)) {
2643 /* should call AUTOLOAD now? */
2646 if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2647 GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
2653 sub_name = sv_newmortal();
2654 gv_efullname3(sub_name, gv, NULL);
2655 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2659 DIE(aTHX_ "Not a CODE reference");
2664 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2665 Perl_get_db_sub(aTHX_ &sv, cv);
2667 PL_curcopdb = PL_curcop;
2669 /* check for lsub that handles lvalue subroutines */
2670 cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2671 /* if lsub not found then fall back to DB::sub */
2672 if (!cv) cv = GvCV(PL_DBsub);
2674 cv = GvCV(PL_DBsub);
2677 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2678 DIE(aTHX_ "No DB::sub routine defined");
2681 if (!(CvISXSUB(cv))) {
2682 /* This path taken at least 75% of the time */
2684 register I32 items = SP - MARK;
2685 AV* const padlist = CvPADLIST(cv);
2686 PUSHBLOCK(cx, CXt_SUB, MARK);
2688 cx->blk_sub.retop = PL_op->op_next;
2690 if (CvDEPTH(cv) >= 2) {
2691 PERL_STACK_OVERFLOW_CHECK();
2692 pad_push(padlist, CvDEPTH(cv));
2695 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2697 AV *const av = MUTABLE_AV(PAD_SVl(0));
2699 /* @_ is normally not REAL--this should only ever
2700 * happen when DB::sub() calls things that modify @_ */
2705 cx->blk_sub.savearray = GvAV(PL_defgv);
2706 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2707 CX_CURPAD_SAVE(cx->blk_sub);
2708 cx->blk_sub.argarray = av;
2711 if (items > AvMAX(av) + 1) {
2712 SV **ary = AvALLOC(av);
2713 if (AvARRAY(av) != ary) {
2714 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2717 if (items > AvMAX(av) + 1) {
2718 AvMAX(av) = items - 1;
2719 Renew(ary,items,SV*);
2724 Copy(MARK,AvARRAY(av),items,SV*);
2725 AvFILLp(av) = items - 1;
2733 if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
2735 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2736 /* warning must come *after* we fully set up the context
2737 * stuff so that __WARN__ handlers can safely dounwind()
2740 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2741 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2742 sub_crush_depth(cv);
2743 RETURNOP(CvSTART(cv));
2746 I32 markix = TOPMARK;
2751 /* Need to copy @_ to stack. Alternative may be to
2752 * switch stack to @_, and copy return values
2753 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2754 AV * const av = GvAV(PL_defgv);
2755 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2758 /* Mark is at the end of the stack. */
2760 Copy(AvARRAY(av), SP + 1, items, SV*);
2765 /* We assume first XSUB in &DB::sub is the called one. */
2767 SAVEVPTR(PL_curcop);
2768 PL_curcop = PL_curcopdb;
2771 /* Do we need to open block here? XXXX */
2773 /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2775 CvXSUB(cv)(aTHX_ cv);
2777 /* Enforce some sanity in scalar context. */
2778 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2779 if (markix > PL_stack_sp - PL_stack_base)
2780 *(PL_stack_base + markix) = &PL_sv_undef;
2782 *(PL_stack_base + markix) = *PL_stack_sp;
2783 PL_stack_sp = PL_stack_base + markix;
2791 Perl_sub_crush_depth(pTHX_ CV *cv)
2793 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2796 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2798 SV* const tmpstr = sv_newmortal();
2799 gv_efullname3(tmpstr, CvGV(cv), NULL);
2800 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2809 SV* const elemsv = POPs;
2810 IV elem = SvIV(elemsv);
2811 AV *const av = MUTABLE_AV(POPs);
2812 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2813 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2814 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2815 bool preeminent = TRUE;
2818 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2819 Perl_warner(aTHX_ packWARN(WARN_MISC),
2820 "Use of reference \"%"SVf"\" as array index",
2822 if (SvTYPE(av) != SVt_PVAV)
2829 /* If we can determine whether the element exist,
2830 * Try to preserve the existenceness of a tied array
2831 * element by using EXISTS and DELETE if possible.
2832 * Fallback to FETCH and STORE otherwise. */
2833 if (SvCANEXISTDELETE(av))
2834 preeminent = av_exists(av, elem);
2837 svp = av_fetch(av, elem, lval && !defer);
2839 #ifdef PERL_MALLOC_WRAP
2840 if (SvUOK(elemsv)) {
2841 const UV uv = SvUV(elemsv);
2842 elem = uv > IV_MAX ? IV_MAX : uv;
2844 else if (SvNOK(elemsv))
2845 elem = (IV)SvNV(elemsv);
2847 static const char oom_array_extend[] =
2848 "Out of memory during array extend"; /* Duplicated in av.c */
2849 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2852 if (!svp || *svp == &PL_sv_undef) {
2855 DIE(aTHX_ PL_no_aelem, elem);
2856 lv = sv_newmortal();
2857 sv_upgrade(lv, SVt_PVLV);
2859 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2860 LvTARG(lv) = SvREFCNT_inc_simple(av);
2861 LvTARGOFF(lv) = elem;
2868 save_aelem(av, elem, svp);
2870 SAVEADELETE(av, elem);
2872 else if (PL_op->op_private & OPpDEREF) {
2873 PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
2877 sv = (svp ? *svp : &PL_sv_undef);
2878 if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
2885 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2887 PERL_ARGS_ASSERT_VIVIFY_REF;
2892 Perl_croak_no_modify(aTHX);
2893 prepare_SV_for_RV(sv);
2896 SvRV_set(sv, newSV(0));
2899 SvRV_set(sv, MUTABLE_SV(newAV()));
2902 SvRV_set(sv, MUTABLE_SV(newHV()));
2909 if (SvGMAGICAL(sv)) {
2910 /* copy the sv without magic to prevent magic from being
2912 SV* msv = sv_newmortal();
2913 sv_setsv_nomg(msv, sv);
2922 SV* const sv = TOPs;
2925 SV* const rsv = SvRV(sv);
2926 if (SvTYPE(rsv) == SVt_PVCV) {
2932 SETs(method_common(sv, NULL));
2939 SV* const sv = cSVOP_sv;
2940 U32 hash = SvSHARED_HASH(sv);
2942 XPUSHs(method_common(sv, &hash));
2947 S_method_common(pTHX_ SV* meth, U32* hashp)
2954 SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
2955 ? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
2956 "package or object reference", SVfARG(meth)),
2958 : *(PL_stack_base + TOPMARK + 1);
2960 PERL_ARGS_ASSERT_METHOD_COMMON;
2963 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
2968 ob = MUTABLE_SV(SvRV(sv));
2972 const char * packname = NULL;
2973 bool packname_is_utf8 = FALSE;
2975 /* this isn't a reference */
2976 if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
2977 const HE* const he =
2978 (const HE *)hv_common_key_len(
2979 PL_stashcache, packname,
2980 packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
2984 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2991 !(iogv = gv_fetchpvn_flags(
2992 packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
2994 !(ob=MUTABLE_SV(GvIO(iogv))))
2996 /* this isn't the name of a filehandle either */
2998 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2999 ? !isIDFIRST_utf8((U8*)packname)
3000 : !isIDFIRST_L1((U8)*packname)
3003 /* diag_listed_as: Can't call method "%s" without a package or object reference */
3004 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3006 SvOK(sv) ? "without a package or object reference"
3007 : "on an undefined value");
3009 /* assume it's a package name */
3010 stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
3014 SV* const ref = newSViv(PTR2IV(stash));
3015 (void)hv_store(PL_stashcache, packname,
3016 packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
3020 /* it _is_ a filehandle name -- replace with a reference */
3021 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3024 /* if we got here, ob should be a reference or a glob */
3025 if (!ob || !(SvOBJECT(ob)
3026 || (SvTYPE(ob) == SVt_PVGV
3028 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3031 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on unblessed reference",
3032 SVfARG((SvSCREAM(meth) && strEQ(SvPV_nolen_const(meth),"isa"))
3033 ? newSVpvs_flags("DOES", SVs_TEMP)
3037 stash = SvSTASH(ob);
3040 /* NOTE: stash may be null, hope hv_fetch_ent and
3041 gv_fetchmethod can cope (it seems they can) */
3043 /* shortcut for simple names */
3045 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3047 gv = MUTABLE_GV(HeVAL(he));
3048 if (isGV(gv) && GvCV(gv) &&
3049 (!GvCVGEN(gv) || GvCVGEN(gv)
3050 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3051 return MUTABLE_SV(GvCV(gv));
3055 gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
3056 meth, GV_AUTOLOAD | GV_CROAK);
3060 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3065 * c-indentation-style: bsd
3067 * indent-tabs-mode: nil
3070 * ex: set ts=8 sts=4 sw=4 et: