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 (LVALUE) 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,
183 if (strEQ(GvNAME(right),"isa")) {
188 SvSetMagicSV(right, left);
197 RETURNOP(cLOGOP->op_other);
199 RETURNOP(cLOGOP->op_next);
206 TAINT_NOT; /* Each statement is presumed innocent */
207 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
209 oldsave = PL_scopestack[PL_scopestack_ix - 1];
210 LEAVE_SCOPE(oldsave);
216 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
221 const char *rpv = NULL;
223 bool rcopied = FALSE;
225 if (TARG == right && right != left) {
226 /* mg_get(right) may happen here ... */
227 rpv = SvPV_const(right, rlen);
228 rbyte = !DO_UTF8(right);
229 right = sv_2mortal(newSVpvn(rpv, rlen));
230 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
236 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
237 lbyte = !DO_UTF8(left);
238 sv_setpvn(TARG, lpv, llen);
244 else { /* TARG == left */
246 SvGETMAGIC(left); /* or mg_get(left) may happen here */
248 if (left == right && ckWARN(WARN_UNINITIALIZED))
249 report_uninit(right);
250 sv_setpvn(left, "", 0);
252 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
253 lbyte = !DO_UTF8(left);
258 /* or mg_get(right) may happen here */
260 rpv = SvPV_const(right, rlen);
261 rbyte = !DO_UTF8(right);
263 if (lbyte != rbyte) {
265 sv_utf8_upgrade_nomg(TARG);
268 right = sv_2mortal(newSVpvn(rpv, rlen));
269 sv_utf8_upgrade_nomg(right);
270 rpv = SvPV_const(right, rlen);
273 sv_catpvn_nomg(TARG, rpv, rlen);
284 if (PL_op->op_flags & OPf_MOD) {
285 if (PL_op->op_private & OPpLVAL_INTRO)
286 if (!(PL_op->op_private & OPpPAD_STATE))
287 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
288 if (PL_op->op_private & OPpDEREF) {
290 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
300 tryAMAGICunTARGET(iter, 0);
301 PL_last_in_gv = (GV*)(*PL_stack_sp--);
302 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
303 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
304 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
307 XPUSHs((SV*)PL_last_in_gv);
310 PL_last_in_gv = (GV*)(*PL_stack_sp--);
313 return do_readline();
318 dVAR; dSP; tryAMAGICbinSET(eq,0);
319 #ifndef NV_PRESERVES_UV
320 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
322 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
326 #ifdef PERL_PRESERVE_IVUV
329 /* Unless the left argument is integer in range we are going
330 to have to use NV maths. Hence only attempt to coerce the
331 right argument if we know the left is integer. */
334 const bool auvok = SvUOK(TOPm1s);
335 const bool buvok = SvUOK(TOPs);
337 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
338 /* Casting IV to UV before comparison isn't going to matter
339 on 2s complement. On 1s complement or sign&magnitude
340 (if we have any of them) it could to make negative zero
341 differ from normal zero. As I understand it. (Need to
342 check - is negative zero implementation defined behaviour
344 const UV buv = SvUVX(POPs);
345 const UV auv = SvUVX(TOPs);
347 SETs(boolSV(auv == buv));
350 { /* ## Mixed IV,UV ## */
354 /* == is commutative so doesn't matter which is left or right */
356 /* top of stack (b) is the iv */
365 /* As uv is a UV, it's >0, so it cannot be == */
368 /* we know iv is >= 0 */
369 SETs(boolSV((UV)iv == SvUVX(uvp)));
376 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
378 if (Perl_isnan(left) || Perl_isnan(right))
380 SETs(boolSV(left == right));
383 SETs(boolSV(TOPn == value));
392 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
393 DIE(aTHX_ PL_no_modify);
394 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
395 && SvIVX(TOPs) != IV_MAX)
397 SvIV_set(TOPs, SvIVX(TOPs) + 1);
398 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
400 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
412 if (PL_op->op_type == OP_OR)
414 RETURNOP(cLOGOP->op_other);
423 const int op_type = PL_op->op_type;
424 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
428 if (!sv || !SvANY(sv)) {
429 if (op_type == OP_DOR)
431 RETURNOP(cLOGOP->op_other);
433 } else if (op_type == OP_DEFINED) {
435 if (!sv || !SvANY(sv))
438 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
441 switch (SvTYPE(sv)) {
443 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
447 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
451 if (CvROOT(sv) || CvXSUB(sv))
464 if(op_type == OP_DOR)
466 RETURNOP(cLOGOP->op_other);
468 /* assuming OP_DEFINED */
476 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
477 useleft = USE_LEFT(TOPm1s);
478 #ifdef PERL_PRESERVE_IVUV
479 /* We must see if we can perform the addition with integers if possible,
480 as the integer code detects overflow while the NV code doesn't.
481 If either argument hasn't had a numeric conversion yet attempt to get
482 the IV. It's important to do this now, rather than just assuming that
483 it's not IOK as a PV of "9223372036854775806" may not take well to NV
484 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
485 integer in case the second argument is IV=9223372036854775806
486 We can (now) rely on sv_2iv to do the right thing, only setting the
487 public IOK flag if the value in the NV (or PV) slot is truly integer.
489 A side effect is that this also aggressively prefers integer maths over
490 fp maths for integer values.
492 How to detect overflow?
494 C 99 section 6.2.6.1 says
496 The range of nonnegative values of a signed integer type is a subrange
497 of the corresponding unsigned integer type, and the representation of
498 the same value in each type is the same. A computation involving
499 unsigned operands can never overflow, because a result that cannot be
500 represented by the resulting unsigned integer type is reduced modulo
501 the number that is one greater than the largest value that can be
502 represented by the resulting type.
506 which I read as "unsigned ints wrap."
508 signed integer overflow seems to be classed as "exception condition"
510 If an exceptional condition occurs during the evaluation of an
511 expression (that is, if the result is not mathematically defined or not
512 in the range of representable values for its type), the behavior is
515 (6.5, the 5th paragraph)
517 I had assumed that on 2s complement machines signed arithmetic would
518 wrap, hence coded pp_add and pp_subtract on the assumption that
519 everything perl builds on would be happy. After much wailing and
520 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
521 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
522 unsigned code below is actually shorter than the old code. :-)
527 /* Unless the left argument is integer in range we are going to have to
528 use NV maths. Hence only attempt to coerce the right argument if
529 we know the left is integer. */
537 /* left operand is undef, treat as zero. + 0 is identity,
538 Could SETi or SETu right now, but space optimise by not adding
539 lots of code to speed up what is probably a rarish case. */
541 /* Left operand is defined, so is it IV? */
544 if ((auvok = SvUOK(TOPm1s)))
547 register const IV aiv = SvIVX(TOPm1s);
550 auvok = 1; /* Now acting as a sign flag. */
551 } else { /* 2s complement assumption for IV_MIN */
559 bool result_good = 0;
562 bool buvok = SvUOK(TOPs);
567 register const IV biv = SvIVX(TOPs);
574 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
575 else "IV" now, independent of how it came in.
576 if a, b represents positive, A, B negative, a maps to -A etc
581 all UV maths. negate result if A negative.
582 add if signs same, subtract if signs differ. */
588 /* Must get smaller */
594 /* result really should be -(auv-buv). as its negation
595 of true value, need to swap our result flag */
612 if (result <= (UV)IV_MIN)
615 /* result valid, but out of range for IV. */
620 } /* Overflow, drop through to NVs. */
627 /* left operand is undef, treat as zero. + 0.0 is identity. */
631 SETn( value + TOPn );
639 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
640 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
641 const U32 lval = PL_op->op_flags & OPf_MOD;
642 SV** const svp = av_fetch(av, PL_op->op_private, lval);
643 SV *sv = (svp ? *svp : &PL_sv_undef);
645 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
646 sv = sv_mortalcopy(sv);
653 dVAR; dSP; dMARK; dTARGET;
655 do_join(TARG, *MARK, MARK, SP);
666 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
667 * will be enough to hold an OP*.
669 SV* const sv = sv_newmortal();
670 sv_upgrade(sv, SVt_PVLV);
672 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
680 /* Oversized hot code. */
684 dVAR; dSP; dMARK; dORIGMARK;
688 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
690 if (gv && (io = GvIO(gv))
691 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
694 if (MARK == ORIGMARK) {
695 /* If using default handle then we need to make space to
696 * pass object as 1st arg, so move other args up ...
700 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
704 *MARK = SvTIED_obj((SV*)io, mg);
707 call_method("PRINT", G_SCALAR);
715 if (!(io = GvIO(gv))) {
716 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
717 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
719 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
720 report_evil_fh(gv, io, PL_op->op_type);
721 SETERRNO(EBADF,RMS_IFI);
724 else if (!(fp = IoOFP(io))) {
725 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
727 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
728 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
729 report_evil_fh(gv, io, PL_op->op_type);
731 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
736 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
738 if (!do_print(*MARK, fp))
742 if (!do_print(PL_ofs_sv, fp)) { /* $, */
751 if (!do_print(*MARK, fp))
759 if (PL_op->op_type == OP_SAY) {
760 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
763 else if (PL_ors_sv && SvOK(PL_ors_sv))
764 if (!do_print(PL_ors_sv, fp)) /* $\ */
767 if (IoFLAGS(io) & IOf_FLUSH)
768 if (PerlIO_flush(fp) == EOF)
778 XPUSHs(&PL_sv_undef);
789 tryAMAGICunDEREF(to_av);
792 if (SvTYPE(av) != SVt_PVAV)
793 DIE(aTHX_ "Not an ARRAY reference");
794 if (PL_op->op_flags & OPf_REF) {
799 if (GIMME == G_SCALAR)
800 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
804 else if (PL_op->op_flags & OPf_MOD
805 && PL_op->op_private & OPpLVAL_INTRO)
806 Perl_croak(aTHX_ PL_no_localize_ref);
809 if (SvTYPE(sv) == SVt_PVAV) {
811 if (PL_op->op_flags & OPf_REF) {
816 if (GIMME == G_SCALAR)
817 Perl_croak(aTHX_ "Can't return array to lvalue"
826 if (SvTYPE(sv) != SVt_PVGV) {
827 if (SvGMAGICAL(sv)) {
833 if (PL_op->op_flags & OPf_REF ||
834 PL_op->op_private & HINT_STRICT_REFS)
835 DIE(aTHX_ PL_no_usym, "an ARRAY");
836 if (ckWARN(WARN_UNINITIALIZED))
838 if (GIMME == G_ARRAY) {
844 if ((PL_op->op_flags & OPf_SPECIAL) &&
845 !(PL_op->op_flags & OPf_MOD))
847 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
849 && (!is_gv_magical_sv(sv,0)
850 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
856 if (PL_op->op_private & HINT_STRICT_REFS)
857 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
858 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
865 if (PL_op->op_private & OPpLVAL_INTRO)
867 if (PL_op->op_flags & OPf_REF) {
872 if (GIMME == G_SCALAR)
873 Perl_croak(aTHX_ "Can't return array to lvalue"
881 if (GIMME == G_ARRAY) {
882 const I32 maxarg = AvFILL(av) + 1;
883 (void)POPs; /* XXXX May be optimized away? */
885 if (SvRMAGICAL(av)) {
887 for (i=0; i < (U32)maxarg; i++) {
888 SV ** const svp = av_fetch(av, i, FALSE);
889 /* See note in pp_helem, and bug id #27839 */
891 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
896 Copy(AvARRAY(av), SP+1, maxarg, SV*);
900 else if (GIMME_V == G_SCALAR) {
902 const I32 maxarg = AvFILL(av) + 1;
912 const I32 gimme = GIMME_V;
913 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
917 tryAMAGICunDEREF(to_hv);
920 if (SvTYPE(hv) != SVt_PVHV)
921 DIE(aTHX_ "Not a HASH reference");
922 if (PL_op->op_flags & OPf_REF) {
927 if (gimme != G_ARRAY)
928 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
932 else if (PL_op->op_flags & OPf_MOD
933 && PL_op->op_private & OPpLVAL_INTRO)
934 Perl_croak(aTHX_ PL_no_localize_ref);
937 if (SvTYPE(sv) == SVt_PVHV) {
939 if (PL_op->op_flags & OPf_REF) {
944 if (gimme != G_ARRAY)
945 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
953 if (SvTYPE(sv) != SVt_PVGV) {
954 if (SvGMAGICAL(sv)) {
960 if (PL_op->op_flags & OPf_REF ||
961 PL_op->op_private & HINT_STRICT_REFS)
962 DIE(aTHX_ PL_no_usym, "a HASH");
963 if (ckWARN(WARN_UNINITIALIZED))
965 if (gimme == G_ARRAY) {
971 if ((PL_op->op_flags & OPf_SPECIAL) &&
972 !(PL_op->op_flags & OPf_MOD))
974 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
976 && (!is_gv_magical_sv(sv,0)
977 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
983 if (PL_op->op_private & HINT_STRICT_REFS)
984 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
985 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
992 if (PL_op->op_private & OPpLVAL_INTRO)
994 if (PL_op->op_flags & OPf_REF) {
999 if (gimme != G_ARRAY)
1000 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
1007 if (gimme == G_ARRAY) { /* array wanted */
1008 *PL_stack_sp = (SV*)hv;
1011 else if (gimme == G_SCALAR) {
1013 TARG = Perl_hv_scalar(aTHX_ hv);
1020 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1027 if (ckWARN(WARN_MISC)) {
1029 if (relem == firstrelem &&
1031 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1032 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1034 err = "Reference found where even-sized list expected";
1037 err = "Odd number of elements in hash assignment";
1038 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1042 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1043 if (SvMAGICAL(hash)) {
1044 if (SvSMAGICAL(tmpstr))
1056 SV **lastlelem = PL_stack_sp;
1057 SV **lastrelem = PL_stack_base + POPMARK;
1058 SV **firstrelem = PL_stack_base + POPMARK + 1;
1059 SV **firstlelem = lastrelem + 1;
1061 register SV **relem;
1062 register SV **lelem;
1072 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1075 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1078 /* If there's a common identifier on both sides we have to take
1079 * special care that assigning the identifier on the left doesn't
1080 * clobber a value on the right that's used later in the list.
1082 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1083 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1084 for (relem = firstrelem; relem <= lastrelem; relem++) {
1085 if ((sv = *relem)) {
1086 TAINT_NOT; /* Each item is independent */
1087 *relem = sv_mortalcopy(sv);
1091 if (PL_op->op_private & OPpASSIGN_STATE) {
1092 if (SvPADSTALE(*firstlelem))
1093 SvPADSTALE_off(*firstlelem);
1095 RETURN; /* ignore assignment */
1103 while (lelem <= lastlelem) {
1104 TAINT_NOT; /* Each item stands on its own, taintwise. */
1106 switch (SvTYPE(sv)) {
1109 magic = SvMAGICAL(ary) != 0;
1111 av_extend(ary, lastrelem - relem);
1113 while (relem <= lastrelem) { /* gobble up all the rest */
1116 sv = newSVsv(*relem);
1118 didstore = av_store(ary,i++,sv);
1128 case SVt_PVHV: { /* normal hash */
1132 magic = SvMAGICAL(hash) != 0;
1134 firsthashrelem = relem;
1136 while (relem < lastrelem) { /* gobble up all the rest */
1138 sv = *relem ? *relem : &PL_sv_no;
1142 sv_setsv(tmpstr,*relem); /* value */
1143 *(relem++) = tmpstr;
1144 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1145 /* key overwrites an existing entry */
1147 didstore = hv_store_ent(hash,sv,tmpstr,0);
1149 if (SvSMAGICAL(tmpstr))
1156 if (relem == lastrelem) {
1157 do_oddball(hash, relem, firstrelem);
1163 if (SvIMMORTAL(sv)) {
1164 if (relem <= lastrelem)
1168 if (relem <= lastrelem) {
1169 sv_setsv(sv, *relem);
1173 sv_setsv(sv, &PL_sv_undef);
1178 if (PL_delaymagic & ~DM_DELAY) {
1179 if (PL_delaymagic & DM_UID) {
1180 #ifdef HAS_SETRESUID
1181 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1182 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1185 # ifdef HAS_SETREUID
1186 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1187 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1190 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1191 (void)setruid(PL_uid);
1192 PL_delaymagic &= ~DM_RUID;
1194 # endif /* HAS_SETRUID */
1196 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1197 (void)seteuid(PL_euid);
1198 PL_delaymagic &= ~DM_EUID;
1200 # endif /* HAS_SETEUID */
1201 if (PL_delaymagic & DM_UID) {
1202 if (PL_uid != PL_euid)
1203 DIE(aTHX_ "No setreuid available");
1204 (void)PerlProc_setuid(PL_uid);
1206 # endif /* HAS_SETREUID */
1207 #endif /* HAS_SETRESUID */
1208 PL_uid = PerlProc_getuid();
1209 PL_euid = PerlProc_geteuid();
1211 if (PL_delaymagic & DM_GID) {
1212 #ifdef HAS_SETRESGID
1213 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1214 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1217 # ifdef HAS_SETREGID
1218 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1219 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1222 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1223 (void)setrgid(PL_gid);
1224 PL_delaymagic &= ~DM_RGID;
1226 # endif /* HAS_SETRGID */
1228 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1229 (void)setegid(PL_egid);
1230 PL_delaymagic &= ~DM_EGID;
1232 # endif /* HAS_SETEGID */
1233 if (PL_delaymagic & DM_GID) {
1234 if (PL_gid != PL_egid)
1235 DIE(aTHX_ "No setregid available");
1236 (void)PerlProc_setgid(PL_gid);
1238 # endif /* HAS_SETREGID */
1239 #endif /* HAS_SETRESGID */
1240 PL_gid = PerlProc_getgid();
1241 PL_egid = PerlProc_getegid();
1243 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1247 if (gimme == G_VOID)
1248 SP = firstrelem - 1;
1249 else if (gimme == G_SCALAR) {
1252 SETi(lastrelem - firstrelem + 1 - duplicates);
1259 /* Removes from the stack the entries which ended up as
1260 * duplicated keys in the hash (fix for [perl #24380]) */
1261 Move(firsthashrelem + duplicates,
1262 firsthashrelem, duplicates, SV**);
1263 lastrelem -= duplicates;
1268 SP = firstrelem + (lastlelem - firstlelem);
1269 lelem = firstlelem + (relem - firstrelem);
1271 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1279 register PMOP * const pm = cPMOP;
1280 SV * const rv = sv_newmortal();
1281 SV * const sv = newSVrv(rv, "Regexp");
1282 if (pm->op_pmdynflags & PMdf_TAINTED)
1284 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1291 register PMOP *pm = cPMOP;
1293 register const char *t;
1294 register const char *s;
1297 I32 r_flags = REXEC_CHECKED;
1298 const char *truebase; /* Start of string */
1299 register REGEXP *rx = PM_GETRE(pm);
1301 const I32 gimme = GIMME;
1304 const I32 oldsave = PL_savestack_ix;
1305 I32 update_minmatch = 1;
1306 I32 had_zerolen = 0;
1309 if (PL_op->op_flags & OPf_STACKED)
1311 else if (PL_op->op_private & OPpTARGET_MY)
1318 PUTBACK; /* EVAL blocks need stack_sp. */
1319 s = SvPV_const(TARG, len);
1321 DIE(aTHX_ "panic: pp_match");
1323 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1324 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1327 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1329 /* PMdf_USED is set after a ?? matches once */
1330 if (pm->op_pmdynflags & PMdf_USED) {
1332 if (gimme == G_ARRAY)
1337 /* empty pattern special-cased to use last successful pattern if possible */
1338 if (!rx->prelen && PL_curpm) {
1343 if (rx->minlen > (I32)len)
1348 /* XXXX What part of this is needed with true \G-support? */
1349 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1351 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1352 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1353 if (mg && mg->mg_len >= 0) {
1354 if (!(rx->extflags & RXf_GPOS_SEEN))
1355 rx->endp[0] = rx->startp[0] = mg->mg_len;
1356 else if (rx->extflags & RXf_ANCH_GPOS) {
1357 r_flags |= REXEC_IGNOREPOS;
1358 rx->endp[0] = rx->startp[0] = mg->mg_len;
1359 } else if (rx->extflags & RXf_GPOS_FLOAT)
1362 rx->endp[0] = rx->startp[0] = mg->mg_len;
1363 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1364 update_minmatch = 0;
1368 /* remove comment to get faster /g but possibly unsafe $1 vars after a
1369 match. Test for the unsafe vars will fail as well*/
1370 if (( /* !global && */ rx->nparens)
1371 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1372 r_flags |= REXEC_COPY_STR;
1374 r_flags |= REXEC_SCREAM;
1377 if (global && rx->startp[0] != -1) {
1378 t = s = rx->endp[0] + truebase - rx->gofs;
1379 if ((s + rx->minlen) > strend || s < truebase)
1381 if (update_minmatch++)
1382 minmatch = had_zerolen;
1384 if (rx->extflags & RXf_USE_INTUIT &&
1385 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1386 /* FIXME - can PL_bostr be made const char *? */
1387 PL_bostr = (char *)truebase;
1388 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1392 if ( (rx->extflags & RXf_CHECK_ALL)
1394 && ((rx->extflags & RXf_NOSCAN)
1395 || !((rx->extflags & RXf_INTUIT_TAIL)
1396 && (r_flags & REXEC_SCREAM)))
1397 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1400 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1403 if (dynpm->op_pmflags & PMf_ONCE)
1404 dynpm->op_pmdynflags |= PMdf_USED;
1413 RX_MATCH_TAINTED_on(rx);
1414 TAINT_IF(RX_MATCH_TAINTED(rx));
1415 if (gimme == G_ARRAY) {
1416 const I32 nparens = rx->nparens;
1417 I32 i = (global && !nparens) ? 1 : 0;
1419 SPAGAIN; /* EVAL blocks could move the stack. */
1420 EXTEND(SP, nparens + i);
1421 EXTEND_MORTAL(nparens + i);
1422 for (i = !i; i <= nparens; i++) {
1423 PUSHs(sv_newmortal());
1424 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1425 const I32 len = rx->endp[i] - rx->startp[i];
1426 s = rx->startp[i] + truebase;
1427 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1428 len < 0 || len > strend - s)
1429 DIE(aTHX_ "panic: pp_match start/end pointers");
1430 sv_setpvn(*SP, s, len);
1431 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1436 if (dynpm->op_pmflags & PMf_CONTINUE) {
1438 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1439 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441 #ifdef PERL_OLD_COPY_ON_WRITE
1443 sv_force_normal_flags(TARG, 0);
1445 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1446 &PL_vtbl_mglob, NULL, 0);
1448 if (rx->startp[0] != -1) {
1449 mg->mg_len = rx->endp[0];
1450 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1451 mg->mg_flags |= MGf_MINMATCH;
1453 mg->mg_flags &= ~MGf_MINMATCH;
1456 had_zerolen = (rx->startp[0] != -1
1457 && rx->startp[0] + rx->gofs == (UV)rx->endp[0]);
1458 PUTBACK; /* EVAL blocks may use stack */
1459 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1464 LEAVE_SCOPE(oldsave);
1470 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1471 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1475 #ifdef PERL_OLD_COPY_ON_WRITE
1477 sv_force_normal_flags(TARG, 0);
1479 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1480 &PL_vtbl_mglob, NULL, 0);
1482 if (rx->startp[0] != -1) {
1483 mg->mg_len = rx->endp[0];
1484 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1485 mg->mg_flags |= MGf_MINMATCH;
1487 mg->mg_flags &= ~MGf_MINMATCH;
1490 LEAVE_SCOPE(oldsave);
1494 yup: /* Confirmed by INTUIT */
1496 RX_MATCH_TAINTED_on(rx);
1497 TAINT_IF(RX_MATCH_TAINTED(rx));
1499 if (dynpm->op_pmflags & PMf_ONCE)
1500 dynpm->op_pmdynflags |= PMdf_USED;
1501 if (RX_MATCH_COPIED(rx))
1502 Safefree(rx->subbeg);
1503 RX_MATCH_COPIED_off(rx);
1506 /* FIXME - should rx->subbeg be const char *? */
1507 rx->subbeg = (char *) truebase;
1508 rx->startp[0] = s - truebase;
1509 if (RX_MATCH_UTF8(rx)) {
1510 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1511 rx->endp[0] = t - truebase;
1514 rx->endp[0] = s - truebase + rx->minlenret;
1516 rx->sublen = strend - truebase;
1519 if (PL_sawampersand) {
1521 #ifdef PERL_OLD_COPY_ON_WRITE
1522 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1524 PerlIO_printf(Perl_debug_log,
1525 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1526 (int) SvTYPE(TARG), truebase, t,
1529 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1530 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1531 assert (SvPOKp(rx->saved_copy));
1536 rx->subbeg = savepvn(t, strend - t);
1537 #ifdef PERL_OLD_COPY_ON_WRITE
1538 rx->saved_copy = NULL;
1541 rx->sublen = strend - t;
1542 RX_MATCH_COPIED_on(rx);
1543 off = rx->startp[0] = s - t;
1544 rx->endp[0] = off + rx->minlenret;
1546 else { /* startp/endp are used by @- @+. */
1547 rx->startp[0] = s - truebase;
1548 rx->endp[0] = s - truebase + rx->minlenret;
1550 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1551 LEAVE_SCOPE(oldsave);
1556 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1557 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1558 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1563 LEAVE_SCOPE(oldsave);
1564 if (gimme == G_ARRAY)
1570 Perl_do_readline(pTHX)
1572 dVAR; dSP; dTARGETSTACKED;
1577 register IO * const io = GvIO(PL_last_in_gv);
1578 register const I32 type = PL_op->op_type;
1579 const I32 gimme = GIMME_V;
1582 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1585 XPUSHs(SvTIED_obj((SV*)io, mg));
1588 call_method("READLINE", gimme);
1591 if (gimme == G_SCALAR) {
1592 SV* const result = POPs;
1593 SvSetSV_nosteal(TARG, result);
1603 if (IoFLAGS(io) & IOf_ARGV) {
1604 if (IoFLAGS(io) & IOf_START) {
1606 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1607 IoFLAGS(io) &= ~IOf_START;
1608 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1609 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1610 SvSETMAGIC(GvSV(PL_last_in_gv));
1615 fp = nextargv(PL_last_in_gv);
1616 if (!fp) { /* Note: fp != IoIFP(io) */
1617 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1620 else if (type == OP_GLOB)
1621 fp = Perl_start_glob(aTHX_ POPs, io);
1623 else if (type == OP_GLOB)
1625 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1626 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1630 if ((!io || !(IoFLAGS(io) & IOf_START))
1631 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1633 if (type == OP_GLOB)
1634 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1635 "glob failed (can't start child: %s)",
1638 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1640 if (gimme == G_SCALAR) {
1641 /* undef TARG, and push that undefined value */
1642 if (type != OP_RCATLINE) {
1643 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1651 if (gimme == G_SCALAR) {
1653 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1656 if (type == OP_RCATLINE)
1657 SvPV_force_nolen(sv);
1661 else if (isGV_with_GP(sv)) {
1662 SvPV_force_nolen(sv);
1664 SvUPGRADE(sv, SVt_PV);
1665 tmplen = SvLEN(sv); /* remember if already alloced */
1666 if (!tmplen && !SvREADONLY(sv))
1667 Sv_Grow(sv, 80); /* try short-buffering it */
1669 if (type == OP_RCATLINE && SvOK(sv)) {
1671 SvPV_force_nolen(sv);
1677 sv = sv_2mortal(newSV(80));
1681 /* This should not be marked tainted if the fp is marked clean */
1682 #define MAYBE_TAINT_LINE(io, sv) \
1683 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1688 /* delay EOF state for a snarfed empty file */
1689 #define SNARF_EOF(gimme,rs,io,sv) \
1690 (gimme != G_SCALAR || SvCUR(sv) \
1691 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1695 if (!sv_gets(sv, fp, offset)
1697 || SNARF_EOF(gimme, PL_rs, io, sv)
1698 || PerlIO_error(fp)))
1700 PerlIO_clearerr(fp);
1701 if (IoFLAGS(io) & IOf_ARGV) {
1702 fp = nextargv(PL_last_in_gv);
1705 (void)do_close(PL_last_in_gv, FALSE);
1707 else if (type == OP_GLOB) {
1708 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1709 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1710 "glob failed (child exited with status %d%s)",
1711 (int)(STATUS_CURRENT >> 8),
1712 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1715 if (gimme == G_SCALAR) {
1716 if (type != OP_RCATLINE) {
1717 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1723 MAYBE_TAINT_LINE(io, sv);
1726 MAYBE_TAINT_LINE(io, sv);
1728 IoFLAGS(io) |= IOf_NOLINE;
1732 if (type == OP_GLOB) {
1735 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1736 char * const tmps = SvEND(sv) - 1;
1737 if (*tmps == *SvPVX_const(PL_rs)) {
1739 SvCUR_set(sv, SvCUR(sv) - 1);
1742 for (t1 = SvPVX_const(sv); *t1; t1++)
1743 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1744 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1746 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1747 (void)POPs; /* Unmatched wildcard? Chuck it... */
1750 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1751 if (ckWARN(WARN_UTF8)) {
1752 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1753 const STRLEN len = SvCUR(sv) - offset;
1756 if (!is_utf8_string_loc(s, len, &f))
1757 /* Emulate :encoding(utf8) warning in the same case. */
1758 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1759 "utf8 \"\\x%02X\" does not map to Unicode",
1760 f < (U8*)SvEND(sv) ? *f : 0);
1763 if (gimme == G_ARRAY) {
1764 if (SvLEN(sv) - SvCUR(sv) > 20) {
1765 SvPV_shrink_to_cur(sv);
1767 sv = sv_2mortal(newSV(80));
1770 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1771 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1772 const STRLEN new_len
1773 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1774 SvPV_renew(sv, new_len);
1783 register PERL_CONTEXT *cx;
1784 I32 gimme = OP_GIMME(PL_op, -1);
1787 if (cxstack_ix >= 0)
1788 gimme = cxstack[cxstack_ix].blk_gimme;
1796 PUSHBLOCK(cx, CXt_BLOCK, SP);
1806 SV * const keysv = POPs;
1807 HV * const hv = (HV*)POPs;
1808 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1809 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1811 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1814 if (SvTYPE(hv) != SVt_PVHV)
1817 if (PL_op->op_private & OPpLVAL_INTRO) {
1820 /* does the element we're localizing already exist? */
1821 preeminent = /* can we determine whether it exists? */
1823 || mg_find((SV*)hv, PERL_MAGIC_env)
1824 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1825 /* Try to preserve the existenceness of a tied hash
1826 * element by using EXISTS and DELETE if possible.
1827 * Fallback to FETCH and STORE otherwise */
1828 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1829 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1830 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1832 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1834 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1835 svp = he ? &HeVAL(he) : NULL;
1837 if (!svp || *svp == &PL_sv_undef) {
1841 DIE(aTHX_ PL_no_helem_sv, keysv);
1843 lv = sv_newmortal();
1844 sv_upgrade(lv, SVt_PVLV);
1846 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1847 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1848 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1853 if (PL_op->op_private & OPpLVAL_INTRO) {
1854 if (HvNAME_get(hv) && isGV(*svp))
1855 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1859 const char * const key = SvPV_const(keysv, keylen);
1860 SAVEDELETE(hv, savepvn(key,keylen),
1861 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1863 save_helem(hv, keysv, svp);
1866 else if (PL_op->op_private & OPpDEREF)
1867 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1869 sv = (svp ? *svp : &PL_sv_undef);
1870 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1871 * Pushing the magical RHS on to the stack is useless, since
1872 * that magic is soon destined to be misled by the local(),
1873 * and thus the later pp_sassign() will fail to mg_get() the
1874 * old value. This should also cure problems with delayed
1875 * mg_get()s. GSAR 98-07-03 */
1876 if (!lval && SvGMAGICAL(sv))
1877 sv = sv_mortalcopy(sv);
1885 register PERL_CONTEXT *cx;
1890 if (PL_op->op_flags & OPf_SPECIAL) {
1891 cx = &cxstack[cxstack_ix];
1892 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1897 gimme = OP_GIMME(PL_op, -1);
1899 if (cxstack_ix >= 0)
1900 gimme = cxstack[cxstack_ix].blk_gimme;
1906 if (gimme == G_VOID)
1908 else if (gimme == G_SCALAR) {
1912 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1915 *MARK = sv_mortalcopy(TOPs);
1918 *MARK = &PL_sv_undef;
1922 else if (gimme == G_ARRAY) {
1923 /* in case LEAVE wipes old return values */
1925 for (mark = newsp + 1; mark <= SP; mark++) {
1926 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1927 *mark = sv_mortalcopy(*mark);
1928 TAINT_NOT; /* Each item is independent */
1932 PL_curpm = newpm; /* Don't pop $1 et al till now */
1942 register PERL_CONTEXT *cx;
1948 cx = &cxstack[cxstack_ix];
1949 if (CxTYPE(cx) != CXt_LOOP)
1950 DIE(aTHX_ "panic: pp_iter");
1952 itersvp = CxITERVAR(cx);
1953 av = cx->blk_loop.iterary;
1954 if (SvTYPE(av) != SVt_PVAV) {
1955 /* iterate ($min .. $max) */
1956 if (cx->blk_loop.iterlval) {
1957 /* string increment */
1958 register SV* cur = cx->blk_loop.iterlval;
1962 SvPV_const((SV*)av, maxlen) : (const char *)"";
1963 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1964 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1965 /* safe to reuse old SV */
1966 sv_setsv(*itersvp, cur);
1970 /* we need a fresh SV every time so that loop body sees a
1971 * completely new SV for closures/references to work as
1974 *itersvp = newSVsv(cur);
1975 SvREFCNT_dec(oldsv);
1977 if (strEQ(SvPVX_const(cur), max))
1978 sv_setiv(cur, 0); /* terminate next time */
1985 /* integer increment */
1986 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1989 /* don't risk potential race */
1990 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1991 /* safe to reuse old SV */
1992 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1996 /* we need a fresh SV every time so that loop body sees a
1997 * completely new SV for closures/references to work as they
2000 *itersvp = newSViv(cx->blk_loop.iterix++);
2001 SvREFCNT_dec(oldsv);
2007 if (PL_op->op_private & OPpITER_REVERSED) {
2008 /* In reverse, use itermax as the min :-) */
2009 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
2012 if (SvMAGICAL(av) || AvREIFY(av)) {
2013 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
2014 sv = svp ? *svp : NULL;
2017 sv = AvARRAY(av)[--cx->blk_loop.iterix];
2021 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
2025 if (SvMAGICAL(av) || AvREIFY(av)) {
2026 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
2027 sv = svp ? *svp : NULL;
2030 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2034 if (sv && SvIS_FREED(sv)) {
2036 Perl_croak(aTHX_ "Use of freed value in iteration");
2043 if (av != PL_curstack && sv == &PL_sv_undef) {
2044 SV *lv = cx->blk_loop.iterlval;
2045 if (lv && SvREFCNT(lv) > 1) {
2050 SvREFCNT_dec(LvTARG(lv));
2052 lv = cx->blk_loop.iterlval = newSV(0);
2053 sv_upgrade(lv, SVt_PVLV);
2055 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2057 LvTARG(lv) = SvREFCNT_inc_simple(av);
2058 LvTARGOFF(lv) = cx->blk_loop.iterix;
2059 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2064 *itersvp = SvREFCNT_inc_simple_NN(sv);
2065 SvREFCNT_dec(oldsv);
2073 register PMOP *pm = cPMOP;
2088 register REGEXP *rx = PM_GETRE(pm);
2090 int force_on_match = 0;
2091 const I32 oldsave = PL_savestack_ix;
2093 bool doutf8 = FALSE;
2094 #ifdef PERL_OLD_COPY_ON_WRITE
2099 /* known replacement string? */
2100 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2101 if (PL_op->op_flags & OPf_STACKED)
2103 else if (PL_op->op_private & OPpTARGET_MY)
2110 #ifdef PERL_OLD_COPY_ON_WRITE
2111 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2112 because they make integers such as 256 "false". */
2113 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2116 sv_force_normal_flags(TARG,0);
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2123 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2124 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2125 DIE(aTHX_ PL_no_modify);
2128 s = SvPV_mutable(TARG, len);
2129 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2131 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2132 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2137 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2141 DIE(aTHX_ "panic: pp_subst");
2144 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2145 maxiters = 2 * slen + 10; /* We can match twice at each
2146 position, once with zero-length,
2147 second time with non-zero. */
2149 if (!rx->prelen && PL_curpm) {
2153 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2154 || (pm->op_pmflags & PMf_EVAL))
2155 ? REXEC_COPY_STR : 0;
2157 r_flags |= REXEC_SCREAM;
2160 if (rx->extflags & RXf_USE_INTUIT) {
2162 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2166 /* How to do it in subst? */
2167 /* if ( (rx->extflags & RXf_CHECK_ALL)
2169 && ((rx->extflags & RXf_NOSCAN)
2170 || !((rx->extflags & RXf_INTUIT_TAIL)
2171 && (r_flags & REXEC_SCREAM))))
2176 /* only replace once? */
2177 once = !(rpm->op_pmflags & PMf_GLOBAL);
2179 /* known replacement string? */
2181 /* replacement needing upgrading? */
2182 if (DO_UTF8(TARG) && !doutf8) {
2183 nsv = sv_newmortal();
2186 sv_recode_to_utf8(nsv, PL_encoding);
2188 sv_utf8_upgrade(nsv);
2189 c = SvPV_const(nsv, clen);
2193 c = SvPV_const(dstr, clen);
2194 doutf8 = DO_UTF8(dstr);
2202 /* can do inplace substitution? */
2204 #ifdef PERL_OLD_COPY_ON_WRITE
2207 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2208 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2209 && (!doutf8 || SvUTF8(TARG))) {
2210 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2211 r_flags | REXEC_CHECKED))
2215 LEAVE_SCOPE(oldsave);
2218 #ifdef PERL_OLD_COPY_ON_WRITE
2219 if (SvIsCOW(TARG)) {
2220 assert (!force_on_match);
2224 if (force_on_match) {
2226 s = SvPV_force(TARG, len);
2231 SvSCREAM_off(TARG); /* disable possible screamer */
2233 rxtainted |= RX_MATCH_TAINTED(rx);
2234 m = orig + rx->startp[0];
2235 d = orig + rx->endp[0];
2237 if (m - s > strend - d) { /* faster to shorten from end */
2239 Copy(c, m, clen, char);
2244 Move(d, m, i, char);
2248 SvCUR_set(TARG, m - s);
2250 else if ((i = m - s)) { /* faster from front */
2258 Copy(c, m, clen, char);
2263 Copy(c, d, clen, char);
2268 TAINT_IF(rxtainted & 1);
2274 if (iters++ > maxiters)
2275 DIE(aTHX_ "Substitution loop");
2276 rxtainted |= RX_MATCH_TAINTED(rx);
2277 m = rx->startp[0] + orig;
2280 Move(s, d, i, char);
2284 Copy(c, d, clen, char);
2287 s = rx->endp[0] + orig;
2288 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2290 /* don't match same null twice */
2291 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2294 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2295 Move(s, d, i+1, char); /* include the NUL */
2297 TAINT_IF(rxtainted & 1);
2299 PUSHs(sv_2mortal(newSViv((I32)iters)));
2301 (void)SvPOK_only_UTF8(TARG);
2302 TAINT_IF(rxtainted);
2303 if (SvSMAGICAL(TARG)) {
2311 LEAVE_SCOPE(oldsave);
2315 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2316 r_flags | REXEC_CHECKED))
2318 if (force_on_match) {
2320 s = SvPV_force(TARG, len);
2323 #ifdef PERL_OLD_COPY_ON_WRITE
2326 rxtainted |= RX_MATCH_TAINTED(rx);
2327 dstr = newSVpvn(m, s-m);
2333 register PERL_CONTEXT *cx;
2336 RETURNOP(cPMOP->op_pmreplroot);
2338 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2340 if (iters++ > maxiters)
2341 DIE(aTHX_ "Substitution loop");
2342 rxtainted |= RX_MATCH_TAINTED(rx);
2343 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2348 strend = s + (strend - m);
2350 m = rx->startp[0] + orig;
2351 if (doutf8 && !SvUTF8(dstr))
2352 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2354 sv_catpvn(dstr, s, m-s);
2355 s = rx->endp[0] + orig;
2357 sv_catpvn(dstr, c, clen);
2360 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2361 TARG, NULL, r_flags));
2362 if (doutf8 && !DO_UTF8(TARG))
2363 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2365 sv_catpvn(dstr, s, strend - s);
2367 #ifdef PERL_OLD_COPY_ON_WRITE
2368 /* The match may make the string COW. If so, brilliant, because that's
2369 just saved us one malloc, copy and free - the regexp has donated
2370 the old buffer, and we malloc an entirely new one, rather than the
2371 regexp malloc()ing a buffer and copying our original, only for
2372 us to throw it away here during the substitution. */
2373 if (SvIsCOW(TARG)) {
2374 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2380 SvPV_set(TARG, SvPVX(dstr));
2381 SvCUR_set(TARG, SvCUR(dstr));
2382 SvLEN_set(TARG, SvLEN(dstr));
2383 doutf8 |= DO_UTF8(dstr);
2384 SvPV_set(dstr, NULL);
2386 TAINT_IF(rxtainted & 1);
2388 PUSHs(sv_2mortal(newSViv((I32)iters)));
2390 (void)SvPOK_only(TARG);
2393 TAINT_IF(rxtainted);
2396 LEAVE_SCOPE(oldsave);
2405 LEAVE_SCOPE(oldsave);
2414 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2415 ++*PL_markstack_ptr;
2416 LEAVE; /* exit inner scope */
2419 if (PL_stack_base + *PL_markstack_ptr > SP) {
2421 const I32 gimme = GIMME_V;
2423 LEAVE; /* exit outer scope */
2424 (void)POPMARK; /* pop src */
2425 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2426 (void)POPMARK; /* pop dst */
2427 SP = PL_stack_base + POPMARK; /* pop original mark */
2428 if (gimme == G_SCALAR) {
2429 if (PL_op->op_private & OPpGREP_LEX) {
2430 SV* const sv = sv_newmortal();
2431 sv_setiv(sv, items);
2439 else if (gimme == G_ARRAY)
2446 ENTER; /* enter inner scope */
2449 src = PL_stack_base[*PL_markstack_ptr];
2451 if (PL_op->op_private & OPpGREP_LEX)
2452 PAD_SVl(PL_op->op_targ) = src;
2456 RETURNOP(cLOGOP->op_other);
2467 register PERL_CONTEXT *cx;
2470 if (CxMULTICALL(&cxstack[cxstack_ix]))
2474 cxstack_ix++; /* temporarily protect top context */
2477 if (gimme == G_SCALAR) {
2480 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2482 *MARK = SvREFCNT_inc(TOPs);
2487 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2489 *MARK = sv_mortalcopy(sv);
2494 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2498 *MARK = &PL_sv_undef;
2502 else if (gimme == G_ARRAY) {
2503 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2504 if (!SvTEMP(*MARK)) {
2505 *MARK = sv_mortalcopy(*MARK);
2506 TAINT_NOT; /* Each item is independent */
2514 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2515 PL_curpm = newpm; /* ... and pop $1 et al */
2518 return cx->blk_sub.retop;
2521 /* This duplicates the above code because the above code must not
2522 * get any slower by more conditions */
2530 register PERL_CONTEXT *cx;
2533 if (CxMULTICALL(&cxstack[cxstack_ix]))
2537 cxstack_ix++; /* temporarily protect top context */
2541 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2542 /* We are an argument to a function or grep().
2543 * This kind of lvalueness was legal before lvalue
2544 * subroutines too, so be backward compatible:
2545 * cannot report errors. */
2547 /* Scalar context *is* possible, on the LHS of -> only,
2548 * as in f()->meth(). But this is not an lvalue. */
2549 if (gimme == G_SCALAR)
2551 if (gimme == G_ARRAY) {
2552 if (!CvLVALUE(cx->blk_sub.cv))
2553 goto temporise_array;
2554 EXTEND_MORTAL(SP - newsp);
2555 for (mark = newsp + 1; mark <= SP; mark++) {
2558 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2559 *mark = sv_mortalcopy(*mark);
2561 /* Can be a localized value subject to deletion. */
2562 PL_tmps_stack[++PL_tmps_ix] = *mark;
2563 SvREFCNT_inc_void(*mark);
2568 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2569 /* Here we go for robustness, not for speed, so we change all
2570 * the refcounts so the caller gets a live guy. Cannot set
2571 * TEMP, so sv_2mortal is out of question. */
2572 if (!CvLVALUE(cx->blk_sub.cv)) {
2578 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2580 if (gimme == G_SCALAR) {
2584 /* Temporaries are bad unless they happen to be elements
2585 * of a tied hash or array */
2586 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2587 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2593 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2594 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2595 : "a readonly value" : "a temporary");
2597 else { /* Can be a localized value
2598 * subject to deletion. */
2599 PL_tmps_stack[++PL_tmps_ix] = *mark;
2600 SvREFCNT_inc_void(*mark);
2603 else { /* Should not happen? */
2609 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2610 (MARK > SP ? "Empty array" : "Array"));
2614 else if (gimme == G_ARRAY) {
2615 EXTEND_MORTAL(SP - newsp);
2616 for (mark = newsp + 1; mark <= SP; mark++) {
2617 if (*mark != &PL_sv_undef
2618 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2619 /* Might be flattened array after $#array = */
2626 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2627 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2630 /* Can be a localized value subject to deletion. */
2631 PL_tmps_stack[++PL_tmps_ix] = *mark;
2632 SvREFCNT_inc_void(*mark);
2638 if (gimme == G_SCALAR) {
2642 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2644 *MARK = SvREFCNT_inc(TOPs);
2649 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2651 *MARK = sv_mortalcopy(sv);
2656 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2660 *MARK = &PL_sv_undef;
2664 else if (gimme == G_ARRAY) {
2666 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2667 if (!SvTEMP(*MARK)) {
2668 *MARK = sv_mortalcopy(*MARK);
2669 TAINT_NOT; /* Each item is independent */
2678 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2679 PL_curpm = newpm; /* ... and pop $1 et al */
2682 return cx->blk_sub.retop;
2687 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2690 SV * const dbsv = GvSVn(PL_DBsub);
2693 if (!PERLDB_SUB_NN) {
2694 GV * const gv = CvGV(cv);
2696 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2697 || strEQ(GvNAME(gv), "END")
2698 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2699 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2700 /* Use GV from the stack as a fallback. */
2701 /* GV is potentially non-unique, or contain different CV. */
2702 SV * const tmp = newRV((SV*)cv);
2703 sv_setsv(dbsv, tmp);
2707 gv_efullname3(dbsv, gv, NULL);
2711 const int type = SvTYPE(dbsv);
2712 if (type < SVt_PVIV && type != SVt_IV)
2713 sv_upgrade(dbsv, SVt_PVIV);
2714 (void)SvIOK_on(dbsv);
2715 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2719 PL_curcopdb = PL_curcop;
2720 cv = GvCV(PL_DBsub);
2729 register PERL_CONTEXT *cx;
2731 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2734 DIE(aTHX_ "Not a CODE reference");
2735 switch (SvTYPE(sv)) {
2736 /* This is overwhelming the most common case: */
2738 if (!(cv = GvCVu((GV*)sv))) {
2740 cv = sv_2cv(sv, &stash, &gv, 0);
2751 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2753 SP = PL_stack_base + POPMARK;
2756 if (SvGMAGICAL(sv)) {
2760 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2763 sym = SvPV_nolen_const(sv);
2766 DIE(aTHX_ PL_no_usym, "a subroutine");
2767 if (PL_op->op_private & HINT_STRICT_REFS)
2768 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2769 cv = get_cv(sym, TRUE);
2774 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2775 tryAMAGICunDEREF(to_cv);
2778 if (SvTYPE(cv) == SVt_PVCV)
2783 DIE(aTHX_ "Not a CODE reference");
2784 /* This is the second most common case: */
2794 if (!CvROOT(cv) && !CvXSUB(cv)) {
2798 /* anonymous or undef'd function leaves us no recourse */
2799 if (CvANON(cv) || !(gv = CvGV(cv)))
2800 DIE(aTHX_ "Undefined subroutine called");
2802 /* autoloaded stub? */
2803 if (cv != GvCV(gv)) {
2806 /* should call AUTOLOAD now? */
2809 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2816 sub_name = sv_newmortal();
2817 gv_efullname3(sub_name, gv, NULL);
2818 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2822 DIE(aTHX_ "Not a CODE reference");
2827 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2828 if (CvASSERTION(cv) && PL_DBassertion)
2829 sv_setiv(PL_DBassertion, 1);
2831 cv = get_db_sub(&sv, cv);
2832 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2833 DIE(aTHX_ "No DB::sub routine defined");
2836 if (!(CvISXSUB(cv))) {
2837 /* This path taken at least 75% of the time */
2839 register I32 items = SP - MARK;
2840 AV* const padlist = CvPADLIST(cv);
2841 PUSHBLOCK(cx, CXt_SUB, MARK);
2843 cx->blk_sub.retop = PL_op->op_next;
2845 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2846 * that eval'' ops within this sub know the correct lexical space.
2847 * Owing the speed considerations, we choose instead to search for
2848 * the cv using find_runcv() when calling doeval().
2850 if (CvDEPTH(cv) >= 2) {
2851 PERL_STACK_OVERFLOW_CHECK();
2852 pad_push(padlist, CvDEPTH(cv));
2855 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2857 AV* const av = (AV*)PAD_SVl(0);
2859 /* @_ is normally not REAL--this should only ever
2860 * happen when DB::sub() calls things that modify @_ */
2865 cx->blk_sub.savearray = GvAV(PL_defgv);
2866 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2867 CX_CURPAD_SAVE(cx->blk_sub);
2868 cx->blk_sub.argarray = av;
2871 if (items > AvMAX(av) + 1) {
2872 SV **ary = AvALLOC(av);
2873 if (AvARRAY(av) != ary) {
2874 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2877 if (items > AvMAX(av) + 1) {
2878 AvMAX(av) = items - 1;
2879 Renew(ary,items,SV*);
2884 Copy(MARK,AvARRAY(av),items,SV*);
2885 AvFILLp(av) = items - 1;
2893 /* warning must come *after* we fully set up the context
2894 * stuff so that __WARN__ handlers can safely dounwind()
2897 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2898 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2899 sub_crush_depth(cv);
2901 DEBUG_S(PerlIO_printf(Perl_debug_log,
2902 "%p entersub returning %p\n", thr, CvSTART(cv)));
2904 RETURNOP(CvSTART(cv));
2907 I32 markix = TOPMARK;
2912 /* Need to copy @_ to stack. Alternative may be to
2913 * switch stack to @_, and copy return values
2914 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2915 AV * const av = GvAV(PL_defgv);
2916 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2919 /* Mark is at the end of the stack. */
2921 Copy(AvARRAY(av), SP + 1, items, SV*);
2926 /* We assume first XSUB in &DB::sub is the called one. */
2928 SAVEVPTR(PL_curcop);
2929 PL_curcop = PL_curcopdb;
2932 /* Do we need to open block here? XXXX */
2933 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2934 (void)(*CvXSUB(cv))(aTHX_ cv);
2936 /* Enforce some sanity in scalar context. */
2937 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2938 if (markix > PL_stack_sp - PL_stack_base)
2939 *(PL_stack_base + markix) = &PL_sv_undef;
2941 *(PL_stack_base + markix) = *PL_stack_sp;
2942 PL_stack_sp = PL_stack_base + markix;
2950 Perl_sub_crush_depth(pTHX_ CV *cv)
2953 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2955 SV* const tmpstr = sv_newmortal();
2956 gv_efullname3(tmpstr, CvGV(cv), NULL);
2957 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2966 SV* const elemsv = POPs;
2967 IV elem = SvIV(elemsv);
2968 AV* const av = (AV*)POPs;
2969 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2970 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2973 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2974 Perl_warner(aTHX_ packWARN(WARN_MISC),
2975 "Use of reference \"%"SVf"\" as array index",
2978 elem -= CopARYBASE_get(PL_curcop);
2979 if (SvTYPE(av) != SVt_PVAV)
2981 svp = av_fetch(av, elem, lval && !defer);
2983 #ifdef PERL_MALLOC_WRAP
2984 if (SvUOK(elemsv)) {
2985 const UV uv = SvUV(elemsv);
2986 elem = uv > IV_MAX ? IV_MAX : uv;
2988 else if (SvNOK(elemsv))
2989 elem = (IV)SvNV(elemsv);
2991 static const char oom_array_extend[] =
2992 "Out of memory during array extend"; /* Duplicated in av.c */
2993 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2996 if (!svp || *svp == &PL_sv_undef) {
2999 DIE(aTHX_ PL_no_aelem, elem);
3000 lv = sv_newmortal();
3001 sv_upgrade(lv, SVt_PVLV);
3003 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3004 LvTARG(lv) = SvREFCNT_inc_simple(av);
3005 LvTARGOFF(lv) = elem;
3010 if (PL_op->op_private & OPpLVAL_INTRO)
3011 save_aelem(av, elem, svp);
3012 else if (PL_op->op_private & OPpDEREF)
3013 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3015 sv = (svp ? *svp : &PL_sv_undef);
3016 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
3017 sv = sv_mortalcopy(sv);
3023 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3028 Perl_croak(aTHX_ PL_no_modify);
3029 if (SvTYPE(sv) < SVt_RV)
3030 sv_upgrade(sv, SVt_RV);
3031 else if (SvTYPE(sv) >= SVt_PV) {
3038 SvRV_set(sv, newSV(0));
3041 SvRV_set(sv, (SV*)newAV());
3044 SvRV_set(sv, (SV*)newHV());
3055 SV* const sv = TOPs;
3058 SV* const rsv = SvRV(sv);
3059 if (SvTYPE(rsv) == SVt_PVCV) {
3065 SETs(method_common(sv, NULL));
3072 SV* const sv = cSVOP_sv;
3073 U32 hash = SvSHARED_HASH(sv);
3075 XPUSHs(method_common(sv, &hash));
3080 S_method_common(pTHX_ SV* meth, U32* hashp)
3087 const char* packname = NULL;
3090 const char * const name = SvPV_const(meth, namelen);
3091 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3094 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3102 /* this isn't a reference */
3103 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3104 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3106 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3113 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3114 !(ob=(SV*)GvIO(iogv)))
3116 /* this isn't the name of a filehandle either */
3118 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3119 ? !isIDFIRST_utf8((U8*)packname)
3120 : !isIDFIRST(*packname)
3123 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3124 SvOK(sv) ? "without a package or object reference"
3125 : "on an undefined value");
3127 /* assume it's a package name */
3128 stash = gv_stashpvn(packname, packlen, FALSE);
3132 SV* const ref = newSViv(PTR2IV(stash));
3133 hv_store(PL_stashcache, packname, packlen, ref, 0);
3137 /* it _is_ a filehandle name -- replace with a reference */
3138 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3141 /* if we got here, ob should be a reference or a glob */
3142 if (!ob || !(SvOBJECT(ob)
3143 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3146 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3150 stash = SvSTASH(ob);
3153 /* NOTE: stash may be null, hope hv_fetch_ent and
3154 gv_fetchmethod can cope (it seems they can) */
3156 /* shortcut for simple names */
3158 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3160 gv = (GV*)HeVAL(he);
3161 if (isGV(gv) && GvCV(gv) &&
3162 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3163 return (SV*)GvCV(gv);
3167 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3170 /* This code tries to figure out just what went wrong with
3171 gv_fetchmethod. It therefore needs to duplicate a lot of
3172 the internals of that function. We can't move it inside
3173 Perl_gv_fetchmethod_autoload(), however, since that would
3174 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3177 const char* leaf = name;
3178 const char* sep = NULL;
3181 for (p = name; *p; p++) {
3183 sep = p, leaf = p + 1;
3184 else if (*p == ':' && *(p + 1) == ':')
3185 sep = p, leaf = p + 2;
3187 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3188 /* the method name is unqualified or starts with SUPER:: */
3189 bool need_strlen = 1;
3191 packname = CopSTASHPV(PL_curcop);
3194 HEK * const packhek = HvNAME_HEK(stash);
3196 packname = HEK_KEY(packhek);
3197 packlen = HEK_LEN(packhek);
3207 "Can't use anonymous symbol table for method lookup");
3209 else if (need_strlen)
3210 packlen = strlen(packname);
3214 /* the method name is qualified */
3216 packlen = sep - name;
3219 /* we're relying on gv_fetchmethod not autovivifying the stash */
3220 if (gv_stashpvn(packname, packlen, FALSE)) {
3222 "Can't locate object method \"%s\" via package \"%.*s\"",
3223 leaf, (int)packlen, packname);
3227 "Can't locate object method \"%s\" via package \"%.*s\""
3228 " (perhaps you forgot to load \"%.*s\"?)",
3229 leaf, (int)packlen, packname, (int)packlen, packname);
3232 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3237 * c-indentation-style: bsd
3239 * indent-tabs-mode: t
3242 * ex: set ts=8 sts=4 sw=4 noet: