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 if (PL_tainting && PL_tainted && !SvTAINTED(left))
125 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
126 SV * const cv = SvRV(left);
127 const U32 cv_type = SvTYPE(cv);
128 const U32 gv_type = SvTYPE(right);
129 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
135 /* Can do the optimisation if right (LVAUE) is not a typeglob,
136 left (RVALUE) is a reference to something, and we're in void
138 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
139 /* Is the target symbol table currently empty? */
140 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
141 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
142 /* Good. Create a new proxy constant subroutine in the target.
143 The gv becomes a(nother) reference to the constant. */
144 SV *const value = SvRV(cv);
146 SvUPGRADE((SV *)gv, SVt_RV);
155 /* Need to fix things up. */
156 if (gv_type != SVt_PVGV) {
157 /* Need to fix GV. */
158 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
162 /* We've been returned a constant rather than a full subroutine,
163 but they expect a subroutine reference to apply. */
165 SvREFCNT_inc(SvRV(cv));
166 /* newCONSTSUB takes a reference count on the passed in SV
167 from us. We set the name to NULL, otherwise we get into
168 all sorts of fun as the reference to our new sub is
169 donated to the GV that we're about to assign to.
171 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
178 SvSetMagicSV(right, left);
187 RETURNOP(cLOGOP->op_other);
189 RETURNOP(cLOGOP->op_next);
196 TAINT_NOT; /* Each statement is presumed innocent */
197 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
199 oldsave = PL_scopestack[PL_scopestack_ix - 1];
200 LEAVE_SCOPE(oldsave);
206 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
213 bool rcopied = FALSE;
215 if (TARG == right && right != left) {
216 /* mg_get(right) may happen here ... */
217 rpv = SvPV_const(right, rlen);
218 rbyte = !DO_UTF8(right);
219 right = sv_2mortal(newSVpvn(rpv, rlen));
220 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
226 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
227 lbyte = !DO_UTF8(left);
228 sv_setpvn(TARG, lpv, llen);
234 else { /* TARG == left */
236 SvGETMAGIC(left); /* or mg_get(left) may happen here */
238 if (left == right && ckWARN(WARN_UNINITIALIZED))
239 report_uninit(right);
240 sv_setpvn(left, "", 0);
242 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
243 lbyte = !DO_UTF8(left);
248 /* or mg_get(right) may happen here */
250 rpv = SvPV_const(right, rlen);
251 rbyte = !DO_UTF8(right);
253 if (lbyte != rbyte) {
255 sv_utf8_upgrade_nomg(TARG);
258 right = sv_2mortal(newSVpvn(rpv, rlen));
259 sv_utf8_upgrade_nomg(right);
260 rpv = SvPV_const(right, rlen);
263 sv_catpvn_nomg(TARG, rpv, rlen);
274 if (PL_op->op_flags & OPf_MOD) {
275 if (PL_op->op_private & OPpLVAL_INTRO)
276 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
277 if (PL_op->op_private & OPpDEREF) {
279 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
289 tryAMAGICunTARGET(iter, 0);
290 PL_last_in_gv = (GV*)(*PL_stack_sp--);
291 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
292 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
293 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
296 XPUSHs((SV*)PL_last_in_gv);
299 PL_last_in_gv = (GV*)(*PL_stack_sp--);
302 return do_readline();
307 dVAR; dSP; tryAMAGICbinSET(eq,0);
308 #ifndef NV_PRESERVES_UV
309 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
311 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
315 #ifdef PERL_PRESERVE_IVUV
318 /* Unless the left argument is integer in range we are going
319 to have to use NV maths. Hence only attempt to coerce the
320 right argument if we know the left is integer. */
323 const bool auvok = SvUOK(TOPm1s);
324 const bool buvok = SvUOK(TOPs);
326 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
327 /* Casting IV to UV before comparison isn't going to matter
328 on 2s complement. On 1s complement or sign&magnitude
329 (if we have any of them) it could to make negative zero
330 differ from normal zero. As I understand it. (Need to
331 check - is negative zero implementation defined behaviour
333 const UV buv = SvUVX(POPs);
334 const UV auv = SvUVX(TOPs);
336 SETs(boolSV(auv == buv));
339 { /* ## Mixed IV,UV ## */
343 /* == is commutative so doesn't matter which is left or right */
345 /* top of stack (b) is the iv */
354 /* As uv is a UV, it's >0, so it cannot be == */
358 /* we know iv is >= 0 */
359 SETs(boolSV((UV)iv == SvUVX(uvp)));
367 SETs(boolSV(TOPn == value));
375 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
376 DIE(aTHX_ PL_no_modify);
377 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
378 && SvIVX(TOPs) != IV_MAX)
380 SvIV_set(TOPs, SvIVX(TOPs) + 1);
381 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
383 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
395 if (PL_op->op_type == OP_OR)
397 RETURNOP(cLOGOP->op_other);
406 const int op_type = PL_op->op_type;
407 const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
411 if (!sv || !SvANY(sv)) {
412 if (op_type == OP_DOR)
414 RETURNOP(cLOGOP->op_other);
416 } else if (op_type == OP_DEFINED) {
418 if (!sv || !SvANY(sv))
421 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
424 switch (SvTYPE(sv)) {
426 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
430 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
434 if (CvROOT(sv) || CvXSUB(sv))
447 if(op_type == OP_DOR)
449 RETURNOP(cLOGOP->op_other);
451 /* assuming OP_DEFINED */
459 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
460 useleft = USE_LEFT(TOPm1s);
461 #ifdef PERL_PRESERVE_IVUV
462 /* We must see if we can perform the addition with integers if possible,
463 as the integer code detects overflow while the NV code doesn't.
464 If either argument hasn't had a numeric conversion yet attempt to get
465 the IV. It's important to do this now, rather than just assuming that
466 it's not IOK as a PV of "9223372036854775806" may not take well to NV
467 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
468 integer in case the second argument is IV=9223372036854775806
469 We can (now) rely on sv_2iv to do the right thing, only setting the
470 public IOK flag if the value in the NV (or PV) slot is truly integer.
472 A side effect is that this also aggressively prefers integer maths over
473 fp maths for integer values.
475 How to detect overflow?
477 C 99 section 6.2.6.1 says
479 The range of nonnegative values of a signed integer type is a subrange
480 of the corresponding unsigned integer type, and the representation of
481 the same value in each type is the same. A computation involving
482 unsigned operands can never overflow, because a result that cannot be
483 represented by the resulting unsigned integer type is reduced modulo
484 the number that is one greater than the largest value that can be
485 represented by the resulting type.
489 which I read as "unsigned ints wrap."
491 signed integer overflow seems to be classed as "exception condition"
493 If an exceptional condition occurs during the evaluation of an
494 expression (that is, if the result is not mathematically defined or not
495 in the range of representable values for its type), the behavior is
498 (6.5, the 5th paragraph)
500 I had assumed that on 2s complement machines signed arithmetic would
501 wrap, hence coded pp_add and pp_subtract on the assumption that
502 everything perl builds on would be happy. After much wailing and
503 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
504 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
505 unsigned code below is actually shorter than the old code. :-)
510 /* Unless the left argument is integer in range we are going to have to
511 use NV maths. Hence only attempt to coerce the right argument if
512 we know the left is integer. */
520 /* left operand is undef, treat as zero. + 0 is identity,
521 Could SETi or SETu right now, but space optimise by not adding
522 lots of code to speed up what is probably a rarish case. */
524 /* Left operand is defined, so is it IV? */
527 if ((auvok = SvUOK(TOPm1s)))
530 register const IV aiv = SvIVX(TOPm1s);
533 auvok = 1; /* Now acting as a sign flag. */
534 } else { /* 2s complement assumption for IV_MIN */
542 bool result_good = 0;
545 bool buvok = SvUOK(TOPs);
550 register const IV biv = SvIVX(TOPs);
557 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
558 else "IV" now, independent of how it came in.
559 if a, b represents positive, A, B negative, a maps to -A etc
564 all UV maths. negate result if A negative.
565 add if signs same, subtract if signs differ. */
571 /* Must get smaller */
577 /* result really should be -(auv-buv). as its negation
578 of true value, need to swap our result flag */
595 if (result <= (UV)IV_MIN)
598 /* result valid, but out of range for IV. */
603 } /* Overflow, drop through to NVs. */
610 /* left operand is undef, treat as zero. + 0.0 is identity. */
614 SETn( value + TOPn );
622 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
623 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
624 const U32 lval = PL_op->op_flags & OPf_MOD;
625 SV** const svp = av_fetch(av, PL_op->op_private, lval);
626 SV *sv = (svp ? *svp : &PL_sv_undef);
628 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
629 sv = sv_mortalcopy(sv);
636 dVAR; dSP; dMARK; dTARGET;
638 do_join(TARG, *MARK, MARK, SP);
649 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
650 * will be enough to hold an OP*.
652 SV* const sv = sv_newmortal();
653 sv_upgrade(sv, SVt_PVLV);
655 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
663 /* Oversized hot code. */
667 dVAR; dSP; dMARK; dORIGMARK;
671 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
673 if (gv && (io = GvIO(gv))
674 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
677 if (MARK == ORIGMARK) {
678 /* If using default handle then we need to make space to
679 * pass object as 1st arg, so move other args up ...
683 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
687 *MARK = SvTIED_obj((SV*)io, mg);
690 call_method("PRINT", G_SCALAR);
698 if (!(io = GvIO(gv))) {
699 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
700 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
702 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
703 report_evil_fh(gv, io, PL_op->op_type);
704 SETERRNO(EBADF,RMS_IFI);
707 else if (!(fp = IoOFP(io))) {
708 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
710 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
711 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
712 report_evil_fh(gv, io, PL_op->op_type);
714 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
719 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
721 if (!do_print(*MARK, fp))
725 if (!do_print(PL_ofs_sv, fp)) { /* $, */
734 if (!do_print(*MARK, fp))
742 if (PL_ors_sv && SvOK(PL_ors_sv))
743 if (!do_print(PL_ors_sv, fp)) /* $\ */
746 if (IoFLAGS(io) & IOf_FLUSH)
747 if (PerlIO_flush(fp) == EOF)
757 XPUSHs(&PL_sv_undef);
768 tryAMAGICunDEREF(to_av);
771 if (SvTYPE(av) != SVt_PVAV)
772 DIE(aTHX_ "Not an ARRAY reference");
773 if (PL_op->op_flags & OPf_REF) {
778 if (GIMME == G_SCALAR)
779 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
783 else if (PL_op->op_flags & OPf_MOD
784 && PL_op->op_private & OPpLVAL_INTRO)
785 Perl_croak(aTHX_ PL_no_localize_ref);
788 if (SvTYPE(sv) == SVt_PVAV) {
790 if (PL_op->op_flags & OPf_REF) {
795 if (GIMME == G_SCALAR)
796 Perl_croak(aTHX_ "Can't return array to lvalue"
805 if (SvTYPE(sv) != SVt_PVGV) {
806 if (SvGMAGICAL(sv)) {
812 if (PL_op->op_flags & OPf_REF ||
813 PL_op->op_private & HINT_STRICT_REFS)
814 DIE(aTHX_ PL_no_usym, "an ARRAY");
815 if (ckWARN(WARN_UNINITIALIZED))
817 if (GIMME == G_ARRAY) {
823 if ((PL_op->op_flags & OPf_SPECIAL) &&
824 !(PL_op->op_flags & OPf_MOD))
826 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
828 && (!is_gv_magical_sv(sv,0)
829 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
835 if (PL_op->op_private & HINT_STRICT_REFS)
836 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
837 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
844 if (PL_op->op_private & OPpLVAL_INTRO)
846 if (PL_op->op_flags & OPf_REF) {
851 if (GIMME == G_SCALAR)
852 Perl_croak(aTHX_ "Can't return array to lvalue"
860 if (GIMME == G_ARRAY) {
861 const I32 maxarg = AvFILL(av) + 1;
862 (void)POPs; /* XXXX May be optimized away? */
864 if (SvRMAGICAL(av)) {
866 for (i=0; i < (U32)maxarg; i++) {
867 SV ** const svp = av_fetch(av, i, FALSE);
868 /* See note in pp_helem, and bug id #27839 */
870 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
875 Copy(AvARRAY(av), SP+1, maxarg, SV*);
879 else if (GIMME_V == G_SCALAR) {
881 const I32 maxarg = AvFILL(av) + 1;
891 const I32 gimme = GIMME_V;
892 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
896 tryAMAGICunDEREF(to_hv);
899 if (SvTYPE(hv) != SVt_PVHV)
900 DIE(aTHX_ "Not a HASH reference");
901 if (PL_op->op_flags & OPf_REF) {
906 if (gimme != G_ARRAY)
907 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
911 else if (PL_op->op_flags & OPf_MOD
912 && PL_op->op_private & OPpLVAL_INTRO)
913 Perl_croak(aTHX_ PL_no_localize_ref);
916 if (SvTYPE(sv) == SVt_PVHV) {
918 if (PL_op->op_flags & OPf_REF) {
923 if (gimme != G_ARRAY)
924 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
932 if (SvTYPE(sv) != SVt_PVGV) {
933 if (SvGMAGICAL(sv)) {
939 if (PL_op->op_flags & OPf_REF ||
940 PL_op->op_private & HINT_STRICT_REFS)
941 DIE(aTHX_ PL_no_usym, "a HASH");
942 if (ckWARN(WARN_UNINITIALIZED))
944 if (gimme == G_ARRAY) {
950 if ((PL_op->op_flags & OPf_SPECIAL) &&
951 !(PL_op->op_flags & OPf_MOD))
953 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
955 && (!is_gv_magical_sv(sv,0)
956 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
962 if (PL_op->op_private & HINT_STRICT_REFS)
963 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
964 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
971 if (PL_op->op_private & OPpLVAL_INTRO)
973 if (PL_op->op_flags & OPf_REF) {
978 if (gimme != G_ARRAY)
979 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
986 if (gimme == G_ARRAY) { /* array wanted */
987 *PL_stack_sp = (SV*)hv;
990 else if (gimme == G_SCALAR) {
992 TARG = Perl_hv_scalar(aTHX_ hv);
999 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1006 if (ckWARN(WARN_MISC)) {
1008 if (relem == firstrelem &&
1010 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1011 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1013 err = "Reference found where even-sized list expected";
1016 err = "Odd number of elements in hash assignment";
1017 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1021 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1022 if (SvMAGICAL(hash)) {
1023 if (SvSMAGICAL(tmpstr))
1035 SV **lastlelem = PL_stack_sp;
1036 SV **lastrelem = PL_stack_base + POPMARK;
1037 SV **firstrelem = PL_stack_base + POPMARK + 1;
1038 SV **firstlelem = lastrelem + 1;
1040 register SV **relem;
1041 register SV **lelem;
1051 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1054 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1057 /* If there's a common identifier on both sides we have to take
1058 * special care that assigning the identifier on the left doesn't
1059 * clobber a value on the right that's used later in the list.
1061 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1062 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1063 for (relem = firstrelem; relem <= lastrelem; relem++) {
1064 if ((sv = *relem)) {
1065 TAINT_NOT; /* Each item is independent */
1066 *relem = sv_mortalcopy(sv);
1076 while (lelem <= lastlelem) {
1077 TAINT_NOT; /* Each item stands on its own, taintwise. */
1079 switch (SvTYPE(sv)) {
1082 magic = SvMAGICAL(ary) != 0;
1084 av_extend(ary, lastrelem - relem);
1086 while (relem <= lastrelem) { /* gobble up all the rest */
1089 sv = newSVsv(*relem);
1091 didstore = av_store(ary,i++,sv);
1101 case SVt_PVHV: { /* normal hash */
1105 magic = SvMAGICAL(hash) != 0;
1107 firsthashrelem = relem;
1109 while (relem < lastrelem) { /* gobble up all the rest */
1111 sv = *relem ? *relem : &PL_sv_no;
1115 sv_setsv(tmpstr,*relem); /* value */
1116 *(relem++) = tmpstr;
1117 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1118 /* key overwrites an existing entry */
1120 didstore = hv_store_ent(hash,sv,tmpstr,0);
1122 if (SvSMAGICAL(tmpstr))
1129 if (relem == lastrelem) {
1130 do_oddball(hash, relem, firstrelem);
1136 if (SvIMMORTAL(sv)) {
1137 if (relem <= lastrelem)
1141 if (relem <= lastrelem) {
1142 sv_setsv(sv, *relem);
1146 sv_setsv(sv, &PL_sv_undef);
1151 if (PL_delaymagic & ~DM_DELAY) {
1152 if (PL_delaymagic & DM_UID) {
1153 #ifdef HAS_SETRESUID
1154 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1155 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1158 # ifdef HAS_SETREUID
1159 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1160 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1163 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1164 (void)setruid(PL_uid);
1165 PL_delaymagic &= ~DM_RUID;
1167 # endif /* HAS_SETRUID */
1169 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1170 (void)seteuid(PL_euid);
1171 PL_delaymagic &= ~DM_EUID;
1173 # endif /* HAS_SETEUID */
1174 if (PL_delaymagic & DM_UID) {
1175 if (PL_uid != PL_euid)
1176 DIE(aTHX_ "No setreuid available");
1177 (void)PerlProc_setuid(PL_uid);
1179 # endif /* HAS_SETREUID */
1180 #endif /* HAS_SETRESUID */
1181 PL_uid = PerlProc_getuid();
1182 PL_euid = PerlProc_geteuid();
1184 if (PL_delaymagic & DM_GID) {
1185 #ifdef HAS_SETRESGID
1186 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1187 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1190 # ifdef HAS_SETREGID
1191 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1192 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1195 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1196 (void)setrgid(PL_gid);
1197 PL_delaymagic &= ~DM_RGID;
1199 # endif /* HAS_SETRGID */
1201 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1202 (void)setegid(PL_egid);
1203 PL_delaymagic &= ~DM_EGID;
1205 # endif /* HAS_SETEGID */
1206 if (PL_delaymagic & DM_GID) {
1207 if (PL_gid != PL_egid)
1208 DIE(aTHX_ "No setregid available");
1209 (void)PerlProc_setgid(PL_gid);
1211 # endif /* HAS_SETREGID */
1212 #endif /* HAS_SETRESGID */
1213 PL_gid = PerlProc_getgid();
1214 PL_egid = PerlProc_getegid();
1216 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1220 if (gimme == G_VOID)
1221 SP = firstrelem - 1;
1222 else if (gimme == G_SCALAR) {
1225 SETi(lastrelem - firstrelem + 1 - duplicates);
1232 /* Removes from the stack the entries which ended up as
1233 * duplicated keys in the hash (fix for [perl #24380]) */
1234 Move(firsthashrelem + duplicates,
1235 firsthashrelem, duplicates, SV**);
1236 lastrelem -= duplicates;
1241 SP = firstrelem + (lastlelem - firstlelem);
1242 lelem = firstlelem + (relem - firstrelem);
1244 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1252 register PMOP * const pm = cPMOP;
1253 SV * const rv = sv_newmortal();
1254 SV * const sv = newSVrv(rv, "Regexp");
1255 if (pm->op_pmdynflags & PMdf_TAINTED)
1257 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1264 register PMOP *pm = cPMOP;
1266 register const char *t;
1267 register const char *s;
1270 I32 r_flags = REXEC_CHECKED;
1271 const char *truebase; /* Start of string */
1272 register REGEXP *rx = PM_GETRE(pm);
1274 const I32 gimme = GIMME;
1277 const I32 oldsave = PL_savestack_ix;
1278 I32 update_minmatch = 1;
1279 I32 had_zerolen = 0;
1281 if (PL_op->op_flags & OPf_STACKED)
1283 else if (PL_op->op_private & OPpTARGET_MY)
1290 PUTBACK; /* EVAL blocks need stack_sp. */
1291 s = SvPV_const(TARG, len);
1293 DIE(aTHX_ "panic: pp_match");
1295 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1296 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1299 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1301 /* PMdf_USED is set after a ?? matches once */
1302 if (pm->op_pmdynflags & PMdf_USED) {
1304 if (gimme == G_ARRAY)
1309 /* empty pattern special-cased to use last successful pattern if possible */
1310 if (!rx->prelen && PL_curpm) {
1315 if (rx->minlen > (I32)len)
1320 /* XXXX What part of this is needed with true \G-support? */
1321 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1323 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1324 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1325 if (mg && mg->mg_len >= 0) {
1326 if (!(rx->reganch & ROPT_GPOS_SEEN))
1327 rx->endp[0] = rx->startp[0] = mg->mg_len;
1328 else if (rx->reganch & ROPT_ANCH_GPOS) {
1329 r_flags |= REXEC_IGNOREPOS;
1330 rx->endp[0] = rx->startp[0] = mg->mg_len;
1332 minmatch = (mg->mg_flags & MGf_MINMATCH);
1333 update_minmatch = 0;
1337 if ((!global && rx->nparens)
1338 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1339 r_flags |= REXEC_COPY_STR;
1341 r_flags |= REXEC_SCREAM;
1344 if (global && rx->startp[0] != -1) {
1345 t = s = rx->endp[0] + truebase;
1346 if ((s + rx->minlen) > strend)
1348 if (update_minmatch++)
1349 minmatch = had_zerolen;
1351 if (rx->reganch & RE_USE_INTUIT &&
1352 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1353 /* FIXME - can PL_bostr be made const char *? */
1354 PL_bostr = (char *)truebase;
1355 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1359 if ( (rx->reganch & ROPT_CHECK_ALL)
1361 && ((rx->reganch & ROPT_NOSCAN)
1362 || !((rx->reganch & RE_INTUIT_TAIL)
1363 && (r_flags & REXEC_SCREAM)))
1364 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1367 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1370 if (dynpm->op_pmflags & PMf_ONCE)
1371 dynpm->op_pmdynflags |= PMdf_USED;
1380 RX_MATCH_TAINTED_on(rx);
1381 TAINT_IF(RX_MATCH_TAINTED(rx));
1382 if (gimme == G_ARRAY) {
1383 const I32 nparens = rx->nparens;
1384 I32 i = (global && !nparens) ? 1 : 0;
1386 SPAGAIN; /* EVAL blocks could move the stack. */
1387 EXTEND(SP, nparens + i);
1388 EXTEND_MORTAL(nparens + i);
1389 for (i = !i; i <= nparens; i++) {
1390 PUSHs(sv_newmortal());
1391 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1392 const I32 len = rx->endp[i] - rx->startp[i];
1393 s = rx->startp[i] + truebase;
1394 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1395 len < 0 || len > strend - s)
1396 DIE(aTHX_ "panic: pp_match start/end pointers");
1397 sv_setpvn(*SP, s, len);
1398 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1403 if (dynpm->op_pmflags & PMf_CONTINUE) {
1405 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1406 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1408 sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
1409 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1411 if (rx->startp[0] != -1) {
1412 mg->mg_len = rx->endp[0];
1413 if (rx->startp[0] == rx->endp[0])
1414 mg->mg_flags |= MGf_MINMATCH;
1416 mg->mg_flags &= ~MGf_MINMATCH;
1419 had_zerolen = (rx->startp[0] != -1
1420 && rx->startp[0] == rx->endp[0]);
1421 PUTBACK; /* EVAL blocks may use stack */
1422 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1427 LEAVE_SCOPE(oldsave);
1433 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1434 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1438 sv_magic(TARG, NULL, PERL_MAGIC_regex_global, NULL, 0);
1439 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1441 if (rx->startp[0] != -1) {
1442 mg->mg_len = rx->endp[0];
1443 if (rx->startp[0] == rx->endp[0])
1444 mg->mg_flags |= MGf_MINMATCH;
1446 mg->mg_flags &= ~MGf_MINMATCH;
1449 LEAVE_SCOPE(oldsave);
1453 yup: /* Confirmed by INTUIT */
1455 RX_MATCH_TAINTED_on(rx);
1456 TAINT_IF(RX_MATCH_TAINTED(rx));
1458 if (dynpm->op_pmflags & PMf_ONCE)
1459 dynpm->op_pmdynflags |= PMdf_USED;
1460 if (RX_MATCH_COPIED(rx))
1461 Safefree(rx->subbeg);
1462 RX_MATCH_COPIED_off(rx);
1465 /* FIXME - should rx->subbeg be const char *? */
1466 rx->subbeg = (char *) truebase;
1467 rx->startp[0] = s - truebase;
1468 if (RX_MATCH_UTF8(rx)) {
1469 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1470 rx->endp[0] = t - truebase;
1473 rx->endp[0] = s - truebase + rx->minlen;
1475 rx->sublen = strend - truebase;
1478 if (PL_sawampersand) {
1480 #ifdef PERL_OLD_COPY_ON_WRITE
1481 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1483 PerlIO_printf(Perl_debug_log,
1484 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1485 (int) SvTYPE(TARG), truebase, t,
1488 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1489 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1490 assert (SvPOKp(rx->saved_copy));
1495 rx->subbeg = savepvn(t, strend - t);
1496 #ifdef PERL_OLD_COPY_ON_WRITE
1497 rx->saved_copy = NULL;
1500 rx->sublen = strend - t;
1501 RX_MATCH_COPIED_on(rx);
1502 off = rx->startp[0] = s - t;
1503 rx->endp[0] = off + rx->minlen;
1505 else { /* startp/endp are used by @- @+. */
1506 rx->startp[0] = s - truebase;
1507 rx->endp[0] = s - truebase + rx->minlen;
1509 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1510 LEAVE_SCOPE(oldsave);
1515 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1516 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1517 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1522 LEAVE_SCOPE(oldsave);
1523 if (gimme == G_ARRAY)
1529 Perl_do_readline(pTHX)
1531 dVAR; dSP; dTARGETSTACKED;
1536 register IO * const io = GvIO(PL_last_in_gv);
1537 register const I32 type = PL_op->op_type;
1538 const I32 gimme = GIMME_V;
1541 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1544 XPUSHs(SvTIED_obj((SV*)io, mg));
1547 call_method("READLINE", gimme);
1550 if (gimme == G_SCALAR) {
1551 SV* const result = POPs;
1552 SvSetSV_nosteal(TARG, result);
1562 if (IoFLAGS(io) & IOf_ARGV) {
1563 if (IoFLAGS(io) & IOf_START) {
1565 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1566 IoFLAGS(io) &= ~IOf_START;
1567 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1568 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1569 SvSETMAGIC(GvSV(PL_last_in_gv));
1574 fp = nextargv(PL_last_in_gv);
1575 if (!fp) { /* Note: fp != IoIFP(io) */
1576 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1579 else if (type == OP_GLOB)
1580 fp = Perl_start_glob(aTHX_ POPs, io);
1582 else if (type == OP_GLOB)
1584 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1585 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1589 if ((!io || !(IoFLAGS(io) & IOf_START))
1590 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1592 if (type == OP_GLOB)
1593 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1594 "glob failed (can't start child: %s)",
1597 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1599 if (gimme == G_SCALAR) {
1600 /* undef TARG, and push that undefined value */
1601 if (type != OP_RCATLINE) {
1602 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1610 if (gimme == G_SCALAR) {
1614 SvUPGRADE(sv, SVt_PV);
1615 tmplen = SvLEN(sv); /* remember if already alloced */
1616 if (!tmplen && !SvREADONLY(sv))
1617 Sv_Grow(sv, 80); /* try short-buffering it */
1619 if (type == OP_RCATLINE && SvOK(sv)) {
1621 SvPV_force_nolen(sv);
1627 sv = sv_2mortal(newSV(80));
1631 /* This should not be marked tainted if the fp is marked clean */
1632 #define MAYBE_TAINT_LINE(io, sv) \
1633 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1638 /* delay EOF state for a snarfed empty file */
1639 #define SNARF_EOF(gimme,rs,io,sv) \
1640 (gimme != G_SCALAR || SvCUR(sv) \
1641 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1645 if (!sv_gets(sv, fp, offset)
1647 || SNARF_EOF(gimme, PL_rs, io, sv)
1648 || PerlIO_error(fp)))
1650 PerlIO_clearerr(fp);
1651 if (IoFLAGS(io) & IOf_ARGV) {
1652 fp = nextargv(PL_last_in_gv);
1655 (void)do_close(PL_last_in_gv, FALSE);
1657 else if (type == OP_GLOB) {
1658 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1659 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1660 "glob failed (child exited with status %d%s)",
1661 (int)(STATUS_CURRENT >> 8),
1662 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1665 if (gimme == G_SCALAR) {
1666 if (type != OP_RCATLINE) {
1667 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1673 MAYBE_TAINT_LINE(io, sv);
1676 MAYBE_TAINT_LINE(io, sv);
1678 IoFLAGS(io) |= IOf_NOLINE;
1682 if (type == OP_GLOB) {
1685 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1686 char * const tmps = SvEND(sv) - 1;
1687 if (*tmps == *SvPVX_const(PL_rs)) {
1689 SvCUR_set(sv, SvCUR(sv) - 1);
1692 for (t1 = SvPVX_const(sv); *t1; t1++)
1693 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1694 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1696 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1697 (void)POPs; /* Unmatched wildcard? Chuck it... */
1700 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1701 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1702 const STRLEN len = SvCUR(sv) - offset;
1705 if (ckWARN(WARN_UTF8) &&
1706 !is_utf8_string_loc(s, len, &f))
1707 /* Emulate :encoding(utf8) warning in the same case. */
1708 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1709 "utf8 \"\\x%02X\" does not map to Unicode",
1710 f < (U8*)SvEND(sv) ? *f : 0);
1712 if (gimme == G_ARRAY) {
1713 if (SvLEN(sv) - SvCUR(sv) > 20) {
1714 SvPV_shrink_to_cur(sv);
1716 sv = sv_2mortal(newSV(80));
1719 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1720 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1721 const STRLEN new_len
1722 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1723 SvPV_renew(sv, new_len);
1732 register PERL_CONTEXT *cx;
1733 I32 gimme = OP_GIMME(PL_op, -1);
1736 if (cxstack_ix >= 0)
1737 gimme = cxstack[cxstack_ix].blk_gimme;
1745 PUSHBLOCK(cx, CXt_BLOCK, SP);
1755 SV * const keysv = POPs;
1756 HV * const hv = (HV*)POPs;
1757 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1758 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1760 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1763 if (SvTYPE(hv) == SVt_PVHV) {
1764 if (PL_op->op_private & OPpLVAL_INTRO) {
1767 /* does the element we're localizing already exist? */
1769 /* can we determine whether it exists? */
1771 || mg_find((SV*)hv, PERL_MAGIC_env)
1772 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1773 /* Try to preserve the existenceness of a tied hash
1774 * element by using EXISTS and DELETE if possible.
1775 * Fallback to FETCH and STORE otherwise */
1776 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1777 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1778 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1780 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1783 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1784 svp = he ? &HeVAL(he) : NULL;
1790 if (!svp || *svp == &PL_sv_undef) {
1794 DIE(aTHX_ PL_no_helem_sv, keysv);
1796 lv = sv_newmortal();
1797 sv_upgrade(lv, SVt_PVLV);
1799 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1800 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1801 LvTARG(lv) = SvREFCNT_inc(hv);
1806 if (PL_op->op_private & OPpLVAL_INTRO) {
1807 if (HvNAME_get(hv) && isGV(*svp))
1808 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1812 const char * const key = SvPV_const(keysv, keylen);
1813 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1815 save_helem(hv, keysv, svp);
1818 else if (PL_op->op_private & OPpDEREF)
1819 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1821 sv = (svp ? *svp : &PL_sv_undef);
1822 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1823 * Pushing the magical RHS on to the stack is useless, since
1824 * that magic is soon destined to be misled by the local(),
1825 * and thus the later pp_sassign() will fail to mg_get() the
1826 * old value. This should also cure problems with delayed
1827 * mg_get()s. GSAR 98-07-03 */
1828 if (!lval && SvGMAGICAL(sv))
1829 sv = sv_mortalcopy(sv);
1837 register PERL_CONTEXT *cx;
1842 if (PL_op->op_flags & OPf_SPECIAL) {
1843 cx = &cxstack[cxstack_ix];
1844 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1849 gimme = OP_GIMME(PL_op, -1);
1851 if (cxstack_ix >= 0)
1852 gimme = cxstack[cxstack_ix].blk_gimme;
1858 if (gimme == G_VOID)
1860 else if (gimme == G_SCALAR) {
1864 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1867 *MARK = sv_mortalcopy(TOPs);
1870 *MARK = &PL_sv_undef;
1874 else if (gimme == G_ARRAY) {
1875 /* in case LEAVE wipes old return values */
1877 for (mark = newsp + 1; mark <= SP; mark++) {
1878 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1879 *mark = sv_mortalcopy(*mark);
1880 TAINT_NOT; /* Each item is independent */
1884 PL_curpm = newpm; /* Don't pop $1 et al till now */
1894 register PERL_CONTEXT *cx;
1900 cx = &cxstack[cxstack_ix];
1901 if (CxTYPE(cx) != CXt_LOOP)
1902 DIE(aTHX_ "panic: pp_iter");
1904 itersvp = CxITERVAR(cx);
1905 av = cx->blk_loop.iterary;
1906 if (SvTYPE(av) != SVt_PVAV) {
1907 /* iterate ($min .. $max) */
1908 if (cx->blk_loop.iterlval) {
1909 /* string increment */
1910 register SV* cur = cx->blk_loop.iterlval;
1912 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1913 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1914 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1915 /* safe to reuse old SV */
1916 sv_setsv(*itersvp, cur);
1920 /* we need a fresh SV every time so that loop body sees a
1921 * completely new SV for closures/references to work as
1924 *itersvp = newSVsv(cur);
1925 SvREFCNT_dec(oldsv);
1927 if (strEQ(SvPVX_const(cur), max))
1928 sv_setiv(cur, 0); /* terminate next time */
1935 /* integer increment */
1936 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1939 /* don't risk potential race */
1940 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1941 /* safe to reuse old SV */
1942 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1946 /* we need a fresh SV every time so that loop body sees a
1947 * completely new SV for closures/references to work as they
1950 *itersvp = newSViv(cx->blk_loop.iterix++);
1951 SvREFCNT_dec(oldsv);
1957 if (PL_op->op_private & OPpITER_REVERSED) {
1958 /* In reverse, use itermax as the min :-) */
1959 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1962 if (SvMAGICAL(av) || AvREIFY(av)) {
1963 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1964 sv = svp ? *svp : NULL;
1967 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1971 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1975 if (SvMAGICAL(av) || AvREIFY(av)) {
1976 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1977 sv = svp ? *svp : NULL;
1980 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1984 if (sv && SvIS_FREED(sv)) {
1986 Perl_croak(aTHX_ "Use of freed value in iteration");
1993 if (av != PL_curstack && sv == &PL_sv_undef) {
1994 SV *lv = cx->blk_loop.iterlval;
1995 if (lv && SvREFCNT(lv) > 1) {
2000 SvREFCNT_dec(LvTARG(lv));
2002 lv = cx->blk_loop.iterlval = newSV(0);
2003 sv_upgrade(lv, SVt_PVLV);
2005 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2007 LvTARG(lv) = SvREFCNT_inc(av);
2008 LvTARGOFF(lv) = cx->blk_loop.iterix;
2009 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2014 *itersvp = SvREFCNT_inc(sv);
2015 SvREFCNT_dec(oldsv);
2023 register PMOP *pm = cPMOP;
2039 register REGEXP *rx = PM_GETRE(pm);
2041 int force_on_match = 0;
2042 const I32 oldsave = PL_savestack_ix;
2044 bool doutf8 = FALSE;
2045 #ifdef PERL_OLD_COPY_ON_WRITE
2050 /* known replacement string? */
2051 dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2052 if (PL_op->op_flags & OPf_STACKED)
2054 else if (PL_op->op_private & OPpTARGET_MY)
2061 #ifdef PERL_OLD_COPY_ON_WRITE
2062 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2063 because they make integers such as 256 "false". */
2064 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2067 sv_force_normal_flags(TARG,0);
2070 #ifdef PERL_OLD_COPY_ON_WRITE
2074 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2075 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2076 DIE(aTHX_ PL_no_modify);
2079 s = SvPV_mutable(TARG, len);
2080 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2082 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2083 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2088 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2092 DIE(aTHX_ "panic: pp_subst");
2095 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2096 maxiters = 2 * slen + 10; /* We can match twice at each
2097 position, once with zero-length,
2098 second time with non-zero. */
2100 if (!rx->prelen && PL_curpm) {
2104 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2105 || (pm->op_pmflags & PMf_EVAL))
2106 ? REXEC_COPY_STR : 0;
2108 r_flags |= REXEC_SCREAM;
2111 if (rx->reganch & RE_USE_INTUIT) {
2113 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2117 /* How to do it in subst? */
2118 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2120 && ((rx->reganch & ROPT_NOSCAN)
2121 || !((rx->reganch & RE_INTUIT_TAIL)
2122 && (r_flags & REXEC_SCREAM))))
2127 /* only replace once? */
2128 once = !(rpm->op_pmflags & PMf_GLOBAL);
2130 /* known replacement string? */
2132 /* replacement needing upgrading? */
2133 if (DO_UTF8(TARG) && !doutf8) {
2134 nsv = sv_newmortal();
2137 sv_recode_to_utf8(nsv, PL_encoding);
2139 sv_utf8_upgrade(nsv);
2140 c = SvPV_const(nsv, clen);
2144 c = SvPV_const(dstr, clen);
2145 doutf8 = DO_UTF8(dstr);
2153 /* can do inplace substitution? */
2155 #ifdef PERL_OLD_COPY_ON_WRITE
2158 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2159 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2160 && (!doutf8 || SvUTF8(TARG))) {
2161 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2162 r_flags | REXEC_CHECKED))
2166 LEAVE_SCOPE(oldsave);
2169 #ifdef PERL_OLD_COPY_ON_WRITE
2170 if (SvIsCOW(TARG)) {
2171 assert (!force_on_match);
2175 if (force_on_match) {
2177 s = SvPV_force(TARG, len);
2182 SvSCREAM_off(TARG); /* disable possible screamer */
2184 rxtainted |= RX_MATCH_TAINTED(rx);
2185 m = orig + rx->startp[0];
2186 d = orig + rx->endp[0];
2188 if (m - s > strend - d) { /* faster to shorten from end */
2190 Copy(c, m, clen, char);
2195 Move(d, m, i, char);
2199 SvCUR_set(TARG, m - s);
2201 else if ((i = m - s)) { /* faster from front */
2209 Copy(c, m, clen, char);
2214 Copy(c, d, clen, char);
2219 TAINT_IF(rxtainted & 1);
2225 if (iters++ > maxiters)
2226 DIE(aTHX_ "Substitution loop");
2227 rxtainted |= RX_MATCH_TAINTED(rx);
2228 m = rx->startp[0] + orig;
2231 Move(s, d, i, char);
2235 Copy(c, d, clen, char);
2238 s = rx->endp[0] + orig;
2239 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2241 /* don't match same null twice */
2242 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2245 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2246 Move(s, d, i+1, char); /* include the NUL */
2248 TAINT_IF(rxtainted & 1);
2250 PUSHs(sv_2mortal(newSViv((I32)iters)));
2252 (void)SvPOK_only_UTF8(TARG);
2253 TAINT_IF(rxtainted);
2254 if (SvSMAGICAL(TARG)) {
2262 LEAVE_SCOPE(oldsave);
2266 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2267 r_flags | REXEC_CHECKED))
2269 if (force_on_match) {
2271 s = SvPV_force(TARG, len);
2274 #ifdef PERL_OLD_COPY_ON_WRITE
2277 rxtainted |= RX_MATCH_TAINTED(rx);
2278 dstr = newSVpvn(m, s-m);
2283 register PERL_CONTEXT *cx;
2285 (void)ReREFCNT_inc(rx);
2287 RETURNOP(cPMOP->op_pmreplroot);
2289 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2291 if (iters++ > maxiters)
2292 DIE(aTHX_ "Substitution loop");
2293 rxtainted |= RX_MATCH_TAINTED(rx);
2294 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2299 strend = s + (strend - m);
2301 m = rx->startp[0] + orig;
2302 if (doutf8 && !SvUTF8(dstr))
2303 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2305 sv_catpvn(dstr, s, m-s);
2306 s = rx->endp[0] + orig;
2308 sv_catpvn(dstr, c, clen);
2311 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2312 TARG, NULL, r_flags));
2313 if (doutf8 && !DO_UTF8(TARG))
2314 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2316 sv_catpvn(dstr, s, strend - s);
2318 #ifdef PERL_OLD_COPY_ON_WRITE
2319 /* The match may make the string COW. If so, brilliant, because that's
2320 just saved us one malloc, copy and free - the regexp has donated
2321 the old buffer, and we malloc an entirely new one, rather than the
2322 regexp malloc()ing a buffer and copying our original, only for
2323 us to throw it away here during the substitution. */
2324 if (SvIsCOW(TARG)) {
2325 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2331 SvPV_set(TARG, SvPVX(dstr));
2332 SvCUR_set(TARG, SvCUR(dstr));
2333 SvLEN_set(TARG, SvLEN(dstr));
2334 doutf8 |= DO_UTF8(dstr);
2335 SvPV_set(dstr, NULL);
2338 TAINT_IF(rxtainted & 1);
2340 PUSHs(sv_2mortal(newSViv((I32)iters)));
2342 (void)SvPOK_only(TARG);
2345 TAINT_IF(rxtainted);
2348 LEAVE_SCOPE(oldsave);
2357 LEAVE_SCOPE(oldsave);
2366 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2367 ++*PL_markstack_ptr;
2368 LEAVE; /* exit inner scope */
2371 if (PL_stack_base + *PL_markstack_ptr > SP) {
2373 const I32 gimme = GIMME_V;
2375 LEAVE; /* exit outer scope */
2376 (void)POPMARK; /* pop src */
2377 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2378 (void)POPMARK; /* pop dst */
2379 SP = PL_stack_base + POPMARK; /* pop original mark */
2380 if (gimme == G_SCALAR) {
2381 if (PL_op->op_private & OPpGREP_LEX) {
2382 SV* const sv = sv_newmortal();
2383 sv_setiv(sv, items);
2391 else if (gimme == G_ARRAY)
2398 ENTER; /* enter inner scope */
2401 src = PL_stack_base[*PL_markstack_ptr];
2403 if (PL_op->op_private & OPpGREP_LEX)
2404 PAD_SVl(PL_op->op_targ) = src;
2408 RETURNOP(cLOGOP->op_other);
2419 register PERL_CONTEXT *cx;
2422 if (CxMULTICALL(&cxstack[cxstack_ix]))
2426 cxstack_ix++; /* temporarily protect top context */
2429 if (gimme == G_SCALAR) {
2432 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2434 *MARK = SvREFCNT_inc(TOPs);
2439 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2441 *MARK = sv_mortalcopy(sv);
2446 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2450 *MARK = &PL_sv_undef;
2454 else if (gimme == G_ARRAY) {
2455 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2456 if (!SvTEMP(*MARK)) {
2457 *MARK = sv_mortalcopy(*MARK);
2458 TAINT_NOT; /* Each item is independent */
2466 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2467 PL_curpm = newpm; /* ... and pop $1 et al */
2470 return cx->blk_sub.retop;
2473 /* This duplicates the above code because the above code must not
2474 * get any slower by more conditions */
2482 register PERL_CONTEXT *cx;
2485 if (CxMULTICALL(&cxstack[cxstack_ix]))
2489 cxstack_ix++; /* temporarily protect top context */
2493 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2494 /* We are an argument to a function or grep().
2495 * This kind of lvalueness was legal before lvalue
2496 * subroutines too, so be backward compatible:
2497 * cannot report errors. */
2499 /* Scalar context *is* possible, on the LHS of -> only,
2500 * as in f()->meth(). But this is not an lvalue. */
2501 if (gimme == G_SCALAR)
2503 if (gimme == G_ARRAY) {
2504 if (!CvLVALUE(cx->blk_sub.cv))
2505 goto temporise_array;
2506 EXTEND_MORTAL(SP - newsp);
2507 for (mark = newsp + 1; mark <= SP; mark++) {
2510 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2511 *mark = sv_mortalcopy(*mark);
2513 /* Can be a localized value subject to deletion. */
2514 PL_tmps_stack[++PL_tmps_ix] = *mark;
2515 (void)SvREFCNT_inc(*mark);
2520 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2521 /* Here we go for robustness, not for speed, so we change all
2522 * the refcounts so the caller gets a live guy. Cannot set
2523 * TEMP, so sv_2mortal is out of question. */
2524 if (!CvLVALUE(cx->blk_sub.cv)) {
2530 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2532 if (gimme == G_SCALAR) {
2536 /* Temporaries are bad unless they happen to be elements
2537 * of a tied hash or array */
2538 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2539 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2545 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2546 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2547 : "a readonly value" : "a temporary");
2549 else { /* Can be a localized value
2550 * subject to deletion. */
2551 PL_tmps_stack[++PL_tmps_ix] = *mark;
2552 (void)SvREFCNT_inc(*mark);
2555 else { /* Should not happen? */
2561 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2562 (MARK > SP ? "Empty array" : "Array"));
2566 else if (gimme == G_ARRAY) {
2567 EXTEND_MORTAL(SP - newsp);
2568 for (mark = newsp + 1; mark <= SP; mark++) {
2569 if (*mark != &PL_sv_undef
2570 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2571 /* Might be flattened array after $#array = */
2578 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2579 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2582 /* Can be a localized value subject to deletion. */
2583 PL_tmps_stack[++PL_tmps_ix] = *mark;
2584 (void)SvREFCNT_inc(*mark);
2590 if (gimme == G_SCALAR) {
2594 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2596 *MARK = SvREFCNT_inc(TOPs);
2601 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2603 *MARK = sv_mortalcopy(sv);
2608 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2612 *MARK = &PL_sv_undef;
2616 else if (gimme == G_ARRAY) {
2618 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2619 if (!SvTEMP(*MARK)) {
2620 *MARK = sv_mortalcopy(*MARK);
2621 TAINT_NOT; /* Each item is independent */
2630 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2631 PL_curpm = newpm; /* ... and pop $1 et al */
2634 return cx->blk_sub.retop;
2639 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2642 SV * const dbsv = GvSVn(PL_DBsub);
2645 if (!PERLDB_SUB_NN) {
2648 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2649 || strEQ(GvNAME(gv), "END")
2650 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2651 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2652 && (gv = (GV*)*svp) ))) {
2653 /* Use GV from the stack as a fallback. */
2654 /* GV is potentially non-unique, or contain different CV. */
2655 SV * const tmp = newRV((SV*)cv);
2656 sv_setsv(dbsv, tmp);
2660 gv_efullname3(dbsv, gv, NULL);
2664 const int type = SvTYPE(dbsv);
2665 if (type < SVt_PVIV && type != SVt_IV)
2666 sv_upgrade(dbsv, SVt_PVIV);
2667 (void)SvIOK_on(dbsv);
2668 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2672 PL_curcopdb = PL_curcop;
2673 cv = GvCV(PL_DBsub);
2682 register PERL_CONTEXT *cx;
2684 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2687 DIE(aTHX_ "Not a CODE reference");
2688 switch (SvTYPE(sv)) {
2689 /* This is overwhelming the most common case: */
2691 if (!(cv = GvCVu((GV*)sv))) {
2693 cv = sv_2cv(sv, &stash, &gv, 0);
2704 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2706 SP = PL_stack_base + POPMARK;
2709 if (SvGMAGICAL(sv)) {
2713 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2716 sym = SvPV_nolen_const(sv);
2719 DIE(aTHX_ PL_no_usym, "a subroutine");
2720 if (PL_op->op_private & HINT_STRICT_REFS)
2721 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2722 cv = get_cv(sym, TRUE);
2727 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2728 tryAMAGICunDEREF(to_cv);
2731 if (SvTYPE(cv) == SVt_PVCV)
2736 DIE(aTHX_ "Not a CODE reference");
2737 /* This is the second most common case: */
2747 if (!CvROOT(cv) && !CvXSUB(cv)) {
2751 /* anonymous or undef'd function leaves us no recourse */
2752 if (CvANON(cv) || !(gv = CvGV(cv)))
2753 DIE(aTHX_ "Undefined subroutine called");
2755 /* autoloaded stub? */
2756 if (cv != GvCV(gv)) {
2759 /* should call AUTOLOAD now? */
2762 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2769 sub_name = sv_newmortal();
2770 gv_efullname3(sub_name, gv, NULL);
2771 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2775 DIE(aTHX_ "Not a CODE reference");
2780 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2781 if (CvASSERTION(cv) && PL_DBassertion)
2782 sv_setiv(PL_DBassertion, 1);
2784 cv = get_db_sub(&sv, cv);
2785 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2786 DIE(aTHX_ "No DB::sub routine defined");
2789 if (!(CvISXSUB(cv))) {
2790 /* This path taken at least 75% of the time */
2792 register I32 items = SP - MARK;
2793 AV* const padlist = CvPADLIST(cv);
2794 PUSHBLOCK(cx, CXt_SUB, MARK);
2796 cx->blk_sub.retop = PL_op->op_next;
2798 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2799 * that eval'' ops within this sub know the correct lexical space.
2800 * Owing the speed considerations, we choose instead to search for
2801 * the cv using find_runcv() when calling doeval().
2803 if (CvDEPTH(cv) >= 2) {
2804 PERL_STACK_OVERFLOW_CHECK();
2805 pad_push(padlist, CvDEPTH(cv));
2808 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2811 AV* const av = (AV*)PAD_SVl(0);
2813 /* @_ is normally not REAL--this should only ever
2814 * happen when DB::sub() calls things that modify @_ */
2819 cx->blk_sub.savearray = GvAV(PL_defgv);
2820 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2821 CX_CURPAD_SAVE(cx->blk_sub);
2822 cx->blk_sub.argarray = av;
2825 if (items > AvMAX(av) + 1) {
2826 SV **ary = AvALLOC(av);
2827 if (AvARRAY(av) != ary) {
2828 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2829 SvPV_set(av, (char*)ary);
2831 if (items > AvMAX(av) + 1) {
2832 AvMAX(av) = items - 1;
2833 Renew(ary,items,SV*);
2835 SvPV_set(av, (char*)ary);
2838 Copy(MARK,AvARRAY(av),items,SV*);
2839 AvFILLp(av) = items - 1;
2847 /* warning must come *after* we fully set up the context
2848 * stuff so that __WARN__ handlers can safely dounwind()
2851 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2852 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2853 sub_crush_depth(cv);
2855 DEBUG_S(PerlIO_printf(Perl_debug_log,
2856 "%p entersub returning %p\n", thr, CvSTART(cv)));
2858 RETURNOP(CvSTART(cv));
2861 I32 markix = TOPMARK;
2866 /* Need to copy @_ to stack. Alternative may be to
2867 * switch stack to @_, and copy return values
2868 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2869 AV * const av = GvAV(PL_defgv);
2870 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2873 /* Mark is at the end of the stack. */
2875 Copy(AvARRAY(av), SP + 1, items, SV*);
2880 /* We assume first XSUB in &DB::sub is the called one. */
2882 SAVEVPTR(PL_curcop);
2883 PL_curcop = PL_curcopdb;
2886 /* Do we need to open block here? XXXX */
2887 (void)(*CvXSUB(cv))(aTHX_ cv);
2889 /* Enforce some sanity in scalar context. */
2890 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2891 if (markix > PL_stack_sp - PL_stack_base)
2892 *(PL_stack_base + markix) = &PL_sv_undef;
2894 *(PL_stack_base + markix) = *PL_stack_sp;
2895 PL_stack_sp = PL_stack_base + markix;
2903 Perl_sub_crush_depth(pTHX_ CV *cv)
2906 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2908 SV* const tmpstr = sv_newmortal();
2909 gv_efullname3(tmpstr, CvGV(cv), NULL);
2910 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2919 SV* const elemsv = POPs;
2920 IV elem = SvIV(elemsv);
2921 AV* const av = (AV*)POPs;
2922 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2923 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2926 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2927 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2929 elem -= PL_curcop->cop_arybase;
2930 if (SvTYPE(av) != SVt_PVAV)
2932 svp = av_fetch(av, elem, lval && !defer);
2934 #ifdef PERL_MALLOC_WRAP
2935 if (SvUOK(elemsv)) {
2936 const UV uv = SvUV(elemsv);
2937 elem = uv > IV_MAX ? IV_MAX : uv;
2939 else if (SvNOK(elemsv))
2940 elem = (IV)SvNV(elemsv);
2942 static const char oom_array_extend[] =
2943 "Out of memory during array extend"; /* Duplicated in av.c */
2944 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2947 if (!svp || *svp == &PL_sv_undef) {
2950 DIE(aTHX_ PL_no_aelem, elem);
2951 lv = sv_newmortal();
2952 sv_upgrade(lv, SVt_PVLV);
2954 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2955 LvTARG(lv) = SvREFCNT_inc(av);
2956 LvTARGOFF(lv) = elem;
2961 if (PL_op->op_private & OPpLVAL_INTRO)
2962 save_aelem(av, elem, svp);
2963 else if (PL_op->op_private & OPpDEREF)
2964 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2966 sv = (svp ? *svp : &PL_sv_undef);
2967 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2968 sv = sv_mortalcopy(sv);
2974 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2979 Perl_croak(aTHX_ PL_no_modify);
2980 if (SvTYPE(sv) < SVt_RV)
2981 sv_upgrade(sv, SVt_RV);
2982 else if (SvTYPE(sv) >= SVt_PV) {
2989 SvRV_set(sv, newSV(0));
2992 SvRV_set(sv, (SV*)newAV());
2995 SvRV_set(sv, (SV*)newHV());
3006 SV* const sv = TOPs;
3009 SV* const rsv = SvRV(sv);
3010 if (SvTYPE(rsv) == SVt_PVCV) {
3016 SETs(method_common(sv, NULL));
3023 SV* const sv = cSVOP_sv;
3024 U32 hash = SvSHARED_HASH(sv);
3026 XPUSHs(method_common(sv, &hash));
3031 S_method_common(pTHX_ SV* meth, U32* hashp)
3038 const char* packname = NULL;
3041 const char * const name = SvPV_const(meth, namelen);
3042 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3045 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3053 /* this isn't a reference */
3054 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3055 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3057 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3064 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3065 !(ob=(SV*)GvIO(iogv)))
3067 /* this isn't the name of a filehandle either */
3069 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3070 ? !isIDFIRST_utf8((U8*)packname)
3071 : !isIDFIRST(*packname)
3074 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3075 SvOK(sv) ? "without a package or object reference"
3076 : "on an undefined value");
3078 /* assume it's a package name */
3079 stash = gv_stashpvn(packname, packlen, FALSE);
3083 SV* ref = newSViv(PTR2IV(stash));
3084 hv_store(PL_stashcache, packname, packlen, ref, 0);
3088 /* it _is_ a filehandle name -- replace with a reference */
3089 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3092 /* if we got here, ob should be a reference or a glob */
3093 if (!ob || !(SvOBJECT(ob)
3094 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3097 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3101 stash = SvSTASH(ob);
3104 /* NOTE: stash may be null, hope hv_fetch_ent and
3105 gv_fetchmethod can cope (it seems they can) */
3107 /* shortcut for simple names */
3109 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3111 gv = (GV*)HeVAL(he);
3112 if (isGV(gv) && GvCV(gv) &&
3113 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3114 return (SV*)GvCV(gv);
3118 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3121 /* This code tries to figure out just what went wrong with
3122 gv_fetchmethod. It therefore needs to duplicate a lot of
3123 the internals of that function. We can't move it inside
3124 Perl_gv_fetchmethod_autoload(), however, since that would
3125 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3128 const char* leaf = name;
3129 const char* sep = NULL;
3132 for (p = name; *p; p++) {
3134 sep = p, leaf = p + 1;
3135 else if (*p == ':' && *(p + 1) == ':')
3136 sep = p, leaf = p + 2;
3138 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3139 /* the method name is unqualified or starts with SUPER:: */
3140 bool need_strlen = 1;
3142 packname = CopSTASHPV(PL_curcop);
3145 HEK * const packhek = HvNAME_HEK(stash);
3147 packname = HEK_KEY(packhek);
3148 packlen = HEK_LEN(packhek);
3158 "Can't use anonymous symbol table for method lookup");
3160 else if (need_strlen)
3161 packlen = strlen(packname);
3165 /* the method name is qualified */
3167 packlen = sep - name;
3170 /* we're relying on gv_fetchmethod not autovivifying the stash */
3171 if (gv_stashpvn(packname, packlen, FALSE)) {
3173 "Can't locate object method \"%s\" via package \"%.*s\"",
3174 leaf, (int)packlen, packname);
3178 "Can't locate object method \"%s\" via package \"%.*s\""
3179 " (perhaps you forgot to load \"%.*s\"?)",
3180 leaf, (int)packlen, packname, (int)packlen, packname);
3183 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3188 * c-indentation-style: bsd
3190 * indent-tabs-mode: t
3193 * ex: set ts=8 sts=4 sw=4 noet: