3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
15 * Awake! Awake! Fear, Fire, Foes! Awake!
19 /* This file contains 'hot' pp ("push/pop") functions that
20 * execute the opcodes that make up a perl program. A typical pp function
21 * expects to find its arguments on the stack, and usually pushes its
22 * results onto the stack, hence the 'pp' terminology. Each OP structure
23 * contains a pointer to the relevant pp_foo() function.
25 * By 'hot', we mean common ops whose execution speed is critical.
26 * By gathering them together into a single file, we encourage
27 * CPU cache hits on hot code. Also it could be taken as a warning not to
28 * change any code in this file unless you're sure it won't affect
33 #define PERL_IN_PP_HOT_C
49 PL_curcop = (COP*)PL_op;
50 TAINT_NOT; /* Each statement is presumed innocent */
51 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
61 if (PL_op->op_private & OPpLVAL_INTRO)
62 PUSHs(save_scalar(cGVOP_gv));
64 PUSHs(GvSVn(cGVOP_gv));
77 PUSHMARK(PL_stack_sp);
92 XPUSHs((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 (!isGV_with_GP(PL_last_in_gv)) {
311 if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
312 PL_last_in_gv = (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_PVAV || isGV_with_GP(TOPs))
401 DIE(aTHX_ PL_no_modify);
402 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
403 && SvIVX(TOPs) != IV_MAX)
405 SvIV_set(TOPs, SvIVX(TOPs) + 1);
406 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
408 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
420 if (PL_op->op_type == OP_OR)
422 RETURNOP(cLOGOP->op_other);
431 const int op_type = PL_op->op_type;
432 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
436 if (!sv || !SvANY(sv)) {
437 if (op_type == OP_DOR)
439 RETURNOP(cLOGOP->op_other);
445 if (!sv || !SvANY(sv))
450 switch (SvTYPE(sv)) {
452 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
456 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
460 if (CvROOT(sv) || CvXSUB(sv))
473 if(op_type == OP_DOR)
475 RETURNOP(cLOGOP->op_other);
477 /* assuming OP_DEFINED */
485 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
486 tryAMAGICbin(add,opASSIGN);
487 svl = sv_2num(TOPm1s);
489 useleft = USE_LEFT(svl);
490 #ifdef PERL_PRESERVE_IVUV
491 /* We must see if we can perform the addition with integers if possible,
492 as the integer code detects overflow while the NV code doesn't.
493 If either argument hasn't had a numeric conversion yet attempt to get
494 the IV. It's important to do this now, rather than just assuming that
495 it's not IOK as a PV of "9223372036854775806" may not take well to NV
496 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
497 integer in case the second argument is IV=9223372036854775806
498 We can (now) rely on sv_2iv to do the right thing, only setting the
499 public IOK flag if the value in the NV (or PV) slot is truly integer.
501 A side effect is that this also aggressively prefers integer maths over
502 fp maths for integer values.
504 How to detect overflow?
506 C 99 section 6.2.6.1 says
508 The range of nonnegative values of a signed integer type is a subrange
509 of the corresponding unsigned integer type, and the representation of
510 the same value in each type is the same. A computation involving
511 unsigned operands can never overflow, because a result that cannot be
512 represented by the resulting unsigned integer type is reduced modulo
513 the number that is one greater than the largest value that can be
514 represented by the resulting type.
518 which I read as "unsigned ints wrap."
520 signed integer overflow seems to be classed as "exception condition"
522 If an exceptional condition occurs during the evaluation of an
523 expression (that is, if the result is not mathematically defined or not
524 in the range of representable values for its type), the behavior is
527 (6.5, the 5th paragraph)
529 I had assumed that on 2s complement machines signed arithmetic would
530 wrap, hence coded pp_add and pp_subtract on the assumption that
531 everything perl builds on would be happy. After much wailing and
532 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
533 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
534 unsigned code below is actually shorter than the old code. :-)
539 /* Unless the left argument is integer in range we are going to have to
540 use NV maths. Hence only attempt to coerce the right argument if
541 we know the left is integer. */
549 /* left operand is undef, treat as zero. + 0 is identity,
550 Could SETi or SETu right now, but space optimise by not adding
551 lots of code to speed up what is probably a rarish case. */
553 /* Left operand is defined, so is it IV? */
556 if ((auvok = SvUOK(svl)))
559 register const IV aiv = SvIVX(svl);
562 auvok = 1; /* Now acting as a sign flag. */
563 } else { /* 2s complement assumption for IV_MIN */
571 bool result_good = 0;
574 bool buvok = SvUOK(svr);
579 register const IV biv = SvIVX(svr);
586 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
587 else "IV" now, independent of how it came in.
588 if a, b represents positive, A, B negative, a maps to -A etc
593 all UV maths. negate result if A negative.
594 add if signs same, subtract if signs differ. */
600 /* Must get smaller */
606 /* result really should be -(auv-buv). as its negation
607 of true value, need to swap our result flag */
624 if (result <= (UV)IV_MIN)
627 /* result valid, but out of range for IV. */
632 } /* Overflow, drop through to NVs. */
637 NV value = SvNV(svr);
640 /* left operand is undef, treat as zero. + 0.0 is identity. */
644 SETn( value + SvNV(svl) );
652 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
653 (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 (!isGV_with_GP(sv)) {
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_ MUTABLE_HV(sv));
921 Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
922 is_pp_rv2av ? "array" : "hash");
927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
931 PERL_ARGS_ASSERT_DO_ODDBALL;
937 if (ckWARN(WARN_MISC)) {
939 if (relem == firstrelem &&
941 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
942 SvTYPE(SvRV(*relem)) == SVt_PVHV))
944 err = "Reference found where even-sized list expected";
947 err = "Odd number of elements in hash assignment";
948 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
952 didstore = hv_store_ent(hash,*relem,tmpstr,0);
953 if (SvMAGICAL(hash)) {
954 if (SvSMAGICAL(tmpstr))
966 SV **lastlelem = PL_stack_sp;
967 SV **lastrelem = PL_stack_base + POPMARK;
968 SV **firstrelem = PL_stack_base + POPMARK + 1;
969 SV **firstlelem = lastrelem + 1;
982 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
984 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
987 /* If there's a common identifier on both sides we have to take
988 * special care that assigning the identifier on the left doesn't
989 * clobber a value on the right that's used later in the list.
991 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
992 EXTEND_MORTAL(lastrelem - firstrelem + 1);
993 for (relem = firstrelem; relem <= lastrelem; relem++) {
995 TAINT_NOT; /* Each item is independent */
996 *relem = sv_mortalcopy(sv);
1006 while (lelem <= lastlelem) {
1007 TAINT_NOT; /* Each item stands on its own, taintwise. */
1009 switch (SvTYPE(sv)) {
1012 magic = SvMAGICAL(ary) != 0;
1014 av_extend(ary, lastrelem - relem);
1016 while (relem <= lastrelem) { /* gobble up all the rest */
1019 sv = newSVsv(*relem);
1021 didstore = av_store(ary,i++,sv);
1023 if (SvSMAGICAL(sv)) {
1024 /* More magic can happen in the mg_set callback, so we
1025 * backup the delaymagic for now. */
1026 U16 dmbak = PL_delaymagic;
1029 PL_delaymagic = dmbak;
1036 if (PL_delaymagic & DM_ARRAY)
1037 SvSETMAGIC((SV*)ary);
1039 case SVt_PVHV: { /* normal hash */
1042 hash = MUTABLE_HV(sv);
1043 magic = SvMAGICAL(hash) != 0;
1045 firsthashrelem = relem;
1047 while (relem < lastrelem) { /* gobble up all the rest */
1049 sv = *relem ? *relem : &PL_sv_no;
1053 sv_setsv(tmpstr,*relem); /* value */
1054 *(relem++) = tmpstr;
1055 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1056 /* key overwrites an existing entry */
1058 didstore = hv_store_ent(hash,sv,tmpstr,0);
1060 if (SvSMAGICAL(tmpstr)) {
1061 U16 dmbak = PL_delaymagic;
1064 PL_delaymagic = dmbak;
1071 if (relem == lastrelem) {
1072 do_oddball(hash, relem, firstrelem);
1078 if (SvIMMORTAL(sv)) {
1079 if (relem <= lastrelem)
1083 if (relem <= lastrelem) {
1084 sv_setsv(sv, *relem);
1088 sv_setsv(sv, &PL_sv_undef);
1090 if (SvSMAGICAL(sv)) {
1091 U16 dmbak = PL_delaymagic;
1094 PL_delaymagic = dmbak;
1099 if (PL_delaymagic & ~DM_DELAY) {
1100 if (PL_delaymagic & DM_UID) {
1101 #ifdef HAS_SETRESUID
1102 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1103 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1106 # ifdef HAS_SETREUID
1107 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1108 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1111 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1112 (void)setruid(PL_uid);
1113 PL_delaymagic &= ~DM_RUID;
1115 # endif /* HAS_SETRUID */
1117 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1118 (void)seteuid(PL_euid);
1119 PL_delaymagic &= ~DM_EUID;
1121 # endif /* HAS_SETEUID */
1122 if (PL_delaymagic & DM_UID) {
1123 if (PL_uid != PL_euid)
1124 DIE(aTHX_ "No setreuid available");
1125 (void)PerlProc_setuid(PL_uid);
1127 # endif /* HAS_SETREUID */
1128 #endif /* HAS_SETRESUID */
1129 PL_uid = PerlProc_getuid();
1130 PL_euid = PerlProc_geteuid();
1132 if (PL_delaymagic & DM_GID) {
1133 #ifdef HAS_SETRESGID
1134 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1135 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1138 # ifdef HAS_SETREGID
1139 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1140 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1143 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1144 (void)setrgid(PL_gid);
1145 PL_delaymagic &= ~DM_RGID;
1147 # endif /* HAS_SETRGID */
1149 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1150 (void)setegid(PL_egid);
1151 PL_delaymagic &= ~DM_EGID;
1153 # endif /* HAS_SETEGID */
1154 if (PL_delaymagic & DM_GID) {
1155 if (PL_gid != PL_egid)
1156 DIE(aTHX_ "No setregid available");
1157 (void)PerlProc_setgid(PL_gid);
1159 # endif /* HAS_SETREGID */
1160 #endif /* HAS_SETRESGID */
1161 PL_gid = PerlProc_getgid();
1162 PL_egid = PerlProc_getegid();
1164 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1168 if (gimme == G_VOID)
1169 SP = firstrelem - 1;
1170 else if (gimme == G_SCALAR) {
1173 SETi(lastrelem - firstrelem + 1 - duplicates);
1180 /* Removes from the stack the entries which ended up as
1181 * duplicated keys in the hash (fix for [perl #24380]) */
1182 Move(firsthashrelem + duplicates,
1183 firsthashrelem, duplicates, SV**);
1184 lastrelem -= duplicates;
1189 SP = firstrelem + (lastlelem - firstlelem);
1190 lelem = firstlelem + (relem - firstrelem);
1192 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1201 register PMOP * const pm = cPMOP;
1202 REGEXP * rx = PM_GETRE(pm);
1203 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1204 SV * const rv = sv_newmortal();
1206 SvUPGRADE(rv, SVt_IV);
1207 /* This RV is about to own a reference to the regexp. (In addition to the
1208 reference already owned by the PMOP. */
1210 SvRV_set(rv, (SV*) rx);
1214 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1216 (void)sv_bless(rv, stash);
1219 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1228 register PMOP *pm = cPMOP;
1230 register const char *t;
1231 register const char *s;
1234 U8 r_flags = REXEC_CHECKED;
1235 const char *truebase; /* Start of string */
1236 register REGEXP *rx = PM_GETRE(pm);
1238 const I32 gimme = GIMME;
1241 const I32 oldsave = PL_savestack_ix;
1242 I32 update_minmatch = 1;
1243 I32 had_zerolen = 0;
1246 if (PL_op->op_flags & OPf_STACKED)
1248 else if (PL_op->op_private & OPpTARGET_MY)
1255 PUTBACK; /* EVAL blocks need stack_sp. */
1256 s = SvPV_const(TARG, len);
1258 DIE(aTHX_ "panic: pp_match");
1260 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1261 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1264 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1266 /* PMdf_USED is set after a ?? matches once */
1269 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1271 pm->op_pmflags & PMf_USED
1275 if (gimme == G_ARRAY)
1282 /* empty pattern special-cased to use last successful pattern if possible */
1283 if (!RX_PRELEN(rx) && PL_curpm) {
1288 if (RX_MINLEN(rx) > (I32)len)
1293 /* XXXX What part of this is needed with true \G-support? */
1294 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1295 RX_OFFS(rx)[0].start = -1;
1296 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1297 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1298 if (mg && mg->mg_len >= 0) {
1299 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1300 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1301 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1302 r_flags |= REXEC_IGNOREPOS;
1303 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1304 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1307 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1308 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1309 update_minmatch = 0;
1313 /* XXX: comment out !global get safe $1 vars after a
1314 match, BUT be aware that this leads to dramatic slowdowns on
1315 /g matches against large strings. So far a solution to this problem
1316 appears to be quite tricky.
1317 Test for the unsafe vars are TODO for now. */
1318 if (( !global && RX_NPARENS(rx))
1319 || SvTEMP(TARG) || PL_sawampersand ||
1320 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1321 r_flags |= REXEC_COPY_STR;
1323 r_flags |= REXEC_SCREAM;
1326 if (global && RX_OFFS(rx)[0].start != -1) {
1327 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1328 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1330 if (update_minmatch++)
1331 minmatch = had_zerolen;
1333 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1334 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1335 /* FIXME - can PL_bostr be made const char *? */
1336 PL_bostr = (char *)truebase;
1337 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1341 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1343 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1344 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1345 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1346 && (r_flags & REXEC_SCREAM)))
1347 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1350 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1351 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1354 if (dynpm->op_pmflags & PMf_ONCE) {
1356 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1358 dynpm->op_pmflags |= PMf_USED;
1369 RX_MATCH_TAINTED_on(rx);
1370 TAINT_IF(RX_MATCH_TAINTED(rx));
1371 if (gimme == G_ARRAY) {
1372 const I32 nparens = RX_NPARENS(rx);
1373 I32 i = (global && !nparens) ? 1 : 0;
1375 SPAGAIN; /* EVAL blocks could move the stack. */
1376 EXTEND(SP, nparens + i);
1377 EXTEND_MORTAL(nparens + i);
1378 for (i = !i; i <= nparens; i++) {
1379 PUSHs(sv_newmortal());
1380 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1381 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1382 s = RX_OFFS(rx)[i].start + truebase;
1383 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1384 len < 0 || len > strend - s)
1385 DIE(aTHX_ "panic: pp_match start/end pointers");
1386 sv_setpvn(*SP, s, len);
1387 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1392 if (dynpm->op_pmflags & PMf_CONTINUE) {
1394 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1395 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1397 #ifdef PERL_OLD_COPY_ON_WRITE
1399 sv_force_normal_flags(TARG, 0);
1401 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1402 &PL_vtbl_mglob, NULL, 0);
1404 if (RX_OFFS(rx)[0].start != -1) {
1405 mg->mg_len = RX_OFFS(rx)[0].end;
1406 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1407 mg->mg_flags |= MGf_MINMATCH;
1409 mg->mg_flags &= ~MGf_MINMATCH;
1412 had_zerolen = (RX_OFFS(rx)[0].start != -1
1413 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1414 == (UV)RX_OFFS(rx)[0].end));
1415 PUTBACK; /* EVAL blocks may use stack */
1416 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1421 LEAVE_SCOPE(oldsave);
1427 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1428 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1432 #ifdef PERL_OLD_COPY_ON_WRITE
1434 sv_force_normal_flags(TARG, 0);
1436 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1437 &PL_vtbl_mglob, NULL, 0);
1439 if (RX_OFFS(rx)[0].start != -1) {
1440 mg->mg_len = RX_OFFS(rx)[0].end;
1441 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1442 mg->mg_flags |= MGf_MINMATCH;
1444 mg->mg_flags &= ~MGf_MINMATCH;
1447 LEAVE_SCOPE(oldsave);
1451 yup: /* Confirmed by INTUIT */
1453 RX_MATCH_TAINTED_on(rx);
1454 TAINT_IF(RX_MATCH_TAINTED(rx));
1456 if (dynpm->op_pmflags & PMf_ONCE) {
1458 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1460 dynpm->op_pmflags |= PMf_USED;
1463 if (RX_MATCH_COPIED(rx))
1464 Safefree(RX_SUBBEG(rx));
1465 RX_MATCH_COPIED_off(rx);
1466 RX_SUBBEG(rx) = NULL;
1468 /* FIXME - should rx->subbeg be const char *? */
1469 RX_SUBBEG(rx) = (char *) truebase;
1470 RX_OFFS(rx)[0].start = s - truebase;
1471 if (RX_MATCH_UTF8(rx)) {
1472 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1473 RX_OFFS(rx)[0].end = t - truebase;
1476 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1478 RX_SUBLEN(rx) = strend - truebase;
1481 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1483 #ifdef PERL_OLD_COPY_ON_WRITE
1484 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1486 PerlIO_printf(Perl_debug_log,
1487 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1488 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1491 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1493 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1494 assert (SvPOKp(RX_SAVED_COPY(rx)));
1499 RX_SUBBEG(rx) = savepvn(t, strend - t);
1500 #ifdef PERL_OLD_COPY_ON_WRITE
1501 RX_SAVED_COPY(rx) = NULL;
1504 RX_SUBLEN(rx) = strend - t;
1505 RX_MATCH_COPIED_on(rx);
1506 off = RX_OFFS(rx)[0].start = s - t;
1507 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1509 else { /* startp/endp are used by @- @+. */
1510 RX_OFFS(rx)[0].start = s - truebase;
1511 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1513 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1515 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1516 LEAVE_SCOPE(oldsave);
1521 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1522 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1523 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1528 LEAVE_SCOPE(oldsave);
1529 if (gimme == G_ARRAY)
1535 Perl_do_readline(pTHX)
1537 dVAR; dSP; dTARGETSTACKED;
1542 register IO * const io = GvIO(PL_last_in_gv);
1543 register const I32 type = PL_op->op_type;
1544 const I32 gimme = GIMME_V;
1547 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1550 XPUSHs(SvTIED_obj((SV*)io, mg));
1553 call_method("READLINE", gimme);
1556 if (gimme == G_SCALAR) {
1557 SV* const result = POPs;
1558 SvSetSV_nosteal(TARG, result);
1568 if (IoFLAGS(io) & IOf_ARGV) {
1569 if (IoFLAGS(io) & IOf_START) {
1571 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1572 IoFLAGS(io) &= ~IOf_START;
1573 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1574 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1575 SvSETMAGIC(GvSV(PL_last_in_gv));
1580 fp = nextargv(PL_last_in_gv);
1581 if (!fp) { /* Note: fp != IoIFP(io) */
1582 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1585 else if (type == OP_GLOB)
1586 fp = Perl_start_glob(aTHX_ POPs, io);
1588 else if (type == OP_GLOB)
1590 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1591 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1595 if ((!io || !(IoFLAGS(io) & IOf_START))
1596 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1598 if (type == OP_GLOB)
1599 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1600 "glob failed (can't start child: %s)",
1603 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1605 if (gimme == G_SCALAR) {
1606 /* undef TARG, and push that undefined value */
1607 if (type != OP_RCATLINE) {
1608 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1616 if (gimme == G_SCALAR) {
1618 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1621 if (type == OP_RCATLINE)
1622 SvPV_force_nolen(sv);
1626 else if (isGV_with_GP(sv)) {
1627 SvPV_force_nolen(sv);
1629 SvUPGRADE(sv, SVt_PV);
1630 tmplen = SvLEN(sv); /* remember if already alloced */
1631 if (!tmplen && !SvREADONLY(sv))
1632 Sv_Grow(sv, 80); /* try short-buffering it */
1634 if (type == OP_RCATLINE && SvOK(sv)) {
1636 SvPV_force_nolen(sv);
1642 sv = sv_2mortal(newSV(80));
1646 /* This should not be marked tainted if the fp is marked clean */
1647 #define MAYBE_TAINT_LINE(io, sv) \
1648 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1653 /* delay EOF state for a snarfed empty file */
1654 #define SNARF_EOF(gimme,rs,io,sv) \
1655 (gimme != G_SCALAR || SvCUR(sv) \
1656 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1660 if (!sv_gets(sv, fp, offset)
1662 || SNARF_EOF(gimme, PL_rs, io, sv)
1663 || PerlIO_error(fp)))
1665 PerlIO_clearerr(fp);
1666 if (IoFLAGS(io) & IOf_ARGV) {
1667 fp = nextargv(PL_last_in_gv);
1670 (void)do_close(PL_last_in_gv, FALSE);
1672 else if (type == OP_GLOB) {
1673 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1674 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1675 "glob failed (child exited with status %d%s)",
1676 (int)(STATUS_CURRENT >> 8),
1677 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1680 if (gimme == G_SCALAR) {
1681 if (type != OP_RCATLINE) {
1682 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1688 MAYBE_TAINT_LINE(io, sv);
1691 MAYBE_TAINT_LINE(io, sv);
1693 IoFLAGS(io) |= IOf_NOLINE;
1697 if (type == OP_GLOB) {
1700 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1701 char * const tmps = SvEND(sv) - 1;
1702 if (*tmps == *SvPVX_const(PL_rs)) {
1704 SvCUR_set(sv, SvCUR(sv) - 1);
1707 for (t1 = SvPVX_const(sv); *t1; t1++)
1708 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1709 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1711 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1712 (void)POPs; /* Unmatched wildcard? Chuck it... */
1715 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1716 if (ckWARN(WARN_UTF8)) {
1717 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1718 const STRLEN len = SvCUR(sv) - offset;
1721 if (!is_utf8_string_loc(s, len, &f))
1722 /* Emulate :encoding(utf8) warning in the same case. */
1723 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1724 "utf8 \"\\x%02X\" does not map to Unicode",
1725 f < (U8*)SvEND(sv) ? *f : 0);
1728 if (gimme == G_ARRAY) {
1729 if (SvLEN(sv) - SvCUR(sv) > 20) {
1730 SvPV_shrink_to_cur(sv);
1732 sv = sv_2mortal(newSV(80));
1735 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1736 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1737 const STRLEN new_len
1738 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1739 SvPV_renew(sv, new_len);
1748 register PERL_CONTEXT *cx;
1749 I32 gimme = OP_GIMME(PL_op, -1);
1752 if (cxstack_ix >= 0)
1753 gimme = cxstack[cxstack_ix].blk_gimme;
1761 PUSHBLOCK(cx, CXt_BLOCK, SP);
1771 SV * const keysv = POPs;
1772 HV * const hv = MUTABLE_HV(POPs);
1773 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1774 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1776 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1779 if (SvTYPE(hv) != SVt_PVHV)
1782 if (PL_op->op_private & OPpLVAL_INTRO) {
1785 /* does the element we're localizing already exist? */
1786 preeminent = /* can we determine whether it exists? */
1788 || mg_find((SV*)hv, PERL_MAGIC_env)
1789 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1790 /* Try to preserve the existenceness of a tied hash
1791 * element by using EXISTS and DELETE if possible.
1792 * Fallback to FETCH and STORE otherwise */
1793 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1794 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1795 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1797 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1799 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1800 svp = he ? &HeVAL(he) : NULL;
1802 if (!svp || *svp == &PL_sv_undef) {
1806 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1808 lv = sv_newmortal();
1809 sv_upgrade(lv, SVt_PVLV);
1811 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1812 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1813 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1818 if (PL_op->op_private & OPpLVAL_INTRO) {
1819 if (HvNAME_get(hv) && isGV(*svp))
1820 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1824 const char * const key = SvPV_const(keysv, keylen);
1825 SAVEDELETE(hv, savepvn(key,keylen),
1826 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1828 save_helem(hv, keysv, svp);
1831 else if (PL_op->op_private & OPpDEREF)
1832 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1834 sv = (svp ? *svp : &PL_sv_undef);
1835 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1836 * Pushing the magical RHS on to the stack is useless, since
1837 * that magic is soon destined to be misled by the local(),
1838 * and thus the later pp_sassign() will fail to mg_get() the
1839 * old value. This should also cure problems with delayed
1840 * mg_get()s. GSAR 98-07-03 */
1841 if (!lval && SvGMAGICAL(sv))
1842 sv = sv_mortalcopy(sv);
1850 register PERL_CONTEXT *cx;
1855 if (PL_op->op_flags & OPf_SPECIAL) {
1856 cx = &cxstack[cxstack_ix];
1857 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1862 gimme = OP_GIMME(PL_op, -1);
1864 if (cxstack_ix >= 0)
1865 gimme = cxstack[cxstack_ix].blk_gimme;
1871 if (gimme == G_VOID)
1873 else if (gimme == G_SCALAR) {
1877 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1880 *MARK = sv_mortalcopy(TOPs);
1883 *MARK = &PL_sv_undef;
1887 else if (gimme == G_ARRAY) {
1888 /* in case LEAVE wipes old return values */
1890 for (mark = newsp + 1; mark <= SP; mark++) {
1891 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1892 *mark = sv_mortalcopy(*mark);
1893 TAINT_NOT; /* Each item is independent */
1897 PL_curpm = newpm; /* Don't pop $1 et al till now */
1907 register PERL_CONTEXT *cx;
1910 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1911 bool av_is_stack = FALSE;
1914 cx = &cxstack[cxstack_ix];
1915 if (!CxTYPE_is_LOOP(cx))
1916 DIE(aTHX_ "panic: pp_iter");
1918 itersvp = CxITERVAR(cx);
1919 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1920 /* string increment */
1921 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1922 SV *end = cx->blk_loop.state_u.lazysv.end;
1923 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1924 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1926 const char *max = SvPV_const(end, maxlen);
1927 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1928 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1929 /* safe to reuse old SV */
1930 sv_setsv(*itersvp, cur);
1934 /* we need a fresh SV every time so that loop body sees a
1935 * completely new SV for closures/references to work as
1938 *itersvp = newSVsv(cur);
1939 SvREFCNT_dec(oldsv);
1941 if (strEQ(SvPVX_const(cur), max))
1942 sv_setiv(cur, 0); /* terminate next time */
1949 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1950 /* integer increment */
1951 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1954 /* don't risk potential race */
1955 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1956 /* safe to reuse old SV */
1957 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1961 /* we need a fresh SV every time so that loop body sees a
1962 * completely new SV for closures/references to work as they
1965 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1966 SvREFCNT_dec(oldsv);
1969 /* Handle end of range at IV_MAX */
1970 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1971 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1973 cx->blk_loop.state_u.lazyiv.cur++;
1974 cx->blk_loop.state_u.lazyiv.end++;
1981 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1982 av = cx->blk_loop.state_u.ary.ary;
1987 if (PL_op->op_private & OPpITER_REVERSED) {
1988 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1989 ? cx->blk_loop.resetsp + 1 : 0))
1992 if (SvMAGICAL(av) || AvREIFY(av)) {
1993 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1994 sv = svp ? *svp : NULL;
1997 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2001 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2005 if (SvMAGICAL(av) || AvREIFY(av)) {
2006 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2007 sv = svp ? *svp : NULL;
2010 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2014 if (sv && SvIS_FREED(sv)) {
2016 Perl_croak(aTHX_ "Use of freed value in iteration");
2021 SvREFCNT_inc_simple_void_NN(sv);
2025 if (!av_is_stack && sv == &PL_sv_undef) {
2026 SV *lv = newSV_type(SVt_PVLV);
2028 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2029 LvTARG(lv) = SvREFCNT_inc_simple(av);
2030 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2031 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2037 SvREFCNT_dec(oldsv);
2045 register PMOP *pm = cPMOP;
2060 register REGEXP *rx = PM_GETRE(pm);
2062 int force_on_match = 0;
2063 const I32 oldsave = PL_savestack_ix;
2065 bool doutf8 = FALSE;
2067 #ifdef PERL_OLD_COPY_ON_WRITE
2072 /* known replacement string? */
2073 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2074 if (PL_op->op_flags & OPf_STACKED)
2076 else if (PL_op->op_private & OPpTARGET_MY)
2083 #ifdef PERL_OLD_COPY_ON_WRITE
2084 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2085 because they make integers such as 256 "false". */
2086 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2089 sv_force_normal_flags(TARG,0);
2092 #ifdef PERL_OLD_COPY_ON_WRITE
2096 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2097 || SvTYPE(TARG) > SVt_PVLV)
2098 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2099 DIE(aTHX_ PL_no_modify);
2102 s = SvPV_mutable(TARG, len);
2103 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2105 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2106 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2111 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2115 DIE(aTHX_ "panic: pp_subst");
2118 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2119 maxiters = 2 * slen + 10; /* We can match twice at each
2120 position, once with zero-length,
2121 second time with non-zero. */
2123 if (!RX_PRELEN(rx) && PL_curpm) {
2127 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2128 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2129 ? REXEC_COPY_STR : 0;
2131 r_flags |= REXEC_SCREAM;
2134 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2136 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2140 /* How to do it in subst? */
2141 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2143 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2144 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2145 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2146 && (r_flags & REXEC_SCREAM))))
2151 /* only replace once? */
2152 once = !(rpm->op_pmflags & PMf_GLOBAL);
2153 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2154 r_flags | REXEC_CHECKED);
2155 /* known replacement string? */
2157 /* replacement needing upgrading? */
2158 if (DO_UTF8(TARG) && !doutf8) {
2159 nsv = sv_newmortal();
2162 sv_recode_to_utf8(nsv, PL_encoding);
2164 sv_utf8_upgrade(nsv);
2165 c = SvPV_const(nsv, clen);
2169 c = SvPV_const(dstr, clen);
2170 doutf8 = DO_UTF8(dstr);
2178 /* can do inplace substitution? */
2180 #ifdef PERL_OLD_COPY_ON_WRITE
2183 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2184 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2185 && (!doutf8 || SvUTF8(TARG))) {
2190 LEAVE_SCOPE(oldsave);
2193 #ifdef PERL_OLD_COPY_ON_WRITE
2194 if (SvIsCOW(TARG)) {
2195 assert (!force_on_match);
2199 if (force_on_match) {
2201 s = SvPV_force(TARG, len);
2206 SvSCREAM_off(TARG); /* disable possible screamer */
2208 rxtainted |= RX_MATCH_TAINTED(rx);
2209 m = orig + RX_OFFS(rx)[0].start;
2210 d = orig + RX_OFFS(rx)[0].end;
2212 if (m - s > strend - d) { /* faster to shorten from end */
2214 Copy(c, m, clen, char);
2219 Move(d, m, i, char);
2223 SvCUR_set(TARG, m - s);
2225 else if ((i = m - s)) { /* faster from front */
2228 Move(s, d - i, i, char);
2231 Copy(c, m, clen, char);
2236 Copy(c, d, clen, char);
2241 TAINT_IF(rxtainted & 1);
2247 if (iters++ > maxiters)
2248 DIE(aTHX_ "Substitution loop");
2249 rxtainted |= RX_MATCH_TAINTED(rx);
2250 m = RX_OFFS(rx)[0].start + orig;
2253 Move(s, d, i, char);
2257 Copy(c, d, clen, char);
2260 s = RX_OFFS(rx)[0].end + orig;
2261 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2263 /* don't match same null twice */
2264 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2267 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2268 Move(s, d, i+1, char); /* include the NUL */
2270 TAINT_IF(rxtainted & 1);
2274 (void)SvPOK_only_UTF8(TARG);
2275 TAINT_IF(rxtainted);
2276 if (SvSMAGICAL(TARG)) {
2284 LEAVE_SCOPE(oldsave);
2290 if (force_on_match) {
2292 s = SvPV_force(TARG, len);
2295 #ifdef PERL_OLD_COPY_ON_WRITE
2298 rxtainted |= RX_MATCH_TAINTED(rx);
2299 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2303 register PERL_CONTEXT *cx;
2306 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2308 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2310 if (iters++ > maxiters)
2311 DIE(aTHX_ "Substitution loop");
2312 rxtainted |= RX_MATCH_TAINTED(rx);
2313 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2316 orig = RX_SUBBEG(rx);
2318 strend = s + (strend - m);
2320 m = RX_OFFS(rx)[0].start + orig;
2321 if (doutf8 && !SvUTF8(dstr))
2322 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2324 sv_catpvn(dstr, s, m-s);
2325 s = RX_OFFS(rx)[0].end + orig;
2327 sv_catpvn(dstr, c, clen);
2330 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2331 TARG, NULL, r_flags));
2332 if (doutf8 && !DO_UTF8(TARG))
2333 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2335 sv_catpvn(dstr, s, strend - s);
2337 #ifdef PERL_OLD_COPY_ON_WRITE
2338 /* The match may make the string COW. If so, brilliant, because that's
2339 just saved us one malloc, copy and free - the regexp has donated
2340 the old buffer, and we malloc an entirely new one, rather than the
2341 regexp malloc()ing a buffer and copying our original, only for
2342 us to throw it away here during the substitution. */
2343 if (SvIsCOW(TARG)) {
2344 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2350 SvPV_set(TARG, SvPVX(dstr));
2351 SvCUR_set(TARG, SvCUR(dstr));
2352 SvLEN_set(TARG, SvLEN(dstr));
2353 doutf8 |= DO_UTF8(dstr);
2354 SvPV_set(dstr, NULL);
2356 TAINT_IF(rxtainted & 1);
2360 (void)SvPOK_only(TARG);
2363 TAINT_IF(rxtainted);
2366 LEAVE_SCOPE(oldsave);
2375 LEAVE_SCOPE(oldsave);
2384 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2385 ++*PL_markstack_ptr;
2386 LEAVE; /* exit inner scope */
2389 if (PL_stack_base + *PL_markstack_ptr > SP) {
2391 const I32 gimme = GIMME_V;
2393 LEAVE; /* exit outer scope */
2394 (void)POPMARK; /* pop src */
2395 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2396 (void)POPMARK; /* pop dst */
2397 SP = PL_stack_base + POPMARK; /* pop original mark */
2398 if (gimme == G_SCALAR) {
2399 if (PL_op->op_private & OPpGREP_LEX) {
2400 SV* const sv = sv_newmortal();
2401 sv_setiv(sv, items);
2409 else if (gimme == G_ARRAY)
2416 ENTER; /* enter inner scope */
2419 src = PL_stack_base[*PL_markstack_ptr];
2421 if (PL_op->op_private & OPpGREP_LEX)
2422 PAD_SVl(PL_op->op_targ) = src;
2426 RETURNOP(cLOGOP->op_other);
2437 register PERL_CONTEXT *cx;
2440 if (CxMULTICALL(&cxstack[cxstack_ix]))
2444 cxstack_ix++; /* temporarily protect top context */
2447 if (gimme == G_SCALAR) {
2450 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2452 *MARK = SvREFCNT_inc(TOPs);
2457 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2459 *MARK = sv_mortalcopy(sv);
2464 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2468 *MARK = &PL_sv_undef;
2472 else if (gimme == G_ARRAY) {
2473 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2474 if (!SvTEMP(*MARK)) {
2475 *MARK = sv_mortalcopy(*MARK);
2476 TAINT_NOT; /* Each item is independent */
2484 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2485 PL_curpm = newpm; /* ... and pop $1 et al */
2488 return cx->blk_sub.retop;
2491 /* This duplicates the above code because the above code must not
2492 * get any slower by more conditions */
2500 register PERL_CONTEXT *cx;
2503 if (CxMULTICALL(&cxstack[cxstack_ix]))
2507 cxstack_ix++; /* temporarily protect top context */
2511 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2512 /* We are an argument to a function or grep().
2513 * This kind of lvalueness was legal before lvalue
2514 * subroutines too, so be backward compatible:
2515 * cannot report errors. */
2517 /* Scalar context *is* possible, on the LHS of -> only,
2518 * as in f()->meth(). But this is not an lvalue. */
2519 if (gimme == G_SCALAR)
2521 if (gimme == G_ARRAY) {
2522 if (!CvLVALUE(cx->blk_sub.cv))
2523 goto temporise_array;
2524 EXTEND_MORTAL(SP - newsp);
2525 for (mark = newsp + 1; mark <= SP; mark++) {
2528 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2529 *mark = sv_mortalcopy(*mark);
2531 /* Can be a localized value subject to deletion. */
2532 PL_tmps_stack[++PL_tmps_ix] = *mark;
2533 SvREFCNT_inc_void(*mark);
2538 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2539 /* Here we go for robustness, not for speed, so we change all
2540 * the refcounts so the caller gets a live guy. Cannot set
2541 * TEMP, so sv_2mortal is out of question. */
2542 if (!CvLVALUE(cx->blk_sub.cv)) {
2548 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2550 if (gimme == G_SCALAR) {
2554 /* Temporaries are bad unless they happen to be elements
2555 * of a tied hash or array */
2556 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2557 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2563 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2564 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2565 : "a readonly value" : "a temporary");
2567 else { /* Can be a localized value
2568 * subject to deletion. */
2569 PL_tmps_stack[++PL_tmps_ix] = *mark;
2570 SvREFCNT_inc_void(*mark);
2573 else { /* Should not happen? */
2579 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2580 (MARK > SP ? "Empty array" : "Array"));
2584 else if (gimme == G_ARRAY) {
2585 EXTEND_MORTAL(SP - newsp);
2586 for (mark = newsp + 1; mark <= SP; mark++) {
2587 if (*mark != &PL_sv_undef
2588 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2589 /* Might be flattened array after $#array = */
2596 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2597 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2600 /* Can be a localized value subject to deletion. */
2601 PL_tmps_stack[++PL_tmps_ix] = *mark;
2602 SvREFCNT_inc_void(*mark);
2608 if (gimme == G_SCALAR) {
2612 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2614 *MARK = SvREFCNT_inc(TOPs);
2619 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2621 *MARK = sv_mortalcopy(sv);
2626 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2630 *MARK = &PL_sv_undef;
2634 else if (gimme == G_ARRAY) {
2636 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2637 if (!SvTEMP(*MARK)) {
2638 *MARK = sv_mortalcopy(*MARK);
2639 TAINT_NOT; /* Each item is independent */
2648 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2649 PL_curpm = newpm; /* ... and pop $1 et al */
2652 return cx->blk_sub.retop;
2660 register PERL_CONTEXT *cx;
2662 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2665 DIE(aTHX_ "Not a CODE reference");
2666 switch (SvTYPE(sv)) {
2667 /* This is overwhelming the most common case: */
2669 if (!isGV_with_GP(sv))
2670 DIE(aTHX_ "Not a CODE reference");
2671 if (!(cv = GvCVu((GV*)sv))) {
2673 cv = sv_2cv(sv, &stash, &gv, 0);
2685 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2687 SP = PL_stack_base + POPMARK;
2690 if (SvGMAGICAL(sv)) {
2695 sym = SvPVX_const(sv);
2703 sym = SvPV_const(sv, len);
2706 DIE(aTHX_ PL_no_usym, "a subroutine");
2707 if (PL_op->op_private & HINT_STRICT_REFS)
2708 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2709 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2714 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2715 tryAMAGICunDEREF(to_cv);
2717 cv = MUTABLE_CV(SvRV(sv));
2718 if (SvTYPE(cv) == SVt_PVCV)
2723 DIE(aTHX_ "Not a CODE reference");
2724 /* This is the second most common case: */
2726 cv = MUTABLE_CV(sv);
2734 if (!CvROOT(cv) && !CvXSUB(cv)) {
2738 /* anonymous or undef'd function leaves us no recourse */
2739 if (CvANON(cv) || !(gv = CvGV(cv)))
2740 DIE(aTHX_ "Undefined subroutine called");
2742 /* autoloaded stub? */
2743 if (cv != GvCV(gv)) {
2746 /* should call AUTOLOAD now? */
2749 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2756 sub_name = sv_newmortal();
2757 gv_efullname3(sub_name, gv, NULL);
2758 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2762 DIE(aTHX_ "Not a CODE reference");
2767 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2768 Perl_get_db_sub(aTHX_ &sv, cv);
2770 PL_curcopdb = PL_curcop;
2771 cv = GvCV(PL_DBsub);
2773 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2774 DIE(aTHX_ "No DB::sub routine defined");
2777 if (!(CvISXSUB(cv))) {
2778 /* This path taken at least 75% of the time */
2780 register I32 items = SP - MARK;
2781 AV* const padlist = CvPADLIST(cv);
2782 PUSHBLOCK(cx, CXt_SUB, MARK);
2784 cx->blk_sub.retop = PL_op->op_next;
2786 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2787 * that eval'' ops within this sub know the correct lexical space.
2788 * Owing the speed considerations, we choose instead to search for
2789 * the cv using find_runcv() when calling doeval().
2791 if (CvDEPTH(cv) >= 2) {
2792 PERL_STACK_OVERFLOW_CHECK();
2793 pad_push(padlist, CvDEPTH(cv));
2796 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2798 AV* const av = (AV*)PAD_SVl(0);
2800 /* @_ is normally not REAL--this should only ever
2801 * happen when DB::sub() calls things that modify @_ */
2806 cx->blk_sub.savearray = GvAV(PL_defgv);
2807 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2808 CX_CURPAD_SAVE(cx->blk_sub);
2809 cx->blk_sub.argarray = av;
2812 if (items > AvMAX(av) + 1) {
2813 SV **ary = AvALLOC(av);
2814 if (AvARRAY(av) != ary) {
2815 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2818 if (items > AvMAX(av) + 1) {
2819 AvMAX(av) = items - 1;
2820 Renew(ary,items,SV*);
2825 Copy(MARK,AvARRAY(av),items,SV*);
2826 AvFILLp(av) = items - 1;
2834 /* warning must come *after* we fully set up the context
2835 * stuff so that __WARN__ handlers can safely dounwind()
2838 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2839 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2840 sub_crush_depth(cv);
2841 RETURNOP(CvSTART(cv));
2844 I32 markix = TOPMARK;
2849 /* Need to copy @_ to stack. Alternative may be to
2850 * switch stack to @_, and copy return values
2851 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2852 AV * const av = GvAV(PL_defgv);
2853 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2856 /* Mark is at the end of the stack. */
2858 Copy(AvARRAY(av), SP + 1, items, SV*);
2863 /* We assume first XSUB in &DB::sub is the called one. */
2865 SAVEVPTR(PL_curcop);
2866 PL_curcop = PL_curcopdb;
2869 /* Do we need to open block here? XXXX */
2870 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2871 (void)(*CvXSUB(cv))(aTHX_ cv);
2873 /* Enforce some sanity in scalar context. */
2874 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2875 if (markix > PL_stack_sp - PL_stack_base)
2876 *(PL_stack_base + markix) = &PL_sv_undef;
2878 *(PL_stack_base + markix) = *PL_stack_sp;
2879 PL_stack_sp = PL_stack_base + markix;
2887 Perl_sub_crush_depth(pTHX_ CV *cv)
2889 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2892 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2894 SV* const tmpstr = sv_newmortal();
2895 gv_efullname3(tmpstr, CvGV(cv), NULL);
2896 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2905 SV* const elemsv = POPs;
2906 IV elem = SvIV(elemsv);
2907 AV* const av = (AV*)POPs;
2908 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2909 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2912 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2913 Perl_warner(aTHX_ packWARN(WARN_MISC),
2914 "Use of reference \"%"SVf"\" as array index",
2917 elem -= CopARYBASE_get(PL_curcop);
2918 if (SvTYPE(av) != SVt_PVAV)
2920 svp = av_fetch(av, elem, lval && !defer);
2922 #ifdef PERL_MALLOC_WRAP
2923 if (SvUOK(elemsv)) {
2924 const UV uv = SvUV(elemsv);
2925 elem = uv > IV_MAX ? IV_MAX : uv;
2927 else if (SvNOK(elemsv))
2928 elem = (IV)SvNV(elemsv);
2930 static const char oom_array_extend[] =
2931 "Out of memory during array extend"; /* Duplicated in av.c */
2932 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2935 if (!svp || *svp == &PL_sv_undef) {
2938 DIE(aTHX_ PL_no_aelem, elem);
2939 lv = sv_newmortal();
2940 sv_upgrade(lv, SVt_PVLV);
2942 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2943 LvTARG(lv) = SvREFCNT_inc_simple(av);
2944 LvTARGOFF(lv) = elem;
2949 if (PL_op->op_private & OPpLVAL_INTRO)
2950 save_aelem(av, elem, svp);
2951 else if (PL_op->op_private & OPpDEREF)
2952 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2954 sv = (svp ? *svp : &PL_sv_undef);
2955 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2956 sv = sv_mortalcopy(sv);
2962 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2964 PERL_ARGS_ASSERT_VIVIFY_REF;
2969 Perl_croak(aTHX_ PL_no_modify);
2970 prepare_SV_for_RV(sv);
2973 SvRV_set(sv, newSV(0));
2976 SvRV_set(sv, (SV*)newAV());
2979 SvRV_set(sv, (SV*)newHV());
2990 SV* const sv = TOPs;
2993 SV* const rsv = SvRV(sv);
2994 if (SvTYPE(rsv) == SVt_PVCV) {
3000 SETs(method_common(sv, NULL));
3007 SV* const sv = cSVOP_sv;
3008 U32 hash = SvSHARED_HASH(sv);
3010 XPUSHs(method_common(sv, &hash));
3015 S_method_common(pTHX_ SV* meth, U32* hashp)
3022 const char* packname = NULL;
3025 const char * const name = SvPV_const(meth, namelen);
3026 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3028 PERL_ARGS_ASSERT_METHOD_COMMON;
3031 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3039 /* this isn't a reference */
3040 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3041 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3043 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3050 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3051 !(ob=(SV*)GvIO(iogv)))
3053 /* this isn't the name of a filehandle either */
3055 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3056 ? !isIDFIRST_utf8((U8*)packname)
3057 : !isIDFIRST(*packname)
3060 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3061 SvOK(sv) ? "without a package or object reference"
3062 : "on an undefined value");
3064 /* assume it's a package name */
3065 stash = gv_stashpvn(packname, packlen, 0);
3069 SV* const ref = newSViv(PTR2IV(stash));
3070 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3074 /* it _is_ a filehandle name -- replace with a reference */
3075 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3078 /* if we got here, ob should be a reference or a glob */
3079 if (!ob || !(SvOBJECT(ob)
3080 || (SvTYPE(ob) == SVt_PVGV
3082 && (ob = (SV*)GvIO((GV*)ob))
3085 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3086 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3090 stash = SvSTASH(ob);
3093 /* NOTE: stash may be null, hope hv_fetch_ent and
3094 gv_fetchmethod can cope (it seems they can) */
3096 /* shortcut for simple names */
3098 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3100 gv = (GV*)HeVAL(he);
3101 if (isGV(gv) && GvCV(gv) &&
3102 (!GvCVGEN(gv) || GvCVGEN(gv)
3103 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3104 return (SV*)GvCV(gv);
3108 gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
3109 GV_AUTOLOAD | GV_CROAK);
3113 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3118 * c-indentation-style: bsd
3120 * indent-tabs-mode: t
3123 * ex: set ts=8 sts=4 sw=4 noet: