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
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (PL_op->op_private & OPpLVAL_INTRO)
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
77 PL_curcop = (COP*)PL_op;
84 PUSHMARK(PL_stack_sp);
99 XPUSHs((SV*)cGVOP_gv);
109 if (PL_op->op_type == OP_AND)
111 RETURNOP(cLOGOP->op_other);
117 dVAR; dSP; dPOPTOPssrl;
119 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
120 SV * const temp = left;
121 left = right; right = temp;
123 else if (PL_op->op_private & OPpASSIGN_STATE) {
124 if (SvPADSTALE(right))
125 SvPADSTALE_off(right);
127 RETURN; /* ignore assignment */
129 if (PL_tainting && PL_tainted && !SvTAINTED(left))
131 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
132 SV * const cv = SvRV(left);
133 const U32 cv_type = SvTYPE(cv);
134 const U32 gv_type = SvTYPE(right);
135 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
141 /* Can do the optimisation if right (LVALUE) is not a typeglob,
142 left (RVALUE) is a reference to something, and we're in void
144 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
145 /* Is the target symbol table currently empty? */
146 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
147 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
148 /* Good. Create a new proxy constant subroutine in the target.
149 The gv becomes a(nother) reference to the constant. */
150 SV *const value = SvRV(cv);
152 SvUPGRADE((SV *)gv, SVt_RV);
153 SvPCS_IMPORTED_on(gv);
155 SvREFCNT_inc_simple_void(value);
161 /* Need to fix things up. */
162 if (gv_type != SVt_PVGV) {
163 /* Need to fix GV. */
164 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
168 /* We've been returned a constant rather than a full subroutine,
169 but they expect a subroutine reference to apply. */
171 SvREFCNT_inc_void(SvRV(cv));
172 /* newCONSTSUB takes a reference count on the passed in SV
173 from us. We set the name to NULL, otherwise we get into
174 all sorts of fun as the reference to our new sub is
175 donated to the GV that we're about to assign to.
177 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
183 if (strEQ(GvNAME(right),"isa")) {
188 SvSetMagicSV(right, left);
197 RETURNOP(cLOGOP->op_other);
199 RETURNOP(cLOGOP->op_next);
206 TAINT_NOT; /* Each statement is presumed innocent */
207 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
209 oldsave = PL_scopestack[PL_scopestack_ix - 1];
210 LEAVE_SCOPE(oldsave);
216 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
221 const char *rpv = NULL;
223 bool rcopied = FALSE;
225 if (TARG == right && right != left) {
226 /* mg_get(right) may happen here ... */
227 rpv = SvPV_const(right, rlen);
228 rbyte = !DO_UTF8(right);
229 right = sv_2mortal(newSVpvn(rpv, rlen));
230 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
236 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
237 lbyte = !DO_UTF8(left);
238 sv_setpvn(TARG, lpv, llen);
244 else { /* TARG == left */
246 SvGETMAGIC(left); /* or mg_get(left) may happen here */
248 if (left == right && ckWARN(WARN_UNINITIALIZED))
249 report_uninit(right);
250 sv_setpvn(left, "", 0);
252 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
253 lbyte = !DO_UTF8(left);
258 /* or mg_get(right) may happen here */
260 rpv = SvPV_const(right, rlen);
261 rbyte = !DO_UTF8(right);
263 if (lbyte != rbyte) {
265 sv_utf8_upgrade_nomg(TARG);
268 right = sv_2mortal(newSVpvn(rpv, rlen));
269 sv_utf8_upgrade_nomg(right);
270 rpv = SvPV_const(right, rlen);
273 sv_catpvn_nomg(TARG, rpv, rlen);
284 if (PL_op->op_flags & OPf_MOD) {
285 if (PL_op->op_private & OPpLVAL_INTRO)
286 if (!(PL_op->op_private & OPpPAD_STATE))
287 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
288 if (PL_op->op_private & OPpDEREF) {
290 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
300 tryAMAGICunTARGET(iter, 0);
301 PL_last_in_gv = (GV*)(*PL_stack_sp--);
302 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
303 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
304 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
307 XPUSHs((SV*)PL_last_in_gv);
310 PL_last_in_gv = (GV*)(*PL_stack_sp--);
313 return do_readline();
318 dVAR; dSP; tryAMAGICbinSET(eq,0);
319 #ifndef NV_PRESERVES_UV
320 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
322 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
326 #ifdef PERL_PRESERVE_IVUV
329 /* Unless the left argument is integer in range we are going
330 to have to use NV maths. Hence only attempt to coerce the
331 right argument if we know the left is integer. */
334 const bool auvok = SvUOK(TOPm1s);
335 const bool buvok = SvUOK(TOPs);
337 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
338 /* Casting IV to UV before comparison isn't going to matter
339 on 2s complement. On 1s complement or sign&magnitude
340 (if we have any of them) it could to make negative zero
341 differ from normal zero. As I understand it. (Need to
342 check - is negative zero implementation defined behaviour
344 const UV buv = SvUVX(POPs);
345 const UV auv = SvUVX(TOPs);
347 SETs(boolSV(auv == buv));
350 { /* ## Mixed IV,UV ## */
354 /* == is commutative so doesn't matter which is left or right */
356 /* top of stack (b) is the iv */
365 /* As uv is a UV, it's >0, so it cannot be == */
368 /* we know iv is >= 0 */
369 SETs(boolSV((UV)iv == SvUVX(uvp)));
376 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
378 if (Perl_isnan(left) || Perl_isnan(right))
380 SETs(boolSV(left == right));
383 SETs(boolSV(TOPn == value));
392 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
393 DIE(aTHX_ PL_no_modify);
394 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
395 && SvIVX(TOPs) != IV_MAX)
397 SvIV_set(TOPs, SvIVX(TOPs) + 1);
398 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
400 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
412 if (PL_op->op_type == OP_OR)
414 RETURNOP(cLOGOP->op_other);
423 const int op_type = PL_op->op_type;
424 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
428 if (!sv || !SvANY(sv)) {
429 if (op_type == OP_DOR)
431 RETURNOP(cLOGOP->op_other);
433 } else if (op_type == OP_DEFINED) {
435 if (!sv || !SvANY(sv))
438 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
441 switch (SvTYPE(sv)) {
443 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
447 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
451 if (CvROOT(sv) || CvXSUB(sv))
464 if(op_type == OP_DOR)
466 RETURNOP(cLOGOP->op_other);
468 /* assuming OP_DEFINED */
476 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
477 useleft = USE_LEFT(TOPm1s);
478 #ifdef PERL_PRESERVE_IVUV
479 /* We must see if we can perform the addition with integers if possible,
480 as the integer code detects overflow while the NV code doesn't.
481 If either argument hasn't had a numeric conversion yet attempt to get
482 the IV. It's important to do this now, rather than just assuming that
483 it's not IOK as a PV of "9223372036854775806" may not take well to NV
484 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
485 integer in case the second argument is IV=9223372036854775806
486 We can (now) rely on sv_2iv to do the right thing, only setting the
487 public IOK flag if the value in the NV (or PV) slot is truly integer.
489 A side effect is that this also aggressively prefers integer maths over
490 fp maths for integer values.
492 How to detect overflow?
494 C 99 section 6.2.6.1 says
496 The range of nonnegative values of a signed integer type is a subrange
497 of the corresponding unsigned integer type, and the representation of
498 the same value in each type is the same. A computation involving
499 unsigned operands can never overflow, because a result that cannot be
500 represented by the resulting unsigned integer type is reduced modulo
501 the number that is one greater than the largest value that can be
502 represented by the resulting type.
506 which I read as "unsigned ints wrap."
508 signed integer overflow seems to be classed as "exception condition"
510 If an exceptional condition occurs during the evaluation of an
511 expression (that is, if the result is not mathematically defined or not
512 in the range of representable values for its type), the behavior is
515 (6.5, the 5th paragraph)
517 I had assumed that on 2s complement machines signed arithmetic would
518 wrap, hence coded pp_add and pp_subtract on the assumption that
519 everything perl builds on would be happy. After much wailing and
520 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
521 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
522 unsigned code below is actually shorter than the old code. :-)
527 /* Unless the left argument is integer in range we are going to have to
528 use NV maths. Hence only attempt to coerce the right argument if
529 we know the left is integer. */
537 /* left operand is undef, treat as zero. + 0 is identity,
538 Could SETi or SETu right now, but space optimise by not adding
539 lots of code to speed up what is probably a rarish case. */
541 /* Left operand is defined, so is it IV? */
544 if ((auvok = SvUOK(TOPm1s)))
547 register const IV aiv = SvIVX(TOPm1s);
550 auvok = 1; /* Now acting as a sign flag. */
551 } else { /* 2s complement assumption for IV_MIN */
559 bool result_good = 0;
562 bool buvok = SvUOK(TOPs);
567 register const IV biv = SvIVX(TOPs);
574 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
575 else "IV" now, independent of how it came in.
576 if a, b represents positive, A, B negative, a maps to -A etc
581 all UV maths. negate result if A negative.
582 add if signs same, subtract if signs differ. */
588 /* Must get smaller */
594 /* result really should be -(auv-buv). as its negation
595 of true value, need to swap our result flag */
612 if (result <= (UV)IV_MIN)
615 /* result valid, but out of range for IV. */
620 } /* Overflow, drop through to NVs. */
627 /* left operand is undef, treat as zero. + 0.0 is identity. */
631 SETn( value + TOPn );
639 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
640 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
641 const U32 lval = PL_op->op_flags & OPf_MOD;
642 SV** const svp = av_fetch(av, PL_op->op_private, lval);
643 SV *sv = (svp ? *svp : &PL_sv_undef);
645 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
646 sv = sv_mortalcopy(sv);
653 dVAR; dSP; dMARK; dTARGET;
655 do_join(TARG, *MARK, MARK, SP);
666 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
667 * will be enough to hold an OP*.
669 SV* const sv = sv_newmortal();
670 sv_upgrade(sv, SVt_PVLV);
672 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
680 /* Oversized hot code. */
684 dVAR; dSP; dMARK; dORIGMARK;
688 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
690 if (gv && (io = GvIO(gv))
691 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
694 if (MARK == ORIGMARK) {
695 /* If using default handle then we need to make space to
696 * pass object as 1st arg, so move other args up ...
700 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
704 *MARK = SvTIED_obj((SV*)io, mg);
707 call_method("PRINT", G_SCALAR);
715 if (!(io = GvIO(gv))) {
716 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
717 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
719 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
720 report_evil_fh(gv, io, PL_op->op_type);
721 SETERRNO(EBADF,RMS_IFI);
724 else if (!(fp = IoOFP(io))) {
725 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
727 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
728 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
729 report_evil_fh(gv, io, PL_op->op_type);
731 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
736 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
738 if (!do_print(*MARK, fp))
742 if (!do_print(PL_ofs_sv, fp)) { /* $, */
751 if (!do_print(*MARK, fp))
759 if (PL_op->op_type == OP_SAY) {
760 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
763 else if (PL_ors_sv && SvOK(PL_ors_sv))
764 if (!do_print(PL_ors_sv, fp)) /* $\ */
767 if (IoFLAGS(io) & IOf_FLUSH)
768 if (PerlIO_flush(fp) == EOF)
778 XPUSHs(&PL_sv_undef);
785 const I32 gimme = GIMME_V;
786 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
787 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
788 static const char an_array[] = "an ARRAY";
789 static const char a_hash[] = "a HASH";
790 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
791 const U32 type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
795 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
798 if (SvTYPE(sv) != type)
799 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
800 if (PL_op->op_flags & OPf_REF) {
805 if (gimme != G_ARRAY)
806 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
807 : return_hash_to_lvalue_scalar);
811 else if (PL_op->op_flags & OPf_MOD
812 && PL_op->op_private & OPpLVAL_INTRO)
813 Perl_croak(aTHX_ PL_no_localize_ref);
816 if (SvTYPE(sv) == type) {
817 if (PL_op->op_flags & OPf_REF) {
822 if (gimme != G_ARRAY)
824 is_pp_rv2av ? return_array_to_lvalue_scalar
825 : return_hash_to_lvalue_scalar);
833 if (SvTYPE(sv) != SVt_PVGV) {
834 if (SvGMAGICAL(sv)) {
839 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
847 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
848 if (PL_op->op_private & OPpLVAL_INTRO)
849 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
850 if (PL_op->op_flags & OPf_REF) {
855 if (gimme != G_ARRAY)
857 is_pp_rv2av ? return_array_to_lvalue_scalar
858 : return_hash_to_lvalue_scalar);
866 AV *const av = (AV*)sv;
867 /* The guts of pp_rv2av, with no intenting change to preserve history
868 (until such time as we get tools that can do blame annotation across
869 whitespace changes. */
870 if (gimme == G_ARRAY) {
871 const I32 maxarg = AvFILL(av) + 1;
872 (void)POPs; /* XXXX May be optimized away? */
874 if (SvRMAGICAL(av)) {
876 for (i=0; i < (U32)maxarg; i++) {
877 SV ** const svp = av_fetch(av, i, FALSE);
878 /* See note in pp_helem, and bug id #27839 */
880 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
885 Copy(AvARRAY(av), SP+1, maxarg, SV*);
889 else if (gimme == G_SCALAR) {
891 const I32 maxarg = AvFILL(av) + 1;
895 /* The guts of pp_rv2hv */
896 if (gimme == G_ARRAY) { /* array wanted */
900 else if (gimme == G_SCALAR) {
902 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
910 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
917 if (ckWARN(WARN_MISC)) {
919 if (relem == firstrelem &&
921 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
922 SvTYPE(SvRV(*relem)) == SVt_PVHV))
924 err = "Reference found where even-sized list expected";
927 err = "Odd number of elements in hash assignment";
928 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
932 didstore = hv_store_ent(hash,*relem,tmpstr,0);
933 if (SvMAGICAL(hash)) {
934 if (SvSMAGICAL(tmpstr))
946 SV **lastlelem = PL_stack_sp;
947 SV **lastrelem = PL_stack_base + POPMARK;
948 SV **firstrelem = PL_stack_base + POPMARK + 1;
949 SV **firstlelem = lastrelem + 1;
962 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
965 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
968 /* If there's a common identifier on both sides we have to take
969 * special care that assigning the identifier on the left doesn't
970 * clobber a value on the right that's used later in the list.
972 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
973 EXTEND_MORTAL(lastrelem - firstrelem + 1);
974 for (relem = firstrelem; relem <= lastrelem; relem++) {
976 TAINT_NOT; /* Each item is independent */
977 *relem = sv_mortalcopy(sv);
981 if (PL_op->op_private & OPpASSIGN_STATE) {
982 if (SvPADSTALE(*firstlelem))
983 SvPADSTALE_off(*firstlelem);
985 RETURN; /* ignore assignment */
993 while (lelem <= lastlelem) {
994 TAINT_NOT; /* Each item stands on its own, taintwise. */
996 switch (SvTYPE(sv)) {
999 magic = SvMAGICAL(ary) != 0;
1001 av_extend(ary, lastrelem - relem);
1003 while (relem <= lastrelem) { /* gobble up all the rest */
1006 sv = newSVsv(*relem);
1008 didstore = av_store(ary,i++,sv);
1018 case SVt_PVHV: { /* normal hash */
1022 magic = SvMAGICAL(hash) != 0;
1024 firsthashrelem = relem;
1026 while (relem < lastrelem) { /* gobble up all the rest */
1028 sv = *relem ? *relem : &PL_sv_no;
1032 sv_setsv(tmpstr,*relem); /* value */
1033 *(relem++) = tmpstr;
1034 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1035 /* key overwrites an existing entry */
1037 didstore = hv_store_ent(hash,sv,tmpstr,0);
1039 if (SvSMAGICAL(tmpstr))
1046 if (relem == lastrelem) {
1047 do_oddball(hash, relem, firstrelem);
1053 if (SvIMMORTAL(sv)) {
1054 if (relem <= lastrelem)
1058 if (relem <= lastrelem) {
1059 sv_setsv(sv, *relem);
1063 sv_setsv(sv, &PL_sv_undef);
1068 if (PL_delaymagic & ~DM_DELAY) {
1069 if (PL_delaymagic & DM_UID) {
1070 #ifdef HAS_SETRESUID
1071 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1072 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1075 # ifdef HAS_SETREUID
1076 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1077 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1080 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1081 (void)setruid(PL_uid);
1082 PL_delaymagic &= ~DM_RUID;
1084 # endif /* HAS_SETRUID */
1086 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1087 (void)seteuid(PL_euid);
1088 PL_delaymagic &= ~DM_EUID;
1090 # endif /* HAS_SETEUID */
1091 if (PL_delaymagic & DM_UID) {
1092 if (PL_uid != PL_euid)
1093 DIE(aTHX_ "No setreuid available");
1094 (void)PerlProc_setuid(PL_uid);
1096 # endif /* HAS_SETREUID */
1097 #endif /* HAS_SETRESUID */
1098 PL_uid = PerlProc_getuid();
1099 PL_euid = PerlProc_geteuid();
1101 if (PL_delaymagic & DM_GID) {
1102 #ifdef HAS_SETRESGID
1103 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1104 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1107 # ifdef HAS_SETREGID
1108 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1109 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1112 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1113 (void)setrgid(PL_gid);
1114 PL_delaymagic &= ~DM_RGID;
1116 # endif /* HAS_SETRGID */
1118 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1119 (void)setegid(PL_egid);
1120 PL_delaymagic &= ~DM_EGID;
1122 # endif /* HAS_SETEGID */
1123 if (PL_delaymagic & DM_GID) {
1124 if (PL_gid != PL_egid)
1125 DIE(aTHX_ "No setregid available");
1126 (void)PerlProc_setgid(PL_gid);
1128 # endif /* HAS_SETREGID */
1129 #endif /* HAS_SETRESGID */
1130 PL_gid = PerlProc_getgid();
1131 PL_egid = PerlProc_getegid();
1133 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1137 if (gimme == G_VOID)
1138 SP = firstrelem - 1;
1139 else if (gimme == G_SCALAR) {
1142 SETi(lastrelem - firstrelem + 1 - duplicates);
1149 /* Removes from the stack the entries which ended up as
1150 * duplicated keys in the hash (fix for [perl #24380]) */
1151 Move(firsthashrelem + duplicates,
1152 firsthashrelem, duplicates, SV**);
1153 lastrelem -= duplicates;
1158 SP = firstrelem + (lastlelem - firstlelem);
1159 lelem = firstlelem + (relem - firstrelem);
1161 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1169 register PMOP * const pm = cPMOP;
1170 SV * const rv = sv_newmortal();
1171 SV * const sv = newSVrv(rv, "Regexp");
1172 if (pm->op_pmdynflags & PMdf_TAINTED)
1174 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1181 register PMOP *pm = cPMOP;
1183 register const char *t;
1184 register const char *s;
1187 I32 r_flags = REXEC_CHECKED;
1188 const char *truebase; /* Start of string */
1189 register REGEXP *rx = PM_GETRE(pm);
1191 const I32 gimme = GIMME;
1194 const I32 oldsave = PL_savestack_ix;
1195 I32 update_minmatch = 1;
1196 I32 had_zerolen = 0;
1199 if (PL_op->op_flags & OPf_STACKED)
1201 else if (PL_op->op_private & OPpTARGET_MY)
1208 PUTBACK; /* EVAL blocks need stack_sp. */
1209 s = SvPV_const(TARG, len);
1211 DIE(aTHX_ "panic: pp_match");
1213 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1214 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1217 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1219 /* PMdf_USED is set after a ?? matches once */
1220 if (pm->op_pmdynflags & PMdf_USED) {
1222 if (gimme == G_ARRAY)
1227 /* empty pattern special-cased to use last successful pattern if possible */
1228 if (!rx->prelen && PL_curpm) {
1233 if (rx->minlen > (I32)len)
1238 /* XXXX What part of this is needed with true \G-support? */
1239 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1241 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1242 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1243 if (mg && mg->mg_len >= 0) {
1244 if (!(rx->extflags & RXf_GPOS_SEEN))
1245 rx->endp[0] = rx->startp[0] = mg->mg_len;
1246 else if (rx->extflags & RXf_ANCH_GPOS) {
1247 r_flags |= REXEC_IGNOREPOS;
1248 rx->endp[0] = rx->startp[0] = mg->mg_len;
1249 } else if (rx->extflags & RXf_GPOS_FLOAT)
1252 rx->endp[0] = rx->startp[0] = mg->mg_len;
1253 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1254 update_minmatch = 0;
1258 /* remove comment to get faster /g but possibly unsafe $1 vars after a
1259 match. Test for the unsafe vars will fail as well*/
1260 if (( /* !global && */ rx->nparens)
1261 || SvTEMP(TARG) || PL_sawampersand ||
1262 (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
1263 r_flags |= REXEC_COPY_STR;
1265 r_flags |= REXEC_SCREAM;
1268 if (global && rx->startp[0] != -1) {
1269 t = s = rx->endp[0] + truebase - rx->gofs;
1270 if ((s + rx->minlen) > strend || s < truebase)
1272 if (update_minmatch++)
1273 minmatch = had_zerolen;
1275 if (rx->extflags & RXf_USE_INTUIT &&
1276 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1277 /* FIXME - can PL_bostr be made const char *? */
1278 PL_bostr = (char *)truebase;
1279 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1283 if ( (rx->extflags & RXf_CHECK_ALL)
1285 && !(pm->op_pmflags & PMf_KEEPCOPY)
1286 && ((rx->extflags & RXf_NOSCAN)
1287 || !((rx->extflags & RXf_INTUIT_TAIL)
1288 && (r_flags & REXEC_SCREAM)))
1289 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1292 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1295 if (dynpm->op_pmflags & PMf_ONCE)
1296 dynpm->op_pmdynflags |= PMdf_USED;
1305 RX_MATCH_TAINTED_on(rx);
1306 TAINT_IF(RX_MATCH_TAINTED(rx));
1307 if (gimme == G_ARRAY) {
1308 const I32 nparens = rx->nparens;
1309 I32 i = (global && !nparens) ? 1 : 0;
1311 SPAGAIN; /* EVAL blocks could move the stack. */
1312 EXTEND(SP, nparens + i);
1313 EXTEND_MORTAL(nparens + i);
1314 for (i = !i; i <= nparens; i++) {
1315 PUSHs(sv_newmortal());
1316 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1317 const I32 len = rx->endp[i] - rx->startp[i];
1318 s = rx->startp[i] + truebase;
1319 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1320 len < 0 || len > strend - s)
1321 DIE(aTHX_ "panic: pp_match start/end pointers");
1322 sv_setpvn(*SP, s, len);
1323 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1328 if (dynpm->op_pmflags & PMf_CONTINUE) {
1330 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1333 #ifdef PERL_OLD_COPY_ON_WRITE
1335 sv_force_normal_flags(TARG, 0);
1337 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1338 &PL_vtbl_mglob, NULL, 0);
1340 if (rx->startp[0] != -1) {
1341 mg->mg_len = rx->endp[0];
1342 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1343 mg->mg_flags |= MGf_MINMATCH;
1345 mg->mg_flags &= ~MGf_MINMATCH;
1348 had_zerolen = (rx->startp[0] != -1
1349 && rx->startp[0] + rx->gofs == (UV)rx->endp[0]);
1350 PUTBACK; /* EVAL blocks may use stack */
1351 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1356 LEAVE_SCOPE(oldsave);
1362 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1363 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1367 #ifdef PERL_OLD_COPY_ON_WRITE
1369 sv_force_normal_flags(TARG, 0);
1371 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1372 &PL_vtbl_mglob, NULL, 0);
1374 if (rx->startp[0] != -1) {
1375 mg->mg_len = rx->endp[0];
1376 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1377 mg->mg_flags |= MGf_MINMATCH;
1379 mg->mg_flags &= ~MGf_MINMATCH;
1382 LEAVE_SCOPE(oldsave);
1386 yup: /* Confirmed by INTUIT */
1388 RX_MATCH_TAINTED_on(rx);
1389 TAINT_IF(RX_MATCH_TAINTED(rx));
1391 if (dynpm->op_pmflags & PMf_ONCE)
1392 dynpm->op_pmdynflags |= PMdf_USED;
1393 if (RX_MATCH_COPIED(rx))
1394 Safefree(rx->subbeg);
1395 RX_MATCH_COPIED_off(rx);
1398 /* FIXME - should rx->subbeg be const char *? */
1399 rx->subbeg = (char *) truebase;
1400 rx->startp[0] = s - truebase;
1401 if (RX_MATCH_UTF8(rx)) {
1402 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1403 rx->endp[0] = t - truebase;
1406 rx->endp[0] = s - truebase + rx->minlenret;
1408 rx->sublen = strend - truebase;
1411 if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
1413 #ifdef PERL_OLD_COPY_ON_WRITE
1414 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1416 PerlIO_printf(Perl_debug_log,
1417 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1418 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1421 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1422 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1423 assert (SvPOKp(rx->saved_copy));
1428 rx->subbeg = savepvn(t, strend - t);
1429 #ifdef PERL_OLD_COPY_ON_WRITE
1430 rx->saved_copy = NULL;
1433 rx->sublen = strend - t;
1434 RX_MATCH_COPIED_on(rx);
1435 off = rx->startp[0] = s - t;
1436 rx->endp[0] = off + rx->minlenret;
1438 else { /* startp/endp are used by @- @+. */
1439 rx->startp[0] = s - truebase;
1440 rx->endp[0] = s - truebase + rx->minlenret;
1442 /* including rx->nparens in the below code seems highly suspicious.
1444 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1445 LEAVE_SCOPE(oldsave);
1450 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1451 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1452 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1457 LEAVE_SCOPE(oldsave);
1458 if (gimme == G_ARRAY)
1464 Perl_do_readline(pTHX)
1466 dVAR; dSP; dTARGETSTACKED;
1471 register IO * const io = GvIO(PL_last_in_gv);
1472 register const I32 type = PL_op->op_type;
1473 const I32 gimme = GIMME_V;
1476 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1479 XPUSHs(SvTIED_obj((SV*)io, mg));
1482 call_method("READLINE", gimme);
1485 if (gimme == G_SCALAR) {
1486 SV* const result = POPs;
1487 SvSetSV_nosteal(TARG, result);
1497 if (IoFLAGS(io) & IOf_ARGV) {
1498 if (IoFLAGS(io) & IOf_START) {
1500 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1501 IoFLAGS(io) &= ~IOf_START;
1502 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1503 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1504 SvSETMAGIC(GvSV(PL_last_in_gv));
1509 fp = nextargv(PL_last_in_gv);
1510 if (!fp) { /* Note: fp != IoIFP(io) */
1511 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1514 else if (type == OP_GLOB)
1515 fp = Perl_start_glob(aTHX_ POPs, io);
1517 else if (type == OP_GLOB)
1519 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1520 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1524 if ((!io || !(IoFLAGS(io) & IOf_START))
1525 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1527 if (type == OP_GLOB)
1528 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1529 "glob failed (can't start child: %s)",
1532 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1534 if (gimme == G_SCALAR) {
1535 /* undef TARG, and push that undefined value */
1536 if (type != OP_RCATLINE) {
1537 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1545 if (gimme == G_SCALAR) {
1547 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1550 if (type == OP_RCATLINE)
1551 SvPV_force_nolen(sv);
1555 else if (isGV_with_GP(sv)) {
1556 SvPV_force_nolen(sv);
1558 SvUPGRADE(sv, SVt_PV);
1559 tmplen = SvLEN(sv); /* remember if already alloced */
1560 if (!tmplen && !SvREADONLY(sv))
1561 Sv_Grow(sv, 80); /* try short-buffering it */
1563 if (type == OP_RCATLINE && SvOK(sv)) {
1565 SvPV_force_nolen(sv);
1571 sv = sv_2mortal(newSV(80));
1575 /* This should not be marked tainted if the fp is marked clean */
1576 #define MAYBE_TAINT_LINE(io, sv) \
1577 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1582 /* delay EOF state for a snarfed empty file */
1583 #define SNARF_EOF(gimme,rs,io,sv) \
1584 (gimme != G_SCALAR || SvCUR(sv) \
1585 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1589 if (!sv_gets(sv, fp, offset)
1591 || SNARF_EOF(gimme, PL_rs, io, sv)
1592 || PerlIO_error(fp)))
1594 PerlIO_clearerr(fp);
1595 if (IoFLAGS(io) & IOf_ARGV) {
1596 fp = nextargv(PL_last_in_gv);
1599 (void)do_close(PL_last_in_gv, FALSE);
1601 else if (type == OP_GLOB) {
1602 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1603 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1604 "glob failed (child exited with status %d%s)",
1605 (int)(STATUS_CURRENT >> 8),
1606 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1609 if (gimme == G_SCALAR) {
1610 if (type != OP_RCATLINE) {
1611 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1617 MAYBE_TAINT_LINE(io, sv);
1620 MAYBE_TAINT_LINE(io, sv);
1622 IoFLAGS(io) |= IOf_NOLINE;
1626 if (type == OP_GLOB) {
1629 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1630 char * const tmps = SvEND(sv) - 1;
1631 if (*tmps == *SvPVX_const(PL_rs)) {
1633 SvCUR_set(sv, SvCUR(sv) - 1);
1636 for (t1 = SvPVX_const(sv); *t1; t1++)
1637 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1638 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1640 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1641 (void)POPs; /* Unmatched wildcard? Chuck it... */
1644 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1645 if (ckWARN(WARN_UTF8)) {
1646 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1647 const STRLEN len = SvCUR(sv) - offset;
1650 if (!is_utf8_string_loc(s, len, &f))
1651 /* Emulate :encoding(utf8) warning in the same case. */
1652 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1653 "utf8 \"\\x%02X\" does not map to Unicode",
1654 f < (U8*)SvEND(sv) ? *f : 0);
1657 if (gimme == G_ARRAY) {
1658 if (SvLEN(sv) - SvCUR(sv) > 20) {
1659 SvPV_shrink_to_cur(sv);
1661 sv = sv_2mortal(newSV(80));
1664 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1665 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1666 const STRLEN new_len
1667 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1668 SvPV_renew(sv, new_len);
1677 register PERL_CONTEXT *cx;
1678 I32 gimme = OP_GIMME(PL_op, -1);
1681 if (cxstack_ix >= 0)
1682 gimme = cxstack[cxstack_ix].blk_gimme;
1690 PUSHBLOCK(cx, CXt_BLOCK, SP);
1700 SV * const keysv = POPs;
1701 HV * const hv = (HV*)POPs;
1702 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1703 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1705 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1708 if (SvTYPE(hv) != SVt_PVHV)
1711 if (PL_op->op_private & OPpLVAL_INTRO) {
1714 /* does the element we're localizing already exist? */
1715 preeminent = /* can we determine whether it exists? */
1717 || mg_find((SV*)hv, PERL_MAGIC_env)
1718 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1719 /* Try to preserve the existenceness of a tied hash
1720 * element by using EXISTS and DELETE if possible.
1721 * Fallback to FETCH and STORE otherwise */
1722 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1723 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1724 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1726 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1728 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1729 svp = he ? &HeVAL(he) : NULL;
1731 if (!svp || *svp == &PL_sv_undef) {
1735 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1737 lv = sv_newmortal();
1738 sv_upgrade(lv, SVt_PVLV);
1740 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1741 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1742 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1747 if (PL_op->op_private & OPpLVAL_INTRO) {
1748 if (HvNAME_get(hv) && isGV(*svp))
1749 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1753 const char * const key = SvPV_const(keysv, keylen);
1754 SAVEDELETE(hv, savepvn(key,keylen),
1755 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1757 save_helem(hv, keysv, svp);
1760 else if (PL_op->op_private & OPpDEREF)
1761 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1763 sv = (svp ? *svp : &PL_sv_undef);
1764 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1765 * Pushing the magical RHS on to the stack is useless, since
1766 * that magic is soon destined to be misled by the local(),
1767 * and thus the later pp_sassign() will fail to mg_get() the
1768 * old value. This should also cure problems with delayed
1769 * mg_get()s. GSAR 98-07-03 */
1770 if (!lval && SvGMAGICAL(sv))
1771 sv = sv_mortalcopy(sv);
1779 register PERL_CONTEXT *cx;
1784 if (PL_op->op_flags & OPf_SPECIAL) {
1785 cx = &cxstack[cxstack_ix];
1786 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1791 gimme = OP_GIMME(PL_op, -1);
1793 if (cxstack_ix >= 0)
1794 gimme = cxstack[cxstack_ix].blk_gimme;
1800 if (gimme == G_VOID)
1802 else if (gimme == G_SCALAR) {
1806 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1809 *MARK = sv_mortalcopy(TOPs);
1812 *MARK = &PL_sv_undef;
1816 else if (gimme == G_ARRAY) {
1817 /* in case LEAVE wipes old return values */
1819 for (mark = newsp + 1; mark <= SP; mark++) {
1820 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1821 *mark = sv_mortalcopy(*mark);
1822 TAINT_NOT; /* Each item is independent */
1826 PL_curpm = newpm; /* Don't pop $1 et al till now */
1836 register PERL_CONTEXT *cx;
1842 cx = &cxstack[cxstack_ix];
1843 if (CxTYPE(cx) != CXt_LOOP)
1844 DIE(aTHX_ "panic: pp_iter");
1846 itersvp = CxITERVAR(cx);
1847 av = cx->blk_loop.iterary;
1848 if (SvTYPE(av) != SVt_PVAV) {
1849 /* iterate ($min .. $max) */
1850 if (cx->blk_loop.iterlval) {
1851 /* string increment */
1852 register SV* cur = cx->blk_loop.iterlval;
1856 SvPV_const((SV*)av, maxlen) : (const char *)"";
1857 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1858 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1859 /* safe to reuse old SV */
1860 sv_setsv(*itersvp, cur);
1864 /* we need a fresh SV every time so that loop body sees a
1865 * completely new SV for closures/references to work as
1868 *itersvp = newSVsv(cur);
1869 SvREFCNT_dec(oldsv);
1871 if (strEQ(SvPVX_const(cur), max))
1872 sv_setiv(cur, 0); /* terminate next time */
1879 /* integer increment */
1880 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1883 /* don't risk potential race */
1884 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1885 /* safe to reuse old SV */
1886 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1890 /* we need a fresh SV every time so that loop body sees a
1891 * completely new SV for closures/references to work as they
1894 *itersvp = newSViv(cx->blk_loop.iterix++);
1895 SvREFCNT_dec(oldsv);
1901 if (PL_op->op_private & OPpITER_REVERSED) {
1902 /* In reverse, use itermax as the min :-) */
1903 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1906 if (SvMAGICAL(av) || AvREIFY(av)) {
1907 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1908 sv = svp ? *svp : NULL;
1911 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1915 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1919 if (SvMAGICAL(av) || AvREIFY(av)) {
1920 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1921 sv = svp ? *svp : NULL;
1924 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1928 if (sv && SvIS_FREED(sv)) {
1930 Perl_croak(aTHX_ "Use of freed value in iteration");
1937 if (av != PL_curstack && sv == &PL_sv_undef) {
1938 SV *lv = cx->blk_loop.iterlval;
1939 if (lv && SvREFCNT(lv) > 1) {
1944 SvREFCNT_dec(LvTARG(lv));
1946 lv = cx->blk_loop.iterlval = newSV(0);
1947 sv_upgrade(lv, SVt_PVLV);
1949 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1951 LvTARG(lv) = SvREFCNT_inc_simple(av);
1952 LvTARGOFF(lv) = cx->blk_loop.iterix;
1953 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1958 *itersvp = SvREFCNT_inc_simple_NN(sv);
1959 SvREFCNT_dec(oldsv);
1967 register PMOP *pm = cPMOP;
1982 register REGEXP *rx = PM_GETRE(pm);
1984 int force_on_match = 0;
1985 const I32 oldsave = PL_savestack_ix;
1987 bool doutf8 = FALSE;
1988 #ifdef PERL_OLD_COPY_ON_WRITE
1993 /* known replacement string? */
1994 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
1995 if (PL_op->op_flags & OPf_STACKED)
1997 else if (PL_op->op_private & OPpTARGET_MY)
2004 #ifdef PERL_OLD_COPY_ON_WRITE
2005 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2006 because they make integers such as 256 "false". */
2007 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2010 sv_force_normal_flags(TARG,0);
2013 #ifdef PERL_OLD_COPY_ON_WRITE
2017 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2018 || SvTYPE(TARG) > SVt_PVLV)
2019 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2020 DIE(aTHX_ PL_no_modify);
2023 s = SvPV_mutable(TARG, len);
2024 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2026 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2027 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2032 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2036 DIE(aTHX_ "panic: pp_subst");
2039 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2040 maxiters = 2 * slen + 10; /* We can match twice at each
2041 position, once with zero-length,
2042 second time with non-zero. */
2044 if (!rx->prelen && PL_curpm) {
2048 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2049 || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
2050 ? REXEC_COPY_STR : 0;
2052 r_flags |= REXEC_SCREAM;
2055 if (rx->extflags & RXf_USE_INTUIT) {
2057 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2061 /* How to do it in subst? */
2062 /* if ( (rx->extflags & RXf_CHECK_ALL)
2064 && !(pm->op_pmflags & PMf_KEEPCOPY)
2065 && ((rx->extflags & RXf_NOSCAN)
2066 || !((rx->extflags & RXf_INTUIT_TAIL)
2067 && (r_flags & REXEC_SCREAM))))
2072 /* only replace once? */
2073 once = !(rpm->op_pmflags & PMf_GLOBAL);
2075 /* known replacement string? */
2077 /* replacement needing upgrading? */
2078 if (DO_UTF8(TARG) && !doutf8) {
2079 nsv = sv_newmortal();
2082 sv_recode_to_utf8(nsv, PL_encoding);
2084 sv_utf8_upgrade(nsv);
2085 c = SvPV_const(nsv, clen);
2089 c = SvPV_const(dstr, clen);
2090 doutf8 = DO_UTF8(dstr);
2098 /* can do inplace substitution? */
2100 #ifdef PERL_OLD_COPY_ON_WRITE
2103 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2104 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2105 && (!doutf8 || SvUTF8(TARG))) {
2106 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2107 r_flags | REXEC_CHECKED))
2111 LEAVE_SCOPE(oldsave);
2114 #ifdef PERL_OLD_COPY_ON_WRITE
2115 if (SvIsCOW(TARG)) {
2116 assert (!force_on_match);
2120 if (force_on_match) {
2122 s = SvPV_force(TARG, len);
2127 SvSCREAM_off(TARG); /* disable possible screamer */
2129 rxtainted |= RX_MATCH_TAINTED(rx);
2130 m = orig + rx->startp[0];
2131 d = orig + rx->endp[0];
2133 if (m - s > strend - d) { /* faster to shorten from end */
2135 Copy(c, m, clen, char);
2140 Move(d, m, i, char);
2144 SvCUR_set(TARG, m - s);
2146 else if ((i = m - s)) { /* faster from front */
2154 Copy(c, m, clen, char);
2159 Copy(c, d, clen, char);
2164 TAINT_IF(rxtainted & 1);
2170 if (iters++ > maxiters)
2171 DIE(aTHX_ "Substitution loop");
2172 rxtainted |= RX_MATCH_TAINTED(rx);
2173 m = rx->startp[0] + orig;
2176 Move(s, d, i, char);
2180 Copy(c, d, clen, char);
2183 s = rx->endp[0] + orig;
2184 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2186 /* don't match same null twice */
2187 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2190 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2191 Move(s, d, i+1, char); /* include the NUL */
2193 TAINT_IF(rxtainted & 1);
2195 PUSHs(sv_2mortal(newSViv((I32)iters)));
2197 (void)SvPOK_only_UTF8(TARG);
2198 TAINT_IF(rxtainted);
2199 if (SvSMAGICAL(TARG)) {
2207 LEAVE_SCOPE(oldsave);
2211 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2212 r_flags | REXEC_CHECKED))
2214 if (force_on_match) {
2216 s = SvPV_force(TARG, len);
2219 #ifdef PERL_OLD_COPY_ON_WRITE
2222 rxtainted |= RX_MATCH_TAINTED(rx);
2223 dstr = newSVpvn(m, s-m);
2229 register PERL_CONTEXT *cx;
2232 RETURNOP(cPMOP->op_pmreplroot);
2234 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2236 if (iters++ > maxiters)
2237 DIE(aTHX_ "Substitution loop");
2238 rxtainted |= RX_MATCH_TAINTED(rx);
2239 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2244 strend = s + (strend - m);
2246 m = rx->startp[0] + orig;
2247 if (doutf8 && !SvUTF8(dstr))
2248 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2250 sv_catpvn(dstr, s, m-s);
2251 s = rx->endp[0] + orig;
2253 sv_catpvn(dstr, c, clen);
2256 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2257 TARG, NULL, r_flags));
2258 if (doutf8 && !DO_UTF8(TARG))
2259 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2261 sv_catpvn(dstr, s, strend - s);
2263 #ifdef PERL_OLD_COPY_ON_WRITE
2264 /* The match may make the string COW. If so, brilliant, because that's
2265 just saved us one malloc, copy and free - the regexp has donated
2266 the old buffer, and we malloc an entirely new one, rather than the
2267 regexp malloc()ing a buffer and copying our original, only for
2268 us to throw it away here during the substitution. */
2269 if (SvIsCOW(TARG)) {
2270 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2276 SvPV_set(TARG, SvPVX(dstr));
2277 SvCUR_set(TARG, SvCUR(dstr));
2278 SvLEN_set(TARG, SvLEN(dstr));
2279 doutf8 |= DO_UTF8(dstr);
2280 SvPV_set(dstr, NULL);
2282 TAINT_IF(rxtainted & 1);
2284 PUSHs(sv_2mortal(newSViv((I32)iters)));
2286 (void)SvPOK_only(TARG);
2289 TAINT_IF(rxtainted);
2292 LEAVE_SCOPE(oldsave);
2301 LEAVE_SCOPE(oldsave);
2310 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2311 ++*PL_markstack_ptr;
2312 LEAVE; /* exit inner scope */
2315 if (PL_stack_base + *PL_markstack_ptr > SP) {
2317 const I32 gimme = GIMME_V;
2319 LEAVE; /* exit outer scope */
2320 (void)POPMARK; /* pop src */
2321 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2322 (void)POPMARK; /* pop dst */
2323 SP = PL_stack_base + POPMARK; /* pop original mark */
2324 if (gimme == G_SCALAR) {
2325 if (PL_op->op_private & OPpGREP_LEX) {
2326 SV* const sv = sv_newmortal();
2327 sv_setiv(sv, items);
2335 else if (gimme == G_ARRAY)
2342 ENTER; /* enter inner scope */
2345 src = PL_stack_base[*PL_markstack_ptr];
2347 if (PL_op->op_private & OPpGREP_LEX)
2348 PAD_SVl(PL_op->op_targ) = src;
2352 RETURNOP(cLOGOP->op_other);
2363 register PERL_CONTEXT *cx;
2366 if (CxMULTICALL(&cxstack[cxstack_ix]))
2370 cxstack_ix++; /* temporarily protect top context */
2373 if (gimme == G_SCALAR) {
2376 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2378 *MARK = SvREFCNT_inc(TOPs);
2383 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2385 *MARK = sv_mortalcopy(sv);
2390 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2394 *MARK = &PL_sv_undef;
2398 else if (gimme == G_ARRAY) {
2399 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2400 if (!SvTEMP(*MARK)) {
2401 *MARK = sv_mortalcopy(*MARK);
2402 TAINT_NOT; /* Each item is independent */
2410 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2411 PL_curpm = newpm; /* ... and pop $1 et al */
2414 return cx->blk_sub.retop;
2417 /* This duplicates the above code because the above code must not
2418 * get any slower by more conditions */
2426 register PERL_CONTEXT *cx;
2429 if (CxMULTICALL(&cxstack[cxstack_ix]))
2433 cxstack_ix++; /* temporarily protect top context */
2437 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2438 /* We are an argument to a function or grep().
2439 * This kind of lvalueness was legal before lvalue
2440 * subroutines too, so be backward compatible:
2441 * cannot report errors. */
2443 /* Scalar context *is* possible, on the LHS of -> only,
2444 * as in f()->meth(). But this is not an lvalue. */
2445 if (gimme == G_SCALAR)
2447 if (gimme == G_ARRAY) {
2448 if (!CvLVALUE(cx->blk_sub.cv))
2449 goto temporise_array;
2450 EXTEND_MORTAL(SP - newsp);
2451 for (mark = newsp + 1; mark <= SP; mark++) {
2454 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2455 *mark = sv_mortalcopy(*mark);
2457 /* Can be a localized value subject to deletion. */
2458 PL_tmps_stack[++PL_tmps_ix] = *mark;
2459 SvREFCNT_inc_void(*mark);
2464 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2465 /* Here we go for robustness, not for speed, so we change all
2466 * the refcounts so the caller gets a live guy. Cannot set
2467 * TEMP, so sv_2mortal is out of question. */
2468 if (!CvLVALUE(cx->blk_sub.cv)) {
2474 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2476 if (gimme == G_SCALAR) {
2480 /* Temporaries are bad unless they happen to be elements
2481 * of a tied hash or array */
2482 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2483 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2489 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2490 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2491 : "a readonly value" : "a temporary");
2493 else { /* Can be a localized value
2494 * subject to deletion. */
2495 PL_tmps_stack[++PL_tmps_ix] = *mark;
2496 SvREFCNT_inc_void(*mark);
2499 else { /* Should not happen? */
2505 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2506 (MARK > SP ? "Empty array" : "Array"));
2510 else if (gimme == G_ARRAY) {
2511 EXTEND_MORTAL(SP - newsp);
2512 for (mark = newsp + 1; mark <= SP; mark++) {
2513 if (*mark != &PL_sv_undef
2514 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2515 /* Might be flattened array after $#array = */
2522 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2523 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2526 /* Can be a localized value subject to deletion. */
2527 PL_tmps_stack[++PL_tmps_ix] = *mark;
2528 SvREFCNT_inc_void(*mark);
2534 if (gimme == G_SCALAR) {
2538 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2540 *MARK = SvREFCNT_inc(TOPs);
2545 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2547 *MARK = sv_mortalcopy(sv);
2552 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2556 *MARK = &PL_sv_undef;
2560 else if (gimme == G_ARRAY) {
2562 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2563 if (!SvTEMP(*MARK)) {
2564 *MARK = sv_mortalcopy(*MARK);
2565 TAINT_NOT; /* Each item is independent */
2574 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2575 PL_curpm = newpm; /* ... and pop $1 et al */
2578 return cx->blk_sub.retop;
2586 register PERL_CONTEXT *cx;
2588 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2591 DIE(aTHX_ "Not a CODE reference");
2592 switch (SvTYPE(sv)) {
2593 /* This is overwhelming the most common case: */
2595 if (!(cv = GvCVu((GV*)sv))) {
2597 cv = sv_2cv(sv, &stash, &gv, 0);
2609 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2611 SP = PL_stack_base + POPMARK;
2614 if (SvGMAGICAL(sv)) {
2619 sym = SvPVX_const(sv);
2627 sym = SvPV_const(sv, len);
2630 DIE(aTHX_ PL_no_usym, "a subroutine");
2631 if (PL_op->op_private & HINT_STRICT_REFS)
2632 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2633 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2638 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2639 tryAMAGICunDEREF(to_cv);
2642 if (SvTYPE(cv) == SVt_PVCV)
2647 DIE(aTHX_ "Not a CODE reference");
2648 /* This is the second most common case: */
2658 if (!CvROOT(cv) && !CvXSUB(cv)) {
2662 /* anonymous or undef'd function leaves us no recourse */
2663 if (CvANON(cv) || !(gv = CvGV(cv)))
2664 DIE(aTHX_ "Undefined subroutine called");
2666 /* autoloaded stub? */
2667 if (cv != GvCV(gv)) {
2670 /* should call AUTOLOAD now? */
2673 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2680 sub_name = sv_newmortal();
2681 gv_efullname3(sub_name, gv, NULL);
2682 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2686 DIE(aTHX_ "Not a CODE reference");
2691 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2692 if (CvASSERTION(cv) && PL_DBassertion)
2693 sv_setiv(PL_DBassertion, 1);
2695 Perl_get_db_sub(aTHX_ &sv, cv);
2697 PL_curcopdb = PL_curcop;
2698 cv = GvCV(PL_DBsub);
2700 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2701 DIE(aTHX_ "No DB::sub routine defined");
2704 if (!(CvISXSUB(cv))) {
2705 /* This path taken at least 75% of the time */
2707 register I32 items = SP - MARK;
2708 AV* const padlist = CvPADLIST(cv);
2709 PUSHBLOCK(cx, CXt_SUB, MARK);
2711 cx->blk_sub.retop = PL_op->op_next;
2713 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2714 * that eval'' ops within this sub know the correct lexical space.
2715 * Owing the speed considerations, we choose instead to search for
2716 * the cv using find_runcv() when calling doeval().
2718 if (CvDEPTH(cv) >= 2) {
2719 PERL_STACK_OVERFLOW_CHECK();
2720 pad_push(padlist, CvDEPTH(cv));
2723 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2725 AV* const av = (AV*)PAD_SVl(0);
2727 /* @_ is normally not REAL--this should only ever
2728 * happen when DB::sub() calls things that modify @_ */
2733 cx->blk_sub.savearray = GvAV(PL_defgv);
2734 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2735 CX_CURPAD_SAVE(cx->blk_sub);
2736 cx->blk_sub.argarray = av;
2739 if (items > AvMAX(av) + 1) {
2740 SV **ary = AvALLOC(av);
2741 if (AvARRAY(av) != ary) {
2742 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2745 if (items > AvMAX(av) + 1) {
2746 AvMAX(av) = items - 1;
2747 Renew(ary,items,SV*);
2752 Copy(MARK,AvARRAY(av),items,SV*);
2753 AvFILLp(av) = items - 1;
2761 /* warning must come *after* we fully set up the context
2762 * stuff so that __WARN__ handlers can safely dounwind()
2765 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2766 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2767 sub_crush_depth(cv);
2769 DEBUG_S(PerlIO_printf(Perl_debug_log,
2770 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2772 RETURNOP(CvSTART(cv));
2775 I32 markix = TOPMARK;
2780 /* Need to copy @_ to stack. Alternative may be to
2781 * switch stack to @_, and copy return values
2782 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2783 AV * const av = GvAV(PL_defgv);
2784 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2787 /* Mark is at the end of the stack. */
2789 Copy(AvARRAY(av), SP + 1, items, SV*);
2794 /* We assume first XSUB in &DB::sub is the called one. */
2796 SAVEVPTR(PL_curcop);
2797 PL_curcop = PL_curcopdb;
2800 /* Do we need to open block here? XXXX */
2801 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2802 (void)(*CvXSUB(cv))(aTHX_ cv);
2804 /* Enforce some sanity in scalar context. */
2805 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2806 if (markix > PL_stack_sp - PL_stack_base)
2807 *(PL_stack_base + markix) = &PL_sv_undef;
2809 *(PL_stack_base + markix) = *PL_stack_sp;
2810 PL_stack_sp = PL_stack_base + markix;
2818 Perl_sub_crush_depth(pTHX_ CV *cv)
2821 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2823 SV* const tmpstr = sv_newmortal();
2824 gv_efullname3(tmpstr, CvGV(cv), NULL);
2825 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2834 SV* const elemsv = POPs;
2835 IV elem = SvIV(elemsv);
2836 AV* const av = (AV*)POPs;
2837 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2838 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2841 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2842 Perl_warner(aTHX_ packWARN(WARN_MISC),
2843 "Use of reference \"%"SVf"\" as array index",
2846 elem -= CopARYBASE_get(PL_curcop);
2847 if (SvTYPE(av) != SVt_PVAV)
2849 svp = av_fetch(av, elem, lval && !defer);
2851 #ifdef PERL_MALLOC_WRAP
2852 if (SvUOK(elemsv)) {
2853 const UV uv = SvUV(elemsv);
2854 elem = uv > IV_MAX ? IV_MAX : uv;
2856 else if (SvNOK(elemsv))
2857 elem = (IV)SvNV(elemsv);
2859 static const char oom_array_extend[] =
2860 "Out of memory during array extend"; /* Duplicated in av.c */
2861 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2864 if (!svp || *svp == &PL_sv_undef) {
2867 DIE(aTHX_ PL_no_aelem, elem);
2868 lv = sv_newmortal();
2869 sv_upgrade(lv, SVt_PVLV);
2871 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2872 LvTARG(lv) = SvREFCNT_inc_simple(av);
2873 LvTARGOFF(lv) = elem;
2878 if (PL_op->op_private & OPpLVAL_INTRO)
2879 save_aelem(av, elem, svp);
2880 else if (PL_op->op_private & OPpDEREF)
2881 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2883 sv = (svp ? *svp : &PL_sv_undef);
2884 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2885 sv = sv_mortalcopy(sv);
2891 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2896 Perl_croak(aTHX_ PL_no_modify);
2897 if (SvTYPE(sv) < SVt_RV)
2898 sv_upgrade(sv, SVt_RV);
2899 else if (SvTYPE(sv) >= SVt_PV) {
2906 SvRV_set(sv, newSV(0));
2909 SvRV_set(sv, (SV*)newAV());
2912 SvRV_set(sv, (SV*)newHV());
2923 SV* const sv = TOPs;
2926 SV* const rsv = SvRV(sv);
2927 if (SvTYPE(rsv) == SVt_PVCV) {
2933 SETs(method_common(sv, NULL));
2940 SV* const sv = cSVOP_sv;
2941 U32 hash = SvSHARED_HASH(sv);
2943 XPUSHs(method_common(sv, &hash));
2948 S_method_common(pTHX_ SV* meth, U32* hashp)
2955 const char* packname = NULL;
2958 const char * const name = SvPV_const(meth, namelen);
2959 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2962 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2970 /* this isn't a reference */
2971 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2972 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2974 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2981 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2982 !(ob=(SV*)GvIO(iogv)))
2984 /* this isn't the name of a filehandle either */
2986 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2987 ? !isIDFIRST_utf8((U8*)packname)
2988 : !isIDFIRST(*packname)
2991 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2992 SvOK(sv) ? "without a package or object reference"
2993 : "on an undefined value");
2995 /* assume it's a package name */
2996 stash = gv_stashpvn(packname, packlen, FALSE);
3000 SV* const ref = newSViv(PTR2IV(stash));
3001 hv_store(PL_stashcache, packname, packlen, ref, 0);
3005 /* it _is_ a filehandle name -- replace with a reference */
3006 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3009 /* if we got here, ob should be a reference or a glob */
3010 if (!ob || !(SvOBJECT(ob)
3011 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3014 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3018 stash = SvSTASH(ob);
3021 /* NOTE: stash may be null, hope hv_fetch_ent and
3022 gv_fetchmethod can cope (it seems they can) */
3024 /* shortcut for simple names */
3026 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3028 gv = (GV*)HeVAL(he);
3029 if (isGV(gv) && GvCV(gv) &&
3030 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3031 return (SV*)GvCV(gv);
3035 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3038 /* This code tries to figure out just what went wrong with
3039 gv_fetchmethod. It therefore needs to duplicate a lot of
3040 the internals of that function. We can't move it inside
3041 Perl_gv_fetchmethod_autoload(), however, since that would
3042 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3045 const char* leaf = name;
3046 const char* sep = NULL;
3049 for (p = name; *p; p++) {
3051 sep = p, leaf = p + 1;
3052 else if (*p == ':' && *(p + 1) == ':')
3053 sep = p, leaf = p + 2;
3055 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3056 /* the method name is unqualified or starts with SUPER:: */
3057 bool need_strlen = 1;
3059 packname = CopSTASHPV(PL_curcop);
3062 HEK * const packhek = HvNAME_HEK(stash);
3064 packname = HEK_KEY(packhek);
3065 packlen = HEK_LEN(packhek);
3075 "Can't use anonymous symbol table for method lookup");
3077 else if (need_strlen)
3078 packlen = strlen(packname);
3082 /* the method name is qualified */
3084 packlen = sep - name;
3087 /* we're relying on gv_fetchmethod not autovivifying the stash */
3088 if (gv_stashpvn(packname, packlen, FALSE)) {
3090 "Can't locate object method \"%s\" via package \"%.*s\"",
3091 leaf, (int)packlen, packname);
3095 "Can't locate object method \"%s\" via package \"%.*s\""
3096 " (perhaps you forgot to load \"%.*s\"?)",
3097 leaf, (int)packlen, packname, (int)packlen, packname);
3100 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3105 * c-indentation-style: bsd
3107 * indent-tabs-mode: t
3110 * ex: set ts=8 sts=4 sw=4 noet: