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);
1008 if (PL_delaymagic & DM_ARRAY)
1009 SvSETMAGIC((SV*)ary);
1011 case SVt_PVHV: { /* normal hash */
1015 magic = SvMAGICAL(hash) != 0;
1017 firsthashrelem = relem;
1019 while (relem < lastrelem) { /* gobble up all the rest */
1021 sv = *relem ? *relem : &PL_sv_no;
1025 sv_setsv(tmpstr,*relem); /* value */
1026 *(relem++) = tmpstr;
1027 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1028 /* key overwrites an existing entry */
1030 didstore = hv_store_ent(hash,sv,tmpstr,0);
1032 if (SvSMAGICAL(tmpstr))
1039 if (relem == lastrelem) {
1040 do_oddball(hash, relem, firstrelem);
1046 if (SvIMMORTAL(sv)) {
1047 if (relem <= lastrelem)
1051 if (relem <= lastrelem) {
1052 sv_setsv(sv, *relem);
1056 sv_setsv(sv, &PL_sv_undef);
1061 if (PL_delaymagic & ~DM_DELAY) {
1062 if (PL_delaymagic & DM_UID) {
1063 #ifdef HAS_SETRESUID
1064 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1065 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1068 # ifdef HAS_SETREUID
1069 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1070 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1073 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1074 (void)setruid(PL_uid);
1075 PL_delaymagic &= ~DM_RUID;
1077 # endif /* HAS_SETRUID */
1079 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1080 (void)seteuid(PL_euid);
1081 PL_delaymagic &= ~DM_EUID;
1083 # endif /* HAS_SETEUID */
1084 if (PL_delaymagic & DM_UID) {
1085 if (PL_uid != PL_euid)
1086 DIE(aTHX_ "No setreuid available");
1087 (void)PerlProc_setuid(PL_uid);
1089 # endif /* HAS_SETREUID */
1090 #endif /* HAS_SETRESUID */
1091 PL_uid = PerlProc_getuid();
1092 PL_euid = PerlProc_geteuid();
1094 if (PL_delaymagic & DM_GID) {
1095 #ifdef HAS_SETRESGID
1096 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1097 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1100 # ifdef HAS_SETREGID
1101 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1102 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1105 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1106 (void)setrgid(PL_gid);
1107 PL_delaymagic &= ~DM_RGID;
1109 # endif /* HAS_SETRGID */
1111 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1112 (void)setegid(PL_egid);
1113 PL_delaymagic &= ~DM_EGID;
1115 # endif /* HAS_SETEGID */
1116 if (PL_delaymagic & DM_GID) {
1117 if (PL_gid != PL_egid)
1118 DIE(aTHX_ "No setregid available");
1119 (void)PerlProc_setgid(PL_gid);
1121 # endif /* HAS_SETREGID */
1122 #endif /* HAS_SETRESGID */
1123 PL_gid = PerlProc_getgid();
1124 PL_egid = PerlProc_getegid();
1126 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1130 if (gimme == G_VOID)
1131 SP = firstrelem - 1;
1132 else if (gimme == G_SCALAR) {
1135 SETi(lastrelem - firstrelem + 1 - duplicates);
1142 /* Removes from the stack the entries which ended up as
1143 * duplicated keys in the hash (fix for [perl #24380]) */
1144 Move(firsthashrelem + duplicates,
1145 firsthashrelem, duplicates, SV**);
1146 lastrelem -= duplicates;
1151 SP = firstrelem + (lastlelem - firstlelem);
1152 lelem = firstlelem + (relem - firstrelem);
1154 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1163 register PMOP * const pm = cPMOP;
1164 REGEXP * rx = PM_GETRE(pm);
1165 SV * const pkg = CALLREG_PACKAGE(rx);
1166 SV * const rv = sv_newmortal();
1167 SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1168 if (rx->extflags & RXf_TAINTED)
1170 sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1178 register PMOP *pm = cPMOP;
1180 register const char *t;
1181 register const char *s;
1184 I32 r_flags = REXEC_CHECKED;
1185 const char *truebase; /* Start of string */
1186 register REGEXP *rx = PM_GETRE(pm);
1188 const I32 gimme = GIMME;
1191 const I32 oldsave = PL_savestack_ix;
1192 I32 update_minmatch = 1;
1193 I32 had_zerolen = 0;
1196 if (PL_op->op_flags & OPf_STACKED)
1198 else if (PL_op->op_private & OPpTARGET_MY)
1205 PUTBACK; /* EVAL blocks need stack_sp. */
1206 s = SvPV_const(TARG, len);
1208 DIE(aTHX_ "panic: pp_match");
1210 rxtainted = ((rx->extflags & RXf_TAINTED) ||
1211 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1214 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1216 /* PMdf_USED is set after a ?? matches once */
1219 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1221 pm->op_pmflags & PMf_USED
1225 if (gimme == G_ARRAY)
1232 /* empty pattern special-cased to use last successful pattern if possible */
1233 if (!rx->prelen && PL_curpm) {
1238 if (rx->minlen > (I32)len)
1243 /* XXXX What part of this is needed with true \G-support? */
1244 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1245 rx->offs[0].start = -1;
1246 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1247 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1248 if (mg && mg->mg_len >= 0) {
1249 if (!(rx->extflags & RXf_GPOS_SEEN))
1250 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1251 else if (rx->extflags & RXf_ANCH_GPOS) {
1252 r_flags |= REXEC_IGNOREPOS;
1253 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1254 } else if (rx->extflags & RXf_GPOS_FLOAT)
1257 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1258 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1259 update_minmatch = 0;
1263 /* XXX: comment out !global get safe $1 vars after a
1264 match, BUT be aware that this leads to dramatic slowdowns on
1265 /g matches against large strings. So far a solution to this problem
1266 appears to be quite tricky.
1267 Test for the unsafe vars are TODO for now. */
1268 if (( !global && rx->nparens)
1269 || SvTEMP(TARG) || PL_sawampersand ||
1270 (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1271 r_flags |= REXEC_COPY_STR;
1273 r_flags |= REXEC_SCREAM;
1276 if (global && rx->offs[0].start != -1) {
1277 t = s = rx->offs[0].end + truebase - rx->gofs;
1278 if ((s + rx->minlen) > strend || s < truebase)
1280 if (update_minmatch++)
1281 minmatch = had_zerolen;
1283 if (rx->extflags & RXf_USE_INTUIT &&
1284 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1285 /* FIXME - can PL_bostr be made const char *? */
1286 PL_bostr = (char *)truebase;
1287 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1291 if ( (rx->extflags & RXf_CHECK_ALL)
1293 && !(rx->extflags & RXf_PMf_KEEPCOPY)
1294 && ((rx->extflags & RXf_NOSCAN)
1295 || !((rx->extflags & RXf_INTUIT_TAIL)
1296 && (r_flags & REXEC_SCREAM)))
1297 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1300 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1303 if (dynpm->op_pmflags & PMf_ONCE) {
1305 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1307 dynpm->op_pmflags |= PMf_USED;
1318 RX_MATCH_TAINTED_on(rx);
1319 TAINT_IF(RX_MATCH_TAINTED(rx));
1320 if (gimme == G_ARRAY) {
1321 const I32 nparens = rx->nparens;
1322 I32 i = (global && !nparens) ? 1 : 0;
1324 SPAGAIN; /* EVAL blocks could move the stack. */
1325 EXTEND(SP, nparens + i);
1326 EXTEND_MORTAL(nparens + i);
1327 for (i = !i; i <= nparens; i++) {
1328 PUSHs(sv_newmortal());
1329 if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1330 const I32 len = rx->offs[i].end - rx->offs[i].start;
1331 s = rx->offs[i].start + truebase;
1332 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1333 len < 0 || len > strend - s)
1334 DIE(aTHX_ "panic: pp_match start/end pointers");
1335 sv_setpvn(*SP, s, len);
1336 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1341 if (dynpm->op_pmflags & PMf_CONTINUE) {
1343 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1344 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346 #ifdef PERL_OLD_COPY_ON_WRITE
1348 sv_force_normal_flags(TARG, 0);
1350 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1351 &PL_vtbl_mglob, NULL, 0);
1353 if (rx->offs[0].start != -1) {
1354 mg->mg_len = rx->offs[0].end;
1355 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1356 mg->mg_flags |= MGf_MINMATCH;
1358 mg->mg_flags &= ~MGf_MINMATCH;
1361 had_zerolen = (rx->offs[0].start != -1
1362 && (rx->offs[0].start + rx->gofs
1363 == (UV)rx->offs[0].end));
1364 PUTBACK; /* EVAL blocks may use stack */
1365 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1370 LEAVE_SCOPE(oldsave);
1376 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1377 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1381 #ifdef PERL_OLD_COPY_ON_WRITE
1383 sv_force_normal_flags(TARG, 0);
1385 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1386 &PL_vtbl_mglob, NULL, 0);
1388 if (rx->offs[0].start != -1) {
1389 mg->mg_len = rx->offs[0].end;
1390 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1391 mg->mg_flags |= MGf_MINMATCH;
1393 mg->mg_flags &= ~MGf_MINMATCH;
1396 LEAVE_SCOPE(oldsave);
1400 yup: /* Confirmed by INTUIT */
1402 RX_MATCH_TAINTED_on(rx);
1403 TAINT_IF(RX_MATCH_TAINTED(rx));
1405 if (dynpm->op_pmflags & PMf_ONCE) {
1407 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1409 dynpm->op_pmflags |= PMf_USED;
1412 if (RX_MATCH_COPIED(rx))
1413 Safefree(rx->subbeg);
1414 RX_MATCH_COPIED_off(rx);
1417 /* FIXME - should rx->subbeg be const char *? */
1418 rx->subbeg = (char *) truebase;
1419 rx->offs[0].start = s - truebase;
1420 if (RX_MATCH_UTF8(rx)) {
1421 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1422 rx->offs[0].end = t - truebase;
1425 rx->offs[0].end = s - truebase + rx->minlenret;
1427 rx->sublen = strend - truebase;
1430 if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1432 #ifdef PERL_OLD_COPY_ON_WRITE
1433 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1435 PerlIO_printf(Perl_debug_log,
1436 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1437 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1440 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1441 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1442 assert (SvPOKp(rx->saved_copy));
1447 rx->subbeg = savepvn(t, strend - t);
1448 #ifdef PERL_OLD_COPY_ON_WRITE
1449 rx->saved_copy = NULL;
1452 rx->sublen = strend - t;
1453 RX_MATCH_COPIED_on(rx);
1454 off = rx->offs[0].start = s - t;
1455 rx->offs[0].end = off + rx->minlenret;
1457 else { /* startp/endp are used by @- @+. */
1458 rx->offs[0].start = s - truebase;
1459 rx->offs[0].end = s - truebase + rx->minlenret;
1461 /* including rx->nparens in the below code seems highly suspicious.
1463 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1464 LEAVE_SCOPE(oldsave);
1469 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1470 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1471 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1476 LEAVE_SCOPE(oldsave);
1477 if (gimme == G_ARRAY)
1483 Perl_do_readline(pTHX)
1485 dVAR; dSP; dTARGETSTACKED;
1490 register IO * const io = GvIO(PL_last_in_gv);
1491 register const I32 type = PL_op->op_type;
1492 const I32 gimme = GIMME_V;
1495 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1498 XPUSHs(SvTIED_obj((SV*)io, mg));
1501 call_method("READLINE", gimme);
1504 if (gimme == G_SCALAR) {
1505 SV* const result = POPs;
1506 SvSetSV_nosteal(TARG, result);
1516 if (IoFLAGS(io) & IOf_ARGV) {
1517 if (IoFLAGS(io) & IOf_START) {
1519 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1520 IoFLAGS(io) &= ~IOf_START;
1521 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1522 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1523 SvSETMAGIC(GvSV(PL_last_in_gv));
1528 fp = nextargv(PL_last_in_gv);
1529 if (!fp) { /* Note: fp != IoIFP(io) */
1530 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1533 else if (type == OP_GLOB)
1534 fp = Perl_start_glob(aTHX_ POPs, io);
1536 else if (type == OP_GLOB)
1538 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1539 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1543 if ((!io || !(IoFLAGS(io) & IOf_START))
1544 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1546 if (type == OP_GLOB)
1547 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1548 "glob failed (can't start child: %s)",
1551 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1553 if (gimme == G_SCALAR) {
1554 /* undef TARG, and push that undefined value */
1555 if (type != OP_RCATLINE) {
1556 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1564 if (gimme == G_SCALAR) {
1566 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1569 if (type == OP_RCATLINE)
1570 SvPV_force_nolen(sv);
1574 else if (isGV_with_GP(sv)) {
1575 SvPV_force_nolen(sv);
1577 SvUPGRADE(sv, SVt_PV);
1578 tmplen = SvLEN(sv); /* remember if already alloced */
1579 if (!tmplen && !SvREADONLY(sv))
1580 Sv_Grow(sv, 80); /* try short-buffering it */
1582 if (type == OP_RCATLINE && SvOK(sv)) {
1584 SvPV_force_nolen(sv);
1590 sv = sv_2mortal(newSV(80));
1594 /* This should not be marked tainted if the fp is marked clean */
1595 #define MAYBE_TAINT_LINE(io, sv) \
1596 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1601 /* delay EOF state for a snarfed empty file */
1602 #define SNARF_EOF(gimme,rs,io,sv) \
1603 (gimme != G_SCALAR || SvCUR(sv) \
1604 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1608 if (!sv_gets(sv, fp, offset)
1610 || SNARF_EOF(gimme, PL_rs, io, sv)
1611 || PerlIO_error(fp)))
1613 PerlIO_clearerr(fp);
1614 if (IoFLAGS(io) & IOf_ARGV) {
1615 fp = nextargv(PL_last_in_gv);
1618 (void)do_close(PL_last_in_gv, FALSE);
1620 else if (type == OP_GLOB) {
1621 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1622 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1623 "glob failed (child exited with status %d%s)",
1624 (int)(STATUS_CURRENT >> 8),
1625 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1628 if (gimme == G_SCALAR) {
1629 if (type != OP_RCATLINE) {
1630 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1636 MAYBE_TAINT_LINE(io, sv);
1639 MAYBE_TAINT_LINE(io, sv);
1641 IoFLAGS(io) |= IOf_NOLINE;
1645 if (type == OP_GLOB) {
1648 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1649 char * const tmps = SvEND(sv) - 1;
1650 if (*tmps == *SvPVX_const(PL_rs)) {
1652 SvCUR_set(sv, SvCUR(sv) - 1);
1655 for (t1 = SvPVX_const(sv); *t1; t1++)
1656 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1657 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1659 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1660 (void)POPs; /* Unmatched wildcard? Chuck it... */
1663 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1664 if (ckWARN(WARN_UTF8)) {
1665 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1666 const STRLEN len = SvCUR(sv) - offset;
1669 if (!is_utf8_string_loc(s, len, &f))
1670 /* Emulate :encoding(utf8) warning in the same case. */
1671 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1672 "utf8 \"\\x%02X\" does not map to Unicode",
1673 f < (U8*)SvEND(sv) ? *f : 0);
1676 if (gimme == G_ARRAY) {
1677 if (SvLEN(sv) - SvCUR(sv) > 20) {
1678 SvPV_shrink_to_cur(sv);
1680 sv = sv_2mortal(newSV(80));
1683 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1684 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1685 const STRLEN new_len
1686 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1687 SvPV_renew(sv, new_len);
1696 register PERL_CONTEXT *cx;
1697 I32 gimme = OP_GIMME(PL_op, -1);
1700 if (cxstack_ix >= 0)
1701 gimme = cxstack[cxstack_ix].blk_gimme;
1709 PUSHBLOCK(cx, CXt_BLOCK, SP);
1719 SV * const keysv = POPs;
1720 HV * const hv = (HV*)POPs;
1721 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1722 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1724 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1727 if (SvTYPE(hv) != SVt_PVHV)
1730 if (PL_op->op_private & OPpLVAL_INTRO) {
1733 /* does the element we're localizing already exist? */
1734 preeminent = /* can we determine whether it exists? */
1736 || mg_find((SV*)hv, PERL_MAGIC_env)
1737 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1738 /* Try to preserve the existenceness of a tied hash
1739 * element by using EXISTS and DELETE if possible.
1740 * Fallback to FETCH and STORE otherwise */
1741 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1742 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1743 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1745 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1747 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1748 svp = he ? &HeVAL(he) : NULL;
1750 if (!svp || *svp == &PL_sv_undef) {
1754 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1756 lv = sv_newmortal();
1757 sv_upgrade(lv, SVt_PVLV);
1759 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1760 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1761 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1766 if (PL_op->op_private & OPpLVAL_INTRO) {
1767 if (HvNAME_get(hv) && isGV(*svp))
1768 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1772 const char * const key = SvPV_const(keysv, keylen);
1773 SAVEDELETE(hv, savepvn(key,keylen),
1774 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1776 save_helem(hv, keysv, svp);
1779 else if (PL_op->op_private & OPpDEREF)
1780 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1782 sv = (svp ? *svp : &PL_sv_undef);
1783 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1784 * Pushing the magical RHS on to the stack is useless, since
1785 * that magic is soon destined to be misled by the local(),
1786 * and thus the later pp_sassign() will fail to mg_get() the
1787 * old value. This should also cure problems with delayed
1788 * mg_get()s. GSAR 98-07-03 */
1789 if (!lval && SvGMAGICAL(sv))
1790 sv = sv_mortalcopy(sv);
1798 register PERL_CONTEXT *cx;
1803 if (PL_op->op_flags & OPf_SPECIAL) {
1804 cx = &cxstack[cxstack_ix];
1805 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1810 gimme = OP_GIMME(PL_op, -1);
1812 if (cxstack_ix >= 0)
1813 gimme = cxstack[cxstack_ix].blk_gimme;
1819 if (gimme == G_VOID)
1821 else if (gimme == G_SCALAR) {
1825 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1828 *MARK = sv_mortalcopy(TOPs);
1831 *MARK = &PL_sv_undef;
1835 else if (gimme == G_ARRAY) {
1836 /* in case LEAVE wipes old return values */
1838 for (mark = newsp + 1; mark <= SP; mark++) {
1839 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1840 *mark = sv_mortalcopy(*mark);
1841 TAINT_NOT; /* Each item is independent */
1845 PL_curpm = newpm; /* Don't pop $1 et al till now */
1855 register PERL_CONTEXT *cx;
1861 cx = &cxstack[cxstack_ix];
1862 if (CxTYPE(cx) != CXt_LOOP)
1863 DIE(aTHX_ "panic: pp_iter");
1865 itersvp = CxITERVAR(cx);
1866 av = cx->blk_loop.iterary;
1867 if (SvTYPE(av) != SVt_PVAV) {
1868 /* iterate ($min .. $max) */
1869 if (cx->blk_loop.iterlval) {
1870 /* string increment */
1871 register SV* cur = cx->blk_loop.iterlval;
1875 SvPV_const((SV*)av, maxlen) : (const char *)"";
1876 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1877 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1878 /* safe to reuse old SV */
1879 sv_setsv(*itersvp, cur);
1883 /* we need a fresh SV every time so that loop body sees a
1884 * completely new SV for closures/references to work as
1887 *itersvp = newSVsv(cur);
1888 SvREFCNT_dec(oldsv);
1890 if (strEQ(SvPVX_const(cur), max))
1891 sv_setiv(cur, 0); /* terminate next time */
1898 /* integer increment */
1899 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1902 /* don't risk potential race */
1903 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1904 /* safe to reuse old SV */
1905 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1909 /* we need a fresh SV every time so that loop body sees a
1910 * completely new SV for closures/references to work as they
1913 *itersvp = newSViv(cx->blk_loop.iterix++);
1914 SvREFCNT_dec(oldsv);
1920 if (PL_op->op_private & OPpITER_REVERSED) {
1921 /* In reverse, use itermax as the min :-) */
1922 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1925 if (SvMAGICAL(av) || AvREIFY(av)) {
1926 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1927 sv = svp ? *svp : NULL;
1930 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1934 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1938 if (SvMAGICAL(av) || AvREIFY(av)) {
1939 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1940 sv = svp ? *svp : NULL;
1943 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1947 if (sv && SvIS_FREED(sv)) {
1949 Perl_croak(aTHX_ "Use of freed value in iteration");
1956 if (av != PL_curstack && sv == &PL_sv_undef) {
1957 SV *lv = cx->blk_loop.iterlval;
1958 if (lv && SvREFCNT(lv) > 1) {
1963 SvREFCNT_dec(LvTARG(lv));
1965 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1967 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1969 LvTARG(lv) = SvREFCNT_inc_simple(av);
1970 LvTARGOFF(lv) = cx->blk_loop.iterix;
1971 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1976 *itersvp = SvREFCNT_inc_simple_NN(sv);
1977 SvREFCNT_dec(oldsv);
1985 register PMOP *pm = cPMOP;
2000 register REGEXP *rx = PM_GETRE(pm);
2002 int force_on_match = 0;
2003 const I32 oldsave = PL_savestack_ix;
2005 bool doutf8 = FALSE;
2006 #ifdef PERL_OLD_COPY_ON_WRITE
2011 /* known replacement string? */
2012 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2013 if (PL_op->op_flags & OPf_STACKED)
2015 else if (PL_op->op_private & OPpTARGET_MY)
2022 #ifdef PERL_OLD_COPY_ON_WRITE
2023 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2024 because they make integers such as 256 "false". */
2025 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2028 sv_force_normal_flags(TARG,0);
2031 #ifdef PERL_OLD_COPY_ON_WRITE
2035 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2036 || SvTYPE(TARG) > SVt_PVLV)
2037 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2038 DIE(aTHX_ PL_no_modify);
2041 s = SvPV_mutable(TARG, len);
2042 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2044 rxtainted = ((rx->extflags & RXf_TAINTED) ||
2045 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2050 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2054 DIE(aTHX_ "panic: pp_subst");
2057 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2058 maxiters = 2 * slen + 10; /* We can match twice at each
2059 position, once with zero-length,
2060 second time with non-zero. */
2062 if (!rx->prelen && PL_curpm) {
2066 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2067 || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2068 ? REXEC_COPY_STR : 0;
2070 r_flags |= REXEC_SCREAM;
2073 if (rx->extflags & RXf_USE_INTUIT) {
2075 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2079 /* How to do it in subst? */
2080 /* if ( (rx->extflags & RXf_CHECK_ALL)
2082 && !(rx->extflags & RXf_KEEPCOPY)
2083 && ((rx->extflags & RXf_NOSCAN)
2084 || !((rx->extflags & RXf_INTUIT_TAIL)
2085 && (r_flags & REXEC_SCREAM))))
2090 /* only replace once? */
2091 once = !(rpm->op_pmflags & PMf_GLOBAL);
2093 /* known replacement string? */
2095 /* replacement needing upgrading? */
2096 if (DO_UTF8(TARG) && !doutf8) {
2097 nsv = sv_newmortal();
2100 sv_recode_to_utf8(nsv, PL_encoding);
2102 sv_utf8_upgrade(nsv);
2103 c = SvPV_const(nsv, clen);
2107 c = SvPV_const(dstr, clen);
2108 doutf8 = DO_UTF8(dstr);
2116 /* can do inplace substitution? */
2118 #ifdef PERL_OLD_COPY_ON_WRITE
2121 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2122 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2123 && (!doutf8 || SvUTF8(TARG))) {
2124 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2125 r_flags | REXEC_CHECKED))
2129 LEAVE_SCOPE(oldsave);
2132 #ifdef PERL_OLD_COPY_ON_WRITE
2133 if (SvIsCOW(TARG)) {
2134 assert (!force_on_match);
2138 if (force_on_match) {
2140 s = SvPV_force(TARG, len);
2145 SvSCREAM_off(TARG); /* disable possible screamer */
2147 rxtainted |= RX_MATCH_TAINTED(rx);
2148 m = orig + rx->offs[0].start;
2149 d = orig + rx->offs[0].end;
2151 if (m - s > strend - d) { /* faster to shorten from end */
2153 Copy(c, m, clen, char);
2158 Move(d, m, i, char);
2162 SvCUR_set(TARG, m - s);
2164 else if ((i = m - s)) { /* faster from front */
2172 Copy(c, m, clen, char);
2177 Copy(c, d, clen, char);
2182 TAINT_IF(rxtainted & 1);
2188 if (iters++ > maxiters)
2189 DIE(aTHX_ "Substitution loop");
2190 rxtainted |= RX_MATCH_TAINTED(rx);
2191 m = rx->offs[0].start + orig;
2194 Move(s, d, i, char);
2198 Copy(c, d, clen, char);
2201 s = rx->offs[0].end + orig;
2202 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2204 /* don't match same null twice */
2205 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2208 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2209 Move(s, d, i+1, char); /* include the NUL */
2211 TAINT_IF(rxtainted & 1);
2213 PUSHs(sv_2mortal(newSViv((I32)iters)));
2215 (void)SvPOK_only_UTF8(TARG);
2216 TAINT_IF(rxtainted);
2217 if (SvSMAGICAL(TARG)) {
2225 LEAVE_SCOPE(oldsave);
2229 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2230 r_flags | REXEC_CHECKED))
2232 if (force_on_match) {
2234 s = SvPV_force(TARG, len);
2237 #ifdef PERL_OLD_COPY_ON_WRITE
2240 rxtainted |= RX_MATCH_TAINTED(rx);
2241 dstr = newSVpvn(m, s-m);
2247 register PERL_CONTEXT *cx;
2250 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2252 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2254 if (iters++ > maxiters)
2255 DIE(aTHX_ "Substitution loop");
2256 rxtainted |= RX_MATCH_TAINTED(rx);
2257 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2262 strend = s + (strend - m);
2264 m = rx->offs[0].start + orig;
2265 if (doutf8 && !SvUTF8(dstr))
2266 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2268 sv_catpvn(dstr, s, m-s);
2269 s = rx->offs[0].end + orig;
2271 sv_catpvn(dstr, c, clen);
2274 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2275 TARG, NULL, r_flags));
2276 if (doutf8 && !DO_UTF8(TARG))
2277 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2279 sv_catpvn(dstr, s, strend - s);
2281 #ifdef PERL_OLD_COPY_ON_WRITE
2282 /* The match may make the string COW. If so, brilliant, because that's
2283 just saved us one malloc, copy and free - the regexp has donated
2284 the old buffer, and we malloc an entirely new one, rather than the
2285 regexp malloc()ing a buffer and copying our original, only for
2286 us to throw it away here during the substitution. */
2287 if (SvIsCOW(TARG)) {
2288 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2294 SvPV_set(TARG, SvPVX(dstr));
2295 SvCUR_set(TARG, SvCUR(dstr));
2296 SvLEN_set(TARG, SvLEN(dstr));
2297 doutf8 |= DO_UTF8(dstr);
2298 SvPV_set(dstr, NULL);
2300 TAINT_IF(rxtainted & 1);
2302 PUSHs(sv_2mortal(newSViv((I32)iters)));
2304 (void)SvPOK_only(TARG);
2307 TAINT_IF(rxtainted);
2310 LEAVE_SCOPE(oldsave);
2319 LEAVE_SCOPE(oldsave);
2328 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2329 ++*PL_markstack_ptr;
2330 LEAVE; /* exit inner scope */
2333 if (PL_stack_base + *PL_markstack_ptr > SP) {
2335 const I32 gimme = GIMME_V;
2337 LEAVE; /* exit outer scope */
2338 (void)POPMARK; /* pop src */
2339 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2340 (void)POPMARK; /* pop dst */
2341 SP = PL_stack_base + POPMARK; /* pop original mark */
2342 if (gimme == G_SCALAR) {
2343 if (PL_op->op_private & OPpGREP_LEX) {
2344 SV* const sv = sv_newmortal();
2345 sv_setiv(sv, items);
2353 else if (gimme == G_ARRAY)
2360 ENTER; /* enter inner scope */
2363 src = PL_stack_base[*PL_markstack_ptr];
2365 if (PL_op->op_private & OPpGREP_LEX)
2366 PAD_SVl(PL_op->op_targ) = src;
2370 RETURNOP(cLOGOP->op_other);
2381 register PERL_CONTEXT *cx;
2384 if (CxMULTICALL(&cxstack[cxstack_ix]))
2388 cxstack_ix++; /* temporarily protect top context */
2391 if (gimme == G_SCALAR) {
2394 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2396 *MARK = SvREFCNT_inc(TOPs);
2401 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2403 *MARK = sv_mortalcopy(sv);
2408 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2412 *MARK = &PL_sv_undef;
2416 else if (gimme == G_ARRAY) {
2417 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2418 if (!SvTEMP(*MARK)) {
2419 *MARK = sv_mortalcopy(*MARK);
2420 TAINT_NOT; /* Each item is independent */
2428 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2429 PL_curpm = newpm; /* ... and pop $1 et al */
2432 return cx->blk_sub.retop;
2435 /* This duplicates the above code because the above code must not
2436 * get any slower by more conditions */
2444 register PERL_CONTEXT *cx;
2447 if (CxMULTICALL(&cxstack[cxstack_ix]))
2451 cxstack_ix++; /* temporarily protect top context */
2455 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2456 /* We are an argument to a function or grep().
2457 * This kind of lvalueness was legal before lvalue
2458 * subroutines too, so be backward compatible:
2459 * cannot report errors. */
2461 /* Scalar context *is* possible, on the LHS of -> only,
2462 * as in f()->meth(). But this is not an lvalue. */
2463 if (gimme == G_SCALAR)
2465 if (gimme == G_ARRAY) {
2466 if (!CvLVALUE(cx->blk_sub.cv))
2467 goto temporise_array;
2468 EXTEND_MORTAL(SP - newsp);
2469 for (mark = newsp + 1; mark <= SP; mark++) {
2472 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2473 *mark = sv_mortalcopy(*mark);
2475 /* Can be a localized value subject to deletion. */
2476 PL_tmps_stack[++PL_tmps_ix] = *mark;
2477 SvREFCNT_inc_void(*mark);
2482 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2483 /* Here we go for robustness, not for speed, so we change all
2484 * the refcounts so the caller gets a live guy. Cannot set
2485 * TEMP, so sv_2mortal is out of question. */
2486 if (!CvLVALUE(cx->blk_sub.cv)) {
2492 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2494 if (gimme == G_SCALAR) {
2498 /* Temporaries are bad unless they happen to be elements
2499 * of a tied hash or array */
2500 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2501 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2507 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2508 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2509 : "a readonly value" : "a temporary");
2511 else { /* Can be a localized value
2512 * subject to deletion. */
2513 PL_tmps_stack[++PL_tmps_ix] = *mark;
2514 SvREFCNT_inc_void(*mark);
2517 else { /* Should not happen? */
2523 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2524 (MARK > SP ? "Empty array" : "Array"));
2528 else if (gimme == G_ARRAY) {
2529 EXTEND_MORTAL(SP - newsp);
2530 for (mark = newsp + 1; mark <= SP; mark++) {
2531 if (*mark != &PL_sv_undef
2532 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2533 /* Might be flattened array after $#array = */
2540 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2541 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2544 /* Can be a localized value subject to deletion. */
2545 PL_tmps_stack[++PL_tmps_ix] = *mark;
2546 SvREFCNT_inc_void(*mark);
2552 if (gimme == G_SCALAR) {
2556 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2558 *MARK = SvREFCNT_inc(TOPs);
2563 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2565 *MARK = sv_mortalcopy(sv);
2570 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2574 *MARK = &PL_sv_undef;
2578 else if (gimme == G_ARRAY) {
2580 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2581 if (!SvTEMP(*MARK)) {
2582 *MARK = sv_mortalcopy(*MARK);
2583 TAINT_NOT; /* Each item is independent */
2592 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2593 PL_curpm = newpm; /* ... and pop $1 et al */
2596 return cx->blk_sub.retop;
2604 register PERL_CONTEXT *cx;
2606 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2609 DIE(aTHX_ "Not a CODE reference");
2610 switch (SvTYPE(sv)) {
2611 /* This is overwhelming the most common case: */
2613 if (!(cv = GvCVu((GV*)sv))) {
2615 cv = sv_2cv(sv, &stash, &gv, 0);
2627 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2629 SP = PL_stack_base + POPMARK;
2632 if (SvGMAGICAL(sv)) {
2637 sym = SvPVX_const(sv);
2645 sym = SvPV_const(sv, len);
2648 DIE(aTHX_ PL_no_usym, "a subroutine");
2649 if (PL_op->op_private & HINT_STRICT_REFS)
2650 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2651 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2656 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2657 tryAMAGICunDEREF(to_cv);
2660 if (SvTYPE(cv) == SVt_PVCV)
2665 DIE(aTHX_ "Not a CODE reference");
2666 /* This is the second most common case: */
2676 if (!CvROOT(cv) && !CvXSUB(cv)) {
2680 /* anonymous or undef'd function leaves us no recourse */
2681 if (CvANON(cv) || !(gv = CvGV(cv)))
2682 DIE(aTHX_ "Undefined subroutine called");
2684 /* autoloaded stub? */
2685 if (cv != GvCV(gv)) {
2688 /* should call AUTOLOAD now? */
2691 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2698 sub_name = sv_newmortal();
2699 gv_efullname3(sub_name, gv, NULL);
2700 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2704 DIE(aTHX_ "Not a CODE reference");
2709 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2710 Perl_get_db_sub(aTHX_ &sv, cv);
2712 PL_curcopdb = PL_curcop;
2713 cv = GvCV(PL_DBsub);
2715 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2716 DIE(aTHX_ "No DB::sub routine defined");
2719 if (!(CvISXSUB(cv))) {
2720 /* This path taken at least 75% of the time */
2722 register I32 items = SP - MARK;
2723 AV* const padlist = CvPADLIST(cv);
2724 PUSHBLOCK(cx, CXt_SUB, MARK);
2726 cx->blk_sub.retop = PL_op->op_next;
2728 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2729 * that eval'' ops within this sub know the correct lexical space.
2730 * Owing the speed considerations, we choose instead to search for
2731 * the cv using find_runcv() when calling doeval().
2733 if (CvDEPTH(cv) >= 2) {
2734 PERL_STACK_OVERFLOW_CHECK();
2735 pad_push(padlist, CvDEPTH(cv));
2738 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2740 AV* const av = (AV*)PAD_SVl(0);
2742 /* @_ is normally not REAL--this should only ever
2743 * happen when DB::sub() calls things that modify @_ */
2748 cx->blk_sub.savearray = GvAV(PL_defgv);
2749 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2750 CX_CURPAD_SAVE(cx->blk_sub);
2751 cx->blk_sub.argarray = av;
2754 if (items > AvMAX(av) + 1) {
2755 SV **ary = AvALLOC(av);
2756 if (AvARRAY(av) != ary) {
2757 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2760 if (items > AvMAX(av) + 1) {
2761 AvMAX(av) = items - 1;
2762 Renew(ary,items,SV*);
2767 Copy(MARK,AvARRAY(av),items,SV*);
2768 AvFILLp(av) = items - 1;
2776 /* warning must come *after* we fully set up the context
2777 * stuff so that __WARN__ handlers can safely dounwind()
2780 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2781 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2782 sub_crush_depth(cv);
2784 DEBUG_S(PerlIO_printf(Perl_debug_log,
2785 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2787 RETURNOP(CvSTART(cv));
2790 I32 markix = TOPMARK;
2795 /* Need to copy @_ to stack. Alternative may be to
2796 * switch stack to @_, and copy return values
2797 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2798 AV * const av = GvAV(PL_defgv);
2799 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2802 /* Mark is at the end of the stack. */
2804 Copy(AvARRAY(av), SP + 1, items, SV*);
2809 /* We assume first XSUB in &DB::sub is the called one. */
2811 SAVEVPTR(PL_curcop);
2812 PL_curcop = PL_curcopdb;
2815 /* Do we need to open block here? XXXX */
2816 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2817 (void)(*CvXSUB(cv))(aTHX_ cv);
2819 /* Enforce some sanity in scalar context. */
2820 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2821 if (markix > PL_stack_sp - PL_stack_base)
2822 *(PL_stack_base + markix) = &PL_sv_undef;
2824 *(PL_stack_base + markix) = *PL_stack_sp;
2825 PL_stack_sp = PL_stack_base + markix;
2833 Perl_sub_crush_depth(pTHX_ CV *cv)
2836 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2838 SV* const tmpstr = sv_newmortal();
2839 gv_efullname3(tmpstr, CvGV(cv), NULL);
2840 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2849 SV* const elemsv = POPs;
2850 IV elem = SvIV(elemsv);
2851 AV* const av = (AV*)POPs;
2852 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2853 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2856 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2857 Perl_warner(aTHX_ packWARN(WARN_MISC),
2858 "Use of reference \"%"SVf"\" as array index",
2861 elem -= CopARYBASE_get(PL_curcop);
2862 if (SvTYPE(av) != SVt_PVAV)
2864 svp = av_fetch(av, elem, lval && !defer);
2866 #ifdef PERL_MALLOC_WRAP
2867 if (SvUOK(elemsv)) {
2868 const UV uv = SvUV(elemsv);
2869 elem = uv > IV_MAX ? IV_MAX : uv;
2871 else if (SvNOK(elemsv))
2872 elem = (IV)SvNV(elemsv);
2874 static const char oom_array_extend[] =
2875 "Out of memory during array extend"; /* Duplicated in av.c */
2876 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2879 if (!svp || *svp == &PL_sv_undef) {
2882 DIE(aTHX_ PL_no_aelem, elem);
2883 lv = sv_newmortal();
2884 sv_upgrade(lv, SVt_PVLV);
2886 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2887 LvTARG(lv) = SvREFCNT_inc_simple(av);
2888 LvTARGOFF(lv) = elem;
2893 if (PL_op->op_private & OPpLVAL_INTRO)
2894 save_aelem(av, elem, svp);
2895 else if (PL_op->op_private & OPpDEREF)
2896 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2898 sv = (svp ? *svp : &PL_sv_undef);
2899 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2900 sv = sv_mortalcopy(sv);
2906 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2911 Perl_croak(aTHX_ PL_no_modify);
2912 if (SvTYPE(sv) < SVt_RV)
2913 sv_upgrade(sv, SVt_RV);
2914 else if (SvTYPE(sv) >= SVt_PV) {
2921 SvRV_set(sv, newSV(0));
2924 SvRV_set(sv, (SV*)newAV());
2927 SvRV_set(sv, (SV*)newHV());
2938 SV* const sv = TOPs;
2941 SV* const rsv = SvRV(sv);
2942 if (SvTYPE(rsv) == SVt_PVCV) {
2948 SETs(method_common(sv, NULL));
2955 SV* const sv = cSVOP_sv;
2956 U32 hash = SvSHARED_HASH(sv);
2958 XPUSHs(method_common(sv, &hash));
2963 S_method_common(pTHX_ SV* meth, U32* hashp)
2970 const char* packname = NULL;
2973 const char * const name = SvPV_const(meth, namelen);
2974 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2977 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2985 /* this isn't a reference */
2986 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2987 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2989 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2996 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2997 !(ob=(SV*)GvIO(iogv)))
2999 /* this isn't the name of a filehandle either */
3001 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3002 ? !isIDFIRST_utf8((U8*)packname)
3003 : !isIDFIRST(*packname)
3006 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3007 SvOK(sv) ? "without a package or object reference"
3008 : "on an undefined value");
3010 /* assume it's a package name */
3011 stash = gv_stashpvn(packname, packlen, 0);
3015 SV* const ref = newSViv(PTR2IV(stash));
3016 hv_store(PL_stashcache, packname, packlen, ref, 0);
3020 /* it _is_ a filehandle name -- replace with a reference */
3021 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3024 /* if we got here, ob should be a reference or a glob */
3025 if (!ob || !(SvOBJECT(ob)
3026 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3029 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3030 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3034 stash = SvSTASH(ob);
3037 /* NOTE: stash may be null, hope hv_fetch_ent and
3038 gv_fetchmethod can cope (it seems they can) */
3040 /* shortcut for simple names */
3042 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3044 gv = (GV*)HeVAL(he);
3045 if (isGV(gv) && GvCV(gv) &&
3046 (!GvCVGEN(gv) || GvCVGEN(gv)
3047 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3048 return (SV*)GvCV(gv);
3052 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3055 /* This code tries to figure out just what went wrong with
3056 gv_fetchmethod. It therefore needs to duplicate a lot of
3057 the internals of that function. We can't move it inside
3058 Perl_gv_fetchmethod_autoload(), however, since that would
3059 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3062 const char* leaf = name;
3063 const char* sep = NULL;
3066 for (p = name; *p; p++) {
3068 sep = p, leaf = p + 1;
3069 else if (*p == ':' && *(p + 1) == ':')
3070 sep = p, leaf = p + 2;
3072 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3073 /* the method name is unqualified or starts with SUPER:: */
3074 bool need_strlen = 1;
3076 packname = CopSTASHPV(PL_curcop);
3079 HEK * const packhek = HvNAME_HEK(stash);
3081 packname = HEK_KEY(packhek);
3082 packlen = HEK_LEN(packhek);
3092 "Can't use anonymous symbol table for method lookup");
3094 else if (need_strlen)
3095 packlen = strlen(packname);
3099 /* the method name is qualified */
3101 packlen = sep - name;
3104 /* we're relying on gv_fetchmethod not autovivifying the stash */
3105 if (gv_stashpvn(packname, packlen, 0)) {
3107 "Can't locate object method \"%s\" via package \"%.*s\"",
3108 leaf, (int)packlen, packname);
3112 "Can't locate object method \"%s\" via package \"%.*s\""
3113 " (perhaps you forgot to load \"%.*s\"?)",
3114 leaf, (int)packlen, packname, (int)packlen, packname);
3117 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3122 * c-indentation-style: bsd
3124 * indent-tabs-mode: t
3127 * ex: set ts=8 sts=4 sw=4 noet: