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 int 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;
1940 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1941 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1942 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1943 /* safe to reuse old SV */
1944 sv_setsv(*itersvp, cur);
1948 /* we need a fresh SV every time so that loop body sees a
1949 * completely new SV for closures/references to work as
1952 *itersvp = newSVsv(cur);
1953 SvREFCNT_dec(oldsv);
1955 if (strEQ(SvPVX_const(cur), max))
1956 sv_setiv(cur, 0); /* terminate next time */
1963 /* integer increment */
1964 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1967 /* don't risk potential race */
1968 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1969 /* safe to reuse old SV */
1970 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1974 /* we need a fresh SV every time so that loop body sees a
1975 * completely new SV for closures/references to work as they
1978 *itersvp = newSViv(cx->blk_loop.iterix++);
1979 SvREFCNT_dec(oldsv);
1985 if (PL_op->op_private & OPpITER_REVERSED) {
1986 /* In reverse, use itermax as the min :-) */
1987 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1990 if (SvMAGICAL(av) || AvREIFY(av)) {
1991 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1992 sv = svp ? *svp : NULL;
1995 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1999 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2003 if (SvMAGICAL(av) || AvREIFY(av)) {
2004 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2005 sv = svp ? *svp : NULL;
2008 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2012 if (sv && SvIS_FREED(sv)) {
2014 Perl_croak(aTHX_ "Use of freed value in iteration");
2021 if (av != PL_curstack && sv == &PL_sv_undef) {
2022 SV *lv = cx->blk_loop.iterlval;
2023 if (lv && SvREFCNT(lv) > 1) {
2028 SvREFCNT_dec(LvTARG(lv));
2030 lv = cx->blk_loop.iterlval = newSV(0);
2031 sv_upgrade(lv, SVt_PVLV);
2033 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2035 LvTARG(lv) = SvREFCNT_inc_simple(av);
2036 LvTARGOFF(lv) = cx->blk_loop.iterix;
2037 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2042 *itersvp = SvREFCNT_inc_simple_NN(sv);
2043 SvREFCNT_dec(oldsv);
2051 register PMOP *pm = cPMOP;
2066 register REGEXP *rx = PM_GETRE(pm);
2068 int force_on_match = 0;
2069 const I32 oldsave = PL_savestack_ix;
2071 bool doutf8 = FALSE;
2072 #ifdef PERL_OLD_COPY_ON_WRITE
2077 /* known replacement string? */
2078 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2079 if (PL_op->op_flags & OPf_STACKED)
2081 else if (PL_op->op_private & OPpTARGET_MY)
2088 #ifdef PERL_OLD_COPY_ON_WRITE
2089 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2090 because they make integers such as 256 "false". */
2091 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2094 sv_force_normal_flags(TARG,0);
2097 #ifdef PERL_OLD_COPY_ON_WRITE
2101 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2102 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2103 DIE(aTHX_ PL_no_modify);
2106 s = SvPV_mutable(TARG, len);
2107 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2109 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2110 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2115 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2119 DIE(aTHX_ "panic: pp_subst");
2122 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2123 maxiters = 2 * slen + 10; /* We can match twice at each
2124 position, once with zero-length,
2125 second time with non-zero. */
2127 if (!rx->prelen && PL_curpm) {
2131 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2132 || (pm->op_pmflags & PMf_EVAL))
2133 ? REXEC_COPY_STR : 0;
2135 r_flags |= REXEC_SCREAM;
2138 if (rx->reganch & RE_USE_INTUIT) {
2140 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2144 /* How to do it in subst? */
2145 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2147 && ((rx->reganch & ROPT_NOSCAN)
2148 || !((rx->reganch & RE_INTUIT_TAIL)
2149 && (r_flags & REXEC_SCREAM))))
2154 /* only replace once? */
2155 once = !(rpm->op_pmflags & PMf_GLOBAL);
2157 /* known replacement string? */
2159 /* replacement needing upgrading? */
2160 if (DO_UTF8(TARG) && !doutf8) {
2161 nsv = sv_newmortal();
2164 sv_recode_to_utf8(nsv, PL_encoding);
2166 sv_utf8_upgrade(nsv);
2167 c = SvPV_const(nsv, clen);
2171 c = SvPV_const(dstr, clen);
2172 doutf8 = DO_UTF8(dstr);
2180 /* can do inplace substitution? */
2182 #ifdef PERL_OLD_COPY_ON_WRITE
2185 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2186 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2187 && (!doutf8 || SvUTF8(TARG))) {
2188 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2189 r_flags | REXEC_CHECKED))
2193 LEAVE_SCOPE(oldsave);
2196 #ifdef PERL_OLD_COPY_ON_WRITE
2197 if (SvIsCOW(TARG)) {
2198 assert (!force_on_match);
2202 if (force_on_match) {
2204 s = SvPV_force(TARG, len);
2209 SvSCREAM_off(TARG); /* disable possible screamer */
2211 rxtainted |= RX_MATCH_TAINTED(rx);
2212 m = orig + rx->startp[0];
2213 d = orig + rx->endp[0];
2215 if (m - s > strend - d) { /* faster to shorten from end */
2217 Copy(c, m, clen, char);
2222 Move(d, m, i, char);
2226 SvCUR_set(TARG, m - s);
2228 else if ((i = m - s)) { /* faster from front */
2236 Copy(c, m, clen, char);
2241 Copy(c, d, clen, char);
2246 TAINT_IF(rxtainted & 1);
2252 if (iters++ > maxiters)
2253 DIE(aTHX_ "Substitution loop");
2254 rxtainted |= RX_MATCH_TAINTED(rx);
2255 m = rx->startp[0] + orig;
2258 Move(s, d, i, char);
2262 Copy(c, d, clen, char);
2265 s = rx->endp[0] + orig;
2266 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2268 /* don't match same null twice */
2269 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2272 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2273 Move(s, d, i+1, char); /* include the NUL */
2275 TAINT_IF(rxtainted & 1);
2277 PUSHs(sv_2mortal(newSViv((I32)iters)));
2279 (void)SvPOK_only_UTF8(TARG);
2280 TAINT_IF(rxtainted);
2281 if (SvSMAGICAL(TARG)) {
2289 LEAVE_SCOPE(oldsave);
2293 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2294 r_flags | REXEC_CHECKED))
2296 if (force_on_match) {
2298 s = SvPV_force(TARG, len);
2301 #ifdef PERL_OLD_COPY_ON_WRITE
2304 rxtainted |= RX_MATCH_TAINTED(rx);
2305 dstr = newSVpvn(m, s-m);
2311 register PERL_CONTEXT *cx;
2314 RETURNOP(cPMOP->op_pmreplroot);
2316 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2318 if (iters++ > maxiters)
2319 DIE(aTHX_ "Substitution loop");
2320 rxtainted |= RX_MATCH_TAINTED(rx);
2321 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2326 strend = s + (strend - m);
2328 m = rx->startp[0] + orig;
2329 if (doutf8 && !SvUTF8(dstr))
2330 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2332 sv_catpvn(dstr, s, m-s);
2333 s = rx->endp[0] + orig;
2335 sv_catpvn(dstr, c, clen);
2338 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2339 TARG, NULL, r_flags));
2340 if (doutf8 && !DO_UTF8(TARG))
2341 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2343 sv_catpvn(dstr, s, strend - s);
2345 #ifdef PERL_OLD_COPY_ON_WRITE
2346 /* The match may make the string COW. If so, brilliant, because that's
2347 just saved us one malloc, copy and free - the regexp has donated
2348 the old buffer, and we malloc an entirely new one, rather than the
2349 regexp malloc()ing a buffer and copying our original, only for
2350 us to throw it away here during the substitution. */
2351 if (SvIsCOW(TARG)) {
2352 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2358 SvPV_set(TARG, SvPVX(dstr));
2359 SvCUR_set(TARG, SvCUR(dstr));
2360 SvLEN_set(TARG, SvLEN(dstr));
2361 doutf8 |= DO_UTF8(dstr);
2362 SvPV_set(dstr, NULL);
2364 TAINT_IF(rxtainted & 1);
2366 PUSHs(sv_2mortal(newSViv((I32)iters)));
2368 (void)SvPOK_only(TARG);
2371 TAINT_IF(rxtainted);
2374 LEAVE_SCOPE(oldsave);
2383 LEAVE_SCOPE(oldsave);
2392 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2393 ++*PL_markstack_ptr;
2394 LEAVE; /* exit inner scope */
2397 if (PL_stack_base + *PL_markstack_ptr > SP) {
2399 const I32 gimme = GIMME_V;
2401 LEAVE; /* exit outer scope */
2402 (void)POPMARK; /* pop src */
2403 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2404 (void)POPMARK; /* pop dst */
2405 SP = PL_stack_base + POPMARK; /* pop original mark */
2406 if (gimme == G_SCALAR) {
2407 if (PL_op->op_private & OPpGREP_LEX) {
2408 SV* const sv = sv_newmortal();
2409 sv_setiv(sv, items);
2417 else if (gimme == G_ARRAY)
2424 ENTER; /* enter inner scope */
2427 src = PL_stack_base[*PL_markstack_ptr];
2429 if (PL_op->op_private & OPpGREP_LEX)
2430 PAD_SVl(PL_op->op_targ) = src;
2434 RETURNOP(cLOGOP->op_other);
2445 register PERL_CONTEXT *cx;
2448 if (CxMULTICALL(&cxstack[cxstack_ix]))
2452 cxstack_ix++; /* temporarily protect top context */
2455 if (gimme == G_SCALAR) {
2458 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2460 *MARK = SvREFCNT_inc(TOPs);
2465 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2467 *MARK = sv_mortalcopy(sv);
2472 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2476 *MARK = &PL_sv_undef;
2480 else if (gimme == G_ARRAY) {
2481 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2482 if (!SvTEMP(*MARK)) {
2483 *MARK = sv_mortalcopy(*MARK);
2484 TAINT_NOT; /* Each item is independent */
2492 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2493 PL_curpm = newpm; /* ... and pop $1 et al */
2496 return cx->blk_sub.retop;
2499 /* This duplicates the above code because the above code must not
2500 * get any slower by more conditions */
2508 register PERL_CONTEXT *cx;
2511 if (CxMULTICALL(&cxstack[cxstack_ix]))
2515 cxstack_ix++; /* temporarily protect top context */
2519 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2520 /* We are an argument to a function or grep().
2521 * This kind of lvalueness was legal before lvalue
2522 * subroutines too, so be backward compatible:
2523 * cannot report errors. */
2525 /* Scalar context *is* possible, on the LHS of -> only,
2526 * as in f()->meth(). But this is not an lvalue. */
2527 if (gimme == G_SCALAR)
2529 if (gimme == G_ARRAY) {
2530 if (!CvLVALUE(cx->blk_sub.cv))
2531 goto temporise_array;
2532 EXTEND_MORTAL(SP - newsp);
2533 for (mark = newsp + 1; mark <= SP; mark++) {
2536 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2537 *mark = sv_mortalcopy(*mark);
2539 /* Can be a localized value subject to deletion. */
2540 PL_tmps_stack[++PL_tmps_ix] = *mark;
2541 SvREFCNT_inc_void(*mark);
2546 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2547 /* Here we go for robustness, not for speed, so we change all
2548 * the refcounts so the caller gets a live guy. Cannot set
2549 * TEMP, so sv_2mortal is out of question. */
2550 if (!CvLVALUE(cx->blk_sub.cv)) {
2556 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2558 if (gimme == G_SCALAR) {
2562 /* Temporaries are bad unless they happen to be elements
2563 * of a tied hash or array */
2564 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2565 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2571 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2572 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2573 : "a readonly value" : "a temporary");
2575 else { /* Can be a localized value
2576 * subject to deletion. */
2577 PL_tmps_stack[++PL_tmps_ix] = *mark;
2578 SvREFCNT_inc_void(*mark);
2581 else { /* Should not happen? */
2587 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2588 (MARK > SP ? "Empty array" : "Array"));
2592 else if (gimme == G_ARRAY) {
2593 EXTEND_MORTAL(SP - newsp);
2594 for (mark = newsp + 1; mark <= SP; mark++) {
2595 if (*mark != &PL_sv_undef
2596 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2597 /* Might be flattened array after $#array = */
2604 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2605 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2608 /* Can be a localized value subject to deletion. */
2609 PL_tmps_stack[++PL_tmps_ix] = *mark;
2610 SvREFCNT_inc_void(*mark);
2616 if (gimme == G_SCALAR) {
2620 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2622 *MARK = SvREFCNT_inc(TOPs);
2627 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2629 *MARK = sv_mortalcopy(sv);
2634 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2638 *MARK = &PL_sv_undef;
2642 else if (gimme == G_ARRAY) {
2644 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2645 if (!SvTEMP(*MARK)) {
2646 *MARK = sv_mortalcopy(*MARK);
2647 TAINT_NOT; /* Each item is independent */
2656 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2657 PL_curpm = newpm; /* ... and pop $1 et al */
2660 return cx->blk_sub.retop;
2665 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2668 SV * const dbsv = GvSVn(PL_DBsub);
2671 if (!PERLDB_SUB_NN) {
2672 GV * const gv = CvGV(cv);
2674 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2675 || strEQ(GvNAME(gv), "END")
2676 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2677 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2678 /* Use GV from the stack as a fallback. */
2679 /* GV is potentially non-unique, or contain different CV. */
2680 SV * const tmp = newRV((SV*)cv);
2681 sv_setsv(dbsv, tmp);
2685 gv_efullname3(dbsv, gv, NULL);
2689 const int type = SvTYPE(dbsv);
2690 if (type < SVt_PVIV && type != SVt_IV)
2691 sv_upgrade(dbsv, SVt_PVIV);
2692 (void)SvIOK_on(dbsv);
2693 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2697 PL_curcopdb = PL_curcop;
2698 cv = GvCV(PL_DBsub);
2707 register PERL_CONTEXT *cx;
2709 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2712 DIE(aTHX_ "Not a CODE reference");
2713 switch (SvTYPE(sv)) {
2714 /* This is overwhelming the most common case: */
2716 if (!(cv = GvCVu((GV*)sv))) {
2718 cv = sv_2cv(sv, &stash, &gv, 0);
2729 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2731 SP = PL_stack_base + POPMARK;
2734 if (SvGMAGICAL(sv)) {
2738 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2741 sym = SvPV_nolen_const(sv);
2744 DIE(aTHX_ PL_no_usym, "a subroutine");
2745 if (PL_op->op_private & HINT_STRICT_REFS)
2746 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2747 cv = get_cv(sym, TRUE);
2752 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2753 tryAMAGICunDEREF(to_cv);
2756 if (SvTYPE(cv) == SVt_PVCV)
2761 DIE(aTHX_ "Not a CODE reference");
2762 /* This is the second most common case: */
2772 if (!CvROOT(cv) && !CvXSUB(cv)) {
2776 /* anonymous or undef'd function leaves us no recourse */
2777 if (CvANON(cv) || !(gv = CvGV(cv)))
2778 DIE(aTHX_ "Undefined subroutine called");
2780 /* autoloaded stub? */
2781 if (cv != GvCV(gv)) {
2784 /* should call AUTOLOAD now? */
2787 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2794 sub_name = sv_newmortal();
2795 gv_efullname3(sub_name, gv, NULL);
2796 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2800 DIE(aTHX_ "Not a CODE reference");
2805 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2806 if (CvASSERTION(cv) && PL_DBassertion)
2807 sv_setiv(PL_DBassertion, 1);
2809 cv = get_db_sub(&sv, cv);
2810 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2811 DIE(aTHX_ "No DB::sub routine defined");
2814 if (!(CvISXSUB(cv))) {
2815 /* This path taken at least 75% of the time */
2817 register I32 items = SP - MARK;
2818 AV* const padlist = CvPADLIST(cv);
2819 PUSHBLOCK(cx, CXt_SUB, MARK);
2821 cx->blk_sub.retop = PL_op->op_next;
2823 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2824 * that eval'' ops within this sub know the correct lexical space.
2825 * Owing the speed considerations, we choose instead to search for
2826 * the cv using find_runcv() when calling doeval().
2828 if (CvDEPTH(cv) >= 2) {
2829 PERL_STACK_OVERFLOW_CHECK();
2830 pad_push(padlist, CvDEPTH(cv));
2833 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2835 AV* const av = (AV*)PAD_SVl(0);
2837 /* @_ is normally not REAL--this should only ever
2838 * happen when DB::sub() calls things that modify @_ */
2843 cx->blk_sub.savearray = GvAV(PL_defgv);
2844 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2845 CX_CURPAD_SAVE(cx->blk_sub);
2846 cx->blk_sub.argarray = av;
2849 if (items > AvMAX(av) + 1) {
2850 SV **ary = AvALLOC(av);
2851 if (AvARRAY(av) != ary) {
2852 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2853 SvPV_set(av, (char*)ary);
2855 if (items > AvMAX(av) + 1) {
2856 AvMAX(av) = items - 1;
2857 Renew(ary,items,SV*);
2859 SvPV_set(av, (char*)ary);
2862 Copy(MARK,AvARRAY(av),items,SV*);
2863 AvFILLp(av) = items - 1;
2871 /* warning must come *after* we fully set up the context
2872 * stuff so that __WARN__ handlers can safely dounwind()
2875 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2876 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2877 sub_crush_depth(cv);
2879 DEBUG_S(PerlIO_printf(Perl_debug_log,
2880 "%p entersub returning %p\n", thr, CvSTART(cv)));
2882 RETURNOP(CvSTART(cv));
2885 I32 markix = TOPMARK;
2890 /* Need to copy @_ to stack. Alternative may be to
2891 * switch stack to @_, and copy return values
2892 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2893 AV * const av = GvAV(PL_defgv);
2894 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2897 /* Mark is at the end of the stack. */
2899 Copy(AvARRAY(av), SP + 1, items, SV*);
2904 /* We assume first XSUB in &DB::sub is the called one. */
2906 SAVEVPTR(PL_curcop);
2907 PL_curcop = PL_curcopdb;
2910 /* Do we need to open block here? XXXX */
2911 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2912 (void)(*CvXSUB(cv))(aTHX_ cv);
2914 /* Enforce some sanity in scalar context. */
2915 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2916 if (markix > PL_stack_sp - PL_stack_base)
2917 *(PL_stack_base + markix) = &PL_sv_undef;
2919 *(PL_stack_base + markix) = *PL_stack_sp;
2920 PL_stack_sp = PL_stack_base + markix;
2928 Perl_sub_crush_depth(pTHX_ CV *cv)
2931 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2933 SV* const tmpstr = sv_newmortal();
2934 gv_efullname3(tmpstr, CvGV(cv), NULL);
2935 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2944 SV* const elemsv = POPs;
2945 IV elem = SvIV(elemsv);
2946 AV* const av = (AV*)POPs;
2947 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2948 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2951 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2952 Perl_warner(aTHX_ packWARN(WARN_MISC),
2953 "Use of reference \"%"SVf"\" as array index",
2956 elem -= CopARYBASE_get(PL_curcop);
2957 if (SvTYPE(av) != SVt_PVAV)
2959 svp = av_fetch(av, elem, lval && !defer);
2961 #ifdef PERL_MALLOC_WRAP
2962 if (SvUOK(elemsv)) {
2963 const UV uv = SvUV(elemsv);
2964 elem = uv > IV_MAX ? IV_MAX : uv;
2966 else if (SvNOK(elemsv))
2967 elem = (IV)SvNV(elemsv);
2969 static const char oom_array_extend[] =
2970 "Out of memory during array extend"; /* Duplicated in av.c */
2971 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2974 if (!svp || *svp == &PL_sv_undef) {
2977 DIE(aTHX_ PL_no_aelem, elem);
2978 lv = sv_newmortal();
2979 sv_upgrade(lv, SVt_PVLV);
2981 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2982 LvTARG(lv) = SvREFCNT_inc_simple(av);
2983 LvTARGOFF(lv) = elem;
2988 if (PL_op->op_private & OPpLVAL_INTRO)
2989 save_aelem(av, elem, svp);
2990 else if (PL_op->op_private & OPpDEREF)
2991 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2993 sv = (svp ? *svp : &PL_sv_undef);
2994 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2995 sv = sv_mortalcopy(sv);
3001 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3006 Perl_croak(aTHX_ PL_no_modify);
3007 if (SvTYPE(sv) < SVt_RV)
3008 sv_upgrade(sv, SVt_RV);
3009 else if (SvTYPE(sv) >= SVt_PV) {
3016 SvRV_set(sv, newSV(0));
3019 SvRV_set(sv, (SV*)newAV());
3022 SvRV_set(sv, (SV*)newHV());
3033 SV* const sv = TOPs;
3036 SV* const rsv = SvRV(sv);
3037 if (SvTYPE(rsv) == SVt_PVCV) {
3043 SETs(method_common(sv, NULL));
3050 SV* const sv = cSVOP_sv;
3051 U32 hash = SvSHARED_HASH(sv);
3053 XPUSHs(method_common(sv, &hash));
3058 S_method_common(pTHX_ SV* meth, U32* hashp)
3065 const char* packname = NULL;
3068 const char * const name = SvPV_const(meth, namelen);
3069 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3072 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3080 /* this isn't a reference */
3081 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3082 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3084 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3091 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3092 !(ob=(SV*)GvIO(iogv)))
3094 /* this isn't the name of a filehandle either */
3096 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3097 ? !isIDFIRST_utf8((U8*)packname)
3098 : !isIDFIRST(*packname)
3101 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3102 SvOK(sv) ? "without a package or object reference"
3103 : "on an undefined value");
3105 /* assume it's a package name */
3106 stash = gv_stashpvn(packname, packlen, FALSE);
3110 SV* const ref = newSViv(PTR2IV(stash));
3111 hv_store(PL_stashcache, packname, packlen, ref, 0);
3115 /* it _is_ a filehandle name -- replace with a reference */
3116 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3119 /* if we got here, ob should be a reference or a glob */
3120 if (!ob || !(SvOBJECT(ob)
3121 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3124 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3128 stash = SvSTASH(ob);
3131 /* NOTE: stash may be null, hope hv_fetch_ent and
3132 gv_fetchmethod can cope (it seems they can) */
3134 /* shortcut for simple names */
3136 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3138 gv = (GV*)HeVAL(he);
3139 if (isGV(gv) && GvCV(gv) &&
3140 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3141 return (SV*)GvCV(gv);
3145 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3148 /* This code tries to figure out just what went wrong with
3149 gv_fetchmethod. It therefore needs to duplicate a lot of
3150 the internals of that function. We can't move it inside
3151 Perl_gv_fetchmethod_autoload(), however, since that would
3152 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3155 const char* leaf = name;
3156 const char* sep = NULL;
3159 for (p = name; *p; p++) {
3161 sep = p, leaf = p + 1;
3162 else if (*p == ':' && *(p + 1) == ':')
3163 sep = p, leaf = p + 2;
3165 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3166 /* the method name is unqualified or starts with SUPER:: */
3167 bool need_strlen = 1;
3169 packname = CopSTASHPV(PL_curcop);
3172 HEK * const packhek = HvNAME_HEK(stash);
3174 packname = HEK_KEY(packhek);
3175 packlen = HEK_LEN(packhek);
3185 "Can't use anonymous symbol table for method lookup");
3187 else if (need_strlen)
3188 packlen = strlen(packname);
3192 /* the method name is qualified */
3194 packlen = sep - name;
3197 /* we're relying on gv_fetchmethod not autovivifying the stash */
3198 if (gv_stashpvn(packname, packlen, FALSE)) {
3200 "Can't locate object method \"%s\" via package \"%.*s\"",
3201 leaf, (int)packlen, packname);
3205 "Can't locate object method \"%s\" via package \"%.*s\""
3206 " (perhaps you forgot to load \"%.*s\"?)",
3207 leaf, (int)packlen, packname, (int)packlen, packname);
3210 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3215 * c-indentation-style: bsd
3217 * indent-tabs-mode: t
3220 * ex: set ts=8 sts=4 sw=4 noet: