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_ors_sv && SvOK(PL_ors_sv))
756 if (!do_print(PL_ors_sv, fp)) /* $\ */
759 if (IoFLAGS(io) & IOf_FLUSH)
760 if (PerlIO_flush(fp) == EOF)
770 XPUSHs(&PL_sv_undef);
781 tryAMAGICunDEREF(to_av);
784 if (SvTYPE(av) != SVt_PVAV)
785 DIE(aTHX_ "Not an ARRAY reference");
786 if (PL_op->op_flags & OPf_REF) {
791 if (GIMME == G_SCALAR)
792 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
796 else if (PL_op->op_flags & OPf_MOD
797 && PL_op->op_private & OPpLVAL_INTRO)
798 Perl_croak(aTHX_ PL_no_localize_ref);
801 if (SvTYPE(sv) == SVt_PVAV) {
803 if (PL_op->op_flags & OPf_REF) {
808 if (GIMME == G_SCALAR)
809 Perl_croak(aTHX_ "Can't return array to lvalue"
818 if (SvTYPE(sv) != SVt_PVGV) {
819 if (SvGMAGICAL(sv)) {
825 if (PL_op->op_flags & OPf_REF ||
826 PL_op->op_private & HINT_STRICT_REFS)
827 DIE(aTHX_ PL_no_usym, "an ARRAY");
828 if (ckWARN(WARN_UNINITIALIZED))
830 if (GIMME == G_ARRAY) {
836 if ((PL_op->op_flags & OPf_SPECIAL) &&
837 !(PL_op->op_flags & OPf_MOD))
839 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
841 && (!is_gv_magical_sv(sv,0)
842 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
848 if (PL_op->op_private & HINT_STRICT_REFS)
849 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
850 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
857 if (PL_op->op_private & OPpLVAL_INTRO)
859 if (PL_op->op_flags & OPf_REF) {
864 if (GIMME == G_SCALAR)
865 Perl_croak(aTHX_ "Can't return array to lvalue"
873 if (GIMME == G_ARRAY) {
874 const I32 maxarg = AvFILL(av) + 1;
875 (void)POPs; /* XXXX May be optimized away? */
877 if (SvRMAGICAL(av)) {
879 for (i=0; i < (U32)maxarg; i++) {
880 SV ** const svp = av_fetch(av, i, FALSE);
881 /* See note in pp_helem, and bug id #27839 */
883 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
888 Copy(AvARRAY(av), SP+1, maxarg, SV*);
892 else if (GIMME_V == G_SCALAR) {
894 const I32 maxarg = AvFILL(av) + 1;
904 const I32 gimme = GIMME_V;
905 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
909 tryAMAGICunDEREF(to_hv);
912 if (SvTYPE(hv) != SVt_PVHV)
913 DIE(aTHX_ "Not a HASH reference");
914 if (PL_op->op_flags & OPf_REF) {
919 if (gimme != G_ARRAY)
920 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
924 else if (PL_op->op_flags & OPf_MOD
925 && PL_op->op_private & OPpLVAL_INTRO)
926 Perl_croak(aTHX_ PL_no_localize_ref);
929 if (SvTYPE(sv) == SVt_PVHV) {
931 if (PL_op->op_flags & OPf_REF) {
936 if (gimme != G_ARRAY)
937 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
945 if (SvTYPE(sv) != SVt_PVGV) {
946 if (SvGMAGICAL(sv)) {
952 if (PL_op->op_flags & OPf_REF ||
953 PL_op->op_private & HINT_STRICT_REFS)
954 DIE(aTHX_ PL_no_usym, "a HASH");
955 if (ckWARN(WARN_UNINITIALIZED))
957 if (gimme == G_ARRAY) {
963 if ((PL_op->op_flags & OPf_SPECIAL) &&
964 !(PL_op->op_flags & OPf_MOD))
966 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
968 && (!is_gv_magical_sv(sv,0)
969 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
975 if (PL_op->op_private & HINT_STRICT_REFS)
976 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
977 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
984 if (PL_op->op_private & OPpLVAL_INTRO)
986 if (PL_op->op_flags & OPf_REF) {
991 if (gimme != G_ARRAY)
992 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
999 if (gimme == G_ARRAY) { /* array wanted */
1000 *PL_stack_sp = (SV*)hv;
1003 else if (gimme == G_SCALAR) {
1005 TARG = Perl_hv_scalar(aTHX_ hv);
1012 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1019 if (ckWARN(WARN_MISC)) {
1021 if (relem == firstrelem &&
1023 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1024 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1026 err = "Reference found where even-sized list expected";
1029 err = "Odd number of elements in hash assignment";
1030 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1034 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1035 if (SvMAGICAL(hash)) {
1036 if (SvSMAGICAL(tmpstr))
1048 SV **lastlelem = PL_stack_sp;
1049 SV **lastrelem = PL_stack_base + POPMARK;
1050 SV **firstrelem = PL_stack_base + POPMARK + 1;
1051 SV **firstlelem = lastrelem + 1;
1053 register SV **relem;
1054 register SV **lelem;
1064 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1067 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1070 /* If there's a common identifier on both sides we have to take
1071 * special care that assigning the identifier on the left doesn't
1072 * clobber a value on the right that's used later in the list.
1074 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1075 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1076 for (relem = firstrelem; relem <= lastrelem; relem++) {
1077 if ((sv = *relem)) {
1078 TAINT_NOT; /* Each item is independent */
1079 *relem = sv_mortalcopy(sv);
1083 if (PL_op->op_private & OPpASSIGN_STATE) {
1084 if (SvPADSTALE(*firstlelem))
1085 SvPADSTALE_off(*firstlelem);
1087 RETURN; /* ignore assignment */
1095 while (lelem <= lastlelem) {
1096 TAINT_NOT; /* Each item stands on its own, taintwise. */
1098 switch (SvTYPE(sv)) {
1101 magic = SvMAGICAL(ary) != 0;
1103 av_extend(ary, lastrelem - relem);
1105 while (relem <= lastrelem) { /* gobble up all the rest */
1108 sv = newSVsv(*relem);
1110 didstore = av_store(ary,i++,sv);
1120 case SVt_PVHV: { /* normal hash */
1124 magic = SvMAGICAL(hash) != 0;
1126 firsthashrelem = relem;
1128 while (relem < lastrelem) { /* gobble up all the rest */
1130 sv = *relem ? *relem : &PL_sv_no;
1134 sv_setsv(tmpstr,*relem); /* value */
1135 *(relem++) = tmpstr;
1136 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1137 /* key overwrites an existing entry */
1139 didstore = hv_store_ent(hash,sv,tmpstr,0);
1141 if (SvSMAGICAL(tmpstr))
1148 if (relem == lastrelem) {
1149 do_oddball(hash, relem, firstrelem);
1155 if (SvIMMORTAL(sv)) {
1156 if (relem <= lastrelem)
1160 if (relem <= lastrelem) {
1161 sv_setsv(sv, *relem);
1165 sv_setsv(sv, &PL_sv_undef);
1170 if (PL_delaymagic & ~DM_DELAY) {
1171 if (PL_delaymagic & DM_UID) {
1172 #ifdef HAS_SETRESUID
1173 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1174 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1177 # ifdef HAS_SETREUID
1178 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1179 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1182 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1183 (void)setruid(PL_uid);
1184 PL_delaymagic &= ~DM_RUID;
1186 # endif /* HAS_SETRUID */
1188 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1189 (void)seteuid(PL_euid);
1190 PL_delaymagic &= ~DM_EUID;
1192 # endif /* HAS_SETEUID */
1193 if (PL_delaymagic & DM_UID) {
1194 if (PL_uid != PL_euid)
1195 DIE(aTHX_ "No setreuid available");
1196 (void)PerlProc_setuid(PL_uid);
1198 # endif /* HAS_SETREUID */
1199 #endif /* HAS_SETRESUID */
1200 PL_uid = PerlProc_getuid();
1201 PL_euid = PerlProc_geteuid();
1203 if (PL_delaymagic & DM_GID) {
1204 #ifdef HAS_SETRESGID
1205 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1206 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1209 # ifdef HAS_SETREGID
1210 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1211 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1214 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1215 (void)setrgid(PL_gid);
1216 PL_delaymagic &= ~DM_RGID;
1218 # endif /* HAS_SETRGID */
1220 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1221 (void)setegid(PL_egid);
1222 PL_delaymagic &= ~DM_EGID;
1224 # endif /* HAS_SETEGID */
1225 if (PL_delaymagic & DM_GID) {
1226 if (PL_gid != PL_egid)
1227 DIE(aTHX_ "No setregid available");
1228 (void)PerlProc_setgid(PL_gid);
1230 # endif /* HAS_SETREGID */
1231 #endif /* HAS_SETRESGID */
1232 PL_gid = PerlProc_getgid();
1233 PL_egid = PerlProc_getegid();
1235 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1239 if (gimme == G_VOID)
1240 SP = firstrelem - 1;
1241 else if (gimme == G_SCALAR) {
1244 SETi(lastrelem - firstrelem + 1 - duplicates);
1251 /* Removes from the stack the entries which ended up as
1252 * duplicated keys in the hash (fix for [perl #24380]) */
1253 Move(firsthashrelem + duplicates,
1254 firsthashrelem, duplicates, SV**);
1255 lastrelem -= duplicates;
1260 SP = firstrelem + (lastlelem - firstlelem);
1261 lelem = firstlelem + (relem - firstrelem);
1263 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1271 register PMOP * const pm = cPMOP;
1272 SV * const rv = sv_newmortal();
1273 SV * const sv = newSVrv(rv, "Regexp");
1274 if (pm->op_pmdynflags & PMdf_TAINTED)
1276 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1283 register PMOP *pm = cPMOP;
1285 register const char *t;
1286 register const char *s;
1289 I32 r_flags = REXEC_CHECKED;
1290 const char *truebase; /* Start of string */
1291 register REGEXP *rx = PM_GETRE(pm);
1293 const I32 gimme = GIMME;
1296 const I32 oldsave = PL_savestack_ix;
1297 I32 update_minmatch = 1;
1298 I32 had_zerolen = 0;
1300 if (PL_op->op_flags & OPf_STACKED)
1302 else if (PL_op->op_private & OPpTARGET_MY)
1309 PUTBACK; /* EVAL blocks need stack_sp. */
1310 s = SvPV_const(TARG, len);
1312 DIE(aTHX_ "panic: pp_match");
1314 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1315 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1318 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1320 /* PMdf_USED is set after a ?? matches once */
1321 if (pm->op_pmdynflags & PMdf_USED) {
1323 if (gimme == G_ARRAY)
1328 /* empty pattern special-cased to use last successful pattern if possible */
1329 if (!rx->prelen && PL_curpm) {
1334 if (rx->minlen > (I32)len)
1339 /* XXXX What part of this is needed with true \G-support? */
1340 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1342 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1343 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1344 if (mg && mg->mg_len >= 0) {
1345 if (!(rx->reganch & ROPT_GPOS_SEEN))
1346 rx->endp[0] = rx->startp[0] = mg->mg_len;
1347 else if (rx->reganch & ROPT_ANCH_GPOS) {
1348 r_flags |= REXEC_IGNOREPOS;
1349 rx->endp[0] = rx->startp[0] = mg->mg_len;
1351 minmatch = (mg->mg_flags & MGf_MINMATCH);
1352 update_minmatch = 0;
1356 if ((!global && rx->nparens)
1357 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1358 r_flags |= REXEC_COPY_STR;
1360 r_flags |= REXEC_SCREAM;
1363 if (global && rx->startp[0] != -1) {
1364 t = s = rx->endp[0] + truebase;
1365 if ((s + rx->minlen) > strend)
1367 if (update_minmatch++)
1368 minmatch = had_zerolen;
1370 if (rx->reganch & RE_USE_INTUIT &&
1371 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1372 /* FIXME - can PL_bostr be made const char *? */
1373 PL_bostr = (char *)truebase;
1374 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1378 if ( (rx->reganch & ROPT_CHECK_ALL)
1380 && ((rx->reganch & ROPT_NOSCAN)
1381 || !((rx->reganch & RE_INTUIT_TAIL)
1382 && (r_flags & REXEC_SCREAM)))
1383 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1386 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1389 if (dynpm->op_pmflags & PMf_ONCE)
1390 dynpm->op_pmdynflags |= PMdf_USED;
1399 RX_MATCH_TAINTED_on(rx);
1400 TAINT_IF(RX_MATCH_TAINTED(rx));
1401 if (gimme == G_ARRAY) {
1402 const I32 nparens = rx->nparens;
1403 I32 i = (global && !nparens) ? 1 : 0;
1405 SPAGAIN; /* EVAL blocks could move the stack. */
1406 EXTEND(SP, nparens + i);
1407 EXTEND_MORTAL(nparens + i);
1408 for (i = !i; i <= nparens; i++) {
1409 PUSHs(sv_newmortal());
1410 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1411 const I32 len = rx->endp[i] - rx->startp[i];
1412 s = rx->startp[i] + truebase;
1413 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1414 len < 0 || len > strend - s)
1415 DIE(aTHX_ "panic: pp_match start/end pointers");
1416 sv_setpvn(*SP, s, len);
1417 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1422 if (dynpm->op_pmflags & PMf_CONTINUE) {
1424 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1425 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1427 #ifdef PERL_OLD_COPY_ON_WRITE
1429 sv_force_normal_flags(TARG, 0);
1431 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1432 &PL_vtbl_mglob, NULL, 0);
1434 if (rx->startp[0] != -1) {
1435 mg->mg_len = rx->endp[0];
1436 if (rx->startp[0] == rx->endp[0])
1437 mg->mg_flags |= MGf_MINMATCH;
1439 mg->mg_flags &= ~MGf_MINMATCH;
1442 had_zerolen = (rx->startp[0] != -1
1443 && rx->startp[0] == rx->endp[0]);
1444 PUTBACK; /* EVAL blocks may use stack */
1445 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1450 LEAVE_SCOPE(oldsave);
1456 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1457 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1461 #ifdef PERL_OLD_COPY_ON_WRITE
1463 sv_force_normal_flags(TARG, 0);
1465 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1466 &PL_vtbl_mglob, NULL, 0);
1468 if (rx->startp[0] != -1) {
1469 mg->mg_len = rx->endp[0];
1470 if (rx->startp[0] == rx->endp[0])
1471 mg->mg_flags |= MGf_MINMATCH;
1473 mg->mg_flags &= ~MGf_MINMATCH;
1476 LEAVE_SCOPE(oldsave);
1480 yup: /* Confirmed by INTUIT */
1482 RX_MATCH_TAINTED_on(rx);
1483 TAINT_IF(RX_MATCH_TAINTED(rx));
1485 if (dynpm->op_pmflags & PMf_ONCE)
1486 dynpm->op_pmdynflags |= PMdf_USED;
1487 if (RX_MATCH_COPIED(rx))
1488 Safefree(rx->subbeg);
1489 RX_MATCH_COPIED_off(rx);
1492 /* FIXME - should rx->subbeg be const char *? */
1493 rx->subbeg = (char *) truebase;
1494 rx->startp[0] = s - truebase;
1495 if (RX_MATCH_UTF8(rx)) {
1496 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1497 rx->endp[0] = t - truebase;
1500 rx->endp[0] = s - truebase + rx->minlen;
1502 rx->sublen = strend - truebase;
1505 if (PL_sawampersand) {
1507 #ifdef PERL_OLD_COPY_ON_WRITE
1508 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1510 PerlIO_printf(Perl_debug_log,
1511 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1512 (int) SvTYPE(TARG), truebase, t,
1515 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1516 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1517 assert (SvPOKp(rx->saved_copy));
1522 rx->subbeg = savepvn(t, strend - t);
1523 #ifdef PERL_OLD_COPY_ON_WRITE
1524 rx->saved_copy = NULL;
1527 rx->sublen = strend - t;
1528 RX_MATCH_COPIED_on(rx);
1529 off = rx->startp[0] = s - t;
1530 rx->endp[0] = off + rx->minlen;
1532 else { /* startp/endp are used by @- @+. */
1533 rx->startp[0] = s - truebase;
1534 rx->endp[0] = s - truebase + rx->minlen;
1536 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1537 LEAVE_SCOPE(oldsave);
1542 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1543 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1544 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1549 LEAVE_SCOPE(oldsave);
1550 if (gimme == G_ARRAY)
1556 Perl_do_readline(pTHX)
1558 dVAR; dSP; dTARGETSTACKED;
1563 register IO * const io = GvIO(PL_last_in_gv);
1564 register const I32 type = PL_op->op_type;
1565 const I32 gimme = GIMME_V;
1568 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1571 XPUSHs(SvTIED_obj((SV*)io, mg));
1574 call_method("READLINE", gimme);
1577 if (gimme == G_SCALAR) {
1578 SV* const result = POPs;
1579 SvSetSV_nosteal(TARG, result);
1589 if (IoFLAGS(io) & IOf_ARGV) {
1590 if (IoFLAGS(io) & IOf_START) {
1592 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1593 IoFLAGS(io) &= ~IOf_START;
1594 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1595 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1596 SvSETMAGIC(GvSV(PL_last_in_gv));
1601 fp = nextargv(PL_last_in_gv);
1602 if (!fp) { /* Note: fp != IoIFP(io) */
1603 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1606 else if (type == OP_GLOB)
1607 fp = Perl_start_glob(aTHX_ POPs, io);
1609 else if (type == OP_GLOB)
1611 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1612 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1616 if ((!io || !(IoFLAGS(io) & IOf_START))
1617 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1619 if (type == OP_GLOB)
1620 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1621 "glob failed (can't start child: %s)",
1624 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1626 if (gimme == G_SCALAR) {
1627 /* undef TARG, and push that undefined value */
1628 if (type != OP_RCATLINE) {
1629 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1637 if (gimme == G_SCALAR) {
1641 else if (isGV_with_GP(sv)) {
1642 SvPV_force_nolen(sv);
1644 SvUPGRADE(sv, SVt_PV);
1645 tmplen = SvLEN(sv); /* remember if already alloced */
1646 if (!tmplen && !SvREADONLY(sv))
1647 Sv_Grow(sv, 80); /* try short-buffering it */
1649 if (type == OP_RCATLINE && SvOK(sv)) {
1651 SvPV_force_nolen(sv);
1657 sv = sv_2mortal(newSV(80));
1661 /* This should not be marked tainted if the fp is marked clean */
1662 #define MAYBE_TAINT_LINE(io, sv) \
1663 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1668 /* delay EOF state for a snarfed empty file */
1669 #define SNARF_EOF(gimme,rs,io,sv) \
1670 (gimme != G_SCALAR || SvCUR(sv) \
1671 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1675 if (!sv_gets(sv, fp, offset)
1677 || SNARF_EOF(gimme, PL_rs, io, sv)
1678 || PerlIO_error(fp)))
1680 PerlIO_clearerr(fp);
1681 if (IoFLAGS(io) & IOf_ARGV) {
1682 fp = nextargv(PL_last_in_gv);
1685 (void)do_close(PL_last_in_gv, FALSE);
1687 else if (type == OP_GLOB) {
1688 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1689 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1690 "glob failed (child exited with status %d%s)",
1691 (int)(STATUS_CURRENT >> 8),
1692 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1695 if (gimme == G_SCALAR) {
1696 if (type != OP_RCATLINE) {
1697 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1703 MAYBE_TAINT_LINE(io, sv);
1706 MAYBE_TAINT_LINE(io, sv);
1708 IoFLAGS(io) |= IOf_NOLINE;
1712 if (type == OP_GLOB) {
1715 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1716 char * const tmps = SvEND(sv) - 1;
1717 if (*tmps == *SvPVX_const(PL_rs)) {
1719 SvCUR_set(sv, SvCUR(sv) - 1);
1722 for (t1 = SvPVX_const(sv); *t1; t1++)
1723 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1724 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1726 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1727 (void)POPs; /* Unmatched wildcard? Chuck it... */
1730 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1731 if (ckWARN(WARN_UTF8)) {
1732 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1733 const STRLEN len = SvCUR(sv) - offset;
1736 if (!is_utf8_string_loc(s, len, &f))
1737 /* Emulate :encoding(utf8) warning in the same case. */
1738 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1739 "utf8 \"\\x%02X\" does not map to Unicode",
1740 f < (U8*)SvEND(sv) ? *f : 0);
1743 if (gimme == G_ARRAY) {
1744 if (SvLEN(sv) - SvCUR(sv) > 20) {
1745 SvPV_shrink_to_cur(sv);
1747 sv = sv_2mortal(newSV(80));
1750 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1751 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1752 const STRLEN new_len
1753 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1754 SvPV_renew(sv, new_len);
1763 register PERL_CONTEXT *cx;
1764 I32 gimme = OP_GIMME(PL_op, -1);
1767 if (cxstack_ix >= 0)
1768 gimme = cxstack[cxstack_ix].blk_gimme;
1776 PUSHBLOCK(cx, CXt_BLOCK, SP);
1786 SV * const keysv = POPs;
1787 HV * const hv = (HV*)POPs;
1788 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1789 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1791 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1794 if (SvTYPE(hv) != SVt_PVHV)
1797 if (PL_op->op_private & OPpLVAL_INTRO) {
1800 /* does the element we're localizing already exist? */
1801 preeminent = /* can we determine whether it exists? */
1803 || mg_find((SV*)hv, PERL_MAGIC_env)
1804 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1805 /* Try to preserve the existenceness of a tied hash
1806 * element by using EXISTS and DELETE if possible.
1807 * Fallback to FETCH and STORE otherwise */
1808 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1809 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1810 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1812 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1814 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1815 svp = he ? &HeVAL(he) : NULL;
1817 if (!svp || *svp == &PL_sv_undef) {
1821 DIE(aTHX_ PL_no_helem_sv, keysv);
1823 lv = sv_newmortal();
1824 sv_upgrade(lv, SVt_PVLV);
1826 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1827 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1828 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1833 if (PL_op->op_private & OPpLVAL_INTRO) {
1834 if (HvNAME_get(hv) && isGV(*svp))
1835 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1839 const char * const key = SvPV_const(keysv, keylen);
1840 SAVEDELETE(hv, savepvn(key,keylen),
1841 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1843 save_helem(hv, keysv, svp);
1846 else if (PL_op->op_private & OPpDEREF)
1847 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1849 sv = (svp ? *svp : &PL_sv_undef);
1850 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1851 * Pushing the magical RHS on to the stack is useless, since
1852 * that magic is soon destined to be misled by the local(),
1853 * and thus the later pp_sassign() will fail to mg_get() the
1854 * old value. This should also cure problems with delayed
1855 * mg_get()s. GSAR 98-07-03 */
1856 if (!lval && SvGMAGICAL(sv))
1857 sv = sv_mortalcopy(sv);
1865 register PERL_CONTEXT *cx;
1870 if (PL_op->op_flags & OPf_SPECIAL) {
1871 cx = &cxstack[cxstack_ix];
1872 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1877 gimme = OP_GIMME(PL_op, -1);
1879 if (cxstack_ix >= 0)
1880 gimme = cxstack[cxstack_ix].blk_gimme;
1886 if (gimme == G_VOID)
1888 else if (gimme == G_SCALAR) {
1892 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1895 *MARK = sv_mortalcopy(TOPs);
1898 *MARK = &PL_sv_undef;
1902 else if (gimme == G_ARRAY) {
1903 /* in case LEAVE wipes old return values */
1905 for (mark = newsp + 1; mark <= SP; mark++) {
1906 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1907 *mark = sv_mortalcopy(*mark);
1908 TAINT_NOT; /* Each item is independent */
1912 PL_curpm = newpm; /* Don't pop $1 et al till now */
1922 register PERL_CONTEXT *cx;
1928 cx = &cxstack[cxstack_ix];
1929 if (CxTYPE(cx) != CXt_LOOP)
1930 DIE(aTHX_ "panic: pp_iter");
1932 itersvp = CxITERVAR(cx);
1933 av = cx->blk_loop.iterary;
1934 if (SvTYPE(av) != SVt_PVAV) {
1935 /* iterate ($min .. $max) */
1936 if (cx->blk_loop.iterlval) {
1937 /* string increment */
1938 register SV* cur = cx->blk_loop.iterlval;
1942 SvPV_const((SV*)av, maxlen) : (const char *)"";
1943 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1944 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1945 /* safe to reuse old SV */
1946 sv_setsv(*itersvp, cur);
1950 /* we need a fresh SV every time so that loop body sees a
1951 * completely new SV for closures/references to work as
1954 *itersvp = newSVsv(cur);
1955 SvREFCNT_dec(oldsv);
1957 if (strEQ(SvPVX_const(cur), max))
1958 sv_setiv(cur, 0); /* terminate next time */
1965 /* integer increment */
1966 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1969 /* don't risk potential race */
1970 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1971 /* safe to reuse old SV */
1972 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1976 /* we need a fresh SV every time so that loop body sees a
1977 * completely new SV for closures/references to work as they
1980 *itersvp = newSViv(cx->blk_loop.iterix++);
1981 SvREFCNT_dec(oldsv);
1987 if (PL_op->op_private & OPpITER_REVERSED) {
1988 /* In reverse, use itermax as the min :-) */
1989 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1992 if (SvMAGICAL(av) || AvREIFY(av)) {
1993 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1994 sv = svp ? *svp : NULL;
1997 sv = AvARRAY(av)[--cx->blk_loop.iterix];
2001 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2005 if (SvMAGICAL(av) || AvREIFY(av)) {
2006 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2007 sv = svp ? *svp : NULL;
2010 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2014 if (sv && SvIS_FREED(sv)) {
2016 Perl_croak(aTHX_ "Use of freed value in iteration");
2023 if (av != PL_curstack && sv == &PL_sv_undef) {
2024 SV *lv = cx->blk_loop.iterlval;
2025 if (lv && SvREFCNT(lv) > 1) {
2030 SvREFCNT_dec(LvTARG(lv));
2032 lv = cx->blk_loop.iterlval = newSV(0);
2033 sv_upgrade(lv, SVt_PVLV);
2035 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2037 LvTARG(lv) = SvREFCNT_inc_simple(av);
2038 LvTARGOFF(lv) = cx->blk_loop.iterix;
2039 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2044 *itersvp = SvREFCNT_inc_simple_NN(sv);
2045 SvREFCNT_dec(oldsv);
2053 register PMOP *pm = cPMOP;
2068 register REGEXP *rx = PM_GETRE(pm);
2070 int force_on_match = 0;
2071 const I32 oldsave = PL_savestack_ix;
2073 bool doutf8 = FALSE;
2074 #ifdef PERL_OLD_COPY_ON_WRITE
2079 /* known replacement string? */
2080 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2081 if (PL_op->op_flags & OPf_STACKED)
2083 else if (PL_op->op_private & OPpTARGET_MY)
2090 #ifdef PERL_OLD_COPY_ON_WRITE
2091 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2092 because they make integers such as 256 "false". */
2093 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2096 sv_force_normal_flags(TARG,0);
2099 #ifdef PERL_OLD_COPY_ON_WRITE
2103 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2104 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2105 DIE(aTHX_ PL_no_modify);
2108 s = SvPV_mutable(TARG, len);
2109 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2111 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2112 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2117 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2121 DIE(aTHX_ "panic: pp_subst");
2124 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2125 maxiters = 2 * slen + 10; /* We can match twice at each
2126 position, once with zero-length,
2127 second time with non-zero. */
2129 if (!rx->prelen && PL_curpm) {
2133 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2134 || (pm->op_pmflags & PMf_EVAL))
2135 ? REXEC_COPY_STR : 0;
2137 r_flags |= REXEC_SCREAM;
2140 if (rx->reganch & RE_USE_INTUIT) {
2142 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2146 /* How to do it in subst? */
2147 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2149 && ((rx->reganch & ROPT_NOSCAN)
2150 || !((rx->reganch & RE_INTUIT_TAIL)
2151 && (r_flags & REXEC_SCREAM))))
2156 /* only replace once? */
2157 once = !(rpm->op_pmflags & PMf_GLOBAL);
2159 /* known replacement string? */
2161 /* replacement needing upgrading? */
2162 if (DO_UTF8(TARG) && !doutf8) {
2163 nsv = sv_newmortal();
2166 sv_recode_to_utf8(nsv, PL_encoding);
2168 sv_utf8_upgrade(nsv);
2169 c = SvPV_const(nsv, clen);
2173 c = SvPV_const(dstr, clen);
2174 doutf8 = DO_UTF8(dstr);
2182 /* can do inplace substitution? */
2184 #ifdef PERL_OLD_COPY_ON_WRITE
2187 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2188 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2189 && (!doutf8 || SvUTF8(TARG))) {
2190 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2191 r_flags | REXEC_CHECKED))
2195 LEAVE_SCOPE(oldsave);
2198 #ifdef PERL_OLD_COPY_ON_WRITE
2199 if (SvIsCOW(TARG)) {
2200 assert (!force_on_match);
2204 if (force_on_match) {
2206 s = SvPV_force(TARG, len);
2211 SvSCREAM_off(TARG); /* disable possible screamer */
2213 rxtainted |= RX_MATCH_TAINTED(rx);
2214 m = orig + rx->startp[0];
2215 d = orig + rx->endp[0];
2217 if (m - s > strend - d) { /* faster to shorten from end */
2219 Copy(c, m, clen, char);
2224 Move(d, m, i, char);
2228 SvCUR_set(TARG, m - s);
2230 else if ((i = m - s)) { /* faster from front */
2238 Copy(c, m, clen, char);
2243 Copy(c, d, clen, char);
2248 TAINT_IF(rxtainted & 1);
2254 if (iters++ > maxiters)
2255 DIE(aTHX_ "Substitution loop");
2256 rxtainted |= RX_MATCH_TAINTED(rx);
2257 m = rx->startp[0] + orig;
2260 Move(s, d, i, char);
2264 Copy(c, d, clen, char);
2267 s = rx->endp[0] + orig;
2268 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2270 /* don't match same null twice */
2271 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2274 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2275 Move(s, d, i+1, char); /* include the NUL */
2277 TAINT_IF(rxtainted & 1);
2279 PUSHs(sv_2mortal(newSViv((I32)iters)));
2281 (void)SvPOK_only_UTF8(TARG);
2282 TAINT_IF(rxtainted);
2283 if (SvSMAGICAL(TARG)) {
2291 LEAVE_SCOPE(oldsave);
2295 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2296 r_flags | REXEC_CHECKED))
2298 if (force_on_match) {
2300 s = SvPV_force(TARG, len);
2303 #ifdef PERL_OLD_COPY_ON_WRITE
2306 rxtainted |= RX_MATCH_TAINTED(rx);
2307 dstr = newSVpvn(m, s-m);
2313 register PERL_CONTEXT *cx;
2316 RETURNOP(cPMOP->op_pmreplroot);
2318 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2320 if (iters++ > maxiters)
2321 DIE(aTHX_ "Substitution loop");
2322 rxtainted |= RX_MATCH_TAINTED(rx);
2323 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2328 strend = s + (strend - m);
2330 m = rx->startp[0] + orig;
2331 if (doutf8 && !SvUTF8(dstr))
2332 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2334 sv_catpvn(dstr, s, m-s);
2335 s = rx->endp[0] + orig;
2337 sv_catpvn(dstr, c, clen);
2340 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2341 TARG, NULL, r_flags));
2342 if (doutf8 && !DO_UTF8(TARG))
2343 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2345 sv_catpvn(dstr, s, strend - s);
2347 #ifdef PERL_OLD_COPY_ON_WRITE
2348 /* The match may make the string COW. If so, brilliant, because that's
2349 just saved us one malloc, copy and free - the regexp has donated
2350 the old buffer, and we malloc an entirely new one, rather than the
2351 regexp malloc()ing a buffer and copying our original, only for
2352 us to throw it away here during the substitution. */
2353 if (SvIsCOW(TARG)) {
2354 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2360 SvPV_set(TARG, SvPVX(dstr));
2361 SvCUR_set(TARG, SvCUR(dstr));
2362 SvLEN_set(TARG, SvLEN(dstr));
2363 doutf8 |= DO_UTF8(dstr);
2364 SvPV_set(dstr, NULL);
2366 TAINT_IF(rxtainted & 1);
2368 PUSHs(sv_2mortal(newSViv((I32)iters)));
2370 (void)SvPOK_only(TARG);
2373 TAINT_IF(rxtainted);
2376 LEAVE_SCOPE(oldsave);
2385 LEAVE_SCOPE(oldsave);
2394 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2395 ++*PL_markstack_ptr;
2396 LEAVE; /* exit inner scope */
2399 if (PL_stack_base + *PL_markstack_ptr > SP) {
2401 const I32 gimme = GIMME_V;
2403 LEAVE; /* exit outer scope */
2404 (void)POPMARK; /* pop src */
2405 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2406 (void)POPMARK; /* pop dst */
2407 SP = PL_stack_base + POPMARK; /* pop original mark */
2408 if (gimme == G_SCALAR) {
2409 if (PL_op->op_private & OPpGREP_LEX) {
2410 SV* const sv = sv_newmortal();
2411 sv_setiv(sv, items);
2419 else if (gimme == G_ARRAY)
2426 ENTER; /* enter inner scope */
2429 src = PL_stack_base[*PL_markstack_ptr];
2431 if (PL_op->op_private & OPpGREP_LEX)
2432 PAD_SVl(PL_op->op_targ) = src;
2436 RETURNOP(cLOGOP->op_other);
2447 register PERL_CONTEXT *cx;
2450 if (CxMULTICALL(&cxstack[cxstack_ix]))
2454 cxstack_ix++; /* temporarily protect top context */
2457 if (gimme == G_SCALAR) {
2460 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2462 *MARK = SvREFCNT_inc(TOPs);
2467 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2469 *MARK = sv_mortalcopy(sv);
2474 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2478 *MARK = &PL_sv_undef;
2482 else if (gimme == G_ARRAY) {
2483 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2484 if (!SvTEMP(*MARK)) {
2485 *MARK = sv_mortalcopy(*MARK);
2486 TAINT_NOT; /* Each item is independent */
2494 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2495 PL_curpm = newpm; /* ... and pop $1 et al */
2498 return cx->blk_sub.retop;
2501 /* This duplicates the above code because the above code must not
2502 * get any slower by more conditions */
2510 register PERL_CONTEXT *cx;
2513 if (CxMULTICALL(&cxstack[cxstack_ix]))
2517 cxstack_ix++; /* temporarily protect top context */
2521 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2522 /* We are an argument to a function or grep().
2523 * This kind of lvalueness was legal before lvalue
2524 * subroutines too, so be backward compatible:
2525 * cannot report errors. */
2527 /* Scalar context *is* possible, on the LHS of -> only,
2528 * as in f()->meth(). But this is not an lvalue. */
2529 if (gimme == G_SCALAR)
2531 if (gimme == G_ARRAY) {
2532 if (!CvLVALUE(cx->blk_sub.cv))
2533 goto temporise_array;
2534 EXTEND_MORTAL(SP - newsp);
2535 for (mark = newsp + 1; mark <= SP; mark++) {
2538 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2539 *mark = sv_mortalcopy(*mark);
2541 /* Can be a localized value subject to deletion. */
2542 PL_tmps_stack[++PL_tmps_ix] = *mark;
2543 SvREFCNT_inc_void(*mark);
2548 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2549 /* Here we go for robustness, not for speed, so we change all
2550 * the refcounts so the caller gets a live guy. Cannot set
2551 * TEMP, so sv_2mortal is out of question. */
2552 if (!CvLVALUE(cx->blk_sub.cv)) {
2558 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2560 if (gimme == G_SCALAR) {
2564 /* Temporaries are bad unless they happen to be elements
2565 * of a tied hash or array */
2566 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2567 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2573 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2574 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2575 : "a readonly value" : "a temporary");
2577 else { /* Can be a localized value
2578 * subject to deletion. */
2579 PL_tmps_stack[++PL_tmps_ix] = *mark;
2580 SvREFCNT_inc_void(*mark);
2583 else { /* Should not happen? */
2589 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2590 (MARK > SP ? "Empty array" : "Array"));
2594 else if (gimme == G_ARRAY) {
2595 EXTEND_MORTAL(SP - newsp);
2596 for (mark = newsp + 1; mark <= SP; mark++) {
2597 if (*mark != &PL_sv_undef
2598 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2599 /* Might be flattened array after $#array = */
2606 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2607 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2610 /* Can be a localized value subject to deletion. */
2611 PL_tmps_stack[++PL_tmps_ix] = *mark;
2612 SvREFCNT_inc_void(*mark);
2618 if (gimme == G_SCALAR) {
2622 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2624 *MARK = SvREFCNT_inc(TOPs);
2629 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2631 *MARK = sv_mortalcopy(sv);
2636 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2640 *MARK = &PL_sv_undef;
2644 else if (gimme == G_ARRAY) {
2646 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2647 if (!SvTEMP(*MARK)) {
2648 *MARK = sv_mortalcopy(*MARK);
2649 TAINT_NOT; /* Each item is independent */
2658 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2659 PL_curpm = newpm; /* ... and pop $1 et al */
2662 return cx->blk_sub.retop;
2667 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2670 SV * const dbsv = GvSVn(PL_DBsub);
2673 if (!PERLDB_SUB_NN) {
2674 GV * const gv = CvGV(cv);
2676 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2677 || strEQ(GvNAME(gv), "END")
2678 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2679 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2680 /* Use GV from the stack as a fallback. */
2681 /* GV is potentially non-unique, or contain different CV. */
2682 SV * const tmp = newRV((SV*)cv);
2683 sv_setsv(dbsv, tmp);
2687 gv_efullname3(dbsv, gv, NULL);
2691 const int type = SvTYPE(dbsv);
2692 if (type < SVt_PVIV && type != SVt_IV)
2693 sv_upgrade(dbsv, SVt_PVIV);
2694 (void)SvIOK_on(dbsv);
2695 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2699 PL_curcopdb = PL_curcop;
2700 cv = GvCV(PL_DBsub);
2709 register PERL_CONTEXT *cx;
2711 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2714 DIE(aTHX_ "Not a CODE reference");
2715 switch (SvTYPE(sv)) {
2716 /* This is overwhelming the most common case: */
2718 if (!(cv = GvCVu((GV*)sv))) {
2720 cv = sv_2cv(sv, &stash, &gv, 0);
2731 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2733 SP = PL_stack_base + POPMARK;
2736 if (SvGMAGICAL(sv)) {
2740 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2743 sym = SvPV_nolen_const(sv);
2746 DIE(aTHX_ PL_no_usym, "a subroutine");
2747 if (PL_op->op_private & HINT_STRICT_REFS)
2748 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2749 cv = get_cv(sym, TRUE);
2754 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2755 tryAMAGICunDEREF(to_cv);
2758 if (SvTYPE(cv) == SVt_PVCV)
2763 DIE(aTHX_ "Not a CODE reference");
2764 /* This is the second most common case: */
2774 if (!CvROOT(cv) && !CvXSUB(cv)) {
2778 /* anonymous or undef'd function leaves us no recourse */
2779 if (CvANON(cv) || !(gv = CvGV(cv)))
2780 DIE(aTHX_ "Undefined subroutine called");
2782 /* autoloaded stub? */
2783 if (cv != GvCV(gv)) {
2786 /* should call AUTOLOAD now? */
2789 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2796 sub_name = sv_newmortal();
2797 gv_efullname3(sub_name, gv, NULL);
2798 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2802 DIE(aTHX_ "Not a CODE reference");
2807 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2808 if (CvASSERTION(cv) && PL_DBassertion)
2809 sv_setiv(PL_DBassertion, 1);
2811 cv = get_db_sub(&sv, cv);
2812 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2813 DIE(aTHX_ "No DB::sub routine defined");
2816 if (!(CvISXSUB(cv))) {
2817 /* This path taken at least 75% of the time */
2819 register I32 items = SP - MARK;
2820 AV* const padlist = CvPADLIST(cv);
2821 PUSHBLOCK(cx, CXt_SUB, MARK);
2823 cx->blk_sub.retop = PL_op->op_next;
2825 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2826 * that eval'' ops within this sub know the correct lexical space.
2827 * Owing the speed considerations, we choose instead to search for
2828 * the cv using find_runcv() when calling doeval().
2830 if (CvDEPTH(cv) >= 2) {
2831 PERL_STACK_OVERFLOW_CHECK();
2832 pad_push(padlist, CvDEPTH(cv));
2835 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2837 AV* const av = (AV*)PAD_SVl(0);
2839 /* @_ is normally not REAL--this should only ever
2840 * happen when DB::sub() calls things that modify @_ */
2845 cx->blk_sub.savearray = GvAV(PL_defgv);
2846 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2847 CX_CURPAD_SAVE(cx->blk_sub);
2848 cx->blk_sub.argarray = av;
2851 if (items > AvMAX(av) + 1) {
2852 SV **ary = AvALLOC(av);
2853 if (AvARRAY(av) != ary) {
2854 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2855 SvPV_set(av, (char*)ary);
2857 if (items > AvMAX(av) + 1) {
2858 AvMAX(av) = items - 1;
2859 Renew(ary,items,SV*);
2861 SvPV_set(av, (char*)ary);
2864 Copy(MARK,AvARRAY(av),items,SV*);
2865 AvFILLp(av) = items - 1;
2873 /* warning must come *after* we fully set up the context
2874 * stuff so that __WARN__ handlers can safely dounwind()
2877 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2878 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2879 sub_crush_depth(cv);
2881 DEBUG_S(PerlIO_printf(Perl_debug_log,
2882 "%p entersub returning %p\n", thr, CvSTART(cv)));
2884 RETURNOP(CvSTART(cv));
2887 I32 markix = TOPMARK;
2892 /* Need to copy @_ to stack. Alternative may be to
2893 * switch stack to @_, and copy return values
2894 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2895 AV * const av = GvAV(PL_defgv);
2896 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2899 /* Mark is at the end of the stack. */
2901 Copy(AvARRAY(av), SP + 1, items, SV*);
2906 /* We assume first XSUB in &DB::sub is the called one. */
2908 SAVEVPTR(PL_curcop);
2909 PL_curcop = PL_curcopdb;
2912 /* Do we need to open block here? XXXX */
2913 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2914 (void)(*CvXSUB(cv))(aTHX_ cv);
2916 /* Enforce some sanity in scalar context. */
2917 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2918 if (markix > PL_stack_sp - PL_stack_base)
2919 *(PL_stack_base + markix) = &PL_sv_undef;
2921 *(PL_stack_base + markix) = *PL_stack_sp;
2922 PL_stack_sp = PL_stack_base + markix;
2930 Perl_sub_crush_depth(pTHX_ CV *cv)
2933 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2935 SV* const tmpstr = sv_newmortal();
2936 gv_efullname3(tmpstr, CvGV(cv), NULL);
2937 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2946 SV* const elemsv = POPs;
2947 IV elem = SvIV(elemsv);
2948 AV* const av = (AV*)POPs;
2949 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2950 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2953 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2954 Perl_warner(aTHX_ packWARN(WARN_MISC),
2955 "Use of reference \"%"SVf"\" as array index",
2958 elem -= CopARYBASE_get(PL_curcop);
2959 if (SvTYPE(av) != SVt_PVAV)
2961 svp = av_fetch(av, elem, lval && !defer);
2963 #ifdef PERL_MALLOC_WRAP
2964 if (SvUOK(elemsv)) {
2965 const UV uv = SvUV(elemsv);
2966 elem = uv > IV_MAX ? IV_MAX : uv;
2968 else if (SvNOK(elemsv))
2969 elem = (IV)SvNV(elemsv);
2971 static const char oom_array_extend[] =
2972 "Out of memory during array extend"; /* Duplicated in av.c */
2973 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2976 if (!svp || *svp == &PL_sv_undef) {
2979 DIE(aTHX_ PL_no_aelem, elem);
2980 lv = sv_newmortal();
2981 sv_upgrade(lv, SVt_PVLV);
2983 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2984 LvTARG(lv) = SvREFCNT_inc_simple(av);
2985 LvTARGOFF(lv) = elem;
2990 if (PL_op->op_private & OPpLVAL_INTRO)
2991 save_aelem(av, elem, svp);
2992 else if (PL_op->op_private & OPpDEREF)
2993 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2995 sv = (svp ? *svp : &PL_sv_undef);
2996 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2997 sv = sv_mortalcopy(sv);
3003 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3008 Perl_croak(aTHX_ PL_no_modify);
3009 if (SvTYPE(sv) < SVt_RV)
3010 sv_upgrade(sv, SVt_RV);
3011 else if (SvTYPE(sv) >= SVt_PV) {
3018 SvRV_set(sv, newSV(0));
3021 SvRV_set(sv, (SV*)newAV());
3024 SvRV_set(sv, (SV*)newHV());
3035 SV* const sv = TOPs;
3038 SV* const rsv = SvRV(sv);
3039 if (SvTYPE(rsv) == SVt_PVCV) {
3045 SETs(method_common(sv, NULL));
3052 SV* const sv = cSVOP_sv;
3053 U32 hash = SvSHARED_HASH(sv);
3055 XPUSHs(method_common(sv, &hash));
3060 S_method_common(pTHX_ SV* meth, U32* hashp)
3067 const char* packname = NULL;
3070 const char * const name = SvPV_const(meth, namelen);
3071 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3074 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3082 /* this isn't a reference */
3083 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3084 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3086 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3093 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3094 !(ob=(SV*)GvIO(iogv)))
3096 /* this isn't the name of a filehandle either */
3098 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3099 ? !isIDFIRST_utf8((U8*)packname)
3100 : !isIDFIRST(*packname)
3103 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3104 SvOK(sv) ? "without a package or object reference"
3105 : "on an undefined value");
3107 /* assume it's a package name */
3108 stash = gv_stashpvn(packname, packlen, FALSE);
3112 SV* const ref = newSViv(PTR2IV(stash));
3113 hv_store(PL_stashcache, packname, packlen, ref, 0);
3117 /* it _is_ a filehandle name -- replace with a reference */
3118 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3121 /* if we got here, ob should be a reference or a glob */
3122 if (!ob || !(SvOBJECT(ob)
3123 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3126 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3130 stash = SvSTASH(ob);
3133 /* NOTE: stash may be null, hope hv_fetch_ent and
3134 gv_fetchmethod can cope (it seems they can) */
3136 /* shortcut for simple names */
3138 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3140 gv = (GV*)HeVAL(he);
3141 if (isGV(gv) && GvCV(gv) &&
3142 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3143 return (SV*)GvCV(gv);
3147 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3150 /* This code tries to figure out just what went wrong with
3151 gv_fetchmethod. It therefore needs to duplicate a lot of
3152 the internals of that function. We can't move it inside
3153 Perl_gv_fetchmethod_autoload(), however, since that would
3154 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3157 const char* leaf = name;
3158 const char* sep = NULL;
3161 for (p = name; *p; p++) {
3163 sep = p, leaf = p + 1;
3164 else if (*p == ':' && *(p + 1) == ':')
3165 sep = p, leaf = p + 2;
3167 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3168 /* the method name is unqualified or starts with SUPER:: */
3169 bool need_strlen = 1;
3171 packname = CopSTASHPV(PL_curcop);
3174 HEK * const packhek = HvNAME_HEK(stash);
3176 packname = HEK_KEY(packhek);
3177 packlen = HEK_LEN(packhek);
3187 "Can't use anonymous symbol table for method lookup");
3189 else if (need_strlen)
3190 packlen = strlen(packname);
3194 /* the method name is qualified */
3196 packlen = sep - name;
3199 /* we're relying on gv_fetchmethod not autovivifying the stash */
3200 if (gv_stashpvn(packname, packlen, FALSE)) {
3202 "Can't locate object method \"%s\" via package \"%.*s\"",
3203 leaf, (int)packlen, packname);
3207 "Can't locate object method \"%s\" via package \"%.*s\""
3208 " (perhaps you forgot to load \"%.*s\"?)",
3209 leaf, (int)packlen, packname, (int)packlen, packname);
3212 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3217 * c-indentation-style: bsd
3219 * indent-tabs-mode: t
3222 * ex: set ts=8 sts=4 sw=4 noet: