3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 *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 = 0; /* "= 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* 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);
1426 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1427 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1429 if (rx->startp[0] != -1) {
1430 mg->mg_len = rx->endp[0];
1431 if (rx->startp[0] == rx->endp[0])
1432 mg->mg_flags |= MGf_MINMATCH;
1434 mg->mg_flags &= ~MGf_MINMATCH;
1437 LEAVE_SCOPE(oldsave);
1441 yup: /* Confirmed by INTUIT */
1443 RX_MATCH_TAINTED_on(rx);
1444 TAINT_IF(RX_MATCH_TAINTED(rx));
1446 if (dynpm->op_pmflags & PMf_ONCE)
1447 dynpm->op_pmdynflags |= PMdf_USED;
1448 if (RX_MATCH_COPIED(rx))
1449 Safefree(rx->subbeg);
1450 RX_MATCH_COPIED_off(rx);
1451 rx->subbeg = Nullch;
1453 /* FIXME - should rx->subbeg be const char *? */
1454 rx->subbeg = (char *) truebase;
1455 rx->startp[0] = s - truebase;
1456 if (RX_MATCH_UTF8(rx)) {
1457 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1458 rx->endp[0] = t - truebase;
1461 rx->endp[0] = s - truebase + rx->minlen;
1463 rx->sublen = strend - truebase;
1466 if (PL_sawampersand) {
1468 #ifdef PERL_OLD_COPY_ON_WRITE
1469 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1471 PerlIO_printf(Perl_debug_log,
1472 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1473 (int) SvTYPE(TARG), truebase, t,
1476 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1477 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1478 assert (SvPOKp(rx->saved_copy));
1483 rx->subbeg = savepvn(t, strend - t);
1484 #ifdef PERL_OLD_COPY_ON_WRITE
1485 rx->saved_copy = Nullsv;
1488 rx->sublen = strend - t;
1489 RX_MATCH_COPIED_on(rx);
1490 off = rx->startp[0] = s - t;
1491 rx->endp[0] = off + rx->minlen;
1493 else { /* startp/endp are used by @- @+. */
1494 rx->startp[0] = s - truebase;
1495 rx->endp[0] = s - truebase + rx->minlen;
1497 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1498 LEAVE_SCOPE(oldsave);
1503 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1504 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1505 MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1510 LEAVE_SCOPE(oldsave);
1511 if (gimme == G_ARRAY)
1517 Perl_do_readline(pTHX)
1519 dVAR; dSP; dTARGETSTACKED;
1524 register IO * const io = GvIO(PL_last_in_gv);
1525 register const I32 type = PL_op->op_type;
1526 const I32 gimme = GIMME_V;
1529 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1531 XPUSHs(SvTIED_obj((SV*)io, mg));
1534 call_method("READLINE", gimme);
1537 if (gimme == G_SCALAR) {
1539 SvSetSV_nosteal(TARG, result);
1548 if (IoFLAGS(io) & IOf_ARGV) {
1549 if (IoFLAGS(io) & IOf_START) {
1551 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1552 IoFLAGS(io) &= ~IOf_START;
1553 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1554 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1555 SvSETMAGIC(GvSV(PL_last_in_gv));
1560 fp = nextargv(PL_last_in_gv);
1561 if (!fp) { /* Note: fp != IoIFP(io) */
1562 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1565 else if (type == OP_GLOB)
1566 fp = Perl_start_glob(aTHX_ POPs, io);
1568 else if (type == OP_GLOB)
1570 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1571 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1575 if ((!io || !(IoFLAGS(io) & IOf_START))
1576 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1578 if (type == OP_GLOB)
1579 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1580 "glob failed (can't start child: %s)",
1583 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1585 if (gimme == G_SCALAR) {
1586 /* undef TARG, and push that undefined value */
1587 if (type != OP_RCATLINE) {
1588 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1596 if (gimme == G_SCALAR) {
1600 SvUPGRADE(sv, SVt_PV);
1601 tmplen = SvLEN(sv); /* remember if already alloced */
1602 if (!tmplen && !SvREADONLY(sv))
1603 Sv_Grow(sv, 80); /* try short-buffering it */
1605 if (type == OP_RCATLINE && SvOK(sv)) {
1607 SvPV_force_nolen(sv);
1613 sv = sv_2mortal(NEWSV(57, 80));
1617 /* This should not be marked tainted if the fp is marked clean */
1618 #define MAYBE_TAINT_LINE(io, sv) \
1619 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1624 /* delay EOF state for a snarfed empty file */
1625 #define SNARF_EOF(gimme,rs,io,sv) \
1626 (gimme != G_SCALAR || SvCUR(sv) \
1627 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1631 if (!sv_gets(sv, fp, offset)
1633 || SNARF_EOF(gimme, PL_rs, io, sv)
1634 || PerlIO_error(fp)))
1636 PerlIO_clearerr(fp);
1637 if (IoFLAGS(io) & IOf_ARGV) {
1638 fp = nextargv(PL_last_in_gv);
1641 (void)do_close(PL_last_in_gv, FALSE);
1643 else if (type == OP_GLOB) {
1644 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1645 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1646 "glob failed (child exited with status %d%s)",
1647 (int)(STATUS_CURRENT >> 8),
1648 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1651 if (gimme == G_SCALAR) {
1652 if (type != OP_RCATLINE) {
1653 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1659 MAYBE_TAINT_LINE(io, sv);
1662 MAYBE_TAINT_LINE(io, sv);
1664 IoFLAGS(io) |= IOf_NOLINE;
1668 if (type == OP_GLOB) {
1672 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1673 tmps = SvEND(sv) - 1;
1674 if (*tmps == *SvPVX_const(PL_rs)) {
1676 SvCUR_set(sv, SvCUR(sv) - 1);
1679 for (t1 = SvPVX_const(sv); *t1; t1++)
1680 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1681 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1683 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1684 (void)POPs; /* Unmatched wildcard? Chuck it... */
1687 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1688 const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1689 const STRLEN len = SvCUR(sv) - offset;
1692 if (ckWARN(WARN_UTF8) &&
1693 !is_utf8_string_loc(s, len, &f))
1694 /* Emulate :encoding(utf8) warning in the same case. */
1695 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1696 "utf8 \"\\x%02X\" does not map to Unicode",
1697 f < (U8*)SvEND(sv) ? *f : 0);
1699 if (gimme == G_ARRAY) {
1700 if (SvLEN(sv) - SvCUR(sv) > 20) {
1701 SvPV_shrink_to_cur(sv);
1703 sv = sv_2mortal(NEWSV(58, 80));
1706 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1707 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1708 const STRLEN new_len
1709 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1710 SvPV_renew(sv, new_len);
1719 register PERL_CONTEXT *cx;
1720 I32 gimme = OP_GIMME(PL_op, -1);
1723 if (cxstack_ix >= 0)
1724 gimme = cxstack[cxstack_ix].blk_gimme;
1732 PUSHBLOCK(cx, CXt_BLOCK, SP);
1744 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1745 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1747 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1750 if (SvTYPE(hv) == SVt_PVHV) {
1751 if (PL_op->op_private & OPpLVAL_INTRO) {
1754 /* does the element we're localizing already exist? */
1756 /* can we determine whether it exists? */
1758 || mg_find((SV*)hv, PERL_MAGIC_env)
1759 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1760 /* Try to preserve the existenceness of a tied hash
1761 * element by using EXISTS and DELETE if possible.
1762 * Fallback to FETCH and STORE otherwise */
1763 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1764 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1765 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1767 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1770 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1771 svp = he ? &HeVAL(he) : 0;
1777 if (!svp || *svp == &PL_sv_undef) {
1781 DIE(aTHX_ PL_no_helem_sv, keysv);
1783 lv = sv_newmortal();
1784 sv_upgrade(lv, SVt_PVLV);
1786 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1787 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1788 LvTARG(lv) = SvREFCNT_inc(hv);
1793 if (PL_op->op_private & OPpLVAL_INTRO) {
1794 if (HvNAME_get(hv) && isGV(*svp))
1795 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1799 const char * const key = SvPV_const(keysv, keylen);
1800 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1802 save_helem(hv, keysv, svp);
1805 else if (PL_op->op_private & OPpDEREF)
1806 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1808 sv = (svp ? *svp : &PL_sv_undef);
1809 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1810 * Pushing the magical RHS on to the stack is useless, since
1811 * that magic is soon destined to be misled by the local(),
1812 * and thus the later pp_sassign() will fail to mg_get() the
1813 * old value. This should also cure problems with delayed
1814 * mg_get()s. GSAR 98-07-03 */
1815 if (!lval && SvGMAGICAL(sv))
1816 sv = sv_mortalcopy(sv);
1824 register PERL_CONTEXT *cx;
1829 if (PL_op->op_flags & OPf_SPECIAL) {
1830 cx = &cxstack[cxstack_ix];
1831 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1836 gimme = OP_GIMME(PL_op, -1);
1838 if (cxstack_ix >= 0)
1839 gimme = cxstack[cxstack_ix].blk_gimme;
1845 if (gimme == G_VOID)
1847 else if (gimme == G_SCALAR) {
1851 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1854 *MARK = sv_mortalcopy(TOPs);
1857 *MARK = &PL_sv_undef;
1861 else if (gimme == G_ARRAY) {
1862 /* in case LEAVE wipes old return values */
1864 for (mark = newsp + 1; mark <= SP; mark++) {
1865 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1866 *mark = sv_mortalcopy(*mark);
1867 TAINT_NOT; /* Each item is independent */
1871 PL_curpm = newpm; /* Don't pop $1 et al till now */
1881 register PERL_CONTEXT *cx;
1887 cx = &cxstack[cxstack_ix];
1888 if (CxTYPE(cx) != CXt_LOOP)
1889 DIE(aTHX_ "panic: pp_iter");
1891 itersvp = CxITERVAR(cx);
1892 av = cx->blk_loop.iterary;
1893 if (SvTYPE(av) != SVt_PVAV) {
1894 /* iterate ($min .. $max) */
1895 if (cx->blk_loop.iterlval) {
1896 /* string increment */
1897 register SV* cur = cx->blk_loop.iterlval;
1899 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1900 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1901 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1902 /* safe to reuse old SV */
1903 sv_setsv(*itersvp, cur);
1907 /* we need a fresh SV every time so that loop body sees a
1908 * completely new SV for closures/references to work as
1911 *itersvp = newSVsv(cur);
1912 SvREFCNT_dec(oldsv);
1914 if (strEQ(SvPVX_const(cur), max))
1915 sv_setiv(cur, 0); /* terminate next time */
1922 /* integer increment */
1923 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1926 /* don't risk potential race */
1927 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1928 /* safe to reuse old SV */
1929 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1933 /* we need a fresh SV every time so that loop body sees a
1934 * completely new SV for closures/references to work as they
1937 *itersvp = newSViv(cx->blk_loop.iterix++);
1938 SvREFCNT_dec(oldsv);
1944 if (PL_op->op_private & OPpITER_REVERSED) {
1945 /* In reverse, use itermax as the min :-) */
1946 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1949 if (SvMAGICAL(av) || AvREIFY(av)) {
1950 SV ** const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1951 sv = svp ? *svp : Nullsv;
1954 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1958 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1962 if (SvMAGICAL(av) || AvREIFY(av)) {
1963 SV ** const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1964 sv = svp ? *svp : Nullsv;
1967 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1971 if (sv && SvIS_FREED(sv)) {
1973 Perl_croak(aTHX_ "Use of freed value in iteration");
1980 if (av != PL_curstack && sv == &PL_sv_undef) {
1981 SV *lv = cx->blk_loop.iterlval;
1982 if (lv && SvREFCNT(lv) > 1) {
1987 SvREFCNT_dec(LvTARG(lv));
1989 lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1990 sv_upgrade(lv, SVt_PVLV);
1992 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1994 LvTARG(lv) = SvREFCNT_inc(av);
1995 LvTARGOFF(lv) = cx->blk_loop.iterix;
1996 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2001 *itersvp = SvREFCNT_inc(sv);
2002 SvREFCNT_dec(oldsv);
2010 register PMOP *pm = cPMOP;
2026 register REGEXP *rx = PM_GETRE(pm);
2028 int force_on_match = 0;
2029 const I32 oldsave = PL_savestack_ix;
2031 bool doutf8 = FALSE;
2032 #ifdef PERL_OLD_COPY_ON_WRITE
2037 /* known replacement string? */
2038 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
2039 if (PL_op->op_flags & OPf_STACKED)
2041 else if (PL_op->op_private & OPpTARGET_MY)
2048 #ifdef PERL_OLD_COPY_ON_WRITE
2049 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2050 because they make integers such as 256 "false". */
2051 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2054 sv_force_normal_flags(TARG,0);
2057 #ifdef PERL_OLD_COPY_ON_WRITE
2061 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2062 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2063 DIE(aTHX_ PL_no_modify);
2066 s = SvPV_mutable(TARG, len);
2067 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2069 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2070 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2075 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2079 DIE(aTHX_ "panic: pp_subst");
2082 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2083 maxiters = 2 * slen + 10; /* We can match twice at each
2084 position, once with zero-length,
2085 second time with non-zero. */
2087 if (!rx->prelen && PL_curpm) {
2091 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2092 ? REXEC_COPY_STR : 0;
2094 r_flags |= REXEC_SCREAM;
2097 if (rx->reganch & RE_USE_INTUIT) {
2099 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2103 /* How to do it in subst? */
2104 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2106 && ((rx->reganch & ROPT_NOSCAN)
2107 || !((rx->reganch & RE_INTUIT_TAIL)
2108 && (r_flags & REXEC_SCREAM))))
2113 /* only replace once? */
2114 once = !(rpm->op_pmflags & PMf_GLOBAL);
2116 /* known replacement string? */
2118 /* replacement needing upgrading? */
2119 if (DO_UTF8(TARG) && !doutf8) {
2120 nsv = sv_newmortal();
2123 sv_recode_to_utf8(nsv, PL_encoding);
2125 sv_utf8_upgrade(nsv);
2126 c = SvPV_const(nsv, clen);
2130 c = SvPV_const(dstr, clen);
2131 doutf8 = DO_UTF8(dstr);
2139 /* can do inplace substitution? */
2141 #ifdef PERL_OLD_COPY_ON_WRITE
2144 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2145 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2146 && (!doutf8 || SvUTF8(TARG))) {
2147 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2148 r_flags | REXEC_CHECKED))
2152 LEAVE_SCOPE(oldsave);
2155 #ifdef PERL_OLD_COPY_ON_WRITE
2156 if (SvIsCOW(TARG)) {
2157 assert (!force_on_match);
2161 if (force_on_match) {
2163 s = SvPV_force(TARG, len);
2168 SvSCREAM_off(TARG); /* disable possible screamer */
2170 rxtainted |= RX_MATCH_TAINTED(rx);
2171 m = orig + rx->startp[0];
2172 d = orig + rx->endp[0];
2174 if (m - s > strend - d) { /* faster to shorten from end */
2176 Copy(c, m, clen, char);
2181 Move(d, m, i, char);
2185 SvCUR_set(TARG, m - s);
2187 else if ((i = m - s)) { /* faster from front */
2195 Copy(c, m, clen, char);
2200 Copy(c, d, clen, char);
2205 TAINT_IF(rxtainted & 1);
2211 if (iters++ > maxiters)
2212 DIE(aTHX_ "Substitution loop");
2213 rxtainted |= RX_MATCH_TAINTED(rx);
2214 m = rx->startp[0] + orig;
2217 Move(s, d, i, char);
2221 Copy(c, d, clen, char);
2224 s = rx->endp[0] + orig;
2225 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2227 /* don't match same null twice */
2228 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2231 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2232 Move(s, d, i+1, char); /* include the NUL */
2234 TAINT_IF(rxtainted & 1);
2236 PUSHs(sv_2mortal(newSViv((I32)iters)));
2238 (void)SvPOK_only_UTF8(TARG);
2239 TAINT_IF(rxtainted);
2240 if (SvSMAGICAL(TARG)) {
2248 LEAVE_SCOPE(oldsave);
2252 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2253 r_flags | REXEC_CHECKED))
2255 if (force_on_match) {
2257 s = SvPV_force(TARG, len);
2260 #ifdef PERL_OLD_COPY_ON_WRITE
2263 rxtainted |= RX_MATCH_TAINTED(rx);
2264 dstr = newSVpvn(m, s-m);
2269 register PERL_CONTEXT *cx;
2271 (void)ReREFCNT_inc(rx);
2273 RETURNOP(cPMOP->op_pmreplroot);
2275 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2277 if (iters++ > maxiters)
2278 DIE(aTHX_ "Substitution loop");
2279 rxtainted |= RX_MATCH_TAINTED(rx);
2280 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2285 strend = s + (strend - m);
2287 m = rx->startp[0] + orig;
2288 if (doutf8 && !SvUTF8(dstr))
2289 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2291 sv_catpvn(dstr, s, m-s);
2292 s = rx->endp[0] + orig;
2294 sv_catpvn(dstr, c, clen);
2297 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2298 TARG, NULL, r_flags));
2299 if (doutf8 && !DO_UTF8(TARG))
2300 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2302 sv_catpvn(dstr, s, strend - s);
2304 #ifdef PERL_OLD_COPY_ON_WRITE
2305 /* The match may make the string COW. If so, brilliant, because that's
2306 just saved us one malloc, copy and free - the regexp has donated
2307 the old buffer, and we malloc an entirely new one, rather than the
2308 regexp malloc()ing a buffer and copying our original, only for
2309 us to throw it away here during the substitution. */
2310 if (SvIsCOW(TARG)) {
2311 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2317 SvPV_set(TARG, SvPVX(dstr));
2318 SvCUR_set(TARG, SvCUR(dstr));
2319 SvLEN_set(TARG, SvLEN(dstr));
2320 doutf8 |= DO_UTF8(dstr);
2321 SvPV_set(dstr, (char*)0);
2324 TAINT_IF(rxtainted & 1);
2326 PUSHs(sv_2mortal(newSViv((I32)iters)));
2328 (void)SvPOK_only(TARG);
2331 TAINT_IF(rxtainted);
2334 LEAVE_SCOPE(oldsave);
2343 LEAVE_SCOPE(oldsave);
2352 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2353 ++*PL_markstack_ptr;
2354 LEAVE; /* exit inner scope */
2357 if (PL_stack_base + *PL_markstack_ptr > SP) {
2359 const I32 gimme = GIMME_V;
2361 LEAVE; /* exit outer scope */
2362 (void)POPMARK; /* pop src */
2363 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2364 (void)POPMARK; /* pop dst */
2365 SP = PL_stack_base + POPMARK; /* pop original mark */
2366 if (gimme == G_SCALAR) {
2367 if (PL_op->op_private & OPpGREP_LEX) {
2368 SV* const sv = sv_newmortal();
2369 sv_setiv(sv, items);
2377 else if (gimme == G_ARRAY)
2384 ENTER; /* enter inner scope */
2387 src = PL_stack_base[*PL_markstack_ptr];
2389 if (PL_op->op_private & OPpGREP_LEX)
2390 PAD_SVl(PL_op->op_targ) = src;
2394 RETURNOP(cLOGOP->op_other);
2405 register PERL_CONTEXT *cx;
2408 if (CxMULTICALL(&cxstack[cxstack_ix]))
2412 cxstack_ix++; /* temporarily protect top context */
2415 if (gimme == G_SCALAR) {
2418 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2420 *MARK = SvREFCNT_inc(TOPs);
2425 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2427 *MARK = sv_mortalcopy(sv);
2432 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2436 *MARK = &PL_sv_undef;
2440 else if (gimme == G_ARRAY) {
2441 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2442 if (!SvTEMP(*MARK)) {
2443 *MARK = sv_mortalcopy(*MARK);
2444 TAINT_NOT; /* Each item is independent */
2452 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2453 PL_curpm = newpm; /* ... and pop $1 et al */
2456 return cx->blk_sub.retop;
2459 /* This duplicates the above code because the above code must not
2460 * get any slower by more conditions */
2468 register PERL_CONTEXT *cx;
2471 if (CxMULTICALL(&cxstack[cxstack_ix]))
2475 cxstack_ix++; /* temporarily protect top context */
2479 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2480 /* We are an argument to a function or grep().
2481 * This kind of lvalueness was legal before lvalue
2482 * subroutines too, so be backward compatible:
2483 * cannot report errors. */
2485 /* Scalar context *is* possible, on the LHS of -> only,
2486 * as in f()->meth(). But this is not an lvalue. */
2487 if (gimme == G_SCALAR)
2489 if (gimme == G_ARRAY) {
2490 if (!CvLVALUE(cx->blk_sub.cv))
2491 goto temporise_array;
2492 EXTEND_MORTAL(SP - newsp);
2493 for (mark = newsp + 1; mark <= SP; mark++) {
2496 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2497 *mark = sv_mortalcopy(*mark);
2499 /* Can be a localized value subject to deletion. */
2500 PL_tmps_stack[++PL_tmps_ix] = *mark;
2501 (void)SvREFCNT_inc(*mark);
2506 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2507 /* Here we go for robustness, not for speed, so we change all
2508 * the refcounts so the caller gets a live guy. Cannot set
2509 * TEMP, so sv_2mortal is out of question. */
2510 if (!CvLVALUE(cx->blk_sub.cv)) {
2516 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2518 if (gimme == G_SCALAR) {
2522 /* Temporaries are bad unless they happen to be elements
2523 * of a tied hash or array */
2524 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2525 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2531 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2532 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2533 : "a readonly value" : "a temporary");
2535 else { /* Can be a localized value
2536 * subject to deletion. */
2537 PL_tmps_stack[++PL_tmps_ix] = *mark;
2538 (void)SvREFCNT_inc(*mark);
2541 else { /* Should not happen? */
2547 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2548 (MARK > SP ? "Empty array" : "Array"));
2552 else if (gimme == G_ARRAY) {
2553 EXTEND_MORTAL(SP - newsp);
2554 for (mark = newsp + 1; mark <= SP; mark++) {
2555 if (*mark != &PL_sv_undef
2556 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2557 /* Might be flattened array after $#array = */
2564 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2565 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2568 /* Can be a localized value subject to deletion. */
2569 PL_tmps_stack[++PL_tmps_ix] = *mark;
2570 (void)SvREFCNT_inc(*mark);
2576 if (gimme == G_SCALAR) {
2580 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2582 *MARK = SvREFCNT_inc(TOPs);
2587 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2589 *MARK = sv_mortalcopy(sv);
2594 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2598 *MARK = &PL_sv_undef;
2602 else if (gimme == G_ARRAY) {
2604 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2605 if (!SvTEMP(*MARK)) {
2606 *MARK = sv_mortalcopy(*MARK);
2607 TAINT_NOT; /* Each item is independent */
2616 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2617 PL_curpm = newpm; /* ... and pop $1 et al */
2620 return cx->blk_sub.retop;
2625 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2627 SV * const dbsv = GvSVn(PL_DBsub);
2630 if (!PERLDB_SUB_NN) {
2633 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2634 || strEQ(GvNAME(gv), "END")
2635 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2636 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2637 && (gv = (GV*)*svp) ))) {
2638 /* Use GV from the stack as a fallback. */
2639 /* GV is potentially non-unique, or contain different CV. */
2640 SV * const tmp = newRV((SV*)cv);
2641 sv_setsv(dbsv, tmp);
2645 gv_efullname3(dbsv, gv, Nullch);
2649 const int type = SvTYPE(dbsv);
2650 if (type < SVt_PVIV && type != SVt_IV)
2651 sv_upgrade(dbsv, SVt_PVIV);
2652 (void)SvIOK_on(dbsv);
2653 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2657 PL_curcopdb = PL_curcop;
2658 cv = GvCV(PL_DBsub);
2667 register PERL_CONTEXT *cx;
2669 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2672 DIE(aTHX_ "Not a CODE reference");
2673 switch (SvTYPE(sv)) {
2674 /* This is overwhelming the most common case: */
2676 if (!(cv = GvCVu((GV*)sv))) {
2678 cv = sv_2cv(sv, &stash, &gv, 0);
2689 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2691 SP = PL_stack_base + POPMARK;
2694 if (SvGMAGICAL(sv)) {
2698 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2701 sym = SvPV_nolen_const(sv);
2704 DIE(aTHX_ PL_no_usym, "a subroutine");
2705 if (PL_op->op_private & HINT_STRICT_REFS)
2706 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2707 cv = get_cv(sym, TRUE);
2712 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2713 tryAMAGICunDEREF(to_cv);
2716 if (SvTYPE(cv) == SVt_PVCV)
2721 DIE(aTHX_ "Not a CODE reference");
2722 /* This is the second most common case: */
2732 if (!CvROOT(cv) && !CvXSUB(cv)) {
2736 /* anonymous or undef'd function leaves us no recourse */
2737 if (CvANON(cv) || !(gv = CvGV(cv)))
2738 DIE(aTHX_ "Undefined subroutine called");
2740 /* autoloaded stub? */
2741 if (cv != GvCV(gv)) {
2744 /* should call AUTOLOAD now? */
2747 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2754 sub_name = sv_newmortal();
2755 gv_efullname3(sub_name, gv, Nullch);
2756 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2760 DIE(aTHX_ "Not a CODE reference");
2765 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2766 if (CvASSERTION(cv) && PL_DBassertion)
2767 sv_setiv(PL_DBassertion, 1);
2769 cv = get_db_sub(&sv, cv);
2770 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2771 DIE(aTHX_ "No DB::sub routine defined");
2774 if (!(CvXSUB(cv))) {
2775 /* This path taken at least 75% of the time */
2777 register I32 items = SP - MARK;
2778 AV* const padlist = CvPADLIST(cv);
2779 PUSHBLOCK(cx, CXt_SUB, MARK);
2781 cx->blk_sub.retop = PL_op->op_next;
2783 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2784 * that eval'' ops within this sub know the correct lexical space.
2785 * Owing the speed considerations, we choose instead to search for
2786 * the cv using find_runcv() when calling doeval().
2788 if (CvDEPTH(cv) >= 2) {
2789 PERL_STACK_OVERFLOW_CHECK();
2790 pad_push(padlist, CvDEPTH(cv));
2793 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2796 AV* const av = (AV*)PAD_SVl(0);
2798 /* @_ is normally not REAL--this should only ever
2799 * happen when DB::sub() calls things that modify @_ */
2804 cx->blk_sub.savearray = GvAV(PL_defgv);
2805 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2806 CX_CURPAD_SAVE(cx->blk_sub);
2807 cx->blk_sub.argarray = av;
2810 if (items > AvMAX(av) + 1) {
2811 SV **ary = AvALLOC(av);
2812 if (AvARRAY(av) != ary) {
2813 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2814 SvPV_set(av, (char*)ary);
2816 if (items > AvMAX(av) + 1) {
2817 AvMAX(av) = items - 1;
2818 Renew(ary,items,SV*);
2820 SvPV_set(av, (char*)ary);
2823 Copy(MARK,AvARRAY(av),items,SV*);
2824 AvFILLp(av) = items - 1;
2832 /* warning must come *after* we fully set up the context
2833 * stuff so that __WARN__ handlers can safely dounwind()
2836 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2837 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2838 sub_crush_depth(cv);
2840 DEBUG_S(PerlIO_printf(Perl_debug_log,
2841 "%p entersub returning %p\n", thr, CvSTART(cv)));
2843 RETURNOP(CvSTART(cv));
2846 #ifdef PERL_XSUB_OLDSTYLE
2847 if (CvOLDSTYLE(cv)) {
2848 I32 (*fp3)(int,int,int);
2850 register I32 items = SP - MARK;
2851 /* We dont worry to copy from @_. */
2856 PL_stack_sp = mark + 1;
2857 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2858 items = (*fp3)(CvXSUBANY(cv).any_i32,
2859 MARK - PL_stack_base + 1,
2861 PL_stack_sp = PL_stack_base + items;
2864 #endif /* PERL_XSUB_OLDSTYLE */
2866 I32 markix = TOPMARK;
2871 /* Need to copy @_ to stack. Alternative may be to
2872 * switch stack to @_, and copy return values
2873 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2874 AV * const av = GvAV(PL_defgv);
2875 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2878 /* Mark is at the end of the stack. */
2880 Copy(AvARRAY(av), SP + 1, items, SV*);
2885 /* We assume first XSUB in &DB::sub is the called one. */
2887 SAVEVPTR(PL_curcop);
2888 PL_curcop = PL_curcopdb;
2891 /* Do we need to open block here? XXXX */
2892 (void)(*CvXSUB(cv))(aTHX_ cv);
2894 /* Enforce some sanity in scalar context. */
2895 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2896 if (markix > PL_stack_sp - PL_stack_base)
2897 *(PL_stack_base + markix) = &PL_sv_undef;
2899 *(PL_stack_base + markix) = *PL_stack_sp;
2900 PL_stack_sp = PL_stack_base + markix;
2909 Perl_sub_crush_depth(pTHX_ CV *cv)
2912 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2914 SV* const tmpstr = sv_newmortal();
2915 gv_efullname3(tmpstr, CvGV(cv), Nullch);
2916 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2925 SV* const elemsv = POPs;
2926 IV elem = SvIV(elemsv);
2927 AV* const av = (AV*)POPs;
2928 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2929 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2932 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2933 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2935 elem -= PL_curcop->cop_arybase;
2936 if (SvTYPE(av) != SVt_PVAV)
2938 svp = av_fetch(av, elem, lval && !defer);
2940 #ifdef PERL_MALLOC_WRAP
2941 if (SvUOK(elemsv)) {
2942 const UV uv = SvUV(elemsv);
2943 elem = uv > IV_MAX ? IV_MAX : uv;
2945 else if (SvNOK(elemsv))
2946 elem = (IV)SvNV(elemsv);
2948 static const char oom_array_extend[] =
2949 "Out of memory during array extend"; /* Duplicated in av.c */
2950 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2953 if (!svp || *svp == &PL_sv_undef) {
2956 DIE(aTHX_ PL_no_aelem, elem);
2957 lv = sv_newmortal();
2958 sv_upgrade(lv, SVt_PVLV);
2960 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2961 LvTARG(lv) = SvREFCNT_inc(av);
2962 LvTARGOFF(lv) = elem;
2967 if (PL_op->op_private & OPpLVAL_INTRO)
2968 save_aelem(av, elem, svp);
2969 else if (PL_op->op_private & OPpDEREF)
2970 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2972 sv = (svp ? *svp : &PL_sv_undef);
2973 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2974 sv = sv_mortalcopy(sv);
2980 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2985 Perl_croak(aTHX_ PL_no_modify);
2986 if (SvTYPE(sv) < SVt_RV)
2987 sv_upgrade(sv, SVt_RV);
2988 else if (SvTYPE(sv) >= SVt_PV) {
2995 SvRV_set(sv, NEWSV(355,0));
2998 SvRV_set(sv, (SV*)newAV());
3001 SvRV_set(sv, (SV*)newHV());
3012 SV* const sv = TOPs;
3015 SV* const rsv = SvRV(sv);
3016 if (SvTYPE(rsv) == SVt_PVCV) {
3022 SETs(method_common(sv, Null(U32*)));
3029 SV* const sv = cSVOP_sv;
3030 U32 hash = SvSHARED_HASH(sv);
3032 XPUSHs(method_common(sv, &hash));
3037 S_method_common(pTHX_ SV* meth, U32* hashp)
3043 const char* packname = Nullch;
3044 SV *packsv = Nullsv;
3046 const char * const name = SvPV_const(meth, namelen);
3047 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3050 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3058 /* this isn't a reference */
3059 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3060 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3062 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3069 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3070 !(ob=(SV*)GvIO(iogv)))
3072 /* this isn't the name of a filehandle either */
3074 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3075 ? !isIDFIRST_utf8((U8*)packname)
3076 : !isIDFIRST(*packname)
3079 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3080 SvOK(sv) ? "without a package or object reference"
3081 : "on an undefined value");
3083 /* assume it's a package name */
3084 stash = gv_stashpvn(packname, packlen, FALSE);
3088 SV* ref = newSViv(PTR2IV(stash));
3089 hv_store(PL_stashcache, packname, packlen, ref, 0);
3093 /* it _is_ a filehandle name -- replace with a reference */
3094 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3097 /* if we got here, ob should be a reference or a glob */
3098 if (!ob || !(SvOBJECT(ob)
3099 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3102 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3106 stash = SvSTASH(ob);
3109 /* NOTE: stash may be null, hope hv_fetch_ent and
3110 gv_fetchmethod can cope (it seems they can) */
3112 /* shortcut for simple names */
3114 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3116 gv = (GV*)HeVAL(he);
3117 if (isGV(gv) && GvCV(gv) &&
3118 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3119 return (SV*)GvCV(gv);
3123 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3126 /* This code tries to figure out just what went wrong with
3127 gv_fetchmethod. It therefore needs to duplicate a lot of
3128 the internals of that function. We can't move it inside
3129 Perl_gv_fetchmethod_autoload(), however, since that would
3130 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3133 const char* leaf = name;
3134 const char* sep = Nullch;
3137 for (p = name; *p; p++) {
3139 sep = p, leaf = p + 1;
3140 else if (*p == ':' && *(p + 1) == ':')
3141 sep = p, leaf = p + 2;
3143 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3144 /* the method name is unqualified or starts with SUPER:: */
3145 bool need_strlen = 1;
3147 packname = CopSTASHPV(PL_curcop);
3150 HEK * const packhek = HvNAME_HEK(stash);
3152 packname = HEK_KEY(packhek);
3153 packlen = HEK_LEN(packhek);
3163 "Can't use anonymous symbol table for method lookup");
3165 else if (need_strlen)
3166 packlen = strlen(packname);
3170 /* the method name is qualified */
3172 packlen = sep - name;
3175 /* we're relying on gv_fetchmethod not autovivifying the stash */
3176 if (gv_stashpvn(packname, packlen, FALSE)) {
3178 "Can't locate object method \"%s\" via package \"%.*s\"",
3179 leaf, (int)packlen, packname);
3183 "Can't locate object method \"%s\" via package \"%.*s\""
3184 " (perhaps you forgot to load \"%.*s\"?)",
3185 leaf, (int)packlen, packname, (int)packlen, packname);
3188 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3193 * c-indentation-style: bsd
3195 * indent-tabs-mode: t
3198 * ex: set ts=8 sts=4 sw=4 noet: