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 else if (PL_op->op_private & OPpASSIGN_STATE) {
124 if (SvPADSTALE(right))
125 SvPADSTALE_off(right);
127 RETURN; /* ignore assignment */
129 if (PL_tainting && PL_tainted && !SvTAINTED(left))
131 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
132 SV * const cv = SvRV(left);
133 const U32 cv_type = SvTYPE(cv);
134 const U32 gv_type = SvTYPE(right);
135 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
141 /* Can do the optimisation if right (LVAUE) is not a typeglob,
142 left (RVALUE) is a reference to something, and we're in void
144 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
145 /* Is the target symbol table currently empty? */
146 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
147 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
148 /* Good. Create a new proxy constant subroutine in the target.
149 The gv becomes a(nother) reference to the constant. */
150 SV *const value = SvRV(cv);
152 SvUPGRADE((SV *)gv, SVt_RV);
155 SvREFCNT_inc_simple_void(value);
161 /* Need to fix things up. */
162 if (gv_type != SVt_PVGV) {
163 /* Need to fix GV. */
164 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
168 /* We've been returned a constant rather than a full subroutine,
169 but they expect a subroutine reference to apply. */
171 SvREFCNT_inc_void(SvRV(cv));
172 /* newCONSTSUB takes a reference count on the passed in SV
173 from us. We set the name to NULL, otherwise we get into
174 all sorts of fun as the reference to our new sub is
175 donated to the GV that we're about to assign to.
177 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
184 SvSetMagicSV(right, left);
193 RETURNOP(cLOGOP->op_other);
195 RETURNOP(cLOGOP->op_next);
202 TAINT_NOT; /* Each statement is presumed innocent */
203 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
205 oldsave = PL_scopestack[PL_scopestack_ix - 1];
206 LEAVE_SCOPE(oldsave);
212 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
217 const char *rpv = NULL;
219 bool rcopied = FALSE;
221 if (TARG == right && right != left) {
222 /* mg_get(right) may happen here ... */
223 rpv = SvPV_const(right, rlen);
224 rbyte = !DO_UTF8(right);
225 right = sv_2mortal(newSVpvn(rpv, rlen));
226 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
232 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
233 lbyte = !DO_UTF8(left);
234 sv_setpvn(TARG, lpv, llen);
240 else { /* TARG == left */
242 SvGETMAGIC(left); /* or mg_get(left) may happen here */
244 if (left == right && ckWARN(WARN_UNINITIALIZED))
245 report_uninit(right);
246 sv_setpvn(left, "", 0);
248 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
249 lbyte = !DO_UTF8(left);
254 /* or mg_get(right) may happen here */
256 rpv = SvPV_const(right, rlen);
257 rbyte = !DO_UTF8(right);
259 if (lbyte != rbyte) {
261 sv_utf8_upgrade_nomg(TARG);
264 right = sv_2mortal(newSVpvn(rpv, rlen));
265 sv_utf8_upgrade_nomg(right);
266 rpv = SvPV_const(right, rlen);
269 sv_catpvn_nomg(TARG, rpv, rlen);
280 if (PL_op->op_flags & OPf_MOD) {
281 if (PL_op->op_private & OPpLVAL_INTRO)
282 if (!(PL_op->op_private & OPpPAD_STATE))
283 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
284 if (PL_op->op_private & OPpDEREF) {
286 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
296 tryAMAGICunTARGET(iter, 0);
297 PL_last_in_gv = (GV*)(*PL_stack_sp--);
298 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
299 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
300 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
303 XPUSHs((SV*)PL_last_in_gv);
306 PL_last_in_gv = (GV*)(*PL_stack_sp--);
309 return do_readline();
314 dVAR; dSP; tryAMAGICbinSET(eq,0);
315 #ifndef NV_PRESERVES_UV
316 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
318 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
322 #ifdef PERL_PRESERVE_IVUV
325 /* Unless the left argument is integer in range we are going
326 to have to use NV maths. Hence only attempt to coerce the
327 right argument if we know the left is integer. */
330 const bool auvok = SvUOK(TOPm1s);
331 const bool buvok = SvUOK(TOPs);
333 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
334 /* Casting IV to UV before comparison isn't going to matter
335 on 2s complement. On 1s complement or sign&magnitude
336 (if we have any of them) it could to make negative zero
337 differ from normal zero. As I understand it. (Need to
338 check - is negative zero implementation defined behaviour
340 const UV buv = SvUVX(POPs);
341 const UV auv = SvUVX(TOPs);
343 SETs(boolSV(auv == buv));
346 { /* ## Mixed IV,UV ## */
350 /* == is commutative so doesn't matter which is left or right */
352 /* top of stack (b) is the iv */
361 /* As uv is a UV, it's >0, so it cannot be == */
364 /* we know iv is >= 0 */
365 SETs(boolSV((UV)iv == SvUVX(uvp)));
372 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
374 if (Perl_isnan(left) || Perl_isnan(right))
376 SETs(boolSV(left == right));
379 SETs(boolSV(TOPn == value));
388 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
389 DIE(aTHX_ PL_no_modify);
390 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
391 && SvIVX(TOPs) != IV_MAX)
393 SvIV_set(TOPs, SvIVX(TOPs) + 1);
394 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
396 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
408 if (PL_op->op_type == OP_OR)
410 RETURNOP(cLOGOP->op_other);
419 const int op_type = PL_op->op_type;
420 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
424 if (!sv || !SvANY(sv)) {
425 if (op_type == OP_DOR)
427 RETURNOP(cLOGOP->op_other);
429 } else if (op_type == OP_DEFINED) {
431 if (!sv || !SvANY(sv))
434 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
437 switch (SvTYPE(sv)) {
439 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
443 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
447 if (CvROOT(sv) || CvXSUB(sv))
460 if(op_type == OP_DOR)
462 RETURNOP(cLOGOP->op_other);
464 /* assuming OP_DEFINED */
472 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
473 useleft = USE_LEFT(TOPm1s);
474 #ifdef PERL_PRESERVE_IVUV
475 /* We must see if we can perform the addition with integers if possible,
476 as the integer code detects overflow while the NV code doesn't.
477 If either argument hasn't had a numeric conversion yet attempt to get
478 the IV. It's important to do this now, rather than just assuming that
479 it's not IOK as a PV of "9223372036854775806" may not take well to NV
480 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
481 integer in case the second argument is IV=9223372036854775806
482 We can (now) rely on sv_2iv to do the right thing, only setting the
483 public IOK flag if the value in the NV (or PV) slot is truly integer.
485 A side effect is that this also aggressively prefers integer maths over
486 fp maths for integer values.
488 How to detect overflow?
490 C 99 section 6.2.6.1 says
492 The range of nonnegative values of a signed integer type is a subrange
493 of the corresponding unsigned integer type, and the representation of
494 the same value in each type is the same. A computation involving
495 unsigned operands can never overflow, because a result that cannot be
496 represented by the resulting unsigned integer type is reduced modulo
497 the number that is one greater than the largest value that can be
498 represented by the resulting type.
502 which I read as "unsigned ints wrap."
504 signed integer overflow seems to be classed as "exception condition"
506 If an exceptional condition occurs during the evaluation of an
507 expression (that is, if the result is not mathematically defined or not
508 in the range of representable values for its type), the behavior is
511 (6.5, the 5th paragraph)
513 I had assumed that on 2s complement machines signed arithmetic would
514 wrap, hence coded pp_add and pp_subtract on the assumption that
515 everything perl builds on would be happy. After much wailing and
516 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
517 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
518 unsigned code below is actually shorter than the old code. :-)
523 /* Unless the left argument is integer in range we are going to have to
524 use NV maths. Hence only attempt to coerce the right argument if
525 we know the left is integer. */
533 /* left operand is undef, treat as zero. + 0 is identity,
534 Could SETi or SETu right now, but space optimise by not adding
535 lots of code to speed up what is probably a rarish case. */
537 /* Left operand is defined, so is it IV? */
540 if ((auvok = SvUOK(TOPm1s)))
543 register const IV aiv = SvIVX(TOPm1s);
546 auvok = 1; /* Now acting as a sign flag. */
547 } else { /* 2s complement assumption for IV_MIN */
555 bool result_good = 0;
558 bool buvok = SvUOK(TOPs);
563 register const IV biv = SvIVX(TOPs);
570 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
571 else "IV" now, independent of how it came in.
572 if a, b represents positive, A, B negative, a maps to -A etc
577 all UV maths. negate result if A negative.
578 add if signs same, subtract if signs differ. */
584 /* Must get smaller */
590 /* result really should be -(auv-buv). as its negation
591 of true value, need to swap our result flag */
608 if (result <= (UV)IV_MIN)
611 /* result valid, but out of range for IV. */
616 } /* Overflow, drop through to NVs. */
623 /* left operand is undef, treat as zero. + 0.0 is identity. */
627 SETn( value + TOPn );
635 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
636 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
637 const U32 lval = PL_op->op_flags & OPf_MOD;
638 SV** const svp = av_fetch(av, PL_op->op_private, lval);
639 SV *sv = (svp ? *svp : &PL_sv_undef);
641 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
642 sv = sv_mortalcopy(sv);
649 dVAR; dSP; dMARK; dTARGET;
651 do_join(TARG, *MARK, MARK, SP);
662 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
663 * will be enough to hold an OP*.
665 SV* const sv = sv_newmortal();
666 sv_upgrade(sv, SVt_PVLV);
668 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
676 /* Oversized hot code. */
680 dVAR; dSP; dMARK; dORIGMARK;
684 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
686 if (gv && (io = GvIO(gv))
687 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
690 if (MARK == ORIGMARK) {
691 /* If using default handle then we need to make space to
692 * pass object as 1st arg, so move other args up ...
696 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
700 *MARK = SvTIED_obj((SV*)io, mg);
703 call_method("PRINT", G_SCALAR);
711 if (!(io = GvIO(gv))) {
712 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
713 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
715 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
716 report_evil_fh(gv, io, PL_op->op_type);
717 SETERRNO(EBADF,RMS_IFI);
720 else if (!(fp = IoOFP(io))) {
721 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
723 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
724 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
725 report_evil_fh(gv, io, PL_op->op_type);
727 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
732 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
734 if (!do_print(*MARK, fp))
738 if (!do_print(PL_ofs_sv, fp)) { /* $, */
747 if (!do_print(*MARK, fp))
755 if (PL_op->op_type == OP_SAY) {
756 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
759 else if (PL_ors_sv && SvOK(PL_ors_sv))
760 if (!do_print(PL_ors_sv, fp)) /* $\ */
763 if (IoFLAGS(io) & IOf_FLUSH)
764 if (PerlIO_flush(fp) == EOF)
774 XPUSHs(&PL_sv_undef);
785 tryAMAGICunDEREF(to_av);
788 if (SvTYPE(av) != SVt_PVAV)
789 DIE(aTHX_ "Not an ARRAY reference");
790 if (PL_op->op_flags & OPf_REF) {
795 if (GIMME == G_SCALAR)
796 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
800 else if (PL_op->op_flags & OPf_MOD
801 && PL_op->op_private & OPpLVAL_INTRO)
802 Perl_croak(aTHX_ PL_no_localize_ref);
805 if (SvTYPE(sv) == SVt_PVAV) {
807 if (PL_op->op_flags & OPf_REF) {
812 if (GIMME == G_SCALAR)
813 Perl_croak(aTHX_ "Can't return array to lvalue"
822 if (SvTYPE(sv) != SVt_PVGV) {
823 if (SvGMAGICAL(sv)) {
829 if (PL_op->op_flags & OPf_REF ||
830 PL_op->op_private & HINT_STRICT_REFS)
831 DIE(aTHX_ PL_no_usym, "an ARRAY");
832 if (ckWARN(WARN_UNINITIALIZED))
834 if (GIMME == G_ARRAY) {
840 if ((PL_op->op_flags & OPf_SPECIAL) &&
841 !(PL_op->op_flags & OPf_MOD))
843 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
845 && (!is_gv_magical_sv(sv,0)
846 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
852 if (PL_op->op_private & HINT_STRICT_REFS)
853 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
854 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
861 if (PL_op->op_private & OPpLVAL_INTRO)
863 if (PL_op->op_flags & OPf_REF) {
868 if (GIMME == G_SCALAR)
869 Perl_croak(aTHX_ "Can't return array to lvalue"
877 if (GIMME == G_ARRAY) {
878 const I32 maxarg = AvFILL(av) + 1;
879 (void)POPs; /* XXXX May be optimized away? */
881 if (SvRMAGICAL(av)) {
883 for (i=0; i < (U32)maxarg; i++) {
884 SV ** const svp = av_fetch(av, i, FALSE);
885 /* See note in pp_helem, and bug id #27839 */
887 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
892 Copy(AvARRAY(av), SP+1, maxarg, SV*);
896 else if (GIMME_V == G_SCALAR) {
898 const I32 maxarg = AvFILL(av) + 1;
908 const I32 gimme = GIMME_V;
909 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
913 tryAMAGICunDEREF(to_hv);
916 if (SvTYPE(hv) != SVt_PVHV)
917 DIE(aTHX_ "Not a HASH reference");
918 if (PL_op->op_flags & OPf_REF) {
923 if (gimme != G_ARRAY)
924 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
928 else if (PL_op->op_flags & OPf_MOD
929 && PL_op->op_private & OPpLVAL_INTRO)
930 Perl_croak(aTHX_ PL_no_localize_ref);
933 if (SvTYPE(sv) == SVt_PVHV) {
935 if (PL_op->op_flags & OPf_REF) {
940 if (gimme != G_ARRAY)
941 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
949 if (SvTYPE(sv) != SVt_PVGV) {
950 if (SvGMAGICAL(sv)) {
956 if (PL_op->op_flags & OPf_REF ||
957 PL_op->op_private & HINT_STRICT_REFS)
958 DIE(aTHX_ PL_no_usym, "a HASH");
959 if (ckWARN(WARN_UNINITIALIZED))
961 if (gimme == G_ARRAY) {
967 if ((PL_op->op_flags & OPf_SPECIAL) &&
968 !(PL_op->op_flags & OPf_MOD))
970 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
972 && (!is_gv_magical_sv(sv,0)
973 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
979 if (PL_op->op_private & HINT_STRICT_REFS)
980 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
981 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
988 if (PL_op->op_private & OPpLVAL_INTRO)
990 if (PL_op->op_flags & OPf_REF) {
995 if (gimme != G_ARRAY)
996 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
1003 if (gimme == G_ARRAY) { /* array wanted */
1004 *PL_stack_sp = (SV*)hv;
1007 else if (gimme == G_SCALAR) {
1009 TARG = Perl_hv_scalar(aTHX_ hv);
1016 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1023 if (ckWARN(WARN_MISC)) {
1025 if (relem == firstrelem &&
1027 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1028 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1030 err = "Reference found where even-sized list expected";
1033 err = "Odd number of elements in hash assignment";
1034 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1038 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1039 if (SvMAGICAL(hash)) {
1040 if (SvSMAGICAL(tmpstr))
1052 SV **lastlelem = PL_stack_sp;
1053 SV **lastrelem = PL_stack_base + POPMARK;
1054 SV **firstrelem = PL_stack_base + POPMARK + 1;
1055 SV **firstlelem = lastrelem + 1;
1057 register SV **relem;
1058 register SV **lelem;
1068 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1071 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1074 /* If there's a common identifier on both sides we have to take
1075 * special care that assigning the identifier on the left doesn't
1076 * clobber a value on the right that's used later in the list.
1078 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1079 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1080 for (relem = firstrelem; relem <= lastrelem; relem++) {
1081 if ((sv = *relem)) {
1082 TAINT_NOT; /* Each item is independent */
1083 *relem = sv_mortalcopy(sv);
1087 if (PL_op->op_private & OPpASSIGN_STATE) {
1088 if (SvPADSTALE(*firstlelem))
1089 SvPADSTALE_off(*firstlelem);
1091 RETURN; /* ignore assignment */
1099 while (lelem <= lastlelem) {
1100 TAINT_NOT; /* Each item stands on its own, taintwise. */
1102 switch (SvTYPE(sv)) {
1105 magic = SvMAGICAL(ary) != 0;
1107 av_extend(ary, lastrelem - relem);
1109 while (relem <= lastrelem) { /* gobble up all the rest */
1112 sv = newSVsv(*relem);
1114 didstore = av_store(ary,i++,sv);
1124 case SVt_PVHV: { /* normal hash */
1128 magic = SvMAGICAL(hash) != 0;
1130 firsthashrelem = relem;
1132 while (relem < lastrelem) { /* gobble up all the rest */
1134 sv = *relem ? *relem : &PL_sv_no;
1138 sv_setsv(tmpstr,*relem); /* value */
1139 *(relem++) = tmpstr;
1140 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1141 /* key overwrites an existing entry */
1143 didstore = hv_store_ent(hash,sv,tmpstr,0);
1145 if (SvSMAGICAL(tmpstr))
1152 if (relem == lastrelem) {
1153 do_oddball(hash, relem, firstrelem);
1159 if (SvIMMORTAL(sv)) {
1160 if (relem <= lastrelem)
1164 if (relem <= lastrelem) {
1165 sv_setsv(sv, *relem);
1169 sv_setsv(sv, &PL_sv_undef);
1174 if (PL_delaymagic & ~DM_DELAY) {
1175 if (PL_delaymagic & DM_UID) {
1176 #ifdef HAS_SETRESUID
1177 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1178 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1181 # ifdef HAS_SETREUID
1182 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1183 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1186 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1187 (void)setruid(PL_uid);
1188 PL_delaymagic &= ~DM_RUID;
1190 # endif /* HAS_SETRUID */
1192 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1193 (void)seteuid(PL_euid);
1194 PL_delaymagic &= ~DM_EUID;
1196 # endif /* HAS_SETEUID */
1197 if (PL_delaymagic & DM_UID) {
1198 if (PL_uid != PL_euid)
1199 DIE(aTHX_ "No setreuid available");
1200 (void)PerlProc_setuid(PL_uid);
1202 # endif /* HAS_SETREUID */
1203 #endif /* HAS_SETRESUID */
1204 PL_uid = PerlProc_getuid();
1205 PL_euid = PerlProc_geteuid();
1207 if (PL_delaymagic & DM_GID) {
1208 #ifdef HAS_SETRESGID
1209 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1210 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1213 # ifdef HAS_SETREGID
1214 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1215 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1218 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1219 (void)setrgid(PL_gid);
1220 PL_delaymagic &= ~DM_RGID;
1222 # endif /* HAS_SETRGID */
1224 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1225 (void)setegid(PL_egid);
1226 PL_delaymagic &= ~DM_EGID;
1228 # endif /* HAS_SETEGID */
1229 if (PL_delaymagic & DM_GID) {
1230 if (PL_gid != PL_egid)
1231 DIE(aTHX_ "No setregid available");
1232 (void)PerlProc_setgid(PL_gid);
1234 # endif /* HAS_SETREGID */
1235 #endif /* HAS_SETRESGID */
1236 PL_gid = PerlProc_getgid();
1237 PL_egid = PerlProc_getegid();
1239 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1243 if (gimme == G_VOID)
1244 SP = firstrelem - 1;
1245 else if (gimme == G_SCALAR) {
1248 SETi(lastrelem - firstrelem + 1 - duplicates);
1255 /* Removes from the stack the entries which ended up as
1256 * duplicated keys in the hash (fix for [perl #24380]) */
1257 Move(firsthashrelem + duplicates,
1258 firsthashrelem, duplicates, SV**);
1259 lastrelem -= duplicates;
1264 SP = firstrelem + (lastlelem - firstlelem);
1265 lelem = firstlelem + (relem - firstrelem);
1267 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1275 register PMOP * const pm = cPMOP;
1276 SV * const rv = sv_newmortal();
1277 SV * const sv = newSVrv(rv, "Regexp");
1278 if (pm->op_pmdynflags & PMdf_TAINTED)
1280 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1287 register PMOP *pm = cPMOP;
1289 register const char *t;
1290 register const char *s;
1293 I32 r_flags = REXEC_CHECKED;
1294 const char *truebase; /* Start of string */
1295 register REGEXP *rx = PM_GETRE(pm);
1297 const I32 gimme = GIMME;
1300 const I32 oldsave = PL_savestack_ix;
1301 I32 update_minmatch = 1;
1302 I32 had_zerolen = 0;
1304 if (PL_op->op_flags & OPf_STACKED)
1306 else if (PL_op->op_private & OPpTARGET_MY)
1313 PUTBACK; /* EVAL blocks need stack_sp. */
1314 s = SvPV_const(TARG, len);
1316 DIE(aTHX_ "panic: pp_match");
1318 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1319 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1322 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1324 /* PMdf_USED is set after a ?? matches once */
1325 if (pm->op_pmdynflags & PMdf_USED) {
1327 if (gimme == G_ARRAY)
1332 /* empty pattern special-cased to use last successful pattern if possible */
1333 if (!rx->prelen && PL_curpm) {
1338 if (rx->minlen > (I32)len)
1343 /* XXXX What part of this is needed with true \G-support? */
1344 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1346 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1347 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1348 if (mg && mg->mg_len >= 0) {
1349 if (!(rx->reganch & ROPT_GPOS_SEEN))
1350 rx->endp[0] = rx->startp[0] = mg->mg_len;
1351 else if (rx->reganch & ROPT_ANCH_GPOS) {
1352 r_flags |= REXEC_IGNOREPOS;
1353 rx->endp[0] = rx->startp[0] = mg->mg_len;
1355 minmatch = (mg->mg_flags & MGf_MINMATCH);
1356 update_minmatch = 0;
1360 if ((!global && rx->nparens)
1361 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1362 r_flags |= REXEC_COPY_STR;
1364 r_flags |= REXEC_SCREAM;
1367 if (global && rx->startp[0] != -1) {
1368 t = s = rx->endp[0] + truebase;
1369 if ((s + rx->minlen) > strend)
1371 if (update_minmatch++)
1372 minmatch = had_zerolen;
1374 if (rx->reganch & RE_USE_INTUIT &&
1375 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1376 /* FIXME - can PL_bostr be made const char *? */
1377 PL_bostr = (char *)truebase;
1378 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1382 if ( (rx->reganch & ROPT_CHECK_ALL)
1384 && ((rx->reganch & ROPT_NOSCAN)
1385 || !((rx->reganch & RE_INTUIT_TAIL)
1386 && (r_flags & REXEC_SCREAM)))
1387 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1390 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1393 if (dynpm->op_pmflags & PMf_ONCE)
1394 dynpm->op_pmdynflags |= PMdf_USED;
1403 RX_MATCH_TAINTED_on(rx);
1404 TAINT_IF(RX_MATCH_TAINTED(rx));
1405 if (gimme == G_ARRAY) {
1406 const I32 nparens = rx->nparens;
1407 I32 i = (global && !nparens) ? 1 : 0;
1409 SPAGAIN; /* EVAL blocks could move the stack. */
1410 EXTEND(SP, nparens + i);
1411 EXTEND_MORTAL(nparens + i);
1412 for (i = !i; i <= nparens; i++) {
1413 PUSHs(sv_newmortal());
1414 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1415 const I32 len = rx->endp[i] - rx->startp[i];
1416 s = rx->startp[i] + truebase;
1417 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1418 len < 0 || len > strend - s)
1419 DIE(aTHX_ "panic: pp_match start/end pointers");
1420 sv_setpvn(*SP, s, len);
1421 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1426 if (dynpm->op_pmflags & PMf_CONTINUE) {
1428 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1429 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1431 #ifdef PERL_OLD_COPY_ON_WRITE
1433 sv_force_normal_flags(TARG, 0);
1435 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1436 &PL_vtbl_mglob, NULL, 0);
1438 if (rx->startp[0] != -1) {
1439 mg->mg_len = rx->endp[0];
1440 if (rx->startp[0] == rx->endp[0])
1441 mg->mg_flags |= MGf_MINMATCH;
1443 mg->mg_flags &= ~MGf_MINMATCH;
1446 had_zerolen = (rx->startp[0] != -1
1447 && rx->startp[0] == rx->endp[0]);
1448 PUTBACK; /* EVAL blocks may use stack */
1449 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1454 LEAVE_SCOPE(oldsave);
1460 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1461 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1465 #ifdef PERL_OLD_COPY_ON_WRITE
1467 sv_force_normal_flags(TARG, 0);
1469 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1470 &PL_vtbl_mglob, NULL, 0);
1472 if (rx->startp[0] != -1) {
1473 mg->mg_len = rx->endp[0];
1474 if (rx->startp[0] == rx->endp[0])
1475 mg->mg_flags |= MGf_MINMATCH;
1477 mg->mg_flags &= ~MGf_MINMATCH;
1480 LEAVE_SCOPE(oldsave);
1484 yup: /* Confirmed by INTUIT */
1486 RX_MATCH_TAINTED_on(rx);
1487 TAINT_IF(RX_MATCH_TAINTED(rx));
1489 if (dynpm->op_pmflags & PMf_ONCE)
1490 dynpm->op_pmdynflags |= PMdf_USED;
1491 if (RX_MATCH_COPIED(rx))
1492 Safefree(rx->subbeg);
1493 RX_MATCH_COPIED_off(rx);
1496 /* FIXME - should rx->subbeg be const char *? */
1497 rx->subbeg = (char *) truebase;
1498 rx->startp[0] = s - truebase;
1499 if (RX_MATCH_UTF8(rx)) {
1500 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1501 rx->endp[0] = t - truebase;
1504 rx->endp[0] = s - truebase + rx->minlen;
1506 rx->sublen = strend - truebase;
1509 if (PL_sawampersand) {
1511 #ifdef PERL_OLD_COPY_ON_WRITE
1512 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1514 PerlIO_printf(Perl_debug_log,
1515 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1516 (int) SvTYPE(TARG), truebase, t,
1519 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1520 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1521 assert (SvPOKp(rx->saved_copy));
1526 rx->subbeg = savepvn(t, strend - t);
1527 #ifdef PERL_OLD_COPY_ON_WRITE
1528 rx->saved_copy = NULL;
1531 rx->sublen = strend - t;
1532 RX_MATCH_COPIED_on(rx);
1533 off = rx->startp[0] = s - t;
1534 rx->endp[0] = off + rx->minlen;
1536 else { /* startp/endp are used by @- @+. */
1537 rx->startp[0] = s - truebase;
1538 rx->endp[0] = s - truebase + rx->minlen;
1540 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1541 LEAVE_SCOPE(oldsave);
1546 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1547 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1548 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1553 LEAVE_SCOPE(oldsave);
1554 if (gimme == G_ARRAY)
1560 Perl_do_readline(pTHX)
1562 dVAR; dSP; dTARGETSTACKED;
1567 register IO * const io = GvIO(PL_last_in_gv);
1568 register const I32 type = PL_op->op_type;
1569 const I32 gimme = GIMME_V;
1572 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1575 XPUSHs(SvTIED_obj((SV*)io, mg));
1578 call_method("READLINE", gimme);
1581 if (gimme == G_SCALAR) {
1582 SV* const result = POPs;
1583 SvSetSV_nosteal(TARG, result);
1593 if (IoFLAGS(io) & IOf_ARGV) {
1594 if (IoFLAGS(io) & IOf_START) {
1596 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1597 IoFLAGS(io) &= ~IOf_START;
1598 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1599 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1600 SvSETMAGIC(GvSV(PL_last_in_gv));
1605 fp = nextargv(PL_last_in_gv);
1606 if (!fp) { /* Note: fp != IoIFP(io) */
1607 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1610 else if (type == OP_GLOB)
1611 fp = Perl_start_glob(aTHX_ POPs, io);
1613 else if (type == OP_GLOB)
1615 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1616 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1620 if ((!io || !(IoFLAGS(io) & IOf_START))
1621 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1623 if (type == OP_GLOB)
1624 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1625 "glob failed (can't start child: %s)",
1628 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1630 if (gimme == G_SCALAR) {
1631 /* undef TARG, and push that undefined value */
1632 if (type != OP_RCATLINE) {
1633 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1641 if (gimme == G_SCALAR) {
1645 else if (isGV_with_GP(sv)) {
1646 SvPV_force_nolen(sv);
1648 SvUPGRADE(sv, SVt_PV);
1649 tmplen = SvLEN(sv); /* remember if already alloced */
1650 if (!tmplen && !SvREADONLY(sv))
1651 Sv_Grow(sv, 80); /* try short-buffering it */
1653 if (type == OP_RCATLINE && SvOK(sv)) {
1655 SvPV_force_nolen(sv);
1661 sv = sv_2mortal(newSV(80));
1665 /* This should not be marked tainted if the fp is marked clean */
1666 #define MAYBE_TAINT_LINE(io, sv) \
1667 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1672 /* delay EOF state for a snarfed empty file */
1673 #define SNARF_EOF(gimme,rs,io,sv) \
1674 (gimme != G_SCALAR || SvCUR(sv) \
1675 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1679 if (!sv_gets(sv, fp, offset)
1681 || SNARF_EOF(gimme, PL_rs, io, sv)
1682 || PerlIO_error(fp)))
1684 PerlIO_clearerr(fp);
1685 if (IoFLAGS(io) & IOf_ARGV) {
1686 fp = nextargv(PL_last_in_gv);
1689 (void)do_close(PL_last_in_gv, FALSE);
1691 else if (type == OP_GLOB) {
1692 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1693 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1694 "glob failed (child exited with status %d%s)",
1695 (int)(STATUS_CURRENT >> 8),
1696 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1699 if (gimme == G_SCALAR) {
1700 if (type != OP_RCATLINE) {
1701 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1707 MAYBE_TAINT_LINE(io, sv);
1710 MAYBE_TAINT_LINE(io, sv);
1712 IoFLAGS(io) |= IOf_NOLINE;
1716 if (type == OP_GLOB) {
1719 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1720 char * const tmps = SvEND(sv) - 1;
1721 if (*tmps == *SvPVX_const(PL_rs)) {
1723 SvCUR_set(sv, SvCUR(sv) - 1);
1726 for (t1 = SvPVX_const(sv); *t1; t1++)
1727 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1728 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1730 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1731 (void)POPs; /* Unmatched wildcard? Chuck it... */
1734 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1735 if (ckWARN(WARN_UTF8)) {
1736 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1737 const STRLEN len = SvCUR(sv) - offset;
1740 if (!is_utf8_string_loc(s, len, &f))
1741 /* Emulate :encoding(utf8) warning in the same case. */
1742 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1743 "utf8 \"\\x%02X\" does not map to Unicode",
1744 f < (U8*)SvEND(sv) ? *f : 0);
1747 if (gimme == G_ARRAY) {
1748 if (SvLEN(sv) - SvCUR(sv) > 20) {
1749 SvPV_shrink_to_cur(sv);
1751 sv = sv_2mortal(newSV(80));
1754 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1755 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1756 const STRLEN new_len
1757 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1758 SvPV_renew(sv, new_len);
1767 register PERL_CONTEXT *cx;
1768 I32 gimme = OP_GIMME(PL_op, -1);
1771 if (cxstack_ix >= 0)
1772 gimme = cxstack[cxstack_ix].blk_gimme;
1780 PUSHBLOCK(cx, CXt_BLOCK, SP);
1790 SV * const keysv = POPs;
1791 HV * const hv = (HV*)POPs;
1792 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1793 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1795 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1798 if (SvTYPE(hv) != SVt_PVHV)
1801 if (PL_op->op_private & OPpLVAL_INTRO) {
1804 /* does the element we're localizing already exist? */
1805 preeminent = /* can we determine whether it exists? */
1807 || mg_find((SV*)hv, PERL_MAGIC_env)
1808 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1809 /* Try to preserve the existenceness of a tied hash
1810 * element by using EXISTS and DELETE if possible.
1811 * Fallback to FETCH and STORE otherwise */
1812 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1813 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1814 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1816 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1818 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1819 svp = he ? &HeVAL(he) : NULL;
1821 if (!svp || *svp == &PL_sv_undef) {
1825 DIE(aTHX_ PL_no_helem_sv, keysv);
1827 lv = sv_newmortal();
1828 sv_upgrade(lv, SVt_PVLV);
1830 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1831 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1832 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1837 if (PL_op->op_private & OPpLVAL_INTRO) {
1838 if (HvNAME_get(hv) && isGV(*svp))
1839 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1843 const char * const key = SvPV_const(keysv, keylen);
1844 SAVEDELETE(hv, savepvn(key,keylen),
1845 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1847 save_helem(hv, keysv, svp);
1850 else if (PL_op->op_private & OPpDEREF)
1851 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1853 sv = (svp ? *svp : &PL_sv_undef);
1854 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1855 * Pushing the magical RHS on to the stack is useless, since
1856 * that magic is soon destined to be misled by the local(),
1857 * and thus the later pp_sassign() will fail to mg_get() the
1858 * old value. This should also cure problems with delayed
1859 * mg_get()s. GSAR 98-07-03 */
1860 if (!lval && SvGMAGICAL(sv))
1861 sv = sv_mortalcopy(sv);
1869 register PERL_CONTEXT *cx;
1874 if (PL_op->op_flags & OPf_SPECIAL) {
1875 cx = &cxstack[cxstack_ix];
1876 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1881 gimme = OP_GIMME(PL_op, -1);
1883 if (cxstack_ix >= 0)
1884 gimme = cxstack[cxstack_ix].blk_gimme;
1890 if (gimme == G_VOID)
1892 else if (gimme == G_SCALAR) {
1896 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1899 *MARK = sv_mortalcopy(TOPs);
1902 *MARK = &PL_sv_undef;
1906 else if (gimme == G_ARRAY) {
1907 /* in case LEAVE wipes old return values */
1909 for (mark = newsp + 1; mark <= SP; mark++) {
1910 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1911 *mark = sv_mortalcopy(*mark);
1912 TAINT_NOT; /* Each item is independent */
1916 PL_curpm = newpm; /* Don't pop $1 et al till now */
1926 register PERL_CONTEXT *cx;
1932 cx = &cxstack[cxstack_ix];
1933 if (CxTYPE(cx) != CXt_LOOP)
1934 DIE(aTHX_ "panic: pp_iter");
1936 itersvp = CxITERVAR(cx);
1937 av = cx->blk_loop.iterary;
1938 if (SvTYPE(av) != SVt_PVAV) {
1939 /* iterate ($min .. $max) */
1940 if (cx->blk_loop.iterlval) {
1941 /* string increment */
1942 register SV* cur = cx->blk_loop.iterlval;
1946 SvPV_const((SV*)av, maxlen) : (const char *)"";
1947 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1948 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1949 /* safe to reuse old SV */
1950 sv_setsv(*itersvp, cur);
1954 /* we need a fresh SV every time so that loop body sees a
1955 * completely new SV for closures/references to work as
1958 *itersvp = newSVsv(cur);
1959 SvREFCNT_dec(oldsv);
1961 if (strEQ(SvPVX_const(cur), max))
1962 sv_setiv(cur, 0); /* terminate next time */
1969 /* integer increment */
1970 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1973 /* don't risk potential race */
1974 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1975 /* safe to reuse old SV */
1976 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1980 /* we need a fresh SV every time so that loop body sees a
1981 * completely new SV for closures/references to work as they
1984 *itersvp = newSViv(cx->blk_loop.iterix++);
1985 SvREFCNT_dec(oldsv);
1991 if (PL_op->op_private & OPpITER_REVERSED) {
1992 /* In reverse, use itermax as the min :-) */
1993 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1996 if (SvMAGICAL(av) || AvREIFY(av)) {
1997 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1998 sv = svp ? *svp : NULL;
2001 sv = AvARRAY(av)[--cx->blk_loop.iterix];
2005 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2009 if (SvMAGICAL(av) || AvREIFY(av)) {
2010 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2011 sv = svp ? *svp : NULL;
2014 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2018 if (sv && SvIS_FREED(sv)) {
2020 Perl_croak(aTHX_ "Use of freed value in iteration");
2027 if (av != PL_curstack && sv == &PL_sv_undef) {
2028 SV *lv = cx->blk_loop.iterlval;
2029 if (lv && SvREFCNT(lv) > 1) {
2034 SvREFCNT_dec(LvTARG(lv));
2036 lv = cx->blk_loop.iterlval = newSV(0);
2037 sv_upgrade(lv, SVt_PVLV);
2039 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2041 LvTARG(lv) = SvREFCNT_inc_simple(av);
2042 LvTARGOFF(lv) = cx->blk_loop.iterix;
2043 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2048 *itersvp = SvREFCNT_inc_simple_NN(sv);
2049 SvREFCNT_dec(oldsv);
2057 register PMOP *pm = cPMOP;
2072 register REGEXP *rx = PM_GETRE(pm);
2074 int force_on_match = 0;
2075 const I32 oldsave = PL_savestack_ix;
2077 bool doutf8 = FALSE;
2078 #ifdef PERL_OLD_COPY_ON_WRITE
2083 /* known replacement string? */
2084 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2085 if (PL_op->op_flags & OPf_STACKED)
2087 else if (PL_op->op_private & OPpTARGET_MY)
2094 #ifdef PERL_OLD_COPY_ON_WRITE
2095 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2096 because they make integers such as 256 "false". */
2097 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2100 sv_force_normal_flags(TARG,0);
2103 #ifdef PERL_OLD_COPY_ON_WRITE
2107 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2108 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2109 DIE(aTHX_ PL_no_modify);
2112 s = SvPV_mutable(TARG, len);
2113 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2115 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2116 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2121 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2125 DIE(aTHX_ "panic: pp_subst");
2128 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2129 maxiters = 2 * slen + 10; /* We can match twice at each
2130 position, once with zero-length,
2131 second time with non-zero. */
2133 if (!rx->prelen && PL_curpm) {
2137 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2138 || (pm->op_pmflags & PMf_EVAL))
2139 ? REXEC_COPY_STR : 0;
2141 r_flags |= REXEC_SCREAM;
2144 if (rx->reganch & RE_USE_INTUIT) {
2146 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2150 /* How to do it in subst? */
2151 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2153 && ((rx->reganch & ROPT_NOSCAN)
2154 || !((rx->reganch & RE_INTUIT_TAIL)
2155 && (r_flags & REXEC_SCREAM))))
2160 /* only replace once? */
2161 once = !(rpm->op_pmflags & PMf_GLOBAL);
2163 /* known replacement string? */
2165 /* replacement needing upgrading? */
2166 if (DO_UTF8(TARG) && !doutf8) {
2167 nsv = sv_newmortal();
2170 sv_recode_to_utf8(nsv, PL_encoding);
2172 sv_utf8_upgrade(nsv);
2173 c = SvPV_const(nsv, clen);
2177 c = SvPV_const(dstr, clen);
2178 doutf8 = DO_UTF8(dstr);
2186 /* can do inplace substitution? */
2188 #ifdef PERL_OLD_COPY_ON_WRITE
2191 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2192 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2193 && (!doutf8 || SvUTF8(TARG))) {
2194 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2195 r_flags | REXEC_CHECKED))
2199 LEAVE_SCOPE(oldsave);
2202 #ifdef PERL_OLD_COPY_ON_WRITE
2203 if (SvIsCOW(TARG)) {
2204 assert (!force_on_match);
2208 if (force_on_match) {
2210 s = SvPV_force(TARG, len);
2215 SvSCREAM_off(TARG); /* disable possible screamer */
2217 rxtainted |= RX_MATCH_TAINTED(rx);
2218 m = orig + rx->startp[0];
2219 d = orig + rx->endp[0];
2221 if (m - s > strend - d) { /* faster to shorten from end */
2223 Copy(c, m, clen, char);
2228 Move(d, m, i, char);
2232 SvCUR_set(TARG, m - s);
2234 else if ((i = m - s)) { /* faster from front */
2242 Copy(c, m, clen, char);
2247 Copy(c, d, clen, char);
2252 TAINT_IF(rxtainted & 1);
2258 if (iters++ > maxiters)
2259 DIE(aTHX_ "Substitution loop");
2260 rxtainted |= RX_MATCH_TAINTED(rx);
2261 m = rx->startp[0] + orig;
2264 Move(s, d, i, char);
2268 Copy(c, d, clen, char);
2271 s = rx->endp[0] + orig;
2272 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2274 /* don't match same null twice */
2275 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2278 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2279 Move(s, d, i+1, char); /* include the NUL */
2281 TAINT_IF(rxtainted & 1);
2283 PUSHs(sv_2mortal(newSViv((I32)iters)));
2285 (void)SvPOK_only_UTF8(TARG);
2286 TAINT_IF(rxtainted);
2287 if (SvSMAGICAL(TARG)) {
2295 LEAVE_SCOPE(oldsave);
2299 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2300 r_flags | REXEC_CHECKED))
2302 if (force_on_match) {
2304 s = SvPV_force(TARG, len);
2307 #ifdef PERL_OLD_COPY_ON_WRITE
2310 rxtainted |= RX_MATCH_TAINTED(rx);
2311 dstr = newSVpvn(m, s-m);
2317 register PERL_CONTEXT *cx;
2320 RETURNOP(cPMOP->op_pmreplroot);
2322 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2324 if (iters++ > maxiters)
2325 DIE(aTHX_ "Substitution loop");
2326 rxtainted |= RX_MATCH_TAINTED(rx);
2327 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2332 strend = s + (strend - m);
2334 m = rx->startp[0] + orig;
2335 if (doutf8 && !SvUTF8(dstr))
2336 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2338 sv_catpvn(dstr, s, m-s);
2339 s = rx->endp[0] + orig;
2341 sv_catpvn(dstr, c, clen);
2344 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2345 TARG, NULL, r_flags));
2346 if (doutf8 && !DO_UTF8(TARG))
2347 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2349 sv_catpvn(dstr, s, strend - s);
2351 #ifdef PERL_OLD_COPY_ON_WRITE
2352 /* The match may make the string COW. If so, brilliant, because that's
2353 just saved us one malloc, copy and free - the regexp has donated
2354 the old buffer, and we malloc an entirely new one, rather than the
2355 regexp malloc()ing a buffer and copying our original, only for
2356 us to throw it away here during the substitution. */
2357 if (SvIsCOW(TARG)) {
2358 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2364 SvPV_set(TARG, SvPVX(dstr));
2365 SvCUR_set(TARG, SvCUR(dstr));
2366 SvLEN_set(TARG, SvLEN(dstr));
2367 doutf8 |= DO_UTF8(dstr);
2368 SvPV_set(dstr, NULL);
2370 TAINT_IF(rxtainted & 1);
2372 PUSHs(sv_2mortal(newSViv((I32)iters)));
2374 (void)SvPOK_only(TARG);
2377 TAINT_IF(rxtainted);
2380 LEAVE_SCOPE(oldsave);
2389 LEAVE_SCOPE(oldsave);
2398 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2399 ++*PL_markstack_ptr;
2400 LEAVE; /* exit inner scope */
2403 if (PL_stack_base + *PL_markstack_ptr > SP) {
2405 const I32 gimme = GIMME_V;
2407 LEAVE; /* exit outer scope */
2408 (void)POPMARK; /* pop src */
2409 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2410 (void)POPMARK; /* pop dst */
2411 SP = PL_stack_base + POPMARK; /* pop original mark */
2412 if (gimme == G_SCALAR) {
2413 if (PL_op->op_private & OPpGREP_LEX) {
2414 SV* const sv = sv_newmortal();
2415 sv_setiv(sv, items);
2423 else if (gimme == G_ARRAY)
2430 ENTER; /* enter inner scope */
2433 src = PL_stack_base[*PL_markstack_ptr];
2435 if (PL_op->op_private & OPpGREP_LEX)
2436 PAD_SVl(PL_op->op_targ) = src;
2440 RETURNOP(cLOGOP->op_other);
2451 register PERL_CONTEXT *cx;
2454 if (CxMULTICALL(&cxstack[cxstack_ix]))
2458 cxstack_ix++; /* temporarily protect top context */
2461 if (gimme == G_SCALAR) {
2464 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2466 *MARK = SvREFCNT_inc(TOPs);
2471 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2473 *MARK = sv_mortalcopy(sv);
2478 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2482 *MARK = &PL_sv_undef;
2486 else if (gimme == G_ARRAY) {
2487 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2488 if (!SvTEMP(*MARK)) {
2489 *MARK = sv_mortalcopy(*MARK);
2490 TAINT_NOT; /* Each item is independent */
2498 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2499 PL_curpm = newpm; /* ... and pop $1 et al */
2502 return cx->blk_sub.retop;
2505 /* This duplicates the above code because the above code must not
2506 * get any slower by more conditions */
2514 register PERL_CONTEXT *cx;
2517 if (CxMULTICALL(&cxstack[cxstack_ix]))
2521 cxstack_ix++; /* temporarily protect top context */
2525 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2526 /* We are an argument to a function or grep().
2527 * This kind of lvalueness was legal before lvalue
2528 * subroutines too, so be backward compatible:
2529 * cannot report errors. */
2531 /* Scalar context *is* possible, on the LHS of -> only,
2532 * as in f()->meth(). But this is not an lvalue. */
2533 if (gimme == G_SCALAR)
2535 if (gimme == G_ARRAY) {
2536 if (!CvLVALUE(cx->blk_sub.cv))
2537 goto temporise_array;
2538 EXTEND_MORTAL(SP - newsp);
2539 for (mark = newsp + 1; mark <= SP; mark++) {
2542 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2543 *mark = sv_mortalcopy(*mark);
2545 /* Can be a localized value subject to deletion. */
2546 PL_tmps_stack[++PL_tmps_ix] = *mark;
2547 SvREFCNT_inc_void(*mark);
2552 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2553 /* Here we go for robustness, not for speed, so we change all
2554 * the refcounts so the caller gets a live guy. Cannot set
2555 * TEMP, so sv_2mortal is out of question. */
2556 if (!CvLVALUE(cx->blk_sub.cv)) {
2562 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2564 if (gimme == G_SCALAR) {
2568 /* Temporaries are bad unless they happen to be elements
2569 * of a tied hash or array */
2570 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2571 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2577 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2578 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2579 : "a readonly value" : "a temporary");
2581 else { /* Can be a localized value
2582 * subject to deletion. */
2583 PL_tmps_stack[++PL_tmps_ix] = *mark;
2584 SvREFCNT_inc_void(*mark);
2587 else { /* Should not happen? */
2593 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2594 (MARK > SP ? "Empty array" : "Array"));
2598 else if (gimme == G_ARRAY) {
2599 EXTEND_MORTAL(SP - newsp);
2600 for (mark = newsp + 1; mark <= SP; mark++) {
2601 if (*mark != &PL_sv_undef
2602 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2603 /* Might be flattened array after $#array = */
2610 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2611 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2614 /* Can be a localized value subject to deletion. */
2615 PL_tmps_stack[++PL_tmps_ix] = *mark;
2616 SvREFCNT_inc_void(*mark);
2622 if (gimme == G_SCALAR) {
2626 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2628 *MARK = SvREFCNT_inc(TOPs);
2633 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2635 *MARK = sv_mortalcopy(sv);
2640 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2644 *MARK = &PL_sv_undef;
2648 else if (gimme == G_ARRAY) {
2650 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2651 if (!SvTEMP(*MARK)) {
2652 *MARK = sv_mortalcopy(*MARK);
2653 TAINT_NOT; /* Each item is independent */
2662 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2663 PL_curpm = newpm; /* ... and pop $1 et al */
2666 return cx->blk_sub.retop;
2671 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2674 SV * const dbsv = GvSVn(PL_DBsub);
2677 if (!PERLDB_SUB_NN) {
2678 GV * const gv = CvGV(cv);
2680 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2681 || strEQ(GvNAME(gv), "END")
2682 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2683 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2684 /* Use GV from the stack as a fallback. */
2685 /* GV is potentially non-unique, or contain different CV. */
2686 SV * const tmp = newRV((SV*)cv);
2687 sv_setsv(dbsv, tmp);
2691 gv_efullname3(dbsv, gv, NULL);
2695 const int type = SvTYPE(dbsv);
2696 if (type < SVt_PVIV && type != SVt_IV)
2697 sv_upgrade(dbsv, SVt_PVIV);
2698 (void)SvIOK_on(dbsv);
2699 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2703 PL_curcopdb = PL_curcop;
2704 cv = GvCV(PL_DBsub);
2713 register PERL_CONTEXT *cx;
2715 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2718 DIE(aTHX_ "Not a CODE reference");
2719 switch (SvTYPE(sv)) {
2720 /* This is overwhelming the most common case: */
2722 if (!(cv = GvCVu((GV*)sv))) {
2724 cv = sv_2cv(sv, &stash, &gv, 0);
2735 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2737 SP = PL_stack_base + POPMARK;
2740 if (SvGMAGICAL(sv)) {
2744 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2747 sym = SvPV_nolen_const(sv);
2750 DIE(aTHX_ PL_no_usym, "a subroutine");
2751 if (PL_op->op_private & HINT_STRICT_REFS)
2752 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2753 cv = get_cv(sym, TRUE);
2758 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2759 tryAMAGICunDEREF(to_cv);
2762 if (SvTYPE(cv) == SVt_PVCV)
2767 DIE(aTHX_ "Not a CODE reference");
2768 /* This is the second most common case: */
2778 if (!CvROOT(cv) && !CvXSUB(cv)) {
2782 /* anonymous or undef'd function leaves us no recourse */
2783 if (CvANON(cv) || !(gv = CvGV(cv)))
2784 DIE(aTHX_ "Undefined subroutine called");
2786 /* autoloaded stub? */
2787 if (cv != GvCV(gv)) {
2790 /* should call AUTOLOAD now? */
2793 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2800 sub_name = sv_newmortal();
2801 gv_efullname3(sub_name, gv, NULL);
2802 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2806 DIE(aTHX_ "Not a CODE reference");
2811 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2812 if (CvASSERTION(cv) && PL_DBassertion)
2813 sv_setiv(PL_DBassertion, 1);
2815 cv = get_db_sub(&sv, cv);
2816 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2817 DIE(aTHX_ "No DB::sub routine defined");
2820 if (!(CvISXSUB(cv))) {
2821 /* This path taken at least 75% of the time */
2823 register I32 items = SP - MARK;
2824 AV* const padlist = CvPADLIST(cv);
2825 PUSHBLOCK(cx, CXt_SUB, MARK);
2827 cx->blk_sub.retop = PL_op->op_next;
2829 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2830 * that eval'' ops within this sub know the correct lexical space.
2831 * Owing the speed considerations, we choose instead to search for
2832 * the cv using find_runcv() when calling doeval().
2834 if (CvDEPTH(cv) >= 2) {
2835 PERL_STACK_OVERFLOW_CHECK();
2836 pad_push(padlist, CvDEPTH(cv));
2839 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2841 AV* const av = (AV*)PAD_SVl(0);
2843 /* @_ is normally not REAL--this should only ever
2844 * happen when DB::sub() calls things that modify @_ */
2849 cx->blk_sub.savearray = GvAV(PL_defgv);
2850 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2851 CX_CURPAD_SAVE(cx->blk_sub);
2852 cx->blk_sub.argarray = av;
2855 if (items > AvMAX(av) + 1) {
2856 SV **ary = AvALLOC(av);
2857 if (AvARRAY(av) != ary) {
2858 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2861 if (items > AvMAX(av) + 1) {
2862 AvMAX(av) = items - 1;
2863 Renew(ary,items,SV*);
2868 Copy(MARK,AvARRAY(av),items,SV*);
2869 AvFILLp(av) = items - 1;
2877 /* warning must come *after* we fully set up the context
2878 * stuff so that __WARN__ handlers can safely dounwind()
2881 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2882 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2883 sub_crush_depth(cv);
2885 DEBUG_S(PerlIO_printf(Perl_debug_log,
2886 "%p entersub returning %p\n", thr, CvSTART(cv)));
2888 RETURNOP(CvSTART(cv));
2891 I32 markix = TOPMARK;
2896 /* Need to copy @_ to stack. Alternative may be to
2897 * switch stack to @_, and copy return values
2898 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2899 AV * const av = GvAV(PL_defgv);
2900 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2903 /* Mark is at the end of the stack. */
2905 Copy(AvARRAY(av), SP + 1, items, SV*);
2910 /* We assume first XSUB in &DB::sub is the called one. */
2912 SAVEVPTR(PL_curcop);
2913 PL_curcop = PL_curcopdb;
2916 /* Do we need to open block here? XXXX */
2917 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2918 (void)(*CvXSUB(cv))(aTHX_ cv);
2920 /* Enforce some sanity in scalar context. */
2921 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2922 if (markix > PL_stack_sp - PL_stack_base)
2923 *(PL_stack_base + markix) = &PL_sv_undef;
2925 *(PL_stack_base + markix) = *PL_stack_sp;
2926 PL_stack_sp = PL_stack_base + markix;
2934 Perl_sub_crush_depth(pTHX_ CV *cv)
2937 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2939 SV* const tmpstr = sv_newmortal();
2940 gv_efullname3(tmpstr, CvGV(cv), NULL);
2941 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2950 SV* const elemsv = POPs;
2951 IV elem = SvIV(elemsv);
2952 AV* const av = (AV*)POPs;
2953 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2954 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2957 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2958 Perl_warner(aTHX_ packWARN(WARN_MISC),
2959 "Use of reference \"%"SVf"\" as array index",
2962 elem -= CopARYBASE_get(PL_curcop);
2963 if (SvTYPE(av) != SVt_PVAV)
2965 svp = av_fetch(av, elem, lval && !defer);
2967 #ifdef PERL_MALLOC_WRAP
2968 if (SvUOK(elemsv)) {
2969 const UV uv = SvUV(elemsv);
2970 elem = uv > IV_MAX ? IV_MAX : uv;
2972 else if (SvNOK(elemsv))
2973 elem = (IV)SvNV(elemsv);
2975 static const char oom_array_extend[] =
2976 "Out of memory during array extend"; /* Duplicated in av.c */
2977 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2980 if (!svp || *svp == &PL_sv_undef) {
2983 DIE(aTHX_ PL_no_aelem, elem);
2984 lv = sv_newmortal();
2985 sv_upgrade(lv, SVt_PVLV);
2987 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2988 LvTARG(lv) = SvREFCNT_inc_simple(av);
2989 LvTARGOFF(lv) = elem;
2994 if (PL_op->op_private & OPpLVAL_INTRO)
2995 save_aelem(av, elem, svp);
2996 else if (PL_op->op_private & OPpDEREF)
2997 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2999 sv = (svp ? *svp : &PL_sv_undef);
3000 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
3001 sv = sv_mortalcopy(sv);
3007 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3012 Perl_croak(aTHX_ PL_no_modify);
3013 if (SvTYPE(sv) < SVt_RV)
3014 sv_upgrade(sv, SVt_RV);
3015 else if (SvTYPE(sv) >= SVt_PV) {
3022 SvRV_set(sv, newSV(0));
3025 SvRV_set(sv, (SV*)newAV());
3028 SvRV_set(sv, (SV*)newHV());
3039 SV* const sv = TOPs;
3042 SV* const rsv = SvRV(sv);
3043 if (SvTYPE(rsv) == SVt_PVCV) {
3049 SETs(method_common(sv, NULL));
3056 SV* const sv = cSVOP_sv;
3057 U32 hash = SvSHARED_HASH(sv);
3059 XPUSHs(method_common(sv, &hash));
3064 S_method_common(pTHX_ SV* meth, U32* hashp)
3071 const char* packname = NULL;
3074 const char * const name = SvPV_const(meth, namelen);
3075 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3078 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3086 /* this isn't a reference */
3087 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3088 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3090 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3097 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3098 !(ob=(SV*)GvIO(iogv)))
3100 /* this isn't the name of a filehandle either */
3102 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3103 ? !isIDFIRST_utf8((U8*)packname)
3104 : !isIDFIRST(*packname)
3107 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3108 SvOK(sv) ? "without a package or object reference"
3109 : "on an undefined value");
3111 /* assume it's a package name */
3112 stash = gv_stashpvn(packname, packlen, FALSE);
3116 SV* const ref = newSViv(PTR2IV(stash));
3117 hv_store(PL_stashcache, packname, packlen, ref, 0);
3121 /* it _is_ a filehandle name -- replace with a reference */
3122 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3125 /* if we got here, ob should be a reference or a glob */
3126 if (!ob || !(SvOBJECT(ob)
3127 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3130 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3134 stash = SvSTASH(ob);
3137 /* NOTE: stash may be null, hope hv_fetch_ent and
3138 gv_fetchmethod can cope (it seems they can) */
3140 /* shortcut for simple names */
3142 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3144 gv = (GV*)HeVAL(he);
3145 if (isGV(gv) && GvCV(gv) &&
3146 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3147 return (SV*)GvCV(gv);
3151 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3154 /* This code tries to figure out just what went wrong with
3155 gv_fetchmethod. It therefore needs to duplicate a lot of
3156 the internals of that function. We can't move it inside
3157 Perl_gv_fetchmethod_autoload(), however, since that would
3158 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3161 const char* leaf = name;
3162 const char* sep = NULL;
3165 for (p = name; *p; p++) {
3167 sep = p, leaf = p + 1;
3168 else if (*p == ':' && *(p + 1) == ':')
3169 sep = p, leaf = p + 2;
3171 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3172 /* the method name is unqualified or starts with SUPER:: */
3173 bool need_strlen = 1;
3175 packname = CopSTASHPV(PL_curcop);
3178 HEK * const packhek = HvNAME_HEK(stash);
3180 packname = HEK_KEY(packhek);
3181 packlen = HEK_LEN(packhek);
3191 "Can't use anonymous symbol table for method lookup");
3193 else if (need_strlen)
3194 packlen = strlen(packname);
3198 /* the method name is qualified */
3200 packlen = sep - name;
3203 /* we're relying on gv_fetchmethod not autovivifying the stash */
3204 if (gv_stashpvn(packname, packlen, FALSE)) {
3206 "Can't locate object method \"%s\" via package \"%.*s\"",
3207 leaf, (int)packlen, packname);
3211 "Can't locate object method \"%s\" via package \"%.*s\""
3212 " (perhaps you forgot to load \"%.*s\"?)",
3213 leaf, (int)packlen, packname, (int)packlen, packname);
3216 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3221 * c-indentation-style: bsd
3223 * indent-tabs-mode: t
3226 * ex: set ts=8 sts=4 sw=4 noet: