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);
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)));
366 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
368 if (Perl_isnan(left) || Perl_isnan(right))
370 SETs(boolSV(left == right));
373 SETs(boolSV(TOPn == value));
382 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
383 DIE(aTHX_ PL_no_modify);
384 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
385 && SvIVX(TOPs) != IV_MAX)
387 SvIV_set(TOPs, SvIVX(TOPs) + 1);
388 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
390 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
402 if (PL_op->op_type == OP_OR)
404 RETURNOP(cLOGOP->op_other);
413 const int op_type = PL_op->op_type;
414 const int is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
418 if (!sv || !SvANY(sv)) {
419 if (op_type == OP_DOR)
421 RETURNOP(cLOGOP->op_other);
423 } else if (op_type == OP_DEFINED) {
425 if (!sv || !SvANY(sv))
428 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
431 switch (SvTYPE(sv)) {
433 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
437 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
441 if (CvROOT(sv) || CvXSUB(sv))
454 if(op_type == OP_DOR)
456 RETURNOP(cLOGOP->op_other);
458 /* assuming OP_DEFINED */
466 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
467 useleft = USE_LEFT(TOPm1s);
468 #ifdef PERL_PRESERVE_IVUV
469 /* We must see if we can perform the addition with integers if possible,
470 as the integer code detects overflow while the NV code doesn't.
471 If either argument hasn't had a numeric conversion yet attempt to get
472 the IV. It's important to do this now, rather than just assuming that
473 it's not IOK as a PV of "9223372036854775806" may not take well to NV
474 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
475 integer in case the second argument is IV=9223372036854775806
476 We can (now) rely on sv_2iv to do the right thing, only setting the
477 public IOK flag if the value in the NV (or PV) slot is truly integer.
479 A side effect is that this also aggressively prefers integer maths over
480 fp maths for integer values.
482 How to detect overflow?
484 C 99 section 6.2.6.1 says
486 The range of nonnegative values of a signed integer type is a subrange
487 of the corresponding unsigned integer type, and the representation of
488 the same value in each type is the same. A computation involving
489 unsigned operands can never overflow, because a result that cannot be
490 represented by the resulting unsigned integer type is reduced modulo
491 the number that is one greater than the largest value that can be
492 represented by the resulting type.
496 which I read as "unsigned ints wrap."
498 signed integer overflow seems to be classed as "exception condition"
500 If an exceptional condition occurs during the evaluation of an
501 expression (that is, if the result is not mathematically defined or not
502 in the range of representable values for its type), the behavior is
505 (6.5, the 5th paragraph)
507 I had assumed that on 2s complement machines signed arithmetic would
508 wrap, hence coded pp_add and pp_subtract on the assumption that
509 everything perl builds on would be happy. After much wailing and
510 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
511 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
512 unsigned code below is actually shorter than the old code. :-)
517 /* Unless the left argument is integer in range we are going to have to
518 use NV maths. Hence only attempt to coerce the right argument if
519 we know the left is integer. */
527 /* left operand is undef, treat as zero. + 0 is identity,
528 Could SETi or SETu right now, but space optimise by not adding
529 lots of code to speed up what is probably a rarish case. */
531 /* Left operand is defined, so is it IV? */
534 if ((auvok = SvUOK(TOPm1s)))
537 register const IV aiv = SvIVX(TOPm1s);
540 auvok = 1; /* Now acting as a sign flag. */
541 } else { /* 2s complement assumption for IV_MIN */
549 bool result_good = 0;
552 bool buvok = SvUOK(TOPs);
557 register const IV biv = SvIVX(TOPs);
564 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
565 else "IV" now, independent of how it came in.
566 if a, b represents positive, A, B negative, a maps to -A etc
571 all UV maths. negate result if A negative.
572 add if signs same, subtract if signs differ. */
578 /* Must get smaller */
584 /* result really should be -(auv-buv). as its negation
585 of true value, need to swap our result flag */
602 if (result <= (UV)IV_MIN)
605 /* result valid, but out of range for IV. */
610 } /* Overflow, drop through to NVs. */
617 /* left operand is undef, treat as zero. + 0.0 is identity. */
621 SETn( value + TOPn );
629 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
630 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
631 const U32 lval = PL_op->op_flags & OPf_MOD;
632 SV** const svp = av_fetch(av, PL_op->op_private, lval);
633 SV *sv = (svp ? *svp : &PL_sv_undef);
635 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
636 sv = sv_mortalcopy(sv);
643 dVAR; dSP; dMARK; dTARGET;
645 do_join(TARG, *MARK, MARK, SP);
656 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
657 * will be enough to hold an OP*.
659 SV* const sv = sv_newmortal();
660 sv_upgrade(sv, SVt_PVLV);
662 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
670 /* Oversized hot code. */
674 dVAR; dSP; dMARK; dORIGMARK;
678 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
680 if (gv && (io = GvIO(gv))
681 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
684 if (MARK == ORIGMARK) {
685 /* If using default handle then we need to make space to
686 * pass object as 1st arg, so move other args up ...
690 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
694 *MARK = SvTIED_obj((SV*)io, mg);
697 call_method("PRINT", G_SCALAR);
705 if (!(io = GvIO(gv))) {
706 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
707 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
709 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
710 report_evil_fh(gv, io, PL_op->op_type);
711 SETERRNO(EBADF,RMS_IFI);
714 else if (!(fp = IoOFP(io))) {
715 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
717 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
718 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
719 report_evil_fh(gv, io, PL_op->op_type);
721 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
726 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
728 if (!do_print(*MARK, fp))
732 if (!do_print(PL_ofs_sv, fp)) { /* $, */
741 if (!do_print(*MARK, fp))
749 if (PL_ors_sv && SvOK(PL_ors_sv))
750 if (!do_print(PL_ors_sv, fp)) /* $\ */
753 if (IoFLAGS(io) & IOf_FLUSH)
754 if (PerlIO_flush(fp) == EOF)
764 XPUSHs(&PL_sv_undef);
775 tryAMAGICunDEREF(to_av);
778 if (SvTYPE(av) != SVt_PVAV)
779 DIE(aTHX_ "Not an ARRAY reference");
780 if (PL_op->op_flags & OPf_REF) {
785 if (GIMME == G_SCALAR)
786 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
790 else if (PL_op->op_flags & OPf_MOD
791 && PL_op->op_private & OPpLVAL_INTRO)
792 Perl_croak(aTHX_ PL_no_localize_ref);
795 if (SvTYPE(sv) == SVt_PVAV) {
797 if (PL_op->op_flags & OPf_REF) {
802 if (GIMME == G_SCALAR)
803 Perl_croak(aTHX_ "Can't return array to lvalue"
812 if (SvTYPE(sv) != SVt_PVGV) {
813 if (SvGMAGICAL(sv)) {
819 if (PL_op->op_flags & OPf_REF ||
820 PL_op->op_private & HINT_STRICT_REFS)
821 DIE(aTHX_ PL_no_usym, "an ARRAY");
822 if (ckWARN(WARN_UNINITIALIZED))
824 if (GIMME == G_ARRAY) {
830 if ((PL_op->op_flags & OPf_SPECIAL) &&
831 !(PL_op->op_flags & OPf_MOD))
833 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
835 && (!is_gv_magical_sv(sv,0)
836 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
842 if (PL_op->op_private & HINT_STRICT_REFS)
843 DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
844 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
851 if (PL_op->op_private & OPpLVAL_INTRO)
853 if (PL_op->op_flags & OPf_REF) {
858 if (GIMME == G_SCALAR)
859 Perl_croak(aTHX_ "Can't return array to lvalue"
867 if (GIMME == G_ARRAY) {
868 const I32 maxarg = AvFILL(av) + 1;
869 (void)POPs; /* XXXX May be optimized away? */
871 if (SvRMAGICAL(av)) {
873 for (i=0; i < (U32)maxarg; i++) {
874 SV ** const svp = av_fetch(av, i, FALSE);
875 /* See note in pp_helem, and bug id #27839 */
877 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
882 Copy(AvARRAY(av), SP+1, maxarg, SV*);
886 else if (GIMME_V == G_SCALAR) {
888 const I32 maxarg = AvFILL(av) + 1;
898 const I32 gimme = GIMME_V;
899 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
903 tryAMAGICunDEREF(to_hv);
906 if (SvTYPE(hv) != SVt_PVHV)
907 DIE(aTHX_ "Not a HASH reference");
908 if (PL_op->op_flags & OPf_REF) {
913 if (gimme != G_ARRAY)
914 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
918 else if (PL_op->op_flags & OPf_MOD
919 && PL_op->op_private & OPpLVAL_INTRO)
920 Perl_croak(aTHX_ PL_no_localize_ref);
923 if (SvTYPE(sv) == SVt_PVHV) {
925 if (PL_op->op_flags & OPf_REF) {
930 if (gimme != G_ARRAY)
931 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
939 if (SvTYPE(sv) != SVt_PVGV) {
940 if (SvGMAGICAL(sv)) {
946 if (PL_op->op_flags & OPf_REF ||
947 PL_op->op_private & HINT_STRICT_REFS)
948 DIE(aTHX_ PL_no_usym, "a HASH");
949 if (ckWARN(WARN_UNINITIALIZED))
951 if (gimme == G_ARRAY) {
957 if ((PL_op->op_flags & OPf_SPECIAL) &&
958 !(PL_op->op_flags & OPf_MOD))
960 gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
962 && (!is_gv_magical_sv(sv,0)
963 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
969 if (PL_op->op_private & HINT_STRICT_REFS)
970 DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
971 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
978 if (PL_op->op_private & OPpLVAL_INTRO)
980 if (PL_op->op_flags & OPf_REF) {
985 if (gimme != G_ARRAY)
986 Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
993 if (gimme == G_ARRAY) { /* array wanted */
994 *PL_stack_sp = (SV*)hv;
997 else if (gimme == G_SCALAR) {
999 TARG = Perl_hv_scalar(aTHX_ hv);
1006 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
1013 if (ckWARN(WARN_MISC)) {
1015 if (relem == firstrelem &&
1017 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
1018 SvTYPE(SvRV(*relem)) == SVt_PVHV))
1020 err = "Reference found where even-sized list expected";
1023 err = "Odd number of elements in hash assignment";
1024 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
1028 didstore = hv_store_ent(hash,*relem,tmpstr,0);
1029 if (SvMAGICAL(hash)) {
1030 if (SvSMAGICAL(tmpstr))
1042 SV **lastlelem = PL_stack_sp;
1043 SV **lastrelem = PL_stack_base + POPMARK;
1044 SV **firstrelem = PL_stack_base + POPMARK + 1;
1045 SV **firstlelem = lastrelem + 1;
1047 register SV **relem;
1048 register SV **lelem;
1058 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
1061 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1064 /* If there's a common identifier on both sides we have to take
1065 * special care that assigning the identifier on the left doesn't
1066 * clobber a value on the right that's used later in the list.
1068 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1069 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1070 for (relem = firstrelem; relem <= lastrelem; relem++) {
1071 if ((sv = *relem)) {
1072 TAINT_NOT; /* Each item is independent */
1073 *relem = sv_mortalcopy(sv);
1083 while (lelem <= lastlelem) {
1084 TAINT_NOT; /* Each item stands on its own, taintwise. */
1086 switch (SvTYPE(sv)) {
1089 magic = SvMAGICAL(ary) != 0;
1091 av_extend(ary, lastrelem - relem);
1093 while (relem <= lastrelem) { /* gobble up all the rest */
1096 sv = newSVsv(*relem);
1098 didstore = av_store(ary,i++,sv);
1108 case SVt_PVHV: { /* normal hash */
1112 magic = SvMAGICAL(hash) != 0;
1114 firsthashrelem = relem;
1116 while (relem < lastrelem) { /* gobble up all the rest */
1118 sv = *relem ? *relem : &PL_sv_no;
1122 sv_setsv(tmpstr,*relem); /* value */
1123 *(relem++) = tmpstr;
1124 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1125 /* key overwrites an existing entry */
1127 didstore = hv_store_ent(hash,sv,tmpstr,0);
1129 if (SvSMAGICAL(tmpstr))
1136 if (relem == lastrelem) {
1137 do_oddball(hash, relem, firstrelem);
1143 if (SvIMMORTAL(sv)) {
1144 if (relem <= lastrelem)
1148 if (relem <= lastrelem) {
1149 sv_setsv(sv, *relem);
1153 sv_setsv(sv, &PL_sv_undef);
1158 if (PL_delaymagic & ~DM_DELAY) {
1159 if (PL_delaymagic & DM_UID) {
1160 #ifdef HAS_SETRESUID
1161 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1162 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1165 # ifdef HAS_SETREUID
1166 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1167 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1170 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1171 (void)setruid(PL_uid);
1172 PL_delaymagic &= ~DM_RUID;
1174 # endif /* HAS_SETRUID */
1176 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1177 (void)seteuid(PL_euid);
1178 PL_delaymagic &= ~DM_EUID;
1180 # endif /* HAS_SETEUID */
1181 if (PL_delaymagic & DM_UID) {
1182 if (PL_uid != PL_euid)
1183 DIE(aTHX_ "No setreuid available");
1184 (void)PerlProc_setuid(PL_uid);
1186 # endif /* HAS_SETREUID */
1187 #endif /* HAS_SETRESUID */
1188 PL_uid = PerlProc_getuid();
1189 PL_euid = PerlProc_geteuid();
1191 if (PL_delaymagic & DM_GID) {
1192 #ifdef HAS_SETRESGID
1193 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1194 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1197 # ifdef HAS_SETREGID
1198 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1199 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1202 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1203 (void)setrgid(PL_gid);
1204 PL_delaymagic &= ~DM_RGID;
1206 # endif /* HAS_SETRGID */
1208 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1209 (void)setegid(PL_egid);
1210 PL_delaymagic &= ~DM_EGID;
1212 # endif /* HAS_SETEGID */
1213 if (PL_delaymagic & DM_GID) {
1214 if (PL_gid != PL_egid)
1215 DIE(aTHX_ "No setregid available");
1216 (void)PerlProc_setgid(PL_gid);
1218 # endif /* HAS_SETREGID */
1219 #endif /* HAS_SETRESGID */
1220 PL_gid = PerlProc_getgid();
1221 PL_egid = PerlProc_getegid();
1223 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1227 if (gimme == G_VOID)
1228 SP = firstrelem - 1;
1229 else if (gimme == G_SCALAR) {
1232 SETi(lastrelem - firstrelem + 1 - duplicates);
1239 /* Removes from the stack the entries which ended up as
1240 * duplicated keys in the hash (fix for [perl #24380]) */
1241 Move(firsthashrelem + duplicates,
1242 firsthashrelem, duplicates, SV**);
1243 lastrelem -= duplicates;
1248 SP = firstrelem + (lastlelem - firstlelem);
1249 lelem = firstlelem + (relem - firstrelem);
1251 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1259 register PMOP * const pm = cPMOP;
1260 SV * const rv = sv_newmortal();
1261 SV * const sv = newSVrv(rv, "Regexp");
1262 if (pm->op_pmdynflags & PMdf_TAINTED)
1264 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1271 register PMOP *pm = cPMOP;
1273 register const char *t;
1274 register const char *s;
1277 I32 r_flags = REXEC_CHECKED;
1278 const char *truebase; /* Start of string */
1279 register REGEXP *rx = PM_GETRE(pm);
1281 const I32 gimme = GIMME;
1284 const I32 oldsave = PL_savestack_ix;
1285 I32 update_minmatch = 1;
1286 I32 had_zerolen = 0;
1288 if (PL_op->op_flags & OPf_STACKED)
1290 else if (PL_op->op_private & OPpTARGET_MY)
1297 PUTBACK; /* EVAL blocks need stack_sp. */
1298 s = SvPV_const(TARG, len);
1300 DIE(aTHX_ "panic: pp_match");
1302 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1303 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1306 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1308 /* PMdf_USED is set after a ?? matches once */
1309 if (pm->op_pmdynflags & PMdf_USED) {
1311 if (gimme == G_ARRAY)
1316 /* empty pattern special-cased to use last successful pattern if possible */
1317 if (!rx->prelen && PL_curpm) {
1322 if (rx->minlen > (I32)len)
1327 /* XXXX What part of this is needed with true \G-support? */
1328 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1331 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332 if (mg && mg->mg_len >= 0) {
1333 if (!(rx->reganch & ROPT_GPOS_SEEN))
1334 rx->endp[0] = rx->startp[0] = mg->mg_len;
1335 else if (rx->reganch & ROPT_ANCH_GPOS) {
1336 r_flags |= REXEC_IGNOREPOS;
1337 rx->endp[0] = rx->startp[0] = mg->mg_len;
1339 minmatch = (mg->mg_flags & MGf_MINMATCH);
1340 update_minmatch = 0;
1344 if ((!global && rx->nparens)
1345 || SvTEMP(TARG) || PL_sawampersand || (pm->op_pmflags & PMf_EVAL))
1346 r_flags |= REXEC_COPY_STR;
1348 r_flags |= REXEC_SCREAM;
1351 if (global && rx->startp[0] != -1) {
1352 t = s = rx->endp[0] + truebase;
1353 if ((s + rx->minlen) > strend)
1355 if (update_minmatch++)
1356 minmatch = had_zerolen;
1358 if (rx->reganch & RE_USE_INTUIT &&
1359 DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1360 /* FIXME - can PL_bostr be made const char *? */
1361 PL_bostr = (char *)truebase;
1362 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1366 if ( (rx->reganch & ROPT_CHECK_ALL)
1368 && ((rx->reganch & ROPT_NOSCAN)
1369 || !((rx->reganch & RE_INTUIT_TAIL)
1370 && (r_flags & REXEC_SCREAM)))
1371 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1374 if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
1377 if (dynpm->op_pmflags & PMf_ONCE)
1378 dynpm->op_pmdynflags |= PMdf_USED;
1387 RX_MATCH_TAINTED_on(rx);
1388 TAINT_IF(RX_MATCH_TAINTED(rx));
1389 if (gimme == G_ARRAY) {
1390 const I32 nparens = rx->nparens;
1391 I32 i = (global && !nparens) ? 1 : 0;
1393 SPAGAIN; /* EVAL blocks could move the stack. */
1394 EXTEND(SP, nparens + i);
1395 EXTEND_MORTAL(nparens + i);
1396 for (i = !i; i <= nparens; i++) {
1397 PUSHs(sv_newmortal());
1398 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1399 const I32 len = rx->endp[i] - rx->startp[i];
1400 s = rx->startp[i] + truebase;
1401 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1402 len < 0 || len > strend - s)
1403 DIE(aTHX_ "panic: pp_match start/end pointers");
1404 sv_setpvn(*SP, s, len);
1405 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1410 if (dynpm->op_pmflags & PMf_CONTINUE) {
1412 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1413 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1415 #ifdef PERL_OLD_COPY_ON_WRITE
1417 sv_force_normal_flags(TARG, 0);
1419 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1420 &PL_vtbl_mglob, NULL, 0);
1422 if (rx->startp[0] != -1) {
1423 mg->mg_len = rx->endp[0];
1424 if (rx->startp[0] == rx->endp[0])
1425 mg->mg_flags |= MGf_MINMATCH;
1427 mg->mg_flags &= ~MGf_MINMATCH;
1430 had_zerolen = (rx->startp[0] != -1
1431 && rx->startp[0] == rx->endp[0]);
1432 PUTBACK; /* EVAL blocks may use stack */
1433 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1438 LEAVE_SCOPE(oldsave);
1444 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1445 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1449 #ifdef PERL_OLD_COPY_ON_WRITE
1451 sv_force_normal_flags(TARG, 0);
1453 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1454 &PL_vtbl_mglob, NULL, 0);
1456 if (rx->startp[0] != -1) {
1457 mg->mg_len = rx->endp[0];
1458 if (rx->startp[0] == rx->endp[0])
1459 mg->mg_flags |= MGf_MINMATCH;
1461 mg->mg_flags &= ~MGf_MINMATCH;
1464 LEAVE_SCOPE(oldsave);
1468 yup: /* Confirmed by INTUIT */
1470 RX_MATCH_TAINTED_on(rx);
1471 TAINT_IF(RX_MATCH_TAINTED(rx));
1473 if (dynpm->op_pmflags & PMf_ONCE)
1474 dynpm->op_pmdynflags |= PMdf_USED;
1475 if (RX_MATCH_COPIED(rx))
1476 Safefree(rx->subbeg);
1477 RX_MATCH_COPIED_off(rx);
1480 /* FIXME - should rx->subbeg be const char *? */
1481 rx->subbeg = (char *) truebase;
1482 rx->startp[0] = s - truebase;
1483 if (RX_MATCH_UTF8(rx)) {
1484 char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
1485 rx->endp[0] = t - truebase;
1488 rx->endp[0] = s - truebase + rx->minlen;
1490 rx->sublen = strend - truebase;
1493 if (PL_sawampersand) {
1495 #ifdef PERL_OLD_COPY_ON_WRITE
1496 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1498 PerlIO_printf(Perl_debug_log,
1499 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1500 (int) SvTYPE(TARG), truebase, t,
1503 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1504 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1505 assert (SvPOKp(rx->saved_copy));
1510 rx->subbeg = savepvn(t, strend - t);
1511 #ifdef PERL_OLD_COPY_ON_WRITE
1512 rx->saved_copy = NULL;
1515 rx->sublen = strend - t;
1516 RX_MATCH_COPIED_on(rx);
1517 off = rx->startp[0] = s - t;
1518 rx->endp[0] = off + rx->minlen;
1520 else { /* startp/endp are used by @- @+. */
1521 rx->startp[0] = s - truebase;
1522 rx->endp[0] = s - truebase + rx->minlen;
1524 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1525 LEAVE_SCOPE(oldsave);
1530 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1531 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1532 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1537 LEAVE_SCOPE(oldsave);
1538 if (gimme == G_ARRAY)
1544 Perl_do_readline(pTHX)
1546 dVAR; dSP; dTARGETSTACKED;
1551 register IO * const io = GvIO(PL_last_in_gv);
1552 register const I32 type = PL_op->op_type;
1553 const I32 gimme = GIMME_V;
1556 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1559 XPUSHs(SvTIED_obj((SV*)io, mg));
1562 call_method("READLINE", gimme);
1565 if (gimme == G_SCALAR) {
1566 SV* const result = POPs;
1567 SvSetSV_nosteal(TARG, result);
1577 if (IoFLAGS(io) & IOf_ARGV) {
1578 if (IoFLAGS(io) & IOf_START) {
1580 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1581 IoFLAGS(io) &= ~IOf_START;
1582 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1583 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1584 SvSETMAGIC(GvSV(PL_last_in_gv));
1589 fp = nextargv(PL_last_in_gv);
1590 if (!fp) { /* Note: fp != IoIFP(io) */
1591 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1594 else if (type == OP_GLOB)
1595 fp = Perl_start_glob(aTHX_ POPs, io);
1597 else if (type == OP_GLOB)
1599 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1600 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1604 if ((!io || !(IoFLAGS(io) & IOf_START))
1605 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1607 if (type == OP_GLOB)
1608 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1609 "glob failed (can't start child: %s)",
1612 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1614 if (gimme == G_SCALAR) {
1615 /* undef TARG, and push that undefined value */
1616 if (type != OP_RCATLINE) {
1617 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1625 if (gimme == G_SCALAR) {
1629 else if (isGV_with_GP(sv)) {
1630 SvPV_force_nolen(sv);
1632 SvUPGRADE(sv, SVt_PV);
1633 tmplen = SvLEN(sv); /* remember if already alloced */
1634 if (!tmplen && !SvREADONLY(sv))
1635 Sv_Grow(sv, 80); /* try short-buffering it */
1637 if (type == OP_RCATLINE && SvOK(sv)) {
1639 SvPV_force_nolen(sv);
1645 sv = sv_2mortal(newSV(80));
1649 /* This should not be marked tainted if the fp is marked clean */
1650 #define MAYBE_TAINT_LINE(io, sv) \
1651 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1656 /* delay EOF state for a snarfed empty file */
1657 #define SNARF_EOF(gimme,rs,io,sv) \
1658 (gimme != G_SCALAR || SvCUR(sv) \
1659 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1663 if (!sv_gets(sv, fp, offset)
1665 || SNARF_EOF(gimme, PL_rs, io, sv)
1666 || PerlIO_error(fp)))
1668 PerlIO_clearerr(fp);
1669 if (IoFLAGS(io) & IOf_ARGV) {
1670 fp = nextargv(PL_last_in_gv);
1673 (void)do_close(PL_last_in_gv, FALSE);
1675 else if (type == OP_GLOB) {
1676 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1677 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1678 "glob failed (child exited with status %d%s)",
1679 (int)(STATUS_CURRENT >> 8),
1680 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1683 if (gimme == G_SCALAR) {
1684 if (type != OP_RCATLINE) {
1685 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1691 MAYBE_TAINT_LINE(io, sv);
1694 MAYBE_TAINT_LINE(io, sv);
1696 IoFLAGS(io) |= IOf_NOLINE;
1700 if (type == OP_GLOB) {
1703 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1704 char * const tmps = SvEND(sv) - 1;
1705 if (*tmps == *SvPVX_const(PL_rs)) {
1707 SvCUR_set(sv, SvCUR(sv) - 1);
1710 for (t1 = SvPVX_const(sv); *t1; t1++)
1711 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1712 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1714 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1715 (void)POPs; /* Unmatched wildcard? Chuck it... */
1718 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1719 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1720 const STRLEN len = SvCUR(sv) - offset;
1723 if (ckWARN(WARN_UTF8) &&
1724 !is_utf8_string_loc(s, len, &f))
1725 /* Emulate :encoding(utf8) warning in the same case. */
1726 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1727 "utf8 \"\\x%02X\" does not map to Unicode",
1728 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) {
1782 if (PL_op->op_private & OPpLVAL_INTRO) {
1785 /* does the element we're localizing already exist? */
1787 /* can we determine whether it exists? */
1789 || mg_find((SV*)hv, PERL_MAGIC_env)
1790 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1791 /* Try to preserve the existenceness of a tied hash
1792 * element by using EXISTS and DELETE if possible.
1793 * Fallback to FETCH and STORE otherwise */
1794 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1795 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1796 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1798 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1801 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1802 svp = he ? &HeVAL(he) : NULL;
1808 if (!svp || *svp == &PL_sv_undef) {
1812 DIE(aTHX_ PL_no_helem_sv, keysv);
1814 lv = sv_newmortal();
1815 sv_upgrade(lv, SVt_PVLV);
1817 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1818 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1819 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1824 if (PL_op->op_private & OPpLVAL_INTRO) {
1825 if (HvNAME_get(hv) && isGV(*svp))
1826 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1830 const char * const key = SvPV_const(keysv, keylen);
1831 SAVEDELETE(hv, savepvn(key,keylen), keylen);
1833 save_helem(hv, keysv, svp);
1836 else if (PL_op->op_private & OPpDEREF)
1837 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1839 sv = (svp ? *svp : &PL_sv_undef);
1840 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1841 * Pushing the magical RHS on to the stack is useless, since
1842 * that magic is soon destined to be misled by the local(),
1843 * and thus the later pp_sassign() will fail to mg_get() the
1844 * old value. This should also cure problems with delayed
1845 * mg_get()s. GSAR 98-07-03 */
1846 if (!lval && SvGMAGICAL(sv))
1847 sv = sv_mortalcopy(sv);
1855 register PERL_CONTEXT *cx;
1860 if (PL_op->op_flags & OPf_SPECIAL) {
1861 cx = &cxstack[cxstack_ix];
1862 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1867 gimme = OP_GIMME(PL_op, -1);
1869 if (cxstack_ix >= 0)
1870 gimme = cxstack[cxstack_ix].blk_gimme;
1876 if (gimme == G_VOID)
1878 else if (gimme == G_SCALAR) {
1882 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1885 *MARK = sv_mortalcopy(TOPs);
1888 *MARK = &PL_sv_undef;
1892 else if (gimme == G_ARRAY) {
1893 /* in case LEAVE wipes old return values */
1895 for (mark = newsp + 1; mark <= SP; mark++) {
1896 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1897 *mark = sv_mortalcopy(*mark);
1898 TAINT_NOT; /* Each item is independent */
1902 PL_curpm = newpm; /* Don't pop $1 et al till now */
1912 register PERL_CONTEXT *cx;
1918 cx = &cxstack[cxstack_ix];
1919 if (CxTYPE(cx) != CXt_LOOP)
1920 DIE(aTHX_ "panic: pp_iter");
1922 itersvp = CxITERVAR(cx);
1923 av = cx->blk_loop.iterary;
1924 if (SvTYPE(av) != SVt_PVAV) {
1925 /* iterate ($min .. $max) */
1926 if (cx->blk_loop.iterlval) {
1927 /* string increment */
1928 register SV* cur = cx->blk_loop.iterlval;
1930 const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1931 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1932 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1933 /* safe to reuse old SV */
1934 sv_setsv(*itersvp, cur);
1938 /* we need a fresh SV every time so that loop body sees a
1939 * completely new SV for closures/references to work as
1942 *itersvp = newSVsv(cur);
1943 SvREFCNT_dec(oldsv);
1945 if (strEQ(SvPVX_const(cur), max))
1946 sv_setiv(cur, 0); /* terminate next time */
1953 /* integer increment */
1954 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1957 /* don't risk potential race */
1958 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1959 /* safe to reuse old SV */
1960 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1964 /* we need a fresh SV every time so that loop body sees a
1965 * completely new SV for closures/references to work as they
1968 *itersvp = newSViv(cx->blk_loop.iterix++);
1969 SvREFCNT_dec(oldsv);
1975 if (PL_op->op_private & OPpITER_REVERSED) {
1976 /* In reverse, use itermax as the min :-) */
1977 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1980 if (SvMAGICAL(av) || AvREIFY(av)) {
1981 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1982 sv = svp ? *svp : NULL;
1985 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1989 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1993 if (SvMAGICAL(av) || AvREIFY(av)) {
1994 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1995 sv = svp ? *svp : NULL;
1998 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2002 if (sv && SvIS_FREED(sv)) {
2004 Perl_croak(aTHX_ "Use of freed value in iteration");
2011 if (av != PL_curstack && sv == &PL_sv_undef) {
2012 SV *lv = cx->blk_loop.iterlval;
2013 if (lv && SvREFCNT(lv) > 1) {
2018 SvREFCNT_dec(LvTARG(lv));
2020 lv = cx->blk_loop.iterlval = newSV(0);
2021 sv_upgrade(lv, SVt_PVLV);
2023 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2025 LvTARG(lv) = SvREFCNT_inc_simple(av);
2026 LvTARGOFF(lv) = cx->blk_loop.iterix;
2027 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2032 *itersvp = SvREFCNT_inc_simple_NN(sv);
2033 SvREFCNT_dec(oldsv);
2041 register PMOP *pm = cPMOP;
2056 register REGEXP *rx = PM_GETRE(pm);
2058 int force_on_match = 0;
2059 const I32 oldsave = PL_savestack_ix;
2061 bool doutf8 = FALSE;
2062 #ifdef PERL_OLD_COPY_ON_WRITE
2067 /* known replacement string? */
2068 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2069 if (PL_op->op_flags & OPf_STACKED)
2071 else if (PL_op->op_private & OPpTARGET_MY)
2078 #ifdef PERL_OLD_COPY_ON_WRITE
2079 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2080 because they make integers such as 256 "false". */
2081 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2084 sv_force_normal_flags(TARG,0);
2087 #ifdef PERL_OLD_COPY_ON_WRITE
2091 || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2092 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2093 DIE(aTHX_ PL_no_modify);
2096 s = SvPV_mutable(TARG, len);
2097 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2099 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2100 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2105 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2109 DIE(aTHX_ "panic: pp_subst");
2112 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2113 maxiters = 2 * slen + 10; /* We can match twice at each
2114 position, once with zero-length,
2115 second time with non-zero. */
2117 if (!rx->prelen && PL_curpm) {
2121 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2122 || (pm->op_pmflags & PMf_EVAL))
2123 ? REXEC_COPY_STR : 0;
2125 r_flags |= REXEC_SCREAM;
2128 if (rx->reganch & RE_USE_INTUIT) {
2130 s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2134 /* How to do it in subst? */
2135 /* if ( (rx->reganch & ROPT_CHECK_ALL)
2137 && ((rx->reganch & ROPT_NOSCAN)
2138 || !((rx->reganch & RE_INTUIT_TAIL)
2139 && (r_flags & REXEC_SCREAM))))
2144 /* only replace once? */
2145 once = !(rpm->op_pmflags & PMf_GLOBAL);
2147 /* known replacement string? */
2149 /* replacement needing upgrading? */
2150 if (DO_UTF8(TARG) && !doutf8) {
2151 nsv = sv_newmortal();
2154 sv_recode_to_utf8(nsv, PL_encoding);
2156 sv_utf8_upgrade(nsv);
2157 c = SvPV_const(nsv, clen);
2161 c = SvPV_const(dstr, clen);
2162 doutf8 = DO_UTF8(dstr);
2170 /* can do inplace substitution? */
2172 #ifdef PERL_OLD_COPY_ON_WRITE
2175 && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2176 && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2177 && (!doutf8 || SvUTF8(TARG))) {
2178 if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2179 r_flags | REXEC_CHECKED))
2183 LEAVE_SCOPE(oldsave);
2186 #ifdef PERL_OLD_COPY_ON_WRITE
2187 if (SvIsCOW(TARG)) {
2188 assert (!force_on_match);
2192 if (force_on_match) {
2194 s = SvPV_force(TARG, len);
2199 SvSCREAM_off(TARG); /* disable possible screamer */
2201 rxtainted |= RX_MATCH_TAINTED(rx);
2202 m = orig + rx->startp[0];
2203 d = orig + rx->endp[0];
2205 if (m - s > strend - d) { /* faster to shorten from end */
2207 Copy(c, m, clen, char);
2212 Move(d, m, i, char);
2216 SvCUR_set(TARG, m - s);
2218 else if ((i = m - s)) { /* faster from front */
2226 Copy(c, m, clen, char);
2231 Copy(c, d, clen, char);
2236 TAINT_IF(rxtainted & 1);
2242 if (iters++ > maxiters)
2243 DIE(aTHX_ "Substitution loop");
2244 rxtainted |= RX_MATCH_TAINTED(rx);
2245 m = rx->startp[0] + orig;
2248 Move(s, d, i, char);
2252 Copy(c, d, clen, char);
2255 s = rx->endp[0] + orig;
2256 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2258 /* don't match same null twice */
2259 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2262 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2263 Move(s, d, i+1, char); /* include the NUL */
2265 TAINT_IF(rxtainted & 1);
2267 PUSHs(sv_2mortal(newSViv((I32)iters)));
2269 (void)SvPOK_only_UTF8(TARG);
2270 TAINT_IF(rxtainted);
2271 if (SvSMAGICAL(TARG)) {
2279 LEAVE_SCOPE(oldsave);
2283 if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2284 r_flags | REXEC_CHECKED))
2286 if (force_on_match) {
2288 s = SvPV_force(TARG, len);
2291 #ifdef PERL_OLD_COPY_ON_WRITE
2294 rxtainted |= RX_MATCH_TAINTED(rx);
2295 dstr = newSVpvn(m, s-m);
2300 register PERL_CONTEXT *cx;
2302 (void)ReREFCNT_inc(rx);
2304 RETURNOP(cPMOP->op_pmreplroot);
2306 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2308 if (iters++ > maxiters)
2309 DIE(aTHX_ "Substitution loop");
2310 rxtainted |= RX_MATCH_TAINTED(rx);
2311 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2316 strend = s + (strend - m);
2318 m = rx->startp[0] + orig;
2319 if (doutf8 && !SvUTF8(dstr))
2320 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2322 sv_catpvn(dstr, s, m-s);
2323 s = rx->endp[0] + orig;
2325 sv_catpvn(dstr, c, clen);
2328 } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2329 TARG, NULL, r_flags));
2330 if (doutf8 && !DO_UTF8(TARG))
2331 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2333 sv_catpvn(dstr, s, strend - s);
2335 #ifdef PERL_OLD_COPY_ON_WRITE
2336 /* The match may make the string COW. If so, brilliant, because that's
2337 just saved us one malloc, copy and free - the regexp has donated
2338 the old buffer, and we malloc an entirely new one, rather than the
2339 regexp malloc()ing a buffer and copying our original, only for
2340 us to throw it away here during the substitution. */
2341 if (SvIsCOW(TARG)) {
2342 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2348 SvPV_set(TARG, SvPVX(dstr));
2349 SvCUR_set(TARG, SvCUR(dstr));
2350 SvLEN_set(TARG, SvLEN(dstr));
2351 doutf8 |= DO_UTF8(dstr);
2352 SvPV_set(dstr, NULL);
2355 TAINT_IF(rxtainted & 1);
2357 PUSHs(sv_2mortal(newSViv((I32)iters)));
2359 (void)SvPOK_only(TARG);
2362 TAINT_IF(rxtainted);
2365 LEAVE_SCOPE(oldsave);
2374 LEAVE_SCOPE(oldsave);
2383 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2384 ++*PL_markstack_ptr;
2385 LEAVE; /* exit inner scope */
2388 if (PL_stack_base + *PL_markstack_ptr > SP) {
2390 const I32 gimme = GIMME_V;
2392 LEAVE; /* exit outer scope */
2393 (void)POPMARK; /* pop src */
2394 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2395 (void)POPMARK; /* pop dst */
2396 SP = PL_stack_base + POPMARK; /* pop original mark */
2397 if (gimme == G_SCALAR) {
2398 if (PL_op->op_private & OPpGREP_LEX) {
2399 SV* const sv = sv_newmortal();
2400 sv_setiv(sv, items);
2408 else if (gimme == G_ARRAY)
2415 ENTER; /* enter inner scope */
2418 src = PL_stack_base[*PL_markstack_ptr];
2420 if (PL_op->op_private & OPpGREP_LEX)
2421 PAD_SVl(PL_op->op_targ) = src;
2425 RETURNOP(cLOGOP->op_other);
2436 register PERL_CONTEXT *cx;
2439 if (CxMULTICALL(&cxstack[cxstack_ix]))
2443 cxstack_ix++; /* temporarily protect top context */
2446 if (gimme == G_SCALAR) {
2449 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2451 *MARK = SvREFCNT_inc(TOPs);
2456 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2458 *MARK = sv_mortalcopy(sv);
2463 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2467 *MARK = &PL_sv_undef;
2471 else if (gimme == G_ARRAY) {
2472 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2473 if (!SvTEMP(*MARK)) {
2474 *MARK = sv_mortalcopy(*MARK);
2475 TAINT_NOT; /* Each item is independent */
2483 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2484 PL_curpm = newpm; /* ... and pop $1 et al */
2487 return cx->blk_sub.retop;
2490 /* This duplicates the above code because the above code must not
2491 * get any slower by more conditions */
2499 register PERL_CONTEXT *cx;
2502 if (CxMULTICALL(&cxstack[cxstack_ix]))
2506 cxstack_ix++; /* temporarily protect top context */
2510 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2511 /* We are an argument to a function or grep().
2512 * This kind of lvalueness was legal before lvalue
2513 * subroutines too, so be backward compatible:
2514 * cannot report errors. */
2516 /* Scalar context *is* possible, on the LHS of -> only,
2517 * as in f()->meth(). But this is not an lvalue. */
2518 if (gimme == G_SCALAR)
2520 if (gimme == G_ARRAY) {
2521 if (!CvLVALUE(cx->blk_sub.cv))
2522 goto temporise_array;
2523 EXTEND_MORTAL(SP - newsp);
2524 for (mark = newsp + 1; mark <= SP; mark++) {
2527 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2528 *mark = sv_mortalcopy(*mark);
2530 /* Can be a localized value subject to deletion. */
2531 PL_tmps_stack[++PL_tmps_ix] = *mark;
2532 SvREFCNT_inc_void(*mark);
2537 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2538 /* Here we go for robustness, not for speed, so we change all
2539 * the refcounts so the caller gets a live guy. Cannot set
2540 * TEMP, so sv_2mortal is out of question. */
2541 if (!CvLVALUE(cx->blk_sub.cv)) {
2547 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2549 if (gimme == G_SCALAR) {
2553 /* Temporaries are bad unless they happen to be elements
2554 * of a tied hash or array */
2555 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2556 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2562 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2563 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2564 : "a readonly value" : "a temporary");
2566 else { /* Can be a localized value
2567 * subject to deletion. */
2568 PL_tmps_stack[++PL_tmps_ix] = *mark;
2569 SvREFCNT_inc_void(*mark);
2572 else { /* Should not happen? */
2578 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2579 (MARK > SP ? "Empty array" : "Array"));
2583 else if (gimme == G_ARRAY) {
2584 EXTEND_MORTAL(SP - newsp);
2585 for (mark = newsp + 1; mark <= SP; mark++) {
2586 if (*mark != &PL_sv_undef
2587 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2588 /* Might be flattened array after $#array = */
2595 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2596 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2599 /* Can be a localized value subject to deletion. */
2600 PL_tmps_stack[++PL_tmps_ix] = *mark;
2601 SvREFCNT_inc_void(*mark);
2607 if (gimme == G_SCALAR) {
2611 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2613 *MARK = SvREFCNT_inc(TOPs);
2618 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2620 *MARK = sv_mortalcopy(sv);
2625 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2629 *MARK = &PL_sv_undef;
2633 else if (gimme == G_ARRAY) {
2635 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2636 if (!SvTEMP(*MARK)) {
2637 *MARK = sv_mortalcopy(*MARK);
2638 TAINT_NOT; /* Each item is independent */
2647 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2648 PL_curpm = newpm; /* ... and pop $1 et al */
2651 return cx->blk_sub.retop;
2656 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2659 SV * const dbsv = GvSVn(PL_DBsub);
2662 if (!PERLDB_SUB_NN) {
2663 GV * const gv = CvGV(cv);
2665 if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2666 || strEQ(GvNAME(gv), "END")
2667 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2668 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) ))) {
2669 /* Use GV from the stack as a fallback. */
2670 /* GV is potentially non-unique, or contain different CV. */
2671 SV * const tmp = newRV((SV*)cv);
2672 sv_setsv(dbsv, tmp);
2676 gv_efullname3(dbsv, gv, NULL);
2680 const int type = SvTYPE(dbsv);
2681 if (type < SVt_PVIV && type != SVt_IV)
2682 sv_upgrade(dbsv, SVt_PVIV);
2683 (void)SvIOK_on(dbsv);
2684 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
2688 PL_curcopdb = PL_curcop;
2689 cv = GvCV(PL_DBsub);
2698 register PERL_CONTEXT *cx;
2700 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2703 DIE(aTHX_ "Not a CODE reference");
2704 switch (SvTYPE(sv)) {
2705 /* This is overwhelming the most common case: */
2707 if (!(cv = GvCVu((GV*)sv))) {
2709 cv = sv_2cv(sv, &stash, &gv, 0);
2720 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2722 SP = PL_stack_base + POPMARK;
2725 if (SvGMAGICAL(sv)) {
2729 sym = SvPOKp(sv) ? SvPVX_const(sv) : NULL;
2732 sym = SvPV_nolen_const(sv);
2735 DIE(aTHX_ PL_no_usym, "a subroutine");
2736 if (PL_op->op_private & HINT_STRICT_REFS)
2737 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2738 cv = get_cv(sym, TRUE);
2743 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2744 tryAMAGICunDEREF(to_cv);
2747 if (SvTYPE(cv) == SVt_PVCV)
2752 DIE(aTHX_ "Not a CODE reference");
2753 /* This is the second most common case: */
2763 if (!CvROOT(cv) && !CvXSUB(cv)) {
2767 /* anonymous or undef'd function leaves us no recourse */
2768 if (CvANON(cv) || !(gv = CvGV(cv)))
2769 DIE(aTHX_ "Undefined subroutine called");
2771 /* autoloaded stub? */
2772 if (cv != GvCV(gv)) {
2775 /* should call AUTOLOAD now? */
2778 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2785 sub_name = sv_newmortal();
2786 gv_efullname3(sub_name, gv, NULL);
2787 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2791 DIE(aTHX_ "Not a CODE reference");
2796 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2797 if (CvASSERTION(cv) && PL_DBassertion)
2798 sv_setiv(PL_DBassertion, 1);
2800 cv = get_db_sub(&sv, cv);
2801 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2802 DIE(aTHX_ "No DB::sub routine defined");
2805 if (!(CvISXSUB(cv))) {
2806 /* This path taken at least 75% of the time */
2808 register I32 items = SP - MARK;
2809 AV* const padlist = CvPADLIST(cv);
2810 PUSHBLOCK(cx, CXt_SUB, MARK);
2812 cx->blk_sub.retop = PL_op->op_next;
2814 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2815 * that eval'' ops within this sub know the correct lexical space.
2816 * Owing the speed considerations, we choose instead to search for
2817 * the cv using find_runcv() when calling doeval().
2819 if (CvDEPTH(cv) >= 2) {
2820 PERL_STACK_OVERFLOW_CHECK();
2821 pad_push(padlist, CvDEPTH(cv));
2824 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2827 AV* const av = (AV*)PAD_SVl(0);
2829 /* @_ is normally not REAL--this should only ever
2830 * happen when DB::sub() calls things that modify @_ */
2835 cx->blk_sub.savearray = GvAV(PL_defgv);
2836 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2837 CX_CURPAD_SAVE(cx->blk_sub);
2838 cx->blk_sub.argarray = av;
2841 if (items > AvMAX(av) + 1) {
2842 SV **ary = AvALLOC(av);
2843 if (AvARRAY(av) != ary) {
2844 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2845 SvPV_set(av, (char*)ary);
2847 if (items > AvMAX(av) + 1) {
2848 AvMAX(av) = items - 1;
2849 Renew(ary,items,SV*);
2851 SvPV_set(av, (char*)ary);
2854 Copy(MARK,AvARRAY(av),items,SV*);
2855 AvFILLp(av) = items - 1;
2863 /* warning must come *after* we fully set up the context
2864 * stuff so that __WARN__ handlers can safely dounwind()
2867 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2868 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2869 sub_crush_depth(cv);
2871 DEBUG_S(PerlIO_printf(Perl_debug_log,
2872 "%p entersub returning %p\n", thr, CvSTART(cv)));
2874 RETURNOP(CvSTART(cv));
2877 I32 markix = TOPMARK;
2882 /* Need to copy @_ to stack. Alternative may be to
2883 * switch stack to @_, and copy return values
2884 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2885 AV * const av = GvAV(PL_defgv);
2886 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2889 /* Mark is at the end of the stack. */
2891 Copy(AvARRAY(av), SP + 1, items, SV*);
2896 /* We assume first XSUB in &DB::sub is the called one. */
2898 SAVEVPTR(PL_curcop);
2899 PL_curcop = PL_curcopdb;
2902 /* Do we need to open block here? XXXX */
2903 (void)(*CvXSUB(cv))(aTHX_ cv);
2905 /* Enforce some sanity in scalar context. */
2906 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2907 if (markix > PL_stack_sp - PL_stack_base)
2908 *(PL_stack_base + markix) = &PL_sv_undef;
2910 *(PL_stack_base + markix) = *PL_stack_sp;
2911 PL_stack_sp = PL_stack_base + markix;
2919 Perl_sub_crush_depth(pTHX_ CV *cv)
2922 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2924 SV* const tmpstr = sv_newmortal();
2925 gv_efullname3(tmpstr, CvGV(cv), NULL);
2926 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2935 SV* const elemsv = POPs;
2936 IV elem = SvIV(elemsv);
2937 AV* const av = (AV*)POPs;
2938 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2939 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2942 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2943 Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2945 elem -= PL_curcop->cop_arybase;
2946 if (SvTYPE(av) != SVt_PVAV)
2948 svp = av_fetch(av, elem, lval && !defer);
2950 #ifdef PERL_MALLOC_WRAP
2951 if (SvUOK(elemsv)) {
2952 const UV uv = SvUV(elemsv);
2953 elem = uv > IV_MAX ? IV_MAX : uv;
2955 else if (SvNOK(elemsv))
2956 elem = (IV)SvNV(elemsv);
2958 static const char oom_array_extend[] =
2959 "Out of memory during array extend"; /* Duplicated in av.c */
2960 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2963 if (!svp || *svp == &PL_sv_undef) {
2966 DIE(aTHX_ PL_no_aelem, elem);
2967 lv = sv_newmortal();
2968 sv_upgrade(lv, SVt_PVLV);
2970 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2971 LvTARG(lv) = SvREFCNT_inc_simple(av);
2972 LvTARGOFF(lv) = elem;
2977 if (PL_op->op_private & OPpLVAL_INTRO)
2978 save_aelem(av, elem, svp);
2979 else if (PL_op->op_private & OPpDEREF)
2980 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2982 sv = (svp ? *svp : &PL_sv_undef);
2983 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2984 sv = sv_mortalcopy(sv);
2990 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2995 Perl_croak(aTHX_ PL_no_modify);
2996 if (SvTYPE(sv) < SVt_RV)
2997 sv_upgrade(sv, SVt_RV);
2998 else if (SvTYPE(sv) >= SVt_PV) {
3005 SvRV_set(sv, newSV(0));
3008 SvRV_set(sv, (SV*)newAV());
3011 SvRV_set(sv, (SV*)newHV());
3022 SV* const sv = TOPs;
3025 SV* const rsv = SvRV(sv);
3026 if (SvTYPE(rsv) == SVt_PVCV) {
3032 SETs(method_common(sv, NULL));
3039 SV* const sv = cSVOP_sv;
3040 U32 hash = SvSHARED_HASH(sv);
3042 XPUSHs(method_common(sv, &hash));
3047 S_method_common(pTHX_ SV* meth, U32* hashp)
3054 const char* packname = NULL;
3057 const char * const name = SvPV_const(meth, namelen);
3058 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3061 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3069 /* this isn't a reference */
3070 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3071 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3073 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3080 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3081 !(ob=(SV*)GvIO(iogv)))
3083 /* this isn't the name of a filehandle either */
3085 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3086 ? !isIDFIRST_utf8((U8*)packname)
3087 : !isIDFIRST(*packname)
3090 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3091 SvOK(sv) ? "without a package or object reference"
3092 : "on an undefined value");
3094 /* assume it's a package name */
3095 stash = gv_stashpvn(packname, packlen, FALSE);
3099 SV* ref = newSViv(PTR2IV(stash));
3100 hv_store(PL_stashcache, packname, packlen, ref, 0);
3104 /* it _is_ a filehandle name -- replace with a reference */
3105 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3108 /* if we got here, ob should be a reference or a glob */
3109 if (!ob || !(SvOBJECT(ob)
3110 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3113 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3117 stash = SvSTASH(ob);
3120 /* NOTE: stash may be null, hope hv_fetch_ent and
3121 gv_fetchmethod can cope (it seems they can) */
3123 /* shortcut for simple names */
3125 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3127 gv = (GV*)HeVAL(he);
3128 if (isGV(gv) && GvCV(gv) &&
3129 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3130 return (SV*)GvCV(gv);
3134 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3137 /* This code tries to figure out just what went wrong with
3138 gv_fetchmethod. It therefore needs to duplicate a lot of
3139 the internals of that function. We can't move it inside
3140 Perl_gv_fetchmethod_autoload(), however, since that would
3141 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3144 const char* leaf = name;
3145 const char* sep = NULL;
3148 for (p = name; *p; p++) {
3150 sep = p, leaf = p + 1;
3151 else if (*p == ':' && *(p + 1) == ':')
3152 sep = p, leaf = p + 2;
3154 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3155 /* the method name is unqualified or starts with SUPER:: */
3156 bool need_strlen = 1;
3158 packname = CopSTASHPV(PL_curcop);
3161 HEK * const packhek = HvNAME_HEK(stash);
3163 packname = HEK_KEY(packhek);
3164 packlen = HEK_LEN(packhek);
3174 "Can't use anonymous symbol table for method lookup");
3176 else if (need_strlen)
3177 packlen = strlen(packname);
3181 /* the method name is qualified */
3183 packlen = sep - name;
3186 /* we're relying on gv_fetchmethod not autovivifying the stash */
3187 if (gv_stashpvn(packname, packlen, FALSE)) {
3189 "Can't locate object method \"%s\" via package \"%.*s\"",
3190 leaf, (int)packlen, packname);
3194 "Can't locate object method \"%s\" via package \"%.*s\""
3195 " (perhaps you forgot to load \"%.*s\"?)",
3196 leaf, (int)packlen, packname, (int)packlen, packname);
3199 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3204 * c-indentation-style: bsd
3206 * indent-tabs-mode: t
3209 * ex: set ts=8 sts=4 sw=4 noet: