3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (PL_op->op_private & OPpLVAL_INTRO)
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
77 PUSHMARK(PL_stack_sp);
92 XPUSHs((SV*)cGVOP_gv);
102 if (PL_op->op_type == OP_AND)
104 RETURNOP(cLOGOP->op_other);
110 dVAR; dSP; dPOPTOPssrl;
112 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
113 SV * const temp = left;
114 left = right; right = temp;
116 if (PL_tainting && PL_tainted && !SvTAINTED(left))
118 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
119 SV * const cv = SvRV(left);
120 const U32 cv_type = SvTYPE(cv);
121 const U32 gv_type = SvTYPE(right);
122 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
128 /* Can do the optimisation if right (LVALUE) is not a typeglob,
129 left (RVALUE) is a reference to something, and we're in void
131 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
132 /* Is the target symbol table currently empty? */
133 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
134 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
135 /* Good. Create a new proxy constant subroutine in the target.
136 The gv becomes a(nother) reference to the constant. */
137 SV *const value = SvRV(cv);
139 SvUPGRADE((SV *)gv, SVt_IV);
140 SvPCS_IMPORTED_on(gv);
142 SvREFCNT_inc_simple_void(value);
148 /* Need to fix things up. */
149 if (gv_type != SVt_PVGV) {
150 /* Need to fix GV. */
151 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
155 /* We've been returned a constant rather than a full subroutine,
156 but they expect a subroutine reference to apply. */
159 SvREFCNT_inc_void(SvRV(cv));
160 /* newCONSTSUB takes a reference count on the passed in SV
161 from us. We set the name to NULL, otherwise we get into
162 all sorts of fun as the reference to our new sub is
163 donated to the GV that we're about to assign to.
165 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
170 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
172 First: ops for \&{"BONK"}; return us the constant in the
174 Second: ops for *{"BONK"} cause that symbol table entry
175 (and our reference to it) to be upgraded from RV
177 Thirdly: We get here. cv is actually PVGV now, and its
178 GvCV() is actually the subroutine we're looking for
180 So change the reference so that it points to the subroutine
181 of that typeglob, as that's what they were after all along.
183 GV *const upgraded = (GV *) cv;
184 CV *const source = GvCV(upgraded);
187 assert(CvFLAGS(source) & CVf_CONST);
189 SvREFCNT_inc_void(source);
190 SvREFCNT_dec(upgraded);
191 SvRV_set(left, (SV *)source);
196 SvSetMagicSV(right, left);
205 RETURNOP(cLOGOP->op_other);
207 RETURNOP(cLOGOP->op_next);
214 TAINT_NOT; /* Each statement is presumed innocent */
215 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
217 oldsave = PL_scopestack[PL_scopestack_ix - 1];
218 LEAVE_SCOPE(oldsave);
224 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
229 const char *rpv = NULL;
231 bool rcopied = FALSE;
233 if (TARG == right && right != left) {
234 /* mg_get(right) may happen here ... */
235 rpv = SvPV_const(right, rlen);
236 rbyte = !DO_UTF8(right);
237 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
238 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
244 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
245 lbyte = !DO_UTF8(left);
246 sv_setpvn(TARG, lpv, llen);
252 else { /* TARG == left */
254 SvGETMAGIC(left); /* or mg_get(left) may happen here */
256 if (left == right && ckWARN(WARN_UNINITIALIZED))
257 report_uninit(right);
258 sv_setpvn(left, "", 0);
260 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
261 lbyte = !DO_UTF8(left);
266 /* or mg_get(right) may happen here */
268 rpv = SvPV_const(right, rlen);
269 rbyte = !DO_UTF8(right);
271 if (lbyte != rbyte) {
273 sv_utf8_upgrade_nomg(TARG);
276 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
277 sv_utf8_upgrade_nomg(right);
278 rpv = SvPV_const(right, rlen);
281 sv_catpvn_nomg(TARG, rpv, rlen);
292 if (PL_op->op_flags & OPf_MOD) {
293 if (PL_op->op_private & OPpLVAL_INTRO)
294 if (!(PL_op->op_private & OPpPAD_STATE))
295 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
296 if (PL_op->op_private & OPpDEREF) {
298 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
308 tryAMAGICunTARGET(iter, 0);
309 PL_last_in_gv = (GV*)(*PL_stack_sp--);
310 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
311 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
312 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
315 XPUSHs((SV*)PL_last_in_gv);
318 PL_last_in_gv = (GV*)(*PL_stack_sp--);
321 return do_readline();
326 dVAR; dSP; tryAMAGICbinSET(eq,0);
327 #ifndef NV_PRESERVES_UV
328 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
330 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
334 #ifdef PERL_PRESERVE_IVUV
337 /* Unless the left argument is integer in range we are going
338 to have to use NV maths. Hence only attempt to coerce the
339 right argument if we know the left is integer. */
342 const bool auvok = SvUOK(TOPm1s);
343 const bool buvok = SvUOK(TOPs);
345 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
346 /* Casting IV to UV before comparison isn't going to matter
347 on 2s complement. On 1s complement or sign&magnitude
348 (if we have any of them) it could to make negative zero
349 differ from normal zero. As I understand it. (Need to
350 check - is negative zero implementation defined behaviour
352 const UV buv = SvUVX(POPs);
353 const UV auv = SvUVX(TOPs);
355 SETs(boolSV(auv == buv));
358 { /* ## Mixed IV,UV ## */
362 /* == is commutative so doesn't matter which is left or right */
364 /* top of stack (b) is the iv */
373 /* As uv is a UV, it's >0, so it cannot be == */
376 /* we know iv is >= 0 */
377 SETs(boolSV((UV)iv == SvUVX(uvp)));
384 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
386 if (Perl_isnan(left) || Perl_isnan(right))
388 SETs(boolSV(left == right));
391 SETs(boolSV(TOPn == value));
400 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
401 DIE(aTHX_ PL_no_modify);
402 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
403 && SvIVX(TOPs) != IV_MAX)
405 SvIV_set(TOPs, SvIVX(TOPs) + 1);
406 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
408 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
420 if (PL_op->op_type == OP_OR)
422 RETURNOP(cLOGOP->op_other);
431 const int op_type = PL_op->op_type;
432 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
436 if (!sv || !SvANY(sv)) {
437 if (op_type == OP_DOR)
439 RETURNOP(cLOGOP->op_other);
445 if (!sv || !SvANY(sv))
450 switch (SvTYPE(sv)) {
452 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
456 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
460 if (CvROOT(sv) || CvXSUB(sv))
473 if(op_type == OP_DOR)
475 RETURNOP(cLOGOP->op_other);
477 /* assuming OP_DEFINED */
485 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
486 tryAMAGICbin(add,opASSIGN);
487 svl = sv_2num(TOPm1s);
489 useleft = USE_LEFT(svl);
490 #ifdef PERL_PRESERVE_IVUV
491 /* We must see if we can perform the addition with integers if possible,
492 as the integer code detects overflow while the NV code doesn't.
493 If either argument hasn't had a numeric conversion yet attempt to get
494 the IV. It's important to do this now, rather than just assuming that
495 it's not IOK as a PV of "9223372036854775806" may not take well to NV
496 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
497 integer in case the second argument is IV=9223372036854775806
498 We can (now) rely on sv_2iv to do the right thing, only setting the
499 public IOK flag if the value in the NV (or PV) slot is truly integer.
501 A side effect is that this also aggressively prefers integer maths over
502 fp maths for integer values.
504 How to detect overflow?
506 C 99 section 6.2.6.1 says
508 The range of nonnegative values of a signed integer type is a subrange
509 of the corresponding unsigned integer type, and the representation of
510 the same value in each type is the same. A computation involving
511 unsigned operands can never overflow, because a result that cannot be
512 represented by the resulting unsigned integer type is reduced modulo
513 the number that is one greater than the largest value that can be
514 represented by the resulting type.
518 which I read as "unsigned ints wrap."
520 signed integer overflow seems to be classed as "exception condition"
522 If an exceptional condition occurs during the evaluation of an
523 expression (that is, if the result is not mathematically defined or not
524 in the range of representable values for its type), the behavior is
527 (6.5, the 5th paragraph)
529 I had assumed that on 2s complement machines signed arithmetic would
530 wrap, hence coded pp_add and pp_subtract on the assumption that
531 everything perl builds on would be happy. After much wailing and
532 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
533 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
534 unsigned code below is actually shorter than the old code. :-)
539 /* Unless the left argument is integer in range we are going to have to
540 use NV maths. Hence only attempt to coerce the right argument if
541 we know the left is integer. */
549 /* left operand is undef, treat as zero. + 0 is identity,
550 Could SETi or SETu right now, but space optimise by not adding
551 lots of code to speed up what is probably a rarish case. */
553 /* Left operand is defined, so is it IV? */
556 if ((auvok = SvUOK(svl)))
559 register const IV aiv = SvIVX(svl);
562 auvok = 1; /* Now acting as a sign flag. */
563 } else { /* 2s complement assumption for IV_MIN */
571 bool result_good = 0;
574 bool buvok = SvUOK(svr);
579 register const IV biv = SvIVX(svr);
586 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
587 else "IV" now, independent of how it came in.
588 if a, b represents positive, A, B negative, a maps to -A etc
593 all UV maths. negate result if A negative.
594 add if signs same, subtract if signs differ. */
600 /* Must get smaller */
606 /* result really should be -(auv-buv). as its negation
607 of true value, need to swap our result flag */
624 if (result <= (UV)IV_MIN)
627 /* result valid, but out of range for IV. */
632 } /* Overflow, drop through to NVs. */
637 NV value = SvNV(svr);
640 /* left operand is undef, treat as zero. + 0.0 is identity. */
644 SETn( value + SvNV(svl) );
652 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
653 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
654 const U32 lval = PL_op->op_flags & OPf_MOD;
655 SV** const svp = av_fetch(av, PL_op->op_private, lval);
656 SV *sv = (svp ? *svp : &PL_sv_undef);
658 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
659 sv = sv_mortalcopy(sv);
666 dVAR; dSP; dMARK; dTARGET;
668 do_join(TARG, *MARK, MARK, SP);
679 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
680 * will be enough to hold an OP*.
682 SV* const sv = sv_newmortal();
683 sv_upgrade(sv, SVt_PVLV);
685 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
693 /* Oversized hot code. */
697 dVAR; dSP; dMARK; dORIGMARK;
701 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
703 if (gv && (io = GvIO(gv))
704 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
707 if (MARK == ORIGMARK) {
708 /* If using default handle then we need to make space to
709 * pass object as 1st arg, so move other args up ...
713 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
717 *MARK = SvTIED_obj((SV*)io, mg);
720 if( PL_op->op_type == OP_SAY ) {
721 /* local $\ = "\n" */
722 SAVEGENERICSV(PL_ors_sv);
723 PL_ors_sv = newSVpvs("\n");
725 call_method("PRINT", G_SCALAR);
733 if (!(io = GvIO(gv))) {
734 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
735 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
737 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
738 report_evil_fh(gv, io, PL_op->op_type);
739 SETERRNO(EBADF,RMS_IFI);
742 else if (!(fp = IoOFP(io))) {
743 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
745 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
746 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
747 report_evil_fh(gv, io, PL_op->op_type);
749 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
754 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
756 if (!do_print(*MARK, fp))
760 if (!do_print(PL_ofs_sv, fp)) { /* $, */
769 if (!do_print(*MARK, fp))
777 if (PL_op->op_type == OP_SAY) {
778 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
781 else if (PL_ors_sv && SvOK(PL_ors_sv))
782 if (!do_print(PL_ors_sv, fp)) /* $\ */
785 if (IoFLAGS(io) & IOf_FLUSH)
786 if (PerlIO_flush(fp) == EOF)
796 XPUSHs(&PL_sv_undef);
803 const I32 gimme = GIMME_V;
804 static const char an_array[] = "an ARRAY";
805 static const char a_hash[] = "a HASH";
806 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
807 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
811 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
814 if (SvTYPE(sv) != type)
815 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
816 if (PL_op->op_flags & OPf_REF) {
821 if (gimme != G_ARRAY)
822 goto croak_cant_return;
826 else if (PL_op->op_flags & OPf_MOD
827 && PL_op->op_private & OPpLVAL_INTRO)
828 Perl_croak(aTHX_ PL_no_localize_ref);
831 if (SvTYPE(sv) == type) {
832 if (PL_op->op_flags & OPf_REF) {
837 if (gimme != G_ARRAY)
838 goto croak_cant_return;
846 if (SvTYPE(sv) != SVt_PVGV) {
847 if (SvGMAGICAL(sv)) {
852 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
860 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
861 if (PL_op->op_private & OPpLVAL_INTRO)
862 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
863 if (PL_op->op_flags & OPf_REF) {
868 if (gimme != G_ARRAY)
869 goto croak_cant_return;
877 AV *const av = (AV*)sv;
878 /* The guts of pp_rv2av, with no intenting change to preserve history
879 (until such time as we get tools that can do blame annotation across
880 whitespace changes. */
881 if (gimme == G_ARRAY) {
882 const I32 maxarg = AvFILL(av) + 1;
883 (void)POPs; /* XXXX May be optimized away? */
885 if (SvRMAGICAL(av)) {
887 for (i=0; i < (U32)maxarg; i++) {
888 SV ** const svp = av_fetch(av, i, FALSE);
889 /* See note in pp_helem, and bug id #27839 */
891 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
896 Copy(AvARRAY(av), SP+1, maxarg, SV*);
900 else if (gimme == G_SCALAR) {
902 const I32 maxarg = AvFILL(av) + 1;
906 /* The guts of pp_rv2hv */
907 if (gimme == G_ARRAY) { /* array wanted */
911 else if (gimme == G_SCALAR) {
913 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
921 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
922 is_pp_rv2av ? "array" : "hash");
927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
931 PERL_ARGS_ASSERT_DO_ODDBALL;
937 if (ckWARN(WARN_MISC)) {
939 if (relem == firstrelem &&
941 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
942 SvTYPE(SvRV(*relem)) == SVt_PVHV))
944 err = "Reference found where even-sized list expected";
947 err = "Odd number of elements in hash assignment";
948 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
952 didstore = hv_store_ent(hash,*relem,tmpstr,0);
953 if (SvMAGICAL(hash)) {
954 if (SvSMAGICAL(tmpstr))
966 SV **lastlelem = PL_stack_sp;
967 SV **lastrelem = PL_stack_base + POPMARK;
968 SV **firstrelem = PL_stack_base + POPMARK + 1;
969 SV **firstlelem = lastrelem + 1;
982 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
984 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
987 /* If there's a common identifier on both sides we have to take
988 * special care that assigning the identifier on the left doesn't
989 * clobber a value on the right that's used later in the list.
991 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
992 EXTEND_MORTAL(lastrelem - firstrelem + 1);
993 for (relem = firstrelem; relem <= lastrelem; relem++) {
995 TAINT_NOT; /* Each item is independent */
996 *relem = sv_mortalcopy(sv);
1006 while (lelem <= lastlelem) {
1007 TAINT_NOT; /* Each item stands on its own, taintwise. */
1009 switch (SvTYPE(sv)) {
1012 magic = SvMAGICAL(ary) != 0;
1014 av_extend(ary, lastrelem - relem);
1016 while (relem <= lastrelem) { /* gobble up all the rest */
1019 sv = newSVsv(*relem);
1021 didstore = av_store(ary,i++,sv);
1023 if (SvSMAGICAL(sv)) {
1024 /* More magic can happen in the mg_set callback, so we
1025 * backup the delaymagic for now. */
1026 U16 dmbak = PL_delaymagic;
1029 PL_delaymagic = dmbak;
1036 if (PL_delaymagic & DM_ARRAY)
1037 SvSETMAGIC((SV*)ary);
1039 case SVt_PVHV: { /* normal hash */
1043 magic = SvMAGICAL(hash) != 0;
1045 firsthashrelem = relem;
1047 while (relem < lastrelem) { /* gobble up all the rest */
1049 sv = *relem ? *relem : &PL_sv_no;
1053 sv_setsv(tmpstr,*relem); /* value */
1054 *(relem++) = tmpstr;
1055 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1056 /* key overwrites an existing entry */
1058 didstore = hv_store_ent(hash,sv,tmpstr,0);
1060 if (SvSMAGICAL(tmpstr)) {
1061 U16 dmbak = PL_delaymagic;
1064 PL_delaymagic = dmbak;
1071 if (relem == lastrelem) {
1072 do_oddball(hash, relem, firstrelem);
1078 if (SvIMMORTAL(sv)) {
1079 if (relem <= lastrelem)
1083 if (relem <= lastrelem) {
1084 sv_setsv(sv, *relem);
1088 sv_setsv(sv, &PL_sv_undef);
1090 if (SvSMAGICAL(sv)) {
1091 U16 dmbak = PL_delaymagic;
1094 PL_delaymagic = dmbak;
1099 if (PL_delaymagic & ~DM_DELAY) {
1100 if (PL_delaymagic & DM_UID) {
1101 #ifdef HAS_SETRESUID
1102 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1103 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1106 # ifdef HAS_SETREUID
1107 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1108 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1111 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1112 (void)setruid(PL_uid);
1113 PL_delaymagic &= ~DM_RUID;
1115 # endif /* HAS_SETRUID */
1117 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1118 (void)seteuid(PL_euid);
1119 PL_delaymagic &= ~DM_EUID;
1121 # endif /* HAS_SETEUID */
1122 if (PL_delaymagic & DM_UID) {
1123 if (PL_uid != PL_euid)
1124 DIE(aTHX_ "No setreuid available");
1125 (void)PerlProc_setuid(PL_uid);
1127 # endif /* HAS_SETREUID */
1128 #endif /* HAS_SETRESUID */
1129 PL_uid = PerlProc_getuid();
1130 PL_euid = PerlProc_geteuid();
1132 if (PL_delaymagic & DM_GID) {
1133 #ifdef HAS_SETRESGID
1134 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1135 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1138 # ifdef HAS_SETREGID
1139 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1140 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1143 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1144 (void)setrgid(PL_gid);
1145 PL_delaymagic &= ~DM_RGID;
1147 # endif /* HAS_SETRGID */
1149 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1150 (void)setegid(PL_egid);
1151 PL_delaymagic &= ~DM_EGID;
1153 # endif /* HAS_SETEGID */
1154 if (PL_delaymagic & DM_GID) {
1155 if (PL_gid != PL_egid)
1156 DIE(aTHX_ "No setregid available");
1157 (void)PerlProc_setgid(PL_gid);
1159 # endif /* HAS_SETREGID */
1160 #endif /* HAS_SETRESGID */
1161 PL_gid = PerlProc_getgid();
1162 PL_egid = PerlProc_getegid();
1164 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1168 if (gimme == G_VOID)
1169 SP = firstrelem - 1;
1170 else if (gimme == G_SCALAR) {
1173 SETi(lastrelem - firstrelem + 1 - duplicates);
1180 /* Removes from the stack the entries which ended up as
1181 * duplicated keys in the hash (fix for [perl #24380]) */
1182 Move(firsthashrelem + duplicates,
1183 firsthashrelem, duplicates, SV**);
1184 lastrelem -= duplicates;
1189 SP = firstrelem + (lastlelem - firstlelem);
1190 lelem = firstlelem + (relem - firstrelem);
1192 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1201 register PMOP * const pm = cPMOP;
1202 REGEXP * rx = PM_GETRE(pm);
1203 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1204 SV * const rv = sv_newmortal();
1206 SvUPGRADE(rv, SVt_IV);
1207 /* This RV is about to own a reference to the regexp. (In addition to the
1208 reference already owned by the PMOP. */
1210 SvRV_set(rv, (SV*) rx);
1214 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1215 (void)sv_bless(rv, stash);
1218 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1227 register PMOP *pm = cPMOP;
1229 register const char *t;
1230 register const char *s;
1233 U8 r_flags = REXEC_CHECKED;
1234 const char *truebase; /* Start of string */
1235 register REGEXP *rx = PM_GETRE(pm);
1237 const I32 gimme = GIMME;
1240 const I32 oldsave = PL_savestack_ix;
1241 I32 update_minmatch = 1;
1242 I32 had_zerolen = 0;
1245 if (PL_op->op_flags & OPf_STACKED)
1247 else if (PL_op->op_private & OPpTARGET_MY)
1254 PUTBACK; /* EVAL blocks need stack_sp. */
1255 s = SvPV_const(TARG, len);
1257 DIE(aTHX_ "panic: pp_match");
1259 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1260 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1263 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1265 /* PMdf_USED is set after a ?? matches once */
1268 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1270 pm->op_pmflags & PMf_USED
1274 if (gimme == G_ARRAY)
1281 /* empty pattern special-cased to use last successful pattern if possible */
1282 if (!RX_PRELEN(rx) && PL_curpm) {
1287 if (RX_MINLEN(rx) > (I32)len)
1292 /* XXXX What part of this is needed with true \G-support? */
1293 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1294 RX_OFFS(rx)[0].start = -1;
1295 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1296 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1297 if (mg && mg->mg_len >= 0) {
1298 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1299 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1300 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1301 r_flags |= REXEC_IGNOREPOS;
1302 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1303 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1306 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1307 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1308 update_minmatch = 0;
1312 /* XXX: comment out !global get safe $1 vars after a
1313 match, BUT be aware that this leads to dramatic slowdowns on
1314 /g matches against large strings. So far a solution to this problem
1315 appears to be quite tricky.
1316 Test for the unsafe vars are TODO for now. */
1317 if (( !global && RX_NPARENS(rx))
1318 || SvTEMP(TARG) || PL_sawampersand ||
1319 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1320 r_flags |= REXEC_COPY_STR;
1322 r_flags |= REXEC_SCREAM;
1325 if (global && RX_OFFS(rx)[0].start != -1) {
1326 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1327 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1329 if (update_minmatch++)
1330 minmatch = had_zerolen;
1332 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1333 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1334 /* FIXME - can PL_bostr be made const char *? */
1335 PL_bostr = (char *)truebase;
1336 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1340 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1342 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1343 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1344 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1345 && (r_flags & REXEC_SCREAM)))
1346 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1349 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1350 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1353 if (dynpm->op_pmflags & PMf_ONCE) {
1355 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1357 dynpm->op_pmflags |= PMf_USED;
1368 RX_MATCH_TAINTED_on(rx);
1369 TAINT_IF(RX_MATCH_TAINTED(rx));
1370 if (gimme == G_ARRAY) {
1371 const I32 nparens = RX_NPARENS(rx);
1372 I32 i = (global && !nparens) ? 1 : 0;
1374 SPAGAIN; /* EVAL blocks could move the stack. */
1375 EXTEND(SP, nparens + i);
1376 EXTEND_MORTAL(nparens + i);
1377 for (i = !i; i <= nparens; i++) {
1378 PUSHs(sv_newmortal());
1379 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1380 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1381 s = RX_OFFS(rx)[i].start + truebase;
1382 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1383 len < 0 || len > strend - s)
1384 DIE(aTHX_ "panic: pp_match start/end pointers");
1385 sv_setpvn(*SP, s, len);
1386 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1391 if (dynpm->op_pmflags & PMf_CONTINUE) {
1393 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1394 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1396 #ifdef PERL_OLD_COPY_ON_WRITE
1398 sv_force_normal_flags(TARG, 0);
1400 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1401 &PL_vtbl_mglob, NULL, 0);
1403 if (RX_OFFS(rx)[0].start != -1) {
1404 mg->mg_len = RX_OFFS(rx)[0].end;
1405 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1406 mg->mg_flags |= MGf_MINMATCH;
1408 mg->mg_flags &= ~MGf_MINMATCH;
1411 had_zerolen = (RX_OFFS(rx)[0].start != -1
1412 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1413 == (UV)RX_OFFS(rx)[0].end));
1414 PUTBACK; /* EVAL blocks may use stack */
1415 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1420 LEAVE_SCOPE(oldsave);
1426 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1427 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1431 #ifdef PERL_OLD_COPY_ON_WRITE
1433 sv_force_normal_flags(TARG, 0);
1435 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1436 &PL_vtbl_mglob, NULL, 0);
1438 if (RX_OFFS(rx)[0].start != -1) {
1439 mg->mg_len = RX_OFFS(rx)[0].end;
1440 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1441 mg->mg_flags |= MGf_MINMATCH;
1443 mg->mg_flags &= ~MGf_MINMATCH;
1446 LEAVE_SCOPE(oldsave);
1450 yup: /* Confirmed by INTUIT */
1452 RX_MATCH_TAINTED_on(rx);
1453 TAINT_IF(RX_MATCH_TAINTED(rx));
1455 if (dynpm->op_pmflags & PMf_ONCE) {
1457 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1459 dynpm->op_pmflags |= PMf_USED;
1462 if (RX_MATCH_COPIED(rx))
1463 Safefree(RX_SUBBEG(rx));
1464 RX_MATCH_COPIED_off(rx);
1465 RX_SUBBEG(rx) = NULL;
1467 /* FIXME - should rx->subbeg be const char *? */
1468 RX_SUBBEG(rx) = (char *) truebase;
1469 RX_OFFS(rx)[0].start = s - truebase;
1470 if (RX_MATCH_UTF8(rx)) {
1471 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1472 RX_OFFS(rx)[0].end = t - truebase;
1475 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1477 RX_SUBLEN(rx) = strend - truebase;
1480 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1482 #ifdef PERL_OLD_COPY_ON_WRITE
1483 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1485 PerlIO_printf(Perl_debug_log,
1486 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1487 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1490 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1492 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1493 assert (SvPOKp(RX_SAVED_COPY(rx)));
1498 RX_SUBBEG(rx) = savepvn(t, strend - t);
1499 #ifdef PERL_OLD_COPY_ON_WRITE
1500 RX_SAVED_COPY(rx) = NULL;
1503 RX_SUBLEN(rx) = strend - t;
1504 RX_MATCH_COPIED_on(rx);
1505 off = RX_OFFS(rx)[0].start = s - t;
1506 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1508 else { /* startp/endp are used by @- @+. */
1509 RX_OFFS(rx)[0].start = s - truebase;
1510 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1512 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1514 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1515 LEAVE_SCOPE(oldsave);
1520 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1521 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1522 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1527 LEAVE_SCOPE(oldsave);
1528 if (gimme == G_ARRAY)
1534 Perl_do_readline(pTHX)
1536 dVAR; dSP; dTARGETSTACKED;
1541 register IO * const io = GvIO(PL_last_in_gv);
1542 register const I32 type = PL_op->op_type;
1543 const I32 gimme = GIMME_V;
1546 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1549 XPUSHs(SvTIED_obj((SV*)io, mg));
1552 call_method("READLINE", gimme);
1555 if (gimme == G_SCALAR) {
1556 SV* const result = POPs;
1557 SvSetSV_nosteal(TARG, result);
1567 if (IoFLAGS(io) & IOf_ARGV) {
1568 if (IoFLAGS(io) & IOf_START) {
1570 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1571 IoFLAGS(io) &= ~IOf_START;
1572 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1573 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1574 SvSETMAGIC(GvSV(PL_last_in_gv));
1579 fp = nextargv(PL_last_in_gv);
1580 if (!fp) { /* Note: fp != IoIFP(io) */
1581 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1584 else if (type == OP_GLOB)
1585 fp = Perl_start_glob(aTHX_ POPs, io);
1587 else if (type == OP_GLOB)
1589 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1590 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1594 if ((!io || !(IoFLAGS(io) & IOf_START))
1595 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1597 if (type == OP_GLOB)
1598 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1599 "glob failed (can't start child: %s)",
1602 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1604 if (gimme == G_SCALAR) {
1605 /* undef TARG, and push that undefined value */
1606 if (type != OP_RCATLINE) {
1607 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1615 if (gimme == G_SCALAR) {
1617 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1620 if (type == OP_RCATLINE)
1621 SvPV_force_nolen(sv);
1625 else if (isGV_with_GP(sv)) {
1626 SvPV_force_nolen(sv);
1628 SvUPGRADE(sv, SVt_PV);
1629 tmplen = SvLEN(sv); /* remember if already alloced */
1630 if (!tmplen && !SvREADONLY(sv))
1631 Sv_Grow(sv, 80); /* try short-buffering it */
1633 if (type == OP_RCATLINE && SvOK(sv)) {
1635 SvPV_force_nolen(sv);
1641 sv = sv_2mortal(newSV(80));
1645 /* This should not be marked tainted if the fp is marked clean */
1646 #define MAYBE_TAINT_LINE(io, sv) \
1647 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1652 /* delay EOF state for a snarfed empty file */
1653 #define SNARF_EOF(gimme,rs,io,sv) \
1654 (gimme != G_SCALAR || SvCUR(sv) \
1655 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1659 if (!sv_gets(sv, fp, offset)
1661 || SNARF_EOF(gimme, PL_rs, io, sv)
1662 || PerlIO_error(fp)))
1664 PerlIO_clearerr(fp);
1665 if (IoFLAGS(io) & IOf_ARGV) {
1666 fp = nextargv(PL_last_in_gv);
1669 (void)do_close(PL_last_in_gv, FALSE);
1671 else if (type == OP_GLOB) {
1672 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1673 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1674 "glob failed (child exited with status %d%s)",
1675 (int)(STATUS_CURRENT >> 8),
1676 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1679 if (gimme == G_SCALAR) {
1680 if (type != OP_RCATLINE) {
1681 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1687 MAYBE_TAINT_LINE(io, sv);
1690 MAYBE_TAINT_LINE(io, sv);
1692 IoFLAGS(io) |= IOf_NOLINE;
1696 if (type == OP_GLOB) {
1699 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1700 char * const tmps = SvEND(sv) - 1;
1701 if (*tmps == *SvPVX_const(PL_rs)) {
1703 SvCUR_set(sv, SvCUR(sv) - 1);
1706 for (t1 = SvPVX_const(sv); *t1; t1++)
1707 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1708 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1710 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1711 (void)POPs; /* Unmatched wildcard? Chuck it... */
1714 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1715 if (ckWARN(WARN_UTF8)) {
1716 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1717 const STRLEN len = SvCUR(sv) - offset;
1720 if (!is_utf8_string_loc(s, len, &f))
1721 /* Emulate :encoding(utf8) warning in the same case. */
1722 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1723 "utf8 \"\\x%02X\" does not map to Unicode",
1724 f < (U8*)SvEND(sv) ? *f : 0);
1727 if (gimme == G_ARRAY) {
1728 if (SvLEN(sv) - SvCUR(sv) > 20) {
1729 SvPV_shrink_to_cur(sv);
1731 sv = sv_2mortal(newSV(80));
1734 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1735 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1736 const STRLEN new_len
1737 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1738 SvPV_renew(sv, new_len);
1747 register PERL_CONTEXT *cx;
1748 I32 gimme = OP_GIMME(PL_op, -1);
1751 if (cxstack_ix >= 0)
1752 gimme = cxstack[cxstack_ix].blk_gimme;
1760 PUSHBLOCK(cx, CXt_BLOCK, SP);
1770 SV * const keysv = POPs;
1771 HV * const hv = (HV*)POPs;
1772 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1773 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1775 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1778 if (SvTYPE(hv) != SVt_PVHV)
1781 if (PL_op->op_private & OPpLVAL_INTRO) {
1784 /* does the element we're localizing already exist? */
1785 preeminent = /* can we determine whether it exists? */
1787 || mg_find((SV*)hv, PERL_MAGIC_env)
1788 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1789 /* Try to preserve the existenceness of a tied hash
1790 * element by using EXISTS and DELETE if possible.
1791 * Fallback to FETCH and STORE otherwise */
1792 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1793 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1794 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1796 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1798 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1799 svp = he ? &HeVAL(he) : NULL;
1801 if (!svp || *svp == &PL_sv_undef) {
1805 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1807 lv = sv_newmortal();
1808 sv_upgrade(lv, SVt_PVLV);
1810 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1811 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1812 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1817 if (PL_op->op_private & OPpLVAL_INTRO) {
1818 if (HvNAME_get(hv) && isGV(*svp))
1819 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1823 const char * const key = SvPV_const(keysv, keylen);
1824 SAVEDELETE(hv, savepvn(key,keylen),
1825 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1827 save_helem(hv, keysv, svp);
1830 else if (PL_op->op_private & OPpDEREF)
1831 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1833 sv = (svp ? *svp : &PL_sv_undef);
1834 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1835 * Pushing the magical RHS on to the stack is useless, since
1836 * that magic is soon destined to be misled by the local(),
1837 * and thus the later pp_sassign() will fail to mg_get() the
1838 * old value. This should also cure problems with delayed
1839 * mg_get()s. GSAR 98-07-03 */
1840 if (!lval && SvGMAGICAL(sv))
1841 sv = sv_mortalcopy(sv);
1849 register PERL_CONTEXT *cx;
1854 if (PL_op->op_flags & OPf_SPECIAL) {
1855 cx = &cxstack[cxstack_ix];
1856 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1861 gimme = OP_GIMME(PL_op, -1);
1863 if (cxstack_ix >= 0)
1864 gimme = cxstack[cxstack_ix].blk_gimme;
1870 if (gimme == G_VOID)
1872 else if (gimme == G_SCALAR) {
1876 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1879 *MARK = sv_mortalcopy(TOPs);
1882 *MARK = &PL_sv_undef;
1886 else if (gimme == G_ARRAY) {
1887 /* in case LEAVE wipes old return values */
1889 for (mark = newsp + 1; mark <= SP; mark++) {
1890 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1891 *mark = sv_mortalcopy(*mark);
1892 TAINT_NOT; /* Each item is independent */
1896 PL_curpm = newpm; /* Don't pop $1 et al till now */
1906 register PERL_CONTEXT *cx;
1909 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1910 bool av_is_stack = FALSE;
1913 cx = &cxstack[cxstack_ix];
1914 if (!CxTYPE_is_LOOP(cx))
1915 DIE(aTHX_ "panic: pp_iter");
1917 itersvp = CxITERVAR(cx);
1918 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1919 /* string increment */
1920 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1921 SV *end = cx->blk_loop.state_u.lazysv.end;
1922 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1923 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1925 const char *max = SvPV_const(end, maxlen);
1926 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1927 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1928 /* safe to reuse old SV */
1929 sv_setsv(*itersvp, cur);
1933 /* we need a fresh SV every time so that loop body sees a
1934 * completely new SV for closures/references to work as
1937 *itersvp = newSVsv(cur);
1938 SvREFCNT_dec(oldsv);
1940 if (strEQ(SvPVX_const(cur), max))
1941 sv_setiv(cur, 0); /* terminate next time */
1948 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1949 /* integer increment */
1950 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1953 /* don't risk potential race */
1954 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1955 /* safe to reuse old SV */
1956 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1960 /* we need a fresh SV every time so that loop body sees a
1961 * completely new SV for closures/references to work as they
1964 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1965 SvREFCNT_dec(oldsv);
1968 /* Handle end of range at IV_MAX */
1969 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1970 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1972 cx->blk_loop.state_u.lazyiv.cur++;
1973 cx->blk_loop.state_u.lazyiv.end++;
1980 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1981 av = cx->blk_loop.state_u.ary.ary;
1986 if (PL_op->op_private & OPpITER_REVERSED) {
1987 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1988 ? cx->blk_loop.resetsp + 1 : 0))
1991 if (SvMAGICAL(av) || AvREIFY(av)) {
1992 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1993 sv = svp ? *svp : NULL;
1996 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2000 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2004 if (SvMAGICAL(av) || AvREIFY(av)) {
2005 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2006 sv = svp ? *svp : NULL;
2009 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2013 if (sv && SvIS_FREED(sv)) {
2015 Perl_croak(aTHX_ "Use of freed value in iteration");
2020 SvREFCNT_inc_simple_void_NN(sv);
2024 if (!av_is_stack && sv == &PL_sv_undef) {
2025 SV *lv = newSV_type(SVt_PVLV);
2027 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2028 LvTARG(lv) = SvREFCNT_inc_simple(av);
2029 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2030 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2036 SvREFCNT_dec(oldsv);
2044 register PMOP *pm = cPMOP;
2059 register REGEXP *rx = PM_GETRE(pm);
2061 int force_on_match = 0;
2062 const I32 oldsave = PL_savestack_ix;
2064 bool doutf8 = FALSE;
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2071 /* known replacement string? */
2072 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2073 if (PL_op->op_flags & OPf_STACKED)
2075 else if (PL_op->op_private & OPpTARGET_MY)
2082 #ifdef PERL_OLD_COPY_ON_WRITE
2083 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2084 because they make integers such as 256 "false". */
2085 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2088 sv_force_normal_flags(TARG,0);
2091 #ifdef PERL_OLD_COPY_ON_WRITE
2095 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2096 || SvTYPE(TARG) > SVt_PVLV)
2097 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2098 DIE(aTHX_ PL_no_modify);
2101 s = SvPV_mutable(TARG, len);
2102 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2104 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2105 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2110 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2114 DIE(aTHX_ "panic: pp_subst");
2117 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2118 maxiters = 2 * slen + 10; /* We can match twice at each
2119 position, once with zero-length,
2120 second time with non-zero. */
2122 if (!RX_PRELEN(rx) && PL_curpm) {
2126 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2127 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2128 ? REXEC_COPY_STR : 0;
2130 r_flags |= REXEC_SCREAM;
2133 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2135 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2139 /* How to do it in subst? */
2140 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2142 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2143 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2144 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2145 && (r_flags & REXEC_SCREAM))))
2150 /* only replace once? */
2151 once = !(rpm->op_pmflags & PMf_GLOBAL);
2152 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2153 r_flags | REXEC_CHECKED);
2154 /* known replacement string? */
2156 /* replacement needing upgrading? */
2157 if (DO_UTF8(TARG) && !doutf8) {
2158 nsv = sv_newmortal();
2161 sv_recode_to_utf8(nsv, PL_encoding);
2163 sv_utf8_upgrade(nsv);
2164 c = SvPV_const(nsv, clen);
2168 c = SvPV_const(dstr, clen);
2169 doutf8 = DO_UTF8(dstr);
2177 /* can do inplace substitution? */
2179 #ifdef PERL_OLD_COPY_ON_WRITE
2182 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2183 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2184 && (!doutf8 || SvUTF8(TARG))) {
2189 LEAVE_SCOPE(oldsave);
2192 #ifdef PERL_OLD_COPY_ON_WRITE
2193 if (SvIsCOW(TARG)) {
2194 assert (!force_on_match);
2198 if (force_on_match) {
2200 s = SvPV_force(TARG, len);
2205 SvSCREAM_off(TARG); /* disable possible screamer */
2207 rxtainted |= RX_MATCH_TAINTED(rx);
2208 m = orig + RX_OFFS(rx)[0].start;
2209 d = orig + RX_OFFS(rx)[0].end;
2211 if (m - s > strend - d) { /* faster to shorten from end */
2213 Copy(c, m, clen, char);
2218 Move(d, m, i, char);
2222 SvCUR_set(TARG, m - s);
2224 else if ((i = m - s)) { /* faster from front */
2227 Move(s, d - i, i, char);
2230 Copy(c, m, clen, char);
2235 Copy(c, d, clen, char);
2240 TAINT_IF(rxtainted & 1);
2246 if (iters++ > maxiters)
2247 DIE(aTHX_ "Substitution loop");
2248 rxtainted |= RX_MATCH_TAINTED(rx);
2249 m = RX_OFFS(rx)[0].start + orig;
2252 Move(s, d, i, char);
2256 Copy(c, d, clen, char);
2259 s = RX_OFFS(rx)[0].end + orig;
2260 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2262 /* don't match same null twice */
2263 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2266 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2267 Move(s, d, i+1, char); /* include the NUL */
2269 TAINT_IF(rxtainted & 1);
2273 (void)SvPOK_only_UTF8(TARG);
2274 TAINT_IF(rxtainted);
2275 if (SvSMAGICAL(TARG)) {
2283 LEAVE_SCOPE(oldsave);
2289 if (force_on_match) {
2291 s = SvPV_force(TARG, len);
2294 #ifdef PERL_OLD_COPY_ON_WRITE
2297 rxtainted |= RX_MATCH_TAINTED(rx);
2298 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2302 register PERL_CONTEXT *cx;
2305 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2307 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2309 if (iters++ > maxiters)
2310 DIE(aTHX_ "Substitution loop");
2311 rxtainted |= RX_MATCH_TAINTED(rx);
2312 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2315 orig = RX_SUBBEG(rx);
2317 strend = s + (strend - m);
2319 m = RX_OFFS(rx)[0].start + orig;
2320 if (doutf8 && !SvUTF8(dstr))
2321 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2323 sv_catpvn(dstr, s, m-s);
2324 s = RX_OFFS(rx)[0].end + orig;
2326 sv_catpvn(dstr, c, clen);
2329 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2330 TARG, NULL, r_flags));
2331 if (doutf8 && !DO_UTF8(TARG))
2332 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2334 sv_catpvn(dstr, s, strend - s);
2336 #ifdef PERL_OLD_COPY_ON_WRITE
2337 /* The match may make the string COW. If so, brilliant, because that's
2338 just saved us one malloc, copy and free - the regexp has donated
2339 the old buffer, and we malloc an entirely new one, rather than the
2340 regexp malloc()ing a buffer and copying our original, only for
2341 us to throw it away here during the substitution. */
2342 if (SvIsCOW(TARG)) {
2343 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2349 SvPV_set(TARG, SvPVX(dstr));
2350 SvCUR_set(TARG, SvCUR(dstr));
2351 SvLEN_set(TARG, SvLEN(dstr));
2352 doutf8 |= DO_UTF8(dstr);
2353 SvPV_set(dstr, NULL);
2355 TAINT_IF(rxtainted & 1);
2359 (void)SvPOK_only(TARG);
2362 TAINT_IF(rxtainted);
2365 LEAVE_SCOPE(oldsave);
2374 LEAVE_SCOPE(oldsave);
2383 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2384 ++*PL_markstack_ptr;
2385 LEAVE; /* exit inner scope */
2388 if (PL_stack_base + *PL_markstack_ptr > SP) {
2390 const I32 gimme = GIMME_V;
2392 LEAVE; /* exit outer scope */
2393 (void)POPMARK; /* pop src */
2394 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2395 (void)POPMARK; /* pop dst */
2396 SP = PL_stack_base + POPMARK; /* pop original mark */
2397 if (gimme == G_SCALAR) {
2398 if (PL_op->op_private & OPpGREP_LEX) {
2399 SV* const sv = sv_newmortal();
2400 sv_setiv(sv, items);
2408 else if (gimme == G_ARRAY)
2415 ENTER; /* enter inner scope */
2418 src = PL_stack_base[*PL_markstack_ptr];
2420 if (PL_op->op_private & OPpGREP_LEX)
2421 PAD_SVl(PL_op->op_targ) = src;
2425 RETURNOP(cLOGOP->op_other);
2436 register PERL_CONTEXT *cx;
2439 if (CxMULTICALL(&cxstack[cxstack_ix]))
2443 cxstack_ix++; /* temporarily protect top context */
2446 if (gimme == G_SCALAR) {
2449 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2451 *MARK = SvREFCNT_inc(TOPs);
2456 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2458 *MARK = sv_mortalcopy(sv);
2463 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2467 *MARK = &PL_sv_undef;
2471 else if (gimme == G_ARRAY) {
2472 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2473 if (!SvTEMP(*MARK)) {
2474 *MARK = sv_mortalcopy(*MARK);
2475 TAINT_NOT; /* Each item is independent */
2483 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2484 PL_curpm = newpm; /* ... and pop $1 et al */
2487 return cx->blk_sub.retop;
2490 /* This duplicates the above code because the above code must not
2491 * get any slower by more conditions */
2499 register PERL_CONTEXT *cx;
2502 if (CxMULTICALL(&cxstack[cxstack_ix]))
2506 cxstack_ix++; /* temporarily protect top context */
2510 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2511 /* We are an argument to a function or grep().
2512 * This kind of lvalueness was legal before lvalue
2513 * subroutines too, so be backward compatible:
2514 * cannot report errors. */
2516 /* Scalar context *is* possible, on the LHS of -> only,
2517 * as in f()->meth(). But this is not an lvalue. */
2518 if (gimme == G_SCALAR)
2520 if (gimme == G_ARRAY) {
2521 if (!CvLVALUE(cx->blk_sub.cv))
2522 goto temporise_array;
2523 EXTEND_MORTAL(SP - newsp);
2524 for (mark = newsp + 1; mark <= SP; mark++) {
2527 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2528 *mark = sv_mortalcopy(*mark);
2530 /* Can be a localized value subject to deletion. */
2531 PL_tmps_stack[++PL_tmps_ix] = *mark;
2532 SvREFCNT_inc_void(*mark);
2537 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2538 /* Here we go for robustness, not for speed, so we change all
2539 * the refcounts so the caller gets a live guy. Cannot set
2540 * TEMP, so sv_2mortal is out of question. */
2541 if (!CvLVALUE(cx->blk_sub.cv)) {
2547 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2549 if (gimme == G_SCALAR) {
2553 /* Temporaries are bad unless they happen to be elements
2554 * of a tied hash or array */
2555 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2556 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2562 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2563 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2564 : "a readonly value" : "a temporary");
2566 else { /* Can be a localized value
2567 * subject to deletion. */
2568 PL_tmps_stack[++PL_tmps_ix] = *mark;
2569 SvREFCNT_inc_void(*mark);
2572 else { /* Should not happen? */
2578 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2579 (MARK > SP ? "Empty array" : "Array"));
2583 else if (gimme == G_ARRAY) {
2584 EXTEND_MORTAL(SP - newsp);
2585 for (mark = newsp + 1; mark <= SP; mark++) {
2586 if (*mark != &PL_sv_undef
2587 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2588 /* Might be flattened array after $#array = */
2595 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2596 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2599 /* Can be a localized value subject to deletion. */
2600 PL_tmps_stack[++PL_tmps_ix] = *mark;
2601 SvREFCNT_inc_void(*mark);
2607 if (gimme == G_SCALAR) {
2611 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2613 *MARK = SvREFCNT_inc(TOPs);
2618 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2620 *MARK = sv_mortalcopy(sv);
2625 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2629 *MARK = &PL_sv_undef;
2633 else if (gimme == G_ARRAY) {
2635 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2636 if (!SvTEMP(*MARK)) {
2637 *MARK = sv_mortalcopy(*MARK);
2638 TAINT_NOT; /* Each item is independent */
2647 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2648 PL_curpm = newpm; /* ... and pop $1 et al */
2651 return cx->blk_sub.retop;
2659 register PERL_CONTEXT *cx;
2661 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2664 DIE(aTHX_ "Not a CODE reference");
2665 switch (SvTYPE(sv)) {
2666 /* This is overwhelming the most common case: */
2668 if (!(cv = GvCVu((GV*)sv))) {
2670 cv = sv_2cv(sv, &stash, &gv, 0);
2682 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2684 SP = PL_stack_base + POPMARK;
2687 if (SvGMAGICAL(sv)) {
2692 sym = SvPVX_const(sv);
2700 sym = SvPV_const(sv, len);
2703 DIE(aTHX_ PL_no_usym, "a subroutine");
2704 if (PL_op->op_private & HINT_STRICT_REFS)
2705 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2706 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2711 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2712 tryAMAGICunDEREF(to_cv);
2715 if (SvTYPE(cv) == SVt_PVCV)
2720 DIE(aTHX_ "Not a CODE reference");
2721 /* This is the second most common case: */
2731 if (!CvROOT(cv) && !CvXSUB(cv)) {
2735 /* anonymous or undef'd function leaves us no recourse */
2736 if (CvANON(cv) || !(gv = CvGV(cv)))
2737 DIE(aTHX_ "Undefined subroutine called");
2739 /* autoloaded stub? */
2740 if (cv != GvCV(gv)) {
2743 /* should call AUTOLOAD now? */
2746 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2753 sub_name = sv_newmortal();
2754 gv_efullname3(sub_name, gv, NULL);
2755 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2759 DIE(aTHX_ "Not a CODE reference");
2764 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2765 Perl_get_db_sub(aTHX_ &sv, cv);
2767 PL_curcopdb = PL_curcop;
2768 cv = GvCV(PL_DBsub);
2770 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2771 DIE(aTHX_ "No DB::sub routine defined");
2774 if (!(CvISXSUB(cv))) {
2775 /* This path taken at least 75% of the time */
2777 register I32 items = SP - MARK;
2778 AV* const padlist = CvPADLIST(cv);
2779 PUSHBLOCK(cx, CXt_SUB, MARK);
2781 cx->blk_sub.retop = PL_op->op_next;
2783 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2784 * that eval'' ops within this sub know the correct lexical space.
2785 * Owing the speed considerations, we choose instead to search for
2786 * the cv using find_runcv() when calling doeval().
2788 if (CvDEPTH(cv) >= 2) {
2789 PERL_STACK_OVERFLOW_CHECK();
2790 pad_push(padlist, CvDEPTH(cv));
2793 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2795 AV* const av = (AV*)PAD_SVl(0);
2797 /* @_ is normally not REAL--this should only ever
2798 * happen when DB::sub() calls things that modify @_ */
2803 cx->blk_sub.savearray = GvAV(PL_defgv);
2804 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2805 CX_CURPAD_SAVE(cx->blk_sub);
2806 cx->blk_sub.argarray = av;
2809 if (items > AvMAX(av) + 1) {
2810 SV **ary = AvALLOC(av);
2811 if (AvARRAY(av) != ary) {
2812 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2815 if (items > AvMAX(av) + 1) {
2816 AvMAX(av) = items - 1;
2817 Renew(ary,items,SV*);
2822 Copy(MARK,AvARRAY(av),items,SV*);
2823 AvFILLp(av) = items - 1;
2831 /* warning must come *after* we fully set up the context
2832 * stuff so that __WARN__ handlers can safely dounwind()
2835 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2836 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2837 sub_crush_depth(cv);
2838 RETURNOP(CvSTART(cv));
2841 I32 markix = TOPMARK;
2846 /* Need to copy @_ to stack. Alternative may be to
2847 * switch stack to @_, and copy return values
2848 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2849 AV * const av = GvAV(PL_defgv);
2850 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2853 /* Mark is at the end of the stack. */
2855 Copy(AvARRAY(av), SP + 1, items, SV*);
2860 /* We assume first XSUB in &DB::sub is the called one. */
2862 SAVEVPTR(PL_curcop);
2863 PL_curcop = PL_curcopdb;
2866 /* Do we need to open block here? XXXX */
2867 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2868 (void)(*CvXSUB(cv))(aTHX_ cv);
2870 /* Enforce some sanity in scalar context. */
2871 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2872 if (markix > PL_stack_sp - PL_stack_base)
2873 *(PL_stack_base + markix) = &PL_sv_undef;
2875 *(PL_stack_base + markix) = *PL_stack_sp;
2876 PL_stack_sp = PL_stack_base + markix;
2884 Perl_sub_crush_depth(pTHX_ CV *cv)
2886 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2889 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2891 SV* const tmpstr = sv_newmortal();
2892 gv_efullname3(tmpstr, CvGV(cv), NULL);
2893 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2902 SV* const elemsv = POPs;
2903 IV elem = SvIV(elemsv);
2904 AV* const av = (AV*)POPs;
2905 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2906 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2909 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2910 Perl_warner(aTHX_ packWARN(WARN_MISC),
2911 "Use of reference \"%"SVf"\" as array index",
2914 elem -= CopARYBASE_get(PL_curcop);
2915 if (SvTYPE(av) != SVt_PVAV)
2917 svp = av_fetch(av, elem, lval && !defer);
2919 #ifdef PERL_MALLOC_WRAP
2920 if (SvUOK(elemsv)) {
2921 const UV uv = SvUV(elemsv);
2922 elem = uv > IV_MAX ? IV_MAX : uv;
2924 else if (SvNOK(elemsv))
2925 elem = (IV)SvNV(elemsv);
2927 static const char oom_array_extend[] =
2928 "Out of memory during array extend"; /* Duplicated in av.c */
2929 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2932 if (!svp || *svp == &PL_sv_undef) {
2935 DIE(aTHX_ PL_no_aelem, elem);
2936 lv = sv_newmortal();
2937 sv_upgrade(lv, SVt_PVLV);
2939 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2940 LvTARG(lv) = SvREFCNT_inc_simple(av);
2941 LvTARGOFF(lv) = elem;
2946 if (PL_op->op_private & OPpLVAL_INTRO)
2947 save_aelem(av, elem, svp);
2948 else if (PL_op->op_private & OPpDEREF)
2949 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2951 sv = (svp ? *svp : &PL_sv_undef);
2952 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2953 sv = sv_mortalcopy(sv);
2959 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2961 PERL_ARGS_ASSERT_VIVIFY_REF;
2966 Perl_croak(aTHX_ PL_no_modify);
2967 prepare_SV_for_RV(sv);
2970 SvRV_set(sv, newSV(0));
2973 SvRV_set(sv, (SV*)newAV());
2976 SvRV_set(sv, (SV*)newHV());
2987 SV* const sv = TOPs;
2990 SV* const rsv = SvRV(sv);
2991 if (SvTYPE(rsv) == SVt_PVCV) {
2997 SETs(method_common(sv, NULL));
3004 SV* const sv = cSVOP_sv;
3005 U32 hash = SvSHARED_HASH(sv);
3007 XPUSHs(method_common(sv, &hash));
3012 S_method_common(pTHX_ SV* meth, U32* hashp)
3019 const char* packname = NULL;
3022 const char * const name = SvPV_const(meth, namelen);
3023 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3025 PERL_ARGS_ASSERT_METHOD_COMMON;
3028 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3036 /* this isn't a reference */
3037 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3038 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3040 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3047 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3048 !(ob=(SV*)GvIO(iogv)))
3050 /* this isn't the name of a filehandle either */
3052 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3053 ? !isIDFIRST_utf8((U8*)packname)
3054 : !isIDFIRST(*packname)
3057 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3058 SvOK(sv) ? "without a package or object reference"
3059 : "on an undefined value");
3061 /* assume it's a package name */
3062 stash = gv_stashpvn(packname, packlen, 0);
3066 SV* const ref = newSViv(PTR2IV(stash));
3067 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3071 /* it _is_ a filehandle name -- replace with a reference */
3072 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3075 /* if we got here, ob should be a reference or a glob */
3076 if (!ob || !(SvOBJECT(ob)
3077 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3080 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3081 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3085 stash = SvSTASH(ob);
3088 /* NOTE: stash may be null, hope hv_fetch_ent and
3089 gv_fetchmethod can cope (it seems they can) */
3091 /* shortcut for simple names */
3093 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3095 gv = (GV*)HeVAL(he);
3096 if (isGV(gv) && GvCV(gv) &&
3097 (!GvCVGEN(gv) || GvCVGEN(gv)
3098 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3099 return (SV*)GvCV(gv);
3103 gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
3104 GV_AUTOLOAD | GV_CROAK);
3108 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3113 * c-indentation-style: bsd
3115 * indent-tabs-mode: t
3118 * ex: set ts=8 sts=4 sw=4 noet: