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
47 PL_curcop = (COP*)PL_op;
48 TAINT_NOT; /* Each statement is presumed innocent */
49 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
58 if (PL_op->op_private & OPpLVAL_INTRO)
59 PUSHs(save_scalar(cGVOP_gv));
61 PUSHs(GvSVn(cGVOP_gv));
72 PL_curcop = (COP*)PL_op;
78 PUSHMARK(PL_stack_sp);
93 XPUSHs((SV*)cGVOP_gv);
103 if (PL_op->op_type == OP_AND)
105 RETURNOP(cLOGOP->op_other);
113 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
114 SV * const temp = left;
115 left = right; right = temp;
117 if (PL_tainting && PL_tainted && !SvTAINTED(left))
119 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
121 const U32 cv_type = SvTYPE(cv);
122 const U32 gv_type = SvTYPE(right);
123 bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
129 /* Can do the optimisation if right (LVAUE) is not a typeglob,
130 left (RVALUE) is a reference to something, and we're in void
132 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
133 /* Is the target symbol table currently empty? */
134 GV *gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
135 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
136 /* Good. Create a new proxy constant subroutine in the target.
137 The gv becomes a(nother) reference to the constant. */
138 SV *const value = SvRV(cv);
140 SvUPGRADE((SV *)gv, SVt_RV);
149 /* Need to fix things up. */
150 if (gv_type != SVt_PVGV) {
151 /* Need to fix GV. */
152 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
156 /* We've been returned a constant rather than a full subroutine,
157 but they expect a subroutine reference to apply. */
159 SvREFCNT_inc(SvRV(cv));
160 /* newCONSTSUB takes a reference count on the passed in SV
161 from us. We set the name to NULL, otherwise we get into
162 all sorts of fun as the reference to our new sub is
163 donated to the GV that we're about to assign to.
165 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
172 SvSetMagicSV(right, left);
181 RETURNOP(cLOGOP->op_other);
183 RETURNOP(cLOGOP->op_next);
189 TAINT_NOT; /* Each statement is presumed innocent */
190 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
192 oldsave = PL_scopestack[PL_scopestack_ix - 1];
193 LEAVE_SCOPE(oldsave);
199 dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
206 bool rcopied = FALSE;
208 if (TARG == right && right != left) {
209 /* mg_get(right) may happen here ... */
210 rpv = SvPV_const(right, rlen);
211 rbyte = !DO_UTF8(right);
212 right = sv_2mortal(newSVpvn(rpv, rlen));
213 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
219 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
220 lbyte = !DO_UTF8(left);
221 sv_setpvn(TARG, lpv, llen);
227 else { /* TARG == left */
229 SvGETMAGIC(left); /* or mg_get(left) may happen here */
231 if (left == right && ckWARN(WARN_UNINITIALIZED))
232 report_uninit(right);
233 sv_setpvn(left, "", 0);
235 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
236 lbyte = !DO_UTF8(left);
241 /* or mg_get(right) may happen here */
243 rpv = SvPV_const(right, rlen);
244 rbyte = !DO_UTF8(right);
246 if (lbyte != rbyte) {
248 sv_utf8_upgrade_nomg(TARG);
251 right = sv_2mortal(newSVpvn(rpv, rlen));
252 sv_utf8_upgrade_nomg(right);
253 rpv = SvPV_const(right, rlen);
256 sv_catpvn_nomg(TARG, rpv, rlen);
267 if (PL_op->op_flags & OPf_MOD) {
268 if (PL_op->op_private & OPpLVAL_INTRO)
269 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
270 if (PL_op->op_private & OPpDEREF) {
272 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
281 tryAMAGICunTARGET(iter, 0);
282 PL_last_in_gv = (GV*)(*PL_stack_sp--);
283 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
284 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
285 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
288 XPUSHs((SV*)PL_last_in_gv);
291 PL_last_in_gv = (GV*)(*PL_stack_sp--);
294 return do_readline();
299 dSP; tryAMAGICbinSET(eq,0);
300 #ifndef NV_PRESERVES_UV
301 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
303 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
307 #ifdef PERL_PRESERVE_IVUV
310 /* Unless the left argument is integer in range we are going
311 to have to use NV maths. Hence only attempt to coerce the
312 right argument if we know the left is integer. */
315 const bool auvok = SvUOK(TOPm1s);
316 const bool buvok = SvUOK(TOPs);
318 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
319 /* Casting IV to UV before comparison isn't going to matter
320 on 2s complement. On 1s complement or sign&magnitude
321 (if we have any of them) it could to make negative zero
322 differ from normal zero. As I understand it. (Need to
323 check - is negative zero implementation defined behaviour
325 const UV buv = SvUVX(POPs);
326 const UV auv = SvUVX(TOPs);
328 SETs(boolSV(auv == buv));
331 { /* ## Mixed IV,UV ## */
335 /* == is commutative so doesn't matter which is left or right */
337 /* top of stack (b) is the iv */
346 /* As uv is a UV, it's >0, so it cannot be == */
350 /* we know iv is >= 0 */
351 SETs(boolSV((UV)iv == SvUVX(uvp)));
359 SETs(boolSV(TOPn == value));
367 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
368 DIE(aTHX_ PL_no_modify);
369 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
370 && SvIVX(TOPs) != IV_MAX)
372 SvIV_set(TOPs, SvIVX(TOPs) + 1);
373 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
375 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
387 if (PL_op->op_type == OP_OR)
389 RETURNOP(cLOGOP->op_other);
396 register SV* sv = NULL;
397 bool defined = FALSE;
398 const int op_type = PL_op->op_type;
400 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
402 if (!sv || !SvANY(sv)) {
403 if (op_type == OP_DOR)
405 RETURNOP(cLOGOP->op_other);
407 } else if (op_type == OP_DEFINED) {
409 if (!sv || !SvANY(sv))
412 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
414 switch (SvTYPE(sv)) {
416 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
420 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
424 if (CvROOT(sv) || CvXSUB(sv))
433 if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
436 if(op_type == OP_DOR)
438 RETURNOP(cLOGOP->op_other);
440 /* assuming OP_DEFINED */
448 dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
449 useleft = USE_LEFT(TOPm1s);
450 #ifdef PERL_PRESERVE_IVUV
451 /* We must see if we can perform the addition with integers if possible,
452 as the integer code detects overflow while the NV code doesn't.
453 If either argument hasn't had a numeric conversion yet attempt to get
454 the IV. It's important to do this now, rather than just assuming that
455 it's not IOK as a PV of "9223372036854775806" may not take well to NV
456 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
457 integer in case the second argument is IV=9223372036854775806
458 We can (now) rely on sv_2iv to do the right thing, only setting the
459 public IOK flag if the value in the NV (or PV) slot is truly integer.
461 A side effect is that this also aggressively prefers integer maths over
462 fp maths for integer values.
464 How to detect overflow?
466 C 99 section 6.2.6.1 says
468 The range of nonnegative values of a signed integer type is a subrange
469 of the corresponding unsigned integer type, and the representation of
470 the same value in each type is the same. A computation involving
471 unsigned operands can never overflow, because a result that cannot be
472 represented by the resulting unsigned integer type is reduced modulo
473 the number that is one greater than the largest value that can be
474 represented by the resulting type.
478 which I read as "unsigned ints wrap."
480 signed integer overflow seems to be classed as "exception condition"
482 If an exceptional condition occurs during the evaluation of an
483 expression (that is, if the result is not mathematically defined or not
484 in the range of representable values for its type), the behavior is
487 (6.5, the 5th paragraph)
489 I had assumed that on 2s complement machines signed arithmetic would
490 wrap, hence coded pp_add and pp_subtract on the assumption that
491 everything perl builds on would be happy. After much wailing and
492 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
493 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
494 unsigned code below is actually shorter than the old code. :-)
499 /* Unless the left argument is integer in range we are going to have to
500 use NV maths. Hence only attempt to coerce the right argument if
501 we know the left is integer. */
509 /* left operand is undef, treat as zero. + 0 is identity,
510 Could SETi or SETu right now, but space optimise by not adding
511 lots of code to speed up what is probably a rarish case. */
513 /* Left operand is defined, so is it IV? */
516 if ((auvok = SvUOK(TOPm1s)))
519 register const IV aiv = SvIVX(TOPm1s);
522 auvok = 1; /* Now acting as a sign flag. */
523 } else { /* 2s complement assumption for IV_MIN */
531 bool result_good = 0;
534 bool buvok = SvUOK(TOPs);
539 register const IV biv = SvIVX(TOPs);
546 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
547 else "IV" now, independent of how it came in.
548 if a, b represents positive, A, B negative, a maps to -A etc
553 all UV maths. negate result if A negative.
554 add if signs same, subtract if signs differ. */
560 /* Must get smaller */
566 /* result really should be -(auv-buv). as its negation
567 of true value, need to swap our result flag */
584 if (result <= (UV)IV_MIN)
587 /* result valid, but out of range for IV. */
592 } /* Overflow, drop through to NVs. */
599 /* left operand is undef, treat as zero. + 0.0 is identity. */
603 SETn( value + TOPn );
611 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
612 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
613 const U32 lval = PL_op->op_flags & OPf_MOD;
614 SV** const svp = av_fetch(av, PL_op->op_private, lval);
615 SV *sv = (svp ? *svp : &PL_sv_undef);
617 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
618 sv = sv_mortalcopy(sv);
627 do_join(TARG, *MARK, MARK, SP);
638 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
639 * will be enough to hold an OP*.
641 SV* const sv = sv_newmortal();
642 sv_upgrade(sv, SVt_PVLV);
644 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
652 /* Oversized hot code. */
656 dVAR; dSP; dMARK; dORIGMARK;
660 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
662 if (gv && (io = GvIO(gv))
663 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
666 if (MARK == ORIGMARK) {
667 /* If using default handle then we need to make space to
668 * pass object as 1st arg, so move other args up ...
672 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
676 *MARK = SvTIED_obj((SV*)io, mg);
679 call_method("PRINT", G_SCALAR);
687 if (!(io = GvIO(gv))) {
688 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
689 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
691 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
692 report_evil_fh(gv, io, PL_op->op_type);
693 SETERRNO(EBADF,RMS_IFI);
696 else if (!(fp = IoOFP(io))) {
697 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
699 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
700 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
701 report_evil_fh(gv, io, PL_op->op_type);
703 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
708 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
710 if (!do_print(*MARK, fp))
714 if (!do_print(PL_ofs_sv, fp)) { /* $, */
723 if (!do_print(*MARK, fp))
731 if (PL_ors_sv && SvOK(PL_ors_sv))
732 if (!do_print(PL_ors_sv, fp)) /* $\ */
735 if (IoFLAGS(io) & IOf_FLUSH)
736 if (PerlIO_flush(fp) == EOF)
746 XPUSHs(&PL_sv_undef);
757 tryAMAGICunDEREF(to_av);
760 if (SvTYPE(av) != SVt_PVAV)
761 DIE(aTHX_ "Not an ARRAY reference");
762 if (PL_op->op_flags & OPf_REF) {
767 if (GIMME == G_SCALAR)
768 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
772 else if (PL_op->op_flags & OPf_MOD
773 && PL_op->op_private & OPpLVAL_INTRO)
774 Perl_croak(aTHX_ PL_no_localize_ref);
777 if (SvTYPE(sv) == SVt_PVAV) {
779 if (PL_op->op_flags & OPf_REF) {
784 if (GIMME == G_SCALAR)
785 Perl_croak(aTHX_ "Can't return array to lvalue"
794 if (SvTYPE(sv) != SVt_PVGV) {
795 if (SvGMAGICAL(sv)) {
801 if (PL_op->op_flags & OPf_REF ||
802 PL_op->op_private & HINT_STRICT_REFS)
803 DIE(aTHX_ PL_no_usym, "an ARRAY");
804 if (ckWARN(WARN_UNINITIALIZED))
806 if (GIMME == G_ARRAY) {
812 if ((PL_op->op_flags & OPf_SPECIAL) &&
813 !(PL_op->op_flags & OPf_MOD))
815 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
817 && (!is_gv_magical_sv(sv,0)
818 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
824 if (PL_op->op_private & HINT_STRICT_REFS)
825 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
826 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
833 if (PL_op->op_private & OPpLVAL_INTRO)
835 if (PL_op->op_flags & OPf_REF) {
840 if (GIMME == G_SCALAR)
841 Perl_croak(aTHX_ "Can't return array to lvalue"
849 if (GIMME == G_ARRAY) {
850 const I32 maxarg = AvFILL(av) + 1;
851 (void)POPs; /* XXXX May be optimized away? */
853 if (SvRMAGICAL(av)) {
855 for (i=0; i < (U32)maxarg; i++) {
856 SV ** const svp = av_fetch(av, i, FALSE);
857 /* See note in pp_helem, and bug id #27839 */
859 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
864 Copy(AvARRAY(av), SP+1, maxarg, SV*);
868 else if (GIMME_V == G_SCALAR) {
870 const I32 maxarg = AvFILL(av) + 1;
880 const I32 gimme = GIMME_V;
881 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
885 tryAMAGICunDEREF(to_hv);
888 if (SvTYPE(hv) != SVt_PVHV)
889 DIE(aTHX_ "Not a HASH reference");
890 if (PL_op->op_flags & OPf_REF) {
895 if (gimme != G_ARRAY)
896 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
900 else if (PL_op->op_flags & OPf_MOD
901 && PL_op->op_private & OPpLVAL_INTRO)
902 Perl_croak(aTHX_ PL_no_localize_ref);
905 if (SvTYPE(sv) == SVt_PVHV) {
907 if (PL_op->op_flags & OPf_REF) {
912 if (gimme != G_ARRAY)
913 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
921 if (SvTYPE(sv) != SVt_PVGV) {
922 if (SvGMAGICAL(sv)) {
928 if (PL_op->op_flags & OPf_REF ||
929 PL_op->op_private & HINT_STRICT_REFS)
930 DIE(aTHX_ PL_no_usym, "a HASH");
931 if (ckWARN(WARN_UNINITIALIZED))
933 if (gimme == G_ARRAY) {
939 if ((PL_op->op_flags & OPf_SPECIAL) &&
940 !(PL_op->op_flags & OPf_MOD))
942 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
944 && (!is_gv_magical_sv(sv,0)
945 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
951 if (PL_op->op_private & HINT_STRICT_REFS)
952 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
953 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
960 if (PL_op->op_private & OPpLVAL_INTRO)
962 if (PL_op->op_flags & OPf_REF) {
967 if (gimme != G_ARRAY)
968 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
975 if (gimme == G_ARRAY) { /* array wanted */
976 *PL_stack_sp = (SV*)hv;
979 else if (gimme == G_SCALAR) {
981 TARG = Perl_hv_scalar(aTHX_ hv);
988 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
994 if (ckWARN(WARN_MISC)) {
996 if (relem == firstrelem &&
998 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
999 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1001 err = "Reference found where even-sized list expected";
1004 err = "Odd number of elements in hash assignment";
1005 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1008 tmpstr = NEWSV(29,0);
1009 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1010 if (SvMAGICAL(hash)) {
1011 if (SvSMAGICAL(tmpstr))
1023 SV **lastlelem = PL_stack_sp;
1024 SV **lastrelem = PL_stack_base + POPMARK;
1025 SV **firstrelem = PL_stack_base + POPMARK + 1;
1026 SV **firstlelem = lastrelem + 1;
1028 register SV **relem;
1029 register SV **lelem;
1039 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1042 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1045 /* If there's a common identifier on both sides we have to take
1046 * special care that assigning the identifier on the left doesn't
1047 * clobber a value on the right that's used later in the list.
1049 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1050 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1051 for (relem = firstrelem; relem <= lastrelem; relem++) {
1052 if ((sv = *relem)) {
1053 TAINT_NOT; /* Each item is independent */
1054 *relem = sv_mortalcopy(sv);
1064 while (lelem <= lastlelem) {
1065 TAINT_NOT; /* Each item stands on its own, taintwise. */
1067 switch (SvTYPE(sv)) {
1070 magic = SvMAGICAL(ary) != 0;
1072 av_extend(ary, lastrelem - relem);
1074 while (relem <= lastrelem) { /* gobble up all the rest */
1077 sv = newSVsv(*relem);
1079 didstore = av_store(ary,i++,sv);
1089 case SVt_PVHV: { /* normal hash */
1093 magic = SvMAGICAL(hash) != 0;
1095 firsthashrelem = relem;
1097 while (relem < lastrelem) { /* gobble up all the rest */
1102 sv = &PL_sv_no, relem++;
1103 tmpstr = NEWSV(29,0);
1105 sv_setsv(tmpstr,*relem); /* value */
1106 *(relem++) = tmpstr;
1107 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1108 /* key overwrites an existing entry */
1110 didstore = hv_store_ent(hash,sv,tmpstr,0);
1112 if (SvSMAGICAL(tmpstr))
1119 if (relem == lastrelem) {
1120 do_oddball(hash, relem, firstrelem);
1126 if (SvIMMORTAL(sv)) {
1127 if (relem <= lastrelem)
1131 if (relem <= lastrelem) {
1132 sv_setsv(sv, *relem);
1136 sv_setsv(sv, &PL_sv_undef);
1141 if (PL_delaymagic & ~DM_DELAY) {
1142 if (PL_delaymagic & DM_UID) {
1143 #ifdef HAS_SETRESUID
1144 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1145 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1148 # ifdef HAS_SETREUID
1149 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1150 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1153 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1154 (void)setruid(PL_uid);
1155 PL_delaymagic &= ~DM_RUID;
1157 # endif /* HAS_SETRUID */
1159 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1160 (void)seteuid(PL_euid);
1161 PL_delaymagic &= ~DM_EUID;
1163 # endif /* HAS_SETEUID */
1164 if (PL_delaymagic & DM_UID) {
1165 if (PL_uid != PL_euid)
1166 DIE(aTHX_ "No setreuid available");
1167 (void)PerlProc_setuid(PL_uid);
1169 # endif /* HAS_SETREUID */
1170 #endif /* HAS_SETRESUID */
1171 PL_uid = PerlProc_getuid();
1172 PL_euid = PerlProc_geteuid();
1174 if (PL_delaymagic & DM_GID) {
1175 #ifdef HAS_SETRESGID
1176 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1177 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1180 # ifdef HAS_SETREGID
1181 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1182 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1185 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1186 (void)setrgid(PL_gid);
1187 PL_delaymagic &= ~DM_RGID;
1189 # endif /* HAS_SETRGID */
1191 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1192 (void)setegid(PL_egid);
1193 PL_delaymagic &= ~DM_EGID;
1195 # endif /* HAS_SETEGID */
1196 if (PL_delaymagic & DM_GID) {
1197 if (PL_gid != PL_egid)
1198 DIE(aTHX_ "No setregid available");
1199 (void)PerlProc_setgid(PL_gid);
1201 # endif /* HAS_SETREGID */
1202 #endif /* HAS_SETRESGID */
1203 PL_gid = PerlProc_getgid();
1204 PL_egid = PerlProc_getegid();
1206 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1210 if (gimme == G_VOID)
1211 SP = firstrelem - 1;
1212 else if (gimme == G_SCALAR) {
1215 SETi(lastrelem - firstrelem + 1 - duplicates);
1222 /* Removes from the stack the entries which ended up as
1223 * duplicated keys in the hash (fix for [perl #24380]) */
1224 Move(firsthashrelem + duplicates,
1225 firsthashrelem, duplicates, SV**);
1226 lastrelem -= duplicates;
1231 SP = firstrelem + (lastlelem - firstlelem);
1232 lelem = firstlelem + (relem - firstrelem);
1234 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1242 register PMOP * const pm = cPMOP;
1243 SV * const rv = sv_newmortal();
1244 SV * const sv = newSVrv(rv, "Regexp");
1245 if (pm->op_pmdynflags & PMdf_TAINTED)
1247 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1254 register PMOP *pm = cPMOP;
1256 register const char *t;
1257 register const char *s;
1260 I32 r_flags = REXEC_CHECKED;
1261 const char *truebase; /* Start of string */
1262 register REGEXP *rx = PM_GETRE(pm);
1264 const I32 gimme = GIMME;
1267 const I32 oldsave = PL_savestack_ix;
1268 I32 update_minmatch = 1;
1269 I32 had_zerolen = 0;
1271 if (PL_op->op_flags & OPf_STACKED)
1273 else if (PL_op->op_private & OPpTARGET_MY)
1280 PUTBACK; /* EVAL blocks need stack_sp. */
1281 s = SvPV_const(TARG, len);
1283 DIE(aTHX_ "panic: pp_match");
1285 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1286 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1289 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1291 /* PMdf_USED is set after a ?? matches once */
1292 if (pm->op_pmdynflags & PMdf_USED) {
1294 if (gimme == G_ARRAY)
1299 /* empty pattern special-cased to use last successful pattern if possible */
1300 if (!rx->prelen && PL_curpm) {
1305 if (rx->minlen > (I32)len)
1310 /* XXXX What part of this is needed with true \G-support? */
1311 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1313 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1314 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1315 if (mg && mg->mg_len >= 0) {
1316 if (!(rx->reganch & ROPT_GPOS_SEEN))
1317 rx->endp[0] = rx->startp[0] = mg->mg_len;
1318 else if (rx->reganch & ROPT_ANCH_GPOS) {
1319 r_flags |= REXEC_IGNOREPOS;
1320 rx->endp[0] = rx->startp[0] = mg->mg_len;
1322 minmatch = (mg->mg_flags & MGf_MINMATCH);
1323 update_minmatch = 0;
1327 if ((!global && rx->nparens)
1328 || SvTEMP(TARG) || PL_sawampersand)
1329 r_flags |= REXEC_COPY_STR;
1331 r_flags |= REXEC_SCREAM;
1334 if (global && rx->startp[0] != -1) {
1335 t = s = rx->endp[0] + truebase;
1336 if ((s + rx->minlen) > strend)
1338 if (update_minmatch++)
1339 minmatch = had_zerolen;
1341 if (rx->reganch & RE_USE_INTUIT &&
1342 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1343 /* FIXME - can PL_bostr be made const char *? */
1344 PL_bostr = (char *)truebase;
1345 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1349 if ( (rx->reganch & ROPT_CHECK_ALL)
1351 && ((rx->reganch & ROPT_NOSCAN)
1352 || !((rx->reganch & RE_INTUIT_TAIL)
1353 && (r_flags & REXEC_SCREAM)))
1354 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1357 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1360 if (dynpm->op_pmflags & PMf_ONCE)
1361 dynpm->op_pmdynflags |= PMdf_USED;
1370 RX_MATCH_TAINTED_on(rx);
1371 TAINT_IF(RX_MATCH_TAINTED(rx));
1372 if (gimme == G_ARRAY) {
1373 const I32 nparens = rx->nparens;
1374 I32 i = (global && !nparens) ? 1 : 0;
1376 SPAGAIN; /* EVAL blocks could move the stack. */
1377 EXTEND(SP, nparens + i);
1378 EXTEND_MORTAL(nparens + i);
1379 for (i = !i; i <= nparens; i++) {
1380 PUSHs(sv_newmortal());
1381 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1382 const I32 len = rx->endp[i] - rx->startp[i];
1383 s = rx->startp[i] + truebase;
1384 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1385 len < 0 || len > strend - s)
1386 DIE(aTHX_ "panic: pp_match start/end pointers");
1387 sv_setpvn(*SP, s, len);
1388 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1393 if (dynpm->op_pmflags & PMf_CONTINUE) {
1395 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1396 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1399 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1401 if (rx->startp[0] != -1) {
1402 mg->mg_len = rx->endp[0];
1403 if (rx->startp[0] == rx->endp[0])
1404 mg->mg_flags |= MGf_MINMATCH;
1406 mg->mg_flags &= ~MGf_MINMATCH;
1409 had_zerolen = (rx->startp[0] != -1
1410 && rx->startp[0] == rx->endp[0]);
1411 PUTBACK; /* EVAL blocks may use stack */
1412 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1417 LEAVE_SCOPE(oldsave);
1423 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1424 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1428 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1429 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1431 if (rx->startp[0] != -1) {
1432 mg->mg_len = rx->endp[0];
1433 if (rx->startp[0] == rx->endp[0])
1434 mg->mg_flags |= MGf_MINMATCH;
1436 mg->mg_flags &= ~MGf_MINMATCH;
1439 LEAVE_SCOPE(oldsave);
1443 yup: /* Confirmed by INTUIT */
1445 RX_MATCH_TAINTED_on(rx);
1446 TAINT_IF(RX_MATCH_TAINTED(rx));
1448 if (dynpm->op_pmflags & PMf_ONCE)
1449 dynpm->op_pmdynflags |= PMdf_USED;
1450 if (RX_MATCH_COPIED(rx))
1451 Safefree(rx->subbeg);
1452 RX_MATCH_COPIED_off(rx);
1453 rx->subbeg = Nullch;
1455 /* FIXME - should rx->subbeg be const char *? */
1456 rx->subbeg = (char *) truebase;
1457 rx->startp[0] = s - truebase;
1458 if (RX_MATCH_UTF8(rx)) {
1459 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1460 rx->endp[0] = t - truebase;
1463 rx->endp[0] = s - truebase + rx->minlen;
1465 rx->sublen = strend - truebase;
1468 if (PL_sawampersand) {
1470 #ifdef PERL_OLD_COPY_ON_WRITE
1471 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1473 PerlIO_printf(Perl_debug_log,
1474 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1475 (int) SvTYPE(TARG), truebase, t,
1478 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1479 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1480 assert (SvPOKp(rx->saved_copy));
1485 rx->subbeg = savepvn(t, strend - t);
1486 #ifdef PERL_OLD_COPY_ON_WRITE
1487 rx->saved_copy = Nullsv;
1490 rx->sublen = strend - t;
1491 RX_MATCH_COPIED_on(rx);
1492 off = rx->startp[0] = s - t;
1493 rx->endp[0] = off + rx->minlen;
1495 else { /* startp/endp are used by @- @+. */
1496 rx->startp[0] = s - truebase;
1497 rx->endp[0] = s - truebase + rx->minlen;
1499 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1500 LEAVE_SCOPE(oldsave);
1505 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1506 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1507 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1512 LEAVE_SCOPE(oldsave);
1513 if (gimme == G_ARRAY)
1519 Perl_do_readline(pTHX)
1521 dVAR; dSP; dTARGETSTACKED;
1526 register IO * const io = GvIO(PL_last_in_gv);
1527 register const I32 type = PL_op->op_type;
1528 const I32 gimme = GIMME_V;
1531 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1533 XPUSHs(SvTIED_obj((SV*)io, mg));
1536 call_method("READLINE", gimme);
1539 if (gimme == G_SCALAR) {
1541 SvSetSV_nosteal(TARG, result);
1550 if (IoFLAGS(io) & IOf_ARGV) {
1551 if (IoFLAGS(io) & IOf_START) {
1553 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1554 IoFLAGS(io) &= ~IOf_START;
1555 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1556 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1557 SvSETMAGIC(GvSV(PL_last_in_gv));
1562 fp = nextargv(PL_last_in_gv);
1563 if (!fp) { /* Note: fp != IoIFP(io) */
1564 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1567 else if (type == OP_GLOB)
1568 fp = Perl_start_glob(aTHX_ POPs, io);
1570 else if (type == OP_GLOB)
1572 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1573 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1577 if ((!io || !(IoFLAGS(io) & IOf_START))
1578 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1580 if (type == OP_GLOB)
1581 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1582 "glob failed (can't start child: %s)",
1585 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1587 if (gimme == G_SCALAR) {
1588 /* undef TARG, and push that undefined value */
1589 if (type != OP_RCATLINE) {
1590 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1598 if (gimme == G_SCALAR) {
1602 SvUPGRADE(sv, SVt_PV);
1603 tmplen = SvLEN(sv); /* remember if already alloced */
1604 if (!tmplen && !SvREADONLY(sv))
1605 Sv_Grow(sv, 80); /* try short-buffering it */
1607 if (type == OP_RCATLINE && SvOK(sv)) {
1609 SvPV_force_nolen(sv);
1615 sv = sv_2mortal(NEWSV(57, 80));
1619 /* This should not be marked tainted if the fp is marked clean */
1620 #define MAYBE_TAINT_LINE(io, sv) \
1621 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1626 /* delay EOF state for a snarfed empty file */
1627 #define SNARF_EOF(gimme,rs,io,sv) \
1628 (gimme != G_SCALAR || SvCUR(sv) \
1629 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1633 if (!sv_gets(sv, fp, offset)
1635 || SNARF_EOF(gimme, PL_rs, io, sv)
1636 || PerlIO_error(fp)))
1638 PerlIO_clearerr(fp);
1639 if (IoFLAGS(io) & IOf_ARGV) {
1640 fp = nextargv(PL_last_in_gv);
1643 (void)do_close(PL_last_in_gv, FALSE);
1645 else if (type == OP_GLOB) {
1646 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1647 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1648 "glob failed (child exited with status %d%s)",
1649 (int)(STATUS_CURRENT >> 8),
1650 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1653 if (gimme == G_SCALAR) {
1654 if (type != OP_RCATLINE) {
1655 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1661 MAYBE_TAINT_LINE(io, sv);
1664 MAYBE_TAINT_LINE(io, sv);
1666 IoFLAGS(io) |= IOf_NOLINE;
1670 if (type == OP_GLOB) {
1674 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1675 tmps = SvEND(sv) - 1;
1676 if (*tmps == *SvPVX_const(PL_rs)) {
1678 SvCUR_set(sv, SvCUR(sv) - 1);
1681 for (t1 = SvPVX_const(sv); *t1; t1++)
1682 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1683 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1685 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1686 (void)POPs; /* Unmatched wildcard? Chuck it... */
1689 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1690 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1691 const STRLEN len = SvCUR(sv) - offset;
1694 if (ckWARN(WARN_UTF8) &&
1695 !is_utf8_string_loc(s, len, &f))
1696 /* Emulate :encoding(utf8) warning in the same case. */
1697 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1698 "utf8 \"\\x%02X\" does not map to Unicode",
1699 f < (U8*)SvEND(sv) ? *f : 0);
1701 if (gimme == G_ARRAY) {
1702 if (SvLEN(sv) - SvCUR(sv) > 20) {
1703 SvPV_shrink_to_cur(sv);
1705 sv = sv_2mortal(NEWSV(58, 80));
1708 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1709 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1710 const STRLEN new_len
1711 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1712 SvPV_renew(sv, new_len);
1721 register PERL_CONTEXT *cx;
1722 I32 gimme = OP_GIMME(PL_op, -1);
1725 if (cxstack_ix >= 0)
1726 gimme = cxstack[cxstack_ix].blk_gimme;
1734 PUSHBLOCK(cx, CXt_BLOCK, SP);
1744 SV * const keysv = POPs;
1745 HV * const hv = (HV*)POPs;
1746 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1747 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1749 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1752 if (SvTYPE(hv) == SVt_PVHV) {
1753 if (PL_op->op_private & OPpLVAL_INTRO) {
1756 /* does the element we're localizing already exist? */
1758 /* can we determine whether it exists? */
1760 || mg_find((SV*)hv, PERL_MAGIC_env)
1761 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1762 /* Try to preserve the existenceness of a tied hash
1763 * element by using EXISTS and DELETE if possible.
1764 * Fallback to FETCH and STORE otherwise */
1765 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1766 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1767 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1769 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1772 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1773 svp = he ? &HeVAL(he) : 0;
1779 if (!svp || *svp == &PL_sv_undef) {
1783 DIE(aTHX_ PL_no_helem_sv, keysv);
1785 lv = sv_newmortal();
1786 sv_upgrade(lv, SVt_PVLV);
1788 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1789 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1790 LvTARG(lv) = SvREFCNT_inc(hv);
1795 if (PL_op->op_private & OPpLVAL_INTRO) {
1796 if (HvNAME_get(hv) && isGV(*svp))
1797 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1801 const char * const key = SvPV_const(keysv, keylen);
1802 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1804 save_helem(hv, keysv, svp);
1807 else if (PL_op->op_private & OPpDEREF)
1808 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1810 sv = (svp ? *svp : &PL_sv_undef);
1811 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1812 * Pushing the magical RHS on to the stack is useless, since
1813 * that magic is soon destined to be misled by the local(),
1814 * and thus the later pp_sassign() will fail to mg_get() the
1815 * old value. This should also cure problems with delayed
1816 * mg_get()s. GSAR 98-07-03 */
1817 if (!lval && SvGMAGICAL(sv))
1818 sv = sv_mortalcopy(sv);
1826 register PERL_CONTEXT *cx;
1831 if (PL_op->op_flags & OPf_SPECIAL) {
1832 cx = &cxstack[cxstack_ix];
1833 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1838 gimme = OP_GIMME(PL_op, -1);
1840 if (cxstack_ix >= 0)
1841 gimme = cxstack[cxstack_ix].blk_gimme;
1847 if (gimme == G_VOID)
1849 else if (gimme == G_SCALAR) {
1853 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1856 *MARK = sv_mortalcopy(TOPs);
1859 *MARK = &PL_sv_undef;
1863 else if (gimme == G_ARRAY) {
1864 /* in case LEAVE wipes old return values */
1866 for (mark = newsp + 1; mark <= SP; mark++) {
1867 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1868 *mark = sv_mortalcopy(*mark);
1869 TAINT_NOT; /* Each item is independent */
1873 PL_curpm = newpm; /* Don't pop $1 et al till now */
1883 register PERL_CONTEXT *cx;
1889 cx = &cxstack[cxstack_ix];
1890 if (CxTYPE(cx) != CXt_LOOP)
1891 DIE(aTHX_ "panic: pp_iter");
1893 itersvp = CxITERVAR(cx);
1894 av = cx->blk_loop.iterary;
1895 if (SvTYPE(av) != SVt_PVAV) {
1896 /* iterate ($min .. $max) */
1897 if (cx->blk_loop.iterlval) {
1898 /* string increment */
1899 register SV* cur = cx->blk_loop.iterlval;
1901 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1902 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1903 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1904 /* safe to reuse old SV */
1905 sv_setsv(*itersvp, cur);
1909 /* we need a fresh SV every time so that loop body sees a
1910 * completely new SV for closures/references to work as
1913 *itersvp = newSVsv(cur);
1914 SvREFCNT_dec(oldsv);
1916 if (strEQ(SvPVX_const(cur), max))
1917 sv_setiv(cur, 0); /* terminate next time */
1924 /* integer increment */
1925 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1928 /* don't risk potential race */
1929 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1930 /* safe to reuse old SV */
1931 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1935 /* we need a fresh SV every time so that loop body sees a
1936 * completely new SV for closures/references to work as they
1939 *itersvp = newSViv(cx->blk_loop.iterix++);
1940 SvREFCNT_dec(oldsv);
1946 if (PL_op->op_private & OPpITER_REVERSED) {
1947 /* In reverse, use itermax as the min :-) */
1948 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1951 if (SvMAGICAL(av) || AvREIFY(av)) {
1952 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1953 sv = svp ? *svp : Nullsv;
1956 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1960 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1964 if (SvMAGICAL(av) || AvREIFY(av)) {
1965 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1966 sv = svp ? *svp : Nullsv;
1969 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1973 if (sv && SvIS_FREED(sv)) {
1975 Perl_croak(aTHX_ "Use of freed value in iteration");
1982 if (av != PL_curstack && sv == &PL_sv_undef) {
1983 SV *lv = cx->blk_loop.iterlval;
1984 if (lv && SvREFCNT(lv) > 1) {
1989 SvREFCNT_dec(LvTARG(lv));
1991 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1992 sv_upgrade(lv, SVt_PVLV);
1994 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1996 LvTARG(lv) = SvREFCNT_inc(av);
1997 LvTARGOFF(lv) = cx->blk_loop.iterix;
1998 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2003 *itersvp = SvREFCNT_inc(sv);
2004 SvREFCNT_dec(oldsv);
2012 register PMOP *pm = cPMOP;
2028 register REGEXP *rx = PM_GETRE(pm);
2030 int force_on_match = 0;
2031 const I32 oldsave = PL_savestack_ix;
2033 bool doutf8 = FALSE;
2034 #ifdef PERL_OLD_COPY_ON_WRITE
2039 /* known replacement string? */
2040 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
2041 if (PL_op->op_flags & OPf_STACKED)
2043 else if (PL_op->op_private & OPpTARGET_MY)
2050 #ifdef PERL_OLD_COPY_ON_WRITE
2051 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2052 because they make integers such as 256 "false". */
2053 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2056 sv_force_normal_flags(TARG,0);
2059 #ifdef PERL_OLD_COPY_ON_WRITE
2063 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2064 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2065 DIE(aTHX_ PL_no_modify);
2068 s = SvPV_mutable(TARG, len);
2069 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2071 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2072 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2077 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2081 DIE(aTHX_ "panic: pp_subst");
2084 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2085 maxiters = 2 * slen + 10; /* We can match twice at each
2086 position, once with zero-length,
2087 second time with non-zero. */
2089 if (!rx->prelen && PL_curpm) {
2093 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2094 ? REXEC_COPY_STR : 0;
2096 r_flags |= REXEC_SCREAM;
2099 if (rx->reganch & RE_USE_INTUIT) {
2101 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2105 /* How to do it in subst? */
2106 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2108 && ((rx->reganch & ROPT_NOSCAN)
2109 || !((rx->reganch & RE_INTUIT_TAIL)
2110 && (r_flags & REXEC_SCREAM))))
2115 /* only replace once? */
2116 once = !(rpm->op_pmflags & PMf_GLOBAL);
2118 /* known replacement string? */
2120 /* replacement needing upgrading? */
2121 if (DO_UTF8(TARG) && !doutf8) {
2122 nsv = sv_newmortal();
2125 sv_recode_to_utf8(nsv, PL_encoding);
2127 sv_utf8_upgrade(nsv);
2128 c = SvPV_const(nsv, clen);
2132 c = SvPV_const(dstr, clen);
2133 doutf8 = DO_UTF8(dstr);
2141 /* can do inplace substitution? */
2143 #ifdef PERL_OLD_COPY_ON_WRITE
2146 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2147 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2148 && (!doutf8 || SvUTF8(TARG))) {
2149 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2150 r_flags | REXEC_CHECKED))
2154 LEAVE_SCOPE(oldsave);
2157 #ifdef PERL_OLD_COPY_ON_WRITE
2158 if (SvIsCOW(TARG)) {
2159 assert (!force_on_match);
2163 if (force_on_match) {
2165 s = SvPV_force(TARG, len);
2170 SvSCREAM_off(TARG); /* disable possible screamer */
2172 rxtainted |= RX_MATCH_TAINTED(rx);
2173 m = orig + rx->startp[0];
2174 d = orig + rx->endp[0];
2176 if (m - s > strend - d) { /* faster to shorten from end */
2178 Copy(c, m, clen, char);
2183 Move(d, m, i, char);
2187 SvCUR_set(TARG, m - s);
2189 else if ((i = m - s)) { /* faster from front */
2197 Copy(c, m, clen, char);
2202 Copy(c, d, clen, char);
2207 TAINT_IF(rxtainted & 1);
2213 if (iters++ > maxiters)
2214 DIE(aTHX_ "Substitution loop");
2215 rxtainted |= RX_MATCH_TAINTED(rx);
2216 m = rx->startp[0] + orig;
2219 Move(s, d, i, char);
2223 Copy(c, d, clen, char);
2226 s = rx->endp[0] + orig;
2227 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2229 /* don't match same null twice */
2230 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2233 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2234 Move(s, d, i+1, char); /* include the NUL */
2236 TAINT_IF(rxtainted & 1);
2238 PUSHs(sv_2mortal(newSViv((I32)iters)));
2240 (void)SvPOK_only_UTF8(TARG);
2241 TAINT_IF(rxtainted);
2242 if (SvSMAGICAL(TARG)) {
2250 LEAVE_SCOPE(oldsave);
2254 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2255 r_flags | REXEC_CHECKED))
2257 if (force_on_match) {
2259 s = SvPV_force(TARG, len);
2262 #ifdef PERL_OLD_COPY_ON_WRITE
2265 rxtainted |= RX_MATCH_TAINTED(rx);
2266 dstr = newSVpvn(m, s-m);
2271 register PERL_CONTEXT *cx;
2273 (void)ReREFCNT_inc(rx);
2275 RETURNOP(cPMOP->op_pmreplroot);
2277 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2279 if (iters++ > maxiters)
2280 DIE(aTHX_ "Substitution loop");
2281 rxtainted |= RX_MATCH_TAINTED(rx);
2282 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2287 strend = s + (strend - m);
2289 m = rx->startp[0] + orig;
2290 if (doutf8 && !SvUTF8(dstr))
2291 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2293 sv_catpvn(dstr, s, m-s);
2294 s = rx->endp[0] + orig;
2296 sv_catpvn(dstr, c, clen);
2299 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2300 TARG, NULL, r_flags));
2301 if (doutf8 && !DO_UTF8(TARG))
2302 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2304 sv_catpvn(dstr, s, strend - s);
2306 #ifdef PERL_OLD_COPY_ON_WRITE
2307 /* The match may make the string COW. If so, brilliant, because that's
2308 just saved us one malloc, copy and free - the regexp has donated
2309 the old buffer, and we malloc an entirely new one, rather than the
2310 regexp malloc()ing a buffer and copying our original, only for
2311 us to throw it away here during the substitution. */
2312 if (SvIsCOW(TARG)) {
2313 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2319 SvPV_set(TARG, SvPVX(dstr));
2320 SvCUR_set(TARG, SvCUR(dstr));
2321 SvLEN_set(TARG, SvLEN(dstr));
2322 doutf8 |= DO_UTF8(dstr);
2323 SvPV_set(dstr, (char*)0);
2326 TAINT_IF(rxtainted & 1);
2328 PUSHs(sv_2mortal(newSViv((I32)iters)));
2330 (void)SvPOK_only(TARG);
2333 TAINT_IF(rxtainted);
2336 LEAVE_SCOPE(oldsave);
2345 LEAVE_SCOPE(oldsave);
2354 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2355 ++*PL_markstack_ptr;
2356 LEAVE; /* exit inner scope */
2359 if (PL_stack_base + *PL_markstack_ptr > SP) {
2361 const I32 gimme = GIMME_V;
2363 LEAVE; /* exit outer scope */
2364 (void)POPMARK; /* pop src */
2365 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2366 (void)POPMARK; /* pop dst */
2367 SP = PL_stack_base + POPMARK; /* pop original mark */
2368 if (gimme == G_SCALAR) {
2369 if (PL_op->op_private & OPpGREP_LEX) {
2370 SV* const sv = sv_newmortal();
2371 sv_setiv(sv, items);
2379 else if (gimme == G_ARRAY)
2386 ENTER; /* enter inner scope */
2389 src = PL_stack_base[*PL_markstack_ptr];
2391 if (PL_op->op_private & OPpGREP_LEX)
2392 PAD_SVl(PL_op->op_targ) = src;
2396 RETURNOP(cLOGOP->op_other);
2407 register PERL_CONTEXT *cx;
2410 if (CxMULTICALL(&cxstack[cxstack_ix]))
2414 cxstack_ix++; /* temporarily protect top context */
2417 if (gimme == G_SCALAR) {
2420 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2422 *MARK = SvREFCNT_inc(TOPs);
2427 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2429 *MARK = sv_mortalcopy(sv);
2434 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2438 *MARK = &PL_sv_undef;
2442 else if (gimme == G_ARRAY) {
2443 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2444 if (!SvTEMP(*MARK)) {
2445 *MARK = sv_mortalcopy(*MARK);
2446 TAINT_NOT; /* Each item is independent */
2454 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2455 PL_curpm = newpm; /* ... and pop $1 et al */
2458 return cx->blk_sub.retop;
2461 /* This duplicates the above code because the above code must not
2462 * get any slower by more conditions */
2470 register PERL_CONTEXT *cx;
2473 if (CxMULTICALL(&cxstack[cxstack_ix]))
2477 cxstack_ix++; /* temporarily protect top context */
2481 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2482 /* We are an argument to a function or grep().
2483 * This kind of lvalueness was legal before lvalue
2484 * subroutines too, so be backward compatible:
2485 * cannot report errors. */
2487 /* Scalar context *is* possible, on the LHS of -> only,
2488 * as in f()->meth(). But this is not an lvalue. */
2489 if (gimme == G_SCALAR)
2491 if (gimme == G_ARRAY) {
2492 if (!CvLVALUE(cx->blk_sub.cv))
2493 goto temporise_array;
2494 EXTEND_MORTAL(SP - newsp);
2495 for (mark = newsp + 1; mark <= SP; mark++) {
2498 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2499 *mark = sv_mortalcopy(*mark);
2501 /* Can be a localized value subject to deletion. */
2502 PL_tmps_stack[++PL_tmps_ix] = *mark;
2503 (void)SvREFCNT_inc(*mark);
2508 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2509 /* Here we go for robustness, not for speed, so we change all
2510 * the refcounts so the caller gets a live guy. Cannot set
2511 * TEMP, so sv_2mortal is out of question. */
2512 if (!CvLVALUE(cx->blk_sub.cv)) {
2518 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2520 if (gimme == G_SCALAR) {
2524 /* Temporaries are bad unless they happen to be elements
2525 * of a tied hash or array */
2526 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2527 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2533 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2534 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2535 : "a readonly value" : "a temporary");
2537 else { /* Can be a localized value
2538 * subject to deletion. */
2539 PL_tmps_stack[++PL_tmps_ix] = *mark;
2540 (void)SvREFCNT_inc(*mark);
2543 else { /* Should not happen? */
2549 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2550 (MARK > SP ? "Empty array" : "Array"));
2554 else if (gimme == G_ARRAY) {
2555 EXTEND_MORTAL(SP - newsp);
2556 for (mark = newsp + 1; mark <= SP; mark++) {
2557 if (*mark != &PL_sv_undef
2558 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2559 /* Might be flattened array after $#array = */
2566 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2567 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2570 /* Can be a localized value subject to deletion. */
2571 PL_tmps_stack[++PL_tmps_ix] = *mark;
2572 (void)SvREFCNT_inc(*mark);
2578 if (gimme == G_SCALAR) {
2582 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2584 *MARK = SvREFCNT_inc(TOPs);
2589 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2591 *MARK = sv_mortalcopy(sv);
2596 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2600 *MARK = &PL_sv_undef;
2604 else if (gimme == G_ARRAY) {
2606 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2607 if (!SvTEMP(*MARK)) {
2608 *MARK = sv_mortalcopy(*MARK);
2609 TAINT_NOT; /* Each item is independent */
2618 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2619 PL_curpm = newpm; /* ... and pop $1 et al */
2622 return cx->blk_sub.retop;
2627 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2629 SV * const dbsv = GvSVn(PL_DBsub);
2632 if (!PERLDB_SUB_NN) {
2635 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2636 || strEQ(GvNAME(gv), "END")
2637 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2638 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2639 && (gv = (GV*)*svp) ))) {
2640 /* Use GV from the stack as a fallback. */
2641 /* GV is potentially non-unique, or contain different CV. */
2642 SV * const tmp = newRV((SV*)cv);
2643 sv_setsv(dbsv, tmp);
2647 gv_efullname3(dbsv, gv, Nullch);
2651 const int type = SvTYPE(dbsv);
2652 if (type < SVt_PVIV && type != SVt_IV)
2653 sv_upgrade(dbsv, SVt_PVIV);
2654 (void)SvIOK_on(dbsv);
2655 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2659 PL_curcopdb = PL_curcop;
2660 cv = GvCV(PL_DBsub);
2669 register PERL_CONTEXT *cx;
2671 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2674 DIE(aTHX_ "Not a CODE reference");
2675 switch (SvTYPE(sv)) {
2676 /* This is overwhelming the most common case: */
2678 if (!(cv = GvCVu((GV*)sv))) {
2680 cv = sv_2cv(sv, &stash, &gv, 0);
2691 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2693 SP = PL_stack_base + POPMARK;
2696 if (SvGMAGICAL(sv)) {
2700 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2703 sym = SvPV_nolen_const(sv);
2706 DIE(aTHX_ PL_no_usym, "a subroutine");
2707 if (PL_op->op_private & HINT_STRICT_REFS)
2708 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2709 cv = get_cv(sym, TRUE);
2714 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2715 tryAMAGICunDEREF(to_cv);
2718 if (SvTYPE(cv) == SVt_PVCV)
2723 DIE(aTHX_ "Not a CODE reference");
2724 /* This is the second most common case: */
2734 if (!CvROOT(cv) && !CvXSUB(cv)) {
2738 /* anonymous or undef'd function leaves us no recourse */
2739 if (CvANON(cv) || !(gv = CvGV(cv)))
2740 DIE(aTHX_ "Undefined subroutine called");
2742 /* autoloaded stub? */
2743 if (cv != GvCV(gv)) {
2746 /* should call AUTOLOAD now? */
2749 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2756 sub_name = sv_newmortal();
2757 gv_efullname3(sub_name, gv, Nullch);
2758 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2762 DIE(aTHX_ "Not a CODE reference");
2767 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2768 if (CvASSERTION(cv) && PL_DBassertion)
2769 sv_setiv(PL_DBassertion, 1);
2771 cv = get_db_sub(&sv, cv);
2772 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2773 DIE(aTHX_ "No DB::sub routine defined");
2776 if (!(CvXSUB(cv))) {
2777 /* This path taken at least 75% of the time */
2779 register I32 items = SP - MARK;
2780 AV* const padlist = CvPADLIST(cv);
2781 PUSHBLOCK(cx, CXt_SUB, MARK);
2783 cx->blk_sub.retop = PL_op->op_next;
2785 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2786 * that eval'' ops within this sub know the correct lexical space.
2787 * Owing the speed considerations, we choose instead to search for
2788 * the cv using find_runcv() when calling doeval().
2790 if (CvDEPTH(cv) >= 2) {
2791 PERL_STACK_OVERFLOW_CHECK();
2792 pad_push(padlist, CvDEPTH(cv));
2795 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2798 AV* const av = (AV*)PAD_SVl(0);
2800 /* @_ is normally not REAL--this should only ever
2801 * happen when DB::sub() calls things that modify @_ */
2806 cx->blk_sub.savearray = GvAV(PL_defgv);
2807 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2808 CX_CURPAD_SAVE(cx->blk_sub);
2809 cx->blk_sub.argarray = av;
2812 if (items > AvMAX(av) + 1) {
2813 SV **ary = AvALLOC(av);
2814 if (AvARRAY(av) != ary) {
2815 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2816 SvPV_set(av, (char*)ary);
2818 if (items > AvMAX(av) + 1) {
2819 AvMAX(av) = items - 1;
2820 Renew(ary,items,SV*);
2822 SvPV_set(av, (char*)ary);
2825 Copy(MARK,AvARRAY(av),items,SV*);
2826 AvFILLp(av) = items - 1;
2834 /* warning must come *after* we fully set up the context
2835 * stuff so that __WARN__ handlers can safely dounwind()
2838 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2839 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2840 sub_crush_depth(cv);
2842 DEBUG_S(PerlIO_printf(Perl_debug_log,
2843 "%p entersub returning %p\n", thr, CvSTART(cv)));
2845 RETURNOP(CvSTART(cv));
2848 #ifdef PERL_XSUB_OLDSTYLE
2849 if (CvOLDSTYLE(cv)) {
2850 I32 (*fp3)(int,int,int);
2852 register I32 items = SP - MARK;
2853 /* We dont worry to copy from @_. */
2858 PL_stack_sp = mark + 1;
2859 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2860 items = (*fp3)(CvXSUBANY(cv).any_i32,
2861 MARK - PL_stack_base + 1,
2863 PL_stack_sp = PL_stack_base + items;
2866 #endif /* PERL_XSUB_OLDSTYLE */
2868 I32 markix = TOPMARK;
2873 /* Need to copy @_ to stack. Alternative may be to
2874 * switch stack to @_, and copy return values
2875 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2876 AV * const av = GvAV(PL_defgv);
2877 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2880 /* Mark is at the end of the stack. */
2882 Copy(AvARRAY(av), SP + 1, items, SV*);
2887 /* We assume first XSUB in &DB::sub is the called one. */
2889 SAVEVPTR(PL_curcop);
2890 PL_curcop = PL_curcopdb;
2893 /* Do we need to open block here? XXXX */
2894 (void)(*CvXSUB(cv))(aTHX_ cv);
2896 /* Enforce some sanity in scalar context. */
2897 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2898 if (markix > PL_stack_sp - PL_stack_base)
2899 *(PL_stack_base + markix) = &PL_sv_undef;
2901 *(PL_stack_base + markix) = *PL_stack_sp;
2902 PL_stack_sp = PL_stack_base + markix;
2911 Perl_sub_crush_depth(pTHX_ CV *cv)
2914 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2916 SV* const tmpstr = sv_newmortal();
2917 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2918 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2927 SV* const elemsv = POPs;
2928 IV elem = SvIV(elemsv);
2929 AV* const av = (AV*)POPs;
2930 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2931 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2934 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2935 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2937 elem -= PL_curcop->cop_arybase;
2938 if (SvTYPE(av) != SVt_PVAV)
2940 svp = av_fetch(av, elem, lval && !defer);
2942 #ifdef PERL_MALLOC_WRAP
2943 if (SvUOK(elemsv)) {
2944 const UV uv = SvUV(elemsv);
2945 elem = uv > IV_MAX ? IV_MAX : uv;
2947 else if (SvNOK(elemsv))
2948 elem = (IV)SvNV(elemsv);
2950 static const char oom_array_extend[] =
2951 "Out of memory during array extend"; /* Duplicated in av.c */
2952 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2955 if (!svp || *svp == &PL_sv_undef) {
2958 DIE(aTHX_ PL_no_aelem, elem);
2959 lv = sv_newmortal();
2960 sv_upgrade(lv, SVt_PVLV);
2962 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2963 LvTARG(lv) = SvREFCNT_inc(av);
2964 LvTARGOFF(lv) = elem;
2969 if (PL_op->op_private & OPpLVAL_INTRO)
2970 save_aelem(av, elem, svp);
2971 else if (PL_op->op_private & OPpDEREF)
2972 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2974 sv = (svp ? *svp : &PL_sv_undef);
2975 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2976 sv = sv_mortalcopy(sv);
2982 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2987 Perl_croak(aTHX_ PL_no_modify);
2988 if (SvTYPE(sv) < SVt_RV)
2989 sv_upgrade(sv, SVt_RV);
2990 else if (SvTYPE(sv) >= SVt_PV) {
2997 SvRV_set(sv, NEWSV(355,0));
3000 SvRV_set(sv, (SV*)newAV());
3003 SvRV_set(sv, (SV*)newHV());
3014 SV* const sv = TOPs;
3017 SV* const rsv = SvRV(sv);
3018 if (SvTYPE(rsv) == SVt_PVCV) {
3024 SETs(method_common(sv, Null(U32*)));
3031 SV* const sv = cSVOP_sv;
3032 U32 hash = SvSHARED_HASH(sv);
3034 XPUSHs(method_common(sv, &hash));
3039 S_method_common(pTHX_ SV* meth, U32* hashp)
3045 const char* packname = Nullch;
3046 SV *packsv = Nullsv;
3048 const char * const name = SvPV_const(meth, namelen);
3049 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3052 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3060 /* this isn't a reference */
3061 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3062 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3064 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3071 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3072 !(ob=(SV*)GvIO(iogv)))
3074 /* this isn't the name of a filehandle either */
3076 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3077 ? !isIDFIRST_utf8((U8*)packname)
3078 : !isIDFIRST(*packname)
3081 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3082 SvOK(sv) ? "without a package or object reference"
3083 : "on an undefined value");
3085 /* assume it's a package name */
3086 stash = gv_stashpvn(packname, packlen, FALSE);
3090 SV* ref = newSViv(PTR2IV(stash));
3091 hv_store(PL_stashcache, packname, packlen, ref, 0);
3095 /* it _is_ a filehandle name -- replace with a reference */
3096 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3099 /* if we got here, ob should be a reference or a glob */
3100 if (!ob || !(SvOBJECT(ob)
3101 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3104 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3108 stash = SvSTASH(ob);
3111 /* NOTE: stash may be null, hope hv_fetch_ent and
3112 gv_fetchmethod can cope (it seems they can) */
3114 /* shortcut for simple names */
3116 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3118 gv = (GV*)HeVAL(he);
3119 if (isGV(gv) && GvCV(gv) &&
3120 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3121 return (SV*)GvCV(gv);
3125 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3128 /* This code tries to figure out just what went wrong with
3129 gv_fetchmethod. It therefore needs to duplicate a lot of
3130 the internals of that function. We can't move it inside
3131 Perl_gv_fetchmethod_autoload(), however, since that would
3132 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3135 const char* leaf = name;
3136 const char* sep = Nullch;
3139 for (p = name; *p; p++) {
3141 sep = p, leaf = p + 1;
3142 else if (*p == ':' && *(p + 1) == ':')
3143 sep = p, leaf = p + 2;
3145 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3146 /* the method name is unqualified or starts with SUPER:: */
3147 bool need_strlen = 1;
3149 packname = CopSTASHPV(PL_curcop);
3152 HEK * const packhek = HvNAME_HEK(stash);
3154 packname = HEK_KEY(packhek);
3155 packlen = HEK_LEN(packhek);
3165 "Can't use anonymous symbol table for method lookup");
3167 else if (need_strlen)
3168 packlen = strlen(packname);
3172 /* the method name is qualified */
3174 packlen = sep - name;
3177 /* we're relying on gv_fetchmethod not autovivifying the stash */
3178 if (gv_stashpvn(packname, packlen, FALSE)) {
3180 "Can't locate object method \"%s\" via package \"%.*s\"",
3181 leaf, (int)packlen, packname);
3185 "Can't locate object method \"%s\" via package \"%.*s\""
3186 " (perhaps you forgot to load \"%.*s\"?)",
3187 leaf, (int)packlen, packname, (int)packlen, packname);
3190 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3195 * c-indentation-style: bsd
3197 * indent-tabs-mode: t
3200 * ex: set ts=8 sts=4 sw=4 noet: