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
42 if ( PL_op->op_flags & OPf_SPECIAL )
43 /* This is a const op added to hold the hints hash for
44 pp_entereval. The hash can be modified by the code
45 being eval'ed, so we return a copy instead. */
46 mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
56 PL_curcop = (COP*)PL_op;
57 TAINT_NOT; /* Each statement is presumed innocent */
58 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
68 if (PL_op->op_private & OPpLVAL_INTRO)
69 PUSHs(save_scalar(cGVOP_gv));
71 PUSHs(GvSVn(cGVOP_gv));
84 PL_curcop = (COP*)PL_op;
91 PUSHMARK(PL_stack_sp);
106 XPUSHs((SV*)cGVOP_gv);
116 if (PL_op->op_type == OP_AND)
118 RETURNOP(cLOGOP->op_other);
124 dVAR; dSP; dPOPTOPssrl;
126 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
127 SV * const temp = left;
128 left = right; right = temp;
130 if (PL_tainting && PL_tainted && !SvTAINTED(left))
132 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
133 SV * const cv = SvRV(left);
134 const U32 cv_type = SvTYPE(cv);
135 const U32 gv_type = SvTYPE(right);
136 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
142 /* Can do the optimisation if right (LVALUE) is not a typeglob,
143 left (RVALUE) is a reference to something, and we're in void
145 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
146 /* Is the target symbol table currently empty? */
147 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
148 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
149 /* Good. Create a new proxy constant subroutine in the target.
150 The gv becomes a(nother) reference to the constant. */
151 SV *const value = SvRV(cv);
153 SvUPGRADE((SV *)gv, SVt_IV);
154 SvPCS_IMPORTED_on(gv);
156 SvREFCNT_inc_simple_void(value);
162 /* Need to fix things up. */
163 if (gv_type != SVt_PVGV) {
164 /* Need to fix GV. */
165 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
169 /* We've been returned a constant rather than a full subroutine,
170 but they expect a subroutine reference to apply. */
173 SvREFCNT_inc_void(SvRV(cv));
174 /* newCONSTSUB takes a reference count on the passed in SV
175 from us. We set the name to NULL, otherwise we get into
176 all sorts of fun as the reference to our new sub is
177 donated to the GV that we're about to assign to.
179 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
184 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
186 First: ops for \&{"BONK"}; return us the constant in the
188 Second: ops for *{"BONK"} cause that symbol table entry
189 (and our reference to it) to be upgraded from RV
191 Thirdly: We get here. cv is actually PVGV now, and its
192 GvCV() is actually the subroutine we're looking for
194 So change the reference so that it points to the subroutine
195 of that typeglob, as that's what they were after all along.
197 GV *const upgraded = (GV *) cv;
198 CV *const source = GvCV(upgraded);
201 assert(CvFLAGS(source) & CVf_CONST);
203 SvREFCNT_inc_void(source);
204 SvREFCNT_dec(upgraded);
205 SvRV_set(left, (SV *)source);
210 SvSetMagicSV(right, left);
219 RETURNOP(cLOGOP->op_other);
221 RETURNOP(cLOGOP->op_next);
228 TAINT_NOT; /* Each statement is presumed innocent */
229 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
231 oldsave = PL_scopestack[PL_scopestack_ix - 1];
232 LEAVE_SCOPE(oldsave);
238 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
243 const char *rpv = NULL;
245 bool rcopied = FALSE;
247 if (TARG == right && right != left) {
248 /* mg_get(right) may happen here ... */
249 rpv = SvPV_const(right, rlen);
250 rbyte = !DO_UTF8(right);
251 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
252 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
258 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
259 lbyte = !DO_UTF8(left);
260 sv_setpvn(TARG, lpv, llen);
266 else { /* TARG == left */
268 SvGETMAGIC(left); /* or mg_get(left) may happen here */
270 if (left == right && ckWARN(WARN_UNINITIALIZED))
271 report_uninit(right);
272 sv_setpvn(left, "", 0);
274 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
275 lbyte = !DO_UTF8(left);
280 /* or mg_get(right) may happen here */
282 rpv = SvPV_const(right, rlen);
283 rbyte = !DO_UTF8(right);
285 if (lbyte != rbyte) {
287 sv_utf8_upgrade_nomg(TARG);
290 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
291 sv_utf8_upgrade_nomg(right);
292 rpv = SvPV_const(right, rlen);
295 sv_catpvn_nomg(TARG, rpv, rlen);
306 if (PL_op->op_flags & OPf_MOD) {
307 if (PL_op->op_private & OPpLVAL_INTRO)
308 if (!(PL_op->op_private & OPpPAD_STATE))
309 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
310 if (PL_op->op_private & OPpDEREF) {
312 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
322 tryAMAGICunTARGET(iter, 0);
323 PL_last_in_gv = (GV*)(*PL_stack_sp--);
324 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
325 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
326 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
329 XPUSHs((SV*)PL_last_in_gv);
332 PL_last_in_gv = (GV*)(*PL_stack_sp--);
335 return do_readline();
340 dVAR; dSP; tryAMAGICbinSET(eq,0);
341 #ifndef NV_PRESERVES_UV
342 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
344 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
348 #ifdef PERL_PRESERVE_IVUV
351 /* Unless the left argument is integer in range we are going
352 to have to use NV maths. Hence only attempt to coerce the
353 right argument if we know the left is integer. */
356 const bool auvok = SvUOK(TOPm1s);
357 const bool buvok = SvUOK(TOPs);
359 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
360 /* Casting IV to UV before comparison isn't going to matter
361 on 2s complement. On 1s complement or sign&magnitude
362 (if we have any of them) it could to make negative zero
363 differ from normal zero. As I understand it. (Need to
364 check - is negative zero implementation defined behaviour
366 const UV buv = SvUVX(POPs);
367 const UV auv = SvUVX(TOPs);
369 SETs(boolSV(auv == buv));
372 { /* ## Mixed IV,UV ## */
376 /* == is commutative so doesn't matter which is left or right */
378 /* top of stack (b) is the iv */
387 /* As uv is a UV, it's >0, so it cannot be == */
390 /* we know iv is >= 0 */
391 SETs(boolSV((UV)iv == SvUVX(uvp)));
398 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
400 if (Perl_isnan(left) || Perl_isnan(right))
402 SETs(boolSV(left == right));
405 SETs(boolSV(TOPn == value));
414 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
415 DIE(aTHX_ PL_no_modify);
416 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
417 && SvIVX(TOPs) != IV_MAX)
419 SvIV_set(TOPs, SvIVX(TOPs) + 1);
420 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
422 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
434 if (PL_op->op_type == OP_OR)
436 RETURNOP(cLOGOP->op_other);
445 const int op_type = PL_op->op_type;
446 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
450 if (!sv || !SvANY(sv)) {
451 if (op_type == OP_DOR)
453 RETURNOP(cLOGOP->op_other);
459 if (!sv || !SvANY(sv))
464 switch (SvTYPE(sv)) {
466 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
470 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
474 if (CvROOT(sv) || CvXSUB(sv))
487 if(op_type == OP_DOR)
489 RETURNOP(cLOGOP->op_other);
491 /* assuming OP_DEFINED */
499 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
500 tryAMAGICbin(add,opASSIGN);
501 svl = sv_2num(TOPm1s);
503 useleft = USE_LEFT(svl);
504 #ifdef PERL_PRESERVE_IVUV
505 /* We must see if we can perform the addition with integers if possible,
506 as the integer code detects overflow while the NV code doesn't.
507 If either argument hasn't had a numeric conversion yet attempt to get
508 the IV. It's important to do this now, rather than just assuming that
509 it's not IOK as a PV of "9223372036854775806" may not take well to NV
510 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
511 integer in case the second argument is IV=9223372036854775806
512 We can (now) rely on sv_2iv to do the right thing, only setting the
513 public IOK flag if the value in the NV (or PV) slot is truly integer.
515 A side effect is that this also aggressively prefers integer maths over
516 fp maths for integer values.
518 How to detect overflow?
520 C 99 section 6.2.6.1 says
522 The range of nonnegative values of a signed integer type is a subrange
523 of the corresponding unsigned integer type, and the representation of
524 the same value in each type is the same. A computation involving
525 unsigned operands can never overflow, because a result that cannot be
526 represented by the resulting unsigned integer type is reduced modulo
527 the number that is one greater than the largest value that can be
528 represented by the resulting type.
532 which I read as "unsigned ints wrap."
534 signed integer overflow seems to be classed as "exception condition"
536 If an exceptional condition occurs during the evaluation of an
537 expression (that is, if the result is not mathematically defined or not
538 in the range of representable values for its type), the behavior is
541 (6.5, the 5th paragraph)
543 I had assumed that on 2s complement machines signed arithmetic would
544 wrap, hence coded pp_add and pp_subtract on the assumption that
545 everything perl builds on would be happy. After much wailing and
546 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
547 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
548 unsigned code below is actually shorter than the old code. :-)
553 /* Unless the left argument is integer in range we are going to have to
554 use NV maths. Hence only attempt to coerce the right argument if
555 we know the left is integer. */
563 /* left operand is undef, treat as zero. + 0 is identity,
564 Could SETi or SETu right now, but space optimise by not adding
565 lots of code to speed up what is probably a rarish case. */
567 /* Left operand is defined, so is it IV? */
570 if ((auvok = SvUOK(svl)))
573 register const IV aiv = SvIVX(svl);
576 auvok = 1; /* Now acting as a sign flag. */
577 } else { /* 2s complement assumption for IV_MIN */
585 bool result_good = 0;
588 bool buvok = SvUOK(svr);
593 register const IV biv = SvIVX(svr);
600 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
601 else "IV" now, independent of how it came in.
602 if a, b represents positive, A, B negative, a maps to -A etc
607 all UV maths. negate result if A negative.
608 add if signs same, subtract if signs differ. */
614 /* Must get smaller */
620 /* result really should be -(auv-buv). as its negation
621 of true value, need to swap our result flag */
638 if (result <= (UV)IV_MIN)
641 /* result valid, but out of range for IV. */
646 } /* Overflow, drop through to NVs. */
651 NV value = SvNV(svr);
654 /* left operand is undef, treat as zero. + 0.0 is identity. */
658 SETn( value + SvNV(svl) );
666 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
667 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
668 const U32 lval = PL_op->op_flags & OPf_MOD;
669 SV** const svp = av_fetch(av, PL_op->op_private, lval);
670 SV *sv = (svp ? *svp : &PL_sv_undef);
672 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
673 sv = sv_mortalcopy(sv);
680 dVAR; dSP; dMARK; dTARGET;
682 do_join(TARG, *MARK, MARK, SP);
693 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
694 * will be enough to hold an OP*.
696 SV* const sv = sv_newmortal();
697 sv_upgrade(sv, SVt_PVLV);
699 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
707 /* Oversized hot code. */
711 dVAR; dSP; dMARK; dORIGMARK;
715 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
717 if (gv && (io = GvIO(gv))
718 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
721 if (MARK == ORIGMARK) {
722 /* If using default handle then we need to make space to
723 * pass object as 1st arg, so move other args up ...
727 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
731 *MARK = SvTIED_obj((SV*)io, mg);
734 call_method("PRINT", G_SCALAR);
742 if (!(io = GvIO(gv))) {
743 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
744 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
746 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
747 report_evil_fh(gv, io, PL_op->op_type);
748 SETERRNO(EBADF,RMS_IFI);
751 else if (!(fp = IoOFP(io))) {
752 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
754 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
755 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
756 report_evil_fh(gv, io, PL_op->op_type);
758 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
763 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
765 if (!do_print(*MARK, fp))
769 if (!do_print(PL_ofs_sv, fp)) { /* $, */
778 if (!do_print(*MARK, fp))
786 if (PL_op->op_type == OP_SAY) {
787 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
790 else if (PL_ors_sv && SvOK(PL_ors_sv))
791 if (!do_print(PL_ors_sv, fp)) /* $\ */
794 if (IoFLAGS(io) & IOf_FLUSH)
795 if (PerlIO_flush(fp) == EOF)
805 XPUSHs(&PL_sv_undef);
812 const I32 gimme = GIMME_V;
813 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
814 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
815 static const char an_array[] = "an ARRAY";
816 static const char a_hash[] = "a HASH";
817 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
818 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
822 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
825 if (SvTYPE(sv) != type)
826 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
827 if (PL_op->op_flags & OPf_REF) {
832 if (gimme != G_ARRAY)
833 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
834 : return_hash_to_lvalue_scalar);
838 else if (PL_op->op_flags & OPf_MOD
839 && PL_op->op_private & OPpLVAL_INTRO)
840 Perl_croak(aTHX_ PL_no_localize_ref);
843 if (SvTYPE(sv) == type) {
844 if (PL_op->op_flags & OPf_REF) {
849 if (gimme != G_ARRAY)
851 is_pp_rv2av ? return_array_to_lvalue_scalar
852 : return_hash_to_lvalue_scalar);
860 if (SvTYPE(sv) != SVt_PVGV) {
861 if (SvGMAGICAL(sv)) {
866 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
874 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
875 if (PL_op->op_private & OPpLVAL_INTRO)
876 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
877 if (PL_op->op_flags & OPf_REF) {
882 if (gimme != G_ARRAY)
884 is_pp_rv2av ? return_array_to_lvalue_scalar
885 : return_hash_to_lvalue_scalar);
893 AV *const av = (AV*)sv;
894 /* The guts of pp_rv2av, with no intenting change to preserve history
895 (until such time as we get tools that can do blame annotation across
896 whitespace changes. */
897 if (gimme == G_ARRAY) {
898 const I32 maxarg = AvFILL(av) + 1;
899 (void)POPs; /* XXXX May be optimized away? */
901 if (SvRMAGICAL(av)) {
903 for (i=0; i < (U32)maxarg; i++) {
904 SV ** const svp = av_fetch(av, i, FALSE);
905 /* See note in pp_helem, and bug id #27839 */
907 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
912 Copy(AvARRAY(av), SP+1, maxarg, SV*);
916 else if (gimme == G_SCALAR) {
918 const I32 maxarg = AvFILL(av) + 1;
922 /* The guts of pp_rv2hv */
923 if (gimme == G_ARRAY) { /* array wanted */
927 else if (gimme == G_SCALAR) {
929 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
938 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
945 if (ckWARN(WARN_MISC)) {
947 if (relem == firstrelem &&
949 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
950 SvTYPE(SvRV(*relem)) == SVt_PVHV))
952 err = "Reference found where even-sized list expected";
955 err = "Odd number of elements in hash assignment";
956 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
960 didstore = hv_store_ent(hash,*relem,tmpstr,0);
961 if (SvMAGICAL(hash)) {
962 if (SvSMAGICAL(tmpstr))
974 SV **lastlelem = PL_stack_sp;
975 SV **lastrelem = PL_stack_base + POPMARK;
976 SV **firstrelem = PL_stack_base + POPMARK + 1;
977 SV **firstlelem = lastrelem + 1;
990 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
992 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
995 /* If there's a common identifier on both sides we have to take
996 * special care that assigning the identifier on the left doesn't
997 * clobber a value on the right that's used later in the list.
999 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1000 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1001 for (relem = firstrelem; relem <= lastrelem; relem++) {
1002 if ((sv = *relem)) {
1003 TAINT_NOT; /* Each item is independent */
1004 *relem = sv_mortalcopy(sv);
1014 while (lelem <= lastlelem) {
1015 TAINT_NOT; /* Each item stands on its own, taintwise. */
1017 switch (SvTYPE(sv)) {
1020 magic = SvMAGICAL(ary) != 0;
1022 av_extend(ary, lastrelem - relem);
1024 while (relem <= lastrelem) { /* gobble up all the rest */
1027 sv = newSVsv(*relem);
1029 didstore = av_store(ary,i++,sv);
1038 if (PL_delaymagic & DM_ARRAY)
1039 SvSETMAGIC((SV*)ary);
1041 case SVt_PVHV: { /* normal hash */
1045 magic = SvMAGICAL(hash) != 0;
1047 firsthashrelem = relem;
1049 while (relem < lastrelem) { /* gobble up all the rest */
1051 sv = *relem ? *relem : &PL_sv_no;
1055 sv_setsv(tmpstr,*relem); /* value */
1056 *(relem++) = tmpstr;
1057 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1058 /* key overwrites an existing entry */
1060 didstore = hv_store_ent(hash,sv,tmpstr,0);
1062 if (SvSMAGICAL(tmpstr))
1069 if (relem == lastrelem) {
1070 do_oddball(hash, relem, firstrelem);
1076 if (SvIMMORTAL(sv)) {
1077 if (relem <= lastrelem)
1081 if (relem <= lastrelem) {
1082 sv_setsv(sv, *relem);
1086 sv_setsv(sv, &PL_sv_undef);
1091 if (PL_delaymagic & ~DM_DELAY) {
1092 if (PL_delaymagic & DM_UID) {
1093 #ifdef HAS_SETRESUID
1094 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1095 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1098 # ifdef HAS_SETREUID
1099 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1100 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1103 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1104 (void)setruid(PL_uid);
1105 PL_delaymagic &= ~DM_RUID;
1107 # endif /* HAS_SETRUID */
1109 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1110 (void)seteuid(PL_euid);
1111 PL_delaymagic &= ~DM_EUID;
1113 # endif /* HAS_SETEUID */
1114 if (PL_delaymagic & DM_UID) {
1115 if (PL_uid != PL_euid)
1116 DIE(aTHX_ "No setreuid available");
1117 (void)PerlProc_setuid(PL_uid);
1119 # endif /* HAS_SETREUID */
1120 #endif /* HAS_SETRESUID */
1121 PL_uid = PerlProc_getuid();
1122 PL_euid = PerlProc_geteuid();
1124 if (PL_delaymagic & DM_GID) {
1125 #ifdef HAS_SETRESGID
1126 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1127 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1130 # ifdef HAS_SETREGID
1131 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1132 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1135 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1136 (void)setrgid(PL_gid);
1137 PL_delaymagic &= ~DM_RGID;
1139 # endif /* HAS_SETRGID */
1141 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1142 (void)setegid(PL_egid);
1143 PL_delaymagic &= ~DM_EGID;
1145 # endif /* HAS_SETEGID */
1146 if (PL_delaymagic & DM_GID) {
1147 if (PL_gid != PL_egid)
1148 DIE(aTHX_ "No setregid available");
1149 (void)PerlProc_setgid(PL_gid);
1151 # endif /* HAS_SETREGID */
1152 #endif /* HAS_SETRESGID */
1153 PL_gid = PerlProc_getgid();
1154 PL_egid = PerlProc_getegid();
1156 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1160 if (gimme == G_VOID)
1161 SP = firstrelem - 1;
1162 else if (gimme == G_SCALAR) {
1165 SETi(lastrelem - firstrelem + 1 - duplicates);
1172 /* Removes from the stack the entries which ended up as
1173 * duplicated keys in the hash (fix for [perl #24380]) */
1174 Move(firsthashrelem + duplicates,
1175 firsthashrelem, duplicates, SV**);
1176 lastrelem -= duplicates;
1181 SP = firstrelem + (lastlelem - firstlelem);
1182 lelem = firstlelem + (relem - firstrelem);
1184 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1193 register PMOP * const pm = cPMOP;
1194 REGEXP * rx = PM_GETRE(pm);
1195 SV * const pkg = CALLREG_PACKAGE(rx);
1196 SV * const rv = sv_newmortal();
1198 SvUPGRADE(rv, SVt_IV);
1199 /* This RV is about to own a reference to the regexp. (In addition to the
1200 reference already owned by the PMOP. */
1206 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1207 (void)sv_bless(rv, stash);
1210 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1219 register PMOP *pm = cPMOP;
1221 register const char *t;
1222 register const char *s;
1225 I32 r_flags = REXEC_CHECKED;
1226 const char *truebase; /* Start of string */
1227 register REGEXP *rx = PM_GETRE(pm);
1229 const I32 gimme = GIMME;
1232 const I32 oldsave = PL_savestack_ix;
1233 I32 update_minmatch = 1;
1234 I32 had_zerolen = 0;
1237 if (PL_op->op_flags & OPf_STACKED)
1239 else if (PL_op->op_private & OPpTARGET_MY)
1246 PUTBACK; /* EVAL blocks need stack_sp. */
1247 s = SvPV_const(TARG, len);
1249 DIE(aTHX_ "panic: pp_match");
1251 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1252 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1255 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1257 /* PMdf_USED is set after a ?? matches once */
1260 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1262 pm->op_pmflags & PMf_USED
1266 if (gimme == G_ARRAY)
1273 /* empty pattern special-cased to use last successful pattern if possible */
1274 if (!RX_PRELEN(rx) && PL_curpm) {
1279 if (RX_MINLEN(rx) > (I32)len)
1284 /* XXXX What part of this is needed with true \G-support? */
1285 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1286 RX_OFFS(rx)[0].start = -1;
1287 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1288 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1289 if (mg && mg->mg_len >= 0) {
1290 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1291 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1292 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1293 r_flags |= REXEC_IGNOREPOS;
1294 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1295 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1298 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1299 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1300 update_minmatch = 0;
1304 /* XXX: comment out !global get safe $1 vars after a
1305 match, BUT be aware that this leads to dramatic slowdowns on
1306 /g matches against large strings. So far a solution to this problem
1307 appears to be quite tricky.
1308 Test for the unsafe vars are TODO for now. */
1309 if (( !global && RX_NPARENS(rx))
1310 || SvTEMP(TARG) || PL_sawampersand ||
1311 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1312 r_flags |= REXEC_COPY_STR;
1314 r_flags |= REXEC_SCREAM;
1317 if (global && RX_OFFS(rx)[0].start != -1) {
1318 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1319 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1321 if (update_minmatch++)
1322 minmatch = had_zerolen;
1324 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1325 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1326 /* FIXME - can PL_bostr be made const char *? */
1327 PL_bostr = (char *)truebase;
1328 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1332 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1334 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1335 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1336 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1337 && (r_flags & REXEC_SCREAM)))
1338 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1341 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1342 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1345 if (dynpm->op_pmflags & PMf_ONCE) {
1347 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1349 dynpm->op_pmflags |= PMf_USED;
1360 RX_MATCH_TAINTED_on(rx);
1361 TAINT_IF(RX_MATCH_TAINTED(rx));
1362 if (gimme == G_ARRAY) {
1363 const I32 nparens = RX_NPARENS(rx);
1364 I32 i = (global && !nparens) ? 1 : 0;
1366 SPAGAIN; /* EVAL blocks could move the stack. */
1367 EXTEND(SP, nparens + i);
1368 EXTEND_MORTAL(nparens + i);
1369 for (i = !i; i <= nparens; i++) {
1370 PUSHs(sv_newmortal());
1371 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1372 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1373 s = RX_OFFS(rx)[i].start + truebase;
1374 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1375 len < 0 || len > strend - s)
1376 DIE(aTHX_ "panic: pp_match start/end pointers");
1377 sv_setpvn(*SP, s, len);
1378 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1383 if (dynpm->op_pmflags & PMf_CONTINUE) {
1385 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1386 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1388 #ifdef PERL_OLD_COPY_ON_WRITE
1390 sv_force_normal_flags(TARG, 0);
1392 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1393 &PL_vtbl_mglob, NULL, 0);
1395 if (RX_OFFS(rx)[0].start != -1) {
1396 mg->mg_len = RX_OFFS(rx)[0].end;
1397 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1398 mg->mg_flags |= MGf_MINMATCH;
1400 mg->mg_flags &= ~MGf_MINMATCH;
1403 had_zerolen = (RX_OFFS(rx)[0].start != -1
1404 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1405 == (UV)RX_OFFS(rx)[0].end));
1406 PUTBACK; /* EVAL blocks may use stack */
1407 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1412 LEAVE_SCOPE(oldsave);
1418 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1419 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1423 #ifdef PERL_OLD_COPY_ON_WRITE
1425 sv_force_normal_flags(TARG, 0);
1427 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1428 &PL_vtbl_mglob, NULL, 0);
1430 if (RX_OFFS(rx)[0].start != -1) {
1431 mg->mg_len = RX_OFFS(rx)[0].end;
1432 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1433 mg->mg_flags |= MGf_MINMATCH;
1435 mg->mg_flags &= ~MGf_MINMATCH;
1438 LEAVE_SCOPE(oldsave);
1442 yup: /* Confirmed by INTUIT */
1444 RX_MATCH_TAINTED_on(rx);
1445 TAINT_IF(RX_MATCH_TAINTED(rx));
1447 if (dynpm->op_pmflags & PMf_ONCE) {
1449 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1451 dynpm->op_pmflags |= PMf_USED;
1454 if (RX_MATCH_COPIED(rx))
1455 Safefree(RX_SUBBEG(rx));
1456 RX_MATCH_COPIED_off(rx);
1457 RX_SUBBEG(rx) = NULL;
1459 /* FIXME - should rx->subbeg be const char *? */
1460 RX_SUBBEG(rx) = (char *) truebase;
1461 RX_OFFS(rx)[0].start = s - truebase;
1462 if (RX_MATCH_UTF8(rx)) {
1463 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1464 RX_OFFS(rx)[0].end = t - truebase;
1467 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1469 RX_SUBLEN(rx) = strend - truebase;
1472 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1474 #ifdef PERL_OLD_COPY_ON_WRITE
1475 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1477 PerlIO_printf(Perl_debug_log,
1478 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1479 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1482 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1484 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1485 assert (SvPOKp(RX_SAVED_COPY(rx)));
1490 RX_SUBBEG(rx) = savepvn(t, strend - t);
1491 #ifdef PERL_OLD_COPY_ON_WRITE
1492 RX_SAVED_COPY(rx) = NULL;
1495 RX_SUBLEN(rx) = strend - t;
1496 RX_MATCH_COPIED_on(rx);
1497 off = RX_OFFS(rx)[0].start = s - t;
1498 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1500 else { /* startp/endp are used by @- @+. */
1501 RX_OFFS(rx)[0].start = s - truebase;
1502 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1504 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1506 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1507 LEAVE_SCOPE(oldsave);
1512 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1513 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1514 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1519 LEAVE_SCOPE(oldsave);
1520 if (gimme == G_ARRAY)
1526 Perl_do_readline(pTHX)
1528 dVAR; dSP; dTARGETSTACKED;
1533 register IO * const io = GvIO(PL_last_in_gv);
1534 register const I32 type = PL_op->op_type;
1535 const I32 gimme = GIMME_V;
1538 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1541 XPUSHs(SvTIED_obj((SV*)io, mg));
1544 call_method("READLINE", gimme);
1547 if (gimme == G_SCALAR) {
1548 SV* const result = POPs;
1549 SvSetSV_nosteal(TARG, result);
1559 if (IoFLAGS(io) & IOf_ARGV) {
1560 if (IoFLAGS(io) & IOf_START) {
1562 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1563 IoFLAGS(io) &= ~IOf_START;
1564 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1565 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1566 SvSETMAGIC(GvSV(PL_last_in_gv));
1571 fp = nextargv(PL_last_in_gv);
1572 if (!fp) { /* Note: fp != IoIFP(io) */
1573 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1576 else if (type == OP_GLOB)
1577 fp = Perl_start_glob(aTHX_ POPs, io);
1579 else if (type == OP_GLOB)
1581 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1582 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1586 if ((!io || !(IoFLAGS(io) & IOf_START))
1587 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1589 if (type == OP_GLOB)
1590 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1591 "glob failed (can't start child: %s)",
1594 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1596 if (gimme == G_SCALAR) {
1597 /* undef TARG, and push that undefined value */
1598 if (type != OP_RCATLINE) {
1599 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1607 if (gimme == G_SCALAR) {
1609 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1612 if (type == OP_RCATLINE)
1613 SvPV_force_nolen(sv);
1617 else if (isGV_with_GP(sv)) {
1618 SvPV_force_nolen(sv);
1620 SvUPGRADE(sv, SVt_PV);
1621 tmplen = SvLEN(sv); /* remember if already alloced */
1622 if (!tmplen && !SvREADONLY(sv))
1623 Sv_Grow(sv, 80); /* try short-buffering it */
1625 if (type == OP_RCATLINE && SvOK(sv)) {
1627 SvPV_force_nolen(sv);
1633 sv = sv_2mortal(newSV(80));
1637 /* This should not be marked tainted if the fp is marked clean */
1638 #define MAYBE_TAINT_LINE(io, sv) \
1639 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1644 /* delay EOF state for a snarfed empty file */
1645 #define SNARF_EOF(gimme,rs,io,sv) \
1646 (gimme != G_SCALAR || SvCUR(sv) \
1647 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1651 if (!sv_gets(sv, fp, offset)
1653 || SNARF_EOF(gimme, PL_rs, io, sv)
1654 || PerlIO_error(fp)))
1656 PerlIO_clearerr(fp);
1657 if (IoFLAGS(io) & IOf_ARGV) {
1658 fp = nextargv(PL_last_in_gv);
1661 (void)do_close(PL_last_in_gv, FALSE);
1663 else if (type == OP_GLOB) {
1664 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1665 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1666 "glob failed (child exited with status %d%s)",
1667 (int)(STATUS_CURRENT >> 8),
1668 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1671 if (gimme == G_SCALAR) {
1672 if (type != OP_RCATLINE) {
1673 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1679 MAYBE_TAINT_LINE(io, sv);
1682 MAYBE_TAINT_LINE(io, sv);
1684 IoFLAGS(io) |= IOf_NOLINE;
1688 if (type == OP_GLOB) {
1691 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1692 char * const tmps = SvEND(sv) - 1;
1693 if (*tmps == *SvPVX_const(PL_rs)) {
1695 SvCUR_set(sv, SvCUR(sv) - 1);
1698 for (t1 = SvPVX_const(sv); *t1; t1++)
1699 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1700 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1702 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1703 (void)POPs; /* Unmatched wildcard? Chuck it... */
1706 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1707 if (ckWARN(WARN_UTF8)) {
1708 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1709 const STRLEN len = SvCUR(sv) - offset;
1712 if (!is_utf8_string_loc(s, len, &f))
1713 /* Emulate :encoding(utf8) warning in the same case. */
1714 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1715 "utf8 \"\\x%02X\" does not map to Unicode",
1716 f < (U8*)SvEND(sv) ? *f : 0);
1719 if (gimme == G_ARRAY) {
1720 if (SvLEN(sv) - SvCUR(sv) > 20) {
1721 SvPV_shrink_to_cur(sv);
1723 sv = sv_2mortal(newSV(80));
1726 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1727 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1728 const STRLEN new_len
1729 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1730 SvPV_renew(sv, new_len);
1739 register PERL_CONTEXT *cx;
1740 I32 gimme = OP_GIMME(PL_op, -1);
1743 if (cxstack_ix >= 0)
1744 gimme = cxstack[cxstack_ix].blk_gimme;
1752 PUSHBLOCK(cx, CXt_BLOCK, SP);
1762 SV * const keysv = POPs;
1763 HV * const hv = (HV*)POPs;
1764 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1765 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1767 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1770 if (SvTYPE(hv) != SVt_PVHV)
1773 if (PL_op->op_private & OPpLVAL_INTRO) {
1776 /* does the element we're localizing already exist? */
1777 preeminent = /* can we determine whether it exists? */
1779 || mg_find((SV*)hv, PERL_MAGIC_env)
1780 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1781 /* Try to preserve the existenceness of a tied hash
1782 * element by using EXISTS and DELETE if possible.
1783 * Fallback to FETCH and STORE otherwise */
1784 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1785 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1786 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1788 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1790 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1791 svp = he ? &HeVAL(he) : NULL;
1793 if (!svp || *svp == &PL_sv_undef) {
1797 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1799 lv = sv_newmortal();
1800 sv_upgrade(lv, SVt_PVLV);
1802 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1803 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1804 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1809 if (PL_op->op_private & OPpLVAL_INTRO) {
1810 if (HvNAME_get(hv) && isGV(*svp))
1811 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1815 const char * const key = SvPV_const(keysv, keylen);
1816 SAVEDELETE(hv, savepvn(key,keylen),
1817 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1819 save_helem(hv, keysv, svp);
1822 else if (PL_op->op_private & OPpDEREF)
1823 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1825 sv = (svp ? *svp : &PL_sv_undef);
1826 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1827 * Pushing the magical RHS on to the stack is useless, since
1828 * that magic is soon destined to be misled by the local(),
1829 * and thus the later pp_sassign() will fail to mg_get() the
1830 * old value. This should also cure problems with delayed
1831 * mg_get()s. GSAR 98-07-03 */
1832 if (!lval && SvGMAGICAL(sv))
1833 sv = sv_mortalcopy(sv);
1841 register PERL_CONTEXT *cx;
1846 if (PL_op->op_flags & OPf_SPECIAL) {
1847 cx = &cxstack[cxstack_ix];
1848 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1853 gimme = OP_GIMME(PL_op, -1);
1855 if (cxstack_ix >= 0)
1856 gimme = cxstack[cxstack_ix].blk_gimme;
1862 if (gimme == G_VOID)
1864 else if (gimme == G_SCALAR) {
1868 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1871 *MARK = sv_mortalcopy(TOPs);
1874 *MARK = &PL_sv_undef;
1878 else if (gimme == G_ARRAY) {
1879 /* in case LEAVE wipes old return values */
1881 for (mark = newsp + 1; mark <= SP; mark++) {
1882 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1883 *mark = sv_mortalcopy(*mark);
1884 TAINT_NOT; /* Each item is independent */
1888 PL_curpm = newpm; /* Don't pop $1 et al till now */
1898 register PERL_CONTEXT *cx;
1904 cx = &cxstack[cxstack_ix];
1905 if (CxTYPE(cx) != CXt_LOOP)
1906 DIE(aTHX_ "panic: pp_iter");
1908 itersvp = CxITERVAR(cx);
1909 av = cx->blk_loop.iterary;
1910 if (SvTYPE(av) != SVt_PVAV) {
1911 /* iterate ($min .. $max) */
1912 if (cx->blk_loop.iterlval) {
1913 /* string increment */
1914 register SV* cur = cx->blk_loop.iterlval;
1918 SvPV_const((SV*)av, maxlen) : (const char *)"";
1919 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1920 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1921 /* safe to reuse old SV */
1922 sv_setsv(*itersvp, cur);
1926 /* we need a fresh SV every time so that loop body sees a
1927 * completely new SV for closures/references to work as
1930 *itersvp = newSVsv(cur);
1931 SvREFCNT_dec(oldsv);
1933 if (strEQ(SvPVX_const(cur), max))
1934 sv_setiv(cur, 0); /* terminate next time */
1941 /* integer increment */
1942 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1945 /* don't risk potential race */
1946 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1947 /* safe to reuse old SV */
1948 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1952 /* we need a fresh SV every time so that loop body sees a
1953 * completely new SV for closures/references to work as they
1956 *itersvp = newSViv(cx->blk_loop.iterix++);
1957 SvREFCNT_dec(oldsv);
1963 if (PL_op->op_private & OPpITER_REVERSED) {
1964 /* In reverse, use itermax as the min :-) */
1965 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1968 if (SvMAGICAL(av) || AvREIFY(av)) {
1969 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1970 sv = svp ? *svp : NULL;
1973 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1977 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1981 if (SvMAGICAL(av) || AvREIFY(av)) {
1982 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1983 sv = svp ? *svp : NULL;
1986 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1990 if (sv && SvIS_FREED(sv)) {
1992 Perl_croak(aTHX_ "Use of freed value in iteration");
1999 if (av != PL_curstack && sv == &PL_sv_undef) {
2000 SV *lv = cx->blk_loop.iterlval;
2001 if (lv && SvREFCNT(lv) > 1) {
2006 SvREFCNT_dec(LvTARG(lv));
2008 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
2010 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2012 LvTARG(lv) = SvREFCNT_inc_simple(av);
2013 LvTARGOFF(lv) = cx->blk_loop.iterix;
2014 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2019 *itersvp = SvREFCNT_inc_simple_NN(sv);
2020 SvREFCNT_dec(oldsv);
2028 register PMOP *pm = cPMOP;
2043 register REGEXP *rx = PM_GETRE(pm);
2045 int force_on_match = 0;
2046 const I32 oldsave = PL_savestack_ix;
2048 bool doutf8 = FALSE;
2050 #ifdef PERL_OLD_COPY_ON_WRITE
2055 /* known replacement string? */
2056 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2057 if (PL_op->op_flags & OPf_STACKED)
2059 else if (PL_op->op_private & OPpTARGET_MY)
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2067 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2068 because they make integers such as 256 "false". */
2069 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2072 sv_force_normal_flags(TARG,0);
2075 #ifdef PERL_OLD_COPY_ON_WRITE
2079 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2080 || SvTYPE(TARG) > SVt_PVLV)
2081 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2082 DIE(aTHX_ PL_no_modify);
2085 s = SvPV_mutable(TARG, len);
2086 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2088 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2089 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2094 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2098 DIE(aTHX_ "panic: pp_subst");
2101 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2102 maxiters = 2 * slen + 10; /* We can match twice at each
2103 position, once with zero-length,
2104 second time with non-zero. */
2106 if (!RX_PRELEN(rx) && PL_curpm) {
2110 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2111 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2112 ? REXEC_COPY_STR : 0;
2114 r_flags |= REXEC_SCREAM;
2117 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2119 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2123 /* How to do it in subst? */
2124 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2126 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2127 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2128 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2129 && (r_flags & REXEC_SCREAM))))
2134 /* only replace once? */
2135 once = !(rpm->op_pmflags & PMf_GLOBAL);
2136 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2137 r_flags | REXEC_CHECKED);
2138 /* known replacement string? */
2140 /* replacement needing upgrading? */
2141 if (DO_UTF8(TARG) && !doutf8) {
2142 nsv = sv_newmortal();
2145 sv_recode_to_utf8(nsv, PL_encoding);
2147 sv_utf8_upgrade(nsv);
2148 c = SvPV_const(nsv, clen);
2152 c = SvPV_const(dstr, clen);
2153 doutf8 = DO_UTF8(dstr);
2161 /* can do inplace substitution? */
2163 #ifdef PERL_OLD_COPY_ON_WRITE
2166 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2167 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2168 && (!doutf8 || SvUTF8(TARG))) {
2173 LEAVE_SCOPE(oldsave);
2176 #ifdef PERL_OLD_COPY_ON_WRITE
2177 if (SvIsCOW(TARG)) {
2178 assert (!force_on_match);
2182 if (force_on_match) {
2184 s = SvPV_force(TARG, len);
2189 SvSCREAM_off(TARG); /* disable possible screamer */
2191 rxtainted |= RX_MATCH_TAINTED(rx);
2192 m = orig + RX_OFFS(rx)[0].start;
2193 d = orig + RX_OFFS(rx)[0].end;
2195 if (m - s > strend - d) { /* faster to shorten from end */
2197 Copy(c, m, clen, char);
2202 Move(d, m, i, char);
2206 SvCUR_set(TARG, m - s);
2208 else if ((i = m - s)) { /* faster from front */
2211 Move(s, d - i, i, char);
2214 Copy(c, m, clen, char);
2219 Copy(c, d, clen, char);
2224 TAINT_IF(rxtainted & 1);
2230 if (iters++ > maxiters)
2231 DIE(aTHX_ "Substitution loop");
2232 rxtainted |= RX_MATCH_TAINTED(rx);
2233 m = RX_OFFS(rx)[0].start + orig;
2236 Move(s, d, i, char);
2240 Copy(c, d, clen, char);
2243 s = RX_OFFS(rx)[0].end + orig;
2244 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2246 /* don't match same null twice */
2247 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2250 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2251 Move(s, d, i+1, char); /* include the NUL */
2253 TAINT_IF(rxtainted & 1);
2257 (void)SvPOK_only_UTF8(TARG);
2258 TAINT_IF(rxtainted);
2259 if (SvSMAGICAL(TARG)) {
2267 LEAVE_SCOPE(oldsave);
2273 if (force_on_match) {
2275 s = SvPV_force(TARG, len);
2278 #ifdef PERL_OLD_COPY_ON_WRITE
2281 rxtainted |= RX_MATCH_TAINTED(rx);
2282 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2286 register PERL_CONTEXT *cx;
2289 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2291 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2293 if (iters++ > maxiters)
2294 DIE(aTHX_ "Substitution loop");
2295 rxtainted |= RX_MATCH_TAINTED(rx);
2296 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2299 orig = RX_SUBBEG(rx);
2301 strend = s + (strend - m);
2303 m = RX_OFFS(rx)[0].start + orig;
2304 if (doutf8 && !SvUTF8(dstr))
2305 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2307 sv_catpvn(dstr, s, m-s);
2308 s = RX_OFFS(rx)[0].end + orig;
2310 sv_catpvn(dstr, c, clen);
2313 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2314 TARG, NULL, r_flags));
2315 if (doutf8 && !DO_UTF8(TARG))
2316 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2318 sv_catpvn(dstr, s, strend - s);
2320 #ifdef PERL_OLD_COPY_ON_WRITE
2321 /* The match may make the string COW. If so, brilliant, because that's
2322 just saved us one malloc, copy and free - the regexp has donated
2323 the old buffer, and we malloc an entirely new one, rather than the
2324 regexp malloc()ing a buffer and copying our original, only for
2325 us to throw it away here during the substitution. */
2326 if (SvIsCOW(TARG)) {
2327 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2333 SvPV_set(TARG, SvPVX(dstr));
2334 SvCUR_set(TARG, SvCUR(dstr));
2335 SvLEN_set(TARG, SvLEN(dstr));
2336 doutf8 |= DO_UTF8(dstr);
2337 SvPV_set(dstr, NULL);
2339 TAINT_IF(rxtainted & 1);
2343 (void)SvPOK_only(TARG);
2346 TAINT_IF(rxtainted);
2349 LEAVE_SCOPE(oldsave);
2358 LEAVE_SCOPE(oldsave);
2367 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2368 ++*PL_markstack_ptr;
2369 LEAVE; /* exit inner scope */
2372 if (PL_stack_base + *PL_markstack_ptr > SP) {
2374 const I32 gimme = GIMME_V;
2376 LEAVE; /* exit outer scope */
2377 (void)POPMARK; /* pop src */
2378 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2379 (void)POPMARK; /* pop dst */
2380 SP = PL_stack_base + POPMARK; /* pop original mark */
2381 if (gimme == G_SCALAR) {
2382 if (PL_op->op_private & OPpGREP_LEX) {
2383 SV* const sv = sv_newmortal();
2384 sv_setiv(sv, items);
2392 else if (gimme == G_ARRAY)
2399 ENTER; /* enter inner scope */
2402 src = PL_stack_base[*PL_markstack_ptr];
2404 if (PL_op->op_private & OPpGREP_LEX)
2405 PAD_SVl(PL_op->op_targ) = src;
2409 RETURNOP(cLOGOP->op_other);
2420 register PERL_CONTEXT *cx;
2423 if (CxMULTICALL(&cxstack[cxstack_ix]))
2427 cxstack_ix++; /* temporarily protect top context */
2430 if (gimme == G_SCALAR) {
2433 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2435 *MARK = SvREFCNT_inc(TOPs);
2440 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2442 *MARK = sv_mortalcopy(sv);
2447 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2451 *MARK = &PL_sv_undef;
2455 else if (gimme == G_ARRAY) {
2456 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2457 if (!SvTEMP(*MARK)) {
2458 *MARK = sv_mortalcopy(*MARK);
2459 TAINT_NOT; /* Each item is independent */
2467 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2468 PL_curpm = newpm; /* ... and pop $1 et al */
2471 return cx->blk_sub.retop;
2474 /* This duplicates the above code because the above code must not
2475 * get any slower by more conditions */
2483 register PERL_CONTEXT *cx;
2486 if (CxMULTICALL(&cxstack[cxstack_ix]))
2490 cxstack_ix++; /* temporarily protect top context */
2494 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2495 /* We are an argument to a function or grep().
2496 * This kind of lvalueness was legal before lvalue
2497 * subroutines too, so be backward compatible:
2498 * cannot report errors. */
2500 /* Scalar context *is* possible, on the LHS of -> only,
2501 * as in f()->meth(). But this is not an lvalue. */
2502 if (gimme == G_SCALAR)
2504 if (gimme == G_ARRAY) {
2505 if (!CvLVALUE(cx->blk_sub.cv))
2506 goto temporise_array;
2507 EXTEND_MORTAL(SP - newsp);
2508 for (mark = newsp + 1; mark <= SP; mark++) {
2511 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2512 *mark = sv_mortalcopy(*mark);
2514 /* Can be a localized value subject to deletion. */
2515 PL_tmps_stack[++PL_tmps_ix] = *mark;
2516 SvREFCNT_inc_void(*mark);
2521 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2522 /* Here we go for robustness, not for speed, so we change all
2523 * the refcounts so the caller gets a live guy. Cannot set
2524 * TEMP, so sv_2mortal is out of question. */
2525 if (!CvLVALUE(cx->blk_sub.cv)) {
2531 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2533 if (gimme == G_SCALAR) {
2537 /* Temporaries are bad unless they happen to be elements
2538 * of a tied hash or array */
2539 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2540 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2546 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2547 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2548 : "a readonly value" : "a temporary");
2550 else { /* Can be a localized value
2551 * subject to deletion. */
2552 PL_tmps_stack[++PL_tmps_ix] = *mark;
2553 SvREFCNT_inc_void(*mark);
2556 else { /* Should not happen? */
2562 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2563 (MARK > SP ? "Empty array" : "Array"));
2567 else if (gimme == G_ARRAY) {
2568 EXTEND_MORTAL(SP - newsp);
2569 for (mark = newsp + 1; mark <= SP; mark++) {
2570 if (*mark != &PL_sv_undef
2571 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2572 /* Might be flattened array after $#array = */
2579 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2580 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2583 /* Can be a localized value subject to deletion. */
2584 PL_tmps_stack[++PL_tmps_ix] = *mark;
2585 SvREFCNT_inc_void(*mark);
2591 if (gimme == G_SCALAR) {
2595 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2597 *MARK = SvREFCNT_inc(TOPs);
2602 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2604 *MARK = sv_mortalcopy(sv);
2609 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2613 *MARK = &PL_sv_undef;
2617 else if (gimme == G_ARRAY) {
2619 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2620 if (!SvTEMP(*MARK)) {
2621 *MARK = sv_mortalcopy(*MARK);
2622 TAINT_NOT; /* Each item is independent */
2631 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2632 PL_curpm = newpm; /* ... and pop $1 et al */
2635 return cx->blk_sub.retop;
2643 register PERL_CONTEXT *cx;
2645 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2648 DIE(aTHX_ "Not a CODE reference");
2649 switch (SvTYPE(sv)) {
2650 /* This is overwhelming the most common case: */
2652 if (!(cv = GvCVu((GV*)sv))) {
2654 cv = sv_2cv(sv, &stash, &gv, 0);
2666 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2668 SP = PL_stack_base + POPMARK;
2671 if (SvGMAGICAL(sv)) {
2676 sym = SvPVX_const(sv);
2684 sym = SvPV_const(sv, len);
2687 DIE(aTHX_ PL_no_usym, "a subroutine");
2688 if (PL_op->op_private & HINT_STRICT_REFS)
2689 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2690 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2695 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2696 tryAMAGICunDEREF(to_cv);
2699 if (SvTYPE(cv) == SVt_PVCV)
2704 DIE(aTHX_ "Not a CODE reference");
2705 /* This is the second most common case: */
2715 if (!CvROOT(cv) && !CvXSUB(cv)) {
2719 /* anonymous or undef'd function leaves us no recourse */
2720 if (CvANON(cv) || !(gv = CvGV(cv)))
2721 DIE(aTHX_ "Undefined subroutine called");
2723 /* autoloaded stub? */
2724 if (cv != GvCV(gv)) {
2727 /* should call AUTOLOAD now? */
2730 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2737 sub_name = sv_newmortal();
2738 gv_efullname3(sub_name, gv, NULL);
2739 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2743 DIE(aTHX_ "Not a CODE reference");
2748 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2749 Perl_get_db_sub(aTHX_ &sv, cv);
2751 PL_curcopdb = PL_curcop;
2752 cv = GvCV(PL_DBsub);
2754 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2755 DIE(aTHX_ "No DB::sub routine defined");
2758 if (!(CvISXSUB(cv))) {
2759 /* This path taken at least 75% of the time */
2761 register I32 items = SP - MARK;
2762 AV* const padlist = CvPADLIST(cv);
2763 PUSHBLOCK(cx, CXt_SUB, MARK);
2765 cx->blk_sub.retop = PL_op->op_next;
2767 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2768 * that eval'' ops within this sub know the correct lexical space.
2769 * Owing the speed considerations, we choose instead to search for
2770 * the cv using find_runcv() when calling doeval().
2772 if (CvDEPTH(cv) >= 2) {
2773 PERL_STACK_OVERFLOW_CHECK();
2774 pad_push(padlist, CvDEPTH(cv));
2777 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2779 AV* const av = (AV*)PAD_SVl(0);
2781 /* @_ is normally not REAL--this should only ever
2782 * happen when DB::sub() calls things that modify @_ */
2787 cx->blk_sub.savearray = GvAV(PL_defgv);
2788 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2789 CX_CURPAD_SAVE(cx->blk_sub);
2790 cx->blk_sub.argarray = av;
2793 if (items > AvMAX(av) + 1) {
2794 SV **ary = AvALLOC(av);
2795 if (AvARRAY(av) != ary) {
2796 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2799 if (items > AvMAX(av) + 1) {
2800 AvMAX(av) = items - 1;
2801 Renew(ary,items,SV*);
2806 Copy(MARK,AvARRAY(av),items,SV*);
2807 AvFILLp(av) = items - 1;
2815 /* warning must come *after* we fully set up the context
2816 * stuff so that __WARN__ handlers can safely dounwind()
2819 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2820 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2821 sub_crush_depth(cv);
2823 DEBUG_S(PerlIO_printf(Perl_debug_log,
2824 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2826 RETURNOP(CvSTART(cv));
2829 I32 markix = TOPMARK;
2834 /* Need to copy @_ to stack. Alternative may be to
2835 * switch stack to @_, and copy return values
2836 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2837 AV * const av = GvAV(PL_defgv);
2838 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2841 /* Mark is at the end of the stack. */
2843 Copy(AvARRAY(av), SP + 1, items, SV*);
2848 /* We assume first XSUB in &DB::sub is the called one. */
2850 SAVEVPTR(PL_curcop);
2851 PL_curcop = PL_curcopdb;
2854 /* Do we need to open block here? XXXX */
2855 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2856 (void)(*CvXSUB(cv))(aTHX_ cv);
2858 /* Enforce some sanity in scalar context. */
2859 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2860 if (markix > PL_stack_sp - PL_stack_base)
2861 *(PL_stack_base + markix) = &PL_sv_undef;
2863 *(PL_stack_base + markix) = *PL_stack_sp;
2864 PL_stack_sp = PL_stack_base + markix;
2872 Perl_sub_crush_depth(pTHX_ CV *cv)
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)
2950 Perl_croak(aTHX_ PL_no_modify);
2951 prepare_SV_for_RV(sv);
2954 SvRV_set(sv, newSV(0));
2957 SvRV_set(sv, (SV*)newAV());
2960 SvRV_set(sv, (SV*)newHV());
2971 SV* const sv = TOPs;
2974 SV* const rsv = SvRV(sv);
2975 if (SvTYPE(rsv) == SVt_PVCV) {
2981 SETs(method_common(sv, NULL));
2988 SV* const sv = cSVOP_sv;
2989 U32 hash = SvSHARED_HASH(sv);
2991 XPUSHs(method_common(sv, &hash));
2996 S_method_common(pTHX_ SV* meth, U32* hashp)
3003 const char* packname = NULL;
3006 const char * const name = SvPV_const(meth, namelen);
3007 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3010 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3018 /* this isn't a reference */
3019 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3020 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3022 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3029 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3030 !(ob=(SV*)GvIO(iogv)))
3032 /* this isn't the name of a filehandle either */
3034 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3035 ? !isIDFIRST_utf8((U8*)packname)
3036 : !isIDFIRST(*packname)
3039 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3040 SvOK(sv) ? "without a package or object reference"
3041 : "on an undefined value");
3043 /* assume it's a package name */
3044 stash = gv_stashpvn(packname, packlen, 0);
3048 SV* const ref = newSViv(PTR2IV(stash));
3049 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3053 /* it _is_ a filehandle name -- replace with a reference */
3054 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3057 /* if we got here, ob should be a reference or a glob */
3058 if (!ob || !(SvOBJECT(ob)
3059 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3062 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3063 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3067 stash = SvSTASH(ob);
3070 /* NOTE: stash may be null, hope hv_fetch_ent and
3071 gv_fetchmethod can cope (it seems they can) */
3073 /* shortcut for simple names */
3075 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3077 gv = (GV*)HeVAL(he);
3078 if (isGV(gv) && GvCV(gv) &&
3079 (!GvCVGEN(gv) || GvCVGEN(gv)
3080 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3081 return (SV*)GvCV(gv);
3085 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3088 /* This code tries to figure out just what went wrong with
3089 gv_fetchmethod. It therefore needs to duplicate a lot of
3090 the internals of that function. We can't move it inside
3091 Perl_gv_fetchmethod_autoload(), however, since that would
3092 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3095 const char* leaf = name;
3096 const char* sep = NULL;
3099 for (p = name; *p; p++) {
3101 sep = p, leaf = p + 1;
3102 else if (*p == ':' && *(p + 1) == ':')
3103 sep = p, leaf = p + 2;
3105 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3106 /* the method name is unqualified or starts with SUPER:: */
3107 #ifndef USE_ITHREADS
3109 stash = CopSTASH(PL_curcop);
3111 bool need_strlen = 1;
3113 packname = CopSTASHPV(PL_curcop);
3118 HEK * const packhek = HvNAME_HEK(stash);
3120 packname = HEK_KEY(packhek);
3121 packlen = HEK_LEN(packhek);
3133 "Can't use anonymous symbol table for method lookup");
3137 packlen = strlen(packname);
3142 /* the method name is qualified */
3144 packlen = sep - name;
3147 /* we're relying on gv_fetchmethod not autovivifying the stash */
3148 if (gv_stashpvn(packname, packlen, 0)) {
3150 "Can't locate object method \"%s\" via package \"%.*s\"",
3151 leaf, (int)packlen, packname);
3155 "Can't locate object method \"%s\" via package \"%.*s\""
3156 " (perhaps you forgot to load \"%.*s\"?)",
3157 leaf, (int)packlen, packname, (int)packlen, packname);
3160 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3165 * c-indentation-style: bsd
3167 * indent-tabs-mode: t
3170 * ex: set ts=8 sts=4 sw=4 noet: