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!
18 * [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
21 /* This file contains 'hot' pp ("push/pop") functions that
22 * execute the opcodes that make up a perl program. A typical pp function
23 * expects to find its arguments on the stack, and usually pushes its
24 * results onto the stack, hence the 'pp' terminology. Each OP structure
25 * contains a pointer to the relevant pp_foo() function.
27 * By 'hot', we mean common ops whose execution speed is critical.
28 * By gathering them together into a single file, we encourage
29 * CPU cache hits on hot code. Also it could be taken as a warning not to
30 * change any code in this file unless you're sure it won't affect
35 #define PERL_IN_PP_HOT_C
51 PL_curcop = (COP*)PL_op;
52 TAINT_NOT; /* Each statement is presumed innocent */
53 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
63 if (PL_op->op_private & OPpLVAL_INTRO)
64 PUSHs(save_scalar(cGVOP_gv));
66 PUSHs(GvSVn(cGVOP_gv));
79 PUSHMARK(PL_stack_sp);
94 XPUSHs(MUTABLE_SV(cGVOP_gv));
104 if (PL_op->op_type == OP_AND)
106 RETURNOP(cLOGOP->op_other);
112 dVAR; dSP; dPOPTOPssrl;
114 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
115 SV * const temp = left;
116 left = right; right = temp;
118 if (PL_tainting && PL_tainted && !SvTAINTED(left))
120 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
121 SV * const cv = SvRV(left);
122 const U32 cv_type = SvTYPE(cv);
123 const U32 gv_type = SvTYPE(right);
124 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
130 /* Can do the optimisation if right (LVALUE) is not a typeglob,
131 left (RVALUE) is a reference to something, and we're in void
133 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
134 /* Is the target symbol table currently empty? */
135 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
136 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
137 /* Good. Create a new proxy constant subroutine in the target.
138 The gv becomes a(nother) reference to the constant. */
139 SV *const value = SvRV(cv);
141 SvUPGRADE(MUTABLE_SV(gv), SVt_IV);
142 SvPCS_IMPORTED_on(gv);
144 SvREFCNT_inc_simple_void(value);
150 /* Need to fix things up. */
151 if (gv_type != SVt_PVGV) {
152 /* Need to fix GV. */
153 right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
157 /* We've been returned a constant rather than a full subroutine,
158 but they expect a subroutine reference to apply. */
161 SvREFCNT_inc_void(SvRV(cv));
162 /* newCONSTSUB takes a reference count on the passed in SV
163 from us. We set the name to NULL, otherwise we get into
164 all sorts of fun as the reference to our new sub is
165 donated to the GV that we're about to assign to.
167 SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
172 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
174 First: ops for \&{"BONK"}; return us the constant in the
176 Second: ops for *{"BONK"} cause that symbol table entry
177 (and our reference to it) to be upgraded from RV
179 Thirdly: We get here. cv is actually PVGV now, and its
180 GvCV() is actually the subroutine we're looking for
182 So change the reference so that it points to the subroutine
183 of that typeglob, as that's what they were after all along.
185 GV *const upgraded = MUTABLE_GV(cv);
186 CV *const source = GvCV(upgraded);
189 assert(CvFLAGS(source) & CVf_CONST);
191 SvREFCNT_inc_void(source);
192 SvREFCNT_dec(upgraded);
193 SvRV_set(left, MUTABLE_SV(source));
198 SvSetMagicSV(right, left);
207 RETURNOP(cLOGOP->op_other);
209 RETURNOP(cLOGOP->op_next);
216 TAINT_NOT; /* Each statement is presumed innocent */
217 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
219 oldsave = PL_scopestack[PL_scopestack_ix - 1];
220 LEAVE_SCOPE(oldsave);
226 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
231 const char *rpv = NULL;
233 bool rcopied = FALSE;
235 if (TARG == right && right != left) {
236 /* mg_get(right) may happen here ... */
237 rpv = SvPV_const(right, rlen);
238 rbyte = !DO_UTF8(right);
239 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
240 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
246 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
247 lbyte = !DO_UTF8(left);
248 sv_setpvn(TARG, lpv, llen);
254 else { /* TARG == left */
256 SvGETMAGIC(left); /* or mg_get(left) may happen here */
258 if (left == right && ckWARN(WARN_UNINITIALIZED))
259 report_uninit(right);
262 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
263 lbyte = !DO_UTF8(left);
268 /* or mg_get(right) may happen here */
270 rpv = SvPV_const(right, rlen);
271 rbyte = !DO_UTF8(right);
273 if (lbyte != rbyte) {
275 sv_utf8_upgrade_nomg(TARG);
278 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
279 sv_utf8_upgrade_nomg(right);
280 rpv = SvPV_const(right, rlen);
283 sv_catpvn_nomg(TARG, rpv, rlen);
294 if (PL_op->op_flags & OPf_MOD) {
295 if (PL_op->op_private & OPpLVAL_INTRO)
296 if (!(PL_op->op_private & OPpPAD_STATE))
297 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
298 if (PL_op->op_private & OPpDEREF) {
300 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
310 tryAMAGICunTARGET(iter, 0);
311 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
312 if (!isGV_with_GP(PL_last_in_gv)) {
313 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
314 PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
317 XPUSHs(MUTABLE_SV(PL_last_in_gv));
320 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
323 return do_readline();
328 dVAR; dSP; tryAMAGICbinSET(eq,0);
329 #ifndef NV_PRESERVES_UV
330 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
332 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
336 #ifdef PERL_PRESERVE_IVUV
339 /* Unless the left argument is integer in range we are going
340 to have to use NV maths. Hence only attempt to coerce the
341 right argument if we know the left is integer. */
344 const bool auvok = SvUOK(TOPm1s);
345 const bool buvok = SvUOK(TOPs);
347 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
348 /* Casting IV to UV before comparison isn't going to matter
349 on 2s complement. On 1s complement or sign&magnitude
350 (if we have any of them) it could to make negative zero
351 differ from normal zero. As I understand it. (Need to
352 check - is negative zero implementation defined behaviour
354 const UV buv = SvUVX(POPs);
355 const UV auv = SvUVX(TOPs);
357 SETs(boolSV(auv == buv));
360 { /* ## Mixed IV,UV ## */
364 /* == is commutative so doesn't matter which is left or right */
366 /* top of stack (b) is the iv */
375 /* As uv is a UV, it's >0, so it cannot be == */
378 /* we know iv is >= 0 */
379 SETs(boolSV((UV)iv == SvUVX(uvp)));
386 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
388 if (Perl_isnan(left) || Perl_isnan(right))
390 SETs(boolSV(left == right));
393 SETs(boolSV(TOPn == value));
402 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
403 DIE(aTHX_ "%s", PL_no_modify);
404 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
405 && SvIVX(TOPs) != IV_MAX)
407 SvIV_set(TOPs, SvIVX(TOPs) + 1);
408 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
410 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
422 if (PL_op->op_type == OP_OR)
424 RETURNOP(cLOGOP->op_other);
433 const int op_type = PL_op->op_type;
434 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
438 if (!sv || !SvANY(sv)) {
439 if (op_type == OP_DOR)
441 RETURNOP(cLOGOP->op_other);
447 if (!sv || !SvANY(sv))
452 switch (SvTYPE(sv)) {
454 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
458 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
462 if (CvROOT(sv) || CvXSUB(sv))
475 if(op_type == OP_DOR)
477 RETURNOP(cLOGOP->op_other);
479 /* assuming OP_DEFINED */
487 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
488 tryAMAGICbin(add,opASSIGN);
489 svl = sv_2num(TOPm1s);
491 useleft = USE_LEFT(svl);
492 #ifdef PERL_PRESERVE_IVUV
493 /* We must see if we can perform the addition with integers if possible,
494 as the integer code detects overflow while the NV code doesn't.
495 If either argument hasn't had a numeric conversion yet attempt to get
496 the IV. It's important to do this now, rather than just assuming that
497 it's not IOK as a PV of "9223372036854775806" may not take well to NV
498 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
499 integer in case the second argument is IV=9223372036854775806
500 We can (now) rely on sv_2iv to do the right thing, only setting the
501 public IOK flag if the value in the NV (or PV) slot is truly integer.
503 A side effect is that this also aggressively prefers integer maths over
504 fp maths for integer values.
506 How to detect overflow?
508 C 99 section 6.2.6.1 says
510 The range of nonnegative values of a signed integer type is a subrange
511 of the corresponding unsigned integer type, and the representation of
512 the same value in each type is the same. A computation involving
513 unsigned operands can never overflow, because a result that cannot be
514 represented by the resulting unsigned integer type is reduced modulo
515 the number that is one greater than the largest value that can be
516 represented by the resulting type.
520 which I read as "unsigned ints wrap."
522 signed integer overflow seems to be classed as "exception condition"
524 If an exceptional condition occurs during the evaluation of an
525 expression (that is, if the result is not mathematically defined or not
526 in the range of representable values for its type), the behavior is
529 (6.5, the 5th paragraph)
531 I had assumed that on 2s complement machines signed arithmetic would
532 wrap, hence coded pp_add and pp_subtract on the assumption that
533 everything perl builds on would be happy. After much wailing and
534 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
535 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
536 unsigned code below is actually shorter than the old code. :-)
541 /* Unless the left argument is integer in range we are going to have to
542 use NV maths. Hence only attempt to coerce the right argument if
543 we know the left is integer. */
551 /* left operand is undef, treat as zero. + 0 is identity,
552 Could SETi or SETu right now, but space optimise by not adding
553 lots of code to speed up what is probably a rarish case. */
555 /* Left operand is defined, so is it IV? */
558 if ((auvok = SvUOK(svl)))
561 register const IV aiv = SvIVX(svl);
564 auvok = 1; /* Now acting as a sign flag. */
565 } else { /* 2s complement assumption for IV_MIN */
573 bool result_good = 0;
576 bool buvok = SvUOK(svr);
581 register const IV biv = SvIVX(svr);
588 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
589 else "IV" now, independent of how it came in.
590 if a, b represents positive, A, B negative, a maps to -A etc
595 all UV maths. negate result if A negative.
596 add if signs same, subtract if signs differ. */
602 /* Must get smaller */
608 /* result really should be -(auv-buv). as its negation
609 of true value, need to swap our result flag */
626 if (result <= (UV)IV_MIN)
629 /* result valid, but out of range for IV. */
634 } /* Overflow, drop through to NVs. */
639 NV value = SvNV(svr);
642 /* left operand is undef, treat as zero. + 0.0 is identity. */
646 SETn( value + SvNV(svl) );
654 AV * const av = PL_op->op_flags & OPf_SPECIAL
655 ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
656 const U32 lval = PL_op->op_flags & OPf_MOD;
657 SV** const svp = av_fetch(av, PL_op->op_private, lval);
658 SV *sv = (svp ? *svp : &PL_sv_undef);
660 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
661 sv = sv_mortalcopy(sv);
668 dVAR; dSP; dMARK; dTARGET;
670 do_join(TARG, *MARK, MARK, SP);
681 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
682 * will be enough to hold an OP*.
684 SV* const sv = sv_newmortal();
685 sv_upgrade(sv, SVt_PVLV);
687 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
690 XPUSHs(MUTABLE_SV(PL_op));
695 /* Oversized hot code. */
699 dVAR; dSP; dMARK; dORIGMARK;
704 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
706 if (gv && (io = GvIO(gv))
707 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
710 if (MARK == ORIGMARK) {
711 /* If using default handle then we need to make space to
712 * pass object as 1st arg, so move other args up ...
716 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
720 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
723 if( PL_op->op_type == OP_SAY ) {
724 /* local $\ = "\n" */
725 SAVEGENERICSV(PL_ors_sv);
726 PL_ors_sv = newSVpvs("\n");
728 call_method("PRINT", G_SCALAR);
736 if (!(io = GvIO(gv))) {
737 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
738 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
740 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
741 report_evil_fh(gv, io, PL_op->op_type);
742 SETERRNO(EBADF,RMS_IFI);
745 else if (!(fp = IoOFP(io))) {
746 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
748 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
749 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
750 report_evil_fh(gv, io, PL_op->op_type);
752 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
756 SV * const ofs = GvSV(PL_ofsgv); /* $, */
758 if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
760 if (!do_print(*MARK, fp))
764 /* don't use 'ofs' here - it may be invalidated by magic callbacks */
765 if (!do_print(GvSV(PL_ofsgv), fp)) {
774 if (!do_print(*MARK, fp))
782 if (PL_op->op_type == OP_SAY) {
783 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
786 else if (PL_ors_sv && SvOK(PL_ors_sv))
787 if (!do_print(PL_ors_sv, fp)) /* $\ */
790 if (IoFLAGS(io) & IOf_FLUSH)
791 if (PerlIO_flush(fp) == EOF)
801 XPUSHs(&PL_sv_undef);
808 const I32 gimme = GIMME_V;
809 static const char an_array[] = "an ARRAY";
810 static const char a_hash[] = "a HASH";
811 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
812 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
816 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
819 if (SvTYPE(sv) != type)
820 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
821 if (PL_op->op_flags & OPf_REF) {
826 if (gimme != G_ARRAY)
827 goto croak_cant_return;
831 else if (PL_op->op_flags & OPf_MOD
832 && PL_op->op_private & OPpLVAL_INTRO)
833 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
836 if (SvTYPE(sv) == type) {
837 if (PL_op->op_flags & OPf_REF) {
842 if (gimme != G_ARRAY)
843 goto croak_cant_return;
851 if (!isGV_with_GP(sv)) {
852 if (SvGMAGICAL(sv)) {
857 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
865 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
866 if (PL_op->op_private & OPpLVAL_INTRO)
867 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
868 if (PL_op->op_flags & OPf_REF) {
873 if (gimme != G_ARRAY)
874 goto croak_cant_return;
882 AV *const av = MUTABLE_AV(sv);
883 /* The guts of pp_rv2av, with no intenting change to preserve history
884 (until such time as we get tools that can do blame annotation across
885 whitespace changes. */
886 if (gimme == G_ARRAY) {
887 const I32 maxarg = AvFILL(av) + 1;
888 (void)POPs; /* XXXX May be optimized away? */
890 if (SvRMAGICAL(av)) {
892 for (i=0; i < (U32)maxarg; i++) {
893 SV ** const svp = av_fetch(av, i, FALSE);
894 /* See note in pp_helem, and bug id #27839 */
896 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
901 Copy(AvARRAY(av), SP+1, maxarg, SV*);
905 else if (gimme == G_SCALAR) {
907 const I32 maxarg = AvFILL(av) + 1;
911 /* The guts of pp_rv2hv */
912 if (gimme == G_ARRAY) { /* array wanted */
916 else if (gimme == G_SCALAR) {
918 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
926 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
927 is_pp_rv2av ? "array" : "hash");
932 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
936 PERL_ARGS_ASSERT_DO_ODDBALL;
942 if (ckWARN(WARN_MISC)) {
944 if (relem == firstrelem &&
946 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
947 SvTYPE(SvRV(*relem)) == SVt_PVHV))
949 err = "Reference found where even-sized list expected";
952 err = "Odd number of elements in hash assignment";
953 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
957 didstore = hv_store_ent(hash,*relem,tmpstr,0);
958 if (SvMAGICAL(hash)) {
959 if (SvSMAGICAL(tmpstr))
971 SV **lastlelem = PL_stack_sp;
972 SV **lastrelem = PL_stack_base + POPMARK;
973 SV **firstrelem = PL_stack_base + POPMARK + 1;
974 SV **firstlelem = lastrelem + 1;
987 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
989 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
992 /* If there's a common identifier on both sides we have to take
993 * special care that assigning the identifier on the left doesn't
994 * clobber a value on the right that's used later in the list.
996 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
997 EXTEND_MORTAL(lastrelem - firstrelem + 1);
998 for (relem = firstrelem; relem <= lastrelem; relem++) {
1000 TAINT_NOT; /* Each item is independent */
1001 *relem = sv_mortalcopy(sv);
1011 while (lelem <= lastlelem) {
1012 TAINT_NOT; /* Each item stands on its own, taintwise. */
1014 switch (SvTYPE(sv)) {
1016 ary = MUTABLE_AV(sv);
1017 magic = SvMAGICAL(ary) != 0;
1019 av_extend(ary, lastrelem - relem);
1021 while (relem <= lastrelem) { /* gobble up all the rest */
1024 sv = newSVsv(*relem);
1026 didstore = av_store(ary,i++,sv);
1028 if (SvSMAGICAL(sv)) {
1029 /* More magic can happen in the mg_set callback, so we
1030 * backup the delaymagic for now. */
1031 U16 dmbak = PL_delaymagic;
1034 PL_delaymagic = dmbak;
1041 if (PL_delaymagic & DM_ARRAY)
1042 SvSETMAGIC(MUTABLE_SV(ary));
1044 case SVt_PVHV: { /* normal hash */
1047 hash = MUTABLE_HV(sv);
1048 magic = SvMAGICAL(hash) != 0;
1050 firsthashrelem = relem;
1052 while (relem < lastrelem) { /* gobble up all the rest */
1054 sv = *relem ? *relem : &PL_sv_no;
1058 sv_setsv(tmpstr,*relem); /* value */
1059 *(relem++) = tmpstr;
1060 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1061 /* key overwrites an existing entry */
1063 didstore = hv_store_ent(hash,sv,tmpstr,0);
1065 if (SvSMAGICAL(tmpstr)) {
1066 U16 dmbak = PL_delaymagic;
1069 PL_delaymagic = dmbak;
1076 if (relem == lastrelem) {
1077 do_oddball(hash, relem, firstrelem);
1083 if (SvIMMORTAL(sv)) {
1084 if (relem <= lastrelem)
1088 if (relem <= lastrelem) {
1089 sv_setsv(sv, *relem);
1093 sv_setsv(sv, &PL_sv_undef);
1095 if (SvSMAGICAL(sv)) {
1096 U16 dmbak = PL_delaymagic;
1099 PL_delaymagic = dmbak;
1104 if (PL_delaymagic & ~DM_DELAY) {
1105 if (PL_delaymagic & DM_UID) {
1106 #ifdef HAS_SETRESUID
1107 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1108 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1111 # ifdef HAS_SETREUID
1112 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1113 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1116 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1117 (void)setruid(PL_uid);
1118 PL_delaymagic &= ~DM_RUID;
1120 # endif /* HAS_SETRUID */
1122 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1123 (void)seteuid(PL_euid);
1124 PL_delaymagic &= ~DM_EUID;
1126 # endif /* HAS_SETEUID */
1127 if (PL_delaymagic & DM_UID) {
1128 if (PL_uid != PL_euid)
1129 DIE(aTHX_ "No setreuid available");
1130 (void)PerlProc_setuid(PL_uid);
1132 # endif /* HAS_SETREUID */
1133 #endif /* HAS_SETRESUID */
1134 PL_uid = PerlProc_getuid();
1135 PL_euid = PerlProc_geteuid();
1137 if (PL_delaymagic & DM_GID) {
1138 #ifdef HAS_SETRESGID
1139 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1140 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1143 # ifdef HAS_SETREGID
1144 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1145 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1148 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1149 (void)setrgid(PL_gid);
1150 PL_delaymagic &= ~DM_RGID;
1152 # endif /* HAS_SETRGID */
1154 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1155 (void)setegid(PL_egid);
1156 PL_delaymagic &= ~DM_EGID;
1158 # endif /* HAS_SETEGID */
1159 if (PL_delaymagic & DM_GID) {
1160 if (PL_gid != PL_egid)
1161 DIE(aTHX_ "No setregid available");
1162 (void)PerlProc_setgid(PL_gid);
1164 # endif /* HAS_SETREGID */
1165 #endif /* HAS_SETRESGID */
1166 PL_gid = PerlProc_getgid();
1167 PL_egid = PerlProc_getegid();
1169 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1173 if (gimme == G_VOID)
1174 SP = firstrelem - 1;
1175 else if (gimme == G_SCALAR) {
1178 SETi(lastrelem - firstrelem + 1 - duplicates);
1185 /* Removes from the stack the entries which ended up as
1186 * duplicated keys in the hash (fix for [perl #24380]) */
1187 Move(firsthashrelem + duplicates,
1188 firsthashrelem, duplicates, SV**);
1189 lastrelem -= duplicates;
1194 SP = firstrelem + (lastlelem - firstlelem);
1195 lelem = firstlelem + (relem - firstrelem);
1197 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1206 register PMOP * const pm = cPMOP;
1207 REGEXP * rx = PM_GETRE(pm);
1208 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1209 SV * const rv = sv_newmortal();
1211 SvUPGRADE(rv, SVt_IV);
1212 /* This RV is about to own a reference to the regexp. (In addition to the
1213 reference already owned by the PMOP. */
1215 SvRV_set(rv, MUTABLE_SV(rx));
1219 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1221 (void)sv_bless(rv, stash);
1224 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1233 register PMOP *pm = cPMOP;
1235 register const char *t;
1236 register const char *s;
1239 U8 r_flags = REXEC_CHECKED;
1240 const char *truebase; /* Start of string */
1241 register REGEXP *rx = PM_GETRE(pm);
1243 const I32 gimme = GIMME;
1246 const I32 oldsave = PL_savestack_ix;
1247 I32 update_minmatch = 1;
1248 I32 had_zerolen = 0;
1251 if (PL_op->op_flags & OPf_STACKED)
1253 else if (PL_op->op_private & OPpTARGET_MY)
1260 PUTBACK; /* EVAL blocks need stack_sp. */
1261 s = SvPV_const(TARG, len);
1263 DIE(aTHX_ "panic: pp_match");
1265 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1266 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1269 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1271 /* PMdf_USED is set after a ?? matches once */
1274 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1276 pm->op_pmflags & PMf_USED
1280 if (gimme == G_ARRAY)
1287 /* empty pattern special-cased to use last successful pattern if possible */
1288 if (!RX_PRELEN(rx) && PL_curpm) {
1293 if (RX_MINLEN(rx) > (I32)len)
1298 /* XXXX What part of this is needed with true \G-support? */
1299 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1300 RX_OFFS(rx)[0].start = -1;
1301 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1302 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1303 if (mg && mg->mg_len >= 0) {
1304 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1305 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1306 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1307 r_flags |= REXEC_IGNOREPOS;
1308 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1309 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1312 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1313 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1314 update_minmatch = 0;
1318 /* XXX: comment out !global get safe $1 vars after a
1319 match, BUT be aware that this leads to dramatic slowdowns on
1320 /g matches against large strings. So far a solution to this problem
1321 appears to be quite tricky.
1322 Test for the unsafe vars are TODO for now. */
1323 if (( !global && RX_NPARENS(rx))
1324 || SvTEMP(TARG) || PL_sawampersand ||
1325 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1326 r_flags |= REXEC_COPY_STR;
1328 r_flags |= REXEC_SCREAM;
1331 if (global && RX_OFFS(rx)[0].start != -1) {
1332 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1333 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1335 if (update_minmatch++)
1336 minmatch = had_zerolen;
1338 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1339 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1340 /* FIXME - can PL_bostr be made const char *? */
1341 PL_bostr = (char *)truebase;
1342 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1346 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1348 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1349 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1350 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1351 && (r_flags & REXEC_SCREAM)))
1352 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1355 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1356 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1359 if (dynpm->op_pmflags & PMf_ONCE) {
1361 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1363 dynpm->op_pmflags |= PMf_USED;
1374 RX_MATCH_TAINTED_on(rx);
1375 TAINT_IF(RX_MATCH_TAINTED(rx));
1376 if (gimme == G_ARRAY) {
1377 const I32 nparens = RX_NPARENS(rx);
1378 I32 i = (global && !nparens) ? 1 : 0;
1380 SPAGAIN; /* EVAL blocks could move the stack. */
1381 EXTEND(SP, nparens + i);
1382 EXTEND_MORTAL(nparens + i);
1383 for (i = !i; i <= nparens; i++) {
1384 PUSHs(sv_newmortal());
1385 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1386 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1387 s = RX_OFFS(rx)[i].start + truebase;
1388 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1389 len < 0 || len > strend - s)
1390 DIE(aTHX_ "panic: pp_match start/end pointers");
1391 sv_setpvn(*SP, s, len);
1392 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1397 if (dynpm->op_pmflags & PMf_CONTINUE) {
1399 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1400 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1402 #ifdef PERL_OLD_COPY_ON_WRITE
1404 sv_force_normal_flags(TARG, 0);
1406 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1407 &PL_vtbl_mglob, NULL, 0);
1409 if (RX_OFFS(rx)[0].start != -1) {
1410 mg->mg_len = RX_OFFS(rx)[0].end;
1411 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1412 mg->mg_flags |= MGf_MINMATCH;
1414 mg->mg_flags &= ~MGf_MINMATCH;
1417 had_zerolen = (RX_OFFS(rx)[0].start != -1
1418 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1419 == (UV)RX_OFFS(rx)[0].end));
1420 PUTBACK; /* EVAL blocks may use stack */
1421 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1426 LEAVE_SCOPE(oldsave);
1432 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1433 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1437 #ifdef PERL_OLD_COPY_ON_WRITE
1439 sv_force_normal_flags(TARG, 0);
1441 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1442 &PL_vtbl_mglob, NULL, 0);
1444 if (RX_OFFS(rx)[0].start != -1) {
1445 mg->mg_len = RX_OFFS(rx)[0].end;
1446 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1447 mg->mg_flags |= MGf_MINMATCH;
1449 mg->mg_flags &= ~MGf_MINMATCH;
1452 LEAVE_SCOPE(oldsave);
1456 yup: /* Confirmed by INTUIT */
1458 RX_MATCH_TAINTED_on(rx);
1459 TAINT_IF(RX_MATCH_TAINTED(rx));
1461 if (dynpm->op_pmflags & PMf_ONCE) {
1463 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1465 dynpm->op_pmflags |= PMf_USED;
1468 if (RX_MATCH_COPIED(rx))
1469 Safefree(RX_SUBBEG(rx));
1470 RX_MATCH_COPIED_off(rx);
1471 RX_SUBBEG(rx) = NULL;
1473 /* FIXME - should rx->subbeg be const char *? */
1474 RX_SUBBEG(rx) = (char *) truebase;
1475 RX_OFFS(rx)[0].start = s - truebase;
1476 if (RX_MATCH_UTF8(rx)) {
1477 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1478 RX_OFFS(rx)[0].end = t - truebase;
1481 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1483 RX_SUBLEN(rx) = strend - truebase;
1486 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1488 #ifdef PERL_OLD_COPY_ON_WRITE
1489 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1491 PerlIO_printf(Perl_debug_log,
1492 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1493 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1496 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1498 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1499 assert (SvPOKp(RX_SAVED_COPY(rx)));
1504 RX_SUBBEG(rx) = savepvn(t, strend - t);
1505 #ifdef PERL_OLD_COPY_ON_WRITE
1506 RX_SAVED_COPY(rx) = NULL;
1509 RX_SUBLEN(rx) = strend - t;
1510 RX_MATCH_COPIED_on(rx);
1511 off = RX_OFFS(rx)[0].start = s - t;
1512 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1514 else { /* startp/endp are used by @- @+. */
1515 RX_OFFS(rx)[0].start = s - truebase;
1516 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1518 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1520 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1521 LEAVE_SCOPE(oldsave);
1526 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1527 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1528 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1533 LEAVE_SCOPE(oldsave);
1534 if (gimme == G_ARRAY)
1540 Perl_do_readline(pTHX)
1542 dVAR; dSP; dTARGETSTACKED;
1547 register IO * const io = GvIO(PL_last_in_gv);
1548 register const I32 type = PL_op->op_type;
1549 const I32 gimme = GIMME_V;
1552 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1555 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1558 call_method("READLINE", gimme);
1561 if (gimme == G_SCALAR) {
1562 SV* const result = POPs;
1563 SvSetSV_nosteal(TARG, result);
1573 if (IoFLAGS(io) & IOf_ARGV) {
1574 if (IoFLAGS(io) & IOf_START) {
1576 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1577 IoFLAGS(io) &= ~IOf_START;
1578 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1579 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1580 SvSETMAGIC(GvSV(PL_last_in_gv));
1585 fp = nextargv(PL_last_in_gv);
1586 if (!fp) { /* Note: fp != IoIFP(io) */
1587 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1590 else if (type == OP_GLOB)
1591 fp = Perl_start_glob(aTHX_ POPs, io);
1593 else if (type == OP_GLOB)
1595 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1596 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1600 if ((!io || !(IoFLAGS(io) & IOf_START))
1601 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1603 if (type == OP_GLOB)
1604 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1605 "glob failed (can't start child: %s)",
1608 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1610 if (gimme == G_SCALAR) {
1611 /* undef TARG, and push that undefined value */
1612 if (type != OP_RCATLINE) {
1613 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1621 if (gimme == G_SCALAR) {
1623 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1626 if (type == OP_RCATLINE)
1627 SvPV_force_nolen(sv);
1631 else if (isGV_with_GP(sv)) {
1632 SvPV_force_nolen(sv);
1634 SvUPGRADE(sv, SVt_PV);
1635 tmplen = SvLEN(sv); /* remember if already alloced */
1636 if (!tmplen && !SvREADONLY(sv))
1637 Sv_Grow(sv, 80); /* try short-buffering it */
1639 if (type == OP_RCATLINE && SvOK(sv)) {
1641 SvPV_force_nolen(sv);
1647 sv = sv_2mortal(newSV(80));
1651 /* This should not be marked tainted if the fp is marked clean */
1652 #define MAYBE_TAINT_LINE(io, sv) \
1653 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1658 /* delay EOF state for a snarfed empty file */
1659 #define SNARF_EOF(gimme,rs,io,sv) \
1660 (gimme != G_SCALAR || SvCUR(sv) \
1661 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1665 if (!sv_gets(sv, fp, offset)
1667 || SNARF_EOF(gimme, PL_rs, io, sv)
1668 || PerlIO_error(fp)))
1670 PerlIO_clearerr(fp);
1671 if (IoFLAGS(io) & IOf_ARGV) {
1672 fp = nextargv(PL_last_in_gv);
1675 (void)do_close(PL_last_in_gv, FALSE);
1677 else if (type == OP_GLOB) {
1678 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1679 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1680 "glob failed (child exited with status %d%s)",
1681 (int)(STATUS_CURRENT >> 8),
1682 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1685 if (gimme == G_SCALAR) {
1686 if (type != OP_RCATLINE) {
1687 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1693 MAYBE_TAINT_LINE(io, sv);
1696 MAYBE_TAINT_LINE(io, sv);
1698 IoFLAGS(io) |= IOf_NOLINE;
1702 if (type == OP_GLOB) {
1705 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1706 char * const tmps = SvEND(sv) - 1;
1707 if (*tmps == *SvPVX_const(PL_rs)) {
1709 SvCUR_set(sv, SvCUR(sv) - 1);
1712 for (t1 = SvPVX_const(sv); *t1; t1++)
1713 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1714 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1716 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1717 (void)POPs; /* Unmatched wildcard? Chuck it... */
1720 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1721 if (ckWARN(WARN_UTF8)) {
1722 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1723 const STRLEN len = SvCUR(sv) - offset;
1726 if (!is_utf8_string_loc(s, len, &f))
1727 /* Emulate :encoding(utf8) warning in the same case. */
1728 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1729 "utf8 \"\\x%02X\" does not map to Unicode",
1730 f < (U8*)SvEND(sv) ? *f : 0);
1733 if (gimme == G_ARRAY) {
1734 if (SvLEN(sv) - SvCUR(sv) > 20) {
1735 SvPV_shrink_to_cur(sv);
1737 sv = sv_2mortal(newSV(80));
1740 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1741 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1742 const STRLEN new_len
1743 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1744 SvPV_renew(sv, new_len);
1753 register PERL_CONTEXT *cx;
1754 I32 gimme = OP_GIMME(PL_op, -1);
1757 if (cxstack_ix >= 0) {
1758 /* If this flag is set, we're just inside a return, so we should
1759 * store the caller's context */
1760 gimme = (PL_op->op_flags & OPf_SPECIAL)
1762 : cxstack[cxstack_ix].blk_gimme;
1770 PUSHBLOCK(cx, CXt_BLOCK, SP);
1780 SV * const keysv = POPs;
1781 HV * const hv = MUTABLE_HV(POPs);
1782 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1783 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1785 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1786 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1787 bool preeminent = TRUE;
1789 if (SvTYPE(hv) != SVt_PVHV)
1796 /* If we can determine whether the element exist,
1797 * Try to preserve the existenceness of a tied hash
1798 * element by using EXISTS and DELETE if possible.
1799 * Fallback to FETCH and STORE otherwise. */
1800 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1801 preeminent = hv_exists_ent(hv, keysv, 0);
1804 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1805 svp = he ? &HeVAL(he) : NULL;
1807 if (!svp || *svp == &PL_sv_undef) {
1811 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1813 lv = sv_newmortal();
1814 sv_upgrade(lv, SVt_PVLV);
1816 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1817 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1818 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1824 if (HvNAME_get(hv) && isGV(*svp))
1825 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1829 const char * const key = SvPV_const(keysv, keylen);
1830 SAVEDELETE(hv, savepvn(key,keylen),
1831 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1833 save_helem_flags(hv, keysv, svp,
1834 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1837 else if (PL_op->op_private & OPpDEREF)
1838 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1840 sv = (svp ? *svp : &PL_sv_undef);
1841 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1842 * Pushing the magical RHS on to the stack is useless, since
1843 * that magic is soon destined to be misled by the local(),
1844 * and thus the later pp_sassign() will fail to mg_get() the
1845 * old value. This should also cure problems with delayed
1846 * mg_get()s. GSAR 98-07-03 */
1847 if (!lval && SvGMAGICAL(sv))
1848 sv = sv_mortalcopy(sv);
1856 register PERL_CONTEXT *cx;
1861 if (PL_op->op_flags & OPf_SPECIAL) {
1862 cx = &cxstack[cxstack_ix];
1863 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1868 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1871 if (gimme == G_VOID)
1873 else if (gimme == G_SCALAR) {
1877 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1880 *MARK = sv_mortalcopy(TOPs);
1883 *MARK = &PL_sv_undef;
1887 else if (gimme == G_ARRAY) {
1888 /* in case LEAVE wipes old return values */
1890 for (mark = newsp + 1; mark <= SP; mark++) {
1891 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1892 *mark = sv_mortalcopy(*mark);
1893 TAINT_NOT; /* Each item is independent */
1897 PL_curpm = newpm; /* Don't pop $1 et al till now */
1907 register PERL_CONTEXT *cx;
1910 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1911 bool av_is_stack = FALSE;
1914 cx = &cxstack[cxstack_ix];
1915 if (!CxTYPE_is_LOOP(cx))
1916 DIE(aTHX_ "panic: pp_iter");
1918 itersvp = CxITERVAR(cx);
1919 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1920 /* string increment */
1921 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1922 SV *end = cx->blk_loop.state_u.lazysv.end;
1923 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1924 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1926 const char *max = SvPV_const(end, maxlen);
1927 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1928 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1929 /* safe to reuse old SV */
1930 sv_setsv(*itersvp, cur);
1934 /* we need a fresh SV every time so that loop body sees a
1935 * completely new SV for closures/references to work as
1938 *itersvp = newSVsv(cur);
1939 SvREFCNT_dec(oldsv);
1941 if (strEQ(SvPVX_const(cur), max))
1942 sv_setiv(cur, 0); /* terminate next time */
1949 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1950 /* integer increment */
1951 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1954 /* don't risk potential race */
1955 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1956 /* safe to reuse old SV */
1957 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1961 /* we need a fresh SV every time so that loop body sees a
1962 * completely new SV for closures/references to work as they
1965 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1966 SvREFCNT_dec(oldsv);
1969 /* Handle end of range at IV_MAX */
1970 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1971 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1973 cx->blk_loop.state_u.lazyiv.cur++;
1974 cx->blk_loop.state_u.lazyiv.end++;
1981 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1982 av = cx->blk_loop.state_u.ary.ary;
1987 if (PL_op->op_private & OPpITER_REVERSED) {
1988 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1989 ? cx->blk_loop.resetsp + 1 : 0))
1992 if (SvMAGICAL(av) || AvREIFY(av)) {
1993 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1994 sv = svp ? *svp : NULL;
1997 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2001 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2005 if (SvMAGICAL(av) || AvREIFY(av)) {
2006 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2007 sv = svp ? *svp : NULL;
2010 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2014 if (sv && SvIS_FREED(sv)) {
2016 Perl_croak(aTHX_ "Use of freed value in iteration");
2021 SvREFCNT_inc_simple_void_NN(sv);
2025 if (!av_is_stack && sv == &PL_sv_undef) {
2026 SV *lv = newSV_type(SVt_PVLV);
2028 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2029 LvTARG(lv) = SvREFCNT_inc_simple(av);
2030 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2031 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2037 SvREFCNT_dec(oldsv);
2045 register PMOP *pm = cPMOP;
2060 register REGEXP *rx = PM_GETRE(pm);
2062 int force_on_match = 0;
2063 const I32 oldsave = PL_savestack_ix;
2065 bool doutf8 = FALSE;
2067 #ifdef PERL_OLD_COPY_ON_WRITE
2072 /* known replacement string? */
2073 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2074 if (PL_op->op_flags & OPf_STACKED)
2076 else if (PL_op->op_private & OPpTARGET_MY)
2083 #ifdef PERL_OLD_COPY_ON_WRITE
2084 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2085 because they make integers such as 256 "false". */
2086 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089 sv_force_normal_flags(TARG,0);
2092 #ifdef PERL_OLD_COPY_ON_WRITE
2096 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2097 || SvTYPE(TARG) > SVt_PVLV)
2098 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2099 DIE(aTHX_ "%s", PL_no_modify);
2102 s = SvPV_mutable(TARG, len);
2103 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2105 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2106 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2111 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2115 DIE(aTHX_ "panic: pp_subst");
2118 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2119 maxiters = 2 * slen + 10; /* We can match twice at each
2120 position, once with zero-length,
2121 second time with non-zero. */
2123 if (!RX_PRELEN(rx) && PL_curpm) {
2127 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2128 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2129 ? REXEC_COPY_STR : 0;
2131 r_flags |= REXEC_SCREAM;
2134 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2136 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2140 /* How to do it in subst? */
2141 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2143 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2144 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2145 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2146 && (r_flags & REXEC_SCREAM))))
2151 /* only replace once? */
2152 once = !(rpm->op_pmflags & PMf_GLOBAL);
2153 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2154 r_flags | REXEC_CHECKED);
2155 /* known replacement string? */
2157 /* replacement needing upgrading? */
2158 if (DO_UTF8(TARG) && !doutf8) {
2159 nsv = sv_newmortal();
2162 sv_recode_to_utf8(nsv, PL_encoding);
2164 sv_utf8_upgrade(nsv);
2165 c = SvPV_const(nsv, clen);
2169 c = SvPV_const(dstr, clen);
2170 doutf8 = DO_UTF8(dstr);
2178 /* can do inplace substitution? */
2180 #ifdef PERL_OLD_COPY_ON_WRITE
2183 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2184 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2185 && (!doutf8 || SvUTF8(TARG))) {
2190 LEAVE_SCOPE(oldsave);
2193 #ifdef PERL_OLD_COPY_ON_WRITE
2194 if (SvIsCOW(TARG)) {
2195 assert (!force_on_match);
2199 if (force_on_match) {
2201 s = SvPV_force(TARG, len);
2206 SvSCREAM_off(TARG); /* disable possible screamer */
2208 rxtainted |= RX_MATCH_TAINTED(rx);
2209 m = orig + RX_OFFS(rx)[0].start;
2210 d = orig + RX_OFFS(rx)[0].end;
2212 if (m - s > strend - d) { /* faster to shorten from end */
2214 Copy(c, m, clen, char);
2219 Move(d, m, i, char);
2223 SvCUR_set(TARG, m - s);
2225 else if ((i = m - s)) { /* faster from front */
2228 Move(s, d - i, i, char);
2231 Copy(c, m, clen, char);
2236 Copy(c, d, clen, char);
2241 TAINT_IF(rxtainted & 1);
2247 if (iters++ > maxiters)
2248 DIE(aTHX_ "Substitution loop");
2249 rxtainted |= RX_MATCH_TAINTED(rx);
2250 m = RX_OFFS(rx)[0].start + orig;
2253 Move(s, d, i, char);
2257 Copy(c, d, clen, char);
2260 s = RX_OFFS(rx)[0].end + orig;
2261 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2263 /* don't match same null twice */
2264 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2267 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2268 Move(s, d, i+1, char); /* include the NUL */
2270 TAINT_IF(rxtainted & 1);
2274 (void)SvPOK_only_UTF8(TARG);
2275 TAINT_IF(rxtainted);
2276 if (SvSMAGICAL(TARG)) {
2284 LEAVE_SCOPE(oldsave);
2290 if (force_on_match) {
2292 s = SvPV_force(TARG, len);
2295 #ifdef PERL_OLD_COPY_ON_WRITE
2298 rxtainted |= RX_MATCH_TAINTED(rx);
2299 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2303 register PERL_CONTEXT *cx;
2306 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2308 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2310 if (iters++ > maxiters)
2311 DIE(aTHX_ "Substitution loop");
2312 rxtainted |= RX_MATCH_TAINTED(rx);
2313 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2316 orig = RX_SUBBEG(rx);
2318 strend = s + (strend - m);
2320 m = RX_OFFS(rx)[0].start + orig;
2321 if (doutf8 && !SvUTF8(dstr))
2322 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2324 sv_catpvn(dstr, s, m-s);
2325 s = RX_OFFS(rx)[0].end + orig;
2327 sv_catpvn(dstr, c, clen);
2330 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2331 TARG, NULL, r_flags));
2332 if (doutf8 && !DO_UTF8(TARG))
2333 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2335 sv_catpvn(dstr, s, strend - s);
2337 #ifdef PERL_OLD_COPY_ON_WRITE
2338 /* The match may make the string COW. If so, brilliant, because that's
2339 just saved us one malloc, copy and free - the regexp has donated
2340 the old buffer, and we malloc an entirely new one, rather than the
2341 regexp malloc()ing a buffer and copying our original, only for
2342 us to throw it away here during the substitution. */
2343 if (SvIsCOW(TARG)) {
2344 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2350 SvPV_set(TARG, SvPVX(dstr));
2351 SvCUR_set(TARG, SvCUR(dstr));
2352 SvLEN_set(TARG, SvLEN(dstr));
2353 doutf8 |= DO_UTF8(dstr);
2354 SvPV_set(dstr, NULL);
2356 TAINT_IF(rxtainted & 1);
2360 (void)SvPOK_only(TARG);
2363 TAINT_IF(rxtainted);
2366 LEAVE_SCOPE(oldsave);
2375 LEAVE_SCOPE(oldsave);
2384 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2385 ++*PL_markstack_ptr;
2386 LEAVE; /* exit inner scope */
2389 if (PL_stack_base + *PL_markstack_ptr > SP) {
2391 const I32 gimme = GIMME_V;
2393 LEAVE; /* exit outer scope */
2394 (void)POPMARK; /* pop src */
2395 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2396 (void)POPMARK; /* pop dst */
2397 SP = PL_stack_base + POPMARK; /* pop original mark */
2398 if (gimme == G_SCALAR) {
2399 if (PL_op->op_private & OPpGREP_LEX) {
2400 SV* const sv = sv_newmortal();
2401 sv_setiv(sv, items);
2409 else if (gimme == G_ARRAY)
2416 ENTER; /* enter inner scope */
2419 src = PL_stack_base[*PL_markstack_ptr];
2421 if (PL_op->op_private & OPpGREP_LEX)
2422 PAD_SVl(PL_op->op_targ) = src;
2426 RETURNOP(cLOGOP->op_other);
2437 register PERL_CONTEXT *cx;
2440 if (CxMULTICALL(&cxstack[cxstack_ix]))
2444 cxstack_ix++; /* temporarily protect top context */
2447 if (gimme == G_SCALAR) {
2450 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2452 *MARK = SvREFCNT_inc(TOPs);
2457 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2459 *MARK = sv_mortalcopy(sv);
2464 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2468 *MARK = &PL_sv_undef;
2472 else if (gimme == G_ARRAY) {
2473 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2474 if (!SvTEMP(*MARK)) {
2475 *MARK = sv_mortalcopy(*MARK);
2476 TAINT_NOT; /* Each item is independent */
2484 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2485 PL_curpm = newpm; /* ... and pop $1 et al */
2488 return cx->blk_sub.retop;
2491 /* This duplicates the above code because the above code must not
2492 * get any slower by more conditions */
2500 register PERL_CONTEXT *cx;
2503 if (CxMULTICALL(&cxstack[cxstack_ix]))
2507 cxstack_ix++; /* temporarily protect top context */
2511 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2512 /* We are an argument to a function or grep().
2513 * This kind of lvalueness was legal before lvalue
2514 * subroutines too, so be backward compatible:
2515 * cannot report errors. */
2517 /* Scalar context *is* possible, on the LHS of -> only,
2518 * as in f()->meth(). But this is not an lvalue. */
2519 if (gimme == G_SCALAR)
2521 if (gimme == G_ARRAY) {
2522 if (!CvLVALUE(cx->blk_sub.cv))
2523 goto temporise_array;
2524 EXTEND_MORTAL(SP - newsp);
2525 for (mark = newsp + 1; mark <= SP; mark++) {
2528 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2529 *mark = sv_mortalcopy(*mark);
2531 /* Can be a localized value subject to deletion. */
2532 PL_tmps_stack[++PL_tmps_ix] = *mark;
2533 SvREFCNT_inc_void(*mark);
2538 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2539 /* Here we go for robustness, not for speed, so we change all
2540 * the refcounts so the caller gets a live guy. Cannot set
2541 * TEMP, so sv_2mortal is out of question. */
2542 if (!CvLVALUE(cx->blk_sub.cv)) {
2548 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2550 if (gimme == G_SCALAR) {
2554 /* Temporaries are bad unless they happen to be elements
2555 * of a tied hash or array */
2556 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2557 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2563 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2564 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2565 : "a readonly value" : "a temporary");
2567 else { /* Can be a localized value
2568 * subject to deletion. */
2569 PL_tmps_stack[++PL_tmps_ix] = *mark;
2570 SvREFCNT_inc_void(*mark);
2573 else { /* Should not happen? */
2579 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2580 (MARK > SP ? "Empty array" : "Array"));
2584 else if (gimme == G_ARRAY) {
2585 EXTEND_MORTAL(SP - newsp);
2586 for (mark = newsp + 1; mark <= SP; mark++) {
2587 if (*mark != &PL_sv_undef
2588 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2589 /* Might be flattened array after $#array = */
2596 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2597 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2600 /* Can be a localized value subject to deletion. */
2601 PL_tmps_stack[++PL_tmps_ix] = *mark;
2602 SvREFCNT_inc_void(*mark);
2608 if (gimme == G_SCALAR) {
2612 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2614 *MARK = SvREFCNT_inc(TOPs);
2619 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2621 *MARK = sv_mortalcopy(sv);
2626 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2630 *MARK = &PL_sv_undef;
2634 else if (gimme == G_ARRAY) {
2636 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2637 if (!SvTEMP(*MARK)) {
2638 *MARK = sv_mortalcopy(*MARK);
2639 TAINT_NOT; /* Each item is independent */
2648 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2649 PL_curpm = newpm; /* ... and pop $1 et al */
2652 return cx->blk_sub.retop;
2660 register PERL_CONTEXT *cx;
2662 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2665 DIE(aTHX_ "Not a CODE reference");
2666 switch (SvTYPE(sv)) {
2667 /* This is overwhelming the most common case: */
2669 if (!isGV_with_GP(sv))
2670 DIE(aTHX_ "Not a CODE reference");
2671 if (!(cv = GvCVu((const GV *)sv))) {
2673 cv = sv_2cv(sv, &stash, &gv, 0);
2685 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2687 SP = PL_stack_base + POPMARK;
2690 if (SvGMAGICAL(sv)) {
2695 sym = SvPVX_const(sv);
2703 sym = SvPV_const(sv, len);
2706 DIE(aTHX_ PL_no_usym, "a subroutine");
2707 if (PL_op->op_private & HINT_STRICT_REFS)
2708 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2709 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2714 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2715 tryAMAGICunDEREF(to_cv);
2717 cv = MUTABLE_CV(SvRV(sv));
2718 if (SvTYPE(cv) == SVt_PVCV)
2723 DIE(aTHX_ "Not a CODE reference");
2724 /* This is the second most common case: */
2726 cv = MUTABLE_CV(sv);
2734 if (!CvROOT(cv) && !CvXSUB(cv)) {
2738 /* anonymous or undef'd function leaves us no recourse */
2739 if (CvANON(cv) || !(gv = CvGV(cv)))
2740 DIE(aTHX_ "Undefined subroutine called");
2742 /* autoloaded stub? */
2743 if (cv != GvCV(gv)) {
2746 /* should call AUTOLOAD now? */
2749 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2756 sub_name = sv_newmortal();
2757 gv_efullname3(sub_name, gv, NULL);
2758 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2762 DIE(aTHX_ "Not a CODE reference");
2767 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2768 Perl_get_db_sub(aTHX_ &sv, cv);
2770 PL_curcopdb = PL_curcop;
2772 /* check for lsub that handles lvalue subroutines */
2773 cv = GvCV(gv_HVadd(gv_fetchpv("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2774 /* if lsub not found then fall back to DB::sub */
2775 if (!cv) cv = GvCV(PL_DBsub);
2777 cv = GvCV(PL_DBsub);
2780 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2781 DIE(aTHX_ "No DB::sub routine defined");
2784 if (!(CvISXSUB(cv))) {
2785 /* This path taken at least 75% of the time */
2787 register I32 items = SP - MARK;
2788 AV* const padlist = CvPADLIST(cv);
2789 PUSHBLOCK(cx, CXt_SUB, MARK);
2791 cx->blk_sub.retop = PL_op->op_next;
2793 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2794 * that eval'' ops within this sub know the correct lexical space.
2795 * Owing the speed considerations, we choose instead to search for
2796 * the cv using find_runcv() when calling doeval().
2798 if (CvDEPTH(cv) >= 2) {
2799 PERL_STACK_OVERFLOW_CHECK();
2800 pad_push(padlist, CvDEPTH(cv));
2803 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2805 AV *const av = MUTABLE_AV(PAD_SVl(0));
2807 /* @_ is normally not REAL--this should only ever
2808 * happen when DB::sub() calls things that modify @_ */
2813 cx->blk_sub.savearray = GvAV(PL_defgv);
2814 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2815 CX_CURPAD_SAVE(cx->blk_sub);
2816 cx->blk_sub.argarray = av;
2819 if (items > AvMAX(av) + 1) {
2820 SV **ary = AvALLOC(av);
2821 if (AvARRAY(av) != ary) {
2822 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2825 if (items > AvMAX(av) + 1) {
2826 AvMAX(av) = items - 1;
2827 Renew(ary,items,SV*);
2832 Copy(MARK,AvARRAY(av),items,SV*);
2833 AvFILLp(av) = items - 1;
2841 /* warning must come *after* we fully set up the context
2842 * stuff so that __WARN__ handlers can safely dounwind()
2845 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2846 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2847 sub_crush_depth(cv);
2848 RETURNOP(CvSTART(cv));
2851 I32 markix = TOPMARK;
2856 /* Need to copy @_ to stack. Alternative may be to
2857 * switch stack to @_, and copy return values
2858 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2859 AV * const av = GvAV(PL_defgv);
2860 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2863 /* Mark is at the end of the stack. */
2865 Copy(AvARRAY(av), SP + 1, items, SV*);
2870 /* We assume first XSUB in &DB::sub is the called one. */
2872 SAVEVPTR(PL_curcop);
2873 PL_curcop = PL_curcopdb;
2876 /* Do we need to open block here? XXXX */
2877 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2878 (void)(*CvXSUB(cv))(aTHX_ cv);
2880 /* Enforce some sanity in scalar context. */
2881 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2882 if (markix > PL_stack_sp - PL_stack_base)
2883 *(PL_stack_base + markix) = &PL_sv_undef;
2885 *(PL_stack_base + markix) = *PL_stack_sp;
2886 PL_stack_sp = PL_stack_base + markix;
2894 Perl_sub_crush_depth(pTHX_ CV *cv)
2896 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2899 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2901 SV* const tmpstr = sv_newmortal();
2902 gv_efullname3(tmpstr, CvGV(cv), NULL);
2903 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2912 SV* const elemsv = POPs;
2913 IV elem = SvIV(elemsv);
2914 AV *const av = MUTABLE_AV(POPs);
2915 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2916 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2917 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2918 bool preeminent = TRUE;
2921 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2922 Perl_warner(aTHX_ packWARN(WARN_MISC),
2923 "Use of reference \"%"SVf"\" as array index",
2926 elem -= CopARYBASE_get(PL_curcop);
2927 if (SvTYPE(av) != SVt_PVAV)
2934 /* If we can determine whether the element exist,
2935 * Try to preserve the existenceness of a tied array
2936 * element by using EXISTS and DELETE if possible.
2937 * Fallback to FETCH and STORE otherwise. */
2938 if (SvCANEXISTDELETE(av))
2939 preeminent = av_exists(av, elem);
2942 svp = av_fetch(av, elem, lval && !defer);
2944 #ifdef PERL_MALLOC_WRAP
2945 if (SvUOK(elemsv)) {
2946 const UV uv = SvUV(elemsv);
2947 elem = uv > IV_MAX ? IV_MAX : uv;
2949 else if (SvNOK(elemsv))
2950 elem = (IV)SvNV(elemsv);
2952 static const char oom_array_extend[] =
2953 "Out of memory during array extend"; /* Duplicated in av.c */
2954 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2957 if (!svp || *svp == &PL_sv_undef) {
2960 DIE(aTHX_ PL_no_aelem, elem);
2961 lv = sv_newmortal();
2962 sv_upgrade(lv, SVt_PVLV);
2964 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2965 LvTARG(lv) = SvREFCNT_inc_simple(av);
2966 LvTARGOFF(lv) = elem;
2973 save_aelem(av, elem, svp);
2975 SAVEADELETE(av, elem);
2977 else if (PL_op->op_private & OPpDEREF)
2978 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2980 sv = (svp ? *svp : &PL_sv_undef);
2981 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2982 sv = sv_mortalcopy(sv);
2988 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2990 PERL_ARGS_ASSERT_VIVIFY_REF;
2995 Perl_croak(aTHX_ "%s", PL_no_modify);
2996 prepare_SV_for_RV(sv);
2999 SvRV_set(sv, newSV(0));
3002 SvRV_set(sv, MUTABLE_SV(newAV()));
3005 SvRV_set(sv, MUTABLE_SV(newHV()));
3016 SV* const sv = TOPs;
3019 SV* const rsv = SvRV(sv);
3020 if (SvTYPE(rsv) == SVt_PVCV) {
3026 SETs(method_common(sv, NULL));
3033 SV* const sv = cSVOP_sv;
3034 U32 hash = SvSHARED_HASH(sv);
3036 XPUSHs(method_common(sv, &hash));
3041 S_method_common(pTHX_ SV* meth, U32* hashp)
3047 const char* packname = NULL;
3050 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3052 PERL_ARGS_ASSERT_METHOD_COMMON;
3055 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3060 ob = MUTABLE_SV(SvRV(sv));
3064 /* this isn't a reference */
3065 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3066 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3068 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3075 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3076 !(ob=MUTABLE_SV(GvIO(iogv))))
3078 /* this isn't the name of a filehandle either */
3080 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3081 ? !isIDFIRST_utf8((U8*)packname)
3082 : !isIDFIRST(*packname)
3085 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3087 SvOK(sv) ? "without a package or object reference"
3088 : "on an undefined value");
3090 /* assume it's a package name */
3091 stash = gv_stashpvn(packname, packlen, 0);
3095 SV* const ref = newSViv(PTR2IV(stash));
3096 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3100 /* it _is_ a filehandle name -- replace with a reference */
3101 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3104 /* if we got here, ob should be a reference or a glob */
3105 if (!ob || !(SvOBJECT(ob)
3106 || (SvTYPE(ob) == SVt_PVGV
3108 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3111 const char * const name = SvPV_nolen_const(meth);
3112 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3113 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3117 stash = SvSTASH(ob);
3120 /* NOTE: stash may be null, hope hv_fetch_ent and
3121 gv_fetchmethod can cope (it seems they can) */
3123 /* shortcut for simple names */
3125 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3127 gv = MUTABLE_GV(HeVAL(he));
3128 if (isGV(gv) && GvCV(gv) &&
3129 (!GvCVGEN(gv) || GvCVGEN(gv)
3130 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3131 return MUTABLE_SV(GvCV(gv));
3135 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3136 SvPV_nolen_const(meth),
3137 GV_AUTOLOAD | GV_CROAK);
3141 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3146 * c-indentation-style: bsd
3148 * indent-tabs-mode: t
3151 * ex: set ts=8 sts=4 sw=4 noet: