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 return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
805 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
806 static const char an_array[] = "an ARRAY";
807 static const char a_hash[] = "a HASH";
808 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
809 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
813 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
816 if (SvTYPE(sv) != type)
817 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
818 if (PL_op->op_flags & OPf_REF) {
823 if (gimme != G_ARRAY)
824 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
825 : return_hash_to_lvalue_scalar);
829 else if (PL_op->op_flags & OPf_MOD
830 && PL_op->op_private & OPpLVAL_INTRO)
831 Perl_croak(aTHX_ PL_no_localize_ref);
834 if (SvTYPE(sv) == type) {
835 if (PL_op->op_flags & OPf_REF) {
840 if (gimme != G_ARRAY)
842 is_pp_rv2av ? return_array_to_lvalue_scalar
843 : return_hash_to_lvalue_scalar);
851 if (SvTYPE(sv) != SVt_PVGV) {
852 if (SvGMAGICAL(sv)) {
857 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
865 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
866 if (PL_op->op_private & OPpLVAL_INTRO)
867 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
868 if (PL_op->op_flags & OPf_REF) {
873 if (gimme != G_ARRAY)
875 is_pp_rv2av ? return_array_to_lvalue_scalar
876 : return_hash_to_lvalue_scalar);
884 AV *const av = (AV*)sv;
885 /* The guts of pp_rv2av, with no intenting change to preserve history
886 (until such time as we get tools that can do blame annotation across
887 whitespace changes. */
888 if (gimme == G_ARRAY) {
889 const I32 maxarg = AvFILL(av) + 1;
890 (void)POPs; /* XXXX May be optimized away? */
892 if (SvRMAGICAL(av)) {
894 for (i=0; i < (U32)maxarg; i++) {
895 SV ** const svp = av_fetch(av, i, FALSE);
896 /* See note in pp_helem, and bug id #27839 */
898 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
903 Copy(AvARRAY(av), SP+1, maxarg, SV*);
907 else if (gimme == G_SCALAR) {
909 const I32 maxarg = AvFILL(av) + 1;
913 /* The guts of pp_rv2hv */
914 if (gimme == G_ARRAY) { /* array wanted */
918 else if (gimme == G_SCALAR) {
920 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
929 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
933 PERL_ARGS_ASSERT_DO_ODDBALL;
939 if (ckWARN(WARN_MISC)) {
941 if (relem == firstrelem &&
943 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
944 SvTYPE(SvRV(*relem)) == SVt_PVHV))
946 err = "Reference found where even-sized list expected";
949 err = "Odd number of elements in hash assignment";
950 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
954 didstore = hv_store_ent(hash,*relem,tmpstr,0);
955 if (SvMAGICAL(hash)) {
956 if (SvSMAGICAL(tmpstr))
968 SV **lastlelem = PL_stack_sp;
969 SV **lastrelem = PL_stack_base + POPMARK;
970 SV **firstrelem = PL_stack_base + POPMARK + 1;
971 SV **firstlelem = lastrelem + 1;
984 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
986 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
989 /* If there's a common identifier on both sides we have to take
990 * special care that assigning the identifier on the left doesn't
991 * clobber a value on the right that's used later in the list.
993 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
994 EXTEND_MORTAL(lastrelem - firstrelem + 1);
995 for (relem = firstrelem; relem <= lastrelem; relem++) {
997 TAINT_NOT; /* Each item is independent */
998 *relem = sv_mortalcopy(sv);
1008 while (lelem <= lastlelem) {
1009 TAINT_NOT; /* Each item stands on its own, taintwise. */
1011 switch (SvTYPE(sv)) {
1014 magic = SvMAGICAL(ary) != 0;
1016 av_extend(ary, lastrelem - relem);
1018 while (relem <= lastrelem) { /* gobble up all the rest */
1021 sv = newSVsv(*relem);
1023 didstore = av_store(ary,i++,sv);
1032 if (PL_delaymagic & DM_ARRAY)
1033 SvSETMAGIC((SV*)ary);
1035 case SVt_PVHV: { /* normal hash */
1039 magic = SvMAGICAL(hash) != 0;
1041 firsthashrelem = relem;
1043 while (relem < lastrelem) { /* gobble up all the rest */
1045 sv = *relem ? *relem : &PL_sv_no;
1049 sv_setsv(tmpstr,*relem); /* value */
1050 *(relem++) = tmpstr;
1051 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1052 /* key overwrites an existing entry */
1054 didstore = hv_store_ent(hash,sv,tmpstr,0);
1056 if (SvSMAGICAL(tmpstr))
1063 if (relem == lastrelem) {
1064 do_oddball(hash, relem, firstrelem);
1070 if (SvIMMORTAL(sv)) {
1071 if (relem <= lastrelem)
1075 if (relem <= lastrelem) {
1076 sv_setsv(sv, *relem);
1080 sv_setsv(sv, &PL_sv_undef);
1085 if (PL_delaymagic & ~DM_DELAY) {
1086 if (PL_delaymagic & DM_UID) {
1087 #ifdef HAS_SETRESUID
1088 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1089 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1092 # ifdef HAS_SETREUID
1093 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1094 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1097 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1098 (void)setruid(PL_uid);
1099 PL_delaymagic &= ~DM_RUID;
1101 # endif /* HAS_SETRUID */
1103 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1104 (void)seteuid(PL_euid);
1105 PL_delaymagic &= ~DM_EUID;
1107 # endif /* HAS_SETEUID */
1108 if (PL_delaymagic & DM_UID) {
1109 if (PL_uid != PL_euid)
1110 DIE(aTHX_ "No setreuid available");
1111 (void)PerlProc_setuid(PL_uid);
1113 # endif /* HAS_SETREUID */
1114 #endif /* HAS_SETRESUID */
1115 PL_uid = PerlProc_getuid();
1116 PL_euid = PerlProc_geteuid();
1118 if (PL_delaymagic & DM_GID) {
1119 #ifdef HAS_SETRESGID
1120 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1121 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1124 # ifdef HAS_SETREGID
1125 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1126 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1129 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1130 (void)setrgid(PL_gid);
1131 PL_delaymagic &= ~DM_RGID;
1133 # endif /* HAS_SETRGID */
1135 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1136 (void)setegid(PL_egid);
1137 PL_delaymagic &= ~DM_EGID;
1139 # endif /* HAS_SETEGID */
1140 if (PL_delaymagic & DM_GID) {
1141 if (PL_gid != PL_egid)
1142 DIE(aTHX_ "No setregid available");
1143 (void)PerlProc_setgid(PL_gid);
1145 # endif /* HAS_SETREGID */
1146 #endif /* HAS_SETRESGID */
1147 PL_gid = PerlProc_getgid();
1148 PL_egid = PerlProc_getegid();
1150 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1154 if (gimme == G_VOID)
1155 SP = firstrelem - 1;
1156 else if (gimme == G_SCALAR) {
1159 SETi(lastrelem - firstrelem + 1 - duplicates);
1166 /* Removes from the stack the entries which ended up as
1167 * duplicated keys in the hash (fix for [perl #24380]) */
1168 Move(firsthashrelem + duplicates,
1169 firsthashrelem, duplicates, SV**);
1170 lastrelem -= duplicates;
1175 SP = firstrelem + (lastlelem - firstlelem);
1176 lelem = firstlelem + (relem - firstrelem);
1178 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1187 register PMOP * const pm = cPMOP;
1188 REGEXP * rx = PM_GETRE(pm);
1189 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1190 SV * const rv = sv_newmortal();
1192 SvUPGRADE(rv, SVt_IV);
1193 /* This RV is about to own a reference to the regexp. (In addition to the
1194 reference already owned by the PMOP. */
1196 SvRV_set(rv, (SV*) rx);
1200 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1201 (void)sv_bless(rv, stash);
1204 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1213 register PMOP *pm = cPMOP;
1215 register const char *t;
1216 register const char *s;
1219 U8 r_flags = REXEC_CHECKED;
1220 const char *truebase; /* Start of string */
1221 register REGEXP *rx = PM_GETRE(pm);
1223 const I32 gimme = GIMME;
1226 const I32 oldsave = PL_savestack_ix;
1227 I32 update_minmatch = 1;
1228 I32 had_zerolen = 0;
1231 if (PL_op->op_flags & OPf_STACKED)
1233 else if (PL_op->op_private & OPpTARGET_MY)
1240 PUTBACK; /* EVAL blocks need stack_sp. */
1241 s = SvPV_const(TARG, len);
1243 DIE(aTHX_ "panic: pp_match");
1245 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1246 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1249 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1251 /* PMdf_USED is set after a ?? matches once */
1254 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1256 pm->op_pmflags & PMf_USED
1260 if (gimme == G_ARRAY)
1267 /* empty pattern special-cased to use last successful pattern if possible */
1268 if (!RX_PRELEN(rx) && PL_curpm) {
1273 if (RX_MINLEN(rx) > (I32)len)
1278 /* XXXX What part of this is needed with true \G-support? */
1279 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1280 RX_OFFS(rx)[0].start = -1;
1281 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1282 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1283 if (mg && mg->mg_len >= 0) {
1284 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1285 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1286 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1287 r_flags |= REXEC_IGNOREPOS;
1288 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1289 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1292 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1293 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1294 update_minmatch = 0;
1298 /* XXX: comment out !global get safe $1 vars after a
1299 match, BUT be aware that this leads to dramatic slowdowns on
1300 /g matches against large strings. So far a solution to this problem
1301 appears to be quite tricky.
1302 Test for the unsafe vars are TODO for now. */
1303 if (( !global && RX_NPARENS(rx))
1304 || SvTEMP(TARG) || PL_sawampersand ||
1305 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1306 r_flags |= REXEC_COPY_STR;
1308 r_flags |= REXEC_SCREAM;
1311 if (global && RX_OFFS(rx)[0].start != -1) {
1312 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1313 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1315 if (update_minmatch++)
1316 minmatch = had_zerolen;
1318 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1319 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1320 /* FIXME - can PL_bostr be made const char *? */
1321 PL_bostr = (char *)truebase;
1322 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1326 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1328 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1329 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1330 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1331 && (r_flags & REXEC_SCREAM)))
1332 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1335 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1336 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1339 if (dynpm->op_pmflags & PMf_ONCE) {
1341 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1343 dynpm->op_pmflags |= PMf_USED;
1354 RX_MATCH_TAINTED_on(rx);
1355 TAINT_IF(RX_MATCH_TAINTED(rx));
1356 if (gimme == G_ARRAY) {
1357 const I32 nparens = RX_NPARENS(rx);
1358 I32 i = (global && !nparens) ? 1 : 0;
1360 SPAGAIN; /* EVAL blocks could move the stack. */
1361 EXTEND(SP, nparens + i);
1362 EXTEND_MORTAL(nparens + i);
1363 for (i = !i; i <= nparens; i++) {
1364 PUSHs(sv_newmortal());
1365 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1366 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1367 s = RX_OFFS(rx)[i].start + truebase;
1368 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1369 len < 0 || len > strend - s)
1370 DIE(aTHX_ "panic: pp_match start/end pointers");
1371 sv_setpvn(*SP, s, len);
1372 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1377 if (dynpm->op_pmflags & PMf_CONTINUE) {
1379 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1380 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1382 #ifdef PERL_OLD_COPY_ON_WRITE
1384 sv_force_normal_flags(TARG, 0);
1386 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1387 &PL_vtbl_mglob, NULL, 0);
1389 if (RX_OFFS(rx)[0].start != -1) {
1390 mg->mg_len = RX_OFFS(rx)[0].end;
1391 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1392 mg->mg_flags |= MGf_MINMATCH;
1394 mg->mg_flags &= ~MGf_MINMATCH;
1397 had_zerolen = (RX_OFFS(rx)[0].start != -1
1398 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1399 == (UV)RX_OFFS(rx)[0].end));
1400 PUTBACK; /* EVAL blocks may use stack */
1401 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1406 LEAVE_SCOPE(oldsave);
1412 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1413 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1417 #ifdef PERL_OLD_COPY_ON_WRITE
1419 sv_force_normal_flags(TARG, 0);
1421 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1422 &PL_vtbl_mglob, NULL, 0);
1424 if (RX_OFFS(rx)[0].start != -1) {
1425 mg->mg_len = RX_OFFS(rx)[0].end;
1426 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1427 mg->mg_flags |= MGf_MINMATCH;
1429 mg->mg_flags &= ~MGf_MINMATCH;
1432 LEAVE_SCOPE(oldsave);
1436 yup: /* Confirmed by INTUIT */
1438 RX_MATCH_TAINTED_on(rx);
1439 TAINT_IF(RX_MATCH_TAINTED(rx));
1441 if (dynpm->op_pmflags & PMf_ONCE) {
1443 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1445 dynpm->op_pmflags |= PMf_USED;
1448 if (RX_MATCH_COPIED(rx))
1449 Safefree(RX_SUBBEG(rx));
1450 RX_MATCH_COPIED_off(rx);
1451 RX_SUBBEG(rx) = NULL;
1453 /* FIXME - should rx->subbeg be const char *? */
1454 RX_SUBBEG(rx) = (char *) truebase;
1455 RX_OFFS(rx)[0].start = s - truebase;
1456 if (RX_MATCH_UTF8(rx)) {
1457 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1458 RX_OFFS(rx)[0].end = t - truebase;
1461 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1463 RX_SUBLEN(rx) = strend - truebase;
1466 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1468 #ifdef PERL_OLD_COPY_ON_WRITE
1469 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1471 PerlIO_printf(Perl_debug_log,
1472 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1473 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1476 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1478 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1479 assert (SvPOKp(RX_SAVED_COPY(rx)));
1484 RX_SUBBEG(rx) = savepvn(t, strend - t);
1485 #ifdef PERL_OLD_COPY_ON_WRITE
1486 RX_SAVED_COPY(rx) = NULL;
1489 RX_SUBLEN(rx) = strend - t;
1490 RX_MATCH_COPIED_on(rx);
1491 off = RX_OFFS(rx)[0].start = s - t;
1492 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1494 else { /* startp/endp are used by @- @+. */
1495 RX_OFFS(rx)[0].start = s - truebase;
1496 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1498 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1500 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1501 LEAVE_SCOPE(oldsave);
1506 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1507 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1508 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1513 LEAVE_SCOPE(oldsave);
1514 if (gimme == G_ARRAY)
1520 Perl_do_readline(pTHX)
1522 dVAR; dSP; dTARGETSTACKED;
1527 register IO * const io = GvIO(PL_last_in_gv);
1528 register const I32 type = PL_op->op_type;
1529 const I32 gimme = GIMME_V;
1532 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1535 XPUSHs(SvTIED_obj((SV*)io, mg));
1538 call_method("READLINE", gimme);
1541 if (gimme == G_SCALAR) {
1542 SV* const result = POPs;
1543 SvSetSV_nosteal(TARG, result);
1553 if (IoFLAGS(io) & IOf_ARGV) {
1554 if (IoFLAGS(io) & IOf_START) {
1556 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1557 IoFLAGS(io) &= ~IOf_START;
1558 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1559 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1560 SvSETMAGIC(GvSV(PL_last_in_gv));
1565 fp = nextargv(PL_last_in_gv);
1566 if (!fp) { /* Note: fp != IoIFP(io) */
1567 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1570 else if (type == OP_GLOB)
1571 fp = Perl_start_glob(aTHX_ POPs, io);
1573 else if (type == OP_GLOB)
1575 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1576 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1580 if ((!io || !(IoFLAGS(io) & IOf_START))
1581 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1583 if (type == OP_GLOB)
1584 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1585 "glob failed (can't start child: %s)",
1588 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1590 if (gimme == G_SCALAR) {
1591 /* undef TARG, and push that undefined value */
1592 if (type != OP_RCATLINE) {
1593 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1601 if (gimme == G_SCALAR) {
1603 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1606 if (type == OP_RCATLINE)
1607 SvPV_force_nolen(sv);
1611 else if (isGV_with_GP(sv)) {
1612 SvPV_force_nolen(sv);
1614 SvUPGRADE(sv, SVt_PV);
1615 tmplen = SvLEN(sv); /* remember if already alloced */
1616 if (!tmplen && !SvREADONLY(sv))
1617 Sv_Grow(sv, 80); /* try short-buffering it */
1619 if (type == OP_RCATLINE && SvOK(sv)) {
1621 SvPV_force_nolen(sv);
1627 sv = sv_2mortal(newSV(80));
1631 /* This should not be marked tainted if the fp is marked clean */
1632 #define MAYBE_TAINT_LINE(io, sv) \
1633 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1638 /* delay EOF state for a snarfed empty file */
1639 #define SNARF_EOF(gimme,rs,io,sv) \
1640 (gimme != G_SCALAR || SvCUR(sv) \
1641 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1645 if (!sv_gets(sv, fp, offset)
1647 || SNARF_EOF(gimme, PL_rs, io, sv)
1648 || PerlIO_error(fp)))
1650 PerlIO_clearerr(fp);
1651 if (IoFLAGS(io) & IOf_ARGV) {
1652 fp = nextargv(PL_last_in_gv);
1655 (void)do_close(PL_last_in_gv, FALSE);
1657 else if (type == OP_GLOB) {
1658 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1659 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1660 "glob failed (child exited with status %d%s)",
1661 (int)(STATUS_CURRENT >> 8),
1662 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1665 if (gimme == G_SCALAR) {
1666 if (type != OP_RCATLINE) {
1667 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1673 MAYBE_TAINT_LINE(io, sv);
1676 MAYBE_TAINT_LINE(io, sv);
1678 IoFLAGS(io) |= IOf_NOLINE;
1682 if (type == OP_GLOB) {
1685 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1686 char * const tmps = SvEND(sv) - 1;
1687 if (*tmps == *SvPVX_const(PL_rs)) {
1689 SvCUR_set(sv, SvCUR(sv) - 1);
1692 for (t1 = SvPVX_const(sv); *t1; t1++)
1693 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1694 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1696 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1697 (void)POPs; /* Unmatched wildcard? Chuck it... */
1700 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1701 if (ckWARN(WARN_UTF8)) {
1702 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1703 const STRLEN len = SvCUR(sv) - offset;
1706 if (!is_utf8_string_loc(s, len, &f))
1707 /* Emulate :encoding(utf8) warning in the same case. */
1708 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1709 "utf8 \"\\x%02X\" does not map to Unicode",
1710 f < (U8*)SvEND(sv) ? *f : 0);
1713 if (gimme == G_ARRAY) {
1714 if (SvLEN(sv) - SvCUR(sv) > 20) {
1715 SvPV_shrink_to_cur(sv);
1717 sv = sv_2mortal(newSV(80));
1720 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1721 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1722 const STRLEN new_len
1723 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1724 SvPV_renew(sv, new_len);
1733 register PERL_CONTEXT *cx;
1734 I32 gimme = OP_GIMME(PL_op, -1);
1737 if (cxstack_ix >= 0)
1738 gimme = cxstack[cxstack_ix].blk_gimme;
1746 PUSHBLOCK(cx, CXt_BLOCK, SP);
1756 SV * const keysv = POPs;
1757 HV * const hv = (HV*)POPs;
1758 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1759 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1761 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1764 if (SvTYPE(hv) != SVt_PVHV)
1767 if (PL_op->op_private & OPpLVAL_INTRO) {
1770 /* does the element we're localizing already exist? */
1771 preeminent = /* can we determine whether it exists? */
1773 || mg_find((SV*)hv, PERL_MAGIC_env)
1774 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1775 /* Try to preserve the existenceness of a tied hash
1776 * element by using EXISTS and DELETE if possible.
1777 * Fallback to FETCH and STORE otherwise */
1778 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1779 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1780 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1782 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1784 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1785 svp = he ? &HeVAL(he) : NULL;
1787 if (!svp || *svp == &PL_sv_undef) {
1791 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1793 lv = sv_newmortal();
1794 sv_upgrade(lv, SVt_PVLV);
1796 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1797 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1798 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1803 if (PL_op->op_private & OPpLVAL_INTRO) {
1804 if (HvNAME_get(hv) && isGV(*svp))
1805 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1809 const char * const key = SvPV_const(keysv, keylen);
1810 SAVEDELETE(hv, savepvn(key,keylen),
1811 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1813 save_helem(hv, keysv, svp);
1816 else if (PL_op->op_private & OPpDEREF)
1817 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1819 sv = (svp ? *svp : &PL_sv_undef);
1820 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1821 * Pushing the magical RHS on to the stack is useless, since
1822 * that magic is soon destined to be misled by the local(),
1823 * and thus the later pp_sassign() will fail to mg_get() the
1824 * old value. This should also cure problems with delayed
1825 * mg_get()s. GSAR 98-07-03 */
1826 if (!lval && SvGMAGICAL(sv))
1827 sv = sv_mortalcopy(sv);
1835 register PERL_CONTEXT *cx;
1840 if (PL_op->op_flags & OPf_SPECIAL) {
1841 cx = &cxstack[cxstack_ix];
1842 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1847 gimme = OP_GIMME(PL_op, -1);
1849 if (cxstack_ix >= 0)
1850 gimme = cxstack[cxstack_ix].blk_gimme;
1856 if (gimme == G_VOID)
1858 else if (gimme == G_SCALAR) {
1862 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1865 *MARK = sv_mortalcopy(TOPs);
1868 *MARK = &PL_sv_undef;
1872 else if (gimme == G_ARRAY) {
1873 /* in case LEAVE wipes old return values */
1875 for (mark = newsp + 1; mark <= SP; mark++) {
1876 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1877 *mark = sv_mortalcopy(*mark);
1878 TAINT_NOT; /* Each item is independent */
1882 PL_curpm = newpm; /* Don't pop $1 et al till now */
1892 register PERL_CONTEXT *cx;
1895 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1896 bool av_is_stack = FALSE;
1899 cx = &cxstack[cxstack_ix];
1900 if (!CxTYPE_is_LOOP(cx))
1901 DIE(aTHX_ "panic: pp_iter");
1903 itersvp = CxITERVAR(cx);
1904 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1905 /* string increment */
1906 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1907 SV *end = cx->blk_loop.state_u.lazysv.end;
1908 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1909 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1911 const char *max = SvPV_const(end, maxlen);
1912 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1913 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1914 /* safe to reuse old SV */
1915 sv_setsv(*itersvp, cur);
1919 /* we need a fresh SV every time so that loop body sees a
1920 * completely new SV for closures/references to work as
1923 *itersvp = newSVsv(cur);
1924 SvREFCNT_dec(oldsv);
1926 if (strEQ(SvPVX_const(cur), max))
1927 sv_setiv(cur, 0); /* terminate next time */
1934 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1935 /* integer increment */
1936 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1939 /* don't risk potential race */
1940 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1941 /* safe to reuse old SV */
1942 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1946 /* we need a fresh SV every time so that loop body sees a
1947 * completely new SV for closures/references to work as they
1950 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1951 SvREFCNT_dec(oldsv);
1954 /* Handle end of range at IV_MAX */
1955 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1956 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1958 cx->blk_loop.state_u.lazyiv.cur++;
1959 cx->blk_loop.state_u.lazyiv.end++;
1966 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1967 av = cx->blk_loop.state_u.ary.ary;
1972 if (PL_op->op_private & OPpITER_REVERSED) {
1973 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1974 ? cx->blk_loop.resetsp + 1 : 0))
1977 if (SvMAGICAL(av) || AvREIFY(av)) {
1978 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1979 sv = svp ? *svp : NULL;
1982 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1986 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1990 if (SvMAGICAL(av) || AvREIFY(av)) {
1991 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1992 sv = svp ? *svp : NULL;
1995 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1999 if (sv && SvIS_FREED(sv)) {
2001 Perl_croak(aTHX_ "Use of freed value in iteration");
2006 SvREFCNT_inc_simple_void_NN(sv);
2010 if (!av_is_stack && sv == &PL_sv_undef) {
2011 SV *lv = newSV_type(SVt_PVLV);
2013 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2014 LvTARG(lv) = SvREFCNT_inc_simple(av);
2015 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2016 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2022 SvREFCNT_dec(oldsv);
2030 register PMOP *pm = cPMOP;
2045 register REGEXP *rx = PM_GETRE(pm);
2047 int force_on_match = 0;
2048 const I32 oldsave = PL_savestack_ix;
2050 bool doutf8 = FALSE;
2052 #ifdef PERL_OLD_COPY_ON_WRITE
2057 /* known replacement string? */
2058 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2059 if (PL_op->op_flags & OPf_STACKED)
2061 else if (PL_op->op_private & OPpTARGET_MY)
2068 #ifdef PERL_OLD_COPY_ON_WRITE
2069 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2070 because they make integers such as 256 "false". */
2071 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2074 sv_force_normal_flags(TARG,0);
2077 #ifdef PERL_OLD_COPY_ON_WRITE
2081 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2082 || SvTYPE(TARG) > SVt_PVLV)
2083 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2084 DIE(aTHX_ PL_no_modify);
2087 s = SvPV_mutable(TARG, len);
2088 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2090 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2091 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2096 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2100 DIE(aTHX_ "panic: pp_subst");
2103 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2104 maxiters = 2 * slen + 10; /* We can match twice at each
2105 position, once with zero-length,
2106 second time with non-zero. */
2108 if (!RX_PRELEN(rx) && PL_curpm) {
2112 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2113 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2114 ? REXEC_COPY_STR : 0;
2116 r_flags |= REXEC_SCREAM;
2119 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2121 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2125 /* How to do it in subst? */
2126 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2128 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2129 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2130 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2131 && (r_flags & REXEC_SCREAM))))
2136 /* only replace once? */
2137 once = !(rpm->op_pmflags & PMf_GLOBAL);
2138 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2139 r_flags | REXEC_CHECKED);
2140 /* known replacement string? */
2142 /* replacement needing upgrading? */
2143 if (DO_UTF8(TARG) && !doutf8) {
2144 nsv = sv_newmortal();
2147 sv_recode_to_utf8(nsv, PL_encoding);
2149 sv_utf8_upgrade(nsv);
2150 c = SvPV_const(nsv, clen);
2154 c = SvPV_const(dstr, clen);
2155 doutf8 = DO_UTF8(dstr);
2163 /* can do inplace substitution? */
2165 #ifdef PERL_OLD_COPY_ON_WRITE
2168 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2169 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2170 && (!doutf8 || SvUTF8(TARG))) {
2175 LEAVE_SCOPE(oldsave);
2178 #ifdef PERL_OLD_COPY_ON_WRITE
2179 if (SvIsCOW(TARG)) {
2180 assert (!force_on_match);
2184 if (force_on_match) {
2186 s = SvPV_force(TARG, len);
2191 SvSCREAM_off(TARG); /* disable possible screamer */
2193 rxtainted |= RX_MATCH_TAINTED(rx);
2194 m = orig + RX_OFFS(rx)[0].start;
2195 d = orig + RX_OFFS(rx)[0].end;
2197 if (m - s > strend - d) { /* faster to shorten from end */
2199 Copy(c, m, clen, char);
2204 Move(d, m, i, char);
2208 SvCUR_set(TARG, m - s);
2210 else if ((i = m - s)) { /* faster from front */
2213 Move(s, d - i, i, char);
2216 Copy(c, m, clen, char);
2221 Copy(c, d, clen, char);
2226 TAINT_IF(rxtainted & 1);
2232 if (iters++ > maxiters)
2233 DIE(aTHX_ "Substitution loop");
2234 rxtainted |= RX_MATCH_TAINTED(rx);
2235 m = RX_OFFS(rx)[0].start + orig;
2238 Move(s, d, i, char);
2242 Copy(c, d, clen, char);
2245 s = RX_OFFS(rx)[0].end + orig;
2246 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2248 /* don't match same null twice */
2249 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2252 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2253 Move(s, d, i+1, char); /* include the NUL */
2255 TAINT_IF(rxtainted & 1);
2259 (void)SvPOK_only_UTF8(TARG);
2260 TAINT_IF(rxtainted);
2261 if (SvSMAGICAL(TARG)) {
2269 LEAVE_SCOPE(oldsave);
2275 if (force_on_match) {
2277 s = SvPV_force(TARG, len);
2280 #ifdef PERL_OLD_COPY_ON_WRITE
2283 rxtainted |= RX_MATCH_TAINTED(rx);
2284 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2288 register PERL_CONTEXT *cx;
2291 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2293 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2295 if (iters++ > maxiters)
2296 DIE(aTHX_ "Substitution loop");
2297 rxtainted |= RX_MATCH_TAINTED(rx);
2298 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2301 orig = RX_SUBBEG(rx);
2303 strend = s + (strend - m);
2305 m = RX_OFFS(rx)[0].start + orig;
2306 if (doutf8 && !SvUTF8(dstr))
2307 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2309 sv_catpvn(dstr, s, m-s);
2310 s = RX_OFFS(rx)[0].end + orig;
2312 sv_catpvn(dstr, c, clen);
2315 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2316 TARG, NULL, r_flags));
2317 if (doutf8 && !DO_UTF8(TARG))
2318 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2320 sv_catpvn(dstr, s, strend - s);
2322 #ifdef PERL_OLD_COPY_ON_WRITE
2323 /* The match may make the string COW. If so, brilliant, because that's
2324 just saved us one malloc, copy and free - the regexp has donated
2325 the old buffer, and we malloc an entirely new one, rather than the
2326 regexp malloc()ing a buffer and copying our original, only for
2327 us to throw it away here during the substitution. */
2328 if (SvIsCOW(TARG)) {
2329 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2335 SvPV_set(TARG, SvPVX(dstr));
2336 SvCUR_set(TARG, SvCUR(dstr));
2337 SvLEN_set(TARG, SvLEN(dstr));
2338 doutf8 |= DO_UTF8(dstr);
2339 SvPV_set(dstr, NULL);
2341 TAINT_IF(rxtainted & 1);
2345 (void)SvPOK_only(TARG);
2348 TAINT_IF(rxtainted);
2351 LEAVE_SCOPE(oldsave);
2360 LEAVE_SCOPE(oldsave);
2369 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2370 ++*PL_markstack_ptr;
2371 LEAVE; /* exit inner scope */
2374 if (PL_stack_base + *PL_markstack_ptr > SP) {
2376 const I32 gimme = GIMME_V;
2378 LEAVE; /* exit outer scope */
2379 (void)POPMARK; /* pop src */
2380 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2381 (void)POPMARK; /* pop dst */
2382 SP = PL_stack_base + POPMARK; /* pop original mark */
2383 if (gimme == G_SCALAR) {
2384 if (PL_op->op_private & OPpGREP_LEX) {
2385 SV* const sv = sv_newmortal();
2386 sv_setiv(sv, items);
2394 else if (gimme == G_ARRAY)
2401 ENTER; /* enter inner scope */
2404 src = PL_stack_base[*PL_markstack_ptr];
2406 if (PL_op->op_private & OPpGREP_LEX)
2407 PAD_SVl(PL_op->op_targ) = src;
2411 RETURNOP(cLOGOP->op_other);
2422 register PERL_CONTEXT *cx;
2425 if (CxMULTICALL(&cxstack[cxstack_ix]))
2429 cxstack_ix++; /* temporarily protect top context */
2432 if (gimme == G_SCALAR) {
2435 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2437 *MARK = SvREFCNT_inc(TOPs);
2442 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2444 *MARK = sv_mortalcopy(sv);
2449 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2453 *MARK = &PL_sv_undef;
2457 else if (gimme == G_ARRAY) {
2458 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2459 if (!SvTEMP(*MARK)) {
2460 *MARK = sv_mortalcopy(*MARK);
2461 TAINT_NOT; /* Each item is independent */
2469 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2470 PL_curpm = newpm; /* ... and pop $1 et al */
2473 return cx->blk_sub.retop;
2476 /* This duplicates the above code because the above code must not
2477 * get any slower by more conditions */
2485 register PERL_CONTEXT *cx;
2488 if (CxMULTICALL(&cxstack[cxstack_ix]))
2492 cxstack_ix++; /* temporarily protect top context */
2496 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2497 /* We are an argument to a function or grep().
2498 * This kind of lvalueness was legal before lvalue
2499 * subroutines too, so be backward compatible:
2500 * cannot report errors. */
2502 /* Scalar context *is* possible, on the LHS of -> only,
2503 * as in f()->meth(). But this is not an lvalue. */
2504 if (gimme == G_SCALAR)
2506 if (gimme == G_ARRAY) {
2507 if (!CvLVALUE(cx->blk_sub.cv))
2508 goto temporise_array;
2509 EXTEND_MORTAL(SP - newsp);
2510 for (mark = newsp + 1; mark <= SP; mark++) {
2513 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2514 *mark = sv_mortalcopy(*mark);
2516 /* Can be a localized value subject to deletion. */
2517 PL_tmps_stack[++PL_tmps_ix] = *mark;
2518 SvREFCNT_inc_void(*mark);
2523 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2524 /* Here we go for robustness, not for speed, so we change all
2525 * the refcounts so the caller gets a live guy. Cannot set
2526 * TEMP, so sv_2mortal is out of question. */
2527 if (!CvLVALUE(cx->blk_sub.cv)) {
2533 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2535 if (gimme == G_SCALAR) {
2539 /* Temporaries are bad unless they happen to be elements
2540 * of a tied hash or array */
2541 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2542 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2548 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2549 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2550 : "a readonly value" : "a temporary");
2552 else { /* Can be a localized value
2553 * subject to deletion. */
2554 PL_tmps_stack[++PL_tmps_ix] = *mark;
2555 SvREFCNT_inc_void(*mark);
2558 else { /* Should not happen? */
2564 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2565 (MARK > SP ? "Empty array" : "Array"));
2569 else if (gimme == G_ARRAY) {
2570 EXTEND_MORTAL(SP - newsp);
2571 for (mark = newsp + 1; mark <= SP; mark++) {
2572 if (*mark != &PL_sv_undef
2573 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2574 /* Might be flattened array after $#array = */
2581 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2582 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2585 /* Can be a localized value subject to deletion. */
2586 PL_tmps_stack[++PL_tmps_ix] = *mark;
2587 SvREFCNT_inc_void(*mark);
2593 if (gimme == G_SCALAR) {
2597 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2599 *MARK = SvREFCNT_inc(TOPs);
2604 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2606 *MARK = sv_mortalcopy(sv);
2611 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2615 *MARK = &PL_sv_undef;
2619 else if (gimme == G_ARRAY) {
2621 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2622 if (!SvTEMP(*MARK)) {
2623 *MARK = sv_mortalcopy(*MARK);
2624 TAINT_NOT; /* Each item is independent */
2633 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2634 PL_curpm = newpm; /* ... and pop $1 et al */
2637 return cx->blk_sub.retop;
2645 register PERL_CONTEXT *cx;
2647 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2650 DIE(aTHX_ "Not a CODE reference");
2651 switch (SvTYPE(sv)) {
2652 /* This is overwhelming the most common case: */
2654 if (!(cv = GvCVu((GV*)sv))) {
2656 cv = sv_2cv(sv, &stash, &gv, 0);
2668 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2670 SP = PL_stack_base + POPMARK;
2673 if (SvGMAGICAL(sv)) {
2678 sym = SvPVX_const(sv);
2686 sym = SvPV_const(sv, len);
2689 DIE(aTHX_ PL_no_usym, "a subroutine");
2690 if (PL_op->op_private & HINT_STRICT_REFS)
2691 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2692 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2697 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2698 tryAMAGICunDEREF(to_cv);
2701 if (SvTYPE(cv) == SVt_PVCV)
2706 DIE(aTHX_ "Not a CODE reference");
2707 /* This is the second most common case: */
2717 if (!CvROOT(cv) && !CvXSUB(cv)) {
2721 /* anonymous or undef'd function leaves us no recourse */
2722 if (CvANON(cv) || !(gv = CvGV(cv)))
2723 DIE(aTHX_ "Undefined subroutine called");
2725 /* autoloaded stub? */
2726 if (cv != GvCV(gv)) {
2729 /* should call AUTOLOAD now? */
2732 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2739 sub_name = sv_newmortal();
2740 gv_efullname3(sub_name, gv, NULL);
2741 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2745 DIE(aTHX_ "Not a CODE reference");
2750 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2751 Perl_get_db_sub(aTHX_ &sv, cv);
2753 PL_curcopdb = PL_curcop;
2754 cv = GvCV(PL_DBsub);
2756 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2757 DIE(aTHX_ "No DB::sub routine defined");
2760 if (!(CvISXSUB(cv))) {
2761 /* This path taken at least 75% of the time */
2763 register I32 items = SP - MARK;
2764 AV* const padlist = CvPADLIST(cv);
2765 PUSHBLOCK(cx, CXt_SUB, MARK);
2767 cx->blk_sub.retop = PL_op->op_next;
2769 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2770 * that eval'' ops within this sub know the correct lexical space.
2771 * Owing the speed considerations, we choose instead to search for
2772 * the cv using find_runcv() when calling doeval().
2774 if (CvDEPTH(cv) >= 2) {
2775 PERL_STACK_OVERFLOW_CHECK();
2776 pad_push(padlist, CvDEPTH(cv));
2779 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2781 AV* const av = (AV*)PAD_SVl(0);
2783 /* @_ is normally not REAL--this should only ever
2784 * happen when DB::sub() calls things that modify @_ */
2789 cx->blk_sub.savearray = GvAV(PL_defgv);
2790 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2791 CX_CURPAD_SAVE(cx->blk_sub);
2792 cx->blk_sub.argarray = av;
2795 if (items > AvMAX(av) + 1) {
2796 SV **ary = AvALLOC(av);
2797 if (AvARRAY(av) != ary) {
2798 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2801 if (items > AvMAX(av) + 1) {
2802 AvMAX(av) = items - 1;
2803 Renew(ary,items,SV*);
2808 Copy(MARK,AvARRAY(av),items,SV*);
2809 AvFILLp(av) = items - 1;
2817 /* warning must come *after* we fully set up the context
2818 * stuff so that __WARN__ handlers can safely dounwind()
2821 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2822 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2823 sub_crush_depth(cv);
2824 RETURNOP(CvSTART(cv));
2827 I32 markix = TOPMARK;
2832 /* Need to copy @_ to stack. Alternative may be to
2833 * switch stack to @_, and copy return values
2834 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2835 AV * const av = GvAV(PL_defgv);
2836 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2839 /* Mark is at the end of the stack. */
2841 Copy(AvARRAY(av), SP + 1, items, SV*);
2846 /* We assume first XSUB in &DB::sub is the called one. */
2848 SAVEVPTR(PL_curcop);
2849 PL_curcop = PL_curcopdb;
2852 /* Do we need to open block here? XXXX */
2853 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2854 (void)(*CvXSUB(cv))(aTHX_ cv);
2856 /* Enforce some sanity in scalar context. */
2857 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2858 if (markix > PL_stack_sp - PL_stack_base)
2859 *(PL_stack_base + markix) = &PL_sv_undef;
2861 *(PL_stack_base + markix) = *PL_stack_sp;
2862 PL_stack_sp = PL_stack_base + markix;
2870 Perl_sub_crush_depth(pTHX_ CV *cv)
2872 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2875 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2877 SV* const tmpstr = sv_newmortal();
2878 gv_efullname3(tmpstr, CvGV(cv), NULL);
2879 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2888 SV* const elemsv = POPs;
2889 IV elem = SvIV(elemsv);
2890 AV* const av = (AV*)POPs;
2891 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2892 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2895 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2896 Perl_warner(aTHX_ packWARN(WARN_MISC),
2897 "Use of reference \"%"SVf"\" as array index",
2900 elem -= CopARYBASE_get(PL_curcop);
2901 if (SvTYPE(av) != SVt_PVAV)
2903 svp = av_fetch(av, elem, lval && !defer);
2905 #ifdef PERL_MALLOC_WRAP
2906 if (SvUOK(elemsv)) {
2907 const UV uv = SvUV(elemsv);
2908 elem = uv > IV_MAX ? IV_MAX : uv;
2910 else if (SvNOK(elemsv))
2911 elem = (IV)SvNV(elemsv);
2913 static const char oom_array_extend[] =
2914 "Out of memory during array extend"; /* Duplicated in av.c */
2915 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2918 if (!svp || *svp == &PL_sv_undef) {
2921 DIE(aTHX_ PL_no_aelem, elem);
2922 lv = sv_newmortal();
2923 sv_upgrade(lv, SVt_PVLV);
2925 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2926 LvTARG(lv) = SvREFCNT_inc_simple(av);
2927 LvTARGOFF(lv) = elem;
2932 if (PL_op->op_private & OPpLVAL_INTRO)
2933 save_aelem(av, elem, svp);
2934 else if (PL_op->op_private & OPpDEREF)
2935 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2937 sv = (svp ? *svp : &PL_sv_undef);
2938 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2939 sv = sv_mortalcopy(sv);
2945 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2947 PERL_ARGS_ASSERT_VIVIFY_REF;
2952 Perl_croak(aTHX_ PL_no_modify);
2953 prepare_SV_for_RV(sv);
2956 SvRV_set(sv, newSV(0));
2959 SvRV_set(sv, (SV*)newAV());
2962 SvRV_set(sv, (SV*)newHV());
2973 SV* const sv = TOPs;
2976 SV* const rsv = SvRV(sv);
2977 if (SvTYPE(rsv) == SVt_PVCV) {
2983 SETs(method_common(sv, NULL));
2990 SV* const sv = cSVOP_sv;
2991 U32 hash = SvSHARED_HASH(sv);
2993 XPUSHs(method_common(sv, &hash));
2998 S_method_common(pTHX_ SV* meth, U32* hashp)
3005 const char* packname = NULL;
3008 const char * const name = SvPV_const(meth, namelen);
3009 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3011 PERL_ARGS_ASSERT_METHOD_COMMON;
3014 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3022 /* this isn't a reference */
3023 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3024 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3026 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3033 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3034 !(ob=(SV*)GvIO(iogv)))
3036 /* this isn't the name of a filehandle either */
3038 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3039 ? !isIDFIRST_utf8((U8*)packname)
3040 : !isIDFIRST(*packname)
3043 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3044 SvOK(sv) ? "without a package or object reference"
3045 : "on an undefined value");
3047 /* assume it's a package name */
3048 stash = gv_stashpvn(packname, packlen, 0);
3052 SV* const ref = newSViv(PTR2IV(stash));
3053 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3057 /* it _is_ a filehandle name -- replace with a reference */
3058 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3061 /* if we got here, ob should be a reference or a glob */
3062 if (!ob || !(SvOBJECT(ob)
3063 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3066 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3067 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3071 stash = SvSTASH(ob);
3074 /* NOTE: stash may be null, hope hv_fetch_ent and
3075 gv_fetchmethod can cope (it seems they can) */
3077 /* shortcut for simple names */
3079 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3081 gv = (GV*)HeVAL(he);
3082 if (isGV(gv) && GvCV(gv) &&
3083 (!GvCVGEN(gv) || GvCVGEN(gv)
3084 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3085 return (SV*)GvCV(gv);
3089 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3092 /* This code tries to figure out just what went wrong with
3093 gv_fetchmethod. It therefore needs to duplicate a lot of
3094 the internals of that function. We can't move it inside
3095 Perl_gv_fetchmethod_autoload(), however, since that would
3096 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3099 const char* leaf = name;
3100 const char* sep = NULL;
3103 for (p = name; *p; p++) {
3105 sep = p, leaf = p + 1;
3106 else if (*p == ':' && *(p + 1) == ':')
3107 sep = p, leaf = p + 2;
3109 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3110 /* the method name is unqualified or starts with SUPER:: */
3111 #ifndef USE_ITHREADS
3113 stash = CopSTASH(PL_curcop);
3115 bool need_strlen = 1;
3117 packname = CopSTASHPV(PL_curcop);
3122 HEK * const packhek = HvNAME_HEK(stash);
3124 packname = HEK_KEY(packhek);
3125 packlen = HEK_LEN(packhek);
3137 "Can't use anonymous symbol table for method lookup");
3141 packlen = strlen(packname);
3146 /* the method name is qualified */
3148 packlen = sep - name;
3151 /* we're relying on gv_fetchmethod not autovivifying the stash */
3152 if (gv_stashpvn(packname, packlen, 0)) {
3154 "Can't locate object method \"%s\" via package \"%.*s\"",
3155 leaf, (int)packlen, packname);
3159 "Can't locate object method \"%s\" via package \"%.*s\""
3160 " (perhaps you forgot to load \"%.*s\"?)",
3161 leaf, (int)packlen, packname, (int)packlen, packname);
3164 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3169 * c-indentation-style: bsd
3171 * indent-tabs-mode: t
3174 * ex: set ts=8 sts=4 sw=4 noet: