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);
149 SvREFCNT_inc_simple_void(value);
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_void(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);
211 const char *rpv = NULL;
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 == */
357 /* we know iv is >= 0 */
358 SETs(boolSV((UV)iv == SvUVX(uvp)));
365 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
367 if (Perl_isnan(left) || Perl_isnan(right))
369 SETs(boolSV(left == right));
372 SETs(boolSV(TOPn == value));
381 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
382 DIE(aTHX_ PL_no_modify);
383 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
384 && SvIVX(TOPs) != IV_MAX)
386 SvIV_set(TOPs, SvIVX(TOPs) + 1);
387 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
389 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
401 if (PL_op->op_type == OP_OR)
403 RETURNOP(cLOGOP->op_other);
412 const int op_type = PL_op->op_type;
413 const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
417 if (!sv || !SvANY(sv)) {
418 if (op_type == OP_DOR)
420 RETURNOP(cLOGOP->op_other);
422 } else if (op_type == OP_DEFINED) {
424 if (!sv || !SvANY(sv))
427 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
430 switch (SvTYPE(sv)) {
432 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
436 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
440 if (CvROOT(sv) || CvXSUB(sv))
453 if(op_type == OP_DOR)
455 RETURNOP(cLOGOP->op_other);
457 /* assuming OP_DEFINED */
465 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
466 useleft = USE_LEFT(TOPm1s);
467 #ifdef PERL_PRESERVE_IVUV
468 /* We must see if we can perform the addition with integers if possible,
469 as the integer code detects overflow while the NV code doesn't.
470 If either argument hasn't had a numeric conversion yet attempt to get
471 the IV. It's important to do this now, rather than just assuming that
472 it's not IOK as a PV of "9223372036854775806" may not take well to NV
473 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
474 integer in case the second argument is IV=9223372036854775806
475 We can (now) rely on sv_2iv to do the right thing, only setting the
476 public IOK flag if the value in the NV (or PV) slot is truly integer.
478 A side effect is that this also aggressively prefers integer maths over
479 fp maths for integer values.
481 How to detect overflow?
483 C 99 section 6.2.6.1 says
485 The range of nonnegative values of a signed integer type is a subrange
486 of the corresponding unsigned integer type, and the representation of
487 the same value in each type is the same. A computation involving
488 unsigned operands can never overflow, because a result that cannot be
489 represented by the resulting unsigned integer type is reduced modulo
490 the number that is one greater than the largest value that can be
491 represented by the resulting type.
495 which I read as "unsigned ints wrap."
497 signed integer overflow seems to be classed as "exception condition"
499 If an exceptional condition occurs during the evaluation of an
500 expression (that is, if the result is not mathematically defined or not
501 in the range of representable values for its type), the behavior is
504 (6.5, the 5th paragraph)
506 I had assumed that on 2s complement machines signed arithmetic would
507 wrap, hence coded pp_add and pp_subtract on the assumption that
508 everything perl builds on would be happy. After much wailing and
509 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
510 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
511 unsigned code below is actually shorter than the old code. :-)
516 /* Unless the left argument is integer in range we are going to have to
517 use NV maths. Hence only attempt to coerce the right argument if
518 we know the left is integer. */
526 /* left operand is undef, treat as zero. + 0 is identity,
527 Could SETi or SETu right now, but space optimise by not adding
528 lots of code to speed up what is probably a rarish case. */
530 /* Left operand is defined, so is it IV? */
533 if ((auvok = SvUOK(TOPm1s)))
536 register const IV aiv = SvIVX(TOPm1s);
539 auvok = 1; /* Now acting as a sign flag. */
540 } else { /* 2s complement assumption for IV_MIN */
548 bool result_good = 0;
551 bool buvok = SvUOK(TOPs);
556 register const IV biv = SvIVX(TOPs);
563 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
564 else "IV" now, independent of how it came in.
565 if a, b represents positive, A, B negative, a maps to -A etc
570 all UV maths. negate result if A negative.
571 add if signs same, subtract if signs differ. */
577 /* Must get smaller */
583 /* result really should be -(auv-buv). as its negation
584 of true value, need to swap our result flag */
601 if (result <= (UV)IV_MIN)
604 /* result valid, but out of range for IV. */
609 } /* Overflow, drop through to NVs. */
616 /* left operand is undef, treat as zero. + 0.0 is identity. */
620 SETn( value + TOPn );
628 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
629 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
630 const U32 lval = PL_op->op_flags & OPf_MOD;
631 SV** const svp = av_fetch(av, PL_op->op_private, lval);
632 SV *sv = (svp ? *svp : &PL_sv_undef);
634 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
635 sv = sv_mortalcopy(sv);
642 dVAR; dSP; dMARK; dTARGET;
644 do_join(TARG, *MARK, MARK, SP);
655 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
656 * will be enough to hold an OP*.
658 SV* const sv = sv_newmortal();
659 sv_upgrade(sv, SVt_PVLV);
661 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
669 /* Oversized hot code. */
673 dVAR; dSP; dMARK; dORIGMARK;
677 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
679 if (gv && (io = GvIO(gv))
680 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
683 if (MARK == ORIGMARK) {
684 /* If using default handle then we need to make space to
685 * pass object as 1st arg, so move other args up ...
689 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
693 *MARK = SvTIED_obj((SV*)io, mg);
696 call_method("PRINT", G_SCALAR);
704 if (!(io = GvIO(gv))) {
705 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
706 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
708 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
709 report_evil_fh(gv, io, PL_op->op_type);
710 SETERRNO(EBADF,RMS_IFI);
713 else if (!(fp = IoOFP(io))) {
714 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
716 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
717 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
718 report_evil_fh(gv, io, PL_op->op_type);
720 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
725 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
727 if (!do_print(*MARK, fp))
731 if (!do_print(PL_ofs_sv, fp)) { /* $, */
740 if (!do_print(*MARK, fp))
748 if (PL_ors_sv && SvOK(PL_ors_sv))
749 if (!do_print(PL_ors_sv, fp)) /* $\ */
752 if (IoFLAGS(io) & IOf_FLUSH)
753 if (PerlIO_flush(fp) == EOF)
763 XPUSHs(&PL_sv_undef);
774 tryAMAGICunDEREF(to_av);
777 if (SvTYPE(av) != SVt_PVAV)
778 DIE(aTHX_ "Not an ARRAY reference");
779 if (PL_op->op_flags & OPf_REF) {
784 if (GIMME == G_SCALAR)
785 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
789 else if (PL_op->op_flags & OPf_MOD
790 && PL_op->op_private & OPpLVAL_INTRO)
791 Perl_croak(aTHX_ PL_no_localize_ref);
794 if (SvTYPE(sv) == SVt_PVAV) {
796 if (PL_op->op_flags & OPf_REF) {
801 if (GIMME == G_SCALAR)
802 Perl_croak(aTHX_ "Can't return array to lvalue"
811 if (SvTYPE(sv) != SVt_PVGV) {
812 if (SvGMAGICAL(sv)) {
818 if (PL_op->op_flags & OPf_REF ||
819 PL_op->op_private & HINT_STRICT_REFS)
820 DIE(aTHX_ PL_no_usym, "an ARRAY");
821 if (ckWARN(WARN_UNINITIALIZED))
823 if (GIMME == G_ARRAY) {
829 if ((PL_op->op_flags & OPf_SPECIAL) &&
830 !(PL_op->op_flags & OPf_MOD))
832 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
834 && (!is_gv_magical_sv(sv,0)
835 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
841 if (PL_op->op_private & HINT_STRICT_REFS)
842 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
843 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
850 if (PL_op->op_private & OPpLVAL_INTRO)
852 if (PL_op->op_flags & OPf_REF) {
857 if (GIMME == G_SCALAR)
858 Perl_croak(aTHX_ "Can't return array to lvalue"
866 if (GIMME == G_ARRAY) {
867 const I32 maxarg = AvFILL(av) + 1;
868 (void)POPs; /* XXXX May be optimized away? */
870 if (SvRMAGICAL(av)) {
872 for (i=0; i < (U32)maxarg; i++) {
873 SV ** const svp = av_fetch(av, i, FALSE);
874 /* See note in pp_helem, and bug id #27839 */
876 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
881 Copy(AvARRAY(av), SP+1, maxarg, SV*);
885 else if (GIMME_V == G_SCALAR) {
887 const I32 maxarg = AvFILL(av) + 1;
897 const I32 gimme = GIMME_V;
898 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
902 tryAMAGICunDEREF(to_hv);
905 if (SvTYPE(hv) != SVt_PVHV)
906 DIE(aTHX_ "Not a HASH reference");
907 if (PL_op->op_flags & OPf_REF) {
912 if (gimme != G_ARRAY)
913 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
917 else if (PL_op->op_flags & OPf_MOD
918 && PL_op->op_private & OPpLVAL_INTRO)
919 Perl_croak(aTHX_ PL_no_localize_ref);
922 if (SvTYPE(sv) == SVt_PVHV) {
924 if (PL_op->op_flags & OPf_REF) {
929 if (gimme != G_ARRAY)
930 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
938 if (SvTYPE(sv) != SVt_PVGV) {
939 if (SvGMAGICAL(sv)) {
945 if (PL_op->op_flags & OPf_REF ||
946 PL_op->op_private & HINT_STRICT_REFS)
947 DIE(aTHX_ PL_no_usym, "a HASH");
948 if (ckWARN(WARN_UNINITIALIZED))
950 if (gimme == G_ARRAY) {
956 if ((PL_op->op_flags & OPf_SPECIAL) &&
957 !(PL_op->op_flags & OPf_MOD))
959 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
961 && (!is_gv_magical_sv(sv,0)
962 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
968 if (PL_op->op_private & HINT_STRICT_REFS)
969 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
970 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
977 if (PL_op->op_private & OPpLVAL_INTRO)
979 if (PL_op->op_flags & OPf_REF) {
984 if (gimme != G_ARRAY)
985 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
992 if (gimme == G_ARRAY) { /* array wanted */
993 *PL_stack_sp = (SV*)hv;
996 else if (gimme == G_SCALAR) {
998 TARG = Perl_hv_scalar(aTHX_ hv);
1005 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1012 if (ckWARN(WARN_MISC)) {
1014 if (relem == firstrelem &&
1016 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1017 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1019 err = "Reference found where even-sized list expected";
1022 err = "Odd number of elements in hash assignment";
1023 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1027 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1028 if (SvMAGICAL(hash)) {
1029 if (SvSMAGICAL(tmpstr))
1041 SV **lastlelem = PL_stack_sp;
1042 SV **lastrelem = PL_stack_base + POPMARK;
1043 SV **firstrelem = PL_stack_base + POPMARK + 1;
1044 SV **firstlelem = lastrelem + 1;
1046 register SV **relem;
1047 register SV **lelem;
1057 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1060 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1063 /* If there's a common identifier on both sides we have to take
1064 * special care that assigning the identifier on the left doesn't
1065 * clobber a value on the right that's used later in the list.
1067 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1068 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1069 for (relem = firstrelem; relem <= lastrelem; relem++) {
1070 if ((sv = *relem)) {
1071 TAINT_NOT; /* Each item is independent */
1072 *relem = sv_mortalcopy(sv);
1082 while (lelem <= lastlelem) {
1083 TAINT_NOT; /* Each item stands on its own, taintwise. */
1085 switch (SvTYPE(sv)) {
1088 magic = SvMAGICAL(ary) != 0;
1090 av_extend(ary, lastrelem - relem);
1092 while (relem <= lastrelem) { /* gobble up all the rest */
1095 sv = newSVsv(*relem);
1097 didstore = av_store(ary,i++,sv);
1107 case SVt_PVHV: { /* normal hash */
1111 magic = SvMAGICAL(hash) != 0;
1113 firsthashrelem = relem;
1115 while (relem < lastrelem) { /* gobble up all the rest */
1117 sv = *relem ? *relem : &PL_sv_no;
1121 sv_setsv(tmpstr,*relem); /* value */
1122 *(relem++) = tmpstr;
1123 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1124 /* key overwrites an existing entry */
1126 didstore = hv_store_ent(hash,sv,tmpstr,0);
1128 if (SvSMAGICAL(tmpstr))
1135 if (relem == lastrelem) {
1136 do_oddball(hash, relem, firstrelem);
1142 if (SvIMMORTAL(sv)) {
1143 if (relem <= lastrelem)
1147 if (relem <= lastrelem) {
1148 sv_setsv(sv, *relem);
1152 sv_setsv(sv, &PL_sv_undef);
1157 if (PL_delaymagic & ~DM_DELAY) {
1158 if (PL_delaymagic & DM_UID) {
1159 #ifdef HAS_SETRESUID
1160 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1161 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1164 # ifdef HAS_SETREUID
1165 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1166 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1169 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1170 (void)setruid(PL_uid);
1171 PL_delaymagic &= ~DM_RUID;
1173 # endif /* HAS_SETRUID */
1175 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1176 (void)seteuid(PL_euid);
1177 PL_delaymagic &= ~DM_EUID;
1179 # endif /* HAS_SETEUID */
1180 if (PL_delaymagic & DM_UID) {
1181 if (PL_uid != PL_euid)
1182 DIE(aTHX_ "No setreuid available");
1183 (void)PerlProc_setuid(PL_uid);
1185 # endif /* HAS_SETREUID */
1186 #endif /* HAS_SETRESUID */
1187 PL_uid = PerlProc_getuid();
1188 PL_euid = PerlProc_geteuid();
1190 if (PL_delaymagic & DM_GID) {
1191 #ifdef HAS_SETRESGID
1192 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1193 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1196 # ifdef HAS_SETREGID
1197 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1198 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1201 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1202 (void)setrgid(PL_gid);
1203 PL_delaymagic &= ~DM_RGID;
1205 # endif /* HAS_SETRGID */
1207 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1208 (void)setegid(PL_egid);
1209 PL_delaymagic &= ~DM_EGID;
1211 # endif /* HAS_SETEGID */
1212 if (PL_delaymagic & DM_GID) {
1213 if (PL_gid != PL_egid)
1214 DIE(aTHX_ "No setregid available");
1215 (void)PerlProc_setgid(PL_gid);
1217 # endif /* HAS_SETREGID */
1218 #endif /* HAS_SETRESGID */
1219 PL_gid = PerlProc_getgid();
1220 PL_egid = PerlProc_getegid();
1222 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1226 if (gimme == G_VOID)
1227 SP = firstrelem - 1;
1228 else if (gimme == G_SCALAR) {
1231 SETi(lastrelem - firstrelem + 1 - duplicates);
1238 /* Removes from the stack the entries which ended up as
1239 * duplicated keys in the hash (fix for [perl #24380]) */
1240 Move(firsthashrelem + duplicates,
1241 firsthashrelem, duplicates, SV**);
1242 lastrelem -= duplicates;
1247 SP = firstrelem + (lastlelem - firstlelem);
1248 lelem = firstlelem + (relem - firstrelem);
1250 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1258 register PMOP * const pm = cPMOP;
1259 SV * const rv = sv_newmortal();
1260 SV * const sv = newSVrv(rv, "Regexp");
1261 if (pm->op_pmdynflags & PMdf_TAINTED)
1263 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1270 register PMOP *pm = cPMOP;
1272 register const char *t;
1273 register const char *s;
1276 I32 r_flags = REXEC_CHECKED;
1277 const char *truebase; /* Start of string */
1278 register REGEXP *rx = PM_GETRE(pm);
1280 const I32 gimme = GIMME;
1283 const I32 oldsave = PL_savestack_ix;
1284 I32 update_minmatch = 1;
1285 I32 had_zerolen = 0;
1287 if (PL_op->op_flags & OPf_STACKED)
1289 else if (PL_op->op_private & OPpTARGET_MY)
1296 PUTBACK; /* EVAL blocks need stack_sp. */
1297 s = SvPV_const(TARG, len);
1299 DIE(aTHX_ "panic: pp_match");
1301 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1302 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1305 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1307 /* PMdf_USED is set after a ?? matches once */
1308 if (pm->op_pmdynflags & PMdf_USED) {
1310 if (gimme == G_ARRAY)
1315 /* empty pattern special-cased to use last successful pattern if possible */
1316 if (!rx->prelen && PL_curpm) {
1321 if (rx->minlen > (I32)len)
1326 /* XXXX What part of this is needed with true \G-support? */
1327 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1329 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1330 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1331 if (mg && mg->mg_len >= 0) {
1332 if (!(rx->reganch & ROPT_GPOS_SEEN))
1333 rx->endp[0] = rx->startp[0] = mg->mg_len;
1334 else if (rx->reganch & ROPT_ANCH_GPOS) {
1335 r_flags |= REXEC_IGNOREPOS;
1336 rx->endp[0] = rx->startp[0] = mg->mg_len;
1338 minmatch = (mg->mg_flags & MGf_MINMATCH);
1339 update_minmatch = 0;
1343 if ((!global && rx->nparens)
1344 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1345 r_flags |= REXEC_COPY_STR;
1347 r_flags |= REXEC_SCREAM;
1350 if (global && rx->startp[0] != -1) {
1351 t = s = rx->endp[0] + truebase;
1352 if ((s + rx->minlen) > strend)
1354 if (update_minmatch++)
1355 minmatch = had_zerolen;
1357 if (rx->reganch & RE_USE_INTUIT &&
1358 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1359 /* FIXME - can PL_bostr be made const char *? */
1360 PL_bostr = (char *)truebase;
1361 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1365 if ( (rx->reganch & ROPT_CHECK_ALL)
1367 && ((rx->reganch & ROPT_NOSCAN)
1368 || !((rx->reganch & RE_INTUIT_TAIL)
1369 && (r_flags & REXEC_SCREAM)))
1370 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1373 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1376 if (dynpm->op_pmflags & PMf_ONCE)
1377 dynpm->op_pmdynflags |= PMdf_USED;
1386 RX_MATCH_TAINTED_on(rx);
1387 TAINT_IF(RX_MATCH_TAINTED(rx));
1388 if (gimme == G_ARRAY) {
1389 const I32 nparens = rx->nparens;
1390 I32 i = (global && !nparens) ? 1 : 0;
1392 SPAGAIN; /* EVAL blocks could move the stack. */
1393 EXTEND(SP, nparens + i);
1394 EXTEND_MORTAL(nparens + i);
1395 for (i = !i; i <= nparens; i++) {
1396 PUSHs(sv_newmortal());
1397 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1398 const I32 len = rx->endp[i] - rx->startp[i];
1399 s = rx->startp[i] + truebase;
1400 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1401 len < 0 || len > strend - s)
1402 DIE(aTHX_ "panic: pp_match start/end pointers");
1403 sv_setpvn(*SP, s, len);
1404 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1409 if (dynpm->op_pmflags & PMf_CONTINUE) {
1411 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1412 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1414 #ifdef PERL_OLD_COPY_ON_WRITE
1416 sv_force_normal_flags(TARG, 0);
1418 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1419 &PL_vtbl_mglob, NULL, 0);
1421 if (rx->startp[0] != -1) {
1422 mg->mg_len = rx->endp[0];
1423 if (rx->startp[0] == rx->endp[0])
1424 mg->mg_flags |= MGf_MINMATCH;
1426 mg->mg_flags &= ~MGf_MINMATCH;
1429 had_zerolen = (rx->startp[0] != -1
1430 && rx->startp[0] == rx->endp[0]);
1431 PUTBACK; /* EVAL blocks may use stack */
1432 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1437 LEAVE_SCOPE(oldsave);
1443 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1444 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1448 #ifdef PERL_OLD_COPY_ON_WRITE
1450 sv_force_normal_flags(TARG, 0);
1452 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1453 &PL_vtbl_mglob, NULL, 0);
1455 if (rx->startp[0] != -1) {
1456 mg->mg_len = rx->endp[0];
1457 if (rx->startp[0] == rx->endp[0])
1458 mg->mg_flags |= MGf_MINMATCH;
1460 mg->mg_flags &= ~MGf_MINMATCH;
1463 LEAVE_SCOPE(oldsave);
1467 yup: /* Confirmed by INTUIT */
1469 RX_MATCH_TAINTED_on(rx);
1470 TAINT_IF(RX_MATCH_TAINTED(rx));
1472 if (dynpm->op_pmflags & PMf_ONCE)
1473 dynpm->op_pmdynflags |= PMdf_USED;
1474 if (RX_MATCH_COPIED(rx))
1475 Safefree(rx->subbeg);
1476 RX_MATCH_COPIED_off(rx);
1479 /* FIXME - should rx->subbeg be const char *? */
1480 rx->subbeg = (char *) truebase;
1481 rx->startp[0] = s - truebase;
1482 if (RX_MATCH_UTF8(rx)) {
1483 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1484 rx->endp[0] = t - truebase;
1487 rx->endp[0] = s - truebase + rx->minlen;
1489 rx->sublen = strend - truebase;
1492 if (PL_sawampersand) {
1494 #ifdef PERL_OLD_COPY_ON_WRITE
1495 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1497 PerlIO_printf(Perl_debug_log,
1498 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1499 (int) SvTYPE(TARG), truebase, t,
1502 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1503 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1504 assert (SvPOKp(rx->saved_copy));
1509 rx->subbeg = savepvn(t, strend - t);
1510 #ifdef PERL_OLD_COPY_ON_WRITE
1511 rx->saved_copy = NULL;
1514 rx->sublen = strend - t;
1515 RX_MATCH_COPIED_on(rx);
1516 off = rx->startp[0] = s - t;
1517 rx->endp[0] = off + rx->minlen;
1519 else { /* startp/endp are used by @- @+. */
1520 rx->startp[0] = s - truebase;
1521 rx->endp[0] = s - truebase + rx->minlen;
1523 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1524 LEAVE_SCOPE(oldsave);
1529 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1530 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1531 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1536 LEAVE_SCOPE(oldsave);
1537 if (gimme == G_ARRAY)
1543 Perl_do_readline(pTHX)
1545 dVAR; dSP; dTARGETSTACKED;
1550 register IO * const io = GvIO(PL_last_in_gv);
1551 register const I32 type = PL_op->op_type;
1552 const I32 gimme = GIMME_V;
1555 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1558 XPUSHs(SvTIED_obj((SV*)io, mg));
1561 call_method("READLINE", gimme);
1564 if (gimme == G_SCALAR) {
1565 SV* const result = POPs;
1566 SvSetSV_nosteal(TARG, result);
1576 if (IoFLAGS(io) & IOf_ARGV) {
1577 if (IoFLAGS(io) & IOf_START) {
1579 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1580 IoFLAGS(io) &= ~IOf_START;
1581 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1582 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1583 SvSETMAGIC(GvSV(PL_last_in_gv));
1588 fp = nextargv(PL_last_in_gv);
1589 if (!fp) { /* Note: fp != IoIFP(io) */
1590 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1593 else if (type == OP_GLOB)
1594 fp = Perl_start_glob(aTHX_ POPs, io);
1596 else if (type == OP_GLOB)
1598 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1599 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1603 if ((!io || !(IoFLAGS(io) & IOf_START))
1604 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1606 if (type == OP_GLOB)
1607 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1608 "glob failed (can't start child: %s)",
1611 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1613 if (gimme == G_SCALAR) {
1614 /* undef TARG, and push that undefined value */
1615 if (type != OP_RCATLINE) {
1616 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1624 if (gimme == G_SCALAR) {
1628 else if (isGV_with_GP(sv)) {
1629 SvPV_force_nolen(sv);
1631 SvUPGRADE(sv, SVt_PV);
1632 tmplen = SvLEN(sv); /* remember if already alloced */
1633 if (!tmplen && !SvREADONLY(sv))
1634 Sv_Grow(sv, 80); /* try short-buffering it */
1636 if (type == OP_RCATLINE && SvOK(sv)) {
1638 SvPV_force_nolen(sv);
1644 sv = sv_2mortal(newSV(80));
1648 /* This should not be marked tainted if the fp is marked clean */
1649 #define MAYBE_TAINT_LINE(io, sv) \
1650 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1655 /* delay EOF state for a snarfed empty file */
1656 #define SNARF_EOF(gimme,rs,io,sv) \
1657 (gimme != G_SCALAR || SvCUR(sv) \
1658 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1662 if (!sv_gets(sv, fp, offset)
1664 || SNARF_EOF(gimme, PL_rs, io, sv)
1665 || PerlIO_error(fp)))
1667 PerlIO_clearerr(fp);
1668 if (IoFLAGS(io) & IOf_ARGV) {
1669 fp = nextargv(PL_last_in_gv);
1672 (void)do_close(PL_last_in_gv, FALSE);
1674 else if (type == OP_GLOB) {
1675 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1676 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1677 "glob failed (child exited with status %d%s)",
1678 (int)(STATUS_CURRENT >> 8),
1679 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1682 if (gimme == G_SCALAR) {
1683 if (type != OP_RCATLINE) {
1684 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1690 MAYBE_TAINT_LINE(io, sv);
1693 MAYBE_TAINT_LINE(io, sv);
1695 IoFLAGS(io) |= IOf_NOLINE;
1699 if (type == OP_GLOB) {
1702 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1703 char * const tmps = SvEND(sv) - 1;
1704 if (*tmps == *SvPVX_const(PL_rs)) {
1706 SvCUR_set(sv, SvCUR(sv) - 1);
1709 for (t1 = SvPVX_const(sv); *t1; t1++)
1710 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1711 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1713 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1714 (void)POPs; /* Unmatched wildcard? Chuck it... */
1717 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1718 if (ckWARN(WARN_UTF8)) {
1719 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1720 const STRLEN len = SvCUR(sv) - offset;
1723 if (!is_utf8_string_loc(s, len, &f))
1724 /* Emulate :encoding(utf8) warning in the same case. */
1725 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1726 "utf8 \"\\x%02X\" does not map to Unicode",
1727 f < (U8*)SvEND(sv) ? *f : 0);
1730 if (gimme == G_ARRAY) {
1731 if (SvLEN(sv) - SvCUR(sv) > 20) {
1732 SvPV_shrink_to_cur(sv);
1734 sv = sv_2mortal(newSV(80));
1737 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1738 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1739 const STRLEN new_len
1740 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1741 SvPV_renew(sv, new_len);
1750 register PERL_CONTEXT *cx;
1751 I32 gimme = OP_GIMME(PL_op, -1);
1754 if (cxstack_ix >= 0)
1755 gimme = cxstack[cxstack_ix].blk_gimme;
1763 PUSHBLOCK(cx, CXt_BLOCK, SP);
1773 SV * const keysv = POPs;
1774 HV * const hv = (HV*)POPs;
1775 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1776 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1778 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1781 if (SvTYPE(hv) != SVt_PVHV)
1784 if (PL_op->op_private & OPpLVAL_INTRO) {
1787 /* does the element we're localizing already exist? */
1788 preeminent = /* can we determine whether it exists? */
1790 || mg_find((SV*)hv, PERL_MAGIC_env)
1791 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1792 /* Try to preserve the existenceness of a tied hash
1793 * element by using EXISTS and DELETE if possible.
1794 * Fallback to FETCH and STORE otherwise */
1795 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1796 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1797 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1799 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1801 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1802 svp = he ? &HeVAL(he) : NULL;
1804 if (!svp || *svp == &PL_sv_undef) {
1808 DIE(aTHX_ PL_no_helem_sv, keysv);
1810 lv = sv_newmortal();
1811 sv_upgrade(lv, SVt_PVLV);
1813 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1814 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1815 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1820 if (PL_op->op_private & OPpLVAL_INTRO) {
1821 if (HvNAME_get(hv) && isGV(*svp))
1822 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1826 const char * const key = SvPV_const(keysv, keylen);
1827 SAVEDELETE(hv, savepvn(key,keylen),
1828 SvUTF8(keysv) ? -(I32)keylen : keylen);
1830 save_helem(hv, keysv, svp);
1833 else if (PL_op->op_private & OPpDEREF)
1834 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1836 sv = (svp ? *svp : &PL_sv_undef);
1837 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1838 * Pushing the magical RHS on to the stack is useless, since
1839 * that magic is soon destined to be misled by the local(),
1840 * and thus the later pp_sassign() will fail to mg_get() the
1841 * old value. This should also cure problems with delayed
1842 * mg_get()s. GSAR 98-07-03 */
1843 if (!lval && SvGMAGICAL(sv))
1844 sv = sv_mortalcopy(sv);
1852 register PERL_CONTEXT *cx;
1857 if (PL_op->op_flags & OPf_SPECIAL) {
1858 cx = &cxstack[cxstack_ix];
1859 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1864 gimme = OP_GIMME(PL_op, -1);
1866 if (cxstack_ix >= 0)
1867 gimme = cxstack[cxstack_ix].blk_gimme;
1873 if (gimme == G_VOID)
1875 else if (gimme == G_SCALAR) {
1879 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1882 *MARK = sv_mortalcopy(TOPs);
1885 *MARK = &PL_sv_undef;
1889 else if (gimme == G_ARRAY) {
1890 /* in case LEAVE wipes old return values */
1892 for (mark = newsp + 1; mark <= SP; mark++) {
1893 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1894 *mark = sv_mortalcopy(*mark);
1895 TAINT_NOT; /* Each item is independent */
1899 PL_curpm = newpm; /* Don't pop $1 et al till now */
1909 register PERL_CONTEXT *cx;
1915 cx = &cxstack[cxstack_ix];
1916 if (CxTYPE(cx) != CXt_LOOP)
1917 DIE(aTHX_ "panic: pp_iter");
1919 itersvp = CxITERVAR(cx);
1920 av = cx->blk_loop.iterary;
1921 if (SvTYPE(av) != SVt_PVAV) {
1922 /* iterate ($min .. $max) */
1923 if (cx->blk_loop.iterlval) {
1924 /* string increment */
1925 register SV* cur = cx->blk_loop.iterlval;
1927 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1928 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1929 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1930 /* safe to reuse old SV */
1931 sv_setsv(*itersvp, cur);
1935 /* we need a fresh SV every time so that loop body sees a
1936 * completely new SV for closures/references to work as
1939 *itersvp = newSVsv(cur);
1940 SvREFCNT_dec(oldsv);
1942 if (strEQ(SvPVX_const(cur), max))
1943 sv_setiv(cur, 0); /* terminate next time */
1950 /* integer increment */
1951 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1954 /* don't risk potential race */
1955 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1956 /* safe to reuse old SV */
1957 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1961 /* we need a fresh SV every time so that loop body sees a
1962 * completely new SV for closures/references to work as they
1965 *itersvp = newSViv(cx->blk_loop.iterix++);
1966 SvREFCNT_dec(oldsv);
1972 if (PL_op->op_private & OPpITER_REVERSED) {
1973 /* In reverse, use itermax as the min :-) */
1974 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1977 if (SvMAGICAL(av) || AvREIFY(av)) {
1978 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1979 sv = svp ? *svp : NULL;
1982 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1986 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1990 if (SvMAGICAL(av) || AvREIFY(av)) {
1991 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1992 sv = svp ? *svp : NULL;
1995 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1999 if (sv && SvIS_FREED(sv)) {
2001 Perl_croak(aTHX_ "Use of freed value in iteration");
2008 if (av != PL_curstack && sv == &PL_sv_undef) {
2009 SV *lv = cx->blk_loop.iterlval;
2010 if (lv && SvREFCNT(lv) > 1) {
2015 SvREFCNT_dec(LvTARG(lv));
2017 lv = cx->blk_loop.iterlval = newSV(0);
2018 sv_upgrade(lv, SVt_PVLV);
2020 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2022 LvTARG(lv) = SvREFCNT_inc_simple(av);
2023 LvTARGOFF(lv) = cx->blk_loop.iterix;
2024 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2029 *itersvp = SvREFCNT_inc_simple_NN(sv);
2030 SvREFCNT_dec(oldsv);
2038 register PMOP *pm = cPMOP;
2053 register REGEXP *rx = PM_GETRE(pm);
2055 int force_on_match = 0;
2056 const I32 oldsave = PL_savestack_ix;
2058 bool doutf8 = FALSE;
2059 #ifdef PERL_OLD_COPY_ON_WRITE
2064 /* known replacement string? */
2065 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2066 if (PL_op->op_flags & OPf_STACKED)
2068 else if (PL_op->op_private & OPpTARGET_MY)
2075 #ifdef PERL_OLD_COPY_ON_WRITE
2076 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2077 because they make integers such as 256 "false". */
2078 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2081 sv_force_normal_flags(TARG,0);
2084 #ifdef PERL_OLD_COPY_ON_WRITE
2088 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2089 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2090 DIE(aTHX_ PL_no_modify);
2093 s = SvPV_mutable(TARG, len);
2094 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2096 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2097 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2102 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2106 DIE(aTHX_ "panic: pp_subst");
2109 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2110 maxiters = 2 * slen + 10; /* We can match twice at each
2111 position, once with zero-length,
2112 second time with non-zero. */
2114 if (!rx->prelen && PL_curpm) {
2118 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2119 || (pm->op_pmflags & PMf_EVAL))
2120 ? REXEC_COPY_STR : 0;
2122 r_flags |= REXEC_SCREAM;
2125 if (rx->reganch & RE_USE_INTUIT) {
2127 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2131 /* How to do it in subst? */
2132 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2134 && ((rx->reganch & ROPT_NOSCAN)
2135 || !((rx->reganch & RE_INTUIT_TAIL)
2136 && (r_flags & REXEC_SCREAM))))
2141 /* only replace once? */
2142 once = !(rpm->op_pmflags & PMf_GLOBAL);
2144 /* known replacement string? */
2146 /* replacement needing upgrading? */
2147 if (DO_UTF8(TARG) && !doutf8) {
2148 nsv = sv_newmortal();
2151 sv_recode_to_utf8(nsv, PL_encoding);
2153 sv_utf8_upgrade(nsv);
2154 c = SvPV_const(nsv, clen);
2158 c = SvPV_const(dstr, clen);
2159 doutf8 = DO_UTF8(dstr);
2167 /* can do inplace substitution? */
2169 #ifdef PERL_OLD_COPY_ON_WRITE
2172 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2173 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2174 && (!doutf8 || SvUTF8(TARG))) {
2175 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2176 r_flags | REXEC_CHECKED))
2180 LEAVE_SCOPE(oldsave);
2183 #ifdef PERL_OLD_COPY_ON_WRITE
2184 if (SvIsCOW(TARG)) {
2185 assert (!force_on_match);
2189 if (force_on_match) {
2191 s = SvPV_force(TARG, len);
2196 SvSCREAM_off(TARG); /* disable possible screamer */
2198 rxtainted |= RX_MATCH_TAINTED(rx);
2199 m = orig + rx->startp[0];
2200 d = orig + rx->endp[0];
2202 if (m - s > strend - d) { /* faster to shorten from end */
2204 Copy(c, m, clen, char);
2209 Move(d, m, i, char);
2213 SvCUR_set(TARG, m - s);
2215 else if ((i = m - s)) { /* faster from front */
2223 Copy(c, m, clen, char);
2228 Copy(c, d, clen, char);
2233 TAINT_IF(rxtainted & 1);
2239 if (iters++ > maxiters)
2240 DIE(aTHX_ "Substitution loop");
2241 rxtainted |= RX_MATCH_TAINTED(rx);
2242 m = rx->startp[0] + orig;
2245 Move(s, d, i, char);
2249 Copy(c, d, clen, char);
2252 s = rx->endp[0] + orig;
2253 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2255 /* don't match same null twice */
2256 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2259 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2260 Move(s, d, i+1, char); /* include the NUL */
2262 TAINT_IF(rxtainted & 1);
2264 PUSHs(sv_2mortal(newSViv((I32)iters)));
2266 (void)SvPOK_only_UTF8(TARG);
2267 TAINT_IF(rxtainted);
2268 if (SvSMAGICAL(TARG)) {
2276 LEAVE_SCOPE(oldsave);
2280 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2281 r_flags | REXEC_CHECKED))
2283 if (force_on_match) {
2285 s = SvPV_force(TARG, len);
2288 #ifdef PERL_OLD_COPY_ON_WRITE
2291 rxtainted |= RX_MATCH_TAINTED(rx);
2292 dstr = newSVpvn(m, s-m);
2297 register PERL_CONTEXT *cx;
2299 (void)ReREFCNT_inc(rx);
2301 RETURNOP(cPMOP->op_pmreplroot);
2303 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2305 if (iters++ > maxiters)
2306 DIE(aTHX_ "Substitution loop");
2307 rxtainted |= RX_MATCH_TAINTED(rx);
2308 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2313 strend = s + (strend - m);
2315 m = rx->startp[0] + orig;
2316 if (doutf8 && !SvUTF8(dstr))
2317 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2319 sv_catpvn(dstr, s, m-s);
2320 s = rx->endp[0] + orig;
2322 sv_catpvn(dstr, c, clen);
2325 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2326 TARG, NULL, r_flags));
2327 if (doutf8 && !DO_UTF8(TARG))
2328 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2330 sv_catpvn(dstr, s, strend - s);
2332 #ifdef PERL_OLD_COPY_ON_WRITE
2333 /* The match may make the string COW. If so, brilliant, because that's
2334 just saved us one malloc, copy and free - the regexp has donated
2335 the old buffer, and we malloc an entirely new one, rather than the
2336 regexp malloc()ing a buffer and copying our original, only for
2337 us to throw it away here during the substitution. */
2338 if (SvIsCOW(TARG)) {
2339 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2345 SvPV_set(TARG, SvPVX(dstr));
2346 SvCUR_set(TARG, SvCUR(dstr));
2347 SvLEN_set(TARG, SvLEN(dstr));
2348 doutf8 |= DO_UTF8(dstr);
2349 SvPV_set(dstr, NULL);
2352 TAINT_IF(rxtainted & 1);
2354 PUSHs(sv_2mortal(newSViv((I32)iters)));
2356 (void)SvPOK_only(TARG);
2359 TAINT_IF(rxtainted);
2362 LEAVE_SCOPE(oldsave);
2371 LEAVE_SCOPE(oldsave);
2380 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2381 ++*PL_markstack_ptr;
2382 LEAVE; /* exit inner scope */
2385 if (PL_stack_base + *PL_markstack_ptr > SP) {
2387 const I32 gimme = GIMME_V;
2389 LEAVE; /* exit outer scope */
2390 (void)POPMARK; /* pop src */
2391 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2392 (void)POPMARK; /* pop dst */
2393 SP = PL_stack_base + POPMARK; /* pop original mark */
2394 if (gimme == G_SCALAR) {
2395 if (PL_op->op_private & OPpGREP_LEX) {
2396 SV* const sv = sv_newmortal();
2397 sv_setiv(sv, items);
2405 else if (gimme == G_ARRAY)
2412 ENTER; /* enter inner scope */
2415 src = PL_stack_base[*PL_markstack_ptr];
2417 if (PL_op->op_private & OPpGREP_LEX)
2418 PAD_SVl(PL_op->op_targ) = src;
2422 RETURNOP(cLOGOP->op_other);
2433 register PERL_CONTEXT *cx;
2436 if (CxMULTICALL(&cxstack[cxstack_ix]))
2440 cxstack_ix++; /* temporarily protect top context */
2443 if (gimme == G_SCALAR) {
2446 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2448 *MARK = SvREFCNT_inc(TOPs);
2453 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2455 *MARK = sv_mortalcopy(sv);
2460 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2464 *MARK = &PL_sv_undef;
2468 else if (gimme == G_ARRAY) {
2469 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2470 if (!SvTEMP(*MARK)) {
2471 *MARK = sv_mortalcopy(*MARK);
2472 TAINT_NOT; /* Each item is independent */
2480 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2481 PL_curpm = newpm; /* ... and pop $1 et al */
2484 return cx->blk_sub.retop;
2487 /* This duplicates the above code because the above code must not
2488 * get any slower by more conditions */
2496 register PERL_CONTEXT *cx;
2499 if (CxMULTICALL(&cxstack[cxstack_ix]))
2503 cxstack_ix++; /* temporarily protect top context */
2507 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2508 /* We are an argument to a function or grep().
2509 * This kind of lvalueness was legal before lvalue
2510 * subroutines too, so be backward compatible:
2511 * cannot report errors. */
2513 /* Scalar context *is* possible, on the LHS of -> only,
2514 * as in f()->meth(). But this is not an lvalue. */
2515 if (gimme == G_SCALAR)
2517 if (gimme == G_ARRAY) {
2518 if (!CvLVALUE(cx->blk_sub.cv))
2519 goto temporise_array;
2520 EXTEND_MORTAL(SP - newsp);
2521 for (mark = newsp + 1; mark <= SP; mark++) {
2524 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2525 *mark = sv_mortalcopy(*mark);
2527 /* Can be a localized value subject to deletion. */
2528 PL_tmps_stack[++PL_tmps_ix] = *mark;
2529 SvREFCNT_inc_void(*mark);
2534 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2535 /* Here we go for robustness, not for speed, so we change all
2536 * the refcounts so the caller gets a live guy. Cannot set
2537 * TEMP, so sv_2mortal is out of question. */
2538 if (!CvLVALUE(cx->blk_sub.cv)) {
2544 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2546 if (gimme == G_SCALAR) {
2550 /* Temporaries are bad unless they happen to be elements
2551 * of a tied hash or array */
2552 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2553 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2559 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2560 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2561 : "a readonly value" : "a temporary");
2563 else { /* Can be a localized value
2564 * subject to deletion. */
2565 PL_tmps_stack[++PL_tmps_ix] = *mark;
2566 SvREFCNT_inc_void(*mark);
2569 else { /* Should not happen? */
2575 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2576 (MARK > SP ? "Empty array" : "Array"));
2580 else if (gimme == G_ARRAY) {
2581 EXTEND_MORTAL(SP - newsp);
2582 for (mark = newsp + 1; mark <= SP; mark++) {
2583 if (*mark != &PL_sv_undef
2584 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2585 /* Might be flattened array after $#array = */
2592 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2593 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2596 /* Can be a localized value subject to deletion. */
2597 PL_tmps_stack[++PL_tmps_ix] = *mark;
2598 SvREFCNT_inc_void(*mark);
2604 if (gimme == G_SCALAR) {
2608 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2610 *MARK = SvREFCNT_inc(TOPs);
2615 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2617 *MARK = sv_mortalcopy(sv);
2622 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2626 *MARK = &PL_sv_undef;
2630 else if (gimme == G_ARRAY) {
2632 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2633 if (!SvTEMP(*MARK)) {
2634 *MARK = sv_mortalcopy(*MARK);
2635 TAINT_NOT; /* Each item is independent */
2644 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2645 PL_curpm = newpm; /* ... and pop $1 et al */
2648 return cx->blk_sub.retop;
2653 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2656 SV * const dbsv = GvSVn(PL_DBsub);
2659 if (!PERLDB_SUB_NN) {
2660 GV * const gv = CvGV(cv);
2662 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2663 || strEQ(GvNAME(gv), "END")
2664 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2665 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2666 /* Use GV from the stack as a fallback. */
2667 /* GV is potentially non-unique, or contain different CV. */
2668 SV * const tmp = newRV((SV*)cv);
2669 sv_setsv(dbsv, tmp);
2673 gv_efullname3(dbsv, gv, NULL);
2677 const int type = SvTYPE(dbsv);
2678 if (type < SVt_PVIV && type != SVt_IV)
2679 sv_upgrade(dbsv, SVt_PVIV);
2680 (void)SvIOK_on(dbsv);
2681 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2685 PL_curcopdb = PL_curcop;
2686 cv = GvCV(PL_DBsub);
2695 register PERL_CONTEXT *cx;
2697 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2700 DIE(aTHX_ "Not a CODE reference");
2701 switch (SvTYPE(sv)) {
2702 /* This is overwhelming the most common case: */
2704 if (!(cv = GvCVu((GV*)sv))) {
2706 cv = sv_2cv(sv, &stash, &gv, 0);
2717 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2719 SP = PL_stack_base + POPMARK;
2722 if (SvGMAGICAL(sv)) {
2726 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2729 sym = SvPV_nolen_const(sv);
2732 DIE(aTHX_ PL_no_usym, "a subroutine");
2733 if (PL_op->op_private & HINT_STRICT_REFS)
2734 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2735 cv = get_cv(sym, TRUE);
2740 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2741 tryAMAGICunDEREF(to_cv);
2744 if (SvTYPE(cv) == SVt_PVCV)
2749 DIE(aTHX_ "Not a CODE reference");
2750 /* This is the second most common case: */
2760 if (!CvROOT(cv) && !CvXSUB(cv)) {
2764 /* anonymous or undef'd function leaves us no recourse */
2765 if (CvANON(cv) || !(gv = CvGV(cv)))
2766 DIE(aTHX_ "Undefined subroutine called");
2768 /* autoloaded stub? */
2769 if (cv != GvCV(gv)) {
2772 /* should call AUTOLOAD now? */
2775 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2782 sub_name = sv_newmortal();
2783 gv_efullname3(sub_name, gv, NULL);
2784 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2788 DIE(aTHX_ "Not a CODE reference");
2793 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2794 if (CvASSERTION(cv) && PL_DBassertion)
2795 sv_setiv(PL_DBassertion, 1);
2797 cv = get_db_sub(&sv, cv);
2798 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2799 DIE(aTHX_ "No DB::sub routine defined");
2802 if (!(CvISXSUB(cv))) {
2803 /* This path taken at least 75% of the time */
2805 register I32 items = SP - MARK;
2806 AV* const padlist = CvPADLIST(cv);
2807 PUSHBLOCK(cx, CXt_SUB, MARK);
2809 cx->blk_sub.retop = PL_op->op_next;
2811 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2812 * that eval'' ops within this sub know the correct lexical space.
2813 * Owing the speed considerations, we choose instead to search for
2814 * the cv using find_runcv() when calling doeval().
2816 if (CvDEPTH(cv) >= 2) {
2817 PERL_STACK_OVERFLOW_CHECK();
2818 pad_push(padlist, CvDEPTH(cv));
2821 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2824 AV* const av = (AV*)PAD_SVl(0);
2826 /* @_ is normally not REAL--this should only ever
2827 * happen when DB::sub() calls things that modify @_ */
2832 cx->blk_sub.savearray = GvAV(PL_defgv);
2833 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2834 CX_CURPAD_SAVE(cx->blk_sub);
2835 cx->blk_sub.argarray = av;
2838 if (items > AvMAX(av) + 1) {
2839 SV **ary = AvALLOC(av);
2840 if (AvARRAY(av) != ary) {
2841 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2842 SvPV_set(av, (char*)ary);
2844 if (items > AvMAX(av) + 1) {
2845 AvMAX(av) = items - 1;
2846 Renew(ary,items,SV*);
2848 SvPV_set(av, (char*)ary);
2851 Copy(MARK,AvARRAY(av),items,SV*);
2852 AvFILLp(av) = items - 1;
2860 /* warning must come *after* we fully set up the context
2861 * stuff so that __WARN__ handlers can safely dounwind()
2864 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2865 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2866 sub_crush_depth(cv);
2868 DEBUG_S(PerlIO_printf(Perl_debug_log,
2869 "%p entersub returning %p\n", thr, CvSTART(cv)));
2871 RETURNOP(CvSTART(cv));
2874 I32 markix = TOPMARK;
2879 /* Need to copy @_ to stack. Alternative may be to
2880 * switch stack to @_, and copy return values
2881 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2882 AV * const av = GvAV(PL_defgv);
2883 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2886 /* Mark is at the end of the stack. */
2888 Copy(AvARRAY(av), SP + 1, items, SV*);
2893 /* We assume first XSUB in &DB::sub is the called one. */
2895 SAVEVPTR(PL_curcop);
2896 PL_curcop = PL_curcopdb;
2899 /* Do we need to open block here? XXXX */
2900 (void)(*CvXSUB(cv))(aTHX_ cv);
2902 /* Enforce some sanity in scalar context. */
2903 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2904 if (markix > PL_stack_sp - PL_stack_base)
2905 *(PL_stack_base + markix) = &PL_sv_undef;
2907 *(PL_stack_base + markix) = *PL_stack_sp;
2908 PL_stack_sp = PL_stack_base + markix;
2916 Perl_sub_crush_depth(pTHX_ CV *cv)
2919 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2921 SV* const tmpstr = sv_newmortal();
2922 gv_efullname3(tmpstr, CvGV(cv), NULL);
2923 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2932 SV* const elemsv = POPs;
2933 IV elem = SvIV(elemsv);
2934 AV* const av = (AV*)POPs;
2935 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2936 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2939 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2940 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2942 elem -= CopARYBASE_get(PL_curcop);
2943 if (SvTYPE(av) != SVt_PVAV)
2945 svp = av_fetch(av, elem, lval && !defer);
2947 #ifdef PERL_MALLOC_WRAP
2948 if (SvUOK(elemsv)) {
2949 const UV uv = SvUV(elemsv);
2950 elem = uv > IV_MAX ? IV_MAX : uv;
2952 else if (SvNOK(elemsv))
2953 elem = (IV)SvNV(elemsv);
2955 static const char oom_array_extend[] =
2956 "Out of memory during array extend"; /* Duplicated in av.c */
2957 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2960 if (!svp || *svp == &PL_sv_undef) {
2963 DIE(aTHX_ PL_no_aelem, elem);
2964 lv = sv_newmortal();
2965 sv_upgrade(lv, SVt_PVLV);
2967 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2968 LvTARG(lv) = SvREFCNT_inc_simple(av);
2969 LvTARGOFF(lv) = elem;
2974 if (PL_op->op_private & OPpLVAL_INTRO)
2975 save_aelem(av, elem, svp);
2976 else if (PL_op->op_private & OPpDEREF)
2977 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2979 sv = (svp ? *svp : &PL_sv_undef);
2980 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2981 sv = sv_mortalcopy(sv);
2987 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2992 Perl_croak(aTHX_ PL_no_modify);
2993 if (SvTYPE(sv) < SVt_RV)
2994 sv_upgrade(sv, SVt_RV);
2995 else if (SvTYPE(sv) >= SVt_PV) {
3002 SvRV_set(sv, newSV(0));
3005 SvRV_set(sv, (SV*)newAV());
3008 SvRV_set(sv, (SV*)newHV());
3019 SV* const sv = TOPs;
3022 SV* const rsv = SvRV(sv);
3023 if (SvTYPE(rsv) == SVt_PVCV) {
3029 SETs(method_common(sv, NULL));
3036 SV* const sv = cSVOP_sv;
3037 U32 hash = SvSHARED_HASH(sv);
3039 XPUSHs(method_common(sv, &hash));
3044 S_method_common(pTHX_ SV* meth, U32* hashp)
3051 const char* packname = NULL;
3054 const char * const name = SvPV_const(meth, namelen);
3055 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3058 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3066 /* this isn't a reference */
3067 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3068 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3070 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3077 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3078 !(ob=(SV*)GvIO(iogv)))
3080 /* this isn't the name of a filehandle either */
3082 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3083 ? !isIDFIRST_utf8((U8*)packname)
3084 : !isIDFIRST(*packname)
3087 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3088 SvOK(sv) ? "without a package or object reference"
3089 : "on an undefined value");
3091 /* assume it's a package name */
3092 stash = gv_stashpvn(packname, packlen, FALSE);
3096 SV* const ref = newSViv(PTR2IV(stash));
3097 hv_store(PL_stashcache, packname, packlen, ref, 0);
3101 /* it _is_ a filehandle name -- replace with a reference */
3102 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3105 /* if we got here, ob should be a reference or a glob */
3106 if (!ob || !(SvOBJECT(ob)
3107 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3110 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3114 stash = SvSTASH(ob);
3117 /* NOTE: stash may be null, hope hv_fetch_ent and
3118 gv_fetchmethod can cope (it seems they can) */
3120 /* shortcut for simple names */
3122 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3124 gv = (GV*)HeVAL(he);
3125 if (isGV(gv) && GvCV(gv) &&
3126 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3127 return (SV*)GvCV(gv);
3131 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3134 /* This code tries to figure out just what went wrong with
3135 gv_fetchmethod. It therefore needs to duplicate a lot of
3136 the internals of that function. We can't move it inside
3137 Perl_gv_fetchmethod_autoload(), however, since that would
3138 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3141 const char* leaf = name;
3142 const char* sep = NULL;
3145 for (p = name; *p; p++) {
3147 sep = p, leaf = p + 1;
3148 else if (*p == ':' && *(p + 1) == ':')
3149 sep = p, leaf = p + 2;
3151 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3152 /* the method name is unqualified or starts with SUPER:: */
3153 bool need_strlen = 1;
3155 packname = CopSTASHPV(PL_curcop);
3158 HEK * const packhek = HvNAME_HEK(stash);
3160 packname = HEK_KEY(packhek);
3161 packlen = HEK_LEN(packhek);
3171 "Can't use anonymous symbol table for method lookup");
3173 else if (need_strlen)
3174 packlen = strlen(packname);
3178 /* the method name is qualified */
3180 packlen = sep - name;
3183 /* we're relying on gv_fetchmethod not autovivifying the stash */
3184 if (gv_stashpvn(packname, packlen, FALSE)) {
3186 "Can't locate object method \"%s\" via package \"%.*s\"",
3187 leaf, (int)packlen, packname);
3191 "Can't locate object method \"%s\" via package \"%.*s\""
3192 " (perhaps you forgot to load \"%.*s\"?)",
3193 leaf, (int)packlen, packname, (int)packlen, packname);
3196 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3201 * c-indentation-style: bsd
3203 * indent-tabs-mode: t
3206 * ex: set ts=8 sts=4 sw=4 noet: