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);
757 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
759 if (!do_print(*MARK, fp))
763 if (!do_print(PL_ofs_sv, fp)) { /* $, */
772 if (!do_print(*MARK, fp))
780 if (PL_op->op_type == OP_SAY) {
781 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
784 else if (PL_ors_sv && SvOK(PL_ors_sv))
785 if (!do_print(PL_ors_sv, fp)) /* $\ */
788 if (IoFLAGS(io) & IOf_FLUSH)
789 if (PerlIO_flush(fp) == EOF)
799 XPUSHs(&PL_sv_undef);
806 const I32 gimme = GIMME_V;
807 static const char an_array[] = "an ARRAY";
808 static const char a_hash[] = "a HASH";
809 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
810 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
814 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
817 if (SvTYPE(sv) != type)
818 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
819 if (PL_op->op_flags & OPf_REF) {
824 if (gimme != G_ARRAY)
825 goto croak_cant_return;
829 else if (PL_op->op_flags & OPf_MOD
830 && PL_op->op_private & OPpLVAL_INTRO)
831 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
834 if (SvTYPE(sv) == type) {
835 if (PL_op->op_flags & OPf_REF) {
840 if (gimme != G_ARRAY)
841 goto croak_cant_return;
849 if (!isGV_with_GP(sv)) {
850 if (SvGMAGICAL(sv)) {
855 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
863 sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
864 if (PL_op->op_private & OPpLVAL_INTRO)
865 sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv));
866 if (PL_op->op_flags & OPf_REF) {
871 if (gimme != G_ARRAY)
872 goto croak_cant_return;
880 AV *const av = MUTABLE_AV(sv);
881 /* The guts of pp_rv2av, with no intenting change to preserve history
882 (until such time as we get tools that can do blame annotation across
883 whitespace changes. */
884 if (gimme == G_ARRAY) {
885 const I32 maxarg = AvFILL(av) + 1;
886 (void)POPs; /* XXXX May be optimized away? */
888 if (SvRMAGICAL(av)) {
890 for (i=0; i < (U32)maxarg; i++) {
891 SV ** const svp = av_fetch(av, i, FALSE);
892 /* See note in pp_helem, and bug id #27839 */
894 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
899 Copy(AvARRAY(av), SP+1, maxarg, SV*);
903 else if (gimme == G_SCALAR) {
905 const I32 maxarg = AvFILL(av) + 1;
909 /* The guts of pp_rv2hv */
910 if (gimme == G_ARRAY) { /* array wanted */
914 else if (gimme == G_SCALAR) {
916 TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
924 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
925 is_pp_rv2av ? "array" : "hash");
930 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
934 PERL_ARGS_ASSERT_DO_ODDBALL;
940 if (ckWARN(WARN_MISC)) {
942 if (relem == firstrelem &&
944 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
945 SvTYPE(SvRV(*relem)) == SVt_PVHV))
947 err = "Reference found where even-sized list expected";
950 err = "Odd number of elements in hash assignment";
951 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
955 didstore = hv_store_ent(hash,*relem,tmpstr,0);
956 if (SvMAGICAL(hash)) {
957 if (SvSMAGICAL(tmpstr))
969 SV **lastlelem = PL_stack_sp;
970 SV **lastrelem = PL_stack_base + POPMARK;
971 SV **firstrelem = PL_stack_base + POPMARK + 1;
972 SV **firstlelem = lastrelem + 1;
985 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
987 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
990 /* If there's a common identifier on both sides we have to take
991 * special care that assigning the identifier on the left doesn't
992 * clobber a value on the right that's used later in the list.
994 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
995 EXTEND_MORTAL(lastrelem - firstrelem + 1);
996 for (relem = firstrelem; relem <= lastrelem; relem++) {
998 TAINT_NOT; /* Each item is independent */
999 *relem = sv_mortalcopy(sv);
1009 while (lelem <= lastlelem) {
1010 TAINT_NOT; /* Each item stands on its own, taintwise. */
1012 switch (SvTYPE(sv)) {
1014 ary = MUTABLE_AV(sv);
1015 magic = SvMAGICAL(ary) != 0;
1017 av_extend(ary, lastrelem - relem);
1019 while (relem <= lastrelem) { /* gobble up all the rest */
1022 sv = newSVsv(*relem);
1024 didstore = av_store(ary,i++,sv);
1026 if (SvSMAGICAL(sv)) {
1027 /* More magic can happen in the mg_set callback, so we
1028 * backup the delaymagic for now. */
1029 U16 dmbak = PL_delaymagic;
1032 PL_delaymagic = dmbak;
1039 if (PL_delaymagic & DM_ARRAY)
1040 SvSETMAGIC(MUTABLE_SV(ary));
1042 case SVt_PVHV: { /* normal hash */
1045 hash = MUTABLE_HV(sv);
1046 magic = SvMAGICAL(hash) != 0;
1048 firsthashrelem = relem;
1050 while (relem < lastrelem) { /* gobble up all the rest */
1052 sv = *relem ? *relem : &PL_sv_no;
1056 sv_setsv(tmpstr,*relem); /* value */
1057 *(relem++) = tmpstr;
1058 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1059 /* key overwrites an existing entry */
1061 didstore = hv_store_ent(hash,sv,tmpstr,0);
1063 if (SvSMAGICAL(tmpstr)) {
1064 U16 dmbak = PL_delaymagic;
1067 PL_delaymagic = dmbak;
1074 if (relem == lastrelem) {
1075 do_oddball(hash, relem, firstrelem);
1081 if (SvIMMORTAL(sv)) {
1082 if (relem <= lastrelem)
1086 if (relem <= lastrelem) {
1087 sv_setsv(sv, *relem);
1091 sv_setsv(sv, &PL_sv_undef);
1093 if (SvSMAGICAL(sv)) {
1094 U16 dmbak = PL_delaymagic;
1097 PL_delaymagic = dmbak;
1102 if (PL_delaymagic & ~DM_DELAY) {
1103 if (PL_delaymagic & DM_UID) {
1104 #ifdef HAS_SETRESUID
1105 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1106 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1109 # ifdef HAS_SETREUID
1110 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1111 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1114 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1115 (void)setruid(PL_uid);
1116 PL_delaymagic &= ~DM_RUID;
1118 # endif /* HAS_SETRUID */
1120 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1121 (void)seteuid(PL_euid);
1122 PL_delaymagic &= ~DM_EUID;
1124 # endif /* HAS_SETEUID */
1125 if (PL_delaymagic & DM_UID) {
1126 if (PL_uid != PL_euid)
1127 DIE(aTHX_ "No setreuid available");
1128 (void)PerlProc_setuid(PL_uid);
1130 # endif /* HAS_SETREUID */
1131 #endif /* HAS_SETRESUID */
1132 PL_uid = PerlProc_getuid();
1133 PL_euid = PerlProc_geteuid();
1135 if (PL_delaymagic & DM_GID) {
1136 #ifdef HAS_SETRESGID
1137 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1138 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1141 # ifdef HAS_SETREGID
1142 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1143 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1146 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1147 (void)setrgid(PL_gid);
1148 PL_delaymagic &= ~DM_RGID;
1150 # endif /* HAS_SETRGID */
1152 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1153 (void)setegid(PL_egid);
1154 PL_delaymagic &= ~DM_EGID;
1156 # endif /* HAS_SETEGID */
1157 if (PL_delaymagic & DM_GID) {
1158 if (PL_gid != PL_egid)
1159 DIE(aTHX_ "No setregid available");
1160 (void)PerlProc_setgid(PL_gid);
1162 # endif /* HAS_SETREGID */
1163 #endif /* HAS_SETRESGID */
1164 PL_gid = PerlProc_getgid();
1165 PL_egid = PerlProc_getegid();
1167 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1171 if (gimme == G_VOID)
1172 SP = firstrelem - 1;
1173 else if (gimme == G_SCALAR) {
1176 SETi(lastrelem - firstrelem + 1 - duplicates);
1183 /* Removes from the stack the entries which ended up as
1184 * duplicated keys in the hash (fix for [perl #24380]) */
1185 Move(firsthashrelem + duplicates,
1186 firsthashrelem, duplicates, SV**);
1187 lastrelem -= duplicates;
1192 SP = firstrelem + (lastlelem - firstlelem);
1193 lelem = firstlelem + (relem - firstrelem);
1195 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1204 register PMOP * const pm = cPMOP;
1205 REGEXP * rx = PM_GETRE(pm);
1206 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1207 SV * const rv = sv_newmortal();
1209 SvUPGRADE(rv, SVt_IV);
1210 /* This RV is about to own a reference to the regexp. (In addition to the
1211 reference already owned by the PMOP. */
1213 SvRV_set(rv, MUTABLE_SV(rx));
1217 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1219 (void)sv_bless(rv, stash);
1222 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1231 register PMOP *pm = cPMOP;
1233 register const char *t;
1234 register const char *s;
1237 U8 r_flags = REXEC_CHECKED;
1238 const char *truebase; /* Start of string */
1239 register REGEXP *rx = PM_GETRE(pm);
1241 const I32 gimme = GIMME;
1244 const I32 oldsave = PL_savestack_ix;
1245 I32 update_minmatch = 1;
1246 I32 had_zerolen = 0;
1249 if (PL_op->op_flags & OPf_STACKED)
1251 else if (PL_op->op_private & OPpTARGET_MY)
1258 PUTBACK; /* EVAL blocks need stack_sp. */
1259 s = SvPV_const(TARG, len);
1261 DIE(aTHX_ "panic: pp_match");
1263 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1264 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1267 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1269 /* PMdf_USED is set after a ?? matches once */
1272 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1274 pm->op_pmflags & PMf_USED
1278 if (gimme == G_ARRAY)
1285 /* empty pattern special-cased to use last successful pattern if possible */
1286 if (!RX_PRELEN(rx) && PL_curpm) {
1291 if (RX_MINLEN(rx) > (I32)len)
1296 /* XXXX What part of this is needed with true \G-support? */
1297 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1298 RX_OFFS(rx)[0].start = -1;
1299 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1300 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1301 if (mg && mg->mg_len >= 0) {
1302 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1303 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1304 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1305 r_flags |= REXEC_IGNOREPOS;
1306 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1307 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1310 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1311 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1312 update_minmatch = 0;
1316 /* XXX: comment out !global get safe $1 vars after a
1317 match, BUT be aware that this leads to dramatic slowdowns on
1318 /g matches against large strings. So far a solution to this problem
1319 appears to be quite tricky.
1320 Test for the unsafe vars are TODO for now. */
1321 if (( !global && RX_NPARENS(rx))
1322 || SvTEMP(TARG) || PL_sawampersand ||
1323 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1324 r_flags |= REXEC_COPY_STR;
1326 r_flags |= REXEC_SCREAM;
1329 if (global && RX_OFFS(rx)[0].start != -1) {
1330 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1331 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1333 if (update_minmatch++)
1334 minmatch = had_zerolen;
1336 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1337 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1338 /* FIXME - can PL_bostr be made const char *? */
1339 PL_bostr = (char *)truebase;
1340 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1344 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1346 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1347 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1348 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1349 && (r_flags & REXEC_SCREAM)))
1350 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1353 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1354 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1357 if (dynpm->op_pmflags & PMf_ONCE) {
1359 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1361 dynpm->op_pmflags |= PMf_USED;
1372 RX_MATCH_TAINTED_on(rx);
1373 TAINT_IF(RX_MATCH_TAINTED(rx));
1374 if (gimme == G_ARRAY) {
1375 const I32 nparens = RX_NPARENS(rx);
1376 I32 i = (global && !nparens) ? 1 : 0;
1378 SPAGAIN; /* EVAL blocks could move the stack. */
1379 EXTEND(SP, nparens + i);
1380 EXTEND_MORTAL(nparens + i);
1381 for (i = !i; i <= nparens; i++) {
1382 PUSHs(sv_newmortal());
1383 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1384 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1385 s = RX_OFFS(rx)[i].start + truebase;
1386 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1387 len < 0 || len > strend - s)
1388 DIE(aTHX_ "panic: pp_match start/end pointers");
1389 sv_setpvn(*SP, s, len);
1390 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1395 if (dynpm->op_pmflags & PMf_CONTINUE) {
1397 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1398 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1400 #ifdef PERL_OLD_COPY_ON_WRITE
1402 sv_force_normal_flags(TARG, 0);
1404 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1405 &PL_vtbl_mglob, NULL, 0);
1407 if (RX_OFFS(rx)[0].start != -1) {
1408 mg->mg_len = RX_OFFS(rx)[0].end;
1409 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1410 mg->mg_flags |= MGf_MINMATCH;
1412 mg->mg_flags &= ~MGf_MINMATCH;
1415 had_zerolen = (RX_OFFS(rx)[0].start != -1
1416 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1417 == (UV)RX_OFFS(rx)[0].end));
1418 PUTBACK; /* EVAL blocks may use stack */
1419 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1424 LEAVE_SCOPE(oldsave);
1430 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1431 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1435 #ifdef PERL_OLD_COPY_ON_WRITE
1437 sv_force_normal_flags(TARG, 0);
1439 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1440 &PL_vtbl_mglob, NULL, 0);
1442 if (RX_OFFS(rx)[0].start != -1) {
1443 mg->mg_len = RX_OFFS(rx)[0].end;
1444 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1445 mg->mg_flags |= MGf_MINMATCH;
1447 mg->mg_flags &= ~MGf_MINMATCH;
1450 LEAVE_SCOPE(oldsave);
1454 yup: /* Confirmed by INTUIT */
1456 RX_MATCH_TAINTED_on(rx);
1457 TAINT_IF(RX_MATCH_TAINTED(rx));
1459 if (dynpm->op_pmflags & PMf_ONCE) {
1461 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1463 dynpm->op_pmflags |= PMf_USED;
1466 if (RX_MATCH_COPIED(rx))
1467 Safefree(RX_SUBBEG(rx));
1468 RX_MATCH_COPIED_off(rx);
1469 RX_SUBBEG(rx) = NULL;
1471 /* FIXME - should rx->subbeg be const char *? */
1472 RX_SUBBEG(rx) = (char *) truebase;
1473 RX_OFFS(rx)[0].start = s - truebase;
1474 if (RX_MATCH_UTF8(rx)) {
1475 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1476 RX_OFFS(rx)[0].end = t - truebase;
1479 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1481 RX_SUBLEN(rx) = strend - truebase;
1484 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1486 #ifdef PERL_OLD_COPY_ON_WRITE
1487 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1489 PerlIO_printf(Perl_debug_log,
1490 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1491 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1494 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1496 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1497 assert (SvPOKp(RX_SAVED_COPY(rx)));
1502 RX_SUBBEG(rx) = savepvn(t, strend - t);
1503 #ifdef PERL_OLD_COPY_ON_WRITE
1504 RX_SAVED_COPY(rx) = NULL;
1507 RX_SUBLEN(rx) = strend - t;
1508 RX_MATCH_COPIED_on(rx);
1509 off = RX_OFFS(rx)[0].start = s - t;
1510 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1512 else { /* startp/endp are used by @- @+. */
1513 RX_OFFS(rx)[0].start = s - truebase;
1514 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1516 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1518 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1519 LEAVE_SCOPE(oldsave);
1524 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1525 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1526 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1531 LEAVE_SCOPE(oldsave);
1532 if (gimme == G_ARRAY)
1538 Perl_do_readline(pTHX)
1540 dVAR; dSP; dTARGETSTACKED;
1545 register IO * const io = GvIO(PL_last_in_gv);
1546 register const I32 type = PL_op->op_type;
1547 const I32 gimme = GIMME_V;
1550 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1553 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1556 call_method("READLINE", gimme);
1559 if (gimme == G_SCALAR) {
1560 SV* const result = POPs;
1561 SvSetSV_nosteal(TARG, result);
1571 if (IoFLAGS(io) & IOf_ARGV) {
1572 if (IoFLAGS(io) & IOf_START) {
1574 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1575 IoFLAGS(io) &= ~IOf_START;
1576 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1577 sv_setpvs(GvSVn(PL_last_in_gv), "-");
1578 SvSETMAGIC(GvSV(PL_last_in_gv));
1583 fp = nextargv(PL_last_in_gv);
1584 if (!fp) { /* Note: fp != IoIFP(io) */
1585 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1588 else if (type == OP_GLOB)
1589 fp = Perl_start_glob(aTHX_ POPs, io);
1591 else if (type == OP_GLOB)
1593 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1594 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1598 if ((!io || !(IoFLAGS(io) & IOf_START))
1599 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1601 if (type == OP_GLOB)
1602 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1603 "glob failed (can't start child: %s)",
1606 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1608 if (gimme == G_SCALAR) {
1609 /* undef TARG, and push that undefined value */
1610 if (type != OP_RCATLINE) {
1611 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1619 if (gimme == G_SCALAR) {
1621 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1624 if (type == OP_RCATLINE)
1625 SvPV_force_nolen(sv);
1629 else if (isGV_with_GP(sv)) {
1630 SvPV_force_nolen(sv);
1632 SvUPGRADE(sv, SVt_PV);
1633 tmplen = SvLEN(sv); /* remember if already alloced */
1634 if (!tmplen && !SvREADONLY(sv))
1635 Sv_Grow(sv, 80); /* try short-buffering it */
1637 if (type == OP_RCATLINE && SvOK(sv)) {
1639 SvPV_force_nolen(sv);
1645 sv = sv_2mortal(newSV(80));
1649 /* This should not be marked tainted if the fp is marked clean */
1650 #define MAYBE_TAINT_LINE(io, sv) \
1651 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1656 /* delay EOF state for a snarfed empty file */
1657 #define SNARF_EOF(gimme,rs,io,sv) \
1658 (gimme != G_SCALAR || SvCUR(sv) \
1659 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1663 if (!sv_gets(sv, fp, offset)
1665 || SNARF_EOF(gimme, PL_rs, io, sv)
1666 || PerlIO_error(fp)))
1668 PerlIO_clearerr(fp);
1669 if (IoFLAGS(io) & IOf_ARGV) {
1670 fp = nextargv(PL_last_in_gv);
1673 (void)do_close(PL_last_in_gv, FALSE);
1675 else if (type == OP_GLOB) {
1676 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1677 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1678 "glob failed (child exited with status %d%s)",
1679 (int)(STATUS_CURRENT >> 8),
1680 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1683 if (gimme == G_SCALAR) {
1684 if (type != OP_RCATLINE) {
1685 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1691 MAYBE_TAINT_LINE(io, sv);
1694 MAYBE_TAINT_LINE(io, sv);
1696 IoFLAGS(io) |= IOf_NOLINE;
1700 if (type == OP_GLOB) {
1703 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1704 char * const tmps = SvEND(sv) - 1;
1705 if (*tmps == *SvPVX_const(PL_rs)) {
1707 SvCUR_set(sv, SvCUR(sv) - 1);
1710 for (t1 = SvPVX_const(sv); *t1; t1++)
1711 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1712 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1714 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1715 (void)POPs; /* Unmatched wildcard? Chuck it... */
1718 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1719 if (ckWARN(WARN_UTF8)) {
1720 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1721 const STRLEN len = SvCUR(sv) - offset;
1724 if (!is_utf8_string_loc(s, len, &f))
1725 /* Emulate :encoding(utf8) warning in the same case. */
1726 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1727 "utf8 \"\\x%02X\" does not map to Unicode",
1728 f < (U8*)SvEND(sv) ? *f : 0);
1731 if (gimme == G_ARRAY) {
1732 if (SvLEN(sv) - SvCUR(sv) > 20) {
1733 SvPV_shrink_to_cur(sv);
1735 sv = sv_2mortal(newSV(80));
1738 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1739 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1740 const STRLEN new_len
1741 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1742 SvPV_renew(sv, new_len);
1751 register PERL_CONTEXT *cx;
1752 I32 gimme = OP_GIMME(PL_op, -1);
1755 if (cxstack_ix >= 0)
1756 gimme = cxstack[cxstack_ix].blk_gimme;
1764 PUSHBLOCK(cx, CXt_BLOCK, SP);
1774 SV * const keysv = POPs;
1775 HV * const hv = MUTABLE_HV(POPs);
1776 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1777 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1779 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1782 if (SvTYPE(hv) != SVt_PVHV)
1785 if (PL_op->op_private & OPpLVAL_INTRO) {
1788 /* does the element we're localizing already exist? */
1789 preeminent = /* can we determine whether it exists? */
1791 || mg_find((const SV *)hv, PERL_MAGIC_env)
1792 || ( (mg = mg_find((const SV *)hv, PERL_MAGIC_tied))
1793 /* Try to preserve the existenceness of a tied hash
1794 * element by using EXISTS and DELETE if possible.
1795 * Fallback to FETCH and STORE otherwise */
1796 && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(hv), mg))))
1797 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1798 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1800 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1802 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1803 svp = he ? &HeVAL(he) : NULL;
1805 if (!svp || *svp == &PL_sv_undef) {
1809 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1811 lv = sv_newmortal();
1812 sv_upgrade(lv, SVt_PVLV);
1814 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1815 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1816 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1821 if (PL_op->op_private & OPpLVAL_INTRO) {
1822 if (HvNAME_get(hv) && isGV(*svp))
1823 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1827 const char * const key = SvPV_const(keysv, keylen);
1828 SAVEDELETE(hv, savepvn(key,keylen),
1829 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1831 save_helem(hv, keysv, svp);
1834 else if (PL_op->op_private & OPpDEREF)
1835 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1837 sv = (svp ? *svp : &PL_sv_undef);
1838 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1839 * Pushing the magical RHS on to the stack is useless, since
1840 * that magic is soon destined to be misled by the local(),
1841 * and thus the later pp_sassign() will fail to mg_get() the
1842 * old value. This should also cure problems with delayed
1843 * mg_get()s. GSAR 98-07-03 */
1844 if (!lval && SvGMAGICAL(sv))
1845 sv = sv_mortalcopy(sv);
1853 register PERL_CONTEXT *cx;
1858 if (PL_op->op_flags & OPf_SPECIAL) {
1859 cx = &cxstack[cxstack_ix];
1860 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1865 gimme = OP_GIMME(PL_op, -1);
1867 if (cxstack_ix >= 0)
1868 gimme = cxstack[cxstack_ix].blk_gimme;
1874 if (gimme == G_VOID)
1876 else if (gimme == G_SCALAR) {
1880 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1883 *MARK = sv_mortalcopy(TOPs);
1886 *MARK = &PL_sv_undef;
1890 else if (gimme == G_ARRAY) {
1891 /* in case LEAVE wipes old return values */
1893 for (mark = newsp + 1; mark <= SP; mark++) {
1894 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1895 *mark = sv_mortalcopy(*mark);
1896 TAINT_NOT; /* Each item is independent */
1900 PL_curpm = newpm; /* Don't pop $1 et al till now */
1910 register PERL_CONTEXT *cx;
1913 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1914 bool av_is_stack = FALSE;
1917 cx = &cxstack[cxstack_ix];
1918 if (!CxTYPE_is_LOOP(cx))
1919 DIE(aTHX_ "panic: pp_iter");
1921 itersvp = CxITERVAR(cx);
1922 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1923 /* string increment */
1924 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1925 SV *end = cx->blk_loop.state_u.lazysv.end;
1926 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1927 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1929 const char *max = SvPV_const(end, maxlen);
1930 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1931 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1932 /* safe to reuse old SV */
1933 sv_setsv(*itersvp, cur);
1937 /* we need a fresh SV every time so that loop body sees a
1938 * completely new SV for closures/references to work as
1941 *itersvp = newSVsv(cur);
1942 SvREFCNT_dec(oldsv);
1944 if (strEQ(SvPVX_const(cur), max))
1945 sv_setiv(cur, 0); /* terminate next time */
1952 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1953 /* integer increment */
1954 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1957 /* don't risk potential race */
1958 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1959 /* safe to reuse old SV */
1960 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1964 /* we need a fresh SV every time so that loop body sees a
1965 * completely new SV for closures/references to work as they
1968 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1969 SvREFCNT_dec(oldsv);
1972 /* Handle end of range at IV_MAX */
1973 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1974 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1976 cx->blk_loop.state_u.lazyiv.cur++;
1977 cx->blk_loop.state_u.lazyiv.end++;
1984 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1985 av = cx->blk_loop.state_u.ary.ary;
1990 if (PL_op->op_private & OPpITER_REVERSED) {
1991 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1992 ? cx->blk_loop.resetsp + 1 : 0))
1995 if (SvMAGICAL(av) || AvREIFY(av)) {
1996 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1997 sv = svp ? *svp : NULL;
2000 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2004 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2008 if (SvMAGICAL(av) || AvREIFY(av)) {
2009 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2010 sv = svp ? *svp : NULL;
2013 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2017 if (sv && SvIS_FREED(sv)) {
2019 Perl_croak(aTHX_ "Use of freed value in iteration");
2024 SvREFCNT_inc_simple_void_NN(sv);
2028 if (!av_is_stack && sv == &PL_sv_undef) {
2029 SV *lv = newSV_type(SVt_PVLV);
2031 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2032 LvTARG(lv) = SvREFCNT_inc_simple(av);
2033 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2034 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2040 SvREFCNT_dec(oldsv);
2048 register PMOP *pm = cPMOP;
2063 register REGEXP *rx = PM_GETRE(pm);
2065 int force_on_match = 0;
2066 const I32 oldsave = PL_savestack_ix;
2068 bool doutf8 = FALSE;
2070 #ifdef PERL_OLD_COPY_ON_WRITE
2075 /* known replacement string? */
2076 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2077 if (PL_op->op_flags & OPf_STACKED)
2079 else if (PL_op->op_private & OPpTARGET_MY)
2086 #ifdef PERL_OLD_COPY_ON_WRITE
2087 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2088 because they make integers such as 256 "false". */
2089 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2092 sv_force_normal_flags(TARG,0);
2095 #ifdef PERL_OLD_COPY_ON_WRITE
2099 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2100 || SvTYPE(TARG) > SVt_PVLV)
2101 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2102 DIE(aTHX_ "%s", PL_no_modify);
2105 s = SvPV_mutable(TARG, len);
2106 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2108 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2109 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2114 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2118 DIE(aTHX_ "panic: pp_subst");
2121 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2122 maxiters = 2 * slen + 10; /* We can match twice at each
2123 position, once with zero-length,
2124 second time with non-zero. */
2126 if (!RX_PRELEN(rx) && PL_curpm) {
2130 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2131 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2132 ? REXEC_COPY_STR : 0;
2134 r_flags |= REXEC_SCREAM;
2137 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2139 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2143 /* How to do it in subst? */
2144 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2146 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2147 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2148 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2149 && (r_flags & REXEC_SCREAM))))
2154 /* only replace once? */
2155 once = !(rpm->op_pmflags & PMf_GLOBAL);
2156 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2157 r_flags | REXEC_CHECKED);
2158 /* known replacement string? */
2160 /* replacement needing upgrading? */
2161 if (DO_UTF8(TARG) && !doutf8) {
2162 nsv = sv_newmortal();
2165 sv_recode_to_utf8(nsv, PL_encoding);
2167 sv_utf8_upgrade(nsv);
2168 c = SvPV_const(nsv, clen);
2172 c = SvPV_const(dstr, clen);
2173 doutf8 = DO_UTF8(dstr);
2181 /* can do inplace substitution? */
2183 #ifdef PERL_OLD_COPY_ON_WRITE
2186 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2187 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2188 && (!doutf8 || SvUTF8(TARG))) {
2193 LEAVE_SCOPE(oldsave);
2196 #ifdef PERL_OLD_COPY_ON_WRITE
2197 if (SvIsCOW(TARG)) {
2198 assert (!force_on_match);
2202 if (force_on_match) {
2204 s = SvPV_force(TARG, len);
2209 SvSCREAM_off(TARG); /* disable possible screamer */
2211 rxtainted |= RX_MATCH_TAINTED(rx);
2212 m = orig + RX_OFFS(rx)[0].start;
2213 d = orig + RX_OFFS(rx)[0].end;
2215 if (m - s > strend - d) { /* faster to shorten from end */
2217 Copy(c, m, clen, char);
2222 Move(d, m, i, char);
2226 SvCUR_set(TARG, m - s);
2228 else if ((i = m - s)) { /* faster from front */
2231 Move(s, d - i, i, char);
2234 Copy(c, m, clen, char);
2239 Copy(c, d, clen, char);
2244 TAINT_IF(rxtainted & 1);
2250 if (iters++ > maxiters)
2251 DIE(aTHX_ "Substitution loop");
2252 rxtainted |= RX_MATCH_TAINTED(rx);
2253 m = RX_OFFS(rx)[0].start + orig;
2256 Move(s, d, i, char);
2260 Copy(c, d, clen, char);
2263 s = RX_OFFS(rx)[0].end + orig;
2264 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2266 /* don't match same null twice */
2267 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2270 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2271 Move(s, d, i+1, char); /* include the NUL */
2273 TAINT_IF(rxtainted & 1);
2277 (void)SvPOK_only_UTF8(TARG);
2278 TAINT_IF(rxtainted);
2279 if (SvSMAGICAL(TARG)) {
2287 LEAVE_SCOPE(oldsave);
2293 if (force_on_match) {
2295 s = SvPV_force(TARG, len);
2298 #ifdef PERL_OLD_COPY_ON_WRITE
2301 rxtainted |= RX_MATCH_TAINTED(rx);
2302 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2306 register PERL_CONTEXT *cx;
2309 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2311 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2313 if (iters++ > maxiters)
2314 DIE(aTHX_ "Substitution loop");
2315 rxtainted |= RX_MATCH_TAINTED(rx);
2316 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2319 orig = RX_SUBBEG(rx);
2321 strend = s + (strend - m);
2323 m = RX_OFFS(rx)[0].start + orig;
2324 if (doutf8 && !SvUTF8(dstr))
2325 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2327 sv_catpvn(dstr, s, m-s);
2328 s = RX_OFFS(rx)[0].end + orig;
2330 sv_catpvn(dstr, c, clen);
2333 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2334 TARG, NULL, r_flags));
2335 if (doutf8 && !DO_UTF8(TARG))
2336 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2338 sv_catpvn(dstr, s, strend - s);
2340 #ifdef PERL_OLD_COPY_ON_WRITE
2341 /* The match may make the string COW. If so, brilliant, because that's
2342 just saved us one malloc, copy and free - the regexp has donated
2343 the old buffer, and we malloc an entirely new one, rather than the
2344 regexp malloc()ing a buffer and copying our original, only for
2345 us to throw it away here during the substitution. */
2346 if (SvIsCOW(TARG)) {
2347 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2353 SvPV_set(TARG, SvPVX(dstr));
2354 SvCUR_set(TARG, SvCUR(dstr));
2355 SvLEN_set(TARG, SvLEN(dstr));
2356 doutf8 |= DO_UTF8(dstr);
2357 SvPV_set(dstr, NULL);
2359 TAINT_IF(rxtainted & 1);
2363 (void)SvPOK_only(TARG);
2366 TAINT_IF(rxtainted);
2369 LEAVE_SCOPE(oldsave);
2378 LEAVE_SCOPE(oldsave);
2387 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2388 ++*PL_markstack_ptr;
2389 LEAVE; /* exit inner scope */
2392 if (PL_stack_base + *PL_markstack_ptr > SP) {
2394 const I32 gimme = GIMME_V;
2396 LEAVE; /* exit outer scope */
2397 (void)POPMARK; /* pop src */
2398 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2399 (void)POPMARK; /* pop dst */
2400 SP = PL_stack_base + POPMARK; /* pop original mark */
2401 if (gimme == G_SCALAR) {
2402 if (PL_op->op_private & OPpGREP_LEX) {
2403 SV* const sv = sv_newmortal();
2404 sv_setiv(sv, items);
2412 else if (gimme == G_ARRAY)
2419 ENTER; /* enter inner scope */
2422 src = PL_stack_base[*PL_markstack_ptr];
2424 if (PL_op->op_private & OPpGREP_LEX)
2425 PAD_SVl(PL_op->op_targ) = src;
2429 RETURNOP(cLOGOP->op_other);
2440 register PERL_CONTEXT *cx;
2443 if (CxMULTICALL(&cxstack[cxstack_ix]))
2447 cxstack_ix++; /* temporarily protect top context */
2450 if (gimme == G_SCALAR) {
2453 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2455 *MARK = SvREFCNT_inc(TOPs);
2460 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2462 *MARK = sv_mortalcopy(sv);
2467 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2471 *MARK = &PL_sv_undef;
2475 else if (gimme == G_ARRAY) {
2476 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2477 if (!SvTEMP(*MARK)) {
2478 *MARK = sv_mortalcopy(*MARK);
2479 TAINT_NOT; /* Each item is independent */
2487 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2488 PL_curpm = newpm; /* ... and pop $1 et al */
2491 return cx->blk_sub.retop;
2494 /* This duplicates the above code because the above code must not
2495 * get any slower by more conditions */
2503 register PERL_CONTEXT *cx;
2506 if (CxMULTICALL(&cxstack[cxstack_ix]))
2510 cxstack_ix++; /* temporarily protect top context */
2514 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2515 /* We are an argument to a function or grep().
2516 * This kind of lvalueness was legal before lvalue
2517 * subroutines too, so be backward compatible:
2518 * cannot report errors. */
2520 /* Scalar context *is* possible, on the LHS of -> only,
2521 * as in f()->meth(). But this is not an lvalue. */
2522 if (gimme == G_SCALAR)
2524 if (gimme == G_ARRAY) {
2525 if (!CvLVALUE(cx->blk_sub.cv))
2526 goto temporise_array;
2527 EXTEND_MORTAL(SP - newsp);
2528 for (mark = newsp + 1; mark <= SP; mark++) {
2531 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2532 *mark = sv_mortalcopy(*mark);
2534 /* Can be a localized value subject to deletion. */
2535 PL_tmps_stack[++PL_tmps_ix] = *mark;
2536 SvREFCNT_inc_void(*mark);
2541 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2542 /* Here we go for robustness, not for speed, so we change all
2543 * the refcounts so the caller gets a live guy. Cannot set
2544 * TEMP, so sv_2mortal is out of question. */
2545 if (!CvLVALUE(cx->blk_sub.cv)) {
2551 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2553 if (gimme == G_SCALAR) {
2557 /* Temporaries are bad unless they happen to be elements
2558 * of a tied hash or array */
2559 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2560 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2566 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2567 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2568 : "a readonly value" : "a temporary");
2570 else { /* Can be a localized value
2571 * subject to deletion. */
2572 PL_tmps_stack[++PL_tmps_ix] = *mark;
2573 SvREFCNT_inc_void(*mark);
2576 else { /* Should not happen? */
2582 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2583 (MARK > SP ? "Empty array" : "Array"));
2587 else if (gimme == G_ARRAY) {
2588 EXTEND_MORTAL(SP - newsp);
2589 for (mark = newsp + 1; mark <= SP; mark++) {
2590 if (*mark != &PL_sv_undef
2591 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2592 /* Might be flattened array after $#array = */
2599 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2600 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2603 /* Can be a localized value subject to deletion. */
2604 PL_tmps_stack[++PL_tmps_ix] = *mark;
2605 SvREFCNT_inc_void(*mark);
2611 if (gimme == G_SCALAR) {
2615 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2617 *MARK = SvREFCNT_inc(TOPs);
2622 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2624 *MARK = sv_mortalcopy(sv);
2629 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2633 *MARK = &PL_sv_undef;
2637 else if (gimme == G_ARRAY) {
2639 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2640 if (!SvTEMP(*MARK)) {
2641 *MARK = sv_mortalcopy(*MARK);
2642 TAINT_NOT; /* Each item is independent */
2651 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2652 PL_curpm = newpm; /* ... and pop $1 et al */
2655 return cx->blk_sub.retop;
2663 register PERL_CONTEXT *cx;
2665 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2668 DIE(aTHX_ "Not a CODE reference");
2669 switch (SvTYPE(sv)) {
2670 /* This is overwhelming the most common case: */
2672 if (!isGV_with_GP(sv))
2673 DIE(aTHX_ "Not a CODE reference");
2674 if (!(cv = GvCVu((const GV *)sv))) {
2676 cv = sv_2cv(sv, &stash, &gv, 0);
2688 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2690 SP = PL_stack_base + POPMARK;
2693 if (SvGMAGICAL(sv)) {
2698 sym = SvPVX_const(sv);
2706 sym = SvPV_const(sv, len);
2709 DIE(aTHX_ PL_no_usym, "a subroutine");
2710 if (PL_op->op_private & HINT_STRICT_REFS)
2711 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2712 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2717 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2718 tryAMAGICunDEREF(to_cv);
2720 cv = MUTABLE_CV(SvRV(sv));
2721 if (SvTYPE(cv) == SVt_PVCV)
2726 DIE(aTHX_ "Not a CODE reference");
2727 /* This is the second most common case: */
2729 cv = MUTABLE_CV(sv);
2737 if (!CvROOT(cv) && !CvXSUB(cv)) {
2741 /* anonymous or undef'd function leaves us no recourse */
2742 if (CvANON(cv) || !(gv = CvGV(cv)))
2743 DIE(aTHX_ "Undefined subroutine called");
2745 /* autoloaded stub? */
2746 if (cv != GvCV(gv)) {
2749 /* should call AUTOLOAD now? */
2752 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2759 sub_name = sv_newmortal();
2760 gv_efullname3(sub_name, gv, NULL);
2761 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2765 DIE(aTHX_ "Not a CODE reference");
2770 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2771 Perl_get_db_sub(aTHX_ &sv, cv);
2773 PL_curcopdb = PL_curcop;
2774 cv = GvCV(PL_DBsub);
2776 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2777 DIE(aTHX_ "No DB::sub routine defined");
2780 if (!(CvISXSUB(cv))) {
2781 /* This path taken at least 75% of the time */
2783 register I32 items = SP - MARK;
2784 AV* const padlist = CvPADLIST(cv);
2785 PUSHBLOCK(cx, CXt_SUB, MARK);
2787 cx->blk_sub.retop = PL_op->op_next;
2789 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2790 * that eval'' ops within this sub know the correct lexical space.
2791 * Owing the speed considerations, we choose instead to search for
2792 * the cv using find_runcv() when calling doeval().
2794 if (CvDEPTH(cv) >= 2) {
2795 PERL_STACK_OVERFLOW_CHECK();
2796 pad_push(padlist, CvDEPTH(cv));
2799 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2801 AV *const av = MUTABLE_AV(PAD_SVl(0));
2803 /* @_ is normally not REAL--this should only ever
2804 * happen when DB::sub() calls things that modify @_ */
2809 cx->blk_sub.savearray = GvAV(PL_defgv);
2810 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2811 CX_CURPAD_SAVE(cx->blk_sub);
2812 cx->blk_sub.argarray = av;
2815 if (items > AvMAX(av) + 1) {
2816 SV **ary = AvALLOC(av);
2817 if (AvARRAY(av) != ary) {
2818 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2821 if (items > AvMAX(av) + 1) {
2822 AvMAX(av) = items - 1;
2823 Renew(ary,items,SV*);
2828 Copy(MARK,AvARRAY(av),items,SV*);
2829 AvFILLp(av) = items - 1;
2837 /* warning must come *after* we fully set up the context
2838 * stuff so that __WARN__ handlers can safely dounwind()
2841 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2842 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2843 sub_crush_depth(cv);
2844 RETURNOP(CvSTART(cv));
2847 I32 markix = TOPMARK;
2852 /* Need to copy @_ to stack. Alternative may be to
2853 * switch stack to @_, and copy return values
2854 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2855 AV * const av = GvAV(PL_defgv);
2856 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2859 /* Mark is at the end of the stack. */
2861 Copy(AvARRAY(av), SP + 1, items, SV*);
2866 /* We assume first XSUB in &DB::sub is the called one. */
2868 SAVEVPTR(PL_curcop);
2869 PL_curcop = PL_curcopdb;
2872 /* Do we need to open block here? XXXX */
2873 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2874 (void)(*CvXSUB(cv))(aTHX_ cv);
2876 /* Enforce some sanity in scalar context. */
2877 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2878 if (markix > PL_stack_sp - PL_stack_base)
2879 *(PL_stack_base + markix) = &PL_sv_undef;
2881 *(PL_stack_base + markix) = *PL_stack_sp;
2882 PL_stack_sp = PL_stack_base + markix;
2890 Perl_sub_crush_depth(pTHX_ CV *cv)
2892 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2895 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2897 SV* const tmpstr = sv_newmortal();
2898 gv_efullname3(tmpstr, CvGV(cv), NULL);
2899 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2908 SV* const elemsv = POPs;
2909 IV elem = SvIV(elemsv);
2910 AV *const av = MUTABLE_AV(POPs);
2911 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2912 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2915 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2916 Perl_warner(aTHX_ packWARN(WARN_MISC),
2917 "Use of reference \"%"SVf"\" as array index",
2920 elem -= CopARYBASE_get(PL_curcop);
2921 if (SvTYPE(av) != SVt_PVAV)
2923 svp = av_fetch(av, elem, lval && !defer);
2925 #ifdef PERL_MALLOC_WRAP
2926 if (SvUOK(elemsv)) {
2927 const UV uv = SvUV(elemsv);
2928 elem = uv > IV_MAX ? IV_MAX : uv;
2930 else if (SvNOK(elemsv))
2931 elem = (IV)SvNV(elemsv);
2933 static const char oom_array_extend[] =
2934 "Out of memory during array extend"; /* Duplicated in av.c */
2935 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2938 if (!svp || *svp == &PL_sv_undef) {
2941 DIE(aTHX_ PL_no_aelem, elem);
2942 lv = sv_newmortal();
2943 sv_upgrade(lv, SVt_PVLV);
2945 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2946 LvTARG(lv) = SvREFCNT_inc_simple(av);
2947 LvTARGOFF(lv) = elem;
2952 if (PL_op->op_private & OPpLVAL_INTRO)
2953 save_aelem(av, elem, svp);
2954 else if (PL_op->op_private & OPpDEREF)
2955 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2957 sv = (svp ? *svp : &PL_sv_undef);
2958 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2959 sv = sv_mortalcopy(sv);
2965 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2967 PERL_ARGS_ASSERT_VIVIFY_REF;
2972 Perl_croak(aTHX_ "%s", PL_no_modify);
2973 prepare_SV_for_RV(sv);
2976 SvRV_set(sv, newSV(0));
2979 SvRV_set(sv, MUTABLE_SV(newAV()));
2982 SvRV_set(sv, MUTABLE_SV(newHV()));
2993 SV* const sv = TOPs;
2996 SV* const rsv = SvRV(sv);
2997 if (SvTYPE(rsv) == SVt_PVCV) {
3003 SETs(method_common(sv, NULL));
3010 SV* const sv = cSVOP_sv;
3011 U32 hash = SvSHARED_HASH(sv);
3013 XPUSHs(method_common(sv, &hash));
3018 S_method_common(pTHX_ SV* meth, U32* hashp)
3025 const char* packname = NULL;
3028 const char * const name = SvPV_const(meth, namelen);
3029 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3031 PERL_ARGS_ASSERT_METHOD_COMMON;
3034 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3038 ob = MUTABLE_SV(SvRV(sv));
3042 /* this isn't a reference */
3043 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3044 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3046 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3053 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3054 !(ob=MUTABLE_SV(GvIO(iogv))))
3056 /* this isn't the name of a filehandle either */
3058 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3059 ? !isIDFIRST_utf8((U8*)packname)
3060 : !isIDFIRST(*packname)
3063 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3064 SvOK(sv) ? "without a package or object reference"
3065 : "on an undefined value");
3067 /* assume it's a package name */
3068 stash = gv_stashpvn(packname, packlen, 0);
3072 SV* const ref = newSViv(PTR2IV(stash));
3073 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3077 /* it _is_ a filehandle name -- replace with a reference */
3078 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3081 /* if we got here, ob should be a reference or a glob */
3082 if (!ob || !(SvOBJECT(ob)
3083 || (SvTYPE(ob) == SVt_PVGV
3085 && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3088 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3089 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3093 stash = SvSTASH(ob);
3096 /* NOTE: stash may be null, hope hv_fetch_ent and
3097 gv_fetchmethod can cope (it seems they can) */
3099 /* shortcut for simple names */
3101 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3103 gv = MUTABLE_GV(HeVAL(he));
3104 if (isGV(gv) && GvCV(gv) &&
3105 (!GvCVGEN(gv) || GvCVGEN(gv)
3106 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3107 return MUTABLE_SV(GvCV(gv));
3111 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
3112 GV_AUTOLOAD | GV_CROAK);
3116 return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3121 * c-indentation-style: bsd
3123 * indent-tabs-mode: t
3126 * ex: set ts=8 sts=4 sw=4 noet: