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);
1089 while (lelem <= lastlelem) {
1090 TAINT_NOT; /* Each item stands on its own, taintwise. */
1092 switch (SvTYPE(sv)) {
1095 magic = SvMAGICAL(ary) != 0;
1097 av_extend(ary, lastrelem - relem);
1099 while (relem <= lastrelem) { /* gobble up all the rest */
1102 sv = newSVsv(*relem);
1104 didstore = av_store(ary,i++,sv);
1114 case SVt_PVHV: { /* normal hash */
1118 magic = SvMAGICAL(hash) != 0;
1120 firsthashrelem = relem;
1122 while (relem < lastrelem) { /* gobble up all the rest */
1124 sv = *relem ? *relem : &PL_sv_no;
1128 sv_setsv(tmpstr,*relem); /* value */
1129 *(relem++) = tmpstr;
1130 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1131 /* key overwrites an existing entry */
1133 didstore = hv_store_ent(hash,sv,tmpstr,0);
1135 if (SvSMAGICAL(tmpstr))
1142 if (relem == lastrelem) {
1143 do_oddball(hash, relem, firstrelem);
1149 if (SvIMMORTAL(sv)) {
1150 if (relem <= lastrelem)
1154 if (relem <= lastrelem) {
1155 sv_setsv(sv, *relem);
1159 sv_setsv(sv, &PL_sv_undef);
1164 if (PL_delaymagic & ~DM_DELAY) {
1165 if (PL_delaymagic & DM_UID) {
1166 #ifdef HAS_SETRESUID
1167 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1168 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1171 # ifdef HAS_SETREUID
1172 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1173 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1176 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1177 (void)setruid(PL_uid);
1178 PL_delaymagic &= ~DM_RUID;
1180 # endif /* HAS_SETRUID */
1182 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1183 (void)seteuid(PL_euid);
1184 PL_delaymagic &= ~DM_EUID;
1186 # endif /* HAS_SETEUID */
1187 if (PL_delaymagic & DM_UID) {
1188 if (PL_uid != PL_euid)
1189 DIE(aTHX_ "No setreuid available");
1190 (void)PerlProc_setuid(PL_uid);
1192 # endif /* HAS_SETREUID */
1193 #endif /* HAS_SETRESUID */
1194 PL_uid = PerlProc_getuid();
1195 PL_euid = PerlProc_geteuid();
1197 if (PL_delaymagic & DM_GID) {
1198 #ifdef HAS_SETRESGID
1199 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1200 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1203 # ifdef HAS_SETREGID
1204 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1205 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1208 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1209 (void)setrgid(PL_gid);
1210 PL_delaymagic &= ~DM_RGID;
1212 # endif /* HAS_SETRGID */
1214 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1215 (void)setegid(PL_egid);
1216 PL_delaymagic &= ~DM_EGID;
1218 # endif /* HAS_SETEGID */
1219 if (PL_delaymagic & DM_GID) {
1220 if (PL_gid != PL_egid)
1221 DIE(aTHX_ "No setregid available");
1222 (void)PerlProc_setgid(PL_gid);
1224 # endif /* HAS_SETREGID */
1225 #endif /* HAS_SETRESGID */
1226 PL_gid = PerlProc_getgid();
1227 PL_egid = PerlProc_getegid();
1229 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1233 if (gimme == G_VOID)
1234 SP = firstrelem - 1;
1235 else if (gimme == G_SCALAR) {
1238 SETi(lastrelem - firstrelem + 1 - duplicates);
1245 /* Removes from the stack the entries which ended up as
1246 * duplicated keys in the hash (fix for [perl #24380]) */
1247 Move(firsthashrelem + duplicates,
1248 firsthashrelem, duplicates, SV**);
1249 lastrelem -= duplicates;
1254 SP = firstrelem + (lastlelem - firstlelem);
1255 lelem = firstlelem + (relem - firstrelem);
1257 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1265 register PMOP * const pm = cPMOP;
1266 SV * const rv = sv_newmortal();
1267 SV * const sv = newSVrv(rv, "Regexp");
1268 if (pm->op_pmdynflags & PMdf_TAINTED)
1270 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1277 register PMOP *pm = cPMOP;
1279 register const char *t;
1280 register const char *s;
1283 I32 r_flags = REXEC_CHECKED;
1284 const char *truebase; /* Start of string */
1285 register REGEXP *rx = PM_GETRE(pm);
1287 const I32 gimme = GIMME;
1290 const I32 oldsave = PL_savestack_ix;
1291 I32 update_minmatch = 1;
1292 I32 had_zerolen = 0;
1294 if (PL_op->op_flags & OPf_STACKED)
1296 else if (PL_op->op_private & OPpTARGET_MY)
1303 PUTBACK; /* EVAL blocks need stack_sp. */
1304 s = SvPV_const(TARG, len);
1306 DIE(aTHX_ "panic: pp_match");
1308 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1309 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1312 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1314 /* PMdf_USED is set after a ?? matches once */
1315 if (pm->op_pmdynflags & PMdf_USED) {
1317 if (gimme == G_ARRAY)
1322 /* empty pattern special-cased to use last successful pattern if possible */
1323 if (!rx->prelen && PL_curpm) {
1328 if (rx->minlen > (I32)len)
1333 /* XXXX What part of this is needed with true \G-support? */
1334 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1336 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1337 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1338 if (mg && mg->mg_len >= 0) {
1339 if (!(rx->reganch & ROPT_GPOS_SEEN))
1340 rx->endp[0] = rx->startp[0] = mg->mg_len;
1341 else if (rx->reganch & ROPT_ANCH_GPOS) {
1342 r_flags |= REXEC_IGNOREPOS;
1343 rx->endp[0] = rx->startp[0] = mg->mg_len;
1345 minmatch = (mg->mg_flags & MGf_MINMATCH);
1346 update_minmatch = 0;
1350 if ((!global && rx->nparens)
1351 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1352 r_flags |= REXEC_COPY_STR;
1354 r_flags |= REXEC_SCREAM;
1357 if (global && rx->startp[0] != -1) {
1358 t = s = rx->endp[0] + truebase;
1359 if ((s + rx->minlen) > strend)
1361 if (update_minmatch++)
1362 minmatch = had_zerolen;
1364 if (rx->reganch & RE_USE_INTUIT &&
1365 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1366 /* FIXME - can PL_bostr be made const char *? */
1367 PL_bostr = (char *)truebase;
1368 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1372 if ( (rx->reganch & ROPT_CHECK_ALL)
1374 && ((rx->reganch & ROPT_NOSCAN)
1375 || !((rx->reganch & RE_INTUIT_TAIL)
1376 && (r_flags & REXEC_SCREAM)))
1377 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1380 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1383 if (dynpm->op_pmflags & PMf_ONCE)
1384 dynpm->op_pmdynflags |= PMdf_USED;
1393 RX_MATCH_TAINTED_on(rx);
1394 TAINT_IF(RX_MATCH_TAINTED(rx));
1395 if (gimme == G_ARRAY) {
1396 const I32 nparens = rx->nparens;
1397 I32 i = (global && !nparens) ? 1 : 0;
1399 SPAGAIN; /* EVAL blocks could move the stack. */
1400 EXTEND(SP, nparens + i);
1401 EXTEND_MORTAL(nparens + i);
1402 for (i = !i; i <= nparens; i++) {
1403 PUSHs(sv_newmortal());
1404 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1405 const I32 len = rx->endp[i] - rx->startp[i];
1406 s = rx->startp[i] + truebase;
1407 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1408 len < 0 || len > strend - s)
1409 DIE(aTHX_ "panic: pp_match start/end pointers");
1410 sv_setpvn(*SP, s, len);
1411 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1416 if (dynpm->op_pmflags & PMf_CONTINUE) {
1418 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1419 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1421 #ifdef PERL_OLD_COPY_ON_WRITE
1423 sv_force_normal_flags(TARG, 0);
1425 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1426 &PL_vtbl_mglob, NULL, 0);
1428 if (rx->startp[0] != -1) {
1429 mg->mg_len = rx->endp[0];
1430 if (rx->startp[0] == rx->endp[0])
1431 mg->mg_flags |= MGf_MINMATCH;
1433 mg->mg_flags &= ~MGf_MINMATCH;
1436 had_zerolen = (rx->startp[0] != -1
1437 && rx->startp[0] == rx->endp[0]);
1438 PUTBACK; /* EVAL blocks may use stack */
1439 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1444 LEAVE_SCOPE(oldsave);
1450 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1451 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1455 #ifdef PERL_OLD_COPY_ON_WRITE
1457 sv_force_normal_flags(TARG, 0);
1459 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1460 &PL_vtbl_mglob, NULL, 0);
1462 if (rx->startp[0] != -1) {
1463 mg->mg_len = rx->endp[0];
1464 if (rx->startp[0] == rx->endp[0])
1465 mg->mg_flags |= MGf_MINMATCH;
1467 mg->mg_flags &= ~MGf_MINMATCH;
1470 LEAVE_SCOPE(oldsave);
1474 yup: /* Confirmed by INTUIT */
1476 RX_MATCH_TAINTED_on(rx);
1477 TAINT_IF(RX_MATCH_TAINTED(rx));
1479 if (dynpm->op_pmflags & PMf_ONCE)
1480 dynpm->op_pmdynflags |= PMdf_USED;
1481 if (RX_MATCH_COPIED(rx))
1482 Safefree(rx->subbeg);
1483 RX_MATCH_COPIED_off(rx);
1486 /* FIXME - should rx->subbeg be const char *? */
1487 rx->subbeg = (char *) truebase;
1488 rx->startp[0] = s - truebase;
1489 if (RX_MATCH_UTF8(rx)) {
1490 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1491 rx->endp[0] = t - truebase;
1494 rx->endp[0] = s - truebase + rx->minlen;
1496 rx->sublen = strend - truebase;
1499 if (PL_sawampersand) {
1501 #ifdef PERL_OLD_COPY_ON_WRITE
1502 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1504 PerlIO_printf(Perl_debug_log,
1505 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1506 (int) SvTYPE(TARG), truebase, t,
1509 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1510 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1511 assert (SvPOKp(rx->saved_copy));
1516 rx->subbeg = savepvn(t, strend - t);
1517 #ifdef PERL_OLD_COPY_ON_WRITE
1518 rx->saved_copy = NULL;
1521 rx->sublen = strend - t;
1522 RX_MATCH_COPIED_on(rx);
1523 off = rx->startp[0] = s - t;
1524 rx->endp[0] = off + rx->minlen;
1526 else { /* startp/endp are used by @- @+. */
1527 rx->startp[0] = s - truebase;
1528 rx->endp[0] = s - truebase + rx->minlen;
1530 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1531 LEAVE_SCOPE(oldsave);
1536 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1537 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1538 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1543 LEAVE_SCOPE(oldsave);
1544 if (gimme == G_ARRAY)
1550 Perl_do_readline(pTHX)
1552 dVAR; dSP; dTARGETSTACKED;
1557 register IO * const io = GvIO(PL_last_in_gv);
1558 register const I32 type = PL_op->op_type;
1559 const I32 gimme = GIMME_V;
1562 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1565 XPUSHs(SvTIED_obj((SV*)io, mg));
1568 call_method("READLINE", gimme);
1571 if (gimme == G_SCALAR) {
1572 SV* const result = POPs;
1573 SvSetSV_nosteal(TARG, result);
1583 if (IoFLAGS(io) & IOf_ARGV) {
1584 if (IoFLAGS(io) & IOf_START) {
1586 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1587 IoFLAGS(io) &= ~IOf_START;
1588 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1589 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1590 SvSETMAGIC(GvSV(PL_last_in_gv));
1595 fp = nextargv(PL_last_in_gv);
1596 if (!fp) { /* Note: fp != IoIFP(io) */
1597 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1600 else if (type == OP_GLOB)
1601 fp = Perl_start_glob(aTHX_ POPs, io);
1603 else if (type == OP_GLOB)
1605 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1606 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1610 if ((!io || !(IoFLAGS(io) & IOf_START))
1611 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1613 if (type == OP_GLOB)
1614 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1615 "glob failed (can't start child: %s)",
1618 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1620 if (gimme == G_SCALAR) {
1621 /* undef TARG, and push that undefined value */
1622 if (type != OP_RCATLINE) {
1623 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1631 if (gimme == G_SCALAR) {
1635 else if (isGV_with_GP(sv)) {
1636 SvPV_force_nolen(sv);
1638 SvUPGRADE(sv, SVt_PV);
1639 tmplen = SvLEN(sv); /* remember if already alloced */
1640 if (!tmplen && !SvREADONLY(sv))
1641 Sv_Grow(sv, 80); /* try short-buffering it */
1643 if (type == OP_RCATLINE && SvOK(sv)) {
1645 SvPV_force_nolen(sv);
1651 sv = sv_2mortal(newSV(80));
1655 /* This should not be marked tainted if the fp is marked clean */
1656 #define MAYBE_TAINT_LINE(io, sv) \
1657 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1662 /* delay EOF state for a snarfed empty file */
1663 #define SNARF_EOF(gimme,rs,io,sv) \
1664 (gimme != G_SCALAR || SvCUR(sv) \
1665 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1669 if (!sv_gets(sv, fp, offset)
1671 || SNARF_EOF(gimme, PL_rs, io, sv)
1672 || PerlIO_error(fp)))
1674 PerlIO_clearerr(fp);
1675 if (IoFLAGS(io) & IOf_ARGV) {
1676 fp = nextargv(PL_last_in_gv);
1679 (void)do_close(PL_last_in_gv, FALSE);
1681 else if (type == OP_GLOB) {
1682 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1683 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1684 "glob failed (child exited with status %d%s)",
1685 (int)(STATUS_CURRENT >> 8),
1686 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1689 if (gimme == G_SCALAR) {
1690 if (type != OP_RCATLINE) {
1691 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1697 MAYBE_TAINT_LINE(io, sv);
1700 MAYBE_TAINT_LINE(io, sv);
1702 IoFLAGS(io) |= IOf_NOLINE;
1706 if (type == OP_GLOB) {
1709 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1710 char * const tmps = SvEND(sv) - 1;
1711 if (*tmps == *SvPVX_const(PL_rs)) {
1713 SvCUR_set(sv, SvCUR(sv) - 1);
1716 for (t1 = SvPVX_const(sv); *t1; t1++)
1717 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1718 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1720 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1721 (void)POPs; /* Unmatched wildcard? Chuck it... */
1724 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1725 if (ckWARN(WARN_UTF8)) {
1726 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1727 const STRLEN len = SvCUR(sv) - offset;
1730 if (!is_utf8_string_loc(s, len, &f))
1731 /* Emulate :encoding(utf8) warning in the same case. */
1732 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1733 "utf8 \"\\x%02X\" does not map to Unicode",
1734 f < (U8*)SvEND(sv) ? *f : 0);
1737 if (gimme == G_ARRAY) {
1738 if (SvLEN(sv) - SvCUR(sv) > 20) {
1739 SvPV_shrink_to_cur(sv);
1741 sv = sv_2mortal(newSV(80));
1744 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1745 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1746 const STRLEN new_len
1747 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1748 SvPV_renew(sv, new_len);
1757 register PERL_CONTEXT *cx;
1758 I32 gimme = OP_GIMME(PL_op, -1);
1761 if (cxstack_ix >= 0)
1762 gimme = cxstack[cxstack_ix].blk_gimme;
1770 PUSHBLOCK(cx, CXt_BLOCK, SP);
1780 SV * const keysv = POPs;
1781 HV * const hv = (HV*)POPs;
1782 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1783 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1785 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1788 if (SvTYPE(hv) != SVt_PVHV)
1791 if (PL_op->op_private & OPpLVAL_INTRO) {
1794 /* does the element we're localizing already exist? */
1795 preeminent = /* can we determine whether it exists? */
1797 || mg_find((SV*)hv, PERL_MAGIC_env)
1798 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1799 /* Try to preserve the existenceness of a tied hash
1800 * element by using EXISTS and DELETE if possible.
1801 * Fallback to FETCH and STORE otherwise */
1802 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1803 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1804 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1806 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1808 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1809 svp = he ? &HeVAL(he) : NULL;
1811 if (!svp || *svp == &PL_sv_undef) {
1815 DIE(aTHX_ PL_no_helem_sv, keysv);
1817 lv = sv_newmortal();
1818 sv_upgrade(lv, SVt_PVLV);
1820 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1821 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1822 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1827 if (PL_op->op_private & OPpLVAL_INTRO) {
1828 if (HvNAME_get(hv) && isGV(*svp))
1829 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1833 const char * const key = SvPV_const(keysv, keylen);
1834 SAVEDELETE(hv, savepvn(key,keylen),
1835 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1837 save_helem(hv, keysv, svp);
1840 else if (PL_op->op_private & OPpDEREF)
1841 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1843 sv = (svp ? *svp : &PL_sv_undef);
1844 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1845 * Pushing the magical RHS on to the stack is useless, since
1846 * that magic is soon destined to be misled by the local(),
1847 * and thus the later pp_sassign() will fail to mg_get() the
1848 * old value. This should also cure problems with delayed
1849 * mg_get()s. GSAR 98-07-03 */
1850 if (!lval && SvGMAGICAL(sv))
1851 sv = sv_mortalcopy(sv);
1859 register PERL_CONTEXT *cx;
1864 if (PL_op->op_flags & OPf_SPECIAL) {
1865 cx = &cxstack[cxstack_ix];
1866 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1871 gimme = OP_GIMME(PL_op, -1);
1873 if (cxstack_ix >= 0)
1874 gimme = cxstack[cxstack_ix].blk_gimme;
1880 if (gimme == G_VOID)
1882 else if (gimme == G_SCALAR) {
1886 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1889 *MARK = sv_mortalcopy(TOPs);
1892 *MARK = &PL_sv_undef;
1896 else if (gimme == G_ARRAY) {
1897 /* in case LEAVE wipes old return values */
1899 for (mark = newsp + 1; mark <= SP; mark++) {
1900 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1901 *mark = sv_mortalcopy(*mark);
1902 TAINT_NOT; /* Each item is independent */
1906 PL_curpm = newpm; /* Don't pop $1 et al till now */
1916 register PERL_CONTEXT *cx;
1922 cx = &cxstack[cxstack_ix];
1923 if (CxTYPE(cx) != CXt_LOOP)
1924 DIE(aTHX_ "panic: pp_iter");
1926 itersvp = CxITERVAR(cx);
1927 av = cx->blk_loop.iterary;
1928 if (SvTYPE(av) != SVt_PVAV) {
1929 /* iterate ($min .. $max) */
1930 if (cx->blk_loop.iterlval) {
1931 /* string increment */
1932 register SV* cur = cx->blk_loop.iterlval;
1934 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1935 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1936 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1937 /* safe to reuse old SV */
1938 sv_setsv(*itersvp, cur);
1942 /* we need a fresh SV every time so that loop body sees a
1943 * completely new SV for closures/references to work as
1946 *itersvp = newSVsv(cur);
1947 SvREFCNT_dec(oldsv);
1949 if (strEQ(SvPVX_const(cur), max))
1950 sv_setiv(cur, 0); /* terminate next time */
1957 /* integer increment */
1958 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1961 /* don't risk potential race */
1962 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1963 /* safe to reuse old SV */
1964 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1968 /* we need a fresh SV every time so that loop body sees a
1969 * completely new SV for closures/references to work as they
1972 *itersvp = newSViv(cx->blk_loop.iterix++);
1973 SvREFCNT_dec(oldsv);
1979 if (PL_op->op_private & OPpITER_REVERSED) {
1980 /* In reverse, use itermax as the min :-) */
1981 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1984 if (SvMAGICAL(av) || AvREIFY(av)) {
1985 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1986 sv = svp ? *svp : NULL;
1989 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1993 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1997 if (SvMAGICAL(av) || AvREIFY(av)) {
1998 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1999 sv = svp ? *svp : NULL;
2002 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2006 if (sv && SvIS_FREED(sv)) {
2008 Perl_croak(aTHX_ "Use of freed value in iteration");
2015 if (av != PL_curstack && sv == &PL_sv_undef) {
2016 SV *lv = cx->blk_loop.iterlval;
2017 if (lv && SvREFCNT(lv) > 1) {
2022 SvREFCNT_dec(LvTARG(lv));
2024 lv = cx->blk_loop.iterlval = newSV(0);
2025 sv_upgrade(lv, SVt_PVLV);
2027 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2029 LvTARG(lv) = SvREFCNT_inc_simple(av);
2030 LvTARGOFF(lv) = cx->blk_loop.iterix;
2031 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2036 *itersvp = SvREFCNT_inc_simple_NN(sv);
2037 SvREFCNT_dec(oldsv);
2045 register PMOP *pm = cPMOP;
2060 register REGEXP *rx = PM_GETRE(pm);
2062 int force_on_match = 0;
2063 const I32 oldsave = PL_savestack_ix;
2065 bool doutf8 = FALSE;
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2071 /* known replacement string? */
2072 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2073 if (PL_op->op_flags & OPf_STACKED)
2075 else if (PL_op->op_private & OPpTARGET_MY)
2082 #ifdef PERL_OLD_COPY_ON_WRITE
2083 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2084 because they make integers such as 256 "false". */
2085 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2088 sv_force_normal_flags(TARG,0);
2091 #ifdef PERL_OLD_COPY_ON_WRITE
2095 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2096 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2097 DIE(aTHX_ PL_no_modify);
2100 s = SvPV_mutable(TARG, len);
2101 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2103 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2104 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2109 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2113 DIE(aTHX_ "panic: pp_subst");
2116 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2117 maxiters = 2 * slen + 10; /* We can match twice at each
2118 position, once with zero-length,
2119 second time with non-zero. */
2121 if (!rx->prelen && PL_curpm) {
2125 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2126 || (pm->op_pmflags & PMf_EVAL))
2127 ? REXEC_COPY_STR : 0;
2129 r_flags |= REXEC_SCREAM;
2132 if (rx->reganch & RE_USE_INTUIT) {
2134 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2138 /* How to do it in subst? */
2139 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2141 && ((rx->reganch & ROPT_NOSCAN)
2142 || !((rx->reganch & RE_INTUIT_TAIL)
2143 && (r_flags & REXEC_SCREAM))))
2148 /* only replace once? */
2149 once = !(rpm->op_pmflags & PMf_GLOBAL);
2151 /* known replacement string? */
2153 /* replacement needing upgrading? */
2154 if (DO_UTF8(TARG) && !doutf8) {
2155 nsv = sv_newmortal();
2158 sv_recode_to_utf8(nsv, PL_encoding);
2160 sv_utf8_upgrade(nsv);
2161 c = SvPV_const(nsv, clen);
2165 c = SvPV_const(dstr, clen);
2166 doutf8 = DO_UTF8(dstr);
2174 /* can do inplace substitution? */
2176 #ifdef PERL_OLD_COPY_ON_WRITE
2179 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2180 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2181 && (!doutf8 || SvUTF8(TARG))) {
2182 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2183 r_flags | REXEC_CHECKED))
2187 LEAVE_SCOPE(oldsave);
2190 #ifdef PERL_OLD_COPY_ON_WRITE
2191 if (SvIsCOW(TARG)) {
2192 assert (!force_on_match);
2196 if (force_on_match) {
2198 s = SvPV_force(TARG, len);
2203 SvSCREAM_off(TARG); /* disable possible screamer */
2205 rxtainted |= RX_MATCH_TAINTED(rx);
2206 m = orig + rx->startp[0];
2207 d = orig + rx->endp[0];
2209 if (m - s > strend - d) { /* faster to shorten from end */
2211 Copy(c, m, clen, char);
2216 Move(d, m, i, char);
2220 SvCUR_set(TARG, m - s);
2222 else if ((i = m - s)) { /* faster from front */
2230 Copy(c, m, clen, char);
2235 Copy(c, d, clen, char);
2240 TAINT_IF(rxtainted & 1);
2246 if (iters++ > maxiters)
2247 DIE(aTHX_ "Substitution loop");
2248 rxtainted |= RX_MATCH_TAINTED(rx);
2249 m = rx->startp[0] + orig;
2252 Move(s, d, i, char);
2256 Copy(c, d, clen, char);
2259 s = rx->endp[0] + orig;
2260 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2262 /* don't match same null twice */
2263 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2266 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2267 Move(s, d, i+1, char); /* include the NUL */
2269 TAINT_IF(rxtainted & 1);
2271 PUSHs(sv_2mortal(newSViv((I32)iters)));
2273 (void)SvPOK_only_UTF8(TARG);
2274 TAINT_IF(rxtainted);
2275 if (SvSMAGICAL(TARG)) {
2283 LEAVE_SCOPE(oldsave);
2287 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2288 r_flags | REXEC_CHECKED))
2290 if (force_on_match) {
2292 s = SvPV_force(TARG, len);
2295 #ifdef PERL_OLD_COPY_ON_WRITE
2298 rxtainted |= RX_MATCH_TAINTED(rx);
2299 dstr = newSVpvn(m, s-m);
2304 register PERL_CONTEXT *cx;
2306 (void)ReREFCNT_inc(rx);
2308 RETURNOP(cPMOP->op_pmreplroot);
2310 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2312 if (iters++ > maxiters)
2313 DIE(aTHX_ "Substitution loop");
2314 rxtainted |= RX_MATCH_TAINTED(rx);
2315 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2320 strend = s + (strend - m);
2322 m = rx->startp[0] + orig;
2323 if (doutf8 && !SvUTF8(dstr))
2324 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2326 sv_catpvn(dstr, s, m-s);
2327 s = rx->endp[0] + orig;
2329 sv_catpvn(dstr, c, clen);
2332 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2333 TARG, NULL, r_flags));
2334 if (doutf8 && !DO_UTF8(TARG))
2335 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2337 sv_catpvn(dstr, s, strend - s);
2339 #ifdef PERL_OLD_COPY_ON_WRITE
2340 /* The match may make the string COW. If so, brilliant, because that's
2341 just saved us one malloc, copy and free - the regexp has donated
2342 the old buffer, and we malloc an entirely new one, rather than the
2343 regexp malloc()ing a buffer and copying our original, only for
2344 us to throw it away here during the substitution. */
2345 if (SvIsCOW(TARG)) {
2346 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2352 SvPV_set(TARG, SvPVX(dstr));
2353 SvCUR_set(TARG, SvCUR(dstr));
2354 SvLEN_set(TARG, SvLEN(dstr));
2355 doutf8 |= DO_UTF8(dstr);
2356 SvPV_set(dstr, NULL);
2359 TAINT_IF(rxtainted & 1);
2361 PUSHs(sv_2mortal(newSViv((I32)iters)));
2363 (void)SvPOK_only(TARG);
2366 TAINT_IF(rxtainted);
2369 LEAVE_SCOPE(oldsave);
2378 LEAVE_SCOPE(oldsave);
2387 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2388 ++*PL_markstack_ptr;
2389 LEAVE; /* exit inner scope */
2392 if (PL_stack_base + *PL_markstack_ptr > SP) {
2394 const I32 gimme = GIMME_V;
2396 LEAVE; /* exit outer scope */
2397 (void)POPMARK; /* pop src */
2398 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2399 (void)POPMARK; /* pop dst */
2400 SP = PL_stack_base + POPMARK; /* pop original mark */
2401 if (gimme == G_SCALAR) {
2402 if (PL_op->op_private & OPpGREP_LEX) {
2403 SV* const sv = sv_newmortal();
2404 sv_setiv(sv, items);
2412 else if (gimme == G_ARRAY)
2419 ENTER; /* enter inner scope */
2422 src = PL_stack_base[*PL_markstack_ptr];
2424 if (PL_op->op_private & OPpGREP_LEX)
2425 PAD_SVl(PL_op->op_targ) = src;
2429 RETURNOP(cLOGOP->op_other);
2440 register PERL_CONTEXT *cx;
2443 if (CxMULTICALL(&cxstack[cxstack_ix]))
2447 cxstack_ix++; /* temporarily protect top context */
2450 if (gimme == G_SCALAR) {
2453 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2455 *MARK = SvREFCNT_inc(TOPs);
2460 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2462 *MARK = sv_mortalcopy(sv);
2467 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2471 *MARK = &PL_sv_undef;
2475 else if (gimme == G_ARRAY) {
2476 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2477 if (!SvTEMP(*MARK)) {
2478 *MARK = sv_mortalcopy(*MARK);
2479 TAINT_NOT; /* Each item is independent */
2487 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2488 PL_curpm = newpm; /* ... and pop $1 et al */
2491 return cx->blk_sub.retop;
2494 /* This duplicates the above code because the above code must not
2495 * get any slower by more conditions */
2503 register PERL_CONTEXT *cx;
2506 if (CxMULTICALL(&cxstack[cxstack_ix]))
2510 cxstack_ix++; /* temporarily protect top context */
2514 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2515 /* We are an argument to a function or grep().
2516 * This kind of lvalueness was legal before lvalue
2517 * subroutines too, so be backward compatible:
2518 * cannot report errors. */
2520 /* Scalar context *is* possible, on the LHS of -> only,
2521 * as in f()->meth(). But this is not an lvalue. */
2522 if (gimme == G_SCALAR)
2524 if (gimme == G_ARRAY) {
2525 if (!CvLVALUE(cx->blk_sub.cv))
2526 goto temporise_array;
2527 EXTEND_MORTAL(SP - newsp);
2528 for (mark = newsp + 1; mark <= SP; mark++) {
2531 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2532 *mark = sv_mortalcopy(*mark);
2534 /* Can be a localized value subject to deletion. */
2535 PL_tmps_stack[++PL_tmps_ix] = *mark;
2536 SvREFCNT_inc_void(*mark);
2541 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2542 /* Here we go for robustness, not for speed, so we change all
2543 * the refcounts so the caller gets a live guy. Cannot set
2544 * TEMP, so sv_2mortal is out of question. */
2545 if (!CvLVALUE(cx->blk_sub.cv)) {
2551 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2553 if (gimme == G_SCALAR) {
2557 /* Temporaries are bad unless they happen to be elements
2558 * of a tied hash or array */
2559 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2560 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2566 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2567 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2568 : "a readonly value" : "a temporary");
2570 else { /* Can be a localized value
2571 * subject to deletion. */
2572 PL_tmps_stack[++PL_tmps_ix] = *mark;
2573 SvREFCNT_inc_void(*mark);
2576 else { /* Should not happen? */
2582 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2583 (MARK > SP ? "Empty array" : "Array"));
2587 else if (gimme == G_ARRAY) {
2588 EXTEND_MORTAL(SP - newsp);
2589 for (mark = newsp + 1; mark <= SP; mark++) {
2590 if (*mark != &PL_sv_undef
2591 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2592 /* Might be flattened array after $#array = */
2599 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2600 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2603 /* Can be a localized value subject to deletion. */
2604 PL_tmps_stack[++PL_tmps_ix] = *mark;
2605 SvREFCNT_inc_void(*mark);
2611 if (gimme == G_SCALAR) {
2615 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2617 *MARK = SvREFCNT_inc(TOPs);
2622 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2624 *MARK = sv_mortalcopy(sv);
2629 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2633 *MARK = &PL_sv_undef;
2637 else if (gimme == G_ARRAY) {
2639 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2640 if (!SvTEMP(*MARK)) {
2641 *MARK = sv_mortalcopy(*MARK);
2642 TAINT_NOT; /* Each item is independent */
2651 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2652 PL_curpm = newpm; /* ... and pop $1 et al */
2655 return cx->blk_sub.retop;
2660 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2663 SV * const dbsv = GvSVn(PL_DBsub);
2666 if (!PERLDB_SUB_NN) {
2667 GV * const gv = CvGV(cv);
2669 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2670 || strEQ(GvNAME(gv), "END")
2671 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2672 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2673 /* Use GV from the stack as a fallback. */
2674 /* GV is potentially non-unique, or contain different CV. */
2675 SV * const tmp = newRV((SV*)cv);
2676 sv_setsv(dbsv, tmp);
2680 gv_efullname3(dbsv, gv, NULL);
2684 const int type = SvTYPE(dbsv);
2685 if (type < SVt_PVIV && type != SVt_IV)
2686 sv_upgrade(dbsv, SVt_PVIV);
2687 (void)SvIOK_on(dbsv);
2688 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2692 PL_curcopdb = PL_curcop;
2693 cv = GvCV(PL_DBsub);
2702 register PERL_CONTEXT *cx;
2704 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2707 DIE(aTHX_ "Not a CODE reference");
2708 switch (SvTYPE(sv)) {
2709 /* This is overwhelming the most common case: */
2711 if (!(cv = GvCVu((GV*)sv))) {
2713 cv = sv_2cv(sv, &stash, &gv, 0);
2724 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2726 SP = PL_stack_base + POPMARK;
2729 if (SvGMAGICAL(sv)) {
2733 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2736 sym = SvPV_nolen_const(sv);
2739 DIE(aTHX_ PL_no_usym, "a subroutine");
2740 if (PL_op->op_private & HINT_STRICT_REFS)
2741 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2742 cv = get_cv(sym, TRUE);
2747 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2748 tryAMAGICunDEREF(to_cv);
2751 if (SvTYPE(cv) == SVt_PVCV)
2756 DIE(aTHX_ "Not a CODE reference");
2757 /* This is the second most common case: */
2767 if (!CvROOT(cv) && !CvXSUB(cv)) {
2771 /* anonymous or undef'd function leaves us no recourse */
2772 if (CvANON(cv) || !(gv = CvGV(cv)))
2773 DIE(aTHX_ "Undefined subroutine called");
2775 /* autoloaded stub? */
2776 if (cv != GvCV(gv)) {
2779 /* should call AUTOLOAD now? */
2782 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2789 sub_name = sv_newmortal();
2790 gv_efullname3(sub_name, gv, NULL);
2791 DIE(aTHX_ "Undefined subroutine &%"SVf" called", (void*)sub_name);
2795 DIE(aTHX_ "Not a CODE reference");
2800 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2801 if (CvASSERTION(cv) && PL_DBassertion)
2802 sv_setiv(PL_DBassertion, 1);
2804 cv = get_db_sub(&sv, cv);
2805 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2806 DIE(aTHX_ "No DB::sub routine defined");
2809 if (!(CvISXSUB(cv))) {
2810 /* This path taken at least 75% of the time */
2812 register I32 items = SP - MARK;
2813 AV* const padlist = CvPADLIST(cv);
2814 PUSHBLOCK(cx, CXt_SUB, MARK);
2816 cx->blk_sub.retop = PL_op->op_next;
2818 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2819 * that eval'' ops within this sub know the correct lexical space.
2820 * Owing the speed considerations, we choose instead to search for
2821 * the cv using find_runcv() when calling doeval().
2823 if (CvDEPTH(cv) >= 2) {
2824 PERL_STACK_OVERFLOW_CHECK();
2825 pad_push(padlist, CvDEPTH(cv));
2828 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2831 AV* const av = (AV*)PAD_SVl(0);
2833 /* @_ is normally not REAL--this should only ever
2834 * happen when DB::sub() calls things that modify @_ */
2839 cx->blk_sub.savearray = GvAV(PL_defgv);
2840 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2841 CX_CURPAD_SAVE(cx->blk_sub);
2842 cx->blk_sub.argarray = av;
2845 if (items > AvMAX(av) + 1) {
2846 SV **ary = AvALLOC(av);
2847 if (AvARRAY(av) != ary) {
2848 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2849 SvPV_set(av, (char*)ary);
2851 if (items > AvMAX(av) + 1) {
2852 AvMAX(av) = items - 1;
2853 Renew(ary,items,SV*);
2855 SvPV_set(av, (char*)ary);
2858 Copy(MARK,AvARRAY(av),items,SV*);
2859 AvFILLp(av) = items - 1;
2867 /* warning must come *after* we fully set up the context
2868 * stuff so that __WARN__ handlers can safely dounwind()
2871 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2872 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2873 sub_crush_depth(cv);
2875 DEBUG_S(PerlIO_printf(Perl_debug_log,
2876 "%p entersub returning %p\n", thr, CvSTART(cv)));
2878 RETURNOP(CvSTART(cv));
2881 I32 markix = TOPMARK;
2886 /* Need to copy @_ to stack. Alternative may be to
2887 * switch stack to @_, and copy return values
2888 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2889 AV * const av = GvAV(PL_defgv);
2890 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2893 /* Mark is at the end of the stack. */
2895 Copy(AvARRAY(av), SP + 1, items, SV*);
2900 /* We assume first XSUB in &DB::sub is the called one. */
2902 SAVEVPTR(PL_curcop);
2903 PL_curcop = PL_curcopdb;
2906 /* Do we need to open block here? XXXX */
2907 (void)(*CvXSUB(cv))(aTHX_ cv);
2909 /* Enforce some sanity in scalar context. */
2910 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2911 if (markix > PL_stack_sp - PL_stack_base)
2912 *(PL_stack_base + markix) = &PL_sv_undef;
2914 *(PL_stack_base + markix) = *PL_stack_sp;
2915 PL_stack_sp = PL_stack_base + markix;
2923 Perl_sub_crush_depth(pTHX_ CV *cv)
2926 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2928 SV* const tmpstr = sv_newmortal();
2929 gv_efullname3(tmpstr, CvGV(cv), NULL);
2930 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2939 SV* const elemsv = POPs;
2940 IV elem = SvIV(elemsv);
2941 AV* const av = (AV*)POPs;
2942 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2943 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2946 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2947 Perl_warner(aTHX_ packWARN(WARN_MISC),
2948 "Use of reference \"%"SVf"\" as array index",
2951 elem -= CopARYBASE_get(PL_curcop);
2952 if (SvTYPE(av) != SVt_PVAV)
2954 svp = av_fetch(av, elem, lval && !defer);
2956 #ifdef PERL_MALLOC_WRAP
2957 if (SvUOK(elemsv)) {
2958 const UV uv = SvUV(elemsv);
2959 elem = uv > IV_MAX ? IV_MAX : uv;
2961 else if (SvNOK(elemsv))
2962 elem = (IV)SvNV(elemsv);
2964 static const char oom_array_extend[] =
2965 "Out of memory during array extend"; /* Duplicated in av.c */
2966 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2969 if (!svp || *svp == &PL_sv_undef) {
2972 DIE(aTHX_ PL_no_aelem, elem);
2973 lv = sv_newmortal();
2974 sv_upgrade(lv, SVt_PVLV);
2976 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2977 LvTARG(lv) = SvREFCNT_inc_simple(av);
2978 LvTARGOFF(lv) = elem;
2983 if (PL_op->op_private & OPpLVAL_INTRO)
2984 save_aelem(av, elem, svp);
2985 else if (PL_op->op_private & OPpDEREF)
2986 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2988 sv = (svp ? *svp : &PL_sv_undef);
2989 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2990 sv = sv_mortalcopy(sv);
2996 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3001 Perl_croak(aTHX_ PL_no_modify);
3002 if (SvTYPE(sv) < SVt_RV)
3003 sv_upgrade(sv, SVt_RV);
3004 else if (SvTYPE(sv) >= SVt_PV) {
3011 SvRV_set(sv, newSV(0));
3014 SvRV_set(sv, (SV*)newAV());
3017 SvRV_set(sv, (SV*)newHV());
3028 SV* const sv = TOPs;
3031 SV* const rsv = SvRV(sv);
3032 if (SvTYPE(rsv) == SVt_PVCV) {
3038 SETs(method_common(sv, NULL));
3045 SV* const sv = cSVOP_sv;
3046 U32 hash = SvSHARED_HASH(sv);
3048 XPUSHs(method_common(sv, &hash));
3053 S_method_common(pTHX_ SV* meth, U32* hashp)
3060 const char* packname = NULL;
3063 const char * const name = SvPV_const(meth, namelen);
3064 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3067 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3075 /* this isn't a reference */
3076 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3077 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3079 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3086 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3087 !(ob=(SV*)GvIO(iogv)))
3089 /* this isn't the name of a filehandle either */
3091 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3092 ? !isIDFIRST_utf8((U8*)packname)
3093 : !isIDFIRST(*packname)
3096 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3097 SvOK(sv) ? "without a package or object reference"
3098 : "on an undefined value");
3100 /* assume it's a package name */
3101 stash = gv_stashpvn(packname, packlen, FALSE);
3105 SV* const ref = newSViv(PTR2IV(stash));
3106 hv_store(PL_stashcache, packname, packlen, ref, 0);
3110 /* it _is_ a filehandle name -- replace with a reference */
3111 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3114 /* if we got here, ob should be a reference or a glob */
3115 if (!ob || !(SvOBJECT(ob)
3116 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3119 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3123 stash = SvSTASH(ob);
3126 /* NOTE: stash may be null, hope hv_fetch_ent and
3127 gv_fetchmethod can cope (it seems they can) */
3129 /* shortcut for simple names */
3131 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3133 gv = (GV*)HeVAL(he);
3134 if (isGV(gv) && GvCV(gv) &&
3135 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3136 return (SV*)GvCV(gv);
3140 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3143 /* This code tries to figure out just what went wrong with
3144 gv_fetchmethod. It therefore needs to duplicate a lot of
3145 the internals of that function. We can't move it inside
3146 Perl_gv_fetchmethod_autoload(), however, since that would
3147 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3150 const char* leaf = name;
3151 const char* sep = NULL;
3154 for (p = name; *p; p++) {
3156 sep = p, leaf = p + 1;
3157 else if (*p == ':' && *(p + 1) == ':')
3158 sep = p, leaf = p + 2;
3160 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3161 /* the method name is unqualified or starts with SUPER:: */
3162 bool need_strlen = 1;
3164 packname = CopSTASHPV(PL_curcop);
3167 HEK * const packhek = HvNAME_HEK(stash);
3169 packname = HEK_KEY(packhek);
3170 packlen = HEK_LEN(packhek);
3180 "Can't use anonymous symbol table for method lookup");
3182 else if (need_strlen)
3183 packlen = strlen(packname);
3187 /* the method name is qualified */
3189 packlen = sep - name;
3192 /* we're relying on gv_fetchmethod not autovivifying the stash */
3193 if (gv_stashpvn(packname, packlen, FALSE)) {
3195 "Can't locate object method \"%s\" via package \"%.*s\"",
3196 leaf, (int)packlen, packname);
3200 "Can't locate object method \"%s\" via package \"%.*s\""
3201 " (perhaps you forgot to load \"%.*s\"?)",
3202 leaf, (int)packlen, packname, (int)packlen, packname);
3205 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3210 * c-indentation-style: bsd
3212 * indent-tabs-mode: t
3215 * ex: set ts=8 sts=4 sw=4 noet: