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));
1126 if (PL_delaymagic & DM_ARRAY && SvMAGICAL((SV*)ary))
1131 if (gimme == G_VOID)
1132 SP = firstrelem - 1;
1133 else if (gimme == G_SCALAR) {
1136 SETi(lastrelem - firstrelem + 1 - duplicates);
1143 /* Removes from the stack the entries which ended up as
1144 * duplicated keys in the hash (fix for [perl #24380]) */
1145 Move(firsthashrelem + duplicates,
1146 firsthashrelem, duplicates, SV**);
1147 lastrelem -= duplicates;
1152 SP = firstrelem + (lastlelem - firstlelem);
1153 lelem = firstlelem + (relem - firstrelem);
1155 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1164 register PMOP * const pm = cPMOP;
1165 REGEXP * rx = PM_GETRE(pm);
1166 SV * const pkg = CALLREG_PACKAGE(rx);
1167 SV * const rv = sv_newmortal();
1168 SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1169 if (rx->extflags & RXf_TAINTED)
1171 sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1179 register PMOP *pm = cPMOP;
1181 register const char *t;
1182 register const char *s;
1185 I32 r_flags = REXEC_CHECKED;
1186 const char *truebase; /* Start of string */
1187 register REGEXP *rx = PM_GETRE(pm);
1189 const I32 gimme = GIMME;
1192 const I32 oldsave = PL_savestack_ix;
1193 I32 update_minmatch = 1;
1194 I32 had_zerolen = 0;
1197 if (PL_op->op_flags & OPf_STACKED)
1199 else if (PL_op->op_private & OPpTARGET_MY)
1206 PUTBACK; /* EVAL blocks need stack_sp. */
1207 s = SvPV_const(TARG, len);
1209 DIE(aTHX_ "panic: pp_match");
1211 rxtainted = ((rx->extflags & RXf_TAINTED) ||
1212 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1215 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1217 /* PMdf_USED is set after a ?? matches once */
1220 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1222 pm->op_pmflags & PMf_USED
1226 if (gimme == G_ARRAY)
1233 /* empty pattern special-cased to use last successful pattern if possible */
1234 if (!rx->prelen && PL_curpm) {
1239 if (rx->minlen > (I32)len)
1244 /* XXXX What part of this is needed with true \G-support? */
1245 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1246 rx->offs[0].start = -1;
1247 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1248 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1249 if (mg && mg->mg_len >= 0) {
1250 if (!(rx->extflags & RXf_GPOS_SEEN))
1251 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1252 else if (rx->extflags & RXf_ANCH_GPOS) {
1253 r_flags |= REXEC_IGNOREPOS;
1254 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1255 } else if (rx->extflags & RXf_GPOS_FLOAT)
1258 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1259 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1260 update_minmatch = 0;
1264 /* XXX: comment out !global get safe $1 vars after a
1265 match, BUT be aware that this leads to dramatic slowdowns on
1266 /g matches against large strings. So far a solution to this problem
1267 appears to be quite tricky.
1268 Test for the unsafe vars are TODO for now. */
1269 if (( !global && rx->nparens)
1270 || SvTEMP(TARG) || PL_sawampersand ||
1271 (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1272 r_flags |= REXEC_COPY_STR;
1274 r_flags |= REXEC_SCREAM;
1277 if (global && rx->offs[0].start != -1) {
1278 t = s = rx->offs[0].end + truebase - rx->gofs;
1279 if ((s + rx->minlen) > strend || s < truebase)
1281 if (update_minmatch++)
1282 minmatch = had_zerolen;
1284 if (rx->extflags & RXf_USE_INTUIT &&
1285 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1286 /* FIXME - can PL_bostr be made const char *? */
1287 PL_bostr = (char *)truebase;
1288 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1292 if ( (rx->extflags & RXf_CHECK_ALL)
1294 && !(rx->extflags & RXf_PMf_KEEPCOPY)
1295 && ((rx->extflags & RXf_NOSCAN)
1296 || !((rx->extflags & RXf_INTUIT_TAIL)
1297 && (r_flags & REXEC_SCREAM)))
1298 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1301 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1304 if (dynpm->op_pmflags & PMf_ONCE) {
1306 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1308 dynpm->op_pmflags |= PMf_USED;
1319 RX_MATCH_TAINTED_on(rx);
1320 TAINT_IF(RX_MATCH_TAINTED(rx));
1321 if (gimme == G_ARRAY) {
1322 const I32 nparens = rx->nparens;
1323 I32 i = (global && !nparens) ? 1 : 0;
1325 SPAGAIN; /* EVAL blocks could move the stack. */
1326 EXTEND(SP, nparens + i);
1327 EXTEND_MORTAL(nparens + i);
1328 for (i = !i; i <= nparens; i++) {
1329 PUSHs(sv_newmortal());
1330 if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1331 const I32 len = rx->offs[i].end - rx->offs[i].start;
1332 s = rx->offs[i].start + truebase;
1333 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1334 len < 0 || len > strend - s)
1335 DIE(aTHX_ "panic: pp_match start/end pointers");
1336 sv_setpvn(*SP, s, len);
1337 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1342 if (dynpm->op_pmflags & PMf_CONTINUE) {
1344 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1345 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1347 #ifdef PERL_OLD_COPY_ON_WRITE
1349 sv_force_normal_flags(TARG, 0);
1351 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1352 &PL_vtbl_mglob, NULL, 0);
1354 if (rx->offs[0].start != -1) {
1355 mg->mg_len = rx->offs[0].end;
1356 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1357 mg->mg_flags |= MGf_MINMATCH;
1359 mg->mg_flags &= ~MGf_MINMATCH;
1362 had_zerolen = (rx->offs[0].start != -1
1363 && (rx->offs[0].start + rx->gofs
1364 == (UV)rx->offs[0].end));
1365 PUTBACK; /* EVAL blocks may use stack */
1366 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1371 LEAVE_SCOPE(oldsave);
1377 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1378 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1382 #ifdef PERL_OLD_COPY_ON_WRITE
1384 sv_force_normal_flags(TARG, 0);
1386 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1387 &PL_vtbl_mglob, NULL, 0);
1389 if (rx->offs[0].start != -1) {
1390 mg->mg_len = rx->offs[0].end;
1391 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1392 mg->mg_flags |= MGf_MINMATCH;
1394 mg->mg_flags &= ~MGf_MINMATCH;
1397 LEAVE_SCOPE(oldsave);
1401 yup: /* Confirmed by INTUIT */
1403 RX_MATCH_TAINTED_on(rx);
1404 TAINT_IF(RX_MATCH_TAINTED(rx));
1406 if (dynpm->op_pmflags & PMf_ONCE) {
1408 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1410 dynpm->op_pmflags |= PMf_USED;
1413 if (RX_MATCH_COPIED(rx))
1414 Safefree(rx->subbeg);
1415 RX_MATCH_COPIED_off(rx);
1418 /* FIXME - should rx->subbeg be const char *? */
1419 rx->subbeg = (char *) truebase;
1420 rx->offs[0].start = s - truebase;
1421 if (RX_MATCH_UTF8(rx)) {
1422 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1423 rx->offs[0].end = t - truebase;
1426 rx->offs[0].end = s - truebase + rx->minlenret;
1428 rx->sublen = strend - truebase;
1431 if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1433 #ifdef PERL_OLD_COPY_ON_WRITE
1434 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1436 PerlIO_printf(Perl_debug_log,
1437 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1438 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1441 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1442 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1443 assert (SvPOKp(rx->saved_copy));
1448 rx->subbeg = savepvn(t, strend - t);
1449 #ifdef PERL_OLD_COPY_ON_WRITE
1450 rx->saved_copy = NULL;
1453 rx->sublen = strend - t;
1454 RX_MATCH_COPIED_on(rx);
1455 off = rx->offs[0].start = s - t;
1456 rx->offs[0].end = off + rx->minlenret;
1458 else { /* startp/endp are used by @- @+. */
1459 rx->offs[0].start = s - truebase;
1460 rx->offs[0].end = s - truebase + rx->minlenret;
1462 /* including rx->nparens in the below code seems highly suspicious.
1464 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1465 LEAVE_SCOPE(oldsave);
1470 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1471 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1472 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1477 LEAVE_SCOPE(oldsave);
1478 if (gimme == G_ARRAY)
1484 Perl_do_readline(pTHX)
1486 dVAR; dSP; dTARGETSTACKED;
1491 register IO * const io = GvIO(PL_last_in_gv);
1492 register const I32 type = PL_op->op_type;
1493 const I32 gimme = GIMME_V;
1496 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1499 XPUSHs(SvTIED_obj((SV*)io, mg));
1502 call_method("READLINE", gimme);
1505 if (gimme == G_SCALAR) {
1506 SV* const result = POPs;
1507 SvSetSV_nosteal(TARG, result);
1517 if (IoFLAGS(io) & IOf_ARGV) {
1518 if (IoFLAGS(io) & IOf_START) {
1520 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1521 IoFLAGS(io) &= ~IOf_START;
1522 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1523 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1524 SvSETMAGIC(GvSV(PL_last_in_gv));
1529 fp = nextargv(PL_last_in_gv);
1530 if (!fp) { /* Note: fp != IoIFP(io) */
1531 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1534 else if (type == OP_GLOB)
1535 fp = Perl_start_glob(aTHX_ POPs, io);
1537 else if (type == OP_GLOB)
1539 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1540 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1544 if ((!io || !(IoFLAGS(io) & IOf_START))
1545 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1547 if (type == OP_GLOB)
1548 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1549 "glob failed (can't start child: %s)",
1552 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1554 if (gimme == G_SCALAR) {
1555 /* undef TARG, and push that undefined value */
1556 if (type != OP_RCATLINE) {
1557 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1565 if (gimme == G_SCALAR) {
1567 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1570 if (type == OP_RCATLINE)
1571 SvPV_force_nolen(sv);
1575 else if (isGV_with_GP(sv)) {
1576 SvPV_force_nolen(sv);
1578 SvUPGRADE(sv, SVt_PV);
1579 tmplen = SvLEN(sv); /* remember if already alloced */
1580 if (!tmplen && !SvREADONLY(sv))
1581 Sv_Grow(sv, 80); /* try short-buffering it */
1583 if (type == OP_RCATLINE && SvOK(sv)) {
1585 SvPV_force_nolen(sv);
1591 sv = sv_2mortal(newSV(80));
1595 /* This should not be marked tainted if the fp is marked clean */
1596 #define MAYBE_TAINT_LINE(io, sv) \
1597 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1602 /* delay EOF state for a snarfed empty file */
1603 #define SNARF_EOF(gimme,rs,io,sv) \
1604 (gimme != G_SCALAR || SvCUR(sv) \
1605 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1609 if (!sv_gets(sv, fp, offset)
1611 || SNARF_EOF(gimme, PL_rs, io, sv)
1612 || PerlIO_error(fp)))
1614 PerlIO_clearerr(fp);
1615 if (IoFLAGS(io) & IOf_ARGV) {
1616 fp = nextargv(PL_last_in_gv);
1619 (void)do_close(PL_last_in_gv, FALSE);
1621 else if (type == OP_GLOB) {
1622 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1623 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1624 "glob failed (child exited with status %d%s)",
1625 (int)(STATUS_CURRENT >> 8),
1626 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1629 if (gimme == G_SCALAR) {
1630 if (type != OP_RCATLINE) {
1631 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1637 MAYBE_TAINT_LINE(io, sv);
1640 MAYBE_TAINT_LINE(io, sv);
1642 IoFLAGS(io) |= IOf_NOLINE;
1646 if (type == OP_GLOB) {
1649 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1650 char * const tmps = SvEND(sv) - 1;
1651 if (*tmps == *SvPVX_const(PL_rs)) {
1653 SvCUR_set(sv, SvCUR(sv) - 1);
1656 for (t1 = SvPVX_const(sv); *t1; t1++)
1657 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1658 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1660 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1661 (void)POPs; /* Unmatched wildcard? Chuck it... */
1664 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1665 if (ckWARN(WARN_UTF8)) {
1666 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1667 const STRLEN len = SvCUR(sv) - offset;
1670 if (!is_utf8_string_loc(s, len, &f))
1671 /* Emulate :encoding(utf8) warning in the same case. */
1672 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1673 "utf8 \"\\x%02X\" does not map to Unicode",
1674 f < (U8*)SvEND(sv) ? *f : 0);
1677 if (gimme == G_ARRAY) {
1678 if (SvLEN(sv) - SvCUR(sv) > 20) {
1679 SvPV_shrink_to_cur(sv);
1681 sv = sv_2mortal(newSV(80));
1684 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1685 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1686 const STRLEN new_len
1687 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1688 SvPV_renew(sv, new_len);
1697 register PERL_CONTEXT *cx;
1698 I32 gimme = OP_GIMME(PL_op, -1);
1701 if (cxstack_ix >= 0)
1702 gimme = cxstack[cxstack_ix].blk_gimme;
1710 PUSHBLOCK(cx, CXt_BLOCK, SP);
1720 SV * const keysv = POPs;
1721 HV * const hv = (HV*)POPs;
1722 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1723 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1725 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1728 if (SvTYPE(hv) != SVt_PVHV)
1731 if (PL_op->op_private & OPpLVAL_INTRO) {
1734 /* does the element we're localizing already exist? */
1735 preeminent = /* can we determine whether it exists? */
1737 || mg_find((SV*)hv, PERL_MAGIC_env)
1738 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1739 /* Try to preserve the existenceness of a tied hash
1740 * element by using EXISTS and DELETE if possible.
1741 * Fallback to FETCH and STORE otherwise */
1742 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1743 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1744 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1746 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1748 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1749 svp = he ? &HeVAL(he) : NULL;
1751 if (!svp || *svp == &PL_sv_undef) {
1755 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1757 lv = sv_newmortal();
1758 sv_upgrade(lv, SVt_PVLV);
1760 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1761 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1762 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1767 if (PL_op->op_private & OPpLVAL_INTRO) {
1768 if (HvNAME_get(hv) && isGV(*svp))
1769 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1773 const char * const key = SvPV_const(keysv, keylen);
1774 SAVEDELETE(hv, savepvn(key,keylen),
1775 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1777 save_helem(hv, keysv, svp);
1780 else if (PL_op->op_private & OPpDEREF)
1781 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1783 sv = (svp ? *svp : &PL_sv_undef);
1784 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1785 * Pushing the magical RHS on to the stack is useless, since
1786 * that magic is soon destined to be misled by the local(),
1787 * and thus the later pp_sassign() will fail to mg_get() the
1788 * old value. This should also cure problems with delayed
1789 * mg_get()s. GSAR 98-07-03 */
1790 if (!lval && SvGMAGICAL(sv))
1791 sv = sv_mortalcopy(sv);
1799 register PERL_CONTEXT *cx;
1804 if (PL_op->op_flags & OPf_SPECIAL) {
1805 cx = &cxstack[cxstack_ix];
1806 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1811 gimme = OP_GIMME(PL_op, -1);
1813 if (cxstack_ix >= 0)
1814 gimme = cxstack[cxstack_ix].blk_gimme;
1820 if (gimme == G_VOID)
1822 else if (gimme == G_SCALAR) {
1826 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1829 *MARK = sv_mortalcopy(TOPs);
1832 *MARK = &PL_sv_undef;
1836 else if (gimme == G_ARRAY) {
1837 /* in case LEAVE wipes old return values */
1839 for (mark = newsp + 1; mark <= SP; mark++) {
1840 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1841 *mark = sv_mortalcopy(*mark);
1842 TAINT_NOT; /* Each item is independent */
1846 PL_curpm = newpm; /* Don't pop $1 et al till now */
1856 register PERL_CONTEXT *cx;
1862 cx = &cxstack[cxstack_ix];
1863 if (CxTYPE(cx) != CXt_LOOP)
1864 DIE(aTHX_ "panic: pp_iter");
1866 itersvp = CxITERVAR(cx);
1867 av = cx->blk_loop.iterary;
1868 if (SvTYPE(av) != SVt_PVAV) {
1869 /* iterate ($min .. $max) */
1870 if (cx->blk_loop.iterlval) {
1871 /* string increment */
1872 register SV* cur = cx->blk_loop.iterlval;
1876 SvPV_const((SV*)av, maxlen) : (const char *)"";
1877 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1878 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1879 /* safe to reuse old SV */
1880 sv_setsv(*itersvp, cur);
1884 /* we need a fresh SV every time so that loop body sees a
1885 * completely new SV for closures/references to work as
1888 *itersvp = newSVsv(cur);
1889 SvREFCNT_dec(oldsv);
1891 if (strEQ(SvPVX_const(cur), max))
1892 sv_setiv(cur, 0); /* terminate next time */
1899 /* integer increment */
1900 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1903 /* don't risk potential race */
1904 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1905 /* safe to reuse old SV */
1906 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1910 /* we need a fresh SV every time so that loop body sees a
1911 * completely new SV for closures/references to work as they
1914 *itersvp = newSViv(cx->blk_loop.iterix++);
1915 SvREFCNT_dec(oldsv);
1921 if (PL_op->op_private & OPpITER_REVERSED) {
1922 /* In reverse, use itermax as the min :-) */
1923 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1926 if (SvMAGICAL(av) || AvREIFY(av)) {
1927 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1928 sv = svp ? *svp : NULL;
1931 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1935 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1939 if (SvMAGICAL(av) || AvREIFY(av)) {
1940 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1941 sv = svp ? *svp : NULL;
1944 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1948 if (sv && SvIS_FREED(sv)) {
1950 Perl_croak(aTHX_ "Use of freed value in iteration");
1957 if (av != PL_curstack && sv == &PL_sv_undef) {
1958 SV *lv = cx->blk_loop.iterlval;
1959 if (lv && SvREFCNT(lv) > 1) {
1964 SvREFCNT_dec(LvTARG(lv));
1966 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1968 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1970 LvTARG(lv) = SvREFCNT_inc_simple(av);
1971 LvTARGOFF(lv) = cx->blk_loop.iterix;
1972 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1977 *itersvp = SvREFCNT_inc_simple_NN(sv);
1978 SvREFCNT_dec(oldsv);
1986 register PMOP *pm = cPMOP;
2001 register REGEXP *rx = PM_GETRE(pm);
2003 int force_on_match = 0;
2004 const I32 oldsave = PL_savestack_ix;
2006 bool doutf8 = FALSE;
2007 #ifdef PERL_OLD_COPY_ON_WRITE
2012 /* known replacement string? */
2013 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2014 if (PL_op->op_flags & OPf_STACKED)
2016 else if (PL_op->op_private & OPpTARGET_MY)
2023 #ifdef PERL_OLD_COPY_ON_WRITE
2024 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2025 because they make integers such as 256 "false". */
2026 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2029 sv_force_normal_flags(TARG,0);
2032 #ifdef PERL_OLD_COPY_ON_WRITE
2036 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2037 || SvTYPE(TARG) > SVt_PVLV)
2038 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2039 DIE(aTHX_ PL_no_modify);
2042 s = SvPV_mutable(TARG, len);
2043 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2045 rxtainted = ((rx->extflags & RXf_TAINTED) ||
2046 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2051 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2055 DIE(aTHX_ "panic: pp_subst");
2058 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2059 maxiters = 2 * slen + 10; /* We can match twice at each
2060 position, once with zero-length,
2061 second time with non-zero. */
2063 if (!rx->prelen && PL_curpm) {
2067 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2068 || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2069 ? REXEC_COPY_STR : 0;
2071 r_flags |= REXEC_SCREAM;
2074 if (rx->extflags & RXf_USE_INTUIT) {
2076 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2080 /* How to do it in subst? */
2081 /* if ( (rx->extflags & RXf_CHECK_ALL)
2083 && !(rx->extflags & RXf_KEEPCOPY)
2084 && ((rx->extflags & RXf_NOSCAN)
2085 || !((rx->extflags & RXf_INTUIT_TAIL)
2086 && (r_flags & REXEC_SCREAM))))
2091 /* only replace once? */
2092 once = !(rpm->op_pmflags & PMf_GLOBAL);
2094 /* known replacement string? */
2096 /* replacement needing upgrading? */
2097 if (DO_UTF8(TARG) && !doutf8) {
2098 nsv = sv_newmortal();
2101 sv_recode_to_utf8(nsv, PL_encoding);
2103 sv_utf8_upgrade(nsv);
2104 c = SvPV_const(nsv, clen);
2108 c = SvPV_const(dstr, clen);
2109 doutf8 = DO_UTF8(dstr);
2117 /* can do inplace substitution? */
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2122 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2123 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2124 && (!doutf8 || SvUTF8(TARG))) {
2125 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2126 r_flags | REXEC_CHECKED))
2130 LEAVE_SCOPE(oldsave);
2133 #ifdef PERL_OLD_COPY_ON_WRITE
2134 if (SvIsCOW(TARG)) {
2135 assert (!force_on_match);
2139 if (force_on_match) {
2141 s = SvPV_force(TARG, len);
2146 SvSCREAM_off(TARG); /* disable possible screamer */
2148 rxtainted |= RX_MATCH_TAINTED(rx);
2149 m = orig + rx->offs[0].start;
2150 d = orig + rx->offs[0].end;
2152 if (m - s > strend - d) { /* faster to shorten from end */
2154 Copy(c, m, clen, char);
2159 Move(d, m, i, char);
2163 SvCUR_set(TARG, m - s);
2165 else if ((i = m - s)) { /* faster from front */
2173 Copy(c, m, clen, char);
2178 Copy(c, d, clen, char);
2183 TAINT_IF(rxtainted & 1);
2189 if (iters++ > maxiters)
2190 DIE(aTHX_ "Substitution loop");
2191 rxtainted |= RX_MATCH_TAINTED(rx);
2192 m = rx->offs[0].start + orig;
2195 Move(s, d, i, char);
2199 Copy(c, d, clen, char);
2202 s = rx->offs[0].end + orig;
2203 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2205 /* don't match same null twice */
2206 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2209 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2210 Move(s, d, i+1, char); /* include the NUL */
2212 TAINT_IF(rxtainted & 1);
2214 PUSHs(sv_2mortal(newSViv((I32)iters)));
2216 (void)SvPOK_only_UTF8(TARG);
2217 TAINT_IF(rxtainted);
2218 if (SvSMAGICAL(TARG)) {
2226 LEAVE_SCOPE(oldsave);
2230 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2231 r_flags | REXEC_CHECKED))
2233 if (force_on_match) {
2235 s = SvPV_force(TARG, len);
2238 #ifdef PERL_OLD_COPY_ON_WRITE
2241 rxtainted |= RX_MATCH_TAINTED(rx);
2242 dstr = newSVpvn(m, s-m);
2248 register PERL_CONTEXT *cx;
2251 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2253 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2255 if (iters++ > maxiters)
2256 DIE(aTHX_ "Substitution loop");
2257 rxtainted |= RX_MATCH_TAINTED(rx);
2258 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2263 strend = s + (strend - m);
2265 m = rx->offs[0].start + orig;
2266 if (doutf8 && !SvUTF8(dstr))
2267 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2269 sv_catpvn(dstr, s, m-s);
2270 s = rx->offs[0].end + orig;
2272 sv_catpvn(dstr, c, clen);
2275 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2276 TARG, NULL, r_flags));
2277 if (doutf8 && !DO_UTF8(TARG))
2278 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2280 sv_catpvn(dstr, s, strend - s);
2282 #ifdef PERL_OLD_COPY_ON_WRITE
2283 /* The match may make the string COW. If so, brilliant, because that's
2284 just saved us one malloc, copy and free - the regexp has donated
2285 the old buffer, and we malloc an entirely new one, rather than the
2286 regexp malloc()ing a buffer and copying our original, only for
2287 us to throw it away here during the substitution. */
2288 if (SvIsCOW(TARG)) {
2289 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2295 SvPV_set(TARG, SvPVX(dstr));
2296 SvCUR_set(TARG, SvCUR(dstr));
2297 SvLEN_set(TARG, SvLEN(dstr));
2298 doutf8 |= DO_UTF8(dstr);
2299 SvPV_set(dstr, NULL);
2301 TAINT_IF(rxtainted & 1);
2303 PUSHs(sv_2mortal(newSViv((I32)iters)));
2305 (void)SvPOK_only(TARG);
2308 TAINT_IF(rxtainted);
2311 LEAVE_SCOPE(oldsave);
2320 LEAVE_SCOPE(oldsave);
2329 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2330 ++*PL_markstack_ptr;
2331 LEAVE; /* exit inner scope */
2334 if (PL_stack_base + *PL_markstack_ptr > SP) {
2336 const I32 gimme = GIMME_V;
2338 LEAVE; /* exit outer scope */
2339 (void)POPMARK; /* pop src */
2340 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2341 (void)POPMARK; /* pop dst */
2342 SP = PL_stack_base + POPMARK; /* pop original mark */
2343 if (gimme == G_SCALAR) {
2344 if (PL_op->op_private & OPpGREP_LEX) {
2345 SV* const sv = sv_newmortal();
2346 sv_setiv(sv, items);
2354 else if (gimme == G_ARRAY)
2361 ENTER; /* enter inner scope */
2364 src = PL_stack_base[*PL_markstack_ptr];
2366 if (PL_op->op_private & OPpGREP_LEX)
2367 PAD_SVl(PL_op->op_targ) = src;
2371 RETURNOP(cLOGOP->op_other);
2382 register PERL_CONTEXT *cx;
2385 if (CxMULTICALL(&cxstack[cxstack_ix]))
2389 cxstack_ix++; /* temporarily protect top context */
2392 if (gimme == G_SCALAR) {
2395 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2397 *MARK = SvREFCNT_inc(TOPs);
2402 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2404 *MARK = sv_mortalcopy(sv);
2409 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2413 *MARK = &PL_sv_undef;
2417 else if (gimme == G_ARRAY) {
2418 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2419 if (!SvTEMP(*MARK)) {
2420 *MARK = sv_mortalcopy(*MARK);
2421 TAINT_NOT; /* Each item is independent */
2429 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2430 PL_curpm = newpm; /* ... and pop $1 et al */
2433 return cx->blk_sub.retop;
2436 /* This duplicates the above code because the above code must not
2437 * get any slower by more conditions */
2445 register PERL_CONTEXT *cx;
2448 if (CxMULTICALL(&cxstack[cxstack_ix]))
2452 cxstack_ix++; /* temporarily protect top context */
2456 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2457 /* We are an argument to a function or grep().
2458 * This kind of lvalueness was legal before lvalue
2459 * subroutines too, so be backward compatible:
2460 * cannot report errors. */
2462 /* Scalar context *is* possible, on the LHS of -> only,
2463 * as in f()->meth(). But this is not an lvalue. */
2464 if (gimme == G_SCALAR)
2466 if (gimme == G_ARRAY) {
2467 if (!CvLVALUE(cx->blk_sub.cv))
2468 goto temporise_array;
2469 EXTEND_MORTAL(SP - newsp);
2470 for (mark = newsp + 1; mark <= SP; mark++) {
2473 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2474 *mark = sv_mortalcopy(*mark);
2476 /* Can be a localized value subject to deletion. */
2477 PL_tmps_stack[++PL_tmps_ix] = *mark;
2478 SvREFCNT_inc_void(*mark);
2483 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2484 /* Here we go for robustness, not for speed, so we change all
2485 * the refcounts so the caller gets a live guy. Cannot set
2486 * TEMP, so sv_2mortal is out of question. */
2487 if (!CvLVALUE(cx->blk_sub.cv)) {
2493 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2495 if (gimme == G_SCALAR) {
2499 /* Temporaries are bad unless they happen to be elements
2500 * of a tied hash or array */
2501 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2502 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2508 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2509 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2510 : "a readonly value" : "a temporary");
2512 else { /* Can be a localized value
2513 * subject to deletion. */
2514 PL_tmps_stack[++PL_tmps_ix] = *mark;
2515 SvREFCNT_inc_void(*mark);
2518 else { /* Should not happen? */
2524 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2525 (MARK > SP ? "Empty array" : "Array"));
2529 else if (gimme == G_ARRAY) {
2530 EXTEND_MORTAL(SP - newsp);
2531 for (mark = newsp + 1; mark <= SP; mark++) {
2532 if (*mark != &PL_sv_undef
2533 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2534 /* Might be flattened array after $#array = */
2541 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2542 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2545 /* Can be a localized value subject to deletion. */
2546 PL_tmps_stack[++PL_tmps_ix] = *mark;
2547 SvREFCNT_inc_void(*mark);
2553 if (gimme == G_SCALAR) {
2557 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2559 *MARK = SvREFCNT_inc(TOPs);
2564 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2566 *MARK = sv_mortalcopy(sv);
2571 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2575 *MARK = &PL_sv_undef;
2579 else if (gimme == G_ARRAY) {
2581 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2582 if (!SvTEMP(*MARK)) {
2583 *MARK = sv_mortalcopy(*MARK);
2584 TAINT_NOT; /* Each item is independent */
2593 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2594 PL_curpm = newpm; /* ... and pop $1 et al */
2597 return cx->blk_sub.retop;
2605 register PERL_CONTEXT *cx;
2607 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2610 DIE(aTHX_ "Not a CODE reference");
2611 switch (SvTYPE(sv)) {
2612 /* This is overwhelming the most common case: */
2614 if (!(cv = GvCVu((GV*)sv))) {
2616 cv = sv_2cv(sv, &stash, &gv, 0);
2628 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2630 SP = PL_stack_base + POPMARK;
2633 if (SvGMAGICAL(sv)) {
2638 sym = SvPVX_const(sv);
2646 sym = SvPV_const(sv, len);
2649 DIE(aTHX_ PL_no_usym, "a subroutine");
2650 if (PL_op->op_private & HINT_STRICT_REFS)
2651 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2652 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2657 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2658 tryAMAGICunDEREF(to_cv);
2661 if (SvTYPE(cv) == SVt_PVCV)
2666 DIE(aTHX_ "Not a CODE reference");
2667 /* This is the second most common case: */
2677 if (!CvROOT(cv) && !CvXSUB(cv)) {
2681 /* anonymous or undef'd function leaves us no recourse */
2682 if (CvANON(cv) || !(gv = CvGV(cv)))
2683 DIE(aTHX_ "Undefined subroutine called");
2685 /* autoloaded stub? */
2686 if (cv != GvCV(gv)) {
2689 /* should call AUTOLOAD now? */
2692 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2699 sub_name = sv_newmortal();
2700 gv_efullname3(sub_name, gv, NULL);
2701 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2705 DIE(aTHX_ "Not a CODE reference");
2710 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2711 Perl_get_db_sub(aTHX_ &sv, cv);
2713 PL_curcopdb = PL_curcop;
2714 cv = GvCV(PL_DBsub);
2716 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2717 DIE(aTHX_ "No DB::sub routine defined");
2720 if (!(CvISXSUB(cv))) {
2721 /* This path taken at least 75% of the time */
2723 register I32 items = SP - MARK;
2724 AV* const padlist = CvPADLIST(cv);
2725 PUSHBLOCK(cx, CXt_SUB, MARK);
2727 cx->blk_sub.retop = PL_op->op_next;
2729 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2730 * that eval'' ops within this sub know the correct lexical space.
2731 * Owing the speed considerations, we choose instead to search for
2732 * the cv using find_runcv() when calling doeval().
2734 if (CvDEPTH(cv) >= 2) {
2735 PERL_STACK_OVERFLOW_CHECK();
2736 pad_push(padlist, CvDEPTH(cv));
2739 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2741 AV* const av = (AV*)PAD_SVl(0);
2743 /* @_ is normally not REAL--this should only ever
2744 * happen when DB::sub() calls things that modify @_ */
2749 cx->blk_sub.savearray = GvAV(PL_defgv);
2750 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2751 CX_CURPAD_SAVE(cx->blk_sub);
2752 cx->blk_sub.argarray = av;
2755 if (items > AvMAX(av) + 1) {
2756 SV **ary = AvALLOC(av);
2757 if (AvARRAY(av) != ary) {
2758 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2761 if (items > AvMAX(av) + 1) {
2762 AvMAX(av) = items - 1;
2763 Renew(ary,items,SV*);
2768 Copy(MARK,AvARRAY(av),items,SV*);
2769 AvFILLp(av) = items - 1;
2777 /* warning must come *after* we fully set up the context
2778 * stuff so that __WARN__ handlers can safely dounwind()
2781 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2782 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2783 sub_crush_depth(cv);
2785 DEBUG_S(PerlIO_printf(Perl_debug_log,
2786 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2788 RETURNOP(CvSTART(cv));
2791 I32 markix = TOPMARK;
2796 /* Need to copy @_ to stack. Alternative may be to
2797 * switch stack to @_, and copy return values
2798 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2799 AV * const av = GvAV(PL_defgv);
2800 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2803 /* Mark is at the end of the stack. */
2805 Copy(AvARRAY(av), SP + 1, items, SV*);
2810 /* We assume first XSUB in &DB::sub is the called one. */
2812 SAVEVPTR(PL_curcop);
2813 PL_curcop = PL_curcopdb;
2816 /* Do we need to open block here? XXXX */
2817 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2818 (void)(*CvXSUB(cv))(aTHX_ cv);
2820 /* Enforce some sanity in scalar context. */
2821 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2822 if (markix > PL_stack_sp - PL_stack_base)
2823 *(PL_stack_base + markix) = &PL_sv_undef;
2825 *(PL_stack_base + markix) = *PL_stack_sp;
2826 PL_stack_sp = PL_stack_base + markix;
2834 Perl_sub_crush_depth(pTHX_ CV *cv)
2837 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2839 SV* const tmpstr = sv_newmortal();
2840 gv_efullname3(tmpstr, CvGV(cv), NULL);
2841 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2850 SV* const elemsv = POPs;
2851 IV elem = SvIV(elemsv);
2852 AV* const av = (AV*)POPs;
2853 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2854 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2857 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2858 Perl_warner(aTHX_ packWARN(WARN_MISC),
2859 "Use of reference \"%"SVf"\" as array index",
2862 elem -= CopARYBASE_get(PL_curcop);
2863 if (SvTYPE(av) != SVt_PVAV)
2865 svp = av_fetch(av, elem, lval && !defer);
2867 #ifdef PERL_MALLOC_WRAP
2868 if (SvUOK(elemsv)) {
2869 const UV uv = SvUV(elemsv);
2870 elem = uv > IV_MAX ? IV_MAX : uv;
2872 else if (SvNOK(elemsv))
2873 elem = (IV)SvNV(elemsv);
2875 static const char oom_array_extend[] =
2876 "Out of memory during array extend"; /* Duplicated in av.c */
2877 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2880 if (!svp || *svp == &PL_sv_undef) {
2883 DIE(aTHX_ PL_no_aelem, elem);
2884 lv = sv_newmortal();
2885 sv_upgrade(lv, SVt_PVLV);
2887 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2888 LvTARG(lv) = SvREFCNT_inc_simple(av);
2889 LvTARGOFF(lv) = elem;
2894 if (PL_op->op_private & OPpLVAL_INTRO)
2895 save_aelem(av, elem, svp);
2896 else if (PL_op->op_private & OPpDEREF)
2897 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2899 sv = (svp ? *svp : &PL_sv_undef);
2900 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2901 sv = sv_mortalcopy(sv);
2907 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2912 Perl_croak(aTHX_ PL_no_modify);
2913 if (SvTYPE(sv) < SVt_RV)
2914 sv_upgrade(sv, SVt_RV);
2915 else if (SvTYPE(sv) >= SVt_PV) {
2922 SvRV_set(sv, newSV(0));
2925 SvRV_set(sv, (SV*)newAV());
2928 SvRV_set(sv, (SV*)newHV());
2939 SV* const sv = TOPs;
2942 SV* const rsv = SvRV(sv);
2943 if (SvTYPE(rsv) == SVt_PVCV) {
2949 SETs(method_common(sv, NULL));
2956 SV* const sv = cSVOP_sv;
2957 U32 hash = SvSHARED_HASH(sv);
2959 XPUSHs(method_common(sv, &hash));
2964 S_method_common(pTHX_ SV* meth, U32* hashp)
2971 const char* packname = NULL;
2974 const char * const name = SvPV_const(meth, namelen);
2975 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2978 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2986 /* this isn't a reference */
2987 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2988 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2990 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2997 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2998 !(ob=(SV*)GvIO(iogv)))
3000 /* this isn't the name of a filehandle either */
3002 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3003 ? !isIDFIRST_utf8((U8*)packname)
3004 : !isIDFIRST(*packname)
3007 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3008 SvOK(sv) ? "without a package or object reference"
3009 : "on an undefined value");
3011 /* assume it's a package name */
3012 stash = gv_stashpvn(packname, packlen, 0);
3016 SV* const ref = newSViv(PTR2IV(stash));
3017 hv_store(PL_stashcache, packname, packlen, ref, 0);
3021 /* it _is_ a filehandle name -- replace with a reference */
3022 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3025 /* if we got here, ob should be a reference or a glob */
3026 if (!ob || !(SvOBJECT(ob)
3027 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3030 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3031 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3035 stash = SvSTASH(ob);
3038 /* NOTE: stash may be null, hope hv_fetch_ent and
3039 gv_fetchmethod can cope (it seems they can) */
3041 /* shortcut for simple names */
3043 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3045 gv = (GV*)HeVAL(he);
3046 if (isGV(gv) && GvCV(gv) &&
3047 (!GvCVGEN(gv) || GvCVGEN(gv)
3048 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3049 return (SV*)GvCV(gv);
3053 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3056 /* This code tries to figure out just what went wrong with
3057 gv_fetchmethod. It therefore needs to duplicate a lot of
3058 the internals of that function. We can't move it inside
3059 Perl_gv_fetchmethod_autoload(), however, since that would
3060 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3063 const char* leaf = name;
3064 const char* sep = NULL;
3067 for (p = name; *p; p++) {
3069 sep = p, leaf = p + 1;
3070 else if (*p == ':' && *(p + 1) == ':')
3071 sep = p, leaf = p + 2;
3073 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3074 /* the method name is unqualified or starts with SUPER:: */
3075 bool need_strlen = 1;
3077 packname = CopSTASHPV(PL_curcop);
3080 HEK * const packhek = HvNAME_HEK(stash);
3082 packname = HEK_KEY(packhek);
3083 packlen = HEK_LEN(packhek);
3093 "Can't use anonymous symbol table for method lookup");
3095 else if (need_strlen)
3096 packlen = strlen(packname);
3100 /* the method name is qualified */
3102 packlen = sep - name;
3105 /* we're relying on gv_fetchmethod not autovivifying the stash */
3106 if (gv_stashpvn(packname, packlen, 0)) {
3108 "Can't locate object method \"%s\" via package \"%.*s\"",
3109 leaf, (int)packlen, packname);
3113 "Can't locate object method \"%s\" via package \"%.*s\""
3114 " (perhaps you forgot to load \"%.*s\"?)",
3115 leaf, (int)packlen, packname, (int)packlen, packname);
3118 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3123 * c-indentation-style: bsd
3125 * indent-tabs-mode: t
3128 * ex: set ts=8 sts=4 sw=4 noet: