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. */
172 SvREFCNT_inc_void(SvRV(cv));
173 /* newCONSTSUB takes a reference count on the passed in SV
174 from us. We set the name to NULL, otherwise we get into
175 all sorts of fun as the reference to our new sub is
176 donated to the GV that we're about to assign to.
178 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
184 SvSetMagicSV(right, left);
193 RETURNOP(cLOGOP->op_other);
195 RETURNOP(cLOGOP->op_next);
202 TAINT_NOT; /* Each statement is presumed innocent */
203 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
205 oldsave = PL_scopestack[PL_scopestack_ix - 1];
206 LEAVE_SCOPE(oldsave);
212 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
217 const char *rpv = NULL;
219 bool rcopied = FALSE;
221 if (TARG == right && right != left) {
222 /* mg_get(right) may happen here ... */
223 rpv = SvPV_const(right, rlen);
224 rbyte = !DO_UTF8(right);
225 right = sv_2mortal(newSVpvn(rpv, rlen));
226 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
232 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
233 lbyte = !DO_UTF8(left);
234 sv_setpvn(TARG, lpv, llen);
240 else { /* TARG == left */
242 SvGETMAGIC(left); /* or mg_get(left) may happen here */
244 if (left == right && ckWARN(WARN_UNINITIALIZED))
245 report_uninit(right);
246 sv_setpvn(left, "", 0);
248 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
249 lbyte = !DO_UTF8(left);
254 /* or mg_get(right) may happen here */
256 rpv = SvPV_const(right, rlen);
257 rbyte = !DO_UTF8(right);
259 if (lbyte != rbyte) {
261 sv_utf8_upgrade_nomg(TARG);
264 right = sv_2mortal(newSVpvn(rpv, rlen));
265 sv_utf8_upgrade_nomg(right);
266 rpv = SvPV_const(right, rlen);
269 sv_catpvn_nomg(TARG, rpv, rlen);
280 if (PL_op->op_flags & OPf_MOD) {
281 if (PL_op->op_private & OPpLVAL_INTRO)
282 if (!(PL_op->op_private & OPpPAD_STATE))
283 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
284 if (PL_op->op_private & OPpDEREF) {
286 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
296 tryAMAGICunTARGET(iter, 0);
297 PL_last_in_gv = (GV*)(*PL_stack_sp--);
298 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
299 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
300 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
303 XPUSHs((SV*)PL_last_in_gv);
306 PL_last_in_gv = (GV*)(*PL_stack_sp--);
309 return do_readline();
314 dVAR; dSP; tryAMAGICbinSET(eq,0);
315 #ifndef NV_PRESERVES_UV
316 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
318 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
322 #ifdef PERL_PRESERVE_IVUV
325 /* Unless the left argument is integer in range we are going
326 to have to use NV maths. Hence only attempt to coerce the
327 right argument if we know the left is integer. */
330 const bool auvok = SvUOK(TOPm1s);
331 const bool buvok = SvUOK(TOPs);
333 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
334 /* Casting IV to UV before comparison isn't going to matter
335 on 2s complement. On 1s complement or sign&magnitude
336 (if we have any of them) it could to make negative zero
337 differ from normal zero. As I understand it. (Need to
338 check - is negative zero implementation defined behaviour
340 const UV buv = SvUVX(POPs);
341 const UV auv = SvUVX(TOPs);
343 SETs(boolSV(auv == buv));
346 { /* ## Mixed IV,UV ## */
350 /* == is commutative so doesn't matter which is left or right */
352 /* top of stack (b) is the iv */
361 /* As uv is a UV, it's >0, so it cannot be == */
364 /* we know iv is >= 0 */
365 SETs(boolSV((UV)iv == SvUVX(uvp)));
372 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
374 if (Perl_isnan(left) || Perl_isnan(right))
376 SETs(boolSV(left == right));
379 SETs(boolSV(TOPn == value));
388 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
389 DIE(aTHX_ PL_no_modify);
390 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
391 && SvIVX(TOPs) != IV_MAX)
393 SvIV_set(TOPs, SvIVX(TOPs) + 1);
394 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
396 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
408 if (PL_op->op_type == OP_OR)
410 RETURNOP(cLOGOP->op_other);
419 const int op_type = PL_op->op_type;
420 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
424 if (!sv || !SvANY(sv)) {
425 if (op_type == OP_DOR)
427 RETURNOP(cLOGOP->op_other);
433 if (!sv || !SvANY(sv))
438 switch (SvTYPE(sv)) {
440 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
444 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
448 if (CvROOT(sv) || CvXSUB(sv))
461 if(op_type == OP_DOR)
463 RETURNOP(cLOGOP->op_other);
465 /* assuming OP_DEFINED */
473 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
474 useleft = USE_LEFT(TOPm1s);
475 #ifdef PERL_PRESERVE_IVUV
476 /* We must see if we can perform the addition with integers if possible,
477 as the integer code detects overflow while the NV code doesn't.
478 If either argument hasn't had a numeric conversion yet attempt to get
479 the IV. It's important to do this now, rather than just assuming that
480 it's not IOK as a PV of "9223372036854775806" may not take well to NV
481 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
482 integer in case the second argument is IV=9223372036854775806
483 We can (now) rely on sv_2iv to do the right thing, only setting the
484 public IOK flag if the value in the NV (or PV) slot is truly integer.
486 A side effect is that this also aggressively prefers integer maths over
487 fp maths for integer values.
489 How to detect overflow?
491 C 99 section 6.2.6.1 says
493 The range of nonnegative values of a signed integer type is a subrange
494 of the corresponding unsigned integer type, and the representation of
495 the same value in each type is the same. A computation involving
496 unsigned operands can never overflow, because a result that cannot be
497 represented by the resulting unsigned integer type is reduced modulo
498 the number that is one greater than the largest value that can be
499 represented by the resulting type.
503 which I read as "unsigned ints wrap."
505 signed integer overflow seems to be classed as "exception condition"
507 If an exceptional condition occurs during the evaluation of an
508 expression (that is, if the result is not mathematically defined or not
509 in the range of representable values for its type), the behavior is
512 (6.5, the 5th paragraph)
514 I had assumed that on 2s complement machines signed arithmetic would
515 wrap, hence coded pp_add and pp_subtract on the assumption that
516 everything perl builds on would be happy. After much wailing and
517 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
518 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
519 unsigned code below is actually shorter than the old code. :-)
524 /* Unless the left argument is integer in range we are going to have to
525 use NV maths. Hence only attempt to coerce the right argument if
526 we know the left is integer. */
534 /* left operand is undef, treat as zero. + 0 is identity,
535 Could SETi or SETu right now, but space optimise by not adding
536 lots of code to speed up what is probably a rarish case. */
538 /* Left operand is defined, so is it IV? */
541 if ((auvok = SvUOK(TOPm1s)))
544 register const IV aiv = SvIVX(TOPm1s);
547 auvok = 1; /* Now acting as a sign flag. */
548 } else { /* 2s complement assumption for IV_MIN */
556 bool result_good = 0;
559 bool buvok = SvUOK(TOPs);
564 register const IV biv = SvIVX(TOPs);
571 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
572 else "IV" now, independent of how it came in.
573 if a, b represents positive, A, B negative, a maps to -A etc
578 all UV maths. negate result if A negative.
579 add if signs same, subtract if signs differ. */
585 /* Must get smaller */
591 /* result really should be -(auv-buv). as its negation
592 of true value, need to swap our result flag */
609 if (result <= (UV)IV_MIN)
612 /* result valid, but out of range for IV. */
617 } /* Overflow, drop through to NVs. */
624 /* left operand is undef, treat as zero. + 0.0 is identity. */
628 SETn( value + TOPn );
636 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
637 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
638 const U32 lval = PL_op->op_flags & OPf_MOD;
639 SV** const svp = av_fetch(av, PL_op->op_private, lval);
640 SV *sv = (svp ? *svp : &PL_sv_undef);
642 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
643 sv = sv_mortalcopy(sv);
650 dVAR; dSP; dMARK; dTARGET;
652 do_join(TARG, *MARK, MARK, SP);
663 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
664 * will be enough to hold an OP*.
666 SV* const sv = sv_newmortal();
667 sv_upgrade(sv, SVt_PVLV);
669 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
677 /* Oversized hot code. */
681 dVAR; dSP; dMARK; dORIGMARK;
685 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
687 if (gv && (io = GvIO(gv))
688 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
691 if (MARK == ORIGMARK) {
692 /* If using default handle then we need to make space to
693 * pass object as 1st arg, so move other args up ...
697 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
701 *MARK = SvTIED_obj((SV*)io, mg);
704 call_method("PRINT", G_SCALAR);
712 if (!(io = GvIO(gv))) {
713 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
714 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
716 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
717 report_evil_fh(gv, io, PL_op->op_type);
718 SETERRNO(EBADF,RMS_IFI);
721 else if (!(fp = IoOFP(io))) {
722 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
724 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
725 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
726 report_evil_fh(gv, io, PL_op->op_type);
728 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
733 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
735 if (!do_print(*MARK, fp))
739 if (!do_print(PL_ofs_sv, fp)) { /* $, */
748 if (!do_print(*MARK, fp))
756 if (PL_op->op_type == OP_SAY) {
757 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
760 else if (PL_ors_sv && SvOK(PL_ors_sv))
761 if (!do_print(PL_ors_sv, fp)) /* $\ */
764 if (IoFLAGS(io) & IOf_FLUSH)
765 if (PerlIO_flush(fp) == EOF)
775 XPUSHs(&PL_sv_undef);
782 const I32 gimme = GIMME_V;
783 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
784 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
785 static const char an_array[] = "an ARRAY";
786 static const char a_hash[] = "a HASH";
787 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
788 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
792 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
795 if (SvTYPE(sv) != type)
796 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
797 if (PL_op->op_flags & OPf_REF) {
802 if (gimme != G_ARRAY)
803 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
804 : return_hash_to_lvalue_scalar);
808 else if (PL_op->op_flags & OPf_MOD
809 && PL_op->op_private & OPpLVAL_INTRO)
810 Perl_croak(aTHX_ PL_no_localize_ref);
813 if (SvTYPE(sv) == type) {
814 if (PL_op->op_flags & OPf_REF) {
819 if (gimme != G_ARRAY)
821 is_pp_rv2av ? return_array_to_lvalue_scalar
822 : return_hash_to_lvalue_scalar);
830 if (SvTYPE(sv) != SVt_PVGV) {
831 if (SvGMAGICAL(sv)) {
836 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
844 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
845 if (PL_op->op_private & OPpLVAL_INTRO)
846 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
847 if (PL_op->op_flags & OPf_REF) {
852 if (gimme != G_ARRAY)
854 is_pp_rv2av ? return_array_to_lvalue_scalar
855 : return_hash_to_lvalue_scalar);
863 AV *const av = (AV*)sv;
864 /* The guts of pp_rv2av, with no intenting change to preserve history
865 (until such time as we get tools that can do blame annotation across
866 whitespace changes. */
867 if (gimme == G_ARRAY) {
868 const I32 maxarg = AvFILL(av) + 1;
869 (void)POPs; /* XXXX May be optimized away? */
871 if (SvRMAGICAL(av)) {
873 for (i=0; i < (U32)maxarg; i++) {
874 SV ** const svp = av_fetch(av, i, FALSE);
875 /* See note in pp_helem, and bug id #27839 */
877 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
882 Copy(AvARRAY(av), SP+1, maxarg, SV*);
886 else if (gimme == G_SCALAR) {
888 const I32 maxarg = AvFILL(av) + 1;
892 /* The guts of pp_rv2hv */
893 if (gimme == G_ARRAY) { /* array wanted */
897 else if (gimme == G_SCALAR) {
899 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
908 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
915 if (ckWARN(WARN_MISC)) {
917 if (relem == firstrelem &&
919 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
920 SvTYPE(SvRV(*relem)) == SVt_PVHV))
922 err = "Reference found where even-sized list expected";
925 err = "Odd number of elements in hash assignment";
926 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
930 didstore = hv_store_ent(hash,*relem,tmpstr,0);
931 if (SvMAGICAL(hash)) {
932 if (SvSMAGICAL(tmpstr))
944 SV **lastlelem = PL_stack_sp;
945 SV **lastrelem = PL_stack_base + POPMARK;
946 SV **firstrelem = PL_stack_base + POPMARK + 1;
947 SV **firstlelem = lastrelem + 1;
960 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
962 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
965 /* If there's a common identifier on both sides we have to take
966 * special care that assigning the identifier on the left doesn't
967 * clobber a value on the right that's used later in the list.
969 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
970 EXTEND_MORTAL(lastrelem - firstrelem + 1);
971 for (relem = firstrelem; relem <= lastrelem; relem++) {
973 TAINT_NOT; /* Each item is independent */
974 *relem = sv_mortalcopy(sv);
984 while (lelem <= lastlelem) {
985 TAINT_NOT; /* Each item stands on its own, taintwise. */
987 switch (SvTYPE(sv)) {
990 magic = SvMAGICAL(ary) != 0;
992 av_extend(ary, lastrelem - relem);
994 while (relem <= lastrelem) { /* gobble up all the rest */
997 sv = newSVsv(*relem);
999 didstore = av_store(ary,i++,sv);
1009 case SVt_PVHV: { /* normal hash */
1013 magic = SvMAGICAL(hash) != 0;
1015 firsthashrelem = relem;
1017 while (relem < lastrelem) { /* gobble up all the rest */
1019 sv = *relem ? *relem : &PL_sv_no;
1023 sv_setsv(tmpstr,*relem); /* value */
1024 *(relem++) = tmpstr;
1025 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1026 /* key overwrites an existing entry */
1028 didstore = hv_store_ent(hash,sv,tmpstr,0);
1030 if (SvSMAGICAL(tmpstr))
1037 if (relem == lastrelem) {
1038 do_oddball(hash, relem, firstrelem);
1044 if (SvIMMORTAL(sv)) {
1045 if (relem <= lastrelem)
1049 if (relem <= lastrelem) {
1050 sv_setsv(sv, *relem);
1054 sv_setsv(sv, &PL_sv_undef);
1059 if (PL_delaymagic & ~DM_DELAY) {
1060 if (PL_delaymagic & DM_UID) {
1061 #ifdef HAS_SETRESUID
1062 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1063 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1066 # ifdef HAS_SETREUID
1067 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1068 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1071 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1072 (void)setruid(PL_uid);
1073 PL_delaymagic &= ~DM_RUID;
1075 # endif /* HAS_SETRUID */
1077 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1078 (void)seteuid(PL_euid);
1079 PL_delaymagic &= ~DM_EUID;
1081 # endif /* HAS_SETEUID */
1082 if (PL_delaymagic & DM_UID) {
1083 if (PL_uid != PL_euid)
1084 DIE(aTHX_ "No setreuid available");
1085 (void)PerlProc_setuid(PL_uid);
1087 # endif /* HAS_SETREUID */
1088 #endif /* HAS_SETRESUID */
1089 PL_uid = PerlProc_getuid();
1090 PL_euid = PerlProc_geteuid();
1092 if (PL_delaymagic & DM_GID) {
1093 #ifdef HAS_SETRESGID
1094 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1095 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1098 # ifdef HAS_SETREGID
1099 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1100 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1103 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1104 (void)setrgid(PL_gid);
1105 PL_delaymagic &= ~DM_RGID;
1107 # endif /* HAS_SETRGID */
1109 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1110 (void)setegid(PL_egid);
1111 PL_delaymagic &= ~DM_EGID;
1113 # endif /* HAS_SETEGID */
1114 if (PL_delaymagic & DM_GID) {
1115 if (PL_gid != PL_egid)
1116 DIE(aTHX_ "No setregid available");
1117 (void)PerlProc_setgid(PL_gid);
1119 # endif /* HAS_SETREGID */
1120 #endif /* HAS_SETRESGID */
1121 PL_gid = PerlProc_getgid();
1122 PL_egid = PerlProc_getegid();
1124 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1128 if (gimme == G_VOID)
1129 SP = firstrelem - 1;
1130 else if (gimme == G_SCALAR) {
1133 SETi(lastrelem - firstrelem + 1 - duplicates);
1140 /* Removes from the stack the entries which ended up as
1141 * duplicated keys in the hash (fix for [perl #24380]) */
1142 Move(firsthashrelem + duplicates,
1143 firsthashrelem, duplicates, SV**);
1144 lastrelem -= duplicates;
1149 SP = firstrelem + (lastlelem - firstlelem);
1150 lelem = firstlelem + (relem - firstrelem);
1152 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1155 /* This is done at the bottom and in this order because
1156 mro_isa_changed_in() can throw exceptions */
1158 HV* stash = PL_delayedisa;
1159 PL_delayedisa = NULL;
1160 mro_isa_changed_in(stash);
1169 register PMOP * const pm = cPMOP;
1170 REGEXP * rx = PM_GETRE(pm);
1171 SV * const pkg = CALLREG_PACKAGE(rx);
1172 SV * const rv = sv_newmortal();
1173 SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1174 if (rx->extflags & RXf_TAINTED)
1176 sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1184 register PMOP *pm = cPMOP;
1186 register const char *t;
1187 register const char *s;
1190 I32 r_flags = REXEC_CHECKED;
1191 const char *truebase; /* Start of string */
1192 register REGEXP *rx = PM_GETRE(pm);
1194 const I32 gimme = GIMME;
1197 const I32 oldsave = PL_savestack_ix;
1198 I32 update_minmatch = 1;
1199 I32 had_zerolen = 0;
1202 if (PL_op->op_flags & OPf_STACKED)
1204 else if (PL_op->op_private & OPpTARGET_MY)
1211 PUTBACK; /* EVAL blocks need stack_sp. */
1212 s = SvPV_const(TARG, len);
1214 DIE(aTHX_ "panic: pp_match");
1216 rxtainted = ((rx->extflags & RXf_TAINTED) ||
1217 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1220 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1222 /* PMdf_USED is set after a ?? matches once */
1225 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1227 pm->op_pmflags & PMf_USED
1231 if (gimme == G_ARRAY)
1238 /* empty pattern special-cased to use last successful pattern if possible */
1239 if (!rx->prelen && PL_curpm) {
1244 if (rx->minlen > (I32)len)
1249 /* XXXX What part of this is needed with true \G-support? */
1250 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1251 rx->offs[0].start = -1;
1252 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1253 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1254 if (mg && mg->mg_len >= 0) {
1255 if (!(rx->extflags & RXf_GPOS_SEEN))
1256 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1257 else if (rx->extflags & RXf_ANCH_GPOS) {
1258 r_flags |= REXEC_IGNOREPOS;
1259 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1260 } else if (rx->extflags & RXf_GPOS_FLOAT)
1263 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1264 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1265 update_minmatch = 0;
1269 /* remove comment to get faster /g but possibly unsafe $1 vars after a
1270 match. Test for the unsafe vars will fail as well*/
1271 if (( /* !global && */ rx->nparens)
1272 || SvTEMP(TARG) || PL_sawampersand ||
1273 (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1274 r_flags |= REXEC_COPY_STR;
1276 r_flags |= REXEC_SCREAM;
1279 if (global && rx->offs[0].start != -1) {
1280 t = s = rx->offs[0].end + truebase - rx->gofs;
1281 if ((s + rx->minlen) > strend || s < truebase)
1283 if (update_minmatch++)
1284 minmatch = had_zerolen;
1286 if (rx->extflags & RXf_USE_INTUIT &&
1287 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1288 /* FIXME - can PL_bostr be made const char *? */
1289 PL_bostr = (char *)truebase;
1290 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1294 if ( (rx->extflags & RXf_CHECK_ALL)
1296 && !(rx->extflags & RXf_PMf_KEEPCOPY)
1297 && ((rx->extflags & RXf_NOSCAN)
1298 || !((rx->extflags & RXf_INTUIT_TAIL)
1299 && (r_flags & REXEC_SCREAM)))
1300 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1303 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1306 if (dynpm->op_pmflags & PMf_ONCE) {
1308 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1310 dynpm->op_pmflags |= PMf_USED;
1321 RX_MATCH_TAINTED_on(rx);
1322 TAINT_IF(RX_MATCH_TAINTED(rx));
1323 if (gimme == G_ARRAY) {
1324 const I32 nparens = rx->nparens;
1325 I32 i = (global && !nparens) ? 1 : 0;
1327 SPAGAIN; /* EVAL blocks could move the stack. */
1328 EXTEND(SP, nparens + i);
1329 EXTEND_MORTAL(nparens + i);
1330 for (i = !i; i <= nparens; i++) {
1331 PUSHs(sv_newmortal());
1332 if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1333 const I32 len = rx->offs[i].end - rx->offs[i].start;
1334 s = rx->offs[i].start + truebase;
1335 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1336 len < 0 || len > strend - s)
1337 DIE(aTHX_ "panic: pp_match start/end pointers");
1338 sv_setpvn(*SP, s, len);
1339 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1344 if (dynpm->op_pmflags & PMf_CONTINUE) {
1346 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1347 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1349 #ifdef PERL_OLD_COPY_ON_WRITE
1351 sv_force_normal_flags(TARG, 0);
1353 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1354 &PL_vtbl_mglob, NULL, 0);
1356 if (rx->offs[0].start != -1) {
1357 mg->mg_len = rx->offs[0].end;
1358 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1359 mg->mg_flags |= MGf_MINMATCH;
1361 mg->mg_flags &= ~MGf_MINMATCH;
1364 had_zerolen = (rx->offs[0].start != -1
1365 && (rx->offs[0].start + rx->gofs
1366 == (UV)rx->offs[0].end));
1367 PUTBACK; /* EVAL blocks may use stack */
1368 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1373 LEAVE_SCOPE(oldsave);
1379 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1380 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1384 #ifdef PERL_OLD_COPY_ON_WRITE
1386 sv_force_normal_flags(TARG, 0);
1388 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1389 &PL_vtbl_mglob, NULL, 0);
1391 if (rx->offs[0].start != -1) {
1392 mg->mg_len = rx->offs[0].end;
1393 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1394 mg->mg_flags |= MGf_MINMATCH;
1396 mg->mg_flags &= ~MGf_MINMATCH;
1399 LEAVE_SCOPE(oldsave);
1403 yup: /* Confirmed by INTUIT */
1405 RX_MATCH_TAINTED_on(rx);
1406 TAINT_IF(RX_MATCH_TAINTED(rx));
1408 if (dynpm->op_pmflags & PMf_ONCE) {
1410 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1412 dynpm->op_pmflags |= PMf_USED;
1415 if (RX_MATCH_COPIED(rx))
1416 Safefree(rx->subbeg);
1417 RX_MATCH_COPIED_off(rx);
1420 /* FIXME - should rx->subbeg be const char *? */
1421 rx->subbeg = (char *) truebase;
1422 rx->offs[0].start = s - truebase;
1423 if (RX_MATCH_UTF8(rx)) {
1424 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1425 rx->offs[0].end = t - truebase;
1428 rx->offs[0].end = s - truebase + rx->minlenret;
1430 rx->sublen = strend - truebase;
1433 if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1435 #ifdef PERL_OLD_COPY_ON_WRITE
1436 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1438 PerlIO_printf(Perl_debug_log,
1439 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1440 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1443 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1444 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1445 assert (SvPOKp(rx->saved_copy));
1450 rx->subbeg = savepvn(t, strend - t);
1451 #ifdef PERL_OLD_COPY_ON_WRITE
1452 rx->saved_copy = NULL;
1455 rx->sublen = strend - t;
1456 RX_MATCH_COPIED_on(rx);
1457 off = rx->offs[0].start = s - t;
1458 rx->offs[0].end = off + rx->minlenret;
1460 else { /* startp/endp are used by @- @+. */
1461 rx->offs[0].start = s - truebase;
1462 rx->offs[0].end = s - truebase + rx->minlenret;
1464 /* including rx->nparens in the below code seems highly suspicious.
1466 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1467 LEAVE_SCOPE(oldsave);
1472 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1473 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1474 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1479 LEAVE_SCOPE(oldsave);
1480 if (gimme == G_ARRAY)
1486 Perl_do_readline(pTHX)
1488 dVAR; dSP; dTARGETSTACKED;
1493 register IO * const io = GvIO(PL_last_in_gv);
1494 register const I32 type = PL_op->op_type;
1495 const I32 gimme = GIMME_V;
1498 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1501 XPUSHs(SvTIED_obj((SV*)io, mg));
1504 call_method("READLINE", gimme);
1507 if (gimme == G_SCALAR) {
1508 SV* const result = POPs;
1509 SvSetSV_nosteal(TARG, result);
1519 if (IoFLAGS(io) & IOf_ARGV) {
1520 if (IoFLAGS(io) & IOf_START) {
1522 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1523 IoFLAGS(io) &= ~IOf_START;
1524 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1525 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1526 SvSETMAGIC(GvSV(PL_last_in_gv));
1531 fp = nextargv(PL_last_in_gv);
1532 if (!fp) { /* Note: fp != IoIFP(io) */
1533 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1536 else if (type == OP_GLOB)
1537 fp = Perl_start_glob(aTHX_ POPs, io);
1539 else if (type == OP_GLOB)
1541 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1542 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1546 if ((!io || !(IoFLAGS(io) & IOf_START))
1547 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1549 if (type == OP_GLOB)
1550 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1551 "glob failed (can't start child: %s)",
1554 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1556 if (gimme == G_SCALAR) {
1557 /* undef TARG, and push that undefined value */
1558 if (type != OP_RCATLINE) {
1559 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1567 if (gimme == G_SCALAR) {
1569 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1572 if (type == OP_RCATLINE)
1573 SvPV_force_nolen(sv);
1577 else if (isGV_with_GP(sv)) {
1578 SvPV_force_nolen(sv);
1580 SvUPGRADE(sv, SVt_PV);
1581 tmplen = SvLEN(sv); /* remember if already alloced */
1582 if (!tmplen && !SvREADONLY(sv))
1583 Sv_Grow(sv, 80); /* try short-buffering it */
1585 if (type == OP_RCATLINE && SvOK(sv)) {
1587 SvPV_force_nolen(sv);
1593 sv = sv_2mortal(newSV(80));
1597 /* This should not be marked tainted if the fp is marked clean */
1598 #define MAYBE_TAINT_LINE(io, sv) \
1599 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1604 /* delay EOF state for a snarfed empty file */
1605 #define SNARF_EOF(gimme,rs,io,sv) \
1606 (gimme != G_SCALAR || SvCUR(sv) \
1607 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1611 if (!sv_gets(sv, fp, offset)
1613 || SNARF_EOF(gimme, PL_rs, io, sv)
1614 || PerlIO_error(fp)))
1616 PerlIO_clearerr(fp);
1617 if (IoFLAGS(io) & IOf_ARGV) {
1618 fp = nextargv(PL_last_in_gv);
1621 (void)do_close(PL_last_in_gv, FALSE);
1623 else if (type == OP_GLOB) {
1624 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1625 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1626 "glob failed (child exited with status %d%s)",
1627 (int)(STATUS_CURRENT >> 8),
1628 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1631 if (gimme == G_SCALAR) {
1632 if (type != OP_RCATLINE) {
1633 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1639 MAYBE_TAINT_LINE(io, sv);
1642 MAYBE_TAINT_LINE(io, sv);
1644 IoFLAGS(io) |= IOf_NOLINE;
1648 if (type == OP_GLOB) {
1651 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1652 char * const tmps = SvEND(sv) - 1;
1653 if (*tmps == *SvPVX_const(PL_rs)) {
1655 SvCUR_set(sv, SvCUR(sv) - 1);
1658 for (t1 = SvPVX_const(sv); *t1; t1++)
1659 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1660 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1662 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1663 (void)POPs; /* Unmatched wildcard? Chuck it... */
1666 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1667 if (ckWARN(WARN_UTF8)) {
1668 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1669 const STRLEN len = SvCUR(sv) - offset;
1672 if (!is_utf8_string_loc(s, len, &f))
1673 /* Emulate :encoding(utf8) warning in the same case. */
1674 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1675 "utf8 \"\\x%02X\" does not map to Unicode",
1676 f < (U8*)SvEND(sv) ? *f : 0);
1679 if (gimme == G_ARRAY) {
1680 if (SvLEN(sv) - SvCUR(sv) > 20) {
1681 SvPV_shrink_to_cur(sv);
1683 sv = sv_2mortal(newSV(80));
1686 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1687 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1688 const STRLEN new_len
1689 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1690 SvPV_renew(sv, new_len);
1699 register PERL_CONTEXT *cx;
1700 I32 gimme = OP_GIMME(PL_op, -1);
1703 if (cxstack_ix >= 0)
1704 gimme = cxstack[cxstack_ix].blk_gimme;
1712 PUSHBLOCK(cx, CXt_BLOCK, SP);
1722 SV * const keysv = POPs;
1723 HV * const hv = (HV*)POPs;
1724 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1725 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1727 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1730 if (SvTYPE(hv) != SVt_PVHV)
1733 if (PL_op->op_private & OPpLVAL_INTRO) {
1736 /* does the element we're localizing already exist? */
1737 preeminent = /* can we determine whether it exists? */
1739 || mg_find((SV*)hv, PERL_MAGIC_env)
1740 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1741 /* Try to preserve the existenceness of a tied hash
1742 * element by using EXISTS and DELETE if possible.
1743 * Fallback to FETCH and STORE otherwise */
1744 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1745 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1746 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1748 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1750 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1751 svp = he ? &HeVAL(he) : NULL;
1753 if (!svp || *svp == &PL_sv_undef) {
1757 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1759 lv = sv_newmortal();
1760 sv_upgrade(lv, SVt_PVLV);
1762 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1763 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1764 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1769 if (PL_op->op_private & OPpLVAL_INTRO) {
1770 if (HvNAME_get(hv) && isGV(*svp))
1771 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1775 const char * const key = SvPV_const(keysv, keylen);
1776 SAVEDELETE(hv, savepvn(key,keylen),
1777 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1779 save_helem(hv, keysv, svp);
1782 else if (PL_op->op_private & OPpDEREF)
1783 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1785 sv = (svp ? *svp : &PL_sv_undef);
1786 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1787 * Pushing the magical RHS on to the stack is useless, since
1788 * that magic is soon destined to be misled by the local(),
1789 * and thus the later pp_sassign() will fail to mg_get() the
1790 * old value. This should also cure problems with delayed
1791 * mg_get()s. GSAR 98-07-03 */
1792 if (!lval && SvGMAGICAL(sv))
1793 sv = sv_mortalcopy(sv);
1801 register PERL_CONTEXT *cx;
1806 if (PL_op->op_flags & OPf_SPECIAL) {
1807 cx = &cxstack[cxstack_ix];
1808 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1813 gimme = OP_GIMME(PL_op, -1);
1815 if (cxstack_ix >= 0)
1816 gimme = cxstack[cxstack_ix].blk_gimme;
1822 if (gimme == G_VOID)
1824 else if (gimme == G_SCALAR) {
1828 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1831 *MARK = sv_mortalcopy(TOPs);
1834 *MARK = &PL_sv_undef;
1838 else if (gimme == G_ARRAY) {
1839 /* in case LEAVE wipes old return values */
1841 for (mark = newsp + 1; mark <= SP; mark++) {
1842 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1843 *mark = sv_mortalcopy(*mark);
1844 TAINT_NOT; /* Each item is independent */
1848 PL_curpm = newpm; /* Don't pop $1 et al till now */
1858 register PERL_CONTEXT *cx;
1864 cx = &cxstack[cxstack_ix];
1865 if (CxTYPE(cx) != CXt_LOOP)
1866 DIE(aTHX_ "panic: pp_iter");
1868 itersvp = CxITERVAR(cx);
1869 av = cx->blk_loop.iterary;
1870 if (SvTYPE(av) != SVt_PVAV) {
1871 /* iterate ($min .. $max) */
1872 if (cx->blk_loop.iterlval) {
1873 /* string increment */
1874 register SV* cur = cx->blk_loop.iterlval;
1878 SvPV_const((SV*)av, maxlen) : (const char *)"";
1879 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1880 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1881 /* safe to reuse old SV */
1882 sv_setsv(*itersvp, cur);
1886 /* we need a fresh SV every time so that loop body sees a
1887 * completely new SV for closures/references to work as
1890 *itersvp = newSVsv(cur);
1891 SvREFCNT_dec(oldsv);
1893 if (strEQ(SvPVX_const(cur), max))
1894 sv_setiv(cur, 0); /* terminate next time */
1901 /* integer increment */
1902 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1905 /* don't risk potential race */
1906 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1907 /* safe to reuse old SV */
1908 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1912 /* we need a fresh SV every time so that loop body sees a
1913 * completely new SV for closures/references to work as they
1916 *itersvp = newSViv(cx->blk_loop.iterix++);
1917 SvREFCNT_dec(oldsv);
1923 if (PL_op->op_private & OPpITER_REVERSED) {
1924 /* In reverse, use itermax as the min :-) */
1925 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1928 if (SvMAGICAL(av) || AvREIFY(av)) {
1929 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1930 sv = svp ? *svp : NULL;
1933 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1937 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1941 if (SvMAGICAL(av) || AvREIFY(av)) {
1942 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1943 sv = svp ? *svp : NULL;
1946 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1950 if (sv && SvIS_FREED(sv)) {
1952 Perl_croak(aTHX_ "Use of freed value in iteration");
1959 if (av != PL_curstack && sv == &PL_sv_undef) {
1960 SV *lv = cx->blk_loop.iterlval;
1961 if (lv && SvREFCNT(lv) > 1) {
1966 SvREFCNT_dec(LvTARG(lv));
1968 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1970 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1972 LvTARG(lv) = SvREFCNT_inc_simple(av);
1973 LvTARGOFF(lv) = cx->blk_loop.iterix;
1974 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1979 *itersvp = SvREFCNT_inc_simple_NN(sv);
1980 SvREFCNT_dec(oldsv);
1988 register PMOP *pm = cPMOP;
2003 register REGEXP *rx = PM_GETRE(pm);
2005 int force_on_match = 0;
2006 const I32 oldsave = PL_savestack_ix;
2008 bool doutf8 = FALSE;
2009 #ifdef PERL_OLD_COPY_ON_WRITE
2014 /* known replacement string? */
2015 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2016 if (PL_op->op_flags & OPf_STACKED)
2018 else if (PL_op->op_private & OPpTARGET_MY)
2025 #ifdef PERL_OLD_COPY_ON_WRITE
2026 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2027 because they make integers such as 256 "false". */
2028 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2031 sv_force_normal_flags(TARG,0);
2034 #ifdef PERL_OLD_COPY_ON_WRITE
2038 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2039 || SvTYPE(TARG) > SVt_PVLV)
2040 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2041 DIE(aTHX_ PL_no_modify);
2044 s = SvPV_mutable(TARG, len);
2045 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2047 rxtainted = ((rx->extflags & RXf_TAINTED) ||
2048 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2053 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2057 DIE(aTHX_ "panic: pp_subst");
2060 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2061 maxiters = 2 * slen + 10; /* We can match twice at each
2062 position, once with zero-length,
2063 second time with non-zero. */
2065 if (!rx->prelen && PL_curpm) {
2069 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2070 || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2071 ? REXEC_COPY_STR : 0;
2073 r_flags |= REXEC_SCREAM;
2076 if (rx->extflags & RXf_USE_INTUIT) {
2078 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2082 /* How to do it in subst? */
2083 /* if ( (rx->extflags & RXf_CHECK_ALL)
2085 && !(rx->extflags & RXf_KEEPCOPY)
2086 && ((rx->extflags & RXf_NOSCAN)
2087 || !((rx->extflags & RXf_INTUIT_TAIL)
2088 && (r_flags & REXEC_SCREAM))))
2093 /* only replace once? */
2094 once = !(rpm->op_pmflags & PMf_GLOBAL);
2096 /* known replacement string? */
2098 /* replacement needing upgrading? */
2099 if (DO_UTF8(TARG) && !doutf8) {
2100 nsv = sv_newmortal();
2103 sv_recode_to_utf8(nsv, PL_encoding);
2105 sv_utf8_upgrade(nsv);
2106 c = SvPV_const(nsv, clen);
2110 c = SvPV_const(dstr, clen);
2111 doutf8 = DO_UTF8(dstr);
2119 /* can do inplace substitution? */
2121 #ifdef PERL_OLD_COPY_ON_WRITE
2124 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2125 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2126 && (!doutf8 || SvUTF8(TARG))) {
2127 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2128 r_flags | REXEC_CHECKED))
2132 LEAVE_SCOPE(oldsave);
2135 #ifdef PERL_OLD_COPY_ON_WRITE
2136 if (SvIsCOW(TARG)) {
2137 assert (!force_on_match);
2141 if (force_on_match) {
2143 s = SvPV_force(TARG, len);
2148 SvSCREAM_off(TARG); /* disable possible screamer */
2150 rxtainted |= RX_MATCH_TAINTED(rx);
2151 m = orig + rx->offs[0].start;
2152 d = orig + rx->offs[0].end;
2154 if (m - s > strend - d) { /* faster to shorten from end */
2156 Copy(c, m, clen, char);
2161 Move(d, m, i, char);
2165 SvCUR_set(TARG, m - s);
2167 else if ((i = m - s)) { /* faster from front */
2175 Copy(c, m, clen, char);
2180 Copy(c, d, clen, char);
2185 TAINT_IF(rxtainted & 1);
2191 if (iters++ > maxiters)
2192 DIE(aTHX_ "Substitution loop");
2193 rxtainted |= RX_MATCH_TAINTED(rx);
2194 m = rx->offs[0].start + orig;
2197 Move(s, d, i, char);
2201 Copy(c, d, clen, char);
2204 s = rx->offs[0].end + orig;
2205 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2207 /* don't match same null twice */
2208 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2211 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2212 Move(s, d, i+1, char); /* include the NUL */
2214 TAINT_IF(rxtainted & 1);
2216 PUSHs(sv_2mortal(newSViv((I32)iters)));
2218 (void)SvPOK_only_UTF8(TARG);
2219 TAINT_IF(rxtainted);
2220 if (SvSMAGICAL(TARG)) {
2228 LEAVE_SCOPE(oldsave);
2232 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2233 r_flags | REXEC_CHECKED))
2235 if (force_on_match) {
2237 s = SvPV_force(TARG, len);
2240 #ifdef PERL_OLD_COPY_ON_WRITE
2243 rxtainted |= RX_MATCH_TAINTED(rx);
2244 dstr = newSVpvn(m, s-m);
2250 register PERL_CONTEXT *cx;
2253 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2255 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2257 if (iters++ > maxiters)
2258 DIE(aTHX_ "Substitution loop");
2259 rxtainted |= RX_MATCH_TAINTED(rx);
2260 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2265 strend = s + (strend - m);
2267 m = rx->offs[0].start + orig;
2268 if (doutf8 && !SvUTF8(dstr))
2269 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2271 sv_catpvn(dstr, s, m-s);
2272 s = rx->offs[0].end + orig;
2274 sv_catpvn(dstr, c, clen);
2277 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2278 TARG, NULL, r_flags));
2279 if (doutf8 && !DO_UTF8(TARG))
2280 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2282 sv_catpvn(dstr, s, strend - s);
2284 #ifdef PERL_OLD_COPY_ON_WRITE
2285 /* The match may make the string COW. If so, brilliant, because that's
2286 just saved us one malloc, copy and free - the regexp has donated
2287 the old buffer, and we malloc an entirely new one, rather than the
2288 regexp malloc()ing a buffer and copying our original, only for
2289 us to throw it away here during the substitution. */
2290 if (SvIsCOW(TARG)) {
2291 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2297 SvPV_set(TARG, SvPVX(dstr));
2298 SvCUR_set(TARG, SvCUR(dstr));
2299 SvLEN_set(TARG, SvLEN(dstr));
2300 doutf8 |= DO_UTF8(dstr);
2301 SvPV_set(dstr, NULL);
2303 TAINT_IF(rxtainted & 1);
2305 PUSHs(sv_2mortal(newSViv((I32)iters)));
2307 (void)SvPOK_only(TARG);
2310 TAINT_IF(rxtainted);
2313 LEAVE_SCOPE(oldsave);
2322 LEAVE_SCOPE(oldsave);
2331 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2332 ++*PL_markstack_ptr;
2333 LEAVE; /* exit inner scope */
2336 if (PL_stack_base + *PL_markstack_ptr > SP) {
2338 const I32 gimme = GIMME_V;
2340 LEAVE; /* exit outer scope */
2341 (void)POPMARK; /* pop src */
2342 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2343 (void)POPMARK; /* pop dst */
2344 SP = PL_stack_base + POPMARK; /* pop original mark */
2345 if (gimme == G_SCALAR) {
2346 if (PL_op->op_private & OPpGREP_LEX) {
2347 SV* const sv = sv_newmortal();
2348 sv_setiv(sv, items);
2356 else if (gimme == G_ARRAY)
2363 ENTER; /* enter inner scope */
2366 src = PL_stack_base[*PL_markstack_ptr];
2368 if (PL_op->op_private & OPpGREP_LEX)
2369 PAD_SVl(PL_op->op_targ) = src;
2373 RETURNOP(cLOGOP->op_other);
2384 register PERL_CONTEXT *cx;
2387 if (CxMULTICALL(&cxstack[cxstack_ix]))
2391 cxstack_ix++; /* temporarily protect top context */
2394 if (gimme == G_SCALAR) {
2397 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2399 *MARK = SvREFCNT_inc(TOPs);
2404 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2406 *MARK = sv_mortalcopy(sv);
2411 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2415 *MARK = &PL_sv_undef;
2419 else if (gimme == G_ARRAY) {
2420 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2421 if (!SvTEMP(*MARK)) {
2422 *MARK = sv_mortalcopy(*MARK);
2423 TAINT_NOT; /* Each item is independent */
2431 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2432 PL_curpm = newpm; /* ... and pop $1 et al */
2435 return cx->blk_sub.retop;
2438 /* This duplicates the above code because the above code must not
2439 * get any slower by more conditions */
2447 register PERL_CONTEXT *cx;
2450 if (CxMULTICALL(&cxstack[cxstack_ix]))
2454 cxstack_ix++; /* temporarily protect top context */
2458 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2459 /* We are an argument to a function or grep().
2460 * This kind of lvalueness was legal before lvalue
2461 * subroutines too, so be backward compatible:
2462 * cannot report errors. */
2464 /* Scalar context *is* possible, on the LHS of -> only,
2465 * as in f()->meth(). But this is not an lvalue. */
2466 if (gimme == G_SCALAR)
2468 if (gimme == G_ARRAY) {
2469 if (!CvLVALUE(cx->blk_sub.cv))
2470 goto temporise_array;
2471 EXTEND_MORTAL(SP - newsp);
2472 for (mark = newsp + 1; mark <= SP; mark++) {
2475 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2476 *mark = sv_mortalcopy(*mark);
2478 /* Can be a localized value subject to deletion. */
2479 PL_tmps_stack[++PL_tmps_ix] = *mark;
2480 SvREFCNT_inc_void(*mark);
2485 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2486 /* Here we go for robustness, not for speed, so we change all
2487 * the refcounts so the caller gets a live guy. Cannot set
2488 * TEMP, so sv_2mortal is out of question. */
2489 if (!CvLVALUE(cx->blk_sub.cv)) {
2495 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2497 if (gimme == G_SCALAR) {
2501 /* Temporaries are bad unless they happen to be elements
2502 * of a tied hash or array */
2503 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2504 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2510 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2511 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2512 : "a readonly value" : "a temporary");
2514 else { /* Can be a localized value
2515 * subject to deletion. */
2516 PL_tmps_stack[++PL_tmps_ix] = *mark;
2517 SvREFCNT_inc_void(*mark);
2520 else { /* Should not happen? */
2526 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2527 (MARK > SP ? "Empty array" : "Array"));
2531 else if (gimme == G_ARRAY) {
2532 EXTEND_MORTAL(SP - newsp);
2533 for (mark = newsp + 1; mark <= SP; mark++) {
2534 if (*mark != &PL_sv_undef
2535 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2536 /* Might be flattened array after $#array = */
2543 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2544 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2547 /* Can be a localized value subject to deletion. */
2548 PL_tmps_stack[++PL_tmps_ix] = *mark;
2549 SvREFCNT_inc_void(*mark);
2555 if (gimme == G_SCALAR) {
2559 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2561 *MARK = SvREFCNT_inc(TOPs);
2566 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2568 *MARK = sv_mortalcopy(sv);
2573 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2577 *MARK = &PL_sv_undef;
2581 else if (gimme == G_ARRAY) {
2583 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2584 if (!SvTEMP(*MARK)) {
2585 *MARK = sv_mortalcopy(*MARK);
2586 TAINT_NOT; /* Each item is independent */
2595 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2596 PL_curpm = newpm; /* ... and pop $1 et al */
2599 return cx->blk_sub.retop;
2607 register PERL_CONTEXT *cx;
2609 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2612 DIE(aTHX_ "Not a CODE reference");
2613 switch (SvTYPE(sv)) {
2614 /* This is overwhelming the most common case: */
2616 if (!(cv = GvCVu((GV*)sv))) {
2618 cv = sv_2cv(sv, &stash, &gv, 0);
2630 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2632 SP = PL_stack_base + POPMARK;
2635 if (SvGMAGICAL(sv)) {
2640 sym = SvPVX_const(sv);
2648 sym = SvPV_const(sv, len);
2651 DIE(aTHX_ PL_no_usym, "a subroutine");
2652 if (PL_op->op_private & HINT_STRICT_REFS)
2653 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2654 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2659 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2660 tryAMAGICunDEREF(to_cv);
2663 if (SvTYPE(cv) == SVt_PVCV)
2668 DIE(aTHX_ "Not a CODE reference");
2669 /* This is the second most common case: */
2679 if (!CvROOT(cv) && !CvXSUB(cv)) {
2683 /* anonymous or undef'd function leaves us no recourse */
2684 if (CvANON(cv) || !(gv = CvGV(cv)))
2685 DIE(aTHX_ "Undefined subroutine called");
2687 /* autoloaded stub? */
2688 if (cv != GvCV(gv)) {
2691 /* should call AUTOLOAD now? */
2694 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2701 sub_name = sv_newmortal();
2702 gv_efullname3(sub_name, gv, NULL);
2703 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2707 DIE(aTHX_ "Not a CODE reference");
2712 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2713 if (CvASSERTION(cv) && PL_DBassertion)
2714 sv_setiv(PL_DBassertion, 1);
2716 Perl_get_db_sub(aTHX_ &sv, cv);
2718 PL_curcopdb = PL_curcop;
2719 cv = GvCV(PL_DBsub);
2721 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2722 DIE(aTHX_ "No DB::sub routine defined");
2725 if (!(CvISXSUB(cv))) {
2726 /* This path taken at least 75% of the time */
2728 register I32 items = SP - MARK;
2729 AV* const padlist = CvPADLIST(cv);
2730 PUSHBLOCK(cx, CXt_SUB, MARK);
2732 cx->blk_sub.retop = PL_op->op_next;
2734 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2735 * that eval'' ops within this sub know the correct lexical space.
2736 * Owing the speed considerations, we choose instead to search for
2737 * the cv using find_runcv() when calling doeval().
2739 if (CvDEPTH(cv) >= 2) {
2740 PERL_STACK_OVERFLOW_CHECK();
2741 pad_push(padlist, CvDEPTH(cv));
2744 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2746 AV* const av = (AV*)PAD_SVl(0);
2748 /* @_ is normally not REAL--this should only ever
2749 * happen when DB::sub() calls things that modify @_ */
2754 cx->blk_sub.savearray = GvAV(PL_defgv);
2755 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2756 CX_CURPAD_SAVE(cx->blk_sub);
2757 cx->blk_sub.argarray = av;
2760 if (items > AvMAX(av) + 1) {
2761 SV **ary = AvALLOC(av);
2762 if (AvARRAY(av) != ary) {
2763 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2766 if (items > AvMAX(av) + 1) {
2767 AvMAX(av) = items - 1;
2768 Renew(ary,items,SV*);
2773 Copy(MARK,AvARRAY(av),items,SV*);
2774 AvFILLp(av) = items - 1;
2782 /* warning must come *after* we fully set up the context
2783 * stuff so that __WARN__ handlers can safely dounwind()
2786 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2787 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2788 sub_crush_depth(cv);
2790 DEBUG_S(PerlIO_printf(Perl_debug_log,
2791 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2793 RETURNOP(CvSTART(cv));
2796 I32 markix = TOPMARK;
2801 /* Need to copy @_ to stack. Alternative may be to
2802 * switch stack to @_, and copy return values
2803 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2804 AV * const av = GvAV(PL_defgv);
2805 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2808 /* Mark is at the end of the stack. */
2810 Copy(AvARRAY(av), SP + 1, items, SV*);
2815 /* We assume first XSUB in &DB::sub is the called one. */
2817 SAVEVPTR(PL_curcop);
2818 PL_curcop = PL_curcopdb;
2821 /* Do we need to open block here? XXXX */
2822 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2823 (void)(*CvXSUB(cv))(aTHX_ cv);
2825 /* Enforce some sanity in scalar context. */
2826 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2827 if (markix > PL_stack_sp - PL_stack_base)
2828 *(PL_stack_base + markix) = &PL_sv_undef;
2830 *(PL_stack_base + markix) = *PL_stack_sp;
2831 PL_stack_sp = PL_stack_base + markix;
2839 Perl_sub_crush_depth(pTHX_ CV *cv)
2842 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2844 SV* const tmpstr = sv_newmortal();
2845 gv_efullname3(tmpstr, CvGV(cv), NULL);
2846 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2855 SV* const elemsv = POPs;
2856 IV elem = SvIV(elemsv);
2857 AV* const av = (AV*)POPs;
2858 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2859 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2862 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2863 Perl_warner(aTHX_ packWARN(WARN_MISC),
2864 "Use of reference \"%"SVf"\" as array index",
2867 elem -= CopARYBASE_get(PL_curcop);
2868 if (SvTYPE(av) != SVt_PVAV)
2870 svp = av_fetch(av, elem, lval && !defer);
2872 #ifdef PERL_MALLOC_WRAP
2873 if (SvUOK(elemsv)) {
2874 const UV uv = SvUV(elemsv);
2875 elem = uv > IV_MAX ? IV_MAX : uv;
2877 else if (SvNOK(elemsv))
2878 elem = (IV)SvNV(elemsv);
2880 static const char oom_array_extend[] =
2881 "Out of memory during array extend"; /* Duplicated in av.c */
2882 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2885 if (!svp || *svp == &PL_sv_undef) {
2888 DIE(aTHX_ PL_no_aelem, elem);
2889 lv = sv_newmortal();
2890 sv_upgrade(lv, SVt_PVLV);
2892 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2893 LvTARG(lv) = SvREFCNT_inc_simple(av);
2894 LvTARGOFF(lv) = elem;
2899 if (PL_op->op_private & OPpLVAL_INTRO)
2900 save_aelem(av, elem, svp);
2901 else if (PL_op->op_private & OPpDEREF)
2902 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2904 sv = (svp ? *svp : &PL_sv_undef);
2905 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2906 sv = sv_mortalcopy(sv);
2912 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2917 Perl_croak(aTHX_ PL_no_modify);
2918 if (SvTYPE(sv) < SVt_RV)
2919 sv_upgrade(sv, SVt_RV);
2920 else if (SvTYPE(sv) >= SVt_PV) {
2927 SvRV_set(sv, newSV(0));
2930 SvRV_set(sv, (SV*)newAV());
2933 SvRV_set(sv, (SV*)newHV());
2944 SV* const sv = TOPs;
2947 SV* const rsv = SvRV(sv);
2948 if (SvTYPE(rsv) == SVt_PVCV) {
2954 SETs(method_common(sv, NULL));
2961 SV* const sv = cSVOP_sv;
2962 U32 hash = SvSHARED_HASH(sv);
2964 XPUSHs(method_common(sv, &hash));
2969 S_method_common(pTHX_ SV* meth, U32* hashp)
2976 const char* packname = NULL;
2979 const char * const name = SvPV_const(meth, namelen);
2980 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2983 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2991 /* this isn't a reference */
2992 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2993 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2995 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3002 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3003 !(ob=(SV*)GvIO(iogv)))
3005 /* this isn't the name of a filehandle either */
3007 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3008 ? !isIDFIRST_utf8((U8*)packname)
3009 : !isIDFIRST(*packname)
3012 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3013 SvOK(sv) ? "without a package or object reference"
3014 : "on an undefined value");
3016 /* assume it's a package name */
3017 stash = gv_stashpvn(packname, packlen, 0);
3021 SV* const ref = newSViv(PTR2IV(stash));
3022 hv_store(PL_stashcache, packname, packlen, ref, 0);
3026 /* it _is_ a filehandle name -- replace with a reference */
3027 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3030 /* if we got here, ob should be a reference or a glob */
3031 if (!ob || !(SvOBJECT(ob)
3032 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3035 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3036 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3040 stash = SvSTASH(ob);
3043 /* NOTE: stash may be null, hope hv_fetch_ent and
3044 gv_fetchmethod can cope (it seems they can) */
3046 /* shortcut for simple names */
3048 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3050 gv = (GV*)HeVAL(he);
3051 if (isGV(gv) && GvCV(gv) &&
3052 (!GvCVGEN(gv) || GvCVGEN(gv)
3053 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3054 return (SV*)GvCV(gv);
3058 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3061 /* This code tries to figure out just what went wrong with
3062 gv_fetchmethod. It therefore needs to duplicate a lot of
3063 the internals of that function. We can't move it inside
3064 Perl_gv_fetchmethod_autoload(), however, since that would
3065 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3068 const char* leaf = name;
3069 const char* sep = NULL;
3072 for (p = name; *p; p++) {
3074 sep = p, leaf = p + 1;
3075 else if (*p == ':' && *(p + 1) == ':')
3076 sep = p, leaf = p + 2;
3078 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3079 /* the method name is unqualified or starts with SUPER:: */
3080 bool need_strlen = 1;
3082 packname = CopSTASHPV(PL_curcop);
3085 HEK * const packhek = HvNAME_HEK(stash);
3087 packname = HEK_KEY(packhek);
3088 packlen = HEK_LEN(packhek);
3098 "Can't use anonymous symbol table for method lookup");
3100 else if (need_strlen)
3101 packlen = strlen(packname);
3105 /* the method name is qualified */
3107 packlen = sep - name;
3110 /* we're relying on gv_fetchmethod not autovivifying the stash */
3111 if (gv_stashpvn(packname, packlen, 0)) {
3113 "Can't locate object method \"%s\" via package \"%.*s\"",
3114 leaf, (int)packlen, packname);
3118 "Can't locate object method \"%s\" via package \"%.*s\""
3119 " (perhaps you forgot to load \"%.*s\"?)",
3120 leaf, (int)packlen, packname, (int)packlen, packname);
3123 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3128 * c-indentation-style: bsd
3130 * indent-tabs-mode: t
3133 * ex: set ts=8 sts=4 sw=4 noet: