3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (PL_op->op_private & OPpLVAL_INTRO)
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
77 PL_curcop = (COP*)PL_op;
84 PUSHMARK(PL_stack_sp);
99 XPUSHs((SV*)cGVOP_gv);
109 if (PL_op->op_type == OP_AND)
111 RETURNOP(cLOGOP->op_other);
117 dVAR; dSP; dPOPTOPssrl;
119 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
120 SV * const temp = left;
121 left = right; right = temp;
123 if (PL_tainting && PL_tainted && !SvTAINTED(left))
125 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
126 SV * const cv = SvRV(left);
127 const U32 cv_type = SvTYPE(cv);
128 const U32 gv_type = SvTYPE(right);
129 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
135 /* Can do the optimisation if right (LVAUE) is not a typeglob,
136 left (RVALUE) is a reference to something, and we're in void
138 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
139 /* Is the target symbol table currently empty? */
140 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
141 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
142 /* Good. Create a new proxy constant subroutine in the target.
143 The gv becomes a(nother) reference to the constant. */
144 SV *const value = SvRV(cv);
146 SvUPGRADE((SV *)gv, SVt_RV);
155 /* Need to fix things up. */
156 if (gv_type != SVt_PVGV) {
157 /* Need to fix GV. */
158 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
162 /* We've been returned a constant rather than a full subroutine,
163 but they expect a subroutine reference to apply. */
165 SvREFCNT_inc(SvRV(cv));
166 /* newCONSTSUB takes a reference count on the passed in SV
167 from us. We set the name to NULL, otherwise we get into
168 all sorts of fun as the reference to our new sub is
169 donated to the GV that we're about to assign to.
171 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
178 SvSetMagicSV(right, left);
187 RETURNOP(cLOGOP->op_other);
189 RETURNOP(cLOGOP->op_next);
196 TAINT_NOT; /* Each statement is presumed innocent */
197 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
199 oldsave = PL_scopestack[PL_scopestack_ix - 1];
200 LEAVE_SCOPE(oldsave);
206 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
213 bool rcopied = FALSE;
215 if (TARG == right && right != left) {
216 /* mg_get(right) may happen here ... */
217 rpv = SvPV_const(right, rlen);
218 rbyte = !DO_UTF8(right);
219 right = sv_2mortal(newSVpvn(rpv, rlen));
220 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
226 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
227 lbyte = !DO_UTF8(left);
228 sv_setpvn(TARG, lpv, llen);
234 else { /* TARG == left */
236 SvGETMAGIC(left); /* or mg_get(left) may happen here */
238 if (left == right && ckWARN(WARN_UNINITIALIZED))
239 report_uninit(right);
240 sv_setpvn(left, "", 0);
242 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
243 lbyte = !DO_UTF8(left);
248 /* or mg_get(right) may happen here */
250 rpv = SvPV_const(right, rlen);
251 rbyte = !DO_UTF8(right);
253 if (lbyte != rbyte) {
255 sv_utf8_upgrade_nomg(TARG);
258 right = sv_2mortal(newSVpvn(rpv, rlen));
259 sv_utf8_upgrade_nomg(right);
260 rpv = SvPV_const(right, rlen);
263 sv_catpvn_nomg(TARG, rpv, rlen);
274 if (PL_op->op_flags & OPf_MOD) {
275 if (PL_op->op_private & OPpLVAL_INTRO)
276 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
277 if (PL_op->op_private & OPpDEREF) {
279 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
289 tryAMAGICunTARGET(iter, 0);
290 PL_last_in_gv = (GV*)(*PL_stack_sp--);
291 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
292 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
293 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
296 XPUSHs((SV*)PL_last_in_gv);
299 PL_last_in_gv = (GV*)(*PL_stack_sp--);
302 return do_readline();
307 dVAR; dSP; tryAMAGICbinSET(eq,0);
308 #ifndef NV_PRESERVES_UV
309 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
311 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
315 #ifdef PERL_PRESERVE_IVUV
318 /* Unless the left argument is integer in range we are going
319 to have to use NV maths. Hence only attempt to coerce the
320 right argument if we know the left is integer. */
323 const bool auvok = SvUOK(TOPm1s);
324 const bool buvok = SvUOK(TOPs);
326 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
327 /* Casting IV to UV before comparison isn't going to matter
328 on 2s complement. On 1s complement or sign&magnitude
329 (if we have any of them) it could to make negative zero
330 differ from normal zero. As I understand it. (Need to
331 check - is negative zero implementation defined behaviour
333 const UV buv = SvUVX(POPs);
334 const UV auv = SvUVX(TOPs);
336 SETs(boolSV(auv == buv));
339 { /* ## Mixed IV,UV ## */
343 /* == is commutative so doesn't matter which is left or right */
345 /* top of stack (b) is the iv */
354 /* As uv is a UV, it's >0, so it cannot be == */
358 /* we know iv is >= 0 */
359 SETs(boolSV((UV)iv == SvUVX(uvp)));
367 SETs(boolSV(TOPn == value));
375 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
376 DIE(aTHX_ PL_no_modify);
377 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
378 && SvIVX(TOPs) != IV_MAX)
380 SvIV_set(TOPs, SvIVX(TOPs) + 1);
381 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
383 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
395 if (PL_op->op_type == OP_OR)
397 RETURNOP(cLOGOP->op_other);
406 const int op_type = PL_op->op_type;
407 const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
411 if (!sv || !SvANY(sv)) {
412 if (op_type == OP_DOR)
414 RETURNOP(cLOGOP->op_other);
416 } else if (op_type == OP_DEFINED) {
418 if (!sv || !SvANY(sv))
421 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
424 switch (SvTYPE(sv)) {
426 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
430 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
434 if (CvROOT(sv) || CvXSUB(sv))
447 if(op_type == OP_DOR)
449 RETURNOP(cLOGOP->op_other);
451 /* assuming OP_DEFINED */
459 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
460 useleft = USE_LEFT(TOPm1s);
461 #ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
472 A side effect is that this also aggressively prefers integer maths over
473 fp maths for integer values.
475 How to detect overflow?
477 C 99 section 6.2.6.1 says
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
489 which I read as "unsigned ints wrap."
491 signed integer overflow seems to be classed as "exception condition"
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
498 (6.5, the 5th paragraph)
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
510 /* Unless the left argument is integer in range we are going to have to
511 use NV maths. Hence only attempt to coerce the right argument if
512 we know the left is integer. */
520 /* left operand is undef, treat as zero. + 0 is identity,
521 Could SETi or SETu right now, but space optimise by not adding
522 lots of code to speed up what is probably a rarish case. */
524 /* Left operand is defined, so is it IV? */
527 if ((auvok = SvUOK(TOPm1s)))
530 register const IV aiv = SvIVX(TOPm1s);
533 auvok = 1; /* Now acting as a sign flag. */
534 } else { /* 2s complement assumption for IV_MIN */
542 bool result_good = 0;
545 bool buvok = SvUOK(TOPs);
550 register const IV biv = SvIVX(TOPs);
557 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
558 else "IV" now, independent of how it came in.
559 if a, b represents positive, A, B negative, a maps to -A etc
564 all UV maths. negate result if A negative.
565 add if signs same, subtract if signs differ. */
571 /* Must get smaller */
577 /* result really should be -(auv-buv). as its negation
578 of true value, need to swap our result flag */
595 if (result <= (UV)IV_MIN)
598 /* result valid, but out of range for IV. */
603 } /* Overflow, drop through to NVs. */
610 /* left operand is undef, treat as zero. + 0.0 is identity. */
614 SETn( value + TOPn );
622 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
623 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
624 const U32 lval = PL_op->op_flags & OPf_MOD;
625 SV** const svp = av_fetch(av, PL_op->op_private, lval);
626 SV *sv = (svp ? *svp : &PL_sv_undef);
628 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
629 sv = sv_mortalcopy(sv);
636 dVAR; dSP; dMARK; dTARGET;
638 do_join(TARG, *MARK, MARK, SP);
649 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
650 * will be enough to hold an OP*.
652 SV* const sv = sv_newmortal();
653 sv_upgrade(sv, SVt_PVLV);
655 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
663 /* Oversized hot code. */
667 dVAR; dSP; dMARK; dORIGMARK;
671 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
673 if (gv && (io = GvIO(gv))
674 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
677 if (MARK == ORIGMARK) {
678 /* If using default handle then we need to make space to
679 * pass object as 1st arg, so move other args up ...
683 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
687 *MARK = SvTIED_obj((SV*)io, mg);
690 call_method("PRINT", G_SCALAR);
698 if (!(io = GvIO(gv))) {
699 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
700 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
702 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
703 report_evil_fh(gv, io, PL_op->op_type);
704 SETERRNO(EBADF,RMS_IFI);
707 else if (!(fp = IoOFP(io))) {
708 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
710 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
711 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
712 report_evil_fh(gv, io, PL_op->op_type);
714 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
719 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
721 if (!do_print(*MARK, fp))
725 if (!do_print(PL_ofs_sv, fp)) { /* $, */
734 if (!do_print(*MARK, fp))
742 if (PL_ors_sv && SvOK(PL_ors_sv))
743 if (!do_print(PL_ors_sv, fp)) /* $\ */
746 if (IoFLAGS(io) & IOf_FLUSH)
747 if (PerlIO_flush(fp) == EOF)
757 XPUSHs(&PL_sv_undef);
768 tryAMAGICunDEREF(to_av);
771 if (SvTYPE(av) != SVt_PVAV)
772 DIE(aTHX_ "Not an ARRAY reference");
773 if (PL_op->op_flags & OPf_REF) {
778 if (GIMME == G_SCALAR)
779 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
783 else if (PL_op->op_flags & OPf_MOD
784 && PL_op->op_private & OPpLVAL_INTRO)
785 Perl_croak(aTHX_ PL_no_localize_ref);
788 if (SvTYPE(sv) == SVt_PVAV) {
790 if (PL_op->op_flags & OPf_REF) {
795 if (GIMME == G_SCALAR)
796 Perl_croak(aTHX_ "Can't return array to lvalue"
805 if (SvTYPE(sv) != SVt_PVGV) {
806 if (SvGMAGICAL(sv)) {
812 if (PL_op->op_flags & OPf_REF ||
813 PL_op->op_private & HINT_STRICT_REFS)
814 DIE(aTHX_ PL_no_usym, "an ARRAY");
815 if (ckWARN(WARN_UNINITIALIZED))
817 if (GIMME == G_ARRAY) {
823 if ((PL_op->op_flags & OPf_SPECIAL) &&
824 !(PL_op->op_flags & OPf_MOD))
826 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
828 && (!is_gv_magical_sv(sv,0)
829 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
835 if (PL_op->op_private & HINT_STRICT_REFS)
836 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
837 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
844 if (PL_op->op_private & OPpLVAL_INTRO)
846 if (PL_op->op_flags & OPf_REF) {
851 if (GIMME == G_SCALAR)
852 Perl_croak(aTHX_ "Can't return array to lvalue"
860 if (GIMME == G_ARRAY) {
861 const I32 maxarg = AvFILL(av) + 1;
862 (void)POPs; /* XXXX May be optimized away? */
864 if (SvRMAGICAL(av)) {
866 for (i=0; i < (U32)maxarg; i++) {
867 SV ** const svp = av_fetch(av, i, FALSE);
868 /* See note in pp_helem, and bug id #27839 */
870 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
875 Copy(AvARRAY(av), SP+1, maxarg, SV*);
879 else if (GIMME_V == G_SCALAR) {
881 const I32 maxarg = AvFILL(av) + 1;
891 const I32 gimme = GIMME_V;
892 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
896 tryAMAGICunDEREF(to_hv);
899 if (SvTYPE(hv) != SVt_PVHV)
900 DIE(aTHX_ "Not a HASH reference");
901 if (PL_op->op_flags & OPf_REF) {
906 if (gimme != G_ARRAY)
907 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
911 else if (PL_op->op_flags & OPf_MOD
912 && PL_op->op_private & OPpLVAL_INTRO)
913 Perl_croak(aTHX_ PL_no_localize_ref);
916 if (SvTYPE(sv) == SVt_PVHV) {
918 if (PL_op->op_flags & OPf_REF) {
923 if (gimme != G_ARRAY)
924 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
932 if (SvTYPE(sv) != SVt_PVGV) {
933 if (SvGMAGICAL(sv)) {
939 if (PL_op->op_flags & OPf_REF ||
940 PL_op->op_private & HINT_STRICT_REFS)
941 DIE(aTHX_ PL_no_usym, "a HASH");
942 if (ckWARN(WARN_UNINITIALIZED))
944 if (gimme == G_ARRAY) {
950 if ((PL_op->op_flags & OPf_SPECIAL) &&
951 !(PL_op->op_flags & OPf_MOD))
953 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
955 && (!is_gv_magical_sv(sv,0)
956 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
962 if (PL_op->op_private & HINT_STRICT_REFS)
963 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
964 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
971 if (PL_op->op_private & OPpLVAL_INTRO)
973 if (PL_op->op_flags & OPf_REF) {
978 if (gimme != G_ARRAY)
979 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
986 if (gimme == G_ARRAY) { /* array wanted */
987 *PL_stack_sp = (SV*)hv;
990 else if (gimme == G_SCALAR) {
992 TARG = Perl_hv_scalar(aTHX_ hv);
999 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1006 if (ckWARN(WARN_MISC)) {
1008 if (relem == firstrelem &&
1010 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1011 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1013 err = "Reference found where even-sized list expected";
1016 err = "Odd number of elements in hash assignment";
1017 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1021 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1022 if (SvMAGICAL(hash)) {
1023 if (SvSMAGICAL(tmpstr))
1035 SV **lastlelem = PL_stack_sp;
1036 SV **lastrelem = PL_stack_base + POPMARK;
1037 SV **firstrelem = PL_stack_base + POPMARK + 1;
1038 SV **firstlelem = lastrelem + 1;
1040 register SV **relem;
1041 register SV **lelem;
1051 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1054 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1057 /* If there's a common identifier on both sides we have to take
1058 * special care that assigning the identifier on the left doesn't
1059 * clobber a value on the right that's used later in the list.
1061 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1062 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1063 for (relem = firstrelem; relem <= lastrelem; relem++) {
1064 if ((sv = *relem)) {
1065 TAINT_NOT; /* Each item is independent */
1066 *relem = sv_mortalcopy(sv);
1076 while (lelem <= lastlelem) {
1077 TAINT_NOT; /* Each item stands on its own, taintwise. */
1079 switch (SvTYPE(sv)) {
1082 magic = SvMAGICAL(ary) != 0;
1084 av_extend(ary, lastrelem - relem);
1086 while (relem <= lastrelem) { /* gobble up all the rest */
1089 sv = newSVsv(*relem);
1091 didstore = av_store(ary,i++,sv);
1101 case SVt_PVHV: { /* normal hash */
1105 magic = SvMAGICAL(hash) != 0;
1107 firsthashrelem = relem;
1109 while (relem < lastrelem) { /* gobble up all the rest */
1111 sv = *relem ? *relem : &PL_sv_no;
1115 sv_setsv(tmpstr,*relem); /* value */
1116 *(relem++) = tmpstr;
1117 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1118 /* key overwrites an existing entry */
1120 didstore = hv_store_ent(hash,sv,tmpstr,0);
1122 if (SvSMAGICAL(tmpstr))
1129 if (relem == lastrelem) {
1130 do_oddball(hash, relem, firstrelem);
1136 if (SvIMMORTAL(sv)) {
1137 if (relem <= lastrelem)
1141 if (relem <= lastrelem) {
1142 sv_setsv(sv, *relem);
1146 sv_setsv(sv, &PL_sv_undef);
1151 if (PL_delaymagic & ~DM_DELAY) {
1152 if (PL_delaymagic & DM_UID) {
1153 #ifdef HAS_SETRESUID
1154 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1155 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1158 # ifdef HAS_SETREUID
1159 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1160 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1163 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1164 (void)setruid(PL_uid);
1165 PL_delaymagic &= ~DM_RUID;
1167 # endif /* HAS_SETRUID */
1169 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1170 (void)seteuid(PL_euid);
1171 PL_delaymagic &= ~DM_EUID;
1173 # endif /* HAS_SETEUID */
1174 if (PL_delaymagic & DM_UID) {
1175 if (PL_uid != PL_euid)
1176 DIE(aTHX_ "No setreuid available");
1177 (void)PerlProc_setuid(PL_uid);
1179 # endif /* HAS_SETREUID */
1180 #endif /* HAS_SETRESUID */
1181 PL_uid = PerlProc_getuid();
1182 PL_euid = PerlProc_geteuid();
1184 if (PL_delaymagic & DM_GID) {
1185 #ifdef HAS_SETRESGID
1186 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1187 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1190 # ifdef HAS_SETREGID
1191 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1192 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1195 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1196 (void)setrgid(PL_gid);
1197 PL_delaymagic &= ~DM_RGID;
1199 # endif /* HAS_SETRGID */
1201 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1202 (void)setegid(PL_egid);
1203 PL_delaymagic &= ~DM_EGID;
1205 # endif /* HAS_SETEGID */
1206 if (PL_delaymagic & DM_GID) {
1207 if (PL_gid != PL_egid)
1208 DIE(aTHX_ "No setregid available");
1209 (void)PerlProc_setgid(PL_gid);
1211 # endif /* HAS_SETREGID */
1212 #endif /* HAS_SETRESGID */
1213 PL_gid = PerlProc_getgid();
1214 PL_egid = PerlProc_getegid();
1216 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1220 if (gimme == G_VOID)
1221 SP = firstrelem - 1;
1222 else if (gimme == G_SCALAR) {
1225 SETi(lastrelem - firstrelem + 1 - duplicates);
1232 /* Removes from the stack the entries which ended up as
1233 * duplicated keys in the hash (fix for [perl #24380]) */
1234 Move(firsthashrelem + duplicates,
1235 firsthashrelem, duplicates, SV**);
1236 lastrelem -= duplicates;
1241 SP = firstrelem + (lastlelem - firstlelem);
1242 lelem = firstlelem + (relem - firstrelem);
1244 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1252 register PMOP * const pm = cPMOP;
1253 SV * const rv = sv_newmortal();
1254 SV * const sv = newSVrv(rv, "Regexp");
1255 if (pm->op_pmdynflags & PMdf_TAINTED)
1257 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1264 register PMOP *pm = cPMOP;
1266 register const char *t;
1267 register const char *s;
1270 I32 r_flags = REXEC_CHECKED;
1271 const char *truebase; /* Start of string */
1272 register REGEXP *rx = PM_GETRE(pm);
1274 const I32 gimme = GIMME;
1277 const I32 oldsave = PL_savestack_ix;
1278 I32 update_minmatch = 1;
1279 I32 had_zerolen = 0;
1281 if (PL_op->op_flags & OPf_STACKED)
1283 else if (PL_op->op_private & OPpTARGET_MY)
1290 PUTBACK; /* EVAL blocks need stack_sp. */
1291 s = SvPV_const(TARG, len);
1293 DIE(aTHX_ "panic: pp_match");
1295 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1296 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1299 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1301 /* PMdf_USED is set after a ?? matches once */
1302 if (pm->op_pmdynflags & PMdf_USED) {
1304 if (gimme == G_ARRAY)
1309 /* empty pattern special-cased to use last successful pattern if possible */
1310 if (!rx->prelen && PL_curpm) {
1315 if (rx->minlen > (I32)len)
1320 /* XXXX What part of this is needed with true \G-support? */
1321 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1323 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1324 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1325 if (mg && mg->mg_len >= 0) {
1326 if (!(rx->reganch & ROPT_GPOS_SEEN))
1327 rx->endp[0] = rx->startp[0] = mg->mg_len;
1328 else if (rx->reganch & ROPT_ANCH_GPOS) {
1329 r_flags |= REXEC_IGNOREPOS;
1330 rx->endp[0] = rx->startp[0] = mg->mg_len;
1332 minmatch = (mg->mg_flags & MGf_MINMATCH);
1333 update_minmatch = 0;
1337 if ((!global && rx->nparens)
1338 || SvTEMP(TARG) || PL_sawampersand)
1339 r_flags |= REXEC_COPY_STR;
1341 r_flags |= REXEC_SCREAM;
1344 if (global && rx->startp[0] != -1) {
1345 t = s = rx->endp[0] + truebase;
1346 if ((s + rx->minlen) > strend)
1348 if (update_minmatch++)
1349 minmatch = had_zerolen;
1351 if (rx->reganch & RE_USE_INTUIT &&
1352 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1353 /* FIXME - can PL_bostr be made const char *? */
1354 PL_bostr = (char *)truebase;
1355 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1359 if ( (rx->reganch & ROPT_CHECK_ALL)
1361 && ((rx->reganch & ROPT_NOSCAN)
1362 || !((rx->reganch & RE_INTUIT_TAIL)
1363 && (r_flags & REXEC_SCREAM)))
1364 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1367 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1370 if (dynpm->op_pmflags & PMf_ONCE)
1371 dynpm->op_pmdynflags |= PMdf_USED;
1380 RX_MATCH_TAINTED_on(rx);
1381 TAINT_IF(RX_MATCH_TAINTED(rx));
1382 if (gimme == G_ARRAY) {
1383 const I32 nparens = rx->nparens;
1384 I32 i = (global && !nparens) ? 1 : 0;
1386 SPAGAIN; /* EVAL blocks could move the stack. */
1387 EXTEND(SP, nparens + i);
1388 EXTEND_MORTAL(nparens + i);
1389 for (i = !i; i <= nparens; i++) {
1390 PUSHs(sv_newmortal());
1391 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1392 const I32 len = rx->endp[i] - rx->startp[i];
1393 s = rx->startp[i] + truebase;
1394 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1395 len < 0 || len > strend - s)
1396 DIE(aTHX_ "panic: pp_match start/end pointers");
1397 sv_setpvn(*SP, s, len);
1398 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1403 if (dynpm->op_pmflags & PMf_CONTINUE) {
1405 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1406 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408 sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
1409 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1411 if (rx->startp[0] != -1) {
1412 mg->mg_len = rx->endp[0];
1413 if (rx->startp[0] == rx->endp[0])
1414 mg->mg_flags |= MGf_MINMATCH;
1416 mg->mg_flags &= ~MGf_MINMATCH;
1419 had_zerolen = (rx->startp[0] != -1
1420 && rx->startp[0] == rx->endp[0]);
1421 PUTBACK; /* EVAL blocks may use stack */
1422 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1427 LEAVE_SCOPE(oldsave);
1433 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1434 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1438 sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
1439 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441 if (rx->startp[0] != -1) {
1442 mg->mg_len = rx->endp[0];
1443 if (rx->startp[0] == rx->endp[0])
1444 mg->mg_flags |= MGf_MINMATCH;
1446 mg->mg_flags &= ~MGf_MINMATCH;
1449 LEAVE_SCOPE(oldsave);
1453 yup: /* Confirmed by INTUIT */
1455 RX_MATCH_TAINTED_on(rx);
1456 TAINT_IF(RX_MATCH_TAINTED(rx));
1458 if (dynpm->op_pmflags & PMf_ONCE)
1459 dynpm->op_pmdynflags |= PMdf_USED;
1460 if (RX_MATCH_COPIED(rx))
1461 Safefree(rx->subbeg);
1462 RX_MATCH_COPIED_off(rx);
1465 /* FIXME - should rx->subbeg be const char *? */
1466 rx->subbeg = (char *) truebase;
1467 rx->startp[0] = s - truebase;
1468 if (RX_MATCH_UTF8(rx)) {
1469 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1470 rx->endp[0] = t - truebase;
1473 rx->endp[0] = s - truebase + rx->minlen;
1475 rx->sublen = strend - truebase;
1478 if (PL_sawampersand) {
1480 #ifdef PERL_OLD_COPY_ON_WRITE
1481 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1483 PerlIO_printf(Perl_debug_log,
1484 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1485 (int) SvTYPE(TARG), truebase, t,
1488 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1489 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1490 assert (SvPOKp(rx->saved_copy));
1495 rx->subbeg = savepvn(t, strend - t);
1496 #ifdef PERL_OLD_COPY_ON_WRITE
1497 rx->saved_copy = Nullsv;
1500 rx->sublen = strend - t;
1501 RX_MATCH_COPIED_on(rx);
1502 off = rx->startp[0] = s - t;
1503 rx->endp[0] = off + rx->minlen;
1505 else { /* startp/endp are used by @- @+. */
1506 rx->startp[0] = s - truebase;
1507 rx->endp[0] = s - truebase + rx->minlen;
1509 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1510 LEAVE_SCOPE(oldsave);
1515 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1516 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1517 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1522 LEAVE_SCOPE(oldsave);
1523 if (gimme == G_ARRAY)
1529 Perl_do_readline(pTHX)
1531 dVAR; dSP; dTARGETSTACKED;
1536 register IO * const io = GvIO(PL_last_in_gv);
1537 register const I32 type = PL_op->op_type;
1538 const I32 gimme = GIMME_V;
1541 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1544 XPUSHs(SvTIED_obj((SV*)io, mg));
1547 call_method("READLINE", gimme);
1550 if (gimme == G_SCALAR) {
1551 SV* const result = POPs;
1552 SvSetSV_nosteal(TARG, result);
1562 if (IoFLAGS(io) & IOf_ARGV) {
1563 if (IoFLAGS(io) & IOf_START) {
1565 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1566 IoFLAGS(io) &= ~IOf_START;
1567 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1568 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1569 SvSETMAGIC(GvSV(PL_last_in_gv));
1574 fp = nextargv(PL_last_in_gv);
1575 if (!fp) { /* Note: fp != IoIFP(io) */
1576 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1579 else if (type == OP_GLOB)
1580 fp = Perl_start_glob(aTHX_ POPs, io);
1582 else if (type == OP_GLOB)
1584 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1585 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1589 if ((!io || !(IoFLAGS(io) & IOf_START))
1590 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1592 if (type == OP_GLOB)
1593 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1594 "glob failed (can't start child: %s)",
1597 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1599 if (gimme == G_SCALAR) {
1600 /* undef TARG, and push that undefined value */
1601 if (type != OP_RCATLINE) {
1602 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1610 if (gimme == G_SCALAR) {
1614 SvUPGRADE(sv, SVt_PV);
1615 tmplen = SvLEN(sv); /* remember if already alloced */
1616 if (!tmplen && !SvREADONLY(sv))
1617 Sv_Grow(sv, 80); /* try short-buffering it */
1619 if (type == OP_RCATLINE && SvOK(sv)) {
1621 SvPV_force_nolen(sv);
1627 sv = sv_2mortal(newSV(80));
1631 /* This should not be marked tainted if the fp is marked clean */
1632 #define MAYBE_TAINT_LINE(io, sv) \
1633 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1638 /* delay EOF state for a snarfed empty file */
1639 #define SNARF_EOF(gimme,rs,io,sv) \
1640 (gimme != G_SCALAR || SvCUR(sv) \
1641 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1645 if (!sv_gets(sv, fp, offset)
1647 || SNARF_EOF(gimme, PL_rs, io, sv)
1648 || PerlIO_error(fp)))
1650 PerlIO_clearerr(fp);
1651 if (IoFLAGS(io) & IOf_ARGV) {
1652 fp = nextargv(PL_last_in_gv);
1655 (void)do_close(PL_last_in_gv, FALSE);
1657 else if (type == OP_GLOB) {
1658 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1659 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1660 "glob failed (child exited with status %d%s)",
1661 (int)(STATUS_CURRENT >> 8),
1662 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1665 if (gimme == G_SCALAR) {
1666 if (type != OP_RCATLINE) {
1667 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1673 MAYBE_TAINT_LINE(io, sv);
1676 MAYBE_TAINT_LINE(io, sv);
1678 IoFLAGS(io) |= IOf_NOLINE;
1682 if (type == OP_GLOB) {
1685 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1686 char * const tmps = SvEND(sv) - 1;
1687 if (*tmps == *SvPVX_const(PL_rs)) {
1689 SvCUR_set(sv, SvCUR(sv) - 1);
1692 for (t1 = SvPVX_const(sv); *t1; t1++)
1693 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1694 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1696 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1697 (void)POPs; /* Unmatched wildcard? Chuck it... */
1700 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1701 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1702 const STRLEN len = SvCUR(sv) - offset;
1705 if (ckWARN(WARN_UTF8) &&
1706 !is_utf8_string_loc(s, len, &f))
1707 /* Emulate :encoding(utf8) warning in the same case. */
1708 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1709 "utf8 \"\\x%02X\" does not map to Unicode",
1710 f < (U8*)SvEND(sv) ? *f : 0);
1712 if (gimme == G_ARRAY) {
1713 if (SvLEN(sv) - SvCUR(sv) > 20) {
1714 SvPV_shrink_to_cur(sv);
1716 sv = sv_2mortal(newSV(80));
1719 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1720 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1721 const STRLEN new_len
1722 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1723 SvPV_renew(sv, new_len);
1732 register PERL_CONTEXT *cx;
1733 I32 gimme = OP_GIMME(PL_op, -1);
1736 if (cxstack_ix >= 0)
1737 gimme = cxstack[cxstack_ix].blk_gimme;
1745 PUSHBLOCK(cx, CXt_BLOCK, SP);
1755 SV * const keysv = POPs;
1756 HV * const hv = (HV*)POPs;
1757 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1758 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1760 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1763 if (SvTYPE(hv) == SVt_PVHV) {
1764 if (PL_op->op_private & OPpLVAL_INTRO) {
1767 /* does the element we're localizing already exist? */
1769 /* can we determine whether it exists? */
1771 || mg_find((SV*)hv, PERL_MAGIC_env)
1772 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1773 /* Try to preserve the existenceness of a tied hash
1774 * element by using EXISTS and DELETE if possible.
1775 * Fallback to FETCH and STORE otherwise */
1776 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1777 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1778 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1780 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1783 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1784 svp = he ? &HeVAL(he) : NULL;
1790 if (!svp || *svp == &PL_sv_undef) {
1794 DIE(aTHX_ PL_no_helem_sv, keysv);
1796 lv = sv_newmortal();
1797 sv_upgrade(lv, SVt_PVLV);
1799 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1800 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1801 LvTARG(lv) = SvREFCNT_inc(hv);
1806 if (PL_op->op_private & OPpLVAL_INTRO) {
1807 if (HvNAME_get(hv) && isGV(*svp))
1808 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1812 const char * const key = SvPV_const(keysv, keylen);
1813 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1815 save_helem(hv, keysv, svp);
1818 else if (PL_op->op_private & OPpDEREF)
1819 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1821 sv = (svp ? *svp : &PL_sv_undef);
1822 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1823 * Pushing the magical RHS on to the stack is useless, since
1824 * that magic is soon destined to be misled by the local(),
1825 * and thus the later pp_sassign() will fail to mg_get() the
1826 * old value. This should also cure problems with delayed
1827 * mg_get()s. GSAR 98-07-03 */
1828 if (!lval && SvGMAGICAL(sv))
1829 sv = sv_mortalcopy(sv);
1837 register PERL_CONTEXT *cx;
1842 if (PL_op->op_flags & OPf_SPECIAL) {
1843 cx = &cxstack[cxstack_ix];
1844 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1849 gimme = OP_GIMME(PL_op, -1);
1851 if (cxstack_ix >= 0)
1852 gimme = cxstack[cxstack_ix].blk_gimme;
1858 if (gimme == G_VOID)
1860 else if (gimme == G_SCALAR) {
1864 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1867 *MARK = sv_mortalcopy(TOPs);
1870 *MARK = &PL_sv_undef;
1874 else if (gimme == G_ARRAY) {
1875 /* in case LEAVE wipes old return values */
1877 for (mark = newsp + 1; mark <= SP; mark++) {
1878 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1879 *mark = sv_mortalcopy(*mark);
1880 TAINT_NOT; /* Each item is independent */
1884 PL_curpm = newpm; /* Don't pop $1 et al till now */
1894 register PERL_CONTEXT *cx;
1900 cx = &cxstack[cxstack_ix];
1901 if (CxTYPE(cx) != CXt_LOOP)
1902 DIE(aTHX_ "panic: pp_iter");
1904 itersvp = CxITERVAR(cx);
1905 av = cx->blk_loop.iterary;
1906 if (SvTYPE(av) != SVt_PVAV) {
1907 /* iterate ($min .. $max) */
1908 if (cx->blk_loop.iterlval) {
1909 /* string increment */
1910 register SV* cur = cx->blk_loop.iterlval;
1912 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1913 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1914 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1915 /* safe to reuse old SV */
1916 sv_setsv(*itersvp, cur);
1920 /* we need a fresh SV every time so that loop body sees a
1921 * completely new SV for closures/references to work as
1924 *itersvp = newSVsv(cur);
1925 SvREFCNT_dec(oldsv);
1927 if (strEQ(SvPVX_const(cur), max))
1928 sv_setiv(cur, 0); /* terminate next time */
1935 /* integer increment */
1936 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1939 /* don't risk potential race */
1940 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1941 /* safe to reuse old SV */
1942 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1946 /* we need a fresh SV every time so that loop body sees a
1947 * completely new SV for closures/references to work as they
1950 *itersvp = newSViv(cx->blk_loop.iterix++);
1951 SvREFCNT_dec(oldsv);
1957 if (PL_op->op_private & OPpITER_REVERSED) {
1958 /* In reverse, use itermax as the min :-) */
1959 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1962 if (SvMAGICAL(av) || AvREIFY(av)) {
1963 SV * const * 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 (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1975 if (SvMAGICAL(av) || AvREIFY(av)) {
1976 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1977 sv = svp ? *svp : Nullsv;
1980 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1984 if (sv && SvIS_FREED(sv)) {
1986 Perl_croak(aTHX_ "Use of freed value in iteration");
1993 if (av != PL_curstack && sv == &PL_sv_undef) {
1994 SV *lv = cx->blk_loop.iterlval;
1995 if (lv && SvREFCNT(lv) > 1) {
2000 SvREFCNT_dec(LvTARG(lv));
2002 lv = cx->blk_loop.iterlval = newSV(0);
2003 sv_upgrade(lv, SVt_PVLV);
2005 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2007 LvTARG(lv) = SvREFCNT_inc(av);
2008 LvTARGOFF(lv) = cx->blk_loop.iterix;
2009 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2014 *itersvp = SvREFCNT_inc(sv);
2015 SvREFCNT_dec(oldsv);
2023 register PMOP *pm = cPMOP;
2039 register REGEXP *rx = PM_GETRE(pm);
2041 int force_on_match = 0;
2042 const I32 oldsave = PL_savestack_ix;
2044 bool doutf8 = FALSE;
2045 #ifdef PERL_OLD_COPY_ON_WRITE
2050 /* known replacement string? */
2051 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
2052 if (PL_op->op_flags & OPf_STACKED)
2054 else if (PL_op->op_private & OPpTARGET_MY)
2061 #ifdef PERL_OLD_COPY_ON_WRITE
2062 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2063 because they make integers such as 256 "false". */
2064 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2067 sv_force_normal_flags(TARG,0);
2070 #ifdef PERL_OLD_COPY_ON_WRITE
2074 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2075 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2076 DIE(aTHX_ PL_no_modify);
2079 s = SvPV_mutable(TARG, len);
2080 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2082 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2083 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2088 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2092 DIE(aTHX_ "panic: pp_subst");
2095 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2096 maxiters = 2 * slen + 10; /* We can match twice at each
2097 position, once with zero-length,
2098 second time with non-zero. */
2100 if (!rx->prelen && PL_curpm) {
2104 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2105 ? REXEC_COPY_STR : 0;
2107 r_flags |= REXEC_SCREAM;
2110 if (rx->reganch & RE_USE_INTUIT) {
2112 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2116 /* How to do it in subst? */
2117 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2119 && ((rx->reganch & ROPT_NOSCAN)
2120 || !((rx->reganch & RE_INTUIT_TAIL)
2121 && (r_flags & REXEC_SCREAM))))
2126 /* only replace once? */
2127 once = !(rpm->op_pmflags & PMf_GLOBAL);
2129 /* known replacement string? */
2131 /* replacement needing upgrading? */
2132 if (DO_UTF8(TARG) && !doutf8) {
2133 nsv = sv_newmortal();
2136 sv_recode_to_utf8(nsv, PL_encoding);
2138 sv_utf8_upgrade(nsv);
2139 c = SvPV_const(nsv, clen);
2143 c = SvPV_const(dstr, clen);
2144 doutf8 = DO_UTF8(dstr);
2152 /* can do inplace substitution? */
2154 #ifdef PERL_OLD_COPY_ON_WRITE
2157 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2158 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2159 && (!doutf8 || SvUTF8(TARG))) {
2160 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2161 r_flags | REXEC_CHECKED))
2165 LEAVE_SCOPE(oldsave);
2168 #ifdef PERL_OLD_COPY_ON_WRITE
2169 if (SvIsCOW(TARG)) {
2170 assert (!force_on_match);
2174 if (force_on_match) {
2176 s = SvPV_force(TARG, len);
2181 SvSCREAM_off(TARG); /* disable possible screamer */
2183 rxtainted |= RX_MATCH_TAINTED(rx);
2184 m = orig + rx->startp[0];
2185 d = orig + rx->endp[0];
2187 if (m - s > strend - d) { /* faster to shorten from end */
2189 Copy(c, m, clen, char);
2194 Move(d, m, i, char);
2198 SvCUR_set(TARG, m - s);
2200 else if ((i = m - s)) { /* faster from front */
2208 Copy(c, m, clen, char);
2213 Copy(c, d, clen, char);
2218 TAINT_IF(rxtainted & 1);
2224 if (iters++ > maxiters)
2225 DIE(aTHX_ "Substitution loop");
2226 rxtainted |= RX_MATCH_TAINTED(rx);
2227 m = rx->startp[0] + orig;
2230 Move(s, d, i, char);
2234 Copy(c, d, clen, char);
2237 s = rx->endp[0] + orig;
2238 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2240 /* don't match same null twice */
2241 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2244 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2245 Move(s, d, i+1, char); /* include the NUL */
2247 TAINT_IF(rxtainted & 1);
2249 PUSHs(sv_2mortal(newSViv((I32)iters)));
2251 (void)SvPOK_only_UTF8(TARG);
2252 TAINT_IF(rxtainted);
2253 if (SvSMAGICAL(TARG)) {
2261 LEAVE_SCOPE(oldsave);
2265 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2266 r_flags | REXEC_CHECKED))
2268 if (force_on_match) {
2270 s = SvPV_force(TARG, len);
2273 #ifdef PERL_OLD_COPY_ON_WRITE
2276 rxtainted |= RX_MATCH_TAINTED(rx);
2277 dstr = newSVpvn(m, s-m);
2282 register PERL_CONTEXT *cx;
2284 (void)ReREFCNT_inc(rx);
2286 RETURNOP(cPMOP->op_pmreplroot);
2288 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2290 if (iters++ > maxiters)
2291 DIE(aTHX_ "Substitution loop");
2292 rxtainted |= RX_MATCH_TAINTED(rx);
2293 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2298 strend = s + (strend - m);
2300 m = rx->startp[0] + orig;
2301 if (doutf8 && !SvUTF8(dstr))
2302 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2304 sv_catpvn(dstr, s, m-s);
2305 s = rx->endp[0] + orig;
2307 sv_catpvn(dstr, c, clen);
2310 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2311 TARG, NULL, r_flags));
2312 if (doutf8 && !DO_UTF8(TARG))
2313 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2315 sv_catpvn(dstr, s, strend - s);
2317 #ifdef PERL_OLD_COPY_ON_WRITE
2318 /* The match may make the string COW. If so, brilliant, because that's
2319 just saved us one malloc, copy and free - the regexp has donated
2320 the old buffer, and we malloc an entirely new one, rather than the
2321 regexp malloc()ing a buffer and copying our original, only for
2322 us to throw it away here during the substitution. */
2323 if (SvIsCOW(TARG)) {
2324 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2330 SvPV_set(TARG, SvPVX(dstr));
2331 SvCUR_set(TARG, SvCUR(dstr));
2332 SvLEN_set(TARG, SvLEN(dstr));
2333 doutf8 |= DO_UTF8(dstr);
2334 SvPV_set(dstr, NULL);
2337 TAINT_IF(rxtainted & 1);
2339 PUSHs(sv_2mortal(newSViv((I32)iters)));
2341 (void)SvPOK_only(TARG);
2344 TAINT_IF(rxtainted);
2347 LEAVE_SCOPE(oldsave);
2356 LEAVE_SCOPE(oldsave);
2365 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2366 ++*PL_markstack_ptr;
2367 LEAVE; /* exit inner scope */
2370 if (PL_stack_base + *PL_markstack_ptr > SP) {
2372 const I32 gimme = GIMME_V;
2374 LEAVE; /* exit outer scope */
2375 (void)POPMARK; /* pop src */
2376 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2377 (void)POPMARK; /* pop dst */
2378 SP = PL_stack_base + POPMARK; /* pop original mark */
2379 if (gimme == G_SCALAR) {
2380 if (PL_op->op_private & OPpGREP_LEX) {
2381 SV* const sv = sv_newmortal();
2382 sv_setiv(sv, items);
2390 else if (gimme == G_ARRAY)
2397 ENTER; /* enter inner scope */
2400 src = PL_stack_base[*PL_markstack_ptr];
2402 if (PL_op->op_private & OPpGREP_LEX)
2403 PAD_SVl(PL_op->op_targ) = src;
2407 RETURNOP(cLOGOP->op_other);
2418 register PERL_CONTEXT *cx;
2421 if (CxMULTICALL(&cxstack[cxstack_ix]))
2425 cxstack_ix++; /* temporarily protect top context */
2428 if (gimme == G_SCALAR) {
2431 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2433 *MARK = SvREFCNT_inc(TOPs);
2438 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2440 *MARK = sv_mortalcopy(sv);
2445 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2449 *MARK = &PL_sv_undef;
2453 else if (gimme == G_ARRAY) {
2454 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2455 if (!SvTEMP(*MARK)) {
2456 *MARK = sv_mortalcopy(*MARK);
2457 TAINT_NOT; /* Each item is independent */
2465 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2466 PL_curpm = newpm; /* ... and pop $1 et al */
2469 return cx->blk_sub.retop;
2472 /* This duplicates the above code because the above code must not
2473 * get any slower by more conditions */
2481 register PERL_CONTEXT *cx;
2484 if (CxMULTICALL(&cxstack[cxstack_ix]))
2488 cxstack_ix++; /* temporarily protect top context */
2492 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2493 /* We are an argument to a function or grep().
2494 * This kind of lvalueness was legal before lvalue
2495 * subroutines too, so be backward compatible:
2496 * cannot report errors. */
2498 /* Scalar context *is* possible, on the LHS of -> only,
2499 * as in f()->meth(). But this is not an lvalue. */
2500 if (gimme == G_SCALAR)
2502 if (gimme == G_ARRAY) {
2503 if (!CvLVALUE(cx->blk_sub.cv))
2504 goto temporise_array;
2505 EXTEND_MORTAL(SP - newsp);
2506 for (mark = newsp + 1; mark <= SP; mark++) {
2509 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2510 *mark = sv_mortalcopy(*mark);
2512 /* Can be a localized value subject to deletion. */
2513 PL_tmps_stack[++PL_tmps_ix] = *mark;
2514 (void)SvREFCNT_inc(*mark);
2519 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2520 /* Here we go for robustness, not for speed, so we change all
2521 * the refcounts so the caller gets a live guy. Cannot set
2522 * TEMP, so sv_2mortal is out of question. */
2523 if (!CvLVALUE(cx->blk_sub.cv)) {
2529 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2531 if (gimme == G_SCALAR) {
2535 /* Temporaries are bad unless they happen to be elements
2536 * of a tied hash or array */
2537 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2538 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2544 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2545 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2546 : "a readonly value" : "a temporary");
2548 else { /* Can be a localized value
2549 * subject to deletion. */
2550 PL_tmps_stack[++PL_tmps_ix] = *mark;
2551 (void)SvREFCNT_inc(*mark);
2554 else { /* Should not happen? */
2560 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2561 (MARK > SP ? "Empty array" : "Array"));
2565 else if (gimme == G_ARRAY) {
2566 EXTEND_MORTAL(SP - newsp);
2567 for (mark = newsp + 1; mark <= SP; mark++) {
2568 if (*mark != &PL_sv_undef
2569 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2570 /* Might be flattened array after $#array = */
2577 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2578 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2581 /* Can be a localized value subject to deletion. */
2582 PL_tmps_stack[++PL_tmps_ix] = *mark;
2583 (void)SvREFCNT_inc(*mark);
2589 if (gimme == G_SCALAR) {
2593 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2595 *MARK = SvREFCNT_inc(TOPs);
2600 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2602 *MARK = sv_mortalcopy(sv);
2607 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2611 *MARK = &PL_sv_undef;
2615 else if (gimme == G_ARRAY) {
2617 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2618 if (!SvTEMP(*MARK)) {
2619 *MARK = sv_mortalcopy(*MARK);
2620 TAINT_NOT; /* Each item is independent */
2629 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2630 PL_curpm = newpm; /* ... and pop $1 et al */
2633 return cx->blk_sub.retop;
2638 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2641 SV * const dbsv = GvSVn(PL_DBsub);
2644 if (!PERLDB_SUB_NN) {
2647 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2648 || strEQ(GvNAME(gv), "END")
2649 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2650 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2651 && (gv = (GV*)*svp) ))) {
2652 /* Use GV from the stack as a fallback. */
2653 /* GV is potentially non-unique, or contain different CV. */
2654 SV * const tmp = newRV((SV*)cv);
2655 sv_setsv(dbsv, tmp);
2659 gv_efullname3(dbsv, gv, NULL);
2663 const int type = SvTYPE(dbsv);
2664 if (type < SVt_PVIV && type != SVt_IV)
2665 sv_upgrade(dbsv, SVt_PVIV);
2666 (void)SvIOK_on(dbsv);
2667 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2671 PL_curcopdb = PL_curcop;
2672 cv = GvCV(PL_DBsub);
2681 register PERL_CONTEXT *cx;
2683 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2686 DIE(aTHX_ "Not a CODE reference");
2687 switch (SvTYPE(sv)) {
2688 /* This is overwhelming the most common case: */
2690 if (!(cv = GvCVu((GV*)sv))) {
2692 cv = sv_2cv(sv, &stash, &gv, 0);
2703 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2705 SP = PL_stack_base + POPMARK;
2708 if (SvGMAGICAL(sv)) {
2712 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2715 sym = SvPV_nolen_const(sv);
2718 DIE(aTHX_ PL_no_usym, "a subroutine");
2719 if (PL_op->op_private & HINT_STRICT_REFS)
2720 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2721 cv = get_cv(sym, TRUE);
2726 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2727 tryAMAGICunDEREF(to_cv);
2730 if (SvTYPE(cv) == SVt_PVCV)
2735 DIE(aTHX_ "Not a CODE reference");
2736 /* This is the second most common case: */
2746 if (!CvROOT(cv) && !CvXSUB(cv)) {
2750 /* anonymous or undef'd function leaves us no recourse */
2751 if (CvANON(cv) || !(gv = CvGV(cv)))
2752 DIE(aTHX_ "Undefined subroutine called");
2754 /* autoloaded stub? */
2755 if (cv != GvCV(gv)) {
2758 /* should call AUTOLOAD now? */
2761 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2768 sub_name = sv_newmortal();
2769 gv_efullname3(sub_name, gv, NULL);
2770 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2774 DIE(aTHX_ "Not a CODE reference");
2779 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2780 if (CvASSERTION(cv) && PL_DBassertion)
2781 sv_setiv(PL_DBassertion, 1);
2783 cv = get_db_sub(&sv, cv);
2784 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2785 DIE(aTHX_ "No DB::sub routine defined");
2788 if (!(CvXSUB(cv))) {
2789 /* This path taken at least 75% of the time */
2791 register I32 items = SP - MARK;
2792 AV* const padlist = CvPADLIST(cv);
2793 PUSHBLOCK(cx, CXt_SUB, MARK);
2795 cx->blk_sub.retop = PL_op->op_next;
2797 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2798 * that eval'' ops within this sub know the correct lexical space.
2799 * Owing the speed considerations, we choose instead to search for
2800 * the cv using find_runcv() when calling doeval().
2802 if (CvDEPTH(cv) >= 2) {
2803 PERL_STACK_OVERFLOW_CHECK();
2804 pad_push(padlist, CvDEPTH(cv));
2807 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2810 AV* const av = (AV*)PAD_SVl(0);
2812 /* @_ is normally not REAL--this should only ever
2813 * happen when DB::sub() calls things that modify @_ */
2818 cx->blk_sub.savearray = GvAV(PL_defgv);
2819 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2820 CX_CURPAD_SAVE(cx->blk_sub);
2821 cx->blk_sub.argarray = av;
2824 if (items > AvMAX(av) + 1) {
2825 SV **ary = AvALLOC(av);
2826 if (AvARRAY(av) != ary) {
2827 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2828 SvPV_set(av, (char*)ary);
2830 if (items > AvMAX(av) + 1) {
2831 AvMAX(av) = items - 1;
2832 Renew(ary,items,SV*);
2834 SvPV_set(av, (char*)ary);
2837 Copy(MARK,AvARRAY(av),items,SV*);
2838 AvFILLp(av) = items - 1;
2846 /* warning must come *after* we fully set up the context
2847 * stuff so that __WARN__ handlers can safely dounwind()
2850 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2851 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2852 sub_crush_depth(cv);
2854 DEBUG_S(PerlIO_printf(Perl_debug_log,
2855 "%p entersub returning %p\n", thr, CvSTART(cv)));
2857 RETURNOP(CvSTART(cv));
2860 #ifdef PERL_XSUB_OLDSTYLE
2861 if (CvOLDSTYLE(cv)) {
2862 I32 (*fp3)(int,int,int);
2864 register I32 items = SP - MARK;
2865 /* We dont worry to copy from @_. */
2870 PL_stack_sp = mark + 1;
2871 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2872 items = (*fp3)(CvXSUBANY(cv).any_i32,
2873 MARK - PL_stack_base + 1,
2875 PL_stack_sp = PL_stack_base + items;
2878 #endif /* PERL_XSUB_OLDSTYLE */
2880 I32 markix = TOPMARK;
2885 /* Need to copy @_ to stack. Alternative may be to
2886 * switch stack to @_, and copy return values
2887 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2888 AV * const av = GvAV(PL_defgv);
2889 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2892 /* Mark is at the end of the stack. */
2894 Copy(AvARRAY(av), SP + 1, items, SV*);
2899 /* We assume first XSUB in &DB::sub is the called one. */
2901 SAVEVPTR(PL_curcop);
2902 PL_curcop = PL_curcopdb;
2905 /* Do we need to open block here? XXXX */
2906 (void)(*CvXSUB(cv))(aTHX_ cv);
2908 /* Enforce some sanity in scalar context. */
2909 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2910 if (markix > PL_stack_sp - PL_stack_base)
2911 *(PL_stack_base + markix) = &PL_sv_undef;
2913 *(PL_stack_base + markix) = *PL_stack_sp;
2914 PL_stack_sp = PL_stack_base + markix;
2923 Perl_sub_crush_depth(pTHX_ CV *cv)
2926 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2928 SV* const tmpstr = sv_newmortal();
2929 gv_efullname3(tmpstr, CvGV(cv), NULL);
2930 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2939 SV* const elemsv = POPs;
2940 IV elem = SvIV(elemsv);
2941 AV* const av = (AV*)POPs;
2942 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2943 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2946 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2947 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2949 elem -= PL_curcop->cop_arybase;
2950 if (SvTYPE(av) != SVt_PVAV)
2952 svp = av_fetch(av, elem, lval && !defer);
2954 #ifdef PERL_MALLOC_WRAP
2955 if (SvUOK(elemsv)) {
2956 const UV uv = SvUV(elemsv);
2957 elem = uv > IV_MAX ? IV_MAX : uv;
2959 else if (SvNOK(elemsv))
2960 elem = (IV)SvNV(elemsv);
2962 static const char oom_array_extend[] =
2963 "Out of memory during array extend"; /* Duplicated in av.c */
2964 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2967 if (!svp || *svp == &PL_sv_undef) {
2970 DIE(aTHX_ PL_no_aelem, elem);
2971 lv = sv_newmortal();
2972 sv_upgrade(lv, SVt_PVLV);
2974 sv_magic(lv, Nullsv, PERL_MAGIC_defelem, NULL, 0);
2975 LvTARG(lv) = SvREFCNT_inc(av);
2976 LvTARGOFF(lv) = elem;
2981 if (PL_op->op_private & OPpLVAL_INTRO)
2982 save_aelem(av, elem, svp);
2983 else if (PL_op->op_private & OPpDEREF)
2984 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2986 sv = (svp ? *svp : &PL_sv_undef);
2987 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2988 sv = sv_mortalcopy(sv);
2994 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2999 Perl_croak(aTHX_ PL_no_modify);
3000 if (SvTYPE(sv) < SVt_RV)
3001 sv_upgrade(sv, SVt_RV);
3002 else if (SvTYPE(sv) >= SVt_PV) {
3009 SvRV_set(sv, newSV(0));
3012 SvRV_set(sv, (SV*)newAV());
3015 SvRV_set(sv, (SV*)newHV());
3026 SV* const sv = TOPs;
3029 SV* const rsv = SvRV(sv);
3030 if (SvTYPE(rsv) == SVt_PVCV) {
3036 SETs(method_common(sv, Null(U32*)));
3043 SV* const sv = cSVOP_sv;
3044 U32 hash = SvSHARED_HASH(sv);
3046 XPUSHs(method_common(sv, &hash));
3051 S_method_common(pTHX_ SV* meth, U32* hashp)
3058 const char* packname = NULL;
3059 SV *packsv = Nullsv;
3061 const char * const name = SvPV_const(meth, namelen);
3062 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3065 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3073 /* this isn't a reference */
3074 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3075 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3077 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3084 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3085 !(ob=(SV*)GvIO(iogv)))
3087 /* this isn't the name of a filehandle either */
3089 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3090 ? !isIDFIRST_utf8((U8*)packname)
3091 : !isIDFIRST(*packname)
3094 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3095 SvOK(sv) ? "without a package or object reference"
3096 : "on an undefined value");
3098 /* assume it's a package name */
3099 stash = gv_stashpvn(packname, packlen, FALSE);
3103 SV* ref = newSViv(PTR2IV(stash));
3104 hv_store(PL_stashcache, packname, packlen, ref, 0);
3108 /* it _is_ a filehandle name -- replace with a reference */
3109 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3112 /* if we got here, ob should be a reference or a glob */
3113 if (!ob || !(SvOBJECT(ob)
3114 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3117 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3121 stash = SvSTASH(ob);
3124 /* NOTE: stash may be null, hope hv_fetch_ent and
3125 gv_fetchmethod can cope (it seems they can) */
3127 /* shortcut for simple names */
3129 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3131 gv = (GV*)HeVAL(he);
3132 if (isGV(gv) && GvCV(gv) &&
3133 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3134 return (SV*)GvCV(gv);
3138 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3141 /* This code tries to figure out just what went wrong with
3142 gv_fetchmethod. It therefore needs to duplicate a lot of
3143 the internals of that function. We can't move it inside
3144 Perl_gv_fetchmethod_autoload(), however, since that would
3145 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3148 const char* leaf = name;
3149 const char* sep = NULL;
3152 for (p = name; *p; p++) {
3154 sep = p, leaf = p + 1;
3155 else if (*p == ':' && *(p + 1) == ':')
3156 sep = p, leaf = p + 2;
3158 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3159 /* the method name is unqualified or starts with SUPER:: */
3160 bool need_strlen = 1;
3162 packname = CopSTASHPV(PL_curcop);
3165 HEK * const packhek = HvNAME_HEK(stash);
3167 packname = HEK_KEY(packhek);
3168 packlen = HEK_LEN(packhek);
3178 "Can't use anonymous symbol table for method lookup");
3180 else if (need_strlen)
3181 packlen = strlen(packname);
3185 /* the method name is qualified */
3187 packlen = sep - name;
3190 /* we're relying on gv_fetchmethod not autovivifying the stash */
3191 if (gv_stashpvn(packname, packlen, FALSE)) {
3193 "Can't locate object method \"%s\" via package \"%.*s\"",
3194 leaf, (int)packlen, packname);
3198 "Can't locate object method \"%s\" via package \"%.*s\""
3199 " (perhaps you forgot to load \"%.*s\"?)",
3200 leaf, (int)packlen, packname, (int)packlen, packname);
3203 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3208 * c-indentation-style: bsd
3210 * indent-tabs-mode: t
3213 * ex: set ts=8 sts=4 sw=4 noet: