3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (PL_op->op_private & OPpLVAL_INTRO)
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
77 PL_curcop = (COP*)PL_op;
84 PUSHMARK(PL_stack_sp);
99 XPUSHs((SV*)cGVOP_gv);
109 if (PL_op->op_type == OP_AND)
111 RETURNOP(cLOGOP->op_other);
117 dVAR; dSP; dPOPTOPssrl;
119 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
120 SV * const temp = left;
121 left = right; right = temp;
123 if (PL_tainting && PL_tainted && !SvTAINTED(left))
125 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
126 SV * const cv = SvRV(left);
127 const U32 cv_type = SvTYPE(cv);
128 const U32 gv_type = SvTYPE(right);
129 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
135 /* Can do the optimisation if right (LVAUE) is not a typeglob,
136 left (RVALUE) is a reference to something, and we're in void
138 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
139 /* Is the target symbol table currently empty? */
140 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
141 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
142 /* Good. Create a new proxy constant subroutine in the target.
143 The gv becomes a(nother) reference to the constant. */
144 SV *const value = SvRV(cv);
146 SvUPGRADE((SV *)gv, SVt_RV);
149 SvREFCNT_inc_simple_void(value);
155 /* Need to fix things up. */
156 if (gv_type != SVt_PVGV) {
157 /* Need to fix GV. */
158 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
162 /* We've been returned a constant rather than a full subroutine,
163 but they expect a subroutine reference to apply. */
165 SvREFCNT_inc_void(SvRV(cv));
166 /* newCONSTSUB takes a reference count on the passed in SV
167 from us. We set the name to NULL, otherwise we get into
168 all sorts of fun as the reference to our new sub is
169 donated to the GV that we're about to assign to.
171 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
178 SvSetMagicSV(right, left);
187 RETURNOP(cLOGOP->op_other);
189 RETURNOP(cLOGOP->op_next);
196 TAINT_NOT; /* Each statement is presumed innocent */
197 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
199 oldsave = PL_scopestack[PL_scopestack_ix - 1];
200 LEAVE_SCOPE(oldsave);
206 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
213 bool rcopied = FALSE;
215 if (TARG == right && right != left) {
216 /* mg_get(right) may happen here ... */
217 rpv = SvPV_const(right, rlen);
218 rbyte = !DO_UTF8(right);
219 right = sv_2mortal(newSVpvn(rpv, rlen));
220 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
226 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
227 lbyte = !DO_UTF8(left);
228 sv_setpvn(TARG, lpv, llen);
234 else { /* TARG == left */
236 SvGETMAGIC(left); /* or mg_get(left) may happen here */
238 if (left == right && ckWARN(WARN_UNINITIALIZED))
239 report_uninit(right);
240 sv_setpvn(left, "", 0);
242 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
243 lbyte = !DO_UTF8(left);
248 /* or mg_get(right) may happen here */
250 rpv = SvPV_const(right, rlen);
251 rbyte = !DO_UTF8(right);
253 if (lbyte != rbyte) {
255 sv_utf8_upgrade_nomg(TARG);
258 right = sv_2mortal(newSVpvn(rpv, rlen));
259 sv_utf8_upgrade_nomg(right);
260 rpv = SvPV_const(right, rlen);
263 sv_catpvn_nomg(TARG, rpv, rlen);
274 if (PL_op->op_flags & OPf_MOD) {
275 if (PL_op->op_private & OPpLVAL_INTRO)
276 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
277 if (PL_op->op_private & OPpDEREF) {
279 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
289 tryAMAGICunTARGET(iter, 0);
290 PL_last_in_gv = (GV*)(*PL_stack_sp--);
291 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
292 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
293 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
296 XPUSHs((SV*)PL_last_in_gv);
299 PL_last_in_gv = (GV*)(*PL_stack_sp--);
302 return do_readline();
307 dVAR; dSP; tryAMAGICbinSET(eq,0);
308 #ifndef NV_PRESERVES_UV
309 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
311 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
315 #ifdef PERL_PRESERVE_IVUV
318 /* Unless the left argument is integer in range we are going
319 to have to use NV maths. Hence only attempt to coerce the
320 right argument if we know the left is integer. */
323 const bool auvok = SvUOK(TOPm1s);
324 const bool buvok = SvUOK(TOPs);
326 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
327 /* Casting IV to UV before comparison isn't going to matter
328 on 2s complement. On 1s complement or sign&magnitude
329 (if we have any of them) it could to make negative zero
330 differ from normal zero. As I understand it. (Need to
331 check - is negative zero implementation defined behaviour
333 const UV buv = SvUVX(POPs);
334 const UV auv = SvUVX(TOPs);
336 SETs(boolSV(auv == buv));
339 { /* ## Mixed IV,UV ## */
343 /* == is commutative so doesn't matter which is left or right */
345 /* top of stack (b) is the iv */
354 /* As uv is a UV, it's >0, so it cannot be == */
358 /* we know iv is >= 0 */
359 SETs(boolSV((UV)iv == SvUVX(uvp)));
367 SETs(boolSV(TOPn == value));
375 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
376 DIE(aTHX_ PL_no_modify);
377 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
378 && SvIVX(TOPs) != IV_MAX)
380 SvIV_set(TOPs, SvIVX(TOPs) + 1);
381 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
383 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
395 if (PL_op->op_type == OP_OR)
397 RETURNOP(cLOGOP->op_other);
406 const int op_type = PL_op->op_type;
407 const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
411 if (!sv || !SvANY(sv)) {
412 if (op_type == OP_DOR)
414 RETURNOP(cLOGOP->op_other);
416 } else if (op_type == OP_DEFINED) {
418 if (!sv || !SvANY(sv))
421 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
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; tryAMAGICbin(add,opASSIGN);
460 useleft = USE_LEFT(TOPm1s);
461 #ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
472 A side effect is that this also aggressively prefers integer maths over
473 fp maths for integer values.
475 How to detect overflow?
477 C 99 section 6.2.6.1 says
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
489 which I read as "unsigned ints wrap."
491 signed integer overflow seems to be classed as "exception condition"
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
498 (6.5, the 5th paragraph)
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
510 /* Unless the left argument is integer in range we are going to have to
511 use NV maths. Hence only attempt to coerce the right argument if
512 we know the left is integer. */
520 /* left operand is undef, treat as zero. + 0 is identity,
521 Could SETi or SETu right now, but space optimise by not adding
522 lots of code to speed up what is probably a rarish case. */
524 /* Left operand is defined, so is it IV? */
527 if ((auvok = SvUOK(TOPm1s)))
530 register const IV aiv = SvIVX(TOPm1s);
533 auvok = 1; /* Now acting as a sign flag. */
534 } else { /* 2s complement assumption for IV_MIN */
542 bool result_good = 0;
545 bool buvok = SvUOK(TOPs);
550 register const IV biv = SvIVX(TOPs);
557 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
558 else "IV" now, independent of how it came in.
559 if a, b represents positive, A, B negative, a maps to -A etc
564 all UV maths. negate result if A negative.
565 add if signs same, subtract if signs differ. */
571 /* Must get smaller */
577 /* result really should be -(auv-buv). as its negation
578 of true value, need to swap our result flag */
595 if (result <= (UV)IV_MIN)
598 /* result valid, but out of range for IV. */
603 } /* Overflow, drop through to NVs. */
610 /* left operand is undef, treat as zero. + 0.0 is identity. */
614 SETn( value + TOPn );
622 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
623 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
624 const U32 lval = PL_op->op_flags & OPf_MOD;
625 SV** const svp = av_fetch(av, PL_op->op_private, lval);
626 SV *sv = (svp ? *svp : &PL_sv_undef);
628 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
629 sv = sv_mortalcopy(sv);
636 dVAR; dSP; dMARK; dTARGET;
638 do_join(TARG, *MARK, MARK, SP);
649 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
650 * will be enough to hold an OP*.
652 SV* const sv = sv_newmortal();
653 sv_upgrade(sv, SVt_PVLV);
655 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
663 /* Oversized hot code. */
667 dVAR; dSP; dMARK; dORIGMARK;
671 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
673 if (gv && (io = GvIO(gv))
674 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
677 if (MARK == ORIGMARK) {
678 /* If using default handle then we need to make space to
679 * pass object as 1st arg, so move other args up ...
683 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
687 *MARK = SvTIED_obj((SV*)io, mg);
690 call_method("PRINT", G_SCALAR);
698 if (!(io = GvIO(gv))) {
699 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
700 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
702 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
703 report_evil_fh(gv, io, PL_op->op_type);
704 SETERRNO(EBADF,RMS_IFI);
707 else if (!(fp = IoOFP(io))) {
708 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
710 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
711 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
712 report_evil_fh(gv, io, PL_op->op_type);
714 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
719 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
721 if (!do_print(*MARK, fp))
725 if (!do_print(PL_ofs_sv, fp)) { /* $, */
734 if (!do_print(*MARK, fp))
742 if (PL_ors_sv && SvOK(PL_ors_sv))
743 if (!do_print(PL_ors_sv, fp)) /* $\ */
746 if (IoFLAGS(io) & IOf_FLUSH)
747 if (PerlIO_flush(fp) == EOF)
757 XPUSHs(&PL_sv_undef);
768 tryAMAGICunDEREF(to_av);
771 if (SvTYPE(av) != SVt_PVAV)
772 DIE(aTHX_ "Not an ARRAY reference");
773 if (PL_op->op_flags & OPf_REF) {
778 if (GIMME == G_SCALAR)
779 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
783 else if (PL_op->op_flags & OPf_MOD
784 && PL_op->op_private & OPpLVAL_INTRO)
785 Perl_croak(aTHX_ PL_no_localize_ref);
788 if (SvTYPE(sv) == SVt_PVAV) {
790 if (PL_op->op_flags & OPf_REF) {
795 if (GIMME == G_SCALAR)
796 Perl_croak(aTHX_ "Can't return array to lvalue"
805 if (SvTYPE(sv) != SVt_PVGV) {
806 if (SvGMAGICAL(sv)) {
812 if (PL_op->op_flags & OPf_REF ||
813 PL_op->op_private & HINT_STRICT_REFS)
814 DIE(aTHX_ PL_no_usym, "an ARRAY");
815 if (ckWARN(WARN_UNINITIALIZED))
817 if (GIMME == G_ARRAY) {
823 if ((PL_op->op_flags & OPf_SPECIAL) &&
824 !(PL_op->op_flags & OPf_MOD))
826 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
828 && (!is_gv_magical_sv(sv,0)
829 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
835 if (PL_op->op_private & HINT_STRICT_REFS)
836 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
837 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
844 if (PL_op->op_private & OPpLVAL_INTRO)
846 if (PL_op->op_flags & OPf_REF) {
851 if (GIMME == G_SCALAR)
852 Perl_croak(aTHX_ "Can't return array to lvalue"
860 if (GIMME == G_ARRAY) {
861 const I32 maxarg = AvFILL(av) + 1;
862 (void)POPs; /* XXXX May be optimized away? */
864 if (SvRMAGICAL(av)) {
866 for (i=0; i < (U32)maxarg; i++) {
867 SV ** const svp = av_fetch(av, i, FALSE);
868 /* See note in pp_helem, and bug id #27839 */
870 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
875 Copy(AvARRAY(av), SP+1, maxarg, SV*);
879 else if (GIMME_V == G_SCALAR) {
881 const I32 maxarg = AvFILL(av) + 1;
891 const I32 gimme = GIMME_V;
892 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
896 tryAMAGICunDEREF(to_hv);
899 if (SvTYPE(hv) != SVt_PVHV)
900 DIE(aTHX_ "Not a HASH reference");
901 if (PL_op->op_flags & OPf_REF) {
906 if (gimme != G_ARRAY)
907 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
911 else if (PL_op->op_flags & OPf_MOD
912 && PL_op->op_private & OPpLVAL_INTRO)
913 Perl_croak(aTHX_ PL_no_localize_ref);
916 if (SvTYPE(sv) == SVt_PVHV) {
918 if (PL_op->op_flags & OPf_REF) {
923 if (gimme != G_ARRAY)
924 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
932 if (SvTYPE(sv) != SVt_PVGV) {
933 if (SvGMAGICAL(sv)) {
939 if (PL_op->op_flags & OPf_REF ||
940 PL_op->op_private & HINT_STRICT_REFS)
941 DIE(aTHX_ PL_no_usym, "a HASH");
942 if (ckWARN(WARN_UNINITIALIZED))
944 if (gimme == G_ARRAY) {
950 if ((PL_op->op_flags & OPf_SPECIAL) &&
951 !(PL_op->op_flags & OPf_MOD))
953 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
955 && (!is_gv_magical_sv(sv,0)
956 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
962 if (PL_op->op_private & HINT_STRICT_REFS)
963 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
964 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
971 if (PL_op->op_private & OPpLVAL_INTRO)
973 if (PL_op->op_flags & OPf_REF) {
978 if (gimme != G_ARRAY)
979 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
986 if (gimme == G_ARRAY) { /* array wanted */
987 *PL_stack_sp = (SV*)hv;
990 else if (gimme == G_SCALAR) {
992 TARG = Perl_hv_scalar(aTHX_ hv);
999 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1006 if (ckWARN(WARN_MISC)) {
1008 if (relem == firstrelem &&
1010 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1011 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1013 err = "Reference found where even-sized list expected";
1016 err = "Odd number of elements in hash assignment";
1017 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1021 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1022 if (SvMAGICAL(hash)) {
1023 if (SvSMAGICAL(tmpstr))
1035 SV **lastlelem = PL_stack_sp;
1036 SV **lastrelem = PL_stack_base + POPMARK;
1037 SV **firstrelem = PL_stack_base + POPMARK + 1;
1038 SV **firstlelem = lastrelem + 1;
1040 register SV **relem;
1041 register SV **lelem;
1051 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1054 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1057 /* If there's a common identifier on both sides we have to take
1058 * special care that assigning the identifier on the left doesn't
1059 * clobber a value on the right that's used later in the list.
1061 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1062 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1063 for (relem = firstrelem; relem <= lastrelem; relem++) {
1064 if ((sv = *relem)) {
1065 TAINT_NOT; /* Each item is independent */
1066 *relem = sv_mortalcopy(sv);
1076 while (lelem <= lastlelem) {
1077 TAINT_NOT; /* Each item stands on its own, taintwise. */
1079 switch (SvTYPE(sv)) {
1082 magic = SvMAGICAL(ary) != 0;
1084 av_extend(ary, lastrelem - relem);
1086 while (relem <= lastrelem) { /* gobble up all the rest */
1089 sv = newSVsv(*relem);
1091 didstore = av_store(ary,i++,sv);
1101 case SVt_PVHV: { /* normal hash */
1105 magic = SvMAGICAL(hash) != 0;
1107 firsthashrelem = relem;
1109 while (relem < lastrelem) { /* gobble up all the rest */
1111 sv = *relem ? *relem : &PL_sv_no;
1115 sv_setsv(tmpstr,*relem); /* value */
1116 *(relem++) = tmpstr;
1117 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1118 /* key overwrites an existing entry */
1120 didstore = hv_store_ent(hash,sv,tmpstr,0);
1122 if (SvSMAGICAL(tmpstr))
1129 if (relem == lastrelem) {
1130 do_oddball(hash, relem, firstrelem);
1136 if (SvIMMORTAL(sv)) {
1137 if (relem <= lastrelem)
1141 if (relem <= lastrelem) {
1142 sv_setsv(sv, *relem);
1146 sv_setsv(sv, &PL_sv_undef);
1151 if (PL_delaymagic & ~DM_DELAY) {
1152 if (PL_delaymagic & DM_UID) {
1153 #ifdef HAS_SETRESUID
1154 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1155 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1158 # ifdef HAS_SETREUID
1159 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1160 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1163 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1164 (void)setruid(PL_uid);
1165 PL_delaymagic &= ~DM_RUID;
1167 # endif /* HAS_SETRUID */
1169 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1170 (void)seteuid(PL_euid);
1171 PL_delaymagic &= ~DM_EUID;
1173 # endif /* HAS_SETEUID */
1174 if (PL_delaymagic & DM_UID) {
1175 if (PL_uid != PL_euid)
1176 DIE(aTHX_ "No setreuid available");
1177 (void)PerlProc_setuid(PL_uid);
1179 # endif /* HAS_SETREUID */
1180 #endif /* HAS_SETRESUID */
1181 PL_uid = PerlProc_getuid();
1182 PL_euid = PerlProc_geteuid();
1184 if (PL_delaymagic & DM_GID) {
1185 #ifdef HAS_SETRESGID
1186 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1187 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1190 # ifdef HAS_SETREGID
1191 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1192 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1195 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1196 (void)setrgid(PL_gid);
1197 PL_delaymagic &= ~DM_RGID;
1199 # endif /* HAS_SETRGID */
1201 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1202 (void)setegid(PL_egid);
1203 PL_delaymagic &= ~DM_EGID;
1205 # endif /* HAS_SETEGID */
1206 if (PL_delaymagic & DM_GID) {
1207 if (PL_gid != PL_egid)
1208 DIE(aTHX_ "No setregid available");
1209 (void)PerlProc_setgid(PL_gid);
1211 # endif /* HAS_SETREGID */
1212 #endif /* HAS_SETRESGID */
1213 PL_gid = PerlProc_getgid();
1214 PL_egid = PerlProc_getegid();
1216 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1220 if (gimme == G_VOID)
1221 SP = firstrelem - 1;
1222 else if (gimme == G_SCALAR) {
1225 SETi(lastrelem - firstrelem + 1 - duplicates);
1232 /* Removes from the stack the entries which ended up as
1233 * duplicated keys in the hash (fix for [perl #24380]) */
1234 Move(firsthashrelem + duplicates,
1235 firsthashrelem, duplicates, SV**);
1236 lastrelem -= duplicates;
1241 SP = firstrelem + (lastlelem - firstlelem);
1242 lelem = firstlelem + (relem - firstrelem);
1244 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1252 register PMOP * const pm = cPMOP;
1253 SV * const rv = sv_newmortal();
1254 SV * const sv = newSVrv(rv, "Regexp");
1255 if (pm->op_pmdynflags & PMdf_TAINTED)
1257 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1264 register PMOP *pm = cPMOP;
1266 register const char *t;
1267 register const char *s;
1270 I32 r_flags = REXEC_CHECKED;
1271 const char *truebase; /* Start of string */
1272 register REGEXP *rx = PM_GETRE(pm);
1274 const I32 gimme = GIMME;
1277 const I32 oldsave = PL_savestack_ix;
1278 I32 update_minmatch = 1;
1279 I32 had_zerolen = 0;
1281 if (PL_op->op_flags & OPf_STACKED)
1283 else if (PL_op->op_private & OPpTARGET_MY)
1290 PUTBACK; /* EVAL blocks need stack_sp. */
1291 s = SvPV_const(TARG, len);
1293 DIE(aTHX_ "panic: pp_match");
1295 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1296 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1299 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1301 /* PMdf_USED is set after a ?? matches once */
1302 if (pm->op_pmdynflags & PMdf_USED) {
1304 if (gimme == G_ARRAY)
1309 /* empty pattern special-cased to use last successful pattern if possible */
1310 if (!rx->prelen && PL_curpm) {
1315 if (rx->minlen > (I32)len)
1320 /* XXXX What part of this is needed with true \G-support? */
1321 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1323 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1324 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1325 if (mg && mg->mg_len >= 0) {
1326 if (!(rx->reganch & ROPT_GPOS_SEEN))
1327 rx->endp[0] = rx->startp[0] = mg->mg_len;
1328 else if (rx->reganch & ROPT_ANCH_GPOS) {
1329 r_flags |= REXEC_IGNOREPOS;
1330 rx->endp[0] = rx->startp[0] = mg->mg_len;
1332 minmatch = (mg->mg_flags & MGf_MINMATCH);
1333 update_minmatch = 0;
1337 if ((!global && rx->nparens)
1338 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1339 r_flags |= REXEC_COPY_STR;
1341 r_flags |= REXEC_SCREAM;
1344 if (global && rx->startp[0] != -1) {
1345 t = s = rx->endp[0] + truebase;
1346 if ((s + rx->minlen) > strend)
1348 if (update_minmatch++)
1349 minmatch = had_zerolen;
1351 if (rx->reganch & RE_USE_INTUIT &&
1352 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1353 /* FIXME - can PL_bostr be made const char *? */
1354 PL_bostr = (char *)truebase;
1355 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1359 if ( (rx->reganch & ROPT_CHECK_ALL)
1361 && ((rx->reganch & ROPT_NOSCAN)
1362 || !((rx->reganch & RE_INTUIT_TAIL)
1363 && (r_flags & REXEC_SCREAM)))
1364 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1367 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1370 if (dynpm->op_pmflags & PMf_ONCE)
1371 dynpm->op_pmdynflags |= PMdf_USED;
1380 RX_MATCH_TAINTED_on(rx);
1381 TAINT_IF(RX_MATCH_TAINTED(rx));
1382 if (gimme == G_ARRAY) {
1383 const I32 nparens = rx->nparens;
1384 I32 i = (global && !nparens) ? 1 : 0;
1386 SPAGAIN; /* EVAL blocks could move the stack. */
1387 EXTEND(SP, nparens + i);
1388 EXTEND_MORTAL(nparens + i);
1389 for (i = !i; i <= nparens; i++) {
1390 PUSHs(sv_newmortal());
1391 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1392 const I32 len = rx->endp[i] - rx->startp[i];
1393 s = rx->startp[i] + truebase;
1394 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1395 len < 0 || len > strend - s)
1396 DIE(aTHX_ "panic: pp_match start/end pointers");
1397 sv_setpvn(*SP, s, len);
1398 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1403 if (dynpm->op_pmflags & PMf_CONTINUE) {
1405 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1406 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408 sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
1409 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1411 if (rx->startp[0] != -1) {
1412 mg->mg_len = rx->endp[0];
1413 if (rx->startp[0] == rx->endp[0])
1414 mg->mg_flags |= MGf_MINMATCH;
1416 mg->mg_flags &= ~MGf_MINMATCH;
1419 had_zerolen = (rx->startp[0] != -1
1420 && rx->startp[0] == rx->endp[0]);
1421 PUTBACK; /* EVAL blocks may use stack */
1422 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1427 LEAVE_SCOPE(oldsave);
1433 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1434 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1438 sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
1439 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441 if (rx->startp[0] != -1) {
1442 mg->mg_len = rx->endp[0];
1443 if (rx->startp[0] == rx->endp[0])
1444 mg->mg_flags |= MGf_MINMATCH;
1446 mg->mg_flags &= ~MGf_MINMATCH;
1449 LEAVE_SCOPE(oldsave);
1453 yup: /* Confirmed by INTUIT */
1455 RX_MATCH_TAINTED_on(rx);
1456 TAINT_IF(RX_MATCH_TAINTED(rx));
1458 if (dynpm->op_pmflags & PMf_ONCE)
1459 dynpm->op_pmdynflags |= PMdf_USED;
1460 if (RX_MATCH_COPIED(rx))
1461 Safefree(rx->subbeg);
1462 RX_MATCH_COPIED_off(rx);
1465 /* FIXME - should rx->subbeg be const char *? */
1466 rx->subbeg = (char *) truebase;
1467 rx->startp[0] = s - truebase;
1468 if (RX_MATCH_UTF8(rx)) {
1469 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1470 rx->endp[0] = t - truebase;
1473 rx->endp[0] = s - truebase + rx->minlen;
1475 rx->sublen = strend - truebase;
1478 if (PL_sawampersand) {
1480 #ifdef PERL_OLD_COPY_ON_WRITE
1481 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1483 PerlIO_printf(Perl_debug_log,
1484 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1485 (int) SvTYPE(TARG), truebase, t,
1488 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1489 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1490 assert (SvPOKp(rx->saved_copy));
1495 rx->subbeg = savepvn(t, strend - t);
1496 #ifdef PERL_OLD_COPY_ON_WRITE
1497 rx->saved_copy = NULL;
1500 rx->sublen = strend - t;
1501 RX_MATCH_COPIED_on(rx);
1502 off = rx->startp[0] = s - t;
1503 rx->endp[0] = off + rx->minlen;
1505 else { /* startp/endp are used by @- @+. */
1506 rx->startp[0] = s - truebase;
1507 rx->endp[0] = s - truebase + rx->minlen;
1509 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1510 LEAVE_SCOPE(oldsave);
1515 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1516 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1517 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1522 LEAVE_SCOPE(oldsave);
1523 if (gimme == G_ARRAY)
1529 Perl_do_readline(pTHX)
1531 dVAR; dSP; dTARGETSTACKED;
1536 register IO * const io = GvIO(PL_last_in_gv);
1537 register const I32 type = PL_op->op_type;
1538 const I32 gimme = GIMME_V;
1541 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1544 XPUSHs(SvTIED_obj((SV*)io, mg));
1547 call_method("READLINE", gimme);
1550 if (gimme == G_SCALAR) {
1551 SV* const result = POPs;
1552 SvSetSV_nosteal(TARG, result);
1562 if (IoFLAGS(io) & IOf_ARGV) {
1563 if (IoFLAGS(io) & IOf_START) {
1565 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1566 IoFLAGS(io) &= ~IOf_START;
1567 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1568 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1569 SvSETMAGIC(GvSV(PL_last_in_gv));
1574 fp = nextargv(PL_last_in_gv);
1575 if (!fp) { /* Note: fp != IoIFP(io) */
1576 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1579 else if (type == OP_GLOB)
1580 fp = Perl_start_glob(aTHX_ POPs, io);
1582 else if (type == OP_GLOB)
1584 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1585 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1589 if ((!io || !(IoFLAGS(io) & IOf_START))
1590 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1592 if (type == OP_GLOB)
1593 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1594 "glob failed (can't start child: %s)",
1597 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1599 if (gimme == G_SCALAR) {
1600 /* undef TARG, and push that undefined value */
1601 if (type != OP_RCATLINE) {
1602 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1610 if (gimme == G_SCALAR) {
1614 else if (isGV_with_GP(sv)) {
1615 SvPV_force_nolen(sv);
1617 SvUPGRADE(sv, SVt_PV);
1618 tmplen = SvLEN(sv); /* remember if already alloced */
1619 if (!tmplen && !SvREADONLY(sv))
1620 Sv_Grow(sv, 80); /* try short-buffering it */
1622 if (type == OP_RCATLINE && SvOK(sv)) {
1624 SvPV_force_nolen(sv);
1630 sv = sv_2mortal(newSV(80));
1634 /* This should not be marked tainted if the fp is marked clean */
1635 #define MAYBE_TAINT_LINE(io, sv) \
1636 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1641 /* delay EOF state for a snarfed empty file */
1642 #define SNARF_EOF(gimme,rs,io,sv) \
1643 (gimme != G_SCALAR || SvCUR(sv) \
1644 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1648 if (!sv_gets(sv, fp, offset)
1650 || SNARF_EOF(gimme, PL_rs, io, sv)
1651 || PerlIO_error(fp)))
1653 PerlIO_clearerr(fp);
1654 if (IoFLAGS(io) & IOf_ARGV) {
1655 fp = nextargv(PL_last_in_gv);
1658 (void)do_close(PL_last_in_gv, FALSE);
1660 else if (type == OP_GLOB) {
1661 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1662 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1663 "glob failed (child exited with status %d%s)",
1664 (int)(STATUS_CURRENT >> 8),
1665 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1668 if (gimme == G_SCALAR) {
1669 if (type != OP_RCATLINE) {
1670 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1676 MAYBE_TAINT_LINE(io, sv);
1679 MAYBE_TAINT_LINE(io, sv);
1681 IoFLAGS(io) |= IOf_NOLINE;
1685 if (type == OP_GLOB) {
1688 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1689 char * const tmps = SvEND(sv) - 1;
1690 if (*tmps == *SvPVX_const(PL_rs)) {
1692 SvCUR_set(sv, SvCUR(sv) - 1);
1695 for (t1 = SvPVX_const(sv); *t1; t1++)
1696 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1697 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1699 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1700 (void)POPs; /* Unmatched wildcard? Chuck it... */
1703 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1704 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1705 const STRLEN len = SvCUR(sv) - offset;
1708 if (ckWARN(WARN_UTF8) &&
1709 !is_utf8_string_loc(s, len, &f))
1710 /* Emulate :encoding(utf8) warning in the same case. */
1711 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1712 "utf8 \"\\x%02X\" does not map to Unicode",
1713 f < (U8*)SvEND(sv) ? *f : 0);
1715 if (gimme == G_ARRAY) {
1716 if (SvLEN(sv) - SvCUR(sv) > 20) {
1717 SvPV_shrink_to_cur(sv);
1719 sv = sv_2mortal(newSV(80));
1722 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1723 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1724 const STRLEN new_len
1725 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1726 SvPV_renew(sv, new_len);
1735 register PERL_CONTEXT *cx;
1736 I32 gimme = OP_GIMME(PL_op, -1);
1739 if (cxstack_ix >= 0)
1740 gimme = cxstack[cxstack_ix].blk_gimme;
1748 PUSHBLOCK(cx, CXt_BLOCK, SP);
1758 SV * const keysv = POPs;
1759 HV * const hv = (HV*)POPs;
1760 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1761 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1763 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1766 if (SvTYPE(hv) == SVt_PVHV) {
1767 if (PL_op->op_private & OPpLVAL_INTRO) {
1770 /* does the element we're localizing already exist? */
1772 /* can we determine whether it exists? */
1774 || mg_find((SV*)hv, PERL_MAGIC_env)
1775 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1776 /* Try to preserve the existenceness of a tied hash
1777 * element by using EXISTS and DELETE if possible.
1778 * Fallback to FETCH and STORE otherwise */
1779 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1780 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1781 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1783 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1786 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1787 svp = he ? &HeVAL(he) : NULL;
1793 if (!svp || *svp == &PL_sv_undef) {
1797 DIE(aTHX_ PL_no_helem_sv, keysv);
1799 lv = sv_newmortal();
1800 sv_upgrade(lv, SVt_PVLV);
1802 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1803 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1804 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1809 if (PL_op->op_private & OPpLVAL_INTRO) {
1810 if (HvNAME_get(hv) && isGV(*svp))
1811 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1815 const char * const key = SvPV_const(keysv, keylen);
1816 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1818 save_helem(hv, keysv, svp);
1821 else if (PL_op->op_private & OPpDEREF)
1822 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1824 sv = (svp ? *svp : &PL_sv_undef);
1825 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1826 * Pushing the magical RHS on to the stack is useless, since
1827 * that magic is soon destined to be misled by the local(),
1828 * and thus the later pp_sassign() will fail to mg_get() the
1829 * old value. This should also cure problems with delayed
1830 * mg_get()s. GSAR 98-07-03 */
1831 if (!lval && SvGMAGICAL(sv))
1832 sv = sv_mortalcopy(sv);
1840 register PERL_CONTEXT *cx;
1845 if (PL_op->op_flags & OPf_SPECIAL) {
1846 cx = &cxstack[cxstack_ix];
1847 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1852 gimme = OP_GIMME(PL_op, -1);
1854 if (cxstack_ix >= 0)
1855 gimme = cxstack[cxstack_ix].blk_gimme;
1861 if (gimme == G_VOID)
1863 else if (gimme == G_SCALAR) {
1867 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1870 *MARK = sv_mortalcopy(TOPs);
1873 *MARK = &PL_sv_undef;
1877 else if (gimme == G_ARRAY) {
1878 /* in case LEAVE wipes old return values */
1880 for (mark = newsp + 1; mark <= SP; mark++) {
1881 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1882 *mark = sv_mortalcopy(*mark);
1883 TAINT_NOT; /* Each item is independent */
1887 PL_curpm = newpm; /* Don't pop $1 et al till now */
1897 register PERL_CONTEXT *cx;
1903 cx = &cxstack[cxstack_ix];
1904 if (CxTYPE(cx) != CXt_LOOP)
1905 DIE(aTHX_ "panic: pp_iter");
1907 itersvp = CxITERVAR(cx);
1908 av = cx->blk_loop.iterary;
1909 if (SvTYPE(av) != SVt_PVAV) {
1910 /* iterate ($min .. $max) */
1911 if (cx->blk_loop.iterlval) {
1912 /* string increment */
1913 register SV* cur = cx->blk_loop.iterlval;
1915 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1916 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1917 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1918 /* safe to reuse old SV */
1919 sv_setsv(*itersvp, cur);
1923 /* we need a fresh SV every time so that loop body sees a
1924 * completely new SV for closures/references to work as
1927 *itersvp = newSVsv(cur);
1928 SvREFCNT_dec(oldsv);
1930 if (strEQ(SvPVX_const(cur), max))
1931 sv_setiv(cur, 0); /* terminate next time */
1938 /* integer increment */
1939 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1942 /* don't risk potential race */
1943 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1944 /* safe to reuse old SV */
1945 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1949 /* we need a fresh SV every time so that loop body sees a
1950 * completely new SV for closures/references to work as they
1953 *itersvp = newSViv(cx->blk_loop.iterix++);
1954 SvREFCNT_dec(oldsv);
1960 if (PL_op->op_private & OPpITER_REVERSED) {
1961 /* In reverse, use itermax as the min :-) */
1962 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1965 if (SvMAGICAL(av) || AvREIFY(av)) {
1966 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1967 sv = svp ? *svp : NULL;
1970 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1974 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1978 if (SvMAGICAL(av) || AvREIFY(av)) {
1979 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1980 sv = svp ? *svp : NULL;
1983 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1987 if (sv && SvIS_FREED(sv)) {
1989 Perl_croak(aTHX_ "Use of freed value in iteration");
1996 if (av != PL_curstack && sv == &PL_sv_undef) {
1997 SV *lv = cx->blk_loop.iterlval;
1998 if (lv && SvREFCNT(lv) > 1) {
2003 SvREFCNT_dec(LvTARG(lv));
2005 lv = cx->blk_loop.iterlval = newSV(0);
2006 sv_upgrade(lv, SVt_PVLV);
2008 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2010 LvTARG(lv) = SvREFCNT_inc_simple(av);
2011 LvTARGOFF(lv) = cx->blk_loop.iterix;
2012 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2017 *itersvp = SvREFCNT_inc_simple_NN(sv);
2018 SvREFCNT_dec(oldsv);
2026 register PMOP *pm = cPMOP;
2041 register REGEXP *rx = PM_GETRE(pm);
2043 int force_on_match = 0;
2044 const I32 oldsave = PL_savestack_ix;
2046 bool doutf8 = FALSE;
2047 #ifdef PERL_OLD_COPY_ON_WRITE
2052 /* known replacement string? */
2053 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2054 if (PL_op->op_flags & OPf_STACKED)
2056 else if (PL_op->op_private & OPpTARGET_MY)
2063 #ifdef PERL_OLD_COPY_ON_WRITE
2064 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2065 because they make integers such as 256 "false". */
2066 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2069 sv_force_normal_flags(TARG,0);
2072 #ifdef PERL_OLD_COPY_ON_WRITE
2076 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2077 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2078 DIE(aTHX_ PL_no_modify);
2081 s = SvPV_mutable(TARG, len);
2082 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2084 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2085 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2090 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2094 DIE(aTHX_ "panic: pp_subst");
2097 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2098 maxiters = 2 * slen + 10; /* We can match twice at each
2099 position, once with zero-length,
2100 second time with non-zero. */
2102 if (!rx->prelen && PL_curpm) {
2106 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2107 || (pm->op_pmflags & PMf_EVAL))
2108 ? REXEC_COPY_STR : 0;
2110 r_flags |= REXEC_SCREAM;
2113 if (rx->reganch & RE_USE_INTUIT) {
2115 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2119 /* How to do it in subst? */
2120 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2122 && ((rx->reganch & ROPT_NOSCAN)
2123 || !((rx->reganch & RE_INTUIT_TAIL)
2124 && (r_flags & REXEC_SCREAM))))
2129 /* only replace once? */
2130 once = !(rpm->op_pmflags & PMf_GLOBAL);
2132 /* known replacement string? */
2134 /* replacement needing upgrading? */
2135 if (DO_UTF8(TARG) && !doutf8) {
2136 nsv = sv_newmortal();
2139 sv_recode_to_utf8(nsv, PL_encoding);
2141 sv_utf8_upgrade(nsv);
2142 c = SvPV_const(nsv, clen);
2146 c = SvPV_const(dstr, clen);
2147 doutf8 = DO_UTF8(dstr);
2155 /* can do inplace substitution? */
2157 #ifdef PERL_OLD_COPY_ON_WRITE
2160 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2161 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2162 && (!doutf8 || SvUTF8(TARG))) {
2163 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2164 r_flags | REXEC_CHECKED))
2168 LEAVE_SCOPE(oldsave);
2171 #ifdef PERL_OLD_COPY_ON_WRITE
2172 if (SvIsCOW(TARG)) {
2173 assert (!force_on_match);
2177 if (force_on_match) {
2179 s = SvPV_force(TARG, len);
2184 SvSCREAM_off(TARG); /* disable possible screamer */
2186 rxtainted |= RX_MATCH_TAINTED(rx);
2187 m = orig + rx->startp[0];
2188 d = orig + rx->endp[0];
2190 if (m - s > strend - d) { /* faster to shorten from end */
2192 Copy(c, m, clen, char);
2197 Move(d, m, i, char);
2201 SvCUR_set(TARG, m - s);
2203 else if ((i = m - s)) { /* faster from front */
2211 Copy(c, m, clen, char);
2216 Copy(c, d, clen, char);
2221 TAINT_IF(rxtainted & 1);
2227 if (iters++ > maxiters)
2228 DIE(aTHX_ "Substitution loop");
2229 rxtainted |= RX_MATCH_TAINTED(rx);
2230 m = rx->startp[0] + orig;
2233 Move(s, d, i, char);
2237 Copy(c, d, clen, char);
2240 s = rx->endp[0] + orig;
2241 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2243 /* don't match same null twice */
2244 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2247 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2248 Move(s, d, i+1, char); /* include the NUL */
2250 TAINT_IF(rxtainted & 1);
2252 PUSHs(sv_2mortal(newSViv((I32)iters)));
2254 (void)SvPOK_only_UTF8(TARG);
2255 TAINT_IF(rxtainted);
2256 if (SvSMAGICAL(TARG)) {
2264 LEAVE_SCOPE(oldsave);
2268 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2269 r_flags | REXEC_CHECKED))
2271 if (force_on_match) {
2273 s = SvPV_force(TARG, len);
2276 #ifdef PERL_OLD_COPY_ON_WRITE
2279 rxtainted |= RX_MATCH_TAINTED(rx);
2280 dstr = newSVpvn(m, s-m);
2285 register PERL_CONTEXT *cx;
2287 (void)ReREFCNT_inc(rx);
2289 RETURNOP(cPMOP->op_pmreplroot);
2291 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2293 if (iters++ > maxiters)
2294 DIE(aTHX_ "Substitution loop");
2295 rxtainted |= RX_MATCH_TAINTED(rx);
2296 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2301 strend = s + (strend - m);
2303 m = rx->startp[0] + orig;
2304 if (doutf8 && !SvUTF8(dstr))
2305 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2307 sv_catpvn(dstr, s, m-s);
2308 s = rx->endp[0] + orig;
2310 sv_catpvn(dstr, c, clen);
2313 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2314 TARG, NULL, r_flags));
2315 if (doutf8 && !DO_UTF8(TARG))
2316 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2318 sv_catpvn(dstr, s, strend - s);
2320 #ifdef PERL_OLD_COPY_ON_WRITE
2321 /* The match may make the string COW. If so, brilliant, because that's
2322 just saved us one malloc, copy and free - the regexp has donated
2323 the old buffer, and we malloc an entirely new one, rather than the
2324 regexp malloc()ing a buffer and copying our original, only for
2325 us to throw it away here during the substitution. */
2326 if (SvIsCOW(TARG)) {
2327 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2333 SvPV_set(TARG, SvPVX(dstr));
2334 SvCUR_set(TARG, SvCUR(dstr));
2335 SvLEN_set(TARG, SvLEN(dstr));
2336 doutf8 |= DO_UTF8(dstr);
2337 SvPV_set(dstr, NULL);
2340 TAINT_IF(rxtainted & 1);
2342 PUSHs(sv_2mortal(newSViv((I32)iters)));
2344 (void)SvPOK_only(TARG);
2347 TAINT_IF(rxtainted);
2350 LEAVE_SCOPE(oldsave);
2359 LEAVE_SCOPE(oldsave);
2368 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2369 ++*PL_markstack_ptr;
2370 LEAVE; /* exit inner scope */
2373 if (PL_stack_base + *PL_markstack_ptr > SP) {
2375 const I32 gimme = GIMME_V;
2377 LEAVE; /* exit outer scope */
2378 (void)POPMARK; /* pop src */
2379 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2380 (void)POPMARK; /* pop dst */
2381 SP = PL_stack_base + POPMARK; /* pop original mark */
2382 if (gimme == G_SCALAR) {
2383 if (PL_op->op_private & OPpGREP_LEX) {
2384 SV* const sv = sv_newmortal();
2385 sv_setiv(sv, items);
2393 else if (gimme == G_ARRAY)
2400 ENTER; /* enter inner scope */
2403 src = PL_stack_base[*PL_markstack_ptr];
2405 if (PL_op->op_private & OPpGREP_LEX)
2406 PAD_SVl(PL_op->op_targ) = src;
2410 RETURNOP(cLOGOP->op_other);
2421 register PERL_CONTEXT *cx;
2424 if (CxMULTICALL(&cxstack[cxstack_ix]))
2428 cxstack_ix++; /* temporarily protect top context */
2431 if (gimme == G_SCALAR) {
2434 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2436 *MARK = SvREFCNT_inc(TOPs);
2441 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2443 *MARK = sv_mortalcopy(sv);
2448 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2452 *MARK = &PL_sv_undef;
2456 else if (gimme == G_ARRAY) {
2457 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2458 if (!SvTEMP(*MARK)) {
2459 *MARK = sv_mortalcopy(*MARK);
2460 TAINT_NOT; /* Each item is independent */
2468 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2469 PL_curpm = newpm; /* ... and pop $1 et al */
2472 return cx->blk_sub.retop;
2475 /* This duplicates the above code because the above code must not
2476 * get any slower by more conditions */
2484 register PERL_CONTEXT *cx;
2487 if (CxMULTICALL(&cxstack[cxstack_ix]))
2491 cxstack_ix++; /* temporarily protect top context */
2495 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2496 /* We are an argument to a function or grep().
2497 * This kind of lvalueness was legal before lvalue
2498 * subroutines too, so be backward compatible:
2499 * cannot report errors. */
2501 /* Scalar context *is* possible, on the LHS of -> only,
2502 * as in f()->meth(). But this is not an lvalue. */
2503 if (gimme == G_SCALAR)
2505 if (gimme == G_ARRAY) {
2506 if (!CvLVALUE(cx->blk_sub.cv))
2507 goto temporise_array;
2508 EXTEND_MORTAL(SP - newsp);
2509 for (mark = newsp + 1; mark <= SP; mark++) {
2512 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2513 *mark = sv_mortalcopy(*mark);
2515 /* Can be a localized value subject to deletion. */
2516 PL_tmps_stack[++PL_tmps_ix] = *mark;
2517 SvREFCNT_inc_void(*mark);
2522 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2523 /* Here we go for robustness, not for speed, so we change all
2524 * the refcounts so the caller gets a live guy. Cannot set
2525 * TEMP, so sv_2mortal is out of question. */
2526 if (!CvLVALUE(cx->blk_sub.cv)) {
2532 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2534 if (gimme == G_SCALAR) {
2538 /* Temporaries are bad unless they happen to be elements
2539 * of a tied hash or array */
2540 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2541 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2547 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2548 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2549 : "a readonly value" : "a temporary");
2551 else { /* Can be a localized value
2552 * subject to deletion. */
2553 PL_tmps_stack[++PL_tmps_ix] = *mark;
2554 SvREFCNT_inc_void(*mark);
2557 else { /* Should not happen? */
2563 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2564 (MARK > SP ? "Empty array" : "Array"));
2568 else if (gimme == G_ARRAY) {
2569 EXTEND_MORTAL(SP - newsp);
2570 for (mark = newsp + 1; mark <= SP; mark++) {
2571 if (*mark != &PL_sv_undef
2572 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2573 /* Might be flattened array after $#array = */
2580 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2581 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2584 /* Can be a localized value subject to deletion. */
2585 PL_tmps_stack[++PL_tmps_ix] = *mark;
2586 SvREFCNT_inc_void(*mark);
2592 if (gimme == G_SCALAR) {
2596 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2598 *MARK = SvREFCNT_inc(TOPs);
2603 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2605 *MARK = sv_mortalcopy(sv);
2610 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2614 *MARK = &PL_sv_undef;
2618 else if (gimme == G_ARRAY) {
2620 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2621 if (!SvTEMP(*MARK)) {
2622 *MARK = sv_mortalcopy(*MARK);
2623 TAINT_NOT; /* Each item is independent */
2632 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2633 PL_curpm = newpm; /* ... and pop $1 et al */
2636 return cx->blk_sub.retop;
2641 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2644 SV * const dbsv = GvSVn(PL_DBsub);
2647 if (!PERLDB_SUB_NN) {
2648 GV * const gv = CvGV(cv);
2650 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2651 || strEQ(GvNAME(gv), "END")
2652 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2653 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2654 /* Use GV from the stack as a fallback. */
2655 /* GV is potentially non-unique, or contain different CV. */
2656 SV * const tmp = newRV((SV*)cv);
2657 sv_setsv(dbsv, tmp);
2661 gv_efullname3(dbsv, gv, NULL);
2665 const int type = SvTYPE(dbsv);
2666 if (type < SVt_PVIV && type != SVt_IV)
2667 sv_upgrade(dbsv, SVt_PVIV);
2668 (void)SvIOK_on(dbsv);
2669 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2673 PL_curcopdb = PL_curcop;
2674 cv = GvCV(PL_DBsub);
2683 register PERL_CONTEXT *cx;
2685 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2688 DIE(aTHX_ "Not a CODE reference");
2689 switch (SvTYPE(sv)) {
2690 /* This is overwhelming the most common case: */
2692 if (!(cv = GvCVu((GV*)sv))) {
2694 cv = sv_2cv(sv, &stash, &gv, 0);
2705 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2707 SP = PL_stack_base + POPMARK;
2710 if (SvGMAGICAL(sv)) {
2714 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2717 sym = SvPV_nolen_const(sv);
2720 DIE(aTHX_ PL_no_usym, "a subroutine");
2721 if (PL_op->op_private & HINT_STRICT_REFS)
2722 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2723 cv = get_cv(sym, TRUE);
2728 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2729 tryAMAGICunDEREF(to_cv);
2732 if (SvTYPE(cv) == SVt_PVCV)
2737 DIE(aTHX_ "Not a CODE reference");
2738 /* This is the second most common case: */
2748 if (!CvROOT(cv) && !CvXSUB(cv)) {
2752 /* anonymous or undef'd function leaves us no recourse */
2753 if (CvANON(cv) || !(gv = CvGV(cv)))
2754 DIE(aTHX_ "Undefined subroutine called");
2756 /* autoloaded stub? */
2757 if (cv != GvCV(gv)) {
2760 /* should call AUTOLOAD now? */
2763 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2770 sub_name = sv_newmortal();
2771 gv_efullname3(sub_name, gv, NULL);
2772 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2776 DIE(aTHX_ "Not a CODE reference");
2781 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2782 if (CvASSERTION(cv) && PL_DBassertion)
2783 sv_setiv(PL_DBassertion, 1);
2785 cv = get_db_sub(&sv, cv);
2786 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2787 DIE(aTHX_ "No DB::sub routine defined");
2790 if (!(CvISXSUB(cv))) {
2791 /* This path taken at least 75% of the time */
2793 register I32 items = SP - MARK;
2794 AV* const padlist = CvPADLIST(cv);
2795 PUSHBLOCK(cx, CXt_SUB, MARK);
2797 cx->blk_sub.retop = PL_op->op_next;
2799 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2800 * that eval'' ops within this sub know the correct lexical space.
2801 * Owing the speed considerations, we choose instead to search for
2802 * the cv using find_runcv() when calling doeval().
2804 if (CvDEPTH(cv) >= 2) {
2805 PERL_STACK_OVERFLOW_CHECK();
2806 pad_push(padlist, CvDEPTH(cv));
2809 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2812 AV* const av = (AV*)PAD_SVl(0);
2814 /* @_ is normally not REAL--this should only ever
2815 * happen when DB::sub() calls things that modify @_ */
2820 cx->blk_sub.savearray = GvAV(PL_defgv);
2821 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2822 CX_CURPAD_SAVE(cx->blk_sub);
2823 cx->blk_sub.argarray = av;
2826 if (items > AvMAX(av) + 1) {
2827 SV **ary = AvALLOC(av);
2828 if (AvARRAY(av) != ary) {
2829 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2830 SvPV_set(av, (char*)ary);
2832 if (items > AvMAX(av) + 1) {
2833 AvMAX(av) = items - 1;
2834 Renew(ary,items,SV*);
2836 SvPV_set(av, (char*)ary);
2839 Copy(MARK,AvARRAY(av),items,SV*);
2840 AvFILLp(av) = items - 1;
2848 /* warning must come *after* we fully set up the context
2849 * stuff so that __WARN__ handlers can safely dounwind()
2852 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2853 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2854 sub_crush_depth(cv);
2856 DEBUG_S(PerlIO_printf(Perl_debug_log,
2857 "%p entersub returning %p\n", thr, CvSTART(cv)));
2859 RETURNOP(CvSTART(cv));
2862 I32 markix = TOPMARK;
2867 /* Need to copy @_ to stack. Alternative may be to
2868 * switch stack to @_, and copy return values
2869 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2870 AV * const av = GvAV(PL_defgv);
2871 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2874 /* Mark is at the end of the stack. */
2876 Copy(AvARRAY(av), SP + 1, items, SV*);
2881 /* We assume first XSUB in &DB::sub is the called one. */
2883 SAVEVPTR(PL_curcop);
2884 PL_curcop = PL_curcopdb;
2887 /* Do we need to open block here? XXXX */
2888 (void)(*CvXSUB(cv))(aTHX_ cv);
2890 /* Enforce some sanity in scalar context. */
2891 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2892 if (markix > PL_stack_sp - PL_stack_base)
2893 *(PL_stack_base + markix) = &PL_sv_undef;
2895 *(PL_stack_base + markix) = *PL_stack_sp;
2896 PL_stack_sp = PL_stack_base + markix;
2904 Perl_sub_crush_depth(pTHX_ CV *cv)
2907 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2909 SV* const tmpstr = sv_newmortal();
2910 gv_efullname3(tmpstr, CvGV(cv), NULL);
2911 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2920 SV* const elemsv = POPs;
2921 IV elem = SvIV(elemsv);
2922 AV* const av = (AV*)POPs;
2923 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2924 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2927 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2928 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2930 elem -= PL_curcop->cop_arybase;
2931 if (SvTYPE(av) != SVt_PVAV)
2933 svp = av_fetch(av, elem, lval && !defer);
2935 #ifdef PERL_MALLOC_WRAP
2936 if (SvUOK(elemsv)) {
2937 const UV uv = SvUV(elemsv);
2938 elem = uv > IV_MAX ? IV_MAX : uv;
2940 else if (SvNOK(elemsv))
2941 elem = (IV)SvNV(elemsv);
2943 static const char oom_array_extend[] =
2944 "Out of memory during array extend"; /* Duplicated in av.c */
2945 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2948 if (!svp || *svp == &PL_sv_undef) {
2951 DIE(aTHX_ PL_no_aelem, elem);
2952 lv = sv_newmortal();
2953 sv_upgrade(lv, SVt_PVLV);
2955 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2956 LvTARG(lv) = SvREFCNT_inc_simple(av);
2957 LvTARGOFF(lv) = elem;
2962 if (PL_op->op_private & OPpLVAL_INTRO)
2963 save_aelem(av, elem, svp);
2964 else if (PL_op->op_private & OPpDEREF)
2965 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2967 sv = (svp ? *svp : &PL_sv_undef);
2968 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2969 sv = sv_mortalcopy(sv);
2975 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2980 Perl_croak(aTHX_ PL_no_modify);
2981 if (SvTYPE(sv) < SVt_RV)
2982 sv_upgrade(sv, SVt_RV);
2983 else if (SvTYPE(sv) >= SVt_PV) {
2990 SvRV_set(sv, newSV(0));
2993 SvRV_set(sv, (SV*)newAV());
2996 SvRV_set(sv, (SV*)newHV());
3007 SV* const sv = TOPs;
3010 SV* const rsv = SvRV(sv);
3011 if (SvTYPE(rsv) == SVt_PVCV) {
3017 SETs(method_common(sv, NULL));
3024 SV* const sv = cSVOP_sv;
3025 U32 hash = SvSHARED_HASH(sv);
3027 XPUSHs(method_common(sv, &hash));
3032 S_method_common(pTHX_ SV* meth, U32* hashp)
3039 const char* packname = NULL;
3042 const char * const name = SvPV_const(meth, namelen);
3043 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3046 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3054 /* this isn't a reference */
3055 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3056 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3058 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3065 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3066 !(ob=(SV*)GvIO(iogv)))
3068 /* this isn't the name of a filehandle either */
3070 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3071 ? !isIDFIRST_utf8((U8*)packname)
3072 : !isIDFIRST(*packname)
3075 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3076 SvOK(sv) ? "without a package or object reference"
3077 : "on an undefined value");
3079 /* assume it's a package name */
3080 stash = gv_stashpvn(packname, packlen, FALSE);
3084 SV* ref = newSViv(PTR2IV(stash));
3085 hv_store(PL_stashcache, packname, packlen, ref, 0);
3089 /* it _is_ a filehandle name -- replace with a reference */
3090 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3093 /* if we got here, ob should be a reference or a glob */
3094 if (!ob || !(SvOBJECT(ob)
3095 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3098 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3102 stash = SvSTASH(ob);
3105 /* NOTE: stash may be null, hope hv_fetch_ent and
3106 gv_fetchmethod can cope (it seems they can) */
3108 /* shortcut for simple names */
3110 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3112 gv = (GV*)HeVAL(he);
3113 if (isGV(gv) && GvCV(gv) &&
3114 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3115 return (SV*)GvCV(gv);
3119 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3122 /* This code tries to figure out just what went wrong with
3123 gv_fetchmethod. It therefore needs to duplicate a lot of
3124 the internals of that function. We can't move it inside
3125 Perl_gv_fetchmethod_autoload(), however, since that would
3126 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3129 const char* leaf = name;
3130 const char* sep = NULL;
3133 for (p = name; *p; p++) {
3135 sep = p, leaf = p + 1;
3136 else if (*p == ':' && *(p + 1) == ':')
3137 sep = p, leaf = p + 2;
3139 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3140 /* the method name is unqualified or starts with SUPER:: */
3141 bool need_strlen = 1;
3143 packname = CopSTASHPV(PL_curcop);
3146 HEK * const packhek = HvNAME_HEK(stash);
3148 packname = HEK_KEY(packhek);
3149 packlen = HEK_LEN(packhek);
3159 "Can't use anonymous symbol table for method lookup");
3161 else if (need_strlen)
3162 packlen = strlen(packname);
3166 /* the method name is qualified */
3168 packlen = sep - name;
3171 /* we're relying on gv_fetchmethod not autovivifying the stash */
3172 if (gv_stashpvn(packname, packlen, FALSE)) {
3174 "Can't locate object method \"%s\" via package \"%.*s\"",
3175 leaf, (int)packlen, packname);
3179 "Can't locate object method \"%s\" via package \"%.*s\""
3180 " (perhaps you forgot to load \"%.*s\"?)",
3181 leaf, (int)packlen, packname, (int)packlen, packname);
3184 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3189 * c-indentation-style: bsd
3191 * indent-tabs-mode: t
3194 * ex: set ts=8 sts=4 sw=4 noet: