3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (PL_op->op_private & OPpLVAL_INTRO)
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
77 PUSHMARK(PL_stack_sp);
92 XPUSHs((SV*)cGVOP_gv);
102 if (PL_op->op_type == OP_AND)
104 RETURNOP(cLOGOP->op_other);
110 dVAR; dSP; dPOPTOPssrl;
112 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
113 SV * const temp = left;
114 left = right; right = temp;
116 if (PL_tainting && PL_tainted && !SvTAINTED(left))
118 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
119 SV * const cv = SvRV(left);
120 const U32 cv_type = SvTYPE(cv);
121 const U32 gv_type = SvTYPE(right);
122 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
128 /* Can do the optimisation if right (LVALUE) is not a typeglob,
129 left (RVALUE) is a reference to something, and we're in void
131 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
132 /* Is the target symbol table currently empty? */
133 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
134 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
135 /* Good. Create a new proxy constant subroutine in the target.
136 The gv becomes a(nother) reference to the constant. */
137 SV *const value = SvRV(cv);
139 SvUPGRADE((SV *)gv, SVt_IV);
140 SvPCS_IMPORTED_on(gv);
142 SvREFCNT_inc_simple_void(value);
148 /* Need to fix things up. */
149 if (gv_type != SVt_PVGV) {
150 /* Need to fix GV. */
151 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
155 /* We've been returned a constant rather than a full subroutine,
156 but they expect a subroutine reference to apply. */
159 SvREFCNT_inc_void(SvRV(cv));
160 /* newCONSTSUB takes a reference count on the passed in SV
161 from us. We set the name to NULL, otherwise we get into
162 all sorts of fun as the reference to our new sub is
163 donated to the GV that we're about to assign to.
165 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
170 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
172 First: ops for \&{"BONK"}; return us the constant in the
174 Second: ops for *{"BONK"} cause that symbol table entry
175 (and our reference to it) to be upgraded from RV
177 Thirdly: We get here. cv is actually PVGV now, and its
178 GvCV() is actually the subroutine we're looking for
180 So change the reference so that it points to the subroutine
181 of that typeglob, as that's what they were after all along.
183 GV *const upgraded = (GV *) cv;
184 CV *const source = GvCV(upgraded);
187 assert(CvFLAGS(source) & CVf_CONST);
189 SvREFCNT_inc_void(source);
190 SvREFCNT_dec(upgraded);
191 SvRV_set(left, (SV *)source);
196 SvSetMagicSV(right, left);
205 RETURNOP(cLOGOP->op_other);
207 RETURNOP(cLOGOP->op_next);
214 TAINT_NOT; /* Each statement is presumed innocent */
215 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
217 oldsave = PL_scopestack[PL_scopestack_ix - 1];
218 LEAVE_SCOPE(oldsave);
224 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
229 const char *rpv = NULL;
231 bool rcopied = FALSE;
233 if (TARG == right && right != left) {
234 /* mg_get(right) may happen here ... */
235 rpv = SvPV_const(right, rlen);
236 rbyte = !DO_UTF8(right);
237 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
238 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
244 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
245 lbyte = !DO_UTF8(left);
246 sv_setpvn(TARG, lpv, llen);
252 else { /* TARG == left */
254 SvGETMAGIC(left); /* or mg_get(left) may happen here */
256 if (left == right && ckWARN(WARN_UNINITIALIZED))
257 report_uninit(right);
258 sv_setpvn(left, "", 0);
260 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
261 lbyte = !DO_UTF8(left);
266 /* or mg_get(right) may happen here */
268 rpv = SvPV_const(right, rlen);
269 rbyte = !DO_UTF8(right);
271 if (lbyte != rbyte) {
273 sv_utf8_upgrade_nomg(TARG);
276 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
277 sv_utf8_upgrade_nomg(right);
278 rpv = SvPV_const(right, rlen);
281 sv_catpvn_nomg(TARG, rpv, rlen);
292 if (PL_op->op_flags & OPf_MOD) {
293 if (PL_op->op_private & OPpLVAL_INTRO)
294 if (!(PL_op->op_private & OPpPAD_STATE))
295 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
296 if (PL_op->op_private & OPpDEREF) {
298 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
308 tryAMAGICunTARGET(iter, 0);
309 PL_last_in_gv = (GV*)(*PL_stack_sp--);
310 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
311 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
312 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
315 XPUSHs((SV*)PL_last_in_gv);
318 PL_last_in_gv = (GV*)(*PL_stack_sp--);
321 return do_readline();
326 dVAR; dSP; tryAMAGICbinSET(eq,0);
327 #ifndef NV_PRESERVES_UV
328 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
330 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
334 #ifdef PERL_PRESERVE_IVUV
337 /* Unless the left argument is integer in range we are going
338 to have to use NV maths. Hence only attempt to coerce the
339 right argument if we know the left is integer. */
342 const bool auvok = SvUOK(TOPm1s);
343 const bool buvok = SvUOK(TOPs);
345 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
346 /* Casting IV to UV before comparison isn't going to matter
347 on 2s complement. On 1s complement or sign&magnitude
348 (if we have any of them) it could to make negative zero
349 differ from normal zero. As I understand it. (Need to
350 check - is negative zero implementation defined behaviour
352 const UV buv = SvUVX(POPs);
353 const UV auv = SvUVX(TOPs);
355 SETs(boolSV(auv == buv));
358 { /* ## Mixed IV,UV ## */
362 /* == is commutative so doesn't matter which is left or right */
364 /* top of stack (b) is the iv */
373 /* As uv is a UV, it's >0, so it cannot be == */
376 /* we know iv is >= 0 */
377 SETs(boolSV((UV)iv == SvUVX(uvp)));
384 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
386 if (Perl_isnan(left) || Perl_isnan(right))
388 SETs(boolSV(left == right));
391 SETs(boolSV(TOPn == value));
400 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
401 DIE(aTHX_ PL_no_modify);
402 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
403 && SvIVX(TOPs) != IV_MAX)
405 SvIV_set(TOPs, SvIVX(TOPs) + 1);
406 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
408 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
420 if (PL_op->op_type == OP_OR)
422 RETURNOP(cLOGOP->op_other);
431 const int op_type = PL_op->op_type;
432 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
436 if (!sv || !SvANY(sv)) {
437 if (op_type == OP_DOR)
439 RETURNOP(cLOGOP->op_other);
445 if (!sv || !SvANY(sv))
450 switch (SvTYPE(sv)) {
452 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
456 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
460 if (CvROOT(sv) || CvXSUB(sv))
473 if(op_type == OP_DOR)
475 RETURNOP(cLOGOP->op_other);
477 /* assuming OP_DEFINED */
485 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
486 tryAMAGICbin(add,opASSIGN);
487 svl = sv_2num(TOPm1s);
489 useleft = USE_LEFT(svl);
490 #ifdef PERL_PRESERVE_IVUV
491 /* We must see if we can perform the addition with integers if possible,
492 as the integer code detects overflow while the NV code doesn't.
493 If either argument hasn't had a numeric conversion yet attempt to get
494 the IV. It's important to do this now, rather than just assuming that
495 it's not IOK as a PV of "9223372036854775806" may not take well to NV
496 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
497 integer in case the second argument is IV=9223372036854775806
498 We can (now) rely on sv_2iv to do the right thing, only setting the
499 public IOK flag if the value in the NV (or PV) slot is truly integer.
501 A side effect is that this also aggressively prefers integer maths over
502 fp maths for integer values.
504 How to detect overflow?
506 C 99 section 6.2.6.1 says
508 The range of nonnegative values of a signed integer type is a subrange
509 of the corresponding unsigned integer type, and the representation of
510 the same value in each type is the same. A computation involving
511 unsigned operands can never overflow, because a result that cannot be
512 represented by the resulting unsigned integer type is reduced modulo
513 the number that is one greater than the largest value that can be
514 represented by the resulting type.
518 which I read as "unsigned ints wrap."
520 signed integer overflow seems to be classed as "exception condition"
522 If an exceptional condition occurs during the evaluation of an
523 expression (that is, if the result is not mathematically defined or not
524 in the range of representable values for its type), the behavior is
527 (6.5, the 5th paragraph)
529 I had assumed that on 2s complement machines signed arithmetic would
530 wrap, hence coded pp_add and pp_subtract on the assumption that
531 everything perl builds on would be happy. After much wailing and
532 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
533 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
534 unsigned code below is actually shorter than the old code. :-)
539 /* Unless the left argument is integer in range we are going to have to
540 use NV maths. Hence only attempt to coerce the right argument if
541 we know the left is integer. */
549 /* left operand is undef, treat as zero. + 0 is identity,
550 Could SETi or SETu right now, but space optimise by not adding
551 lots of code to speed up what is probably a rarish case. */
553 /* Left operand is defined, so is it IV? */
556 if ((auvok = SvUOK(svl)))
559 register const IV aiv = SvIVX(svl);
562 auvok = 1; /* Now acting as a sign flag. */
563 } else { /* 2s complement assumption for IV_MIN */
571 bool result_good = 0;
574 bool buvok = SvUOK(svr);
579 register const IV biv = SvIVX(svr);
586 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
587 else "IV" now, independent of how it came in.
588 if a, b represents positive, A, B negative, a maps to -A etc
593 all UV maths. negate result if A negative.
594 add if signs same, subtract if signs differ. */
600 /* Must get smaller */
606 /* result really should be -(auv-buv). as its negation
607 of true value, need to swap our result flag */
624 if (result <= (UV)IV_MIN)
627 /* result valid, but out of range for IV. */
632 } /* Overflow, drop through to NVs. */
637 NV value = SvNV(svr);
640 /* left operand is undef, treat as zero. + 0.0 is identity. */
644 SETn( value + SvNV(svl) );
652 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
653 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
654 const U32 lval = PL_op->op_flags & OPf_MOD;
655 SV** const svp = av_fetch(av, PL_op->op_private, lval);
656 SV *sv = (svp ? *svp : &PL_sv_undef);
658 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
659 sv = sv_mortalcopy(sv);
666 dVAR; dSP; dMARK; dTARGET;
668 do_join(TARG, *MARK, MARK, SP);
679 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
680 * will be enough to hold an OP*.
682 SV* const sv = sv_newmortal();
683 sv_upgrade(sv, SVt_PVLV);
685 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
693 /* Oversized hot code. */
697 dVAR; dSP; dMARK; dORIGMARK;
701 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
703 if (gv && (io = GvIO(gv))
704 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
707 if (MARK == ORIGMARK) {
708 /* If using default handle then we need to make space to
709 * pass object as 1st arg, so move other args up ...
713 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
717 *MARK = SvTIED_obj((SV*)io, mg);
720 if( PL_op->op_type == OP_SAY ) {
721 /* local $\ = "\n" */
722 SAVEGENERICSV(PL_ors_sv);
723 PL_ors_sv = newSVpvs("\n");
725 call_method("PRINT", G_SCALAR);
733 if (!(io = GvIO(gv))) {
734 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
735 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
737 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
738 report_evil_fh(gv, io, PL_op->op_type);
739 SETERRNO(EBADF,RMS_IFI);
742 else if (!(fp = IoOFP(io))) {
743 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
745 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
746 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
747 report_evil_fh(gv, io, PL_op->op_type);
749 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
754 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
756 if (!do_print(*MARK, fp))
760 if (!do_print(PL_ofs_sv, fp)) { /* $, */
769 if (!do_print(*MARK, fp))
777 if (PL_op->op_type == OP_SAY) {
778 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
781 else if (PL_ors_sv && SvOK(PL_ors_sv))
782 if (!do_print(PL_ors_sv, fp)) /* $\ */
785 if (IoFLAGS(io) & IOf_FLUSH)
786 if (PerlIO_flush(fp) == EOF)
796 XPUSHs(&PL_sv_undef);
803 const I32 gimme = GIMME_V;
804 static const char an_array[] = "an ARRAY";
805 static const char a_hash[] = "a HASH";
806 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
807 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
811 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
814 if (SvTYPE(sv) != type)
815 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
816 if (PL_op->op_flags & OPf_REF) {
821 if (gimme != G_ARRAY)
822 goto croak_cant_return;
826 else if (PL_op->op_flags & OPf_MOD
827 && PL_op->op_private & OPpLVAL_INTRO)
828 Perl_croak(aTHX_ PL_no_localize_ref);
831 if (SvTYPE(sv) == type) {
832 if (PL_op->op_flags & OPf_REF) {
837 if (gimme != G_ARRAY)
838 goto croak_cant_return;
846 if (SvTYPE(sv) != SVt_PVGV) {
847 if (SvGMAGICAL(sv)) {
852 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
860 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
861 if (PL_op->op_private & OPpLVAL_INTRO)
862 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
863 if (PL_op->op_flags & OPf_REF) {
868 if (gimme != G_ARRAY)
869 goto croak_cant_return;
877 AV *const av = (AV*)sv;
878 /* The guts of pp_rv2av, with no intenting change to preserve history
879 (until such time as we get tools that can do blame annotation across
880 whitespace changes. */
881 if (gimme == G_ARRAY) {
882 const I32 maxarg = AvFILL(av) + 1;
883 (void)POPs; /* XXXX May be optimized away? */
885 if (SvRMAGICAL(av)) {
887 for (i=0; i < (U32)maxarg; i++) {
888 SV ** const svp = av_fetch(av, i, FALSE);
889 /* See note in pp_helem, and bug id #27839 */
891 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
896 Copy(AvARRAY(av), SP+1, maxarg, SV*);
900 else if (gimme == G_SCALAR) {
902 const I32 maxarg = AvFILL(av) + 1;
906 /* The guts of pp_rv2hv */
907 if (gimme == G_ARRAY) { /* array wanted */
911 else if (gimme == G_SCALAR) {
913 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
921 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
922 is_pp_rv2av ? "array" : "hash");
927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
931 PERL_ARGS_ASSERT_DO_ODDBALL;
937 if (ckWARN(WARN_MISC)) {
939 if (relem == firstrelem &&
941 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
942 SvTYPE(SvRV(*relem)) == SVt_PVHV))
944 err = "Reference found where even-sized list expected";
947 err = "Odd number of elements in hash assignment";
948 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
952 didstore = hv_store_ent(hash,*relem,tmpstr,0);
953 if (SvMAGICAL(hash)) {
954 if (SvSMAGICAL(tmpstr))
966 SV **lastlelem = PL_stack_sp;
967 SV **lastrelem = PL_stack_base + POPMARK;
968 SV **firstrelem = PL_stack_base + POPMARK + 1;
969 SV **firstlelem = lastrelem + 1;
982 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
984 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
987 /* If there's a common identifier on both sides we have to take
988 * special care that assigning the identifier on the left doesn't
989 * clobber a value on the right that's used later in the list.
991 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
992 EXTEND_MORTAL(lastrelem - firstrelem + 1);
993 for (relem = firstrelem; relem <= lastrelem; relem++) {
995 TAINT_NOT; /* Each item is independent */
996 *relem = sv_mortalcopy(sv);
1006 while (lelem <= lastlelem) {
1007 TAINT_NOT; /* Each item stands on its own, taintwise. */
1009 switch (SvTYPE(sv)) {
1012 magic = SvMAGICAL(ary) != 0;
1014 av_extend(ary, lastrelem - relem);
1016 while (relem <= lastrelem) { /* gobble up all the rest */
1019 sv = newSVsv(*relem);
1021 didstore = av_store(ary,i++,sv);
1030 if (PL_delaymagic & DM_ARRAY)
1031 SvSETMAGIC((SV*)ary);
1033 case SVt_PVHV: { /* normal hash */
1037 magic = SvMAGICAL(hash) != 0;
1039 firsthashrelem = relem;
1041 while (relem < lastrelem) { /* gobble up all the rest */
1043 sv = *relem ? *relem : &PL_sv_no;
1047 sv_setsv(tmpstr,*relem); /* value */
1048 *(relem++) = tmpstr;
1049 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1050 /* key overwrites an existing entry */
1052 didstore = hv_store_ent(hash,sv,tmpstr,0);
1054 if (SvSMAGICAL(tmpstr))
1061 if (relem == lastrelem) {
1062 do_oddball(hash, relem, firstrelem);
1068 if (SvIMMORTAL(sv)) {
1069 if (relem <= lastrelem)
1073 if (relem <= lastrelem) {
1074 sv_setsv(sv, *relem);
1078 sv_setsv(sv, &PL_sv_undef);
1083 if (PL_delaymagic & ~DM_DELAY) {
1084 if (PL_delaymagic & DM_UID) {
1085 #ifdef HAS_SETRESUID
1086 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1087 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1090 # ifdef HAS_SETREUID
1091 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1092 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1095 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1096 (void)setruid(PL_uid);
1097 PL_delaymagic &= ~DM_RUID;
1099 # endif /* HAS_SETRUID */
1101 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1102 (void)seteuid(PL_euid);
1103 PL_delaymagic &= ~DM_EUID;
1105 # endif /* HAS_SETEUID */
1106 if (PL_delaymagic & DM_UID) {
1107 if (PL_uid != PL_euid)
1108 DIE(aTHX_ "No setreuid available");
1109 (void)PerlProc_setuid(PL_uid);
1111 # endif /* HAS_SETREUID */
1112 #endif /* HAS_SETRESUID */
1113 PL_uid = PerlProc_getuid();
1114 PL_euid = PerlProc_geteuid();
1116 if (PL_delaymagic & DM_GID) {
1117 #ifdef HAS_SETRESGID
1118 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1119 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1122 # ifdef HAS_SETREGID
1123 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1124 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1127 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1128 (void)setrgid(PL_gid);
1129 PL_delaymagic &= ~DM_RGID;
1131 # endif /* HAS_SETRGID */
1133 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1134 (void)setegid(PL_egid);
1135 PL_delaymagic &= ~DM_EGID;
1137 # endif /* HAS_SETEGID */
1138 if (PL_delaymagic & DM_GID) {
1139 if (PL_gid != PL_egid)
1140 DIE(aTHX_ "No setregid available");
1141 (void)PerlProc_setgid(PL_gid);
1143 # endif /* HAS_SETREGID */
1144 #endif /* HAS_SETRESGID */
1145 PL_gid = PerlProc_getgid();
1146 PL_egid = PerlProc_getegid();
1148 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1152 if (gimme == G_VOID)
1153 SP = firstrelem - 1;
1154 else if (gimme == G_SCALAR) {
1157 SETi(lastrelem - firstrelem + 1 - duplicates);
1164 /* Removes from the stack the entries which ended up as
1165 * duplicated keys in the hash (fix for [perl #24380]) */
1166 Move(firsthashrelem + duplicates,
1167 firsthashrelem, duplicates, SV**);
1168 lastrelem -= duplicates;
1173 SP = firstrelem + (lastlelem - firstlelem);
1174 lelem = firstlelem + (relem - firstrelem);
1176 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1185 register PMOP * const pm = cPMOP;
1186 REGEXP * rx = PM_GETRE(pm);
1187 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1188 SV * const rv = sv_newmortal();
1190 SvUPGRADE(rv, SVt_IV);
1191 /* This RV is about to own a reference to the regexp. (In addition to the
1192 reference already owned by the PMOP. */
1194 SvRV_set(rv, (SV*) rx);
1198 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1199 (void)sv_bless(rv, stash);
1202 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1211 register PMOP *pm = cPMOP;
1213 register const char *t;
1214 register const char *s;
1217 U8 r_flags = REXEC_CHECKED;
1218 const char *truebase; /* Start of string */
1219 register REGEXP *rx = PM_GETRE(pm);
1221 const I32 gimme = GIMME;
1224 const I32 oldsave = PL_savestack_ix;
1225 I32 update_minmatch = 1;
1226 I32 had_zerolen = 0;
1229 if (PL_op->op_flags & OPf_STACKED)
1231 else if (PL_op->op_private & OPpTARGET_MY)
1238 PUTBACK; /* EVAL blocks need stack_sp. */
1239 s = SvPV_const(TARG, len);
1241 DIE(aTHX_ "panic: pp_match");
1243 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1244 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1247 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1249 /* PMdf_USED is set after a ?? matches once */
1252 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1254 pm->op_pmflags & PMf_USED
1258 if (gimme == G_ARRAY)
1265 /* empty pattern special-cased to use last successful pattern if possible */
1266 if (!RX_PRELEN(rx) && PL_curpm) {
1271 if (RX_MINLEN(rx) > (I32)len)
1276 /* XXXX What part of this is needed with true \G-support? */
1277 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1278 RX_OFFS(rx)[0].start = -1;
1279 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1280 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1281 if (mg && mg->mg_len >= 0) {
1282 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1283 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1284 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1285 r_flags |= REXEC_IGNOREPOS;
1286 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1287 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1290 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1291 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1292 update_minmatch = 0;
1296 /* XXX: comment out !global get safe $1 vars after a
1297 match, BUT be aware that this leads to dramatic slowdowns on
1298 /g matches against large strings. So far a solution to this problem
1299 appears to be quite tricky.
1300 Test for the unsafe vars are TODO for now. */
1301 if (( !global && RX_NPARENS(rx))
1302 || SvTEMP(TARG) || PL_sawampersand ||
1303 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1304 r_flags |= REXEC_COPY_STR;
1306 r_flags |= REXEC_SCREAM;
1309 if (global && RX_OFFS(rx)[0].start != -1) {
1310 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1311 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1313 if (update_minmatch++)
1314 minmatch = had_zerolen;
1316 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1317 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1318 /* FIXME - can PL_bostr be made const char *? */
1319 PL_bostr = (char *)truebase;
1320 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1324 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1326 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1327 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1328 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1329 && (r_flags & REXEC_SCREAM)))
1330 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1333 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1334 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1337 if (dynpm->op_pmflags & PMf_ONCE) {
1339 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1341 dynpm->op_pmflags |= PMf_USED;
1352 RX_MATCH_TAINTED_on(rx);
1353 TAINT_IF(RX_MATCH_TAINTED(rx));
1354 if (gimme == G_ARRAY) {
1355 const I32 nparens = RX_NPARENS(rx);
1356 I32 i = (global && !nparens) ? 1 : 0;
1358 SPAGAIN; /* EVAL blocks could move the stack. */
1359 EXTEND(SP, nparens + i);
1360 EXTEND_MORTAL(nparens + i);
1361 for (i = !i; i <= nparens; i++) {
1362 PUSHs(sv_newmortal());
1363 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1364 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1365 s = RX_OFFS(rx)[i].start + truebase;
1366 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1367 len < 0 || len > strend - s)
1368 DIE(aTHX_ "panic: pp_match start/end pointers");
1369 sv_setpvn(*SP, s, len);
1370 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1375 if (dynpm->op_pmflags & PMf_CONTINUE) {
1377 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1378 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1380 #ifdef PERL_OLD_COPY_ON_WRITE
1382 sv_force_normal_flags(TARG, 0);
1384 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1385 &PL_vtbl_mglob, NULL, 0);
1387 if (RX_OFFS(rx)[0].start != -1) {
1388 mg->mg_len = RX_OFFS(rx)[0].end;
1389 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1390 mg->mg_flags |= MGf_MINMATCH;
1392 mg->mg_flags &= ~MGf_MINMATCH;
1395 had_zerolen = (RX_OFFS(rx)[0].start != -1
1396 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1397 == (UV)RX_OFFS(rx)[0].end));
1398 PUTBACK; /* EVAL blocks may use stack */
1399 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1404 LEAVE_SCOPE(oldsave);
1410 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1411 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1415 #ifdef PERL_OLD_COPY_ON_WRITE
1417 sv_force_normal_flags(TARG, 0);
1419 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1420 &PL_vtbl_mglob, NULL, 0);
1422 if (RX_OFFS(rx)[0].start != -1) {
1423 mg->mg_len = RX_OFFS(rx)[0].end;
1424 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1425 mg->mg_flags |= MGf_MINMATCH;
1427 mg->mg_flags &= ~MGf_MINMATCH;
1430 LEAVE_SCOPE(oldsave);
1434 yup: /* Confirmed by INTUIT */
1436 RX_MATCH_TAINTED_on(rx);
1437 TAINT_IF(RX_MATCH_TAINTED(rx));
1439 if (dynpm->op_pmflags & PMf_ONCE) {
1441 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1443 dynpm->op_pmflags |= PMf_USED;
1446 if (RX_MATCH_COPIED(rx))
1447 Safefree(RX_SUBBEG(rx));
1448 RX_MATCH_COPIED_off(rx);
1449 RX_SUBBEG(rx) = NULL;
1451 /* FIXME - should rx->subbeg be const char *? */
1452 RX_SUBBEG(rx) = (char *) truebase;
1453 RX_OFFS(rx)[0].start = s - truebase;
1454 if (RX_MATCH_UTF8(rx)) {
1455 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1456 RX_OFFS(rx)[0].end = t - truebase;
1459 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1461 RX_SUBLEN(rx) = strend - truebase;
1464 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1466 #ifdef PERL_OLD_COPY_ON_WRITE
1467 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1469 PerlIO_printf(Perl_debug_log,
1470 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1471 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1474 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1476 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1477 assert (SvPOKp(RX_SAVED_COPY(rx)));
1482 RX_SUBBEG(rx) = savepvn(t, strend - t);
1483 #ifdef PERL_OLD_COPY_ON_WRITE
1484 RX_SAVED_COPY(rx) = NULL;
1487 RX_SUBLEN(rx) = strend - t;
1488 RX_MATCH_COPIED_on(rx);
1489 off = RX_OFFS(rx)[0].start = s - t;
1490 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1492 else { /* startp/endp are used by @- @+. */
1493 RX_OFFS(rx)[0].start = s - truebase;
1494 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1496 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1498 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1499 LEAVE_SCOPE(oldsave);
1504 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1505 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1506 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1511 LEAVE_SCOPE(oldsave);
1512 if (gimme == G_ARRAY)
1518 Perl_do_readline(pTHX)
1520 dVAR; dSP; dTARGETSTACKED;
1525 register IO * const io = GvIO(PL_last_in_gv);
1526 register const I32 type = PL_op->op_type;
1527 const I32 gimme = GIMME_V;
1530 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1533 XPUSHs(SvTIED_obj((SV*)io, mg));
1536 call_method("READLINE", gimme);
1539 if (gimme == G_SCALAR) {
1540 SV* const result = POPs;
1541 SvSetSV_nosteal(TARG, result);
1551 if (IoFLAGS(io) & IOf_ARGV) {
1552 if (IoFLAGS(io) & IOf_START) {
1554 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1555 IoFLAGS(io) &= ~IOf_START;
1556 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1557 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1558 SvSETMAGIC(GvSV(PL_last_in_gv));
1563 fp = nextargv(PL_last_in_gv);
1564 if (!fp) { /* Note: fp != IoIFP(io) */
1565 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1568 else if (type == OP_GLOB)
1569 fp = Perl_start_glob(aTHX_ POPs, io);
1571 else if (type == OP_GLOB)
1573 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1574 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1578 if ((!io || !(IoFLAGS(io) & IOf_START))
1579 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1581 if (type == OP_GLOB)
1582 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1583 "glob failed (can't start child: %s)",
1586 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1588 if (gimme == G_SCALAR) {
1589 /* undef TARG, and push that undefined value */
1590 if (type != OP_RCATLINE) {
1591 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1599 if (gimme == G_SCALAR) {
1601 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1604 if (type == OP_RCATLINE)
1605 SvPV_force_nolen(sv);
1609 else if (isGV_with_GP(sv)) {
1610 SvPV_force_nolen(sv);
1612 SvUPGRADE(sv, SVt_PV);
1613 tmplen = SvLEN(sv); /* remember if already alloced */
1614 if (!tmplen && !SvREADONLY(sv))
1615 Sv_Grow(sv, 80); /* try short-buffering it */
1617 if (type == OP_RCATLINE && SvOK(sv)) {
1619 SvPV_force_nolen(sv);
1625 sv = sv_2mortal(newSV(80));
1629 /* This should not be marked tainted if the fp is marked clean */
1630 #define MAYBE_TAINT_LINE(io, sv) \
1631 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1636 /* delay EOF state for a snarfed empty file */
1637 #define SNARF_EOF(gimme,rs,io,sv) \
1638 (gimme != G_SCALAR || SvCUR(sv) \
1639 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1643 if (!sv_gets(sv, fp, offset)
1645 || SNARF_EOF(gimme, PL_rs, io, sv)
1646 || PerlIO_error(fp)))
1648 PerlIO_clearerr(fp);
1649 if (IoFLAGS(io) & IOf_ARGV) {
1650 fp = nextargv(PL_last_in_gv);
1653 (void)do_close(PL_last_in_gv, FALSE);
1655 else if (type == OP_GLOB) {
1656 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1657 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1658 "glob failed (child exited with status %d%s)",
1659 (int)(STATUS_CURRENT >> 8),
1660 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1663 if (gimme == G_SCALAR) {
1664 if (type != OP_RCATLINE) {
1665 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1671 MAYBE_TAINT_LINE(io, sv);
1674 MAYBE_TAINT_LINE(io, sv);
1676 IoFLAGS(io) |= IOf_NOLINE;
1680 if (type == OP_GLOB) {
1683 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1684 char * const tmps = SvEND(sv) - 1;
1685 if (*tmps == *SvPVX_const(PL_rs)) {
1687 SvCUR_set(sv, SvCUR(sv) - 1);
1690 for (t1 = SvPVX_const(sv); *t1; t1++)
1691 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1692 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1694 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1695 (void)POPs; /* Unmatched wildcard? Chuck it... */
1698 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1699 if (ckWARN(WARN_UTF8)) {
1700 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1701 const STRLEN len = SvCUR(sv) - offset;
1704 if (!is_utf8_string_loc(s, len, &f))
1705 /* Emulate :encoding(utf8) warning in the same case. */
1706 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1707 "utf8 \"\\x%02X\" does not map to Unicode",
1708 f < (U8*)SvEND(sv) ? *f : 0);
1711 if (gimme == G_ARRAY) {
1712 if (SvLEN(sv) - SvCUR(sv) > 20) {
1713 SvPV_shrink_to_cur(sv);
1715 sv = sv_2mortal(newSV(80));
1718 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1719 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1720 const STRLEN new_len
1721 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1722 SvPV_renew(sv, new_len);
1731 register PERL_CONTEXT *cx;
1732 I32 gimme = OP_GIMME(PL_op, -1);
1735 if (cxstack_ix >= 0)
1736 gimme = cxstack[cxstack_ix].blk_gimme;
1744 PUSHBLOCK(cx, CXt_BLOCK, SP);
1754 SV * const keysv = POPs;
1755 HV * const hv = (HV*)POPs;
1756 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1757 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1759 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1762 if (SvTYPE(hv) != SVt_PVHV)
1765 if (PL_op->op_private & OPpLVAL_INTRO) {
1768 /* does the element we're localizing already exist? */
1769 preeminent = /* can we determine whether it exists? */
1771 || mg_find((SV*)hv, PERL_MAGIC_env)
1772 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1773 /* Try to preserve the existenceness of a tied hash
1774 * element by using EXISTS and DELETE if possible.
1775 * Fallback to FETCH and STORE otherwise */
1776 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1777 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1778 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1780 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1782 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1783 svp = he ? &HeVAL(he) : NULL;
1785 if (!svp || *svp == &PL_sv_undef) {
1789 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1791 lv = sv_newmortal();
1792 sv_upgrade(lv, SVt_PVLV);
1794 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1795 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1796 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1801 if (PL_op->op_private & OPpLVAL_INTRO) {
1802 if (HvNAME_get(hv) && isGV(*svp))
1803 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1807 const char * const key = SvPV_const(keysv, keylen);
1808 SAVEDELETE(hv, savepvn(key,keylen),
1809 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1811 save_helem(hv, keysv, svp);
1814 else if (PL_op->op_private & OPpDEREF)
1815 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1817 sv = (svp ? *svp : &PL_sv_undef);
1818 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1819 * Pushing the magical RHS on to the stack is useless, since
1820 * that magic is soon destined to be misled by the local(),
1821 * and thus the later pp_sassign() will fail to mg_get() the
1822 * old value. This should also cure problems with delayed
1823 * mg_get()s. GSAR 98-07-03 */
1824 if (!lval && SvGMAGICAL(sv))
1825 sv = sv_mortalcopy(sv);
1833 register PERL_CONTEXT *cx;
1838 if (PL_op->op_flags & OPf_SPECIAL) {
1839 cx = &cxstack[cxstack_ix];
1840 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1845 gimme = OP_GIMME(PL_op, -1);
1847 if (cxstack_ix >= 0)
1848 gimme = cxstack[cxstack_ix].blk_gimme;
1854 if (gimme == G_VOID)
1856 else if (gimme == G_SCALAR) {
1860 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1863 *MARK = sv_mortalcopy(TOPs);
1866 *MARK = &PL_sv_undef;
1870 else if (gimme == G_ARRAY) {
1871 /* in case LEAVE wipes old return values */
1873 for (mark = newsp + 1; mark <= SP; mark++) {
1874 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1875 *mark = sv_mortalcopy(*mark);
1876 TAINT_NOT; /* Each item is independent */
1880 PL_curpm = newpm; /* Don't pop $1 et al till now */
1890 register PERL_CONTEXT *cx;
1893 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1894 bool av_is_stack = FALSE;
1897 cx = &cxstack[cxstack_ix];
1898 if (!CxTYPE_is_LOOP(cx))
1899 DIE(aTHX_ "panic: pp_iter");
1901 itersvp = CxITERVAR(cx);
1902 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1903 /* string increment */
1904 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1905 SV *end = cx->blk_loop.state_u.lazysv.end;
1906 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1907 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1909 const char *max = SvPV_const(end, maxlen);
1910 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1911 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1912 /* safe to reuse old SV */
1913 sv_setsv(*itersvp, cur);
1917 /* we need a fresh SV every time so that loop body sees a
1918 * completely new SV for closures/references to work as
1921 *itersvp = newSVsv(cur);
1922 SvREFCNT_dec(oldsv);
1924 if (strEQ(SvPVX_const(cur), max))
1925 sv_setiv(cur, 0); /* terminate next time */
1932 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1933 /* integer increment */
1934 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1937 /* don't risk potential race */
1938 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1939 /* safe to reuse old SV */
1940 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1944 /* we need a fresh SV every time so that loop body sees a
1945 * completely new SV for closures/references to work as they
1948 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1949 SvREFCNT_dec(oldsv);
1952 /* Handle end of range at IV_MAX */
1953 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1954 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1956 cx->blk_loop.state_u.lazyiv.cur++;
1957 cx->blk_loop.state_u.lazyiv.end++;
1964 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1965 av = cx->blk_loop.state_u.ary.ary;
1970 if (PL_op->op_private & OPpITER_REVERSED) {
1971 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1972 ? cx->blk_loop.resetsp + 1 : 0))
1975 if (SvMAGICAL(av) || AvREIFY(av)) {
1976 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1977 sv = svp ? *svp : NULL;
1980 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1984 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1988 if (SvMAGICAL(av) || AvREIFY(av)) {
1989 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1990 sv = svp ? *svp : NULL;
1993 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1997 if (sv && SvIS_FREED(sv)) {
1999 Perl_croak(aTHX_ "Use of freed value in iteration");
2004 SvREFCNT_inc_simple_void_NN(sv);
2008 if (!av_is_stack && sv == &PL_sv_undef) {
2009 SV *lv = newSV_type(SVt_PVLV);
2011 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2012 LvTARG(lv) = SvREFCNT_inc_simple(av);
2013 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2014 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2020 SvREFCNT_dec(oldsv);
2028 register PMOP *pm = cPMOP;
2043 register REGEXP *rx = PM_GETRE(pm);
2045 int force_on_match = 0;
2046 const I32 oldsave = PL_savestack_ix;
2048 bool doutf8 = FALSE;
2050 #ifdef PERL_OLD_COPY_ON_WRITE
2055 /* known replacement string? */
2056 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2057 if (PL_op->op_flags & OPf_STACKED)
2059 else if (PL_op->op_private & OPpTARGET_MY)
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2067 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2068 because they make integers such as 256 "false". */
2069 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2072 sv_force_normal_flags(TARG,0);
2075 #ifdef PERL_OLD_COPY_ON_WRITE
2079 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2080 || SvTYPE(TARG) > SVt_PVLV)
2081 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2082 DIE(aTHX_ PL_no_modify);
2085 s = SvPV_mutable(TARG, len);
2086 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2088 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2089 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2094 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2098 DIE(aTHX_ "panic: pp_subst");
2101 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2102 maxiters = 2 * slen + 10; /* We can match twice at each
2103 position, once with zero-length,
2104 second time with non-zero. */
2106 if (!RX_PRELEN(rx) && PL_curpm) {
2110 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2111 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2112 ? REXEC_COPY_STR : 0;
2114 r_flags |= REXEC_SCREAM;
2117 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2119 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2123 /* How to do it in subst? */
2124 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2126 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2127 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2128 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2129 && (r_flags & REXEC_SCREAM))))
2134 /* only replace once? */
2135 once = !(rpm->op_pmflags & PMf_GLOBAL);
2136 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2137 r_flags | REXEC_CHECKED);
2138 /* known replacement string? */
2140 /* replacement needing upgrading? */
2141 if (DO_UTF8(TARG) && !doutf8) {
2142 nsv = sv_newmortal();
2145 sv_recode_to_utf8(nsv, PL_encoding);
2147 sv_utf8_upgrade(nsv);
2148 c = SvPV_const(nsv, clen);
2152 c = SvPV_const(dstr, clen);
2153 doutf8 = DO_UTF8(dstr);
2161 /* can do inplace substitution? */
2163 #ifdef PERL_OLD_COPY_ON_WRITE
2166 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2167 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2168 && (!doutf8 || SvUTF8(TARG))) {
2173 LEAVE_SCOPE(oldsave);
2176 #ifdef PERL_OLD_COPY_ON_WRITE
2177 if (SvIsCOW(TARG)) {
2178 assert (!force_on_match);
2182 if (force_on_match) {
2184 s = SvPV_force(TARG, len);
2189 SvSCREAM_off(TARG); /* disable possible screamer */
2191 rxtainted |= RX_MATCH_TAINTED(rx);
2192 m = orig + RX_OFFS(rx)[0].start;
2193 d = orig + RX_OFFS(rx)[0].end;
2195 if (m - s > strend - d) { /* faster to shorten from end */
2197 Copy(c, m, clen, char);
2202 Move(d, m, i, char);
2206 SvCUR_set(TARG, m - s);
2208 else if ((i = m - s)) { /* faster from front */
2211 Move(s, d - i, i, char);
2214 Copy(c, m, clen, char);
2219 Copy(c, d, clen, char);
2224 TAINT_IF(rxtainted & 1);
2230 if (iters++ > maxiters)
2231 DIE(aTHX_ "Substitution loop");
2232 rxtainted |= RX_MATCH_TAINTED(rx);
2233 m = RX_OFFS(rx)[0].start + orig;
2236 Move(s, d, i, char);
2240 Copy(c, d, clen, char);
2243 s = RX_OFFS(rx)[0].end + orig;
2244 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2246 /* don't match same null twice */
2247 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2250 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2251 Move(s, d, i+1, char); /* include the NUL */
2253 TAINT_IF(rxtainted & 1);
2257 (void)SvPOK_only_UTF8(TARG);
2258 TAINT_IF(rxtainted);
2259 if (SvSMAGICAL(TARG)) {
2267 LEAVE_SCOPE(oldsave);
2273 if (force_on_match) {
2275 s = SvPV_force(TARG, len);
2278 #ifdef PERL_OLD_COPY_ON_WRITE
2281 rxtainted |= RX_MATCH_TAINTED(rx);
2282 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2286 register PERL_CONTEXT *cx;
2289 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2291 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2293 if (iters++ > maxiters)
2294 DIE(aTHX_ "Substitution loop");
2295 rxtainted |= RX_MATCH_TAINTED(rx);
2296 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2299 orig = RX_SUBBEG(rx);
2301 strend = s + (strend - m);
2303 m = RX_OFFS(rx)[0].start + orig;
2304 if (doutf8 && !SvUTF8(dstr))
2305 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2307 sv_catpvn(dstr, s, m-s);
2308 s = RX_OFFS(rx)[0].end + orig;
2310 sv_catpvn(dstr, c, clen);
2313 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2314 TARG, NULL, r_flags));
2315 if (doutf8 && !DO_UTF8(TARG))
2316 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2318 sv_catpvn(dstr, s, strend - s);
2320 #ifdef PERL_OLD_COPY_ON_WRITE
2321 /* The match may make the string COW. If so, brilliant, because that's
2322 just saved us one malloc, copy and free - the regexp has donated
2323 the old buffer, and we malloc an entirely new one, rather than the
2324 regexp malloc()ing a buffer and copying our original, only for
2325 us to throw it away here during the substitution. */
2326 if (SvIsCOW(TARG)) {
2327 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2333 SvPV_set(TARG, SvPVX(dstr));
2334 SvCUR_set(TARG, SvCUR(dstr));
2335 SvLEN_set(TARG, SvLEN(dstr));
2336 doutf8 |= DO_UTF8(dstr);
2337 SvPV_set(dstr, NULL);
2339 TAINT_IF(rxtainted & 1);
2343 (void)SvPOK_only(TARG);
2346 TAINT_IF(rxtainted);
2349 LEAVE_SCOPE(oldsave);
2358 LEAVE_SCOPE(oldsave);
2367 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2368 ++*PL_markstack_ptr;
2369 LEAVE; /* exit inner scope */
2372 if (PL_stack_base + *PL_markstack_ptr > SP) {
2374 const I32 gimme = GIMME_V;
2376 LEAVE; /* exit outer scope */
2377 (void)POPMARK; /* pop src */
2378 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2379 (void)POPMARK; /* pop dst */
2380 SP = PL_stack_base + POPMARK; /* pop original mark */
2381 if (gimme == G_SCALAR) {
2382 if (PL_op->op_private & OPpGREP_LEX) {
2383 SV* const sv = sv_newmortal();
2384 sv_setiv(sv, items);
2392 else if (gimme == G_ARRAY)
2399 ENTER; /* enter inner scope */
2402 src = PL_stack_base[*PL_markstack_ptr];
2404 if (PL_op->op_private & OPpGREP_LEX)
2405 PAD_SVl(PL_op->op_targ) = src;
2409 RETURNOP(cLOGOP->op_other);
2420 register PERL_CONTEXT *cx;
2423 if (CxMULTICALL(&cxstack[cxstack_ix]))
2427 cxstack_ix++; /* temporarily protect top context */
2430 if (gimme == G_SCALAR) {
2433 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2435 *MARK = SvREFCNT_inc(TOPs);
2440 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2442 *MARK = sv_mortalcopy(sv);
2447 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2451 *MARK = &PL_sv_undef;
2455 else if (gimme == G_ARRAY) {
2456 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2457 if (!SvTEMP(*MARK)) {
2458 *MARK = sv_mortalcopy(*MARK);
2459 TAINT_NOT; /* Each item is independent */
2467 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2468 PL_curpm = newpm; /* ... and pop $1 et al */
2471 return cx->blk_sub.retop;
2474 /* This duplicates the above code because the above code must not
2475 * get any slower by more conditions */
2483 register PERL_CONTEXT *cx;
2486 if (CxMULTICALL(&cxstack[cxstack_ix]))
2490 cxstack_ix++; /* temporarily protect top context */
2494 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2495 /* We are an argument to a function or grep().
2496 * This kind of lvalueness was legal before lvalue
2497 * subroutines too, so be backward compatible:
2498 * cannot report errors. */
2500 /* Scalar context *is* possible, on the LHS of -> only,
2501 * as in f()->meth(). But this is not an lvalue. */
2502 if (gimme == G_SCALAR)
2504 if (gimme == G_ARRAY) {
2505 if (!CvLVALUE(cx->blk_sub.cv))
2506 goto temporise_array;
2507 EXTEND_MORTAL(SP - newsp);
2508 for (mark = newsp + 1; mark <= SP; mark++) {
2511 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2512 *mark = sv_mortalcopy(*mark);
2514 /* Can be a localized value subject to deletion. */
2515 PL_tmps_stack[++PL_tmps_ix] = *mark;
2516 SvREFCNT_inc_void(*mark);
2521 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2522 /* Here we go for robustness, not for speed, so we change all
2523 * the refcounts so the caller gets a live guy. Cannot set
2524 * TEMP, so sv_2mortal is out of question. */
2525 if (!CvLVALUE(cx->blk_sub.cv)) {
2531 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2533 if (gimme == G_SCALAR) {
2537 /* Temporaries are bad unless they happen to be elements
2538 * of a tied hash or array */
2539 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2540 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2546 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2547 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2548 : "a readonly value" : "a temporary");
2550 else { /* Can be a localized value
2551 * subject to deletion. */
2552 PL_tmps_stack[++PL_tmps_ix] = *mark;
2553 SvREFCNT_inc_void(*mark);
2556 else { /* Should not happen? */
2562 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2563 (MARK > SP ? "Empty array" : "Array"));
2567 else if (gimme == G_ARRAY) {
2568 EXTEND_MORTAL(SP - newsp);
2569 for (mark = newsp + 1; mark <= SP; mark++) {
2570 if (*mark != &PL_sv_undef
2571 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2572 /* Might be flattened array after $#array = */
2579 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2580 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2583 /* Can be a localized value subject to deletion. */
2584 PL_tmps_stack[++PL_tmps_ix] = *mark;
2585 SvREFCNT_inc_void(*mark);
2591 if (gimme == G_SCALAR) {
2595 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2597 *MARK = SvREFCNT_inc(TOPs);
2602 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2604 *MARK = sv_mortalcopy(sv);
2609 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2613 *MARK = &PL_sv_undef;
2617 else if (gimme == G_ARRAY) {
2619 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2620 if (!SvTEMP(*MARK)) {
2621 *MARK = sv_mortalcopy(*MARK);
2622 TAINT_NOT; /* Each item is independent */
2631 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2632 PL_curpm = newpm; /* ... and pop $1 et al */
2635 return cx->blk_sub.retop;
2643 register PERL_CONTEXT *cx;
2645 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2648 DIE(aTHX_ "Not a CODE reference");
2649 switch (SvTYPE(sv)) {
2650 /* This is overwhelming the most common case: */
2652 if (!(cv = GvCVu((GV*)sv))) {
2654 cv = sv_2cv(sv, &stash, &gv, 0);
2666 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2668 SP = PL_stack_base + POPMARK;
2671 if (SvGMAGICAL(sv)) {
2676 sym = SvPVX_const(sv);
2684 sym = SvPV_const(sv, len);
2687 DIE(aTHX_ PL_no_usym, "a subroutine");
2688 if (PL_op->op_private & HINT_STRICT_REFS)
2689 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2690 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2695 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2696 tryAMAGICunDEREF(to_cv);
2699 if (SvTYPE(cv) == SVt_PVCV)
2704 DIE(aTHX_ "Not a CODE reference");
2705 /* This is the second most common case: */
2715 if (!CvROOT(cv) && !CvXSUB(cv)) {
2719 /* anonymous or undef'd function leaves us no recourse */
2720 if (CvANON(cv) || !(gv = CvGV(cv)))
2721 DIE(aTHX_ "Undefined subroutine called");
2723 /* autoloaded stub? */
2724 if (cv != GvCV(gv)) {
2727 /* should call AUTOLOAD now? */
2730 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2737 sub_name = sv_newmortal();
2738 gv_efullname3(sub_name, gv, NULL);
2739 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2743 DIE(aTHX_ "Not a CODE reference");
2748 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2749 Perl_get_db_sub(aTHX_ &sv, cv);
2751 PL_curcopdb = PL_curcop;
2752 cv = GvCV(PL_DBsub);
2754 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2755 DIE(aTHX_ "No DB::sub routine defined");
2758 if (!(CvISXSUB(cv))) {
2759 /* This path taken at least 75% of the time */
2761 register I32 items = SP - MARK;
2762 AV* const padlist = CvPADLIST(cv);
2763 PUSHBLOCK(cx, CXt_SUB, MARK);
2765 cx->blk_sub.retop = PL_op->op_next;
2767 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2768 * that eval'' ops within this sub know the correct lexical space.
2769 * Owing the speed considerations, we choose instead to search for
2770 * the cv using find_runcv() when calling doeval().
2772 if (CvDEPTH(cv) >= 2) {
2773 PERL_STACK_OVERFLOW_CHECK();
2774 pad_push(padlist, CvDEPTH(cv));
2777 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2779 AV* const av = (AV*)PAD_SVl(0);
2781 /* @_ is normally not REAL--this should only ever
2782 * happen when DB::sub() calls things that modify @_ */
2787 cx->blk_sub.savearray = GvAV(PL_defgv);
2788 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2789 CX_CURPAD_SAVE(cx->blk_sub);
2790 cx->blk_sub.argarray = av;
2793 if (items > AvMAX(av) + 1) {
2794 SV **ary = AvALLOC(av);
2795 if (AvARRAY(av) != ary) {
2796 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2799 if (items > AvMAX(av) + 1) {
2800 AvMAX(av) = items - 1;
2801 Renew(ary,items,SV*);
2806 Copy(MARK,AvARRAY(av),items,SV*);
2807 AvFILLp(av) = items - 1;
2815 /* warning must come *after* we fully set up the context
2816 * stuff so that __WARN__ handlers can safely dounwind()
2819 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2820 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2821 sub_crush_depth(cv);
2822 RETURNOP(CvSTART(cv));
2825 I32 markix = TOPMARK;
2830 /* Need to copy @_ to stack. Alternative may be to
2831 * switch stack to @_, and copy return values
2832 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2833 AV * const av = GvAV(PL_defgv);
2834 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2837 /* Mark is at the end of the stack. */
2839 Copy(AvARRAY(av), SP + 1, items, SV*);
2844 /* We assume first XSUB in &DB::sub is the called one. */
2846 SAVEVPTR(PL_curcop);
2847 PL_curcop = PL_curcopdb;
2850 /* Do we need to open block here? XXXX */
2851 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2852 (void)(*CvXSUB(cv))(aTHX_ cv);
2854 /* Enforce some sanity in scalar context. */
2855 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2856 if (markix > PL_stack_sp - PL_stack_base)
2857 *(PL_stack_base + markix) = &PL_sv_undef;
2859 *(PL_stack_base + markix) = *PL_stack_sp;
2860 PL_stack_sp = PL_stack_base + markix;
2868 Perl_sub_crush_depth(pTHX_ CV *cv)
2870 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2873 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2875 SV* const tmpstr = sv_newmortal();
2876 gv_efullname3(tmpstr, CvGV(cv), NULL);
2877 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2886 SV* const elemsv = POPs;
2887 IV elem = SvIV(elemsv);
2888 AV* const av = (AV*)POPs;
2889 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2890 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2893 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2894 Perl_warner(aTHX_ packWARN(WARN_MISC),
2895 "Use of reference \"%"SVf"\" as array index",
2898 elem -= CopARYBASE_get(PL_curcop);
2899 if (SvTYPE(av) != SVt_PVAV)
2901 svp = av_fetch(av, elem, lval && !defer);
2903 #ifdef PERL_MALLOC_WRAP
2904 if (SvUOK(elemsv)) {
2905 const UV uv = SvUV(elemsv);
2906 elem = uv > IV_MAX ? IV_MAX : uv;
2908 else if (SvNOK(elemsv))
2909 elem = (IV)SvNV(elemsv);
2911 static const char oom_array_extend[] =
2912 "Out of memory during array extend"; /* Duplicated in av.c */
2913 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2916 if (!svp || *svp == &PL_sv_undef) {
2919 DIE(aTHX_ PL_no_aelem, elem);
2920 lv = sv_newmortal();
2921 sv_upgrade(lv, SVt_PVLV);
2923 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2924 LvTARG(lv) = SvREFCNT_inc_simple(av);
2925 LvTARGOFF(lv) = elem;
2930 if (PL_op->op_private & OPpLVAL_INTRO)
2931 save_aelem(av, elem, svp);
2932 else if (PL_op->op_private & OPpDEREF)
2933 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2935 sv = (svp ? *svp : &PL_sv_undef);
2936 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2937 sv = sv_mortalcopy(sv);
2943 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2945 PERL_ARGS_ASSERT_VIVIFY_REF;
2950 Perl_croak(aTHX_ PL_no_modify);
2951 prepare_SV_for_RV(sv);
2954 SvRV_set(sv, newSV(0));
2957 SvRV_set(sv, (SV*)newAV());
2960 SvRV_set(sv, (SV*)newHV());
2971 SV* const sv = TOPs;
2974 SV* const rsv = SvRV(sv);
2975 if (SvTYPE(rsv) == SVt_PVCV) {
2981 SETs(method_common(sv, NULL));
2988 SV* const sv = cSVOP_sv;
2989 U32 hash = SvSHARED_HASH(sv);
2991 XPUSHs(method_common(sv, &hash));
2996 S_method_common(pTHX_ SV* meth, U32* hashp)
3003 const char* packname = NULL;
3006 const char * const name = SvPV_const(meth, namelen);
3007 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3009 PERL_ARGS_ASSERT_METHOD_COMMON;
3012 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3020 /* this isn't a reference */
3021 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3022 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3024 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3031 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3032 !(ob=(SV*)GvIO(iogv)))
3034 /* this isn't the name of a filehandle either */
3036 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3037 ? !isIDFIRST_utf8((U8*)packname)
3038 : !isIDFIRST(*packname)
3041 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3042 SvOK(sv) ? "without a package or object reference"
3043 : "on an undefined value");
3045 /* assume it's a package name */
3046 stash = gv_stashpvn(packname, packlen, 0);
3050 SV* const ref = newSViv(PTR2IV(stash));
3051 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3055 /* it _is_ a filehandle name -- replace with a reference */
3056 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3059 /* if we got here, ob should be a reference or a glob */
3060 if (!ob || !(SvOBJECT(ob)
3061 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3064 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3065 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3069 stash = SvSTASH(ob);
3072 /* NOTE: stash may be null, hope hv_fetch_ent and
3073 gv_fetchmethod can cope (it seems they can) */
3075 /* shortcut for simple names */
3077 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3079 gv = (GV*)HeVAL(he);
3080 if (isGV(gv) && GvCV(gv) &&
3081 (!GvCVGEN(gv) || GvCVGEN(gv)
3082 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3083 return (SV*)GvCV(gv);
3087 gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
3088 GV_AUTOLOAD | GV_CROAK);
3092 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3097 * c-indentation-style: bsd
3099 * indent-tabs-mode: t
3102 * ex: set ts=8 sts=4 sw=4 noet: