3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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(MUTABLE_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(MUTABLE_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 = MUTABLE_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, MUTABLE_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 = MUTABLE_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, MUTABLE_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);
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 = MUTABLE_GV(*PL_stack_sp--);
310 if (!isGV_with_GP(PL_last_in_gv)) {
311 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
312 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
315 XPUSHs(MUTABLE_SV(PL_last_in_gv));
318 PL_last_in_gv = MUTABLE_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_PVAV || isGV_with_GP(TOPs))
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 ? MUTABLE_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*);
688 XPUSHs(MUTABLE_SV(PL_op));
693 /* Oversized hot code. */
697 dVAR; dSP; dMARK; dORIGMARK;
702 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
704 if (gv && (io = GvIO(gv))
705 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
708 if (MARK == ORIGMARK) {
709 /* If using default handle then we need to make space to
710 * pass object as 1st arg, so move other args up ...
714 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
718 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
721 if( PL_op->op_type == OP_SAY ) {
722 /* local $\ = "\n" */
723 SAVEGENERICSV(PL_ors_sv);
724 PL_ors_sv = newSVpvs("\n");
726 call_method("PRINT", G_SCALAR);
734 if (!(io = GvIO(gv))) {
735 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
736 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
738 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
739 report_evil_fh(gv, io, PL_op->op_type);
740 SETERRNO(EBADF,RMS_IFI);
743 else if (!(fp = IoOFP(io))) {
744 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
746 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
747 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
748 report_evil_fh(gv, io, PL_op->op_type);
750 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
755 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
757 if (!do_print(*MARK, fp))
761 if (!do_print(PL_ofs_sv, fp)) { /* $, */
770 if (!do_print(*MARK, fp))
778 if (PL_op->op_type == OP_SAY) {
779 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
782 else if (PL_ors_sv && SvOK(PL_ors_sv))
783 if (!do_print(PL_ors_sv, fp)) /* $\ */
786 if (IoFLAGS(io) & IOf_FLUSH)
787 if (PerlIO_flush(fp) == EOF)
797 XPUSHs(&PL_sv_undef);
804 const I32 gimme = GIMME_V;
805 static const char an_array[] = "an ARRAY";
806 static const char a_hash[] = "a HASH";
807 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
808 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
812 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
815 if (SvTYPE(sv) != type)
816 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
817 if (PL_op->op_flags & OPf_REF) {
822 if (gimme != G_ARRAY)
823 goto croak_cant_return;
827 else if (PL_op->op_flags & OPf_MOD
828 && PL_op->op_private & OPpLVAL_INTRO)
829 Perl_croak(aTHX_ PL_no_localize_ref);
832 if (SvTYPE(sv) == type) {
833 if (PL_op->op_flags & OPf_REF) {
838 if (gimme != G_ARRAY)
839 goto croak_cant_return;
847 if (!isGV_with_GP(sv)) {
848 if (SvGMAGICAL(sv)) {
853 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
861 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
862 if (PL_op->op_private & OPpLVAL_INTRO)
863 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
864 if (PL_op->op_flags & OPf_REF) {
869 if (gimme != G_ARRAY)
870 goto croak_cant_return;
878 AV *const av = MUTABLE_AV(sv);
879 /* The guts of pp_rv2av, with no intenting change to preserve history
880 (until such time as we get tools that can do blame annotation across
881 whitespace changes. */
882 if (gimme == G_ARRAY) {
883 const I32 maxarg = AvFILL(av) + 1;
884 (void)POPs; /* XXXX May be optimized away? */
886 if (SvRMAGICAL(av)) {
888 for (i=0; i < (U32)maxarg; i++) {
889 SV ** const svp = av_fetch(av, i, FALSE);
890 /* See note in pp_helem, and bug id #27839 */
892 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
897 Copy(AvARRAY(av), SP+1, maxarg, SV*);
901 else if (gimme == G_SCALAR) {
903 const I32 maxarg = AvFILL(av) + 1;
907 /* The guts of pp_rv2hv */
908 if (gimme == G_ARRAY) { /* array wanted */
912 else if (gimme == G_SCALAR) {
914 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
922 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
923 is_pp_rv2av ? "array" : "hash");
928 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
932 PERL_ARGS_ASSERT_DO_ODDBALL;
938 if (ckWARN(WARN_MISC)) {
940 if (relem == firstrelem &&
942 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
943 SvTYPE(SvRV(*relem)) == SVt_PVHV))
945 err = "Reference found where even-sized list expected";
948 err = "Odd number of elements in hash assignment";
949 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
953 didstore = hv_store_ent(hash,*relem,tmpstr,0);
954 if (SvMAGICAL(hash)) {
955 if (SvSMAGICAL(tmpstr))
967 SV **lastlelem = PL_stack_sp;
968 SV **lastrelem = PL_stack_base + POPMARK;
969 SV **firstrelem = PL_stack_base + POPMARK + 1;
970 SV **firstlelem = lastrelem + 1;
983 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
985 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
988 /* If there's a common identifier on both sides we have to take
989 * special care that assigning the identifier on the left doesn't
990 * clobber a value on the right that's used later in the list.
992 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
993 EXTEND_MORTAL(lastrelem - firstrelem + 1);
994 for (relem = firstrelem; relem <= lastrelem; relem++) {
996 TAINT_NOT; /* Each item is independent */
997 *relem = sv_mortalcopy(sv);
1007 while (lelem <= lastlelem) {
1008 TAINT_NOT; /* Each item stands on its own, taintwise. */
1010 switch (SvTYPE(sv)) {
1012 ary = MUTABLE_AV(sv);
1013 magic = SvMAGICAL(ary) != 0;
1015 av_extend(ary, lastrelem - relem);
1017 while (relem <= lastrelem) { /* gobble up all the rest */
1020 sv = newSVsv(*relem);
1022 didstore = av_store(ary,i++,sv);
1024 if (SvSMAGICAL(sv)) {
1025 /* More magic can happen in the mg_set callback, so we
1026 * backup the delaymagic for now. */
1027 U16 dmbak = PL_delaymagic;
1030 PL_delaymagic = dmbak;
1037 if (PL_delaymagic & DM_ARRAY)
1038 SvSETMAGIC(MUTABLE_SV(ary));
1040 case SVt_PVHV: { /* normal hash */
1043 hash = MUTABLE_HV(sv);
1044 magic = SvMAGICAL(hash) != 0;
1046 firsthashrelem = relem;
1048 while (relem < lastrelem) { /* gobble up all the rest */
1050 sv = *relem ? *relem : &PL_sv_no;
1054 sv_setsv(tmpstr,*relem); /* value */
1055 *(relem++) = tmpstr;
1056 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1057 /* key overwrites an existing entry */
1059 didstore = hv_store_ent(hash,sv,tmpstr,0);
1061 if (SvSMAGICAL(tmpstr)) {
1062 U16 dmbak = PL_delaymagic;
1065 PL_delaymagic = dmbak;
1072 if (relem == lastrelem) {
1073 do_oddball(hash, relem, firstrelem);
1079 if (SvIMMORTAL(sv)) {
1080 if (relem <= lastrelem)
1084 if (relem <= lastrelem) {
1085 sv_setsv(sv, *relem);
1089 sv_setsv(sv, &PL_sv_undef);
1091 if (SvSMAGICAL(sv)) {
1092 U16 dmbak = PL_delaymagic;
1095 PL_delaymagic = dmbak;
1100 if (PL_delaymagic & ~DM_DELAY) {
1101 if (PL_delaymagic & DM_UID) {
1102 #ifdef HAS_SETRESUID
1103 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1104 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1107 # ifdef HAS_SETREUID
1108 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1109 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1112 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1113 (void)setruid(PL_uid);
1114 PL_delaymagic &= ~DM_RUID;
1116 # endif /* HAS_SETRUID */
1118 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1119 (void)seteuid(PL_euid);
1120 PL_delaymagic &= ~DM_EUID;
1122 # endif /* HAS_SETEUID */
1123 if (PL_delaymagic & DM_UID) {
1124 if (PL_uid != PL_euid)
1125 DIE(aTHX_ "No setreuid available");
1126 (void)PerlProc_setuid(PL_uid);
1128 # endif /* HAS_SETREUID */
1129 #endif /* HAS_SETRESUID */
1130 PL_uid = PerlProc_getuid();
1131 PL_euid = PerlProc_geteuid();
1133 if (PL_delaymagic & DM_GID) {
1134 #ifdef HAS_SETRESGID
1135 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1136 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1139 # ifdef HAS_SETREGID
1140 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1141 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1144 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1145 (void)setrgid(PL_gid);
1146 PL_delaymagic &= ~DM_RGID;
1148 # endif /* HAS_SETRGID */
1150 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1151 (void)setegid(PL_egid);
1152 PL_delaymagic &= ~DM_EGID;
1154 # endif /* HAS_SETEGID */
1155 if (PL_delaymagic & DM_GID) {
1156 if (PL_gid != PL_egid)
1157 DIE(aTHX_ "No setregid available");
1158 (void)PerlProc_setgid(PL_gid);
1160 # endif /* HAS_SETREGID */
1161 #endif /* HAS_SETRESGID */
1162 PL_gid = PerlProc_getgid();
1163 PL_egid = PerlProc_getegid();
1165 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1169 if (gimme == G_VOID)
1170 SP = firstrelem - 1;
1171 else if (gimme == G_SCALAR) {
1174 SETi(lastrelem - firstrelem + 1 - duplicates);
1181 /* Removes from the stack the entries which ended up as
1182 * duplicated keys in the hash (fix for [perl #24380]) */
1183 Move(firsthashrelem + duplicates,
1184 firsthashrelem, duplicates, SV**);
1185 lastrelem -= duplicates;
1190 SP = firstrelem + (lastlelem - firstlelem);
1191 lelem = firstlelem + (relem - firstrelem);
1193 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1202 register PMOP * const pm = cPMOP;
1203 REGEXP * rx = PM_GETRE(pm);
1204 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1205 SV * const rv = sv_newmortal();
1207 SvUPGRADE(rv, SVt_IV);
1208 /* This RV is about to own a reference to the regexp. (In addition to the
1209 reference already owned by the PMOP. */
1211 SvRV_set(rv, MUTABLE_SV(rx));
1215 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1217 (void)sv_bless(rv, stash);
1220 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1229 register PMOP *pm = cPMOP;
1231 register const char *t;
1232 register const char *s;
1235 U8 r_flags = REXEC_CHECKED;
1236 const char *truebase; /* Start of string */
1237 register REGEXP *rx = PM_GETRE(pm);
1239 const I32 gimme = GIMME;
1242 const I32 oldsave = PL_savestack_ix;
1243 I32 update_minmatch = 1;
1244 I32 had_zerolen = 0;
1247 if (PL_op->op_flags & OPf_STACKED)
1249 else if (PL_op->op_private & OPpTARGET_MY)
1256 PUTBACK; /* EVAL blocks need stack_sp. */
1257 s = SvPV_const(TARG, len);
1259 DIE(aTHX_ "panic: pp_match");
1261 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1262 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1265 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1267 /* PMdf_USED is set after a ?? matches once */
1270 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1272 pm->op_pmflags & PMf_USED
1276 if (gimme == G_ARRAY)
1283 /* empty pattern special-cased to use last successful pattern if possible */
1284 if (!RX_PRELEN(rx) && PL_curpm) {
1289 if (RX_MINLEN(rx) > (I32)len)
1294 /* XXXX What part of this is needed with true \G-support? */
1295 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1296 RX_OFFS(rx)[0].start = -1;
1297 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1298 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1299 if (mg && mg->mg_len >= 0) {
1300 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1301 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1302 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1303 r_flags |= REXEC_IGNOREPOS;
1304 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1305 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1308 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1309 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1310 update_minmatch = 0;
1314 /* XXX: comment out !global get safe $1 vars after a
1315 match, BUT be aware that this leads to dramatic slowdowns on
1316 /g matches against large strings. So far a solution to this problem
1317 appears to be quite tricky.
1318 Test for the unsafe vars are TODO for now. */
1319 if (( !global && RX_NPARENS(rx))
1320 || SvTEMP(TARG) || PL_sawampersand ||
1321 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1322 r_flags |= REXEC_COPY_STR;
1324 r_flags |= REXEC_SCREAM;
1327 if (global && RX_OFFS(rx)[0].start != -1) {
1328 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1329 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1331 if (update_minmatch++)
1332 minmatch = had_zerolen;
1334 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1335 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1336 /* FIXME - can PL_bostr be made const char *? */
1337 PL_bostr = (char *)truebase;
1338 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1342 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1344 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1345 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1346 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1347 && (r_flags & REXEC_SCREAM)))
1348 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1351 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1352 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1355 if (dynpm->op_pmflags & PMf_ONCE) {
1357 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1359 dynpm->op_pmflags |= PMf_USED;
1370 RX_MATCH_TAINTED_on(rx);
1371 TAINT_IF(RX_MATCH_TAINTED(rx));
1372 if (gimme == G_ARRAY) {
1373 const I32 nparens = RX_NPARENS(rx);
1374 I32 i = (global && !nparens) ? 1 : 0;
1376 SPAGAIN; /* EVAL blocks could move the stack. */
1377 EXTEND(SP, nparens + i);
1378 EXTEND_MORTAL(nparens + i);
1379 for (i = !i; i <= nparens; i++) {
1380 PUSHs(sv_newmortal());
1381 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1382 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1383 s = RX_OFFS(rx)[i].start + truebase;
1384 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1385 len < 0 || len > strend - s)
1386 DIE(aTHX_ "panic: pp_match start/end pointers");
1387 sv_setpvn(*SP, s, len);
1388 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1393 if (dynpm->op_pmflags & PMf_CONTINUE) {
1395 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1396 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1398 #ifdef PERL_OLD_COPY_ON_WRITE
1400 sv_force_normal_flags(TARG, 0);
1402 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1403 &PL_vtbl_mglob, NULL, 0);
1405 if (RX_OFFS(rx)[0].start != -1) {
1406 mg->mg_len = RX_OFFS(rx)[0].end;
1407 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1408 mg->mg_flags |= MGf_MINMATCH;
1410 mg->mg_flags &= ~MGf_MINMATCH;
1413 had_zerolen = (RX_OFFS(rx)[0].start != -1
1414 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1415 == (UV)RX_OFFS(rx)[0].end));
1416 PUTBACK; /* EVAL blocks may use stack */
1417 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1422 LEAVE_SCOPE(oldsave);
1428 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1429 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1433 #ifdef PERL_OLD_COPY_ON_WRITE
1435 sv_force_normal_flags(TARG, 0);
1437 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1438 &PL_vtbl_mglob, NULL, 0);
1440 if (RX_OFFS(rx)[0].start != -1) {
1441 mg->mg_len = RX_OFFS(rx)[0].end;
1442 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1443 mg->mg_flags |= MGf_MINMATCH;
1445 mg->mg_flags &= ~MGf_MINMATCH;
1448 LEAVE_SCOPE(oldsave);
1452 yup: /* Confirmed by INTUIT */
1454 RX_MATCH_TAINTED_on(rx);
1455 TAINT_IF(RX_MATCH_TAINTED(rx));
1457 if (dynpm->op_pmflags & PMf_ONCE) {
1459 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1461 dynpm->op_pmflags |= PMf_USED;
1464 if (RX_MATCH_COPIED(rx))
1465 Safefree(RX_SUBBEG(rx));
1466 RX_MATCH_COPIED_off(rx);
1467 RX_SUBBEG(rx) = NULL;
1469 /* FIXME - should rx->subbeg be const char *? */
1470 RX_SUBBEG(rx) = (char *) truebase;
1471 RX_OFFS(rx)[0].start = s - truebase;
1472 if (RX_MATCH_UTF8(rx)) {
1473 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1474 RX_OFFS(rx)[0].end = t - truebase;
1477 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1479 RX_SUBLEN(rx) = strend - truebase;
1482 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1484 #ifdef PERL_OLD_COPY_ON_WRITE
1485 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1487 PerlIO_printf(Perl_debug_log,
1488 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1489 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1492 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1494 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1495 assert (SvPOKp(RX_SAVED_COPY(rx)));
1500 RX_SUBBEG(rx) = savepvn(t, strend - t);
1501 #ifdef PERL_OLD_COPY_ON_WRITE
1502 RX_SAVED_COPY(rx) = NULL;
1505 RX_SUBLEN(rx) = strend - t;
1506 RX_MATCH_COPIED_on(rx);
1507 off = RX_OFFS(rx)[0].start = s - t;
1508 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1510 else { /* startp/endp are used by @- @+. */
1511 RX_OFFS(rx)[0].start = s - truebase;
1512 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1514 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1516 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1517 LEAVE_SCOPE(oldsave);
1522 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1523 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1524 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1529 LEAVE_SCOPE(oldsave);
1530 if (gimme == G_ARRAY)
1536 Perl_do_readline(pTHX)
1538 dVAR; dSP; dTARGETSTACKED;
1543 register IO * const io = GvIO(PL_last_in_gv);
1544 register const I32 type = PL_op->op_type;
1545 const I32 gimme = GIMME_V;
1548 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1551 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1554 call_method("READLINE", gimme);
1557 if (gimme == G_SCALAR) {
1558 SV* const result = POPs;
1559 SvSetSV_nosteal(TARG, result);
1569 if (IoFLAGS(io) & IOf_ARGV) {
1570 if (IoFLAGS(io) & IOf_START) {
1572 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1573 IoFLAGS(io) &= ~IOf_START;
1574 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1575 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1576 SvSETMAGIC(GvSV(PL_last_in_gv));
1581 fp = nextargv(PL_last_in_gv);
1582 if (!fp) { /* Note: fp != IoIFP(io) */
1583 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1586 else if (type == OP_GLOB)
1587 fp = Perl_start_glob(aTHX_ POPs, io);
1589 else if (type == OP_GLOB)
1591 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1592 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1596 if ((!io || !(IoFLAGS(io) & IOf_START))
1597 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1599 if (type == OP_GLOB)
1600 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1601 "glob failed (can't start child: %s)",
1604 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1606 if (gimme == G_SCALAR) {
1607 /* undef TARG, and push that undefined value */
1608 if (type != OP_RCATLINE) {
1609 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1617 if (gimme == G_SCALAR) {
1619 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1622 if (type == OP_RCATLINE)
1623 SvPV_force_nolen(sv);
1627 else if (isGV_with_GP(sv)) {
1628 SvPV_force_nolen(sv);
1630 SvUPGRADE(sv, SVt_PV);
1631 tmplen = SvLEN(sv); /* remember if already alloced */
1632 if (!tmplen && !SvREADONLY(sv))
1633 Sv_Grow(sv, 80); /* try short-buffering it */
1635 if (type == OP_RCATLINE && SvOK(sv)) {
1637 SvPV_force_nolen(sv);
1643 sv = sv_2mortal(newSV(80));
1647 /* This should not be marked tainted if the fp is marked clean */
1648 #define MAYBE_TAINT_LINE(io, sv) \
1649 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1654 /* delay EOF state for a snarfed empty file */
1655 #define SNARF_EOF(gimme,rs,io,sv) \
1656 (gimme != G_SCALAR || SvCUR(sv) \
1657 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1661 if (!sv_gets(sv, fp, offset)
1663 || SNARF_EOF(gimme, PL_rs, io, sv)
1664 || PerlIO_error(fp)))
1666 PerlIO_clearerr(fp);
1667 if (IoFLAGS(io) & IOf_ARGV) {
1668 fp = nextargv(PL_last_in_gv);
1671 (void)do_close(PL_last_in_gv, FALSE);
1673 else if (type == OP_GLOB) {
1674 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1675 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1676 "glob failed (child exited with status %d%s)",
1677 (int)(STATUS_CURRENT >> 8),
1678 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1681 if (gimme == G_SCALAR) {
1682 if (type != OP_RCATLINE) {
1683 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1689 MAYBE_TAINT_LINE(io, sv);
1692 MAYBE_TAINT_LINE(io, sv);
1694 IoFLAGS(io) |= IOf_NOLINE;
1698 if (type == OP_GLOB) {
1701 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1702 char * const tmps = SvEND(sv) - 1;
1703 if (*tmps == *SvPVX_const(PL_rs)) {
1705 SvCUR_set(sv, SvCUR(sv) - 1);
1708 for (t1 = SvPVX_const(sv); *t1; t1++)
1709 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1710 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1712 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1713 (void)POPs; /* Unmatched wildcard? Chuck it... */
1716 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1717 if (ckWARN(WARN_UTF8)) {
1718 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1719 const STRLEN len = SvCUR(sv) - offset;
1722 if (!is_utf8_string_loc(s, len, &f))
1723 /* Emulate :encoding(utf8) warning in the same case. */
1724 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1725 "utf8 \"\\x%02X\" does not map to Unicode",
1726 f < (U8*)SvEND(sv) ? *f : 0);
1729 if (gimme == G_ARRAY) {
1730 if (SvLEN(sv) - SvCUR(sv) > 20) {
1731 SvPV_shrink_to_cur(sv);
1733 sv = sv_2mortal(newSV(80));
1736 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1737 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1738 const STRLEN new_len
1739 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1740 SvPV_renew(sv, new_len);
1749 register PERL_CONTEXT *cx;
1750 I32 gimme = OP_GIMME(PL_op, -1);
1753 if (cxstack_ix >= 0)
1754 gimme = cxstack[cxstack_ix].blk_gimme;
1762 PUSHBLOCK(cx, CXt_BLOCK, SP);
1772 SV * const keysv = POPs;
1773 HV * const hv = MUTABLE_HV(POPs);
1774 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1775 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1777 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1780 if (SvTYPE(hv) != SVt_PVHV)
1783 if (PL_op->op_private & OPpLVAL_INTRO) {
1786 /* does the element we're localizing already exist? */
1787 preeminent = /* can we determine whether it exists? */
1789 || mg_find((const SV *)hv, PERL_MAGIC_env)
1790 || ( (mg = mg_find((const SV *)hv, PERL_MAGIC_tied))
1791 /* Try to preserve the existenceness of a tied hash
1792 * element by using EXISTS and DELETE if possible.
1793 * Fallback to FETCH and STORE otherwise */
1794 && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(hv), mg))))
1795 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1796 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1798 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1800 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1801 svp = he ? &HeVAL(he) : NULL;
1803 if (!svp || *svp == &PL_sv_undef) {
1807 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1809 lv = sv_newmortal();
1810 sv_upgrade(lv, SVt_PVLV);
1812 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1813 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1814 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1819 if (PL_op->op_private & OPpLVAL_INTRO) {
1820 if (HvNAME_get(hv) && isGV(*svp))
1821 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1825 const char * const key = SvPV_const(keysv, keylen);
1826 SAVEDELETE(hv, savepvn(key,keylen),
1827 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1829 save_helem(hv, keysv, svp);
1832 else if (PL_op->op_private & OPpDEREF)
1833 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1835 sv = (svp ? *svp : &PL_sv_undef);
1836 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1837 * Pushing the magical RHS on to the stack is useless, since
1838 * that magic is soon destined to be misled by the local(),
1839 * and thus the later pp_sassign() will fail to mg_get() the
1840 * old value. This should also cure problems with delayed
1841 * mg_get()s. GSAR 98-07-03 */
1842 if (!lval && SvGMAGICAL(sv))
1843 sv = sv_mortalcopy(sv);
1851 register PERL_CONTEXT *cx;
1856 if (PL_op->op_flags & OPf_SPECIAL) {
1857 cx = &cxstack[cxstack_ix];
1858 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1863 gimme = OP_GIMME(PL_op, -1);
1865 if (cxstack_ix >= 0)
1866 gimme = cxstack[cxstack_ix].blk_gimme;
1872 if (gimme == G_VOID)
1874 else if (gimme == G_SCALAR) {
1878 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1881 *MARK = sv_mortalcopy(TOPs);
1884 *MARK = &PL_sv_undef;
1888 else if (gimme == G_ARRAY) {
1889 /* in case LEAVE wipes old return values */
1891 for (mark = newsp + 1; mark <= SP; mark++) {
1892 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1893 *mark = sv_mortalcopy(*mark);
1894 TAINT_NOT; /* Each item is independent */
1898 PL_curpm = newpm; /* Don't pop $1 et al till now */
1908 register PERL_CONTEXT *cx;
1911 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1912 bool av_is_stack = FALSE;
1915 cx = &cxstack[cxstack_ix];
1916 if (!CxTYPE_is_LOOP(cx))
1917 DIE(aTHX_ "panic: pp_iter");
1919 itersvp = CxITERVAR(cx);
1920 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1921 /* string increment */
1922 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1923 SV *end = cx->blk_loop.state_u.lazysv.end;
1924 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1925 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1927 const char *max = SvPV_const(end, maxlen);
1928 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1929 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1930 /* safe to reuse old SV */
1931 sv_setsv(*itersvp, cur);
1935 /* we need a fresh SV every time so that loop body sees a
1936 * completely new SV for closures/references to work as
1939 *itersvp = newSVsv(cur);
1940 SvREFCNT_dec(oldsv);
1942 if (strEQ(SvPVX_const(cur), max))
1943 sv_setiv(cur, 0); /* terminate next time */
1950 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1951 /* integer increment */
1952 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1955 /* don't risk potential race */
1956 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1957 /* safe to reuse old SV */
1958 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1962 /* we need a fresh SV every time so that loop body sees a
1963 * completely new SV for closures/references to work as they
1966 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1967 SvREFCNT_dec(oldsv);
1970 /* Handle end of range at IV_MAX */
1971 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1972 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1974 cx->blk_loop.state_u.lazyiv.cur++;
1975 cx->blk_loop.state_u.lazyiv.end++;
1982 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1983 av = cx->blk_loop.state_u.ary.ary;
1988 if (PL_op->op_private & OPpITER_REVERSED) {
1989 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1990 ? cx->blk_loop.resetsp + 1 : 0))
1993 if (SvMAGICAL(av) || AvREIFY(av)) {
1994 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1995 sv = svp ? *svp : NULL;
1998 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2002 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2006 if (SvMAGICAL(av) || AvREIFY(av)) {
2007 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2008 sv = svp ? *svp : NULL;
2011 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2015 if (sv && SvIS_FREED(sv)) {
2017 Perl_croak(aTHX_ "Use of freed value in iteration");
2022 SvREFCNT_inc_simple_void_NN(sv);
2026 if (!av_is_stack && sv == &PL_sv_undef) {
2027 SV *lv = newSV_type(SVt_PVLV);
2029 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2030 LvTARG(lv) = SvREFCNT_inc_simple(av);
2031 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2032 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2038 SvREFCNT_dec(oldsv);
2046 register PMOP *pm = cPMOP;
2061 register REGEXP *rx = PM_GETRE(pm);
2063 int force_on_match = 0;
2064 const I32 oldsave = PL_savestack_ix;
2066 bool doutf8 = FALSE;
2068 #ifdef PERL_OLD_COPY_ON_WRITE
2073 /* known replacement string? */
2074 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2075 if (PL_op->op_flags & OPf_STACKED)
2077 else if (PL_op->op_private & OPpTARGET_MY)
2084 #ifdef PERL_OLD_COPY_ON_WRITE
2085 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2086 because they make integers such as 256 "false". */
2087 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2090 sv_force_normal_flags(TARG,0);
2093 #ifdef PERL_OLD_COPY_ON_WRITE
2097 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2098 || SvTYPE(TARG) > SVt_PVLV)
2099 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2100 DIE(aTHX_ PL_no_modify);
2103 s = SvPV_mutable(TARG, len);
2104 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2106 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2107 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2112 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2116 DIE(aTHX_ "panic: pp_subst");
2119 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2120 maxiters = 2 * slen + 10; /* We can match twice at each
2121 position, once with zero-length,
2122 second time with non-zero. */
2124 if (!RX_PRELEN(rx) && PL_curpm) {
2128 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2129 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2130 ? REXEC_COPY_STR : 0;
2132 r_flags |= REXEC_SCREAM;
2135 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2137 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2141 /* How to do it in subst? */
2142 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2144 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2145 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2146 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2147 && (r_flags & REXEC_SCREAM))))
2152 /* only replace once? */
2153 once = !(rpm->op_pmflags & PMf_GLOBAL);
2154 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2155 r_flags | REXEC_CHECKED);
2156 /* known replacement string? */
2158 /* replacement needing upgrading? */
2159 if (DO_UTF8(TARG) && !doutf8) {
2160 nsv = sv_newmortal();
2163 sv_recode_to_utf8(nsv, PL_encoding);
2165 sv_utf8_upgrade(nsv);
2166 c = SvPV_const(nsv, clen);
2170 c = SvPV_const(dstr, clen);
2171 doutf8 = DO_UTF8(dstr);
2179 /* can do inplace substitution? */
2181 #ifdef PERL_OLD_COPY_ON_WRITE
2184 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2185 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2186 && (!doutf8 || SvUTF8(TARG))) {
2191 LEAVE_SCOPE(oldsave);
2194 #ifdef PERL_OLD_COPY_ON_WRITE
2195 if (SvIsCOW(TARG)) {
2196 assert (!force_on_match);
2200 if (force_on_match) {
2202 s = SvPV_force(TARG, len);
2207 SvSCREAM_off(TARG); /* disable possible screamer */
2209 rxtainted |= RX_MATCH_TAINTED(rx);
2210 m = orig + RX_OFFS(rx)[0].start;
2211 d = orig + RX_OFFS(rx)[0].end;
2213 if (m - s > strend - d) { /* faster to shorten from end */
2215 Copy(c, m, clen, char);
2220 Move(d, m, i, char);
2224 SvCUR_set(TARG, m - s);
2226 else if ((i = m - s)) { /* faster from front */
2229 Move(s, d - i, i, char);
2232 Copy(c, m, clen, char);
2237 Copy(c, d, clen, char);
2242 TAINT_IF(rxtainted & 1);
2248 if (iters++ > maxiters)
2249 DIE(aTHX_ "Substitution loop");
2250 rxtainted |= RX_MATCH_TAINTED(rx);
2251 m = RX_OFFS(rx)[0].start + orig;
2254 Move(s, d, i, char);
2258 Copy(c, d, clen, char);
2261 s = RX_OFFS(rx)[0].end + orig;
2262 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2264 /* don't match same null twice */
2265 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2268 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2269 Move(s, d, i+1, char); /* include the NUL */
2271 TAINT_IF(rxtainted & 1);
2275 (void)SvPOK_only_UTF8(TARG);
2276 TAINT_IF(rxtainted);
2277 if (SvSMAGICAL(TARG)) {
2285 LEAVE_SCOPE(oldsave);
2291 if (force_on_match) {
2293 s = SvPV_force(TARG, len);
2296 #ifdef PERL_OLD_COPY_ON_WRITE
2299 rxtainted |= RX_MATCH_TAINTED(rx);
2300 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2304 register PERL_CONTEXT *cx;
2307 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2309 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2311 if (iters++ > maxiters)
2312 DIE(aTHX_ "Substitution loop");
2313 rxtainted |= RX_MATCH_TAINTED(rx);
2314 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2317 orig = RX_SUBBEG(rx);
2319 strend = s + (strend - m);
2321 m = RX_OFFS(rx)[0].start + orig;
2322 if (doutf8 && !SvUTF8(dstr))
2323 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2325 sv_catpvn(dstr, s, m-s);
2326 s = RX_OFFS(rx)[0].end + orig;
2328 sv_catpvn(dstr, c, clen);
2331 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2332 TARG, NULL, r_flags));
2333 if (doutf8 && !DO_UTF8(TARG))
2334 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2336 sv_catpvn(dstr, s, strend - s);
2338 #ifdef PERL_OLD_COPY_ON_WRITE
2339 /* The match may make the string COW. If so, brilliant, because that's
2340 just saved us one malloc, copy and free - the regexp has donated
2341 the old buffer, and we malloc an entirely new one, rather than the
2342 regexp malloc()ing a buffer and copying our original, only for
2343 us to throw it away here during the substitution. */
2344 if (SvIsCOW(TARG)) {
2345 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2351 SvPV_set(TARG, SvPVX(dstr));
2352 SvCUR_set(TARG, SvCUR(dstr));
2353 SvLEN_set(TARG, SvLEN(dstr));
2354 doutf8 |= DO_UTF8(dstr);
2355 SvPV_set(dstr, NULL);
2357 TAINT_IF(rxtainted & 1);
2361 (void)SvPOK_only(TARG);
2364 TAINT_IF(rxtainted);
2367 LEAVE_SCOPE(oldsave);
2376 LEAVE_SCOPE(oldsave);
2385 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2386 ++*PL_markstack_ptr;
2387 LEAVE; /* exit inner scope */
2390 if (PL_stack_base + *PL_markstack_ptr > SP) {
2392 const I32 gimme = GIMME_V;
2394 LEAVE; /* exit outer scope */
2395 (void)POPMARK; /* pop src */
2396 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2397 (void)POPMARK; /* pop dst */
2398 SP = PL_stack_base + POPMARK; /* pop original mark */
2399 if (gimme == G_SCALAR) {
2400 if (PL_op->op_private & OPpGREP_LEX) {
2401 SV* const sv = sv_newmortal();
2402 sv_setiv(sv, items);
2410 else if (gimme == G_ARRAY)
2417 ENTER; /* enter inner scope */
2420 src = PL_stack_base[*PL_markstack_ptr];
2422 if (PL_op->op_private & OPpGREP_LEX)
2423 PAD_SVl(PL_op->op_targ) = src;
2427 RETURNOP(cLOGOP->op_other);
2438 register PERL_CONTEXT *cx;
2441 if (CxMULTICALL(&cxstack[cxstack_ix]))
2445 cxstack_ix++; /* temporarily protect top context */
2448 if (gimme == G_SCALAR) {
2451 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2453 *MARK = SvREFCNT_inc(TOPs);
2458 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2460 *MARK = sv_mortalcopy(sv);
2465 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2469 *MARK = &PL_sv_undef;
2473 else if (gimme == G_ARRAY) {
2474 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2475 if (!SvTEMP(*MARK)) {
2476 *MARK = sv_mortalcopy(*MARK);
2477 TAINT_NOT; /* Each item is independent */
2485 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2486 PL_curpm = newpm; /* ... and pop $1 et al */
2489 return cx->blk_sub.retop;
2492 /* This duplicates the above code because the above code must not
2493 * get any slower by more conditions */
2501 register PERL_CONTEXT *cx;
2504 if (CxMULTICALL(&cxstack[cxstack_ix]))
2508 cxstack_ix++; /* temporarily protect top context */
2512 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2513 /* We are an argument to a function or grep().
2514 * This kind of lvalueness was legal before lvalue
2515 * subroutines too, so be backward compatible:
2516 * cannot report errors. */
2518 /* Scalar context *is* possible, on the LHS of -> only,
2519 * as in f()->meth(). But this is not an lvalue. */
2520 if (gimme == G_SCALAR)
2522 if (gimme == G_ARRAY) {
2523 if (!CvLVALUE(cx->blk_sub.cv))
2524 goto temporise_array;
2525 EXTEND_MORTAL(SP - newsp);
2526 for (mark = newsp + 1; mark <= SP; mark++) {
2529 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2530 *mark = sv_mortalcopy(*mark);
2532 /* Can be a localized value subject to deletion. */
2533 PL_tmps_stack[++PL_tmps_ix] = *mark;
2534 SvREFCNT_inc_void(*mark);
2539 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2540 /* Here we go for robustness, not for speed, so we change all
2541 * the refcounts so the caller gets a live guy. Cannot set
2542 * TEMP, so sv_2mortal is out of question. */
2543 if (!CvLVALUE(cx->blk_sub.cv)) {
2549 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2551 if (gimme == G_SCALAR) {
2555 /* Temporaries are bad unless they happen to be elements
2556 * of a tied hash or array */
2557 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2558 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2564 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2565 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2566 : "a readonly value" : "a temporary");
2568 else { /* Can be a localized value
2569 * subject to deletion. */
2570 PL_tmps_stack[++PL_tmps_ix] = *mark;
2571 SvREFCNT_inc_void(*mark);
2574 else { /* Should not happen? */
2580 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2581 (MARK > SP ? "Empty array" : "Array"));
2585 else if (gimme == G_ARRAY) {
2586 EXTEND_MORTAL(SP - newsp);
2587 for (mark = newsp + 1; mark <= SP; mark++) {
2588 if (*mark != &PL_sv_undef
2589 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2590 /* Might be flattened array after $#array = */
2597 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2598 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2601 /* Can be a localized value subject to deletion. */
2602 PL_tmps_stack[++PL_tmps_ix] = *mark;
2603 SvREFCNT_inc_void(*mark);
2609 if (gimme == G_SCALAR) {
2613 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2615 *MARK = SvREFCNT_inc(TOPs);
2620 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2622 *MARK = sv_mortalcopy(sv);
2627 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2631 *MARK = &PL_sv_undef;
2635 else if (gimme == G_ARRAY) {
2637 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2638 if (!SvTEMP(*MARK)) {
2639 *MARK = sv_mortalcopy(*MARK);
2640 TAINT_NOT; /* Each item is independent */
2649 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2650 PL_curpm = newpm; /* ... and pop $1 et al */
2653 return cx->blk_sub.retop;
2661 register PERL_CONTEXT *cx;
2663 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2666 DIE(aTHX_ "Not a CODE reference");
2667 switch (SvTYPE(sv)) {
2668 /* This is overwhelming the most common case: */
2670 if (!isGV_with_GP(sv))
2671 DIE(aTHX_ "Not a CODE reference");
2672 if (!(cv = GvCVu((const GV *)sv))) {
2674 cv = sv_2cv(sv, &stash, &gv, 0);
2686 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2688 SP = PL_stack_base + POPMARK;
2691 if (SvGMAGICAL(sv)) {
2696 sym = SvPVX_const(sv);
2704 sym = SvPV_const(sv, len);
2707 DIE(aTHX_ PL_no_usym, "a subroutine");
2708 if (PL_op->op_private & HINT_STRICT_REFS)
2709 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2710 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2715 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2716 tryAMAGICunDEREF(to_cv);
2718 cv = MUTABLE_CV(SvRV(sv));
2719 if (SvTYPE(cv) == SVt_PVCV)
2724 DIE(aTHX_ "Not a CODE reference");
2725 /* This is the second most common case: */
2727 cv = MUTABLE_CV(sv);
2735 if (!CvROOT(cv) && !CvXSUB(cv)) {
2739 /* anonymous or undef'd function leaves us no recourse */
2740 if (CvANON(cv) || !(gv = CvGV(cv)))
2741 DIE(aTHX_ "Undefined subroutine called");
2743 /* autoloaded stub? */
2744 if (cv != GvCV(gv)) {
2747 /* should call AUTOLOAD now? */
2750 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2757 sub_name = sv_newmortal();
2758 gv_efullname3(sub_name, gv, NULL);
2759 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2763 DIE(aTHX_ "Not a CODE reference");
2768 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2769 Perl_get_db_sub(aTHX_ &sv, cv);
2771 PL_curcopdb = PL_curcop;
2772 cv = GvCV(PL_DBsub);
2774 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2775 DIE(aTHX_ "No DB::sub routine defined");
2778 if (!(CvISXSUB(cv))) {
2779 /* This path taken at least 75% of the time */
2781 register I32 items = SP - MARK;
2782 AV* const padlist = CvPADLIST(cv);
2783 PUSHBLOCK(cx, CXt_SUB, MARK);
2785 cx->blk_sub.retop = PL_op->op_next;
2787 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2788 * that eval'' ops within this sub know the correct lexical space.
2789 * Owing the speed considerations, we choose instead to search for
2790 * the cv using find_runcv() when calling doeval().
2792 if (CvDEPTH(cv) >= 2) {
2793 PERL_STACK_OVERFLOW_CHECK();
2794 pad_push(padlist, CvDEPTH(cv));
2797 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2799 AV *const av = MUTABLE_AV(PAD_SVl(0));
2801 /* @_ is normally not REAL--this should only ever
2802 * happen when DB::sub() calls things that modify @_ */
2807 cx->blk_sub.savearray = GvAV(PL_defgv);
2808 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2809 CX_CURPAD_SAVE(cx->blk_sub);
2810 cx->blk_sub.argarray = av;
2813 if (items > AvMAX(av) + 1) {
2814 SV **ary = AvALLOC(av);
2815 if (AvARRAY(av) != ary) {
2816 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2819 if (items > AvMAX(av) + 1) {
2820 AvMAX(av) = items - 1;
2821 Renew(ary,items,SV*);
2826 Copy(MARK,AvARRAY(av),items,SV*);
2827 AvFILLp(av) = items - 1;
2835 /* warning must come *after* we fully set up the context
2836 * stuff so that __WARN__ handlers can safely dounwind()
2839 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2840 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2841 sub_crush_depth(cv);
2842 RETURNOP(CvSTART(cv));
2845 I32 markix = TOPMARK;
2850 /* Need to copy @_ to stack. Alternative may be to
2851 * switch stack to @_, and copy return values
2852 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2853 AV * const av = GvAV(PL_defgv);
2854 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2857 /* Mark is at the end of the stack. */
2859 Copy(AvARRAY(av), SP + 1, items, SV*);
2864 /* We assume first XSUB in &DB::sub is the called one. */
2866 SAVEVPTR(PL_curcop);
2867 PL_curcop = PL_curcopdb;
2870 /* Do we need to open block here? XXXX */
2871 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2872 (void)(*CvXSUB(cv))(aTHX_ cv);
2874 /* Enforce some sanity in scalar context. */
2875 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2876 if (markix > PL_stack_sp - PL_stack_base)
2877 *(PL_stack_base + markix) = &PL_sv_undef;
2879 *(PL_stack_base + markix) = *PL_stack_sp;
2880 PL_stack_sp = PL_stack_base + markix;
2888 Perl_sub_crush_depth(pTHX_ CV *cv)
2890 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2893 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2895 SV* const tmpstr = sv_newmortal();
2896 gv_efullname3(tmpstr, CvGV(cv), NULL);
2897 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2906 SV* const elemsv = POPs;
2907 IV elem = SvIV(elemsv);
2908 AV *const av = MUTABLE_AV(POPs);
2909 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2910 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2913 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2914 Perl_warner(aTHX_ packWARN(WARN_MISC),
2915 "Use of reference \"%"SVf"\" as array index",
2918 elem -= CopARYBASE_get(PL_curcop);
2919 if (SvTYPE(av) != SVt_PVAV)
2921 svp = av_fetch(av, elem, lval && !defer);
2923 #ifdef PERL_MALLOC_WRAP
2924 if (SvUOK(elemsv)) {
2925 const UV uv = SvUV(elemsv);
2926 elem = uv > IV_MAX ? IV_MAX : uv;
2928 else if (SvNOK(elemsv))
2929 elem = (IV)SvNV(elemsv);
2931 static const char oom_array_extend[] =
2932 "Out of memory during array extend"; /* Duplicated in av.c */
2933 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2936 if (!svp || *svp == &PL_sv_undef) {
2939 DIE(aTHX_ PL_no_aelem, elem);
2940 lv = sv_newmortal();
2941 sv_upgrade(lv, SVt_PVLV);
2943 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2944 LvTARG(lv) = SvREFCNT_inc_simple(av);
2945 LvTARGOFF(lv) = elem;
2950 if (PL_op->op_private & OPpLVAL_INTRO)
2951 save_aelem(av, elem, svp);
2952 else if (PL_op->op_private & OPpDEREF)
2953 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2955 sv = (svp ? *svp : &PL_sv_undef);
2956 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2957 sv = sv_mortalcopy(sv);
2963 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2965 PERL_ARGS_ASSERT_VIVIFY_REF;
2970 Perl_croak(aTHX_ PL_no_modify);
2971 prepare_SV_for_RV(sv);
2974 SvRV_set(sv, newSV(0));
2977 SvRV_set(sv, MUTABLE_SV(newAV()));
2980 SvRV_set(sv, MUTABLE_SV(newHV()));
2991 SV* const sv = TOPs;
2994 SV* const rsv = SvRV(sv);
2995 if (SvTYPE(rsv) == SVt_PVCV) {
3001 SETs(method_common(sv, NULL));
3008 SV* const sv = cSVOP_sv;
3009 U32 hash = SvSHARED_HASH(sv);
3011 XPUSHs(method_common(sv, &hash));
3016 S_method_common(pTHX_ SV* meth, U32* hashp)
3023 const char* packname = NULL;
3026 const char * const name = SvPV_const(meth, namelen);
3027 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3029 PERL_ARGS_ASSERT_METHOD_COMMON;
3032 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3036 ob = MUTABLE_SV(SvRV(sv));
3040 /* this isn't a reference */
3041 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3042 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3044 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3051 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3052 !(ob=MUTABLE_SV(GvIO(iogv))))
3054 /* this isn't the name of a filehandle either */
3056 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3057 ? !isIDFIRST_utf8((U8*)packname)
3058 : !isIDFIRST(*packname)
3061 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3062 SvOK(sv) ? "without a package or object reference"
3063 : "on an undefined value");
3065 /* assume it's a package name */
3066 stash = gv_stashpvn(packname, packlen, 0);
3070 SV* const ref = newSViv(PTR2IV(stash));
3071 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3075 /* it _is_ a filehandle name -- replace with a reference */
3076 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3079 /* if we got here, ob should be a reference or a glob */
3080 if (!ob || !(SvOBJECT(ob)
3081 || (SvTYPE(ob) == SVt_PVGV
3083 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3086 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3087 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3091 stash = SvSTASH(ob);
3094 /* NOTE: stash may be null, hope hv_fetch_ent and
3095 gv_fetchmethod can cope (it seems they can) */
3097 /* shortcut for simple names */
3099 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3101 gv = MUTABLE_GV(HeVAL(he));
3102 if (isGV(gv) && GvCV(gv) &&
3103 (!GvCVGEN(gv) || GvCVGEN(gv)
3104 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3105 return MUTABLE_SV(GvCV(gv));
3109 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
3110 GV_AUTOLOAD | GV_CROAK);
3114 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3119 * c-indentation-style: bsd
3121 * indent-tabs-mode: t
3124 * ex: set ts=8 sts=4 sw=4 noet: