3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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
42 if ( PL_op->op_flags & OPf_SPECIAL )
43 /* This is a const op added to hold the hints hash for
44 pp_entereval. The hash can be modified by the code
45 being eval'ed, so we return a copy instead. */
46 XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)));
56 PL_curcop = (COP*)PL_op;
57 TAINT_NOT; /* Each statement is presumed innocent */
58 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
68 if (PL_op->op_private & OPpLVAL_INTRO)
69 PUSHs(save_scalar(cGVOP_gv));
71 PUSHs(GvSVn(cGVOP_gv));
84 PL_curcop = (COP*)PL_op;
91 PUSHMARK(PL_stack_sp);
106 XPUSHs((SV*)cGVOP_gv);
116 if (PL_op->op_type == OP_AND)
118 RETURNOP(cLOGOP->op_other);
124 dVAR; dSP; dPOPTOPssrl;
126 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
127 SV * const temp = left;
128 left = right; right = temp;
130 if (PL_tainting && PL_tainted && !SvTAINTED(left))
132 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
133 SV * const cv = SvRV(left);
134 const U32 cv_type = SvTYPE(cv);
135 const U32 gv_type = SvTYPE(right);
136 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
142 /* Can do the optimisation if right (LVALUE) is not a typeglob,
143 left (RVALUE) is a reference to something, and we're in void
145 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
146 /* Is the target symbol table currently empty? */
147 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
148 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
149 /* Good. Create a new proxy constant subroutine in the target.
150 The gv becomes a(nother) reference to the constant. */
151 SV *const value = SvRV(cv);
153 SvUPGRADE((SV *)gv, SVt_RV);
154 SvPCS_IMPORTED_on(gv);
156 SvREFCNT_inc_simple_void(value);
162 /* Need to fix things up. */
163 if (gv_type != SVt_PVGV) {
164 /* Need to fix GV. */
165 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
169 /* We've been returned a constant rather than a full subroutine,
170 but they expect a subroutine reference to apply. */
173 SvREFCNT_inc_void(SvRV(cv));
174 /* newCONSTSUB takes a reference count on the passed in SV
175 from us. We set the name to NULL, otherwise we get into
176 all sorts of fun as the reference to our new sub is
177 donated to the GV that we're about to assign to.
179 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
184 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
186 First: ops for \&{"BONK"}; return us the constant in the
188 Second: ops for *{"BONK"} cause that symbol table entry
189 (and our reference to it) to be upgraded from RV
191 Thirdly: We get here. cv is actually PVGV now, and its
192 GvCV() is actually the subroutine we're looking for
194 So change the reference so that it points to the subroutine
195 of that typeglob, as that's what they were after all along.
197 GV *const upgraded = (GV *) cv;
198 CV *const source = GvCV(upgraded);
201 assert(CvFLAGS(source) & CVf_CONST);
203 SvREFCNT_inc_void(source);
204 SvREFCNT_dec(upgraded);
205 SvRV_set(left, (SV *)source);
210 SvSetMagicSV(right, left);
219 RETURNOP(cLOGOP->op_other);
221 RETURNOP(cLOGOP->op_next);
228 TAINT_NOT; /* Each statement is presumed innocent */
229 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
231 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
238 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
243 const char *rpv = NULL;
245 bool rcopied = FALSE;
247 if (TARG == right && right != left) {
248 /* mg_get(right) may happen here ... */
249 rpv = SvPV_const(right, rlen);
250 rbyte = !DO_UTF8(right);
251 right = sv_2mortal(newSVpvn(rpv, rlen));
252 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
258 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
259 lbyte = !DO_UTF8(left);
260 sv_setpvn(TARG, lpv, llen);
266 else { /* TARG == left */
268 SvGETMAGIC(left); /* or mg_get(left) may happen here */
270 if (left == right && ckWARN(WARN_UNINITIALIZED))
271 report_uninit(right);
272 sv_setpvn(left, "", 0);
274 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
275 lbyte = !DO_UTF8(left);
280 /* or mg_get(right) may happen here */
282 rpv = SvPV_const(right, rlen);
283 rbyte = !DO_UTF8(right);
285 if (lbyte != rbyte) {
287 sv_utf8_upgrade_nomg(TARG);
290 right = sv_2mortal(newSVpvn(rpv, rlen));
291 sv_utf8_upgrade_nomg(right);
292 rpv = SvPV_const(right, rlen);
295 sv_catpvn_nomg(TARG, rpv, rlen);
306 if (PL_op->op_flags & OPf_MOD) {
307 if (PL_op->op_private & OPpLVAL_INTRO)
308 if (!(PL_op->op_private & OPpPAD_STATE))
309 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
310 if (PL_op->op_private & OPpDEREF) {
312 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
322 tryAMAGICunTARGET(iter, 0);
323 PL_last_in_gv = (GV*)(*PL_stack_sp--);
324 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
325 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
326 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
329 XPUSHs((SV*)PL_last_in_gv);
332 PL_last_in_gv = (GV*)(*PL_stack_sp--);
335 return do_readline();
340 dVAR; dSP; tryAMAGICbinSET(eq,0);
341 #ifndef NV_PRESERVES_UV
342 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
344 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
348 #ifdef PERL_PRESERVE_IVUV
351 /* Unless the left argument is integer in range we are going
352 to have to use NV maths. Hence only attempt to coerce the
353 right argument if we know the left is integer. */
356 const bool auvok = SvUOK(TOPm1s);
357 const bool buvok = SvUOK(TOPs);
359 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
360 /* Casting IV to UV before comparison isn't going to matter
361 on 2s complement. On 1s complement or sign&magnitude
362 (if we have any of them) it could to make negative zero
363 differ from normal zero. As I understand it. (Need to
364 check - is negative zero implementation defined behaviour
366 const UV buv = SvUVX(POPs);
367 const UV auv = SvUVX(TOPs);
369 SETs(boolSV(auv == buv));
372 { /* ## Mixed IV,UV ## */
376 /* == is commutative so doesn't matter which is left or right */
378 /* top of stack (b) is the iv */
387 /* As uv is a UV, it's >0, so it cannot be == */
390 /* we know iv is >= 0 */
391 SETs(boolSV((UV)iv == SvUVX(uvp)));
398 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
400 if (Perl_isnan(left) || Perl_isnan(right))
402 SETs(boolSV(left == right));
405 SETs(boolSV(TOPn == value));
414 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
415 DIE(aTHX_ PL_no_modify);
416 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
417 && SvIVX(TOPs) != IV_MAX)
419 SvIV_set(TOPs, SvIVX(TOPs) + 1);
420 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
422 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
434 if (PL_op->op_type == OP_OR)
436 RETURNOP(cLOGOP->op_other);
445 const int op_type = PL_op->op_type;
446 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
450 if (!sv || !SvANY(sv)) {
451 if (op_type == OP_DOR)
453 RETURNOP(cLOGOP->op_other);
459 if (!sv || !SvANY(sv))
464 switch (SvTYPE(sv)) {
466 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
470 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
474 if (CvROOT(sv) || CvXSUB(sv))
487 if(op_type == OP_DOR)
489 RETURNOP(cLOGOP->op_other);
491 /* assuming OP_DEFINED */
499 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
500 useleft = USE_LEFT(TOPm1s);
501 #ifdef PERL_PRESERVE_IVUV
502 /* We must see if we can perform the addition with integers if possible,
503 as the integer code detects overflow while the NV code doesn't.
504 If either argument hasn't had a numeric conversion yet attempt to get
505 the IV. It's important to do this now, rather than just assuming that
506 it's not IOK as a PV of "9223372036854775806" may not take well to NV
507 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
508 integer in case the second argument is IV=9223372036854775806
509 We can (now) rely on sv_2iv to do the right thing, only setting the
510 public IOK flag if the value in the NV (or PV) slot is truly integer.
512 A side effect is that this also aggressively prefers integer maths over
513 fp maths for integer values.
515 How to detect overflow?
517 C 99 section 6.2.6.1 says
519 The range of nonnegative values of a signed integer type is a subrange
520 of the corresponding unsigned integer type, and the representation of
521 the same value in each type is the same. A computation involving
522 unsigned operands can never overflow, because a result that cannot be
523 represented by the resulting unsigned integer type is reduced modulo
524 the number that is one greater than the largest value that can be
525 represented by the resulting type.
529 which I read as "unsigned ints wrap."
531 signed integer overflow seems to be classed as "exception condition"
533 If an exceptional condition occurs during the evaluation of an
534 expression (that is, if the result is not mathematically defined or not
535 in the range of representable values for its type), the behavior is
538 (6.5, the 5th paragraph)
540 I had assumed that on 2s complement machines signed arithmetic would
541 wrap, hence coded pp_add and pp_subtract on the assumption that
542 everything perl builds on would be happy. After much wailing and
543 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
544 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
545 unsigned code below is actually shorter than the old code. :-)
550 /* Unless the left argument is integer in range we are going to have to
551 use NV maths. Hence only attempt to coerce the right argument if
552 we know the left is integer. */
560 /* left operand is undef, treat as zero. + 0 is identity,
561 Could SETi or SETu right now, but space optimise by not adding
562 lots of code to speed up what is probably a rarish case. */
564 /* Left operand is defined, so is it IV? */
567 if ((auvok = SvUOK(TOPm1s)))
570 register const IV aiv = SvIVX(TOPm1s);
573 auvok = 1; /* Now acting as a sign flag. */
574 } else { /* 2s complement assumption for IV_MIN */
582 bool result_good = 0;
585 bool buvok = SvUOK(TOPs);
590 register const IV biv = SvIVX(TOPs);
597 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
598 else "IV" now, independent of how it came in.
599 if a, b represents positive, A, B negative, a maps to -A etc
604 all UV maths. negate result if A negative.
605 add if signs same, subtract if signs differ. */
611 /* Must get smaller */
617 /* result really should be -(auv-buv). as its negation
618 of true value, need to swap our result flag */
635 if (result <= (UV)IV_MIN)
638 /* result valid, but out of range for IV. */
643 } /* Overflow, drop through to NVs. */
650 /* left operand is undef, treat as zero. + 0.0 is identity. */
654 SETn( value + TOPn );
662 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
663 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
664 const U32 lval = PL_op->op_flags & OPf_MOD;
665 SV** const svp = av_fetch(av, PL_op->op_private, lval);
666 SV *sv = (svp ? *svp : &PL_sv_undef);
668 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
669 sv = sv_mortalcopy(sv);
676 dVAR; dSP; dMARK; dTARGET;
678 do_join(TARG, *MARK, MARK, SP);
689 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
690 * will be enough to hold an OP*.
692 SV* const sv = sv_newmortal();
693 sv_upgrade(sv, SVt_PVLV);
695 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
703 /* Oversized hot code. */
707 dVAR; dSP; dMARK; dORIGMARK;
711 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
713 if (gv && (io = GvIO(gv))
714 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
717 if (MARK == ORIGMARK) {
718 /* If using default handle then we need to make space to
719 * pass object as 1st arg, so move other args up ...
723 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
727 *MARK = SvTIED_obj((SV*)io, mg);
730 call_method("PRINT", G_SCALAR);
738 if (!(io = GvIO(gv))) {
739 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
740 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
742 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
743 report_evil_fh(gv, io, PL_op->op_type);
744 SETERRNO(EBADF,RMS_IFI);
747 else if (!(fp = IoOFP(io))) {
748 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
750 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
751 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
752 report_evil_fh(gv, io, PL_op->op_type);
754 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
759 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
761 if (!do_print(*MARK, fp))
765 if (!do_print(PL_ofs_sv, fp)) { /* $, */
774 if (!do_print(*MARK, fp))
782 if (PL_op->op_type == OP_SAY) {
783 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
786 else if (PL_ors_sv && SvOK(PL_ors_sv))
787 if (!do_print(PL_ors_sv, fp)) /* $\ */
790 if (IoFLAGS(io) & IOf_FLUSH)
791 if (PerlIO_flush(fp) == EOF)
801 XPUSHs(&PL_sv_undef);
808 const I32 gimme = GIMME_V;
809 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
810 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
811 static const char an_array[] = "an ARRAY";
812 static const char a_hash[] = "a HASH";
813 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
814 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
818 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
821 if (SvTYPE(sv) != type)
822 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
823 if (PL_op->op_flags & OPf_REF) {
828 if (gimme != G_ARRAY)
829 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
830 : return_hash_to_lvalue_scalar);
834 else if (PL_op->op_flags & OPf_MOD
835 && PL_op->op_private & OPpLVAL_INTRO)
836 Perl_croak(aTHX_ PL_no_localize_ref);
839 if (SvTYPE(sv) == type) {
840 if (PL_op->op_flags & OPf_REF) {
845 if (gimme != G_ARRAY)
847 is_pp_rv2av ? return_array_to_lvalue_scalar
848 : return_hash_to_lvalue_scalar);
856 if (SvTYPE(sv) != SVt_PVGV) {
857 if (SvGMAGICAL(sv)) {
862 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
870 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
871 if (PL_op->op_private & OPpLVAL_INTRO)
872 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
873 if (PL_op->op_flags & OPf_REF) {
878 if (gimme != G_ARRAY)
880 is_pp_rv2av ? return_array_to_lvalue_scalar
881 : return_hash_to_lvalue_scalar);
889 AV *const av = (AV*)sv;
890 /* The guts of pp_rv2av, with no intenting change to preserve history
891 (until such time as we get tools that can do blame annotation across
892 whitespace changes. */
893 if (gimme == G_ARRAY) {
894 const I32 maxarg = AvFILL(av) + 1;
895 (void)POPs; /* XXXX May be optimized away? */
897 if (SvRMAGICAL(av)) {
899 for (i=0; i < (U32)maxarg; i++) {
900 SV ** const svp = av_fetch(av, i, FALSE);
901 /* See note in pp_helem, and bug id #27839 */
903 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
908 Copy(AvARRAY(av), SP+1, maxarg, SV*);
912 else if (gimme == G_SCALAR) {
914 const I32 maxarg = AvFILL(av) + 1;
918 /* The guts of pp_rv2hv */
919 if (gimme == G_ARRAY) { /* array wanted */
923 else if (gimme == G_SCALAR) {
925 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
934 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
941 if (ckWARN(WARN_MISC)) {
943 if (relem == firstrelem &&
945 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
946 SvTYPE(SvRV(*relem)) == SVt_PVHV))
948 err = "Reference found where even-sized list expected";
951 err = "Odd number of elements in hash assignment";
952 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
956 didstore = hv_store_ent(hash,*relem,tmpstr,0);
957 if (SvMAGICAL(hash)) {
958 if (SvSMAGICAL(tmpstr))
970 SV **lastlelem = PL_stack_sp;
971 SV **lastrelem = PL_stack_base + POPMARK;
972 SV **firstrelem = PL_stack_base + POPMARK + 1;
973 SV **firstlelem = lastrelem + 1;
986 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
988 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
991 /* If there's a common identifier on both sides we have to take
992 * special care that assigning the identifier on the left doesn't
993 * clobber a value on the right that's used later in the list.
995 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
996 EXTEND_MORTAL(lastrelem - firstrelem + 1);
997 for (relem = firstrelem; relem <= lastrelem; relem++) {
999 TAINT_NOT; /* Each item is independent */
1000 *relem = sv_mortalcopy(sv);
1010 while (lelem <= lastlelem) {
1011 TAINT_NOT; /* Each item stands on its own, taintwise. */
1013 switch (SvTYPE(sv)) {
1016 magic = SvMAGICAL(ary) != 0;
1018 av_extend(ary, lastrelem - relem);
1020 while (relem <= lastrelem) { /* gobble up all the rest */
1023 sv = newSVsv(*relem);
1025 didstore = av_store(ary,i++,sv);
1034 if (PL_delaymagic & DM_ARRAY)
1035 SvSETMAGIC((SV*)ary);
1037 case SVt_PVHV: { /* normal hash */
1041 magic = SvMAGICAL(hash) != 0;
1043 firsthashrelem = relem;
1045 while (relem < lastrelem) { /* gobble up all the rest */
1047 sv = *relem ? *relem : &PL_sv_no;
1051 sv_setsv(tmpstr,*relem); /* value */
1052 *(relem++) = tmpstr;
1053 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1054 /* key overwrites an existing entry */
1056 didstore = hv_store_ent(hash,sv,tmpstr,0);
1058 if (SvSMAGICAL(tmpstr))
1065 if (relem == lastrelem) {
1066 do_oddball(hash, relem, firstrelem);
1072 if (SvIMMORTAL(sv)) {
1073 if (relem <= lastrelem)
1077 if (relem <= lastrelem) {
1078 sv_setsv(sv, *relem);
1082 sv_setsv(sv, &PL_sv_undef);
1087 if (PL_delaymagic & ~DM_DELAY) {
1088 if (PL_delaymagic & DM_UID) {
1089 #ifdef HAS_SETRESUID
1090 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1091 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1094 # ifdef HAS_SETREUID
1095 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1096 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1099 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1100 (void)setruid(PL_uid);
1101 PL_delaymagic &= ~DM_RUID;
1103 # endif /* HAS_SETRUID */
1105 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1106 (void)seteuid(PL_euid);
1107 PL_delaymagic &= ~DM_EUID;
1109 # endif /* HAS_SETEUID */
1110 if (PL_delaymagic & DM_UID) {
1111 if (PL_uid != PL_euid)
1112 DIE(aTHX_ "No setreuid available");
1113 (void)PerlProc_setuid(PL_uid);
1115 # endif /* HAS_SETREUID */
1116 #endif /* HAS_SETRESUID */
1117 PL_uid = PerlProc_getuid();
1118 PL_euid = PerlProc_geteuid();
1120 if (PL_delaymagic & DM_GID) {
1121 #ifdef HAS_SETRESGID
1122 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1123 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1126 # ifdef HAS_SETREGID
1127 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1128 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1131 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1132 (void)setrgid(PL_gid);
1133 PL_delaymagic &= ~DM_RGID;
1135 # endif /* HAS_SETRGID */
1137 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1138 (void)setegid(PL_egid);
1139 PL_delaymagic &= ~DM_EGID;
1141 # endif /* HAS_SETEGID */
1142 if (PL_delaymagic & DM_GID) {
1143 if (PL_gid != PL_egid)
1144 DIE(aTHX_ "No setregid available");
1145 (void)PerlProc_setgid(PL_gid);
1147 # endif /* HAS_SETREGID */
1148 #endif /* HAS_SETRESGID */
1149 PL_gid = PerlProc_getgid();
1150 PL_egid = PerlProc_getegid();
1152 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1156 if (gimme == G_VOID)
1157 SP = firstrelem - 1;
1158 else if (gimme == G_SCALAR) {
1161 SETi(lastrelem - firstrelem + 1 - duplicates);
1168 /* Removes from the stack the entries which ended up as
1169 * duplicated keys in the hash (fix for [perl #24380]) */
1170 Move(firsthashrelem + duplicates,
1171 firsthashrelem, duplicates, SV**);
1172 lastrelem -= duplicates;
1177 SP = firstrelem + (lastlelem - firstlelem);
1178 lelem = firstlelem + (relem - firstrelem);
1180 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1189 register PMOP * const pm = cPMOP;
1190 REGEXP * rx = PM_GETRE(pm);
1191 SV * const pkg = CALLREG_PACKAGE(rx);
1192 SV * const rv = sv_newmortal();
1193 SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1194 if (rx->extflags & RXf_TAINTED)
1196 sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1204 register PMOP *pm = cPMOP;
1206 register const char *t;
1207 register const char *s;
1210 I32 r_flags = REXEC_CHECKED;
1211 const char *truebase; /* Start of string */
1212 register REGEXP *rx = PM_GETRE(pm);
1214 const I32 gimme = GIMME;
1217 const I32 oldsave = PL_savestack_ix;
1218 I32 update_minmatch = 1;
1219 I32 had_zerolen = 0;
1222 if (PL_op->op_flags & OPf_STACKED)
1224 else if (PL_op->op_private & OPpTARGET_MY)
1231 PUTBACK; /* EVAL blocks need stack_sp. */
1232 s = SvPV_const(TARG, len);
1234 DIE(aTHX_ "panic: pp_match");
1236 rxtainted = ((rx->extflags & RXf_TAINTED) ||
1237 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1240 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1242 /* PMdf_USED is set after a ?? matches once */
1245 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1247 pm->op_pmflags & PMf_USED
1251 if (gimme == G_ARRAY)
1258 /* empty pattern special-cased to use last successful pattern if possible */
1259 if (!rx->prelen && PL_curpm) {
1264 if (rx->minlen > (I32)len)
1269 /* XXXX What part of this is needed with true \G-support? */
1270 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1271 rx->offs[0].start = -1;
1272 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1273 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1274 if (mg && mg->mg_len >= 0) {
1275 if (!(rx->extflags & RXf_GPOS_SEEN))
1276 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1277 else if (rx->extflags & RXf_ANCH_GPOS) {
1278 r_flags |= REXEC_IGNOREPOS;
1279 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1280 } else if (rx->extflags & RXf_GPOS_FLOAT)
1283 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1284 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1285 update_minmatch = 0;
1289 /* XXX: comment out !global get safe $1 vars after a
1290 match, BUT be aware that this leads to dramatic slowdowns on
1291 /g matches against large strings. So far a solution to this problem
1292 appears to be quite tricky.
1293 Test for the unsafe vars are TODO for now. */
1294 if (( !global && rx->nparens)
1295 || SvTEMP(TARG) || PL_sawampersand ||
1296 (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1297 r_flags |= REXEC_COPY_STR;
1299 r_flags |= REXEC_SCREAM;
1302 if (global && rx->offs[0].start != -1) {
1303 t = s = rx->offs[0].end + truebase - rx->gofs;
1304 if ((s + rx->minlen) > strend || s < truebase)
1306 if (update_minmatch++)
1307 minmatch = had_zerolen;
1309 if (rx->extflags & RXf_USE_INTUIT &&
1310 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1311 /* FIXME - can PL_bostr be made const char *? */
1312 PL_bostr = (char *)truebase;
1313 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1317 if ( (rx->extflags & RXf_CHECK_ALL)
1319 && !(rx->extflags & RXf_PMf_KEEPCOPY)
1320 && ((rx->extflags & RXf_NOSCAN)
1321 || !((rx->extflags & RXf_INTUIT_TAIL)
1322 && (r_flags & REXEC_SCREAM)))
1323 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1326 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1329 if (dynpm->op_pmflags & PMf_ONCE) {
1331 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1333 dynpm->op_pmflags |= PMf_USED;
1344 RX_MATCH_TAINTED_on(rx);
1345 TAINT_IF(RX_MATCH_TAINTED(rx));
1346 if (gimme == G_ARRAY) {
1347 const I32 nparens = rx->nparens;
1348 I32 i = (global && !nparens) ? 1 : 0;
1350 SPAGAIN; /* EVAL blocks could move the stack. */
1351 EXTEND(SP, nparens + i);
1352 EXTEND_MORTAL(nparens + i);
1353 for (i = !i; i <= nparens; i++) {
1354 PUSHs(sv_newmortal());
1355 if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1356 const I32 len = rx->offs[i].end - rx->offs[i].start;
1357 s = rx->offs[i].start + truebase;
1358 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1359 len < 0 || len > strend - s)
1360 DIE(aTHX_ "panic: pp_match start/end pointers");
1361 sv_setpvn(*SP, s, len);
1362 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1367 if (dynpm->op_pmflags & PMf_CONTINUE) {
1369 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1370 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1372 #ifdef PERL_OLD_COPY_ON_WRITE
1374 sv_force_normal_flags(TARG, 0);
1376 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1377 &PL_vtbl_mglob, NULL, 0);
1379 if (rx->offs[0].start != -1) {
1380 mg->mg_len = rx->offs[0].end;
1381 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1382 mg->mg_flags |= MGf_MINMATCH;
1384 mg->mg_flags &= ~MGf_MINMATCH;
1387 had_zerolen = (rx->offs[0].start != -1
1388 && (rx->offs[0].start + rx->gofs
1389 == (UV)rx->offs[0].end));
1390 PUTBACK; /* EVAL blocks may use stack */
1391 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1396 LEAVE_SCOPE(oldsave);
1402 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1403 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1407 #ifdef PERL_OLD_COPY_ON_WRITE
1409 sv_force_normal_flags(TARG, 0);
1411 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1412 &PL_vtbl_mglob, NULL, 0);
1414 if (rx->offs[0].start != -1) {
1415 mg->mg_len = rx->offs[0].end;
1416 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1417 mg->mg_flags |= MGf_MINMATCH;
1419 mg->mg_flags &= ~MGf_MINMATCH;
1422 LEAVE_SCOPE(oldsave);
1426 yup: /* Confirmed by INTUIT */
1428 RX_MATCH_TAINTED_on(rx);
1429 TAINT_IF(RX_MATCH_TAINTED(rx));
1431 if (dynpm->op_pmflags & PMf_ONCE) {
1433 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1435 dynpm->op_pmflags |= PMf_USED;
1438 if (RX_MATCH_COPIED(rx))
1439 Safefree(rx->subbeg);
1440 RX_MATCH_COPIED_off(rx);
1443 /* FIXME - should rx->subbeg be const char *? */
1444 rx->subbeg = (char *) truebase;
1445 rx->offs[0].start = s - truebase;
1446 if (RX_MATCH_UTF8(rx)) {
1447 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1448 rx->offs[0].end = t - truebase;
1451 rx->offs[0].end = s - truebase + rx->minlenret;
1453 rx->sublen = strend - truebase;
1456 if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1458 #ifdef PERL_OLD_COPY_ON_WRITE
1459 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1461 PerlIO_printf(Perl_debug_log,
1462 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1463 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1466 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1467 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1468 assert (SvPOKp(rx->saved_copy));
1473 rx->subbeg = savepvn(t, strend - t);
1474 #ifdef PERL_OLD_COPY_ON_WRITE
1475 rx->saved_copy = NULL;
1478 rx->sublen = strend - t;
1479 RX_MATCH_COPIED_on(rx);
1480 off = rx->offs[0].start = s - t;
1481 rx->offs[0].end = off + rx->minlenret;
1483 else { /* startp/endp are used by @- @+. */
1484 rx->offs[0].start = s - truebase;
1485 rx->offs[0].end = s - truebase + rx->minlenret;
1487 /* including rx->nparens in the below code seems highly suspicious.
1489 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1490 LEAVE_SCOPE(oldsave);
1495 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1496 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1497 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1502 LEAVE_SCOPE(oldsave);
1503 if (gimme == G_ARRAY)
1509 Perl_do_readline(pTHX)
1511 dVAR; dSP; dTARGETSTACKED;
1516 register IO * const io = GvIO(PL_last_in_gv);
1517 register const I32 type = PL_op->op_type;
1518 const I32 gimme = GIMME_V;
1521 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1524 XPUSHs(SvTIED_obj((SV*)io, mg));
1527 call_method("READLINE", gimme);
1530 if (gimme == G_SCALAR) {
1531 SV* const result = POPs;
1532 SvSetSV_nosteal(TARG, result);
1542 if (IoFLAGS(io) & IOf_ARGV) {
1543 if (IoFLAGS(io) & IOf_START) {
1545 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1546 IoFLAGS(io) &= ~IOf_START;
1547 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1548 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1549 SvSETMAGIC(GvSV(PL_last_in_gv));
1554 fp = nextargv(PL_last_in_gv);
1555 if (!fp) { /* Note: fp != IoIFP(io) */
1556 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1559 else if (type == OP_GLOB)
1560 fp = Perl_start_glob(aTHX_ POPs, io);
1562 else if (type == OP_GLOB)
1564 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1565 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1569 if ((!io || !(IoFLAGS(io) & IOf_START))
1570 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1572 if (type == OP_GLOB)
1573 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1574 "glob failed (can't start child: %s)",
1577 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1579 if (gimme == G_SCALAR) {
1580 /* undef TARG, and push that undefined value */
1581 if (type != OP_RCATLINE) {
1582 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1590 if (gimme == G_SCALAR) {
1592 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1595 if (type == OP_RCATLINE)
1596 SvPV_force_nolen(sv);
1600 else if (isGV_with_GP(sv)) {
1601 SvPV_force_nolen(sv);
1603 SvUPGRADE(sv, SVt_PV);
1604 tmplen = SvLEN(sv); /* remember if already alloced */
1605 if (!tmplen && !SvREADONLY(sv))
1606 Sv_Grow(sv, 80); /* try short-buffering it */
1608 if (type == OP_RCATLINE && SvOK(sv)) {
1610 SvPV_force_nolen(sv);
1616 sv = sv_2mortal(newSV(80));
1620 /* This should not be marked tainted if the fp is marked clean */
1621 #define MAYBE_TAINT_LINE(io, sv) \
1622 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1627 /* delay EOF state for a snarfed empty file */
1628 #define SNARF_EOF(gimme,rs,io,sv) \
1629 (gimme != G_SCALAR || SvCUR(sv) \
1630 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1634 if (!sv_gets(sv, fp, offset)
1636 || SNARF_EOF(gimme, PL_rs, io, sv)
1637 || PerlIO_error(fp)))
1639 PerlIO_clearerr(fp);
1640 if (IoFLAGS(io) & IOf_ARGV) {
1641 fp = nextargv(PL_last_in_gv);
1644 (void)do_close(PL_last_in_gv, FALSE);
1646 else if (type == OP_GLOB) {
1647 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1648 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1649 "glob failed (child exited with status %d%s)",
1650 (int)(STATUS_CURRENT >> 8),
1651 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1654 if (gimme == G_SCALAR) {
1655 if (type != OP_RCATLINE) {
1656 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1662 MAYBE_TAINT_LINE(io, sv);
1665 MAYBE_TAINT_LINE(io, sv);
1667 IoFLAGS(io) |= IOf_NOLINE;
1671 if (type == OP_GLOB) {
1674 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1675 char * const tmps = SvEND(sv) - 1;
1676 if (*tmps == *SvPVX_const(PL_rs)) {
1678 SvCUR_set(sv, SvCUR(sv) - 1);
1681 for (t1 = SvPVX_const(sv); *t1; t1++)
1682 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1683 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1685 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1686 (void)POPs; /* Unmatched wildcard? Chuck it... */
1689 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1690 if (ckWARN(WARN_UTF8)) {
1691 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1692 const STRLEN len = SvCUR(sv) - offset;
1695 if (!is_utf8_string_loc(s, len, &f))
1696 /* Emulate :encoding(utf8) warning in the same case. */
1697 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1698 "utf8 \"\\x%02X\" does not map to Unicode",
1699 f < (U8*)SvEND(sv) ? *f : 0);
1702 if (gimme == G_ARRAY) {
1703 if (SvLEN(sv) - SvCUR(sv) > 20) {
1704 SvPV_shrink_to_cur(sv);
1706 sv = sv_2mortal(newSV(80));
1709 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1710 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1711 const STRLEN new_len
1712 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1713 SvPV_renew(sv, new_len);
1722 register PERL_CONTEXT *cx;
1723 I32 gimme = OP_GIMME(PL_op, -1);
1726 if (cxstack_ix >= 0)
1727 gimme = cxstack[cxstack_ix].blk_gimme;
1735 PUSHBLOCK(cx, CXt_BLOCK, SP);
1745 SV * const keysv = POPs;
1746 HV * const hv = (HV*)POPs;
1747 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1748 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1750 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1753 if (SvTYPE(hv) != SVt_PVHV)
1756 if (PL_op->op_private & OPpLVAL_INTRO) {
1759 /* does the element we're localizing already exist? */
1760 preeminent = /* can we determine whether it exists? */
1762 || mg_find((SV*)hv, PERL_MAGIC_env)
1763 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1764 /* Try to preserve the existenceness of a tied hash
1765 * element by using EXISTS and DELETE if possible.
1766 * Fallback to FETCH and STORE otherwise */
1767 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1768 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1769 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1771 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1773 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1774 svp = he ? &HeVAL(he) : NULL;
1776 if (!svp || *svp == &PL_sv_undef) {
1780 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1782 lv = sv_newmortal();
1783 sv_upgrade(lv, SVt_PVLV);
1785 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1786 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1787 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1792 if (PL_op->op_private & OPpLVAL_INTRO) {
1793 if (HvNAME_get(hv) && isGV(*svp))
1794 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1798 const char * const key = SvPV_const(keysv, keylen);
1799 SAVEDELETE(hv, savepvn(key,keylen),
1800 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1802 save_helem(hv, keysv, svp);
1805 else if (PL_op->op_private & OPpDEREF)
1806 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1808 sv = (svp ? *svp : &PL_sv_undef);
1809 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1810 * Pushing the magical RHS on to the stack is useless, since
1811 * that magic is soon destined to be misled by the local(),
1812 * and thus the later pp_sassign() will fail to mg_get() the
1813 * old value. This should also cure problems with delayed
1814 * mg_get()s. GSAR 98-07-03 */
1815 if (!lval && SvGMAGICAL(sv))
1816 sv = sv_mortalcopy(sv);
1824 register PERL_CONTEXT *cx;
1829 if (PL_op->op_flags & OPf_SPECIAL) {
1830 cx = &cxstack[cxstack_ix];
1831 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1836 gimme = OP_GIMME(PL_op, -1);
1838 if (cxstack_ix >= 0)
1839 gimme = cxstack[cxstack_ix].blk_gimme;
1845 if (gimme == G_VOID)
1847 else if (gimme == G_SCALAR) {
1851 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1854 *MARK = sv_mortalcopy(TOPs);
1857 *MARK = &PL_sv_undef;
1861 else if (gimme == G_ARRAY) {
1862 /* in case LEAVE wipes old return values */
1864 for (mark = newsp + 1; mark <= SP; mark++) {
1865 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1866 *mark = sv_mortalcopy(*mark);
1867 TAINT_NOT; /* Each item is independent */
1871 PL_curpm = newpm; /* Don't pop $1 et al till now */
1881 register PERL_CONTEXT *cx;
1887 cx = &cxstack[cxstack_ix];
1888 if (CxTYPE(cx) != CXt_LOOP)
1889 DIE(aTHX_ "panic: pp_iter");
1891 itersvp = CxITERVAR(cx);
1892 av = cx->blk_loop.iterary;
1893 if (SvTYPE(av) != SVt_PVAV) {
1894 /* iterate ($min .. $max) */
1895 if (cx->blk_loop.iterlval) {
1896 /* string increment */
1897 register SV* cur = cx->blk_loop.iterlval;
1901 SvPV_const((SV*)av, maxlen) : (const char *)"";
1902 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1903 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1904 /* safe to reuse old SV */
1905 sv_setsv(*itersvp, cur);
1909 /* we need a fresh SV every time so that loop body sees a
1910 * completely new SV for closures/references to work as
1913 *itersvp = newSVsv(cur);
1914 SvREFCNT_dec(oldsv);
1916 if (strEQ(SvPVX_const(cur), max))
1917 sv_setiv(cur, 0); /* terminate next time */
1924 /* integer increment */
1925 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1928 /* don't risk potential race */
1929 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1930 /* safe to reuse old SV */
1931 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1935 /* we need a fresh SV every time so that loop body sees a
1936 * completely new SV for closures/references to work as they
1939 *itersvp = newSViv(cx->blk_loop.iterix++);
1940 SvREFCNT_dec(oldsv);
1946 if (PL_op->op_private & OPpITER_REVERSED) {
1947 /* In reverse, use itermax as the min :-) */
1948 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1951 if (SvMAGICAL(av) || AvREIFY(av)) {
1952 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1953 sv = svp ? *svp : NULL;
1956 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1960 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1964 if (SvMAGICAL(av) || AvREIFY(av)) {
1965 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1966 sv = svp ? *svp : NULL;
1969 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1973 if (sv && SvIS_FREED(sv)) {
1975 Perl_croak(aTHX_ "Use of freed value in iteration");
1982 if (av != PL_curstack && sv == &PL_sv_undef) {
1983 SV *lv = cx->blk_loop.iterlval;
1984 if (lv && SvREFCNT(lv) > 1) {
1989 SvREFCNT_dec(LvTARG(lv));
1991 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1993 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1995 LvTARG(lv) = SvREFCNT_inc_simple(av);
1996 LvTARGOFF(lv) = cx->blk_loop.iterix;
1997 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2002 *itersvp = SvREFCNT_inc_simple_NN(sv);
2003 SvREFCNT_dec(oldsv);
2011 register PMOP *pm = cPMOP;
2026 register REGEXP *rx = PM_GETRE(pm);
2028 int force_on_match = 0;
2029 const I32 oldsave = PL_savestack_ix;
2031 bool doutf8 = FALSE;
2032 #ifdef PERL_OLD_COPY_ON_WRITE
2037 /* known replacement string? */
2038 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2039 if (PL_op->op_flags & OPf_STACKED)
2041 else if (PL_op->op_private & OPpTARGET_MY)
2048 #ifdef PERL_OLD_COPY_ON_WRITE
2049 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2050 because they make integers such as 256 "false". */
2051 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2054 sv_force_normal_flags(TARG,0);
2057 #ifdef PERL_OLD_COPY_ON_WRITE
2061 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2062 || SvTYPE(TARG) > SVt_PVLV)
2063 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2064 DIE(aTHX_ PL_no_modify);
2067 s = SvPV_mutable(TARG, len);
2068 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2070 rxtainted = ((rx->extflags & RXf_TAINTED) ||
2071 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2076 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2080 DIE(aTHX_ "panic: pp_subst");
2083 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2084 maxiters = 2 * slen + 10; /* We can match twice at each
2085 position, once with zero-length,
2086 second time with non-zero. */
2088 if (!rx->prelen && PL_curpm) {
2092 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2093 || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2094 ? REXEC_COPY_STR : 0;
2096 r_flags |= REXEC_SCREAM;
2099 if (rx->extflags & RXf_USE_INTUIT) {
2101 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2105 /* How to do it in subst? */
2106 /* if ( (rx->extflags & RXf_CHECK_ALL)
2108 && !(rx->extflags & RXf_KEEPCOPY)
2109 && ((rx->extflags & RXf_NOSCAN)
2110 || !((rx->extflags & RXf_INTUIT_TAIL)
2111 && (r_flags & REXEC_SCREAM))))
2116 /* only replace once? */
2117 once = !(rpm->op_pmflags & PMf_GLOBAL);
2119 /* known replacement string? */
2121 /* replacement needing upgrading? */
2122 if (DO_UTF8(TARG) && !doutf8) {
2123 nsv = sv_newmortal();
2126 sv_recode_to_utf8(nsv, PL_encoding);
2128 sv_utf8_upgrade(nsv);
2129 c = SvPV_const(nsv, clen);
2133 c = SvPV_const(dstr, clen);
2134 doutf8 = DO_UTF8(dstr);
2142 /* can do inplace substitution? */
2144 #ifdef PERL_OLD_COPY_ON_WRITE
2147 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2148 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2149 && (!doutf8 || SvUTF8(TARG))) {
2150 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2151 r_flags | REXEC_CHECKED))
2155 LEAVE_SCOPE(oldsave);
2158 #ifdef PERL_OLD_COPY_ON_WRITE
2159 if (SvIsCOW(TARG)) {
2160 assert (!force_on_match);
2164 if (force_on_match) {
2166 s = SvPV_force(TARG, len);
2171 SvSCREAM_off(TARG); /* disable possible screamer */
2173 rxtainted |= RX_MATCH_TAINTED(rx);
2174 m = orig + rx->offs[0].start;
2175 d = orig + rx->offs[0].end;
2177 if (m - s > strend - d) { /* faster to shorten from end */
2179 Copy(c, m, clen, char);
2184 Move(d, m, i, char);
2188 SvCUR_set(TARG, m - s);
2190 else if ((i = m - s)) { /* faster from front */
2198 Copy(c, m, clen, char);
2203 Copy(c, d, clen, char);
2208 TAINT_IF(rxtainted & 1);
2214 if (iters++ > maxiters)
2215 DIE(aTHX_ "Substitution loop");
2216 rxtainted |= RX_MATCH_TAINTED(rx);
2217 m = rx->offs[0].start + orig;
2220 Move(s, d, i, char);
2224 Copy(c, d, clen, char);
2227 s = rx->offs[0].end + orig;
2228 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2230 /* don't match same null twice */
2231 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2234 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2235 Move(s, d, i+1, char); /* include the NUL */
2237 TAINT_IF(rxtainted & 1);
2239 PUSHs(sv_2mortal(newSViv((I32)iters)));
2241 (void)SvPOK_only_UTF8(TARG);
2242 TAINT_IF(rxtainted);
2243 if (SvSMAGICAL(TARG)) {
2251 LEAVE_SCOPE(oldsave);
2255 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2256 r_flags | REXEC_CHECKED))
2258 if (force_on_match) {
2260 s = SvPV_force(TARG, len);
2263 #ifdef PERL_OLD_COPY_ON_WRITE
2266 rxtainted |= RX_MATCH_TAINTED(rx);
2267 dstr = newSVpvn(m, s-m);
2273 register PERL_CONTEXT *cx;
2276 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2278 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2280 if (iters++ > maxiters)
2281 DIE(aTHX_ "Substitution loop");
2282 rxtainted |= RX_MATCH_TAINTED(rx);
2283 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2288 strend = s + (strend - m);
2290 m = rx->offs[0].start + orig;
2291 if (doutf8 && !SvUTF8(dstr))
2292 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2294 sv_catpvn(dstr, s, m-s);
2295 s = rx->offs[0].end + orig;
2297 sv_catpvn(dstr, c, clen);
2300 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2301 TARG, NULL, r_flags));
2302 if (doutf8 && !DO_UTF8(TARG))
2303 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2305 sv_catpvn(dstr, s, strend - s);
2307 #ifdef PERL_OLD_COPY_ON_WRITE
2308 /* The match may make the string COW. If so, brilliant, because that's
2309 just saved us one malloc, copy and free - the regexp has donated
2310 the old buffer, and we malloc an entirely new one, rather than the
2311 regexp malloc()ing a buffer and copying our original, only for
2312 us to throw it away here during the substitution. */
2313 if (SvIsCOW(TARG)) {
2314 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2320 SvPV_set(TARG, SvPVX(dstr));
2321 SvCUR_set(TARG, SvCUR(dstr));
2322 SvLEN_set(TARG, SvLEN(dstr));
2323 doutf8 |= DO_UTF8(dstr);
2324 SvPV_set(dstr, NULL);
2326 TAINT_IF(rxtainted & 1);
2328 PUSHs(sv_2mortal(newSViv((I32)iters)));
2330 (void)SvPOK_only(TARG);
2333 TAINT_IF(rxtainted);
2336 LEAVE_SCOPE(oldsave);
2345 LEAVE_SCOPE(oldsave);
2354 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2355 ++*PL_markstack_ptr;
2356 LEAVE; /* exit inner scope */
2359 if (PL_stack_base + *PL_markstack_ptr > SP) {
2361 const I32 gimme = GIMME_V;
2363 LEAVE; /* exit outer scope */
2364 (void)POPMARK; /* pop src */
2365 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2366 (void)POPMARK; /* pop dst */
2367 SP = PL_stack_base + POPMARK; /* pop original mark */
2368 if (gimme == G_SCALAR) {
2369 if (PL_op->op_private & OPpGREP_LEX) {
2370 SV* const sv = sv_newmortal();
2371 sv_setiv(sv, items);
2379 else if (gimme == G_ARRAY)
2386 ENTER; /* enter inner scope */
2389 src = PL_stack_base[*PL_markstack_ptr];
2391 if (PL_op->op_private & OPpGREP_LEX)
2392 PAD_SVl(PL_op->op_targ) = src;
2396 RETURNOP(cLOGOP->op_other);
2407 register PERL_CONTEXT *cx;
2410 if (CxMULTICALL(&cxstack[cxstack_ix]))
2414 cxstack_ix++; /* temporarily protect top context */
2417 if (gimme == G_SCALAR) {
2420 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2422 *MARK = SvREFCNT_inc(TOPs);
2427 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2429 *MARK = sv_mortalcopy(sv);
2434 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2438 *MARK = &PL_sv_undef;
2442 else if (gimme == G_ARRAY) {
2443 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2444 if (!SvTEMP(*MARK)) {
2445 *MARK = sv_mortalcopy(*MARK);
2446 TAINT_NOT; /* Each item is independent */
2454 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2455 PL_curpm = newpm; /* ... and pop $1 et al */
2458 return cx->blk_sub.retop;
2461 /* This duplicates the above code because the above code must not
2462 * get any slower by more conditions */
2470 register PERL_CONTEXT *cx;
2473 if (CxMULTICALL(&cxstack[cxstack_ix]))
2477 cxstack_ix++; /* temporarily protect top context */
2481 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2482 /* We are an argument to a function or grep().
2483 * This kind of lvalueness was legal before lvalue
2484 * subroutines too, so be backward compatible:
2485 * cannot report errors. */
2487 /* Scalar context *is* possible, on the LHS of -> only,
2488 * as in f()->meth(). But this is not an lvalue. */
2489 if (gimme == G_SCALAR)
2491 if (gimme == G_ARRAY) {
2492 if (!CvLVALUE(cx->blk_sub.cv))
2493 goto temporise_array;
2494 EXTEND_MORTAL(SP - newsp);
2495 for (mark = newsp + 1; mark <= SP; mark++) {
2498 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2499 *mark = sv_mortalcopy(*mark);
2501 /* Can be a localized value subject to deletion. */
2502 PL_tmps_stack[++PL_tmps_ix] = *mark;
2503 SvREFCNT_inc_void(*mark);
2508 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2509 /* Here we go for robustness, not for speed, so we change all
2510 * the refcounts so the caller gets a live guy. Cannot set
2511 * TEMP, so sv_2mortal is out of question. */
2512 if (!CvLVALUE(cx->blk_sub.cv)) {
2518 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2520 if (gimme == G_SCALAR) {
2524 /* Temporaries are bad unless they happen to be elements
2525 * of a tied hash or array */
2526 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2527 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2533 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2534 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2535 : "a readonly value" : "a temporary");
2537 else { /* Can be a localized value
2538 * subject to deletion. */
2539 PL_tmps_stack[++PL_tmps_ix] = *mark;
2540 SvREFCNT_inc_void(*mark);
2543 else { /* Should not happen? */
2549 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2550 (MARK > SP ? "Empty array" : "Array"));
2554 else if (gimme == G_ARRAY) {
2555 EXTEND_MORTAL(SP - newsp);
2556 for (mark = newsp + 1; mark <= SP; mark++) {
2557 if (*mark != &PL_sv_undef
2558 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2559 /* Might be flattened array after $#array = */
2566 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2567 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2570 /* Can be a localized value subject to deletion. */
2571 PL_tmps_stack[++PL_tmps_ix] = *mark;
2572 SvREFCNT_inc_void(*mark);
2578 if (gimme == G_SCALAR) {
2582 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2584 *MARK = SvREFCNT_inc(TOPs);
2589 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2591 *MARK = sv_mortalcopy(sv);
2596 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2600 *MARK = &PL_sv_undef;
2604 else if (gimme == G_ARRAY) {
2606 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2607 if (!SvTEMP(*MARK)) {
2608 *MARK = sv_mortalcopy(*MARK);
2609 TAINT_NOT; /* Each item is independent */
2618 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2619 PL_curpm = newpm; /* ... and pop $1 et al */
2622 return cx->blk_sub.retop;
2630 register PERL_CONTEXT *cx;
2632 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2635 DIE(aTHX_ "Not a CODE reference");
2636 switch (SvTYPE(sv)) {
2637 /* This is overwhelming the most common case: */
2639 if (!(cv = GvCVu((GV*)sv))) {
2641 cv = sv_2cv(sv, &stash, &gv, 0);
2653 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2655 SP = PL_stack_base + POPMARK;
2658 if (SvGMAGICAL(sv)) {
2663 sym = SvPVX_const(sv);
2671 sym = SvPV_const(sv, len);
2674 DIE(aTHX_ PL_no_usym, "a subroutine");
2675 if (PL_op->op_private & HINT_STRICT_REFS)
2676 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2677 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2682 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2683 tryAMAGICunDEREF(to_cv);
2686 if (SvTYPE(cv) == SVt_PVCV)
2691 DIE(aTHX_ "Not a CODE reference");
2692 /* This is the second most common case: */
2702 if (!CvROOT(cv) && !CvXSUB(cv)) {
2706 /* anonymous or undef'd function leaves us no recourse */
2707 if (CvANON(cv) || !(gv = CvGV(cv)))
2708 DIE(aTHX_ "Undefined subroutine called");
2710 /* autoloaded stub? */
2711 if (cv != GvCV(gv)) {
2714 /* should call AUTOLOAD now? */
2717 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2724 sub_name = sv_newmortal();
2725 gv_efullname3(sub_name, gv, NULL);
2726 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2730 DIE(aTHX_ "Not a CODE reference");
2735 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2736 Perl_get_db_sub(aTHX_ &sv, cv);
2738 PL_curcopdb = PL_curcop;
2739 cv = GvCV(PL_DBsub);
2741 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2742 DIE(aTHX_ "No DB::sub routine defined");
2745 if (!(CvISXSUB(cv))) {
2746 /* This path taken at least 75% of the time */
2748 register I32 items = SP - MARK;
2749 AV* const padlist = CvPADLIST(cv);
2750 PUSHBLOCK(cx, CXt_SUB, MARK);
2752 cx->blk_sub.retop = PL_op->op_next;
2754 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2755 * that eval'' ops within this sub know the correct lexical space.
2756 * Owing the speed considerations, we choose instead to search for
2757 * the cv using find_runcv() when calling doeval().
2759 if (CvDEPTH(cv) >= 2) {
2760 PERL_STACK_OVERFLOW_CHECK();
2761 pad_push(padlist, CvDEPTH(cv));
2764 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2766 AV* const av = (AV*)PAD_SVl(0);
2768 /* @_ is normally not REAL--this should only ever
2769 * happen when DB::sub() calls things that modify @_ */
2774 cx->blk_sub.savearray = GvAV(PL_defgv);
2775 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2776 CX_CURPAD_SAVE(cx->blk_sub);
2777 cx->blk_sub.argarray = av;
2780 if (items > AvMAX(av) + 1) {
2781 SV **ary = AvALLOC(av);
2782 if (AvARRAY(av) != ary) {
2783 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2786 if (items > AvMAX(av) + 1) {
2787 AvMAX(av) = items - 1;
2788 Renew(ary,items,SV*);
2793 Copy(MARK,AvARRAY(av),items,SV*);
2794 AvFILLp(av) = items - 1;
2802 /* warning must come *after* we fully set up the context
2803 * stuff so that __WARN__ handlers can safely dounwind()
2806 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2807 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2808 sub_crush_depth(cv);
2810 DEBUG_S(PerlIO_printf(Perl_debug_log,
2811 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2813 RETURNOP(CvSTART(cv));
2816 I32 markix = TOPMARK;
2821 /* Need to copy @_ to stack. Alternative may be to
2822 * switch stack to @_, and copy return values
2823 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2824 AV * const av = GvAV(PL_defgv);
2825 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2828 /* Mark is at the end of the stack. */
2830 Copy(AvARRAY(av), SP + 1, items, SV*);
2835 /* We assume first XSUB in &DB::sub is the called one. */
2837 SAVEVPTR(PL_curcop);
2838 PL_curcop = PL_curcopdb;
2841 /* Do we need to open block here? XXXX */
2842 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2843 (void)(*CvXSUB(cv))(aTHX_ cv);
2845 /* Enforce some sanity in scalar context. */
2846 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2847 if (markix > PL_stack_sp - PL_stack_base)
2848 *(PL_stack_base + markix) = &PL_sv_undef;
2850 *(PL_stack_base + markix) = *PL_stack_sp;
2851 PL_stack_sp = PL_stack_base + markix;
2859 Perl_sub_crush_depth(pTHX_ CV *cv)
2862 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2864 SV* const tmpstr = sv_newmortal();
2865 gv_efullname3(tmpstr, CvGV(cv), NULL);
2866 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2875 SV* const elemsv = POPs;
2876 IV elem = SvIV(elemsv);
2877 AV* const av = (AV*)POPs;
2878 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2879 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2882 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2883 Perl_warner(aTHX_ packWARN(WARN_MISC),
2884 "Use of reference \"%"SVf"\" as array index",
2887 elem -= CopARYBASE_get(PL_curcop);
2888 if (SvTYPE(av) != SVt_PVAV)
2890 svp = av_fetch(av, elem, lval && !defer);
2892 #ifdef PERL_MALLOC_WRAP
2893 if (SvUOK(elemsv)) {
2894 const UV uv = SvUV(elemsv);
2895 elem = uv > IV_MAX ? IV_MAX : uv;
2897 else if (SvNOK(elemsv))
2898 elem = (IV)SvNV(elemsv);
2900 static const char oom_array_extend[] =
2901 "Out of memory during array extend"; /* Duplicated in av.c */
2902 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2905 if (!svp || *svp == &PL_sv_undef) {
2908 DIE(aTHX_ PL_no_aelem, elem);
2909 lv = sv_newmortal();
2910 sv_upgrade(lv, SVt_PVLV);
2912 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2913 LvTARG(lv) = SvREFCNT_inc_simple(av);
2914 LvTARGOFF(lv) = elem;
2919 if (PL_op->op_private & OPpLVAL_INTRO)
2920 save_aelem(av, elem, svp);
2921 else if (PL_op->op_private & OPpDEREF)
2922 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2924 sv = (svp ? *svp : &PL_sv_undef);
2925 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2926 sv = sv_mortalcopy(sv);
2932 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2937 Perl_croak(aTHX_ PL_no_modify);
2938 if (SvTYPE(sv) < SVt_RV)
2939 sv_upgrade(sv, SVt_RV);
2940 else if (SvTYPE(sv) >= SVt_PV) {
2947 SvRV_set(sv, newSV(0));
2950 SvRV_set(sv, (SV*)newAV());
2953 SvRV_set(sv, (SV*)newHV());
2964 SV* const sv = TOPs;
2967 SV* const rsv = SvRV(sv);
2968 if (SvTYPE(rsv) == SVt_PVCV) {
2974 SETs(method_common(sv, NULL));
2981 SV* const sv = cSVOP_sv;
2982 U32 hash = SvSHARED_HASH(sv);
2984 XPUSHs(method_common(sv, &hash));
2989 S_method_common(pTHX_ SV* meth, U32* hashp)
2996 const char* packname = NULL;
2999 const char * const name = SvPV_const(meth, namelen);
3000 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3003 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3011 /* this isn't a reference */
3012 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3013 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3015 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3022 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3023 !(ob=(SV*)GvIO(iogv)))
3025 /* this isn't the name of a filehandle either */
3027 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3028 ? !isIDFIRST_utf8((U8*)packname)
3029 : !isIDFIRST(*packname)
3032 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3033 SvOK(sv) ? "without a package or object reference"
3034 : "on an undefined value");
3036 /* assume it's a package name */
3037 stash = gv_stashpvn(packname, packlen, 0);
3041 SV* const ref = newSViv(PTR2IV(stash));
3042 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3046 /* it _is_ a filehandle name -- replace with a reference */
3047 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3050 /* if we got here, ob should be a reference or a glob */
3051 if (!ob || !(SvOBJECT(ob)
3052 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3055 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3056 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3060 stash = SvSTASH(ob);
3063 /* NOTE: stash may be null, hope hv_fetch_ent and
3064 gv_fetchmethod can cope (it seems they can) */
3066 /* shortcut for simple names */
3068 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3070 gv = (GV*)HeVAL(he);
3071 if (isGV(gv) && GvCV(gv) &&
3072 (!GvCVGEN(gv) || GvCVGEN(gv)
3073 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3074 return (SV*)GvCV(gv);
3078 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3081 /* This code tries to figure out just what went wrong with
3082 gv_fetchmethod. It therefore needs to duplicate a lot of
3083 the internals of that function. We can't move it inside
3084 Perl_gv_fetchmethod_autoload(), however, since that would
3085 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3088 const char* leaf = name;
3089 const char* sep = NULL;
3092 for (p = name; *p; p++) {
3094 sep = p, leaf = p + 1;
3095 else if (*p == ':' && *(p + 1) == ':')
3096 sep = p, leaf = p + 2;
3098 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3099 /* the method name is unqualified or starts with SUPER:: */
3100 bool need_strlen = 1;
3102 packname = CopSTASHPV(PL_curcop);
3105 HEK * const packhek = HvNAME_HEK(stash);
3107 packname = HEK_KEY(packhek);
3108 packlen = HEK_LEN(packhek);
3118 "Can't use anonymous symbol table for method lookup");
3120 else if (need_strlen)
3121 packlen = strlen(packname);
3125 /* the method name is qualified */
3127 packlen = sep - name;
3130 /* we're relying on gv_fetchmethod not autovivifying the stash */
3131 if (gv_stashpvn(packname, packlen, 0)) {
3133 "Can't locate object method \"%s\" via package \"%.*s\"",
3134 leaf, (int)packlen, packname);
3138 "Can't locate object method \"%s\" via package \"%.*s\""
3139 " (perhaps you forgot to load \"%.*s\"?)",
3140 leaf, (int)packlen, packname, (int)packlen, packname);
3143 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3148 * c-indentation-style: bsd
3150 * indent-tabs-mode: t
3153 * ex: set ts=8 sts=4 sw=4 noet: