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 if( PL_op->op_type == OP_SAY ) {
735 /* local $\ = "\n" */
736 SAVEGENERICSV(PL_ors_sv);
737 PL_ors_sv = newSVpvs("\n");
739 call_method("PRINT", G_SCALAR);
747 if (!(io = GvIO(gv))) {
748 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
749 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
751 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
752 report_evil_fh(gv, io, PL_op->op_type);
753 SETERRNO(EBADF,RMS_IFI);
756 else if (!(fp = IoOFP(io))) {
757 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
759 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
760 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
761 report_evil_fh(gv, io, PL_op->op_type);
763 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
768 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
770 if (!do_print(*MARK, fp))
774 if (!do_print(PL_ofs_sv, fp)) { /* $, */
783 if (!do_print(*MARK, fp))
791 if (PL_op->op_type == OP_SAY) {
792 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
795 else if (PL_ors_sv && SvOK(PL_ors_sv))
796 if (!do_print(PL_ors_sv, fp)) /* $\ */
799 if (IoFLAGS(io) & IOf_FLUSH)
800 if (PerlIO_flush(fp) == EOF)
810 XPUSHs(&PL_sv_undef);
817 const I32 gimme = GIMME_V;
818 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
819 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
820 static const char an_array[] = "an ARRAY";
821 static const char a_hash[] = "a HASH";
822 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
823 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
827 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
830 if (SvTYPE(sv) != type)
831 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
832 if (PL_op->op_flags & OPf_REF) {
837 if (gimme != G_ARRAY)
838 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
839 : return_hash_to_lvalue_scalar);
843 else if (PL_op->op_flags & OPf_MOD
844 && PL_op->op_private & OPpLVAL_INTRO)
845 Perl_croak(aTHX_ PL_no_localize_ref);
848 if (SvTYPE(sv) == type) {
849 if (PL_op->op_flags & OPf_REF) {
854 if (gimme != G_ARRAY)
856 is_pp_rv2av ? return_array_to_lvalue_scalar
857 : return_hash_to_lvalue_scalar);
865 if (SvTYPE(sv) != SVt_PVGV) {
866 if (SvGMAGICAL(sv)) {
871 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
879 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
880 if (PL_op->op_private & OPpLVAL_INTRO)
881 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
882 if (PL_op->op_flags & OPf_REF) {
887 if (gimme != G_ARRAY)
889 is_pp_rv2av ? return_array_to_lvalue_scalar
890 : return_hash_to_lvalue_scalar);
898 AV *const av = (AV*)sv;
899 /* The guts of pp_rv2av, with no intenting change to preserve history
900 (until such time as we get tools that can do blame annotation across
901 whitespace changes. */
902 if (gimme == G_ARRAY) {
903 const I32 maxarg = AvFILL(av) + 1;
904 (void)POPs; /* XXXX May be optimized away? */
906 if (SvRMAGICAL(av)) {
908 for (i=0; i < (U32)maxarg; i++) {
909 SV ** const svp = av_fetch(av, i, FALSE);
910 /* See note in pp_helem, and bug id #27839 */
912 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
917 Copy(AvARRAY(av), SP+1, maxarg, SV*);
921 else if (gimme == G_SCALAR) {
923 const I32 maxarg = AvFILL(av) + 1;
927 /* The guts of pp_rv2hv */
928 if (gimme == G_ARRAY) { /* array wanted */
932 else if (gimme == G_SCALAR) {
934 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
943 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
950 if (ckWARN(WARN_MISC)) {
952 if (relem == firstrelem &&
954 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
955 SvTYPE(SvRV(*relem)) == SVt_PVHV))
957 err = "Reference found where even-sized list expected";
960 err = "Odd number of elements in hash assignment";
961 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
965 didstore = hv_store_ent(hash,*relem,tmpstr,0);
966 if (SvMAGICAL(hash)) {
967 if (SvSMAGICAL(tmpstr))
979 SV **lastlelem = PL_stack_sp;
980 SV **lastrelem = PL_stack_base + POPMARK;
981 SV **firstrelem = PL_stack_base + POPMARK + 1;
982 SV **firstlelem = lastrelem + 1;
995 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
997 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
1000 /* If there's a common identifier on both sides we have to take
1001 * special care that assigning the identifier on the left doesn't
1002 * clobber a value on the right that's used later in the list.
1004 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1005 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1006 for (relem = firstrelem; relem <= lastrelem; relem++) {
1007 if ((sv = *relem)) {
1008 TAINT_NOT; /* Each item is independent */
1009 *relem = sv_mortalcopy(sv);
1019 while (lelem <= lastlelem) {
1020 TAINT_NOT; /* Each item stands on its own, taintwise. */
1022 switch (SvTYPE(sv)) {
1025 magic = SvMAGICAL(ary) != 0;
1027 av_extend(ary, lastrelem - relem);
1029 while (relem <= lastrelem) { /* gobble up all the rest */
1032 sv = newSVsv(*relem);
1034 didstore = av_store(ary,i++,sv);
1043 if (PL_delaymagic & DM_ARRAY)
1044 SvSETMAGIC((SV*)ary);
1046 case SVt_PVHV: { /* normal hash */
1050 magic = SvMAGICAL(hash) != 0;
1052 firsthashrelem = relem;
1054 while (relem < lastrelem) { /* gobble up all the rest */
1056 sv = *relem ? *relem : &PL_sv_no;
1060 sv_setsv(tmpstr,*relem); /* value */
1061 *(relem++) = tmpstr;
1062 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1063 /* key overwrites an existing entry */
1065 didstore = hv_store_ent(hash,sv,tmpstr,0);
1067 if (SvSMAGICAL(tmpstr))
1074 if (relem == lastrelem) {
1075 do_oddball(hash, relem, firstrelem);
1081 if (SvIMMORTAL(sv)) {
1082 if (relem <= lastrelem)
1086 if (relem <= lastrelem) {
1087 sv_setsv(sv, *relem);
1091 sv_setsv(sv, &PL_sv_undef);
1096 if (PL_delaymagic & ~DM_DELAY) {
1097 if (PL_delaymagic & DM_UID) {
1098 #ifdef HAS_SETRESUID
1099 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1100 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1103 # ifdef HAS_SETREUID
1104 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1105 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1108 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1109 (void)setruid(PL_uid);
1110 PL_delaymagic &= ~DM_RUID;
1112 # endif /* HAS_SETRUID */
1114 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1115 (void)seteuid(PL_euid);
1116 PL_delaymagic &= ~DM_EUID;
1118 # endif /* HAS_SETEUID */
1119 if (PL_delaymagic & DM_UID) {
1120 if (PL_uid != PL_euid)
1121 DIE(aTHX_ "No setreuid available");
1122 (void)PerlProc_setuid(PL_uid);
1124 # endif /* HAS_SETREUID */
1125 #endif /* HAS_SETRESUID */
1126 PL_uid = PerlProc_getuid();
1127 PL_euid = PerlProc_geteuid();
1129 if (PL_delaymagic & DM_GID) {
1130 #ifdef HAS_SETRESGID
1131 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1132 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1135 # ifdef HAS_SETREGID
1136 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1137 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1140 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1141 (void)setrgid(PL_gid);
1142 PL_delaymagic &= ~DM_RGID;
1144 # endif /* HAS_SETRGID */
1146 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1147 (void)setegid(PL_egid);
1148 PL_delaymagic &= ~DM_EGID;
1150 # endif /* HAS_SETEGID */
1151 if (PL_delaymagic & DM_GID) {
1152 if (PL_gid != PL_egid)
1153 DIE(aTHX_ "No setregid available");
1154 (void)PerlProc_setgid(PL_gid);
1156 # endif /* HAS_SETREGID */
1157 #endif /* HAS_SETRESGID */
1158 PL_gid = PerlProc_getgid();
1159 PL_egid = PerlProc_getegid();
1161 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1165 if (gimme == G_VOID)
1166 SP = firstrelem - 1;
1167 else if (gimme == G_SCALAR) {
1170 SETi(lastrelem - firstrelem + 1 - duplicates);
1177 /* Removes from the stack the entries which ended up as
1178 * duplicated keys in the hash (fix for [perl #24380]) */
1179 Move(firsthashrelem + duplicates,
1180 firsthashrelem, duplicates, SV**);
1181 lastrelem -= duplicates;
1186 SP = firstrelem + (lastlelem - firstlelem);
1187 lelem = firstlelem + (relem - firstrelem);
1189 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1198 register PMOP * const pm = cPMOP;
1199 REGEXP * rx = PM_GETRE(pm);
1200 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1201 SV * const rv = sv_newmortal();
1203 SvUPGRADE(rv, SVt_IV);
1204 /* This RV is about to own a reference to the regexp. (In addition to the
1205 reference already owned by the PMOP. */
1207 SvRV_set(rv, (SV*) rx);
1211 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1212 (void)sv_bless(rv, stash);
1215 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1224 register PMOP *pm = cPMOP;
1226 register const char *t;
1227 register const char *s;
1230 U8 r_flags = REXEC_CHECKED;
1231 const char *truebase; /* Start of string */
1232 register REGEXP *rx = PM_GETRE(pm);
1234 const I32 gimme = GIMME;
1237 const I32 oldsave = PL_savestack_ix;
1238 I32 update_minmatch = 1;
1239 I32 had_zerolen = 0;
1242 if (PL_op->op_flags & OPf_STACKED)
1244 else if (PL_op->op_private & OPpTARGET_MY)
1251 PUTBACK; /* EVAL blocks need stack_sp. */
1252 s = SvPV_const(TARG, len);
1254 DIE(aTHX_ "panic: pp_match");
1256 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1257 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1260 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1262 /* PMdf_USED is set after a ?? matches once */
1265 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1267 pm->op_pmflags & PMf_USED
1271 if (gimme == G_ARRAY)
1278 /* empty pattern special-cased to use last successful pattern if possible */
1279 if (!RX_PRELEN(rx) && PL_curpm) {
1284 if (RX_MINLEN(rx) > (I32)len)
1289 /* XXXX What part of this is needed with true \G-support? */
1290 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1291 RX_OFFS(rx)[0].start = -1;
1292 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1293 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1294 if (mg && mg->mg_len >= 0) {
1295 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1296 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1297 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1298 r_flags |= REXEC_IGNOREPOS;
1299 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1300 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1303 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1304 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1305 update_minmatch = 0;
1309 /* XXX: comment out !global get safe $1 vars after a
1310 match, BUT be aware that this leads to dramatic slowdowns on
1311 /g matches against large strings. So far a solution to this problem
1312 appears to be quite tricky.
1313 Test for the unsafe vars are TODO for now. */
1314 if (( !global && RX_NPARENS(rx))
1315 || SvTEMP(TARG) || PL_sawampersand ||
1316 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1317 r_flags |= REXEC_COPY_STR;
1319 r_flags |= REXEC_SCREAM;
1322 if (global && RX_OFFS(rx)[0].start != -1) {
1323 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1324 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1326 if (update_minmatch++)
1327 minmatch = had_zerolen;
1329 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1330 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1331 /* FIXME - can PL_bostr be made const char *? */
1332 PL_bostr = (char *)truebase;
1333 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1337 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1339 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1340 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1341 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1342 && (r_flags & REXEC_SCREAM)))
1343 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1346 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1347 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1350 if (dynpm->op_pmflags & PMf_ONCE) {
1352 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1354 dynpm->op_pmflags |= PMf_USED;
1365 RX_MATCH_TAINTED_on(rx);
1366 TAINT_IF(RX_MATCH_TAINTED(rx));
1367 if (gimme == G_ARRAY) {
1368 const I32 nparens = RX_NPARENS(rx);
1369 I32 i = (global && !nparens) ? 1 : 0;
1371 SPAGAIN; /* EVAL blocks could move the stack. */
1372 EXTEND(SP, nparens + i);
1373 EXTEND_MORTAL(nparens + i);
1374 for (i = !i; i <= nparens; i++) {
1375 PUSHs(sv_newmortal());
1376 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1377 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1378 s = RX_OFFS(rx)[i].start + truebase;
1379 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1380 len < 0 || len > strend - s)
1381 DIE(aTHX_ "panic: pp_match start/end pointers");
1382 sv_setpvn(*SP, s, len);
1383 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1388 if (dynpm->op_pmflags & PMf_CONTINUE) {
1390 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1391 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1393 #ifdef PERL_OLD_COPY_ON_WRITE
1395 sv_force_normal_flags(TARG, 0);
1397 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1398 &PL_vtbl_mglob, NULL, 0);
1400 if (RX_OFFS(rx)[0].start != -1) {
1401 mg->mg_len = RX_OFFS(rx)[0].end;
1402 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1403 mg->mg_flags |= MGf_MINMATCH;
1405 mg->mg_flags &= ~MGf_MINMATCH;
1408 had_zerolen = (RX_OFFS(rx)[0].start != -1
1409 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1410 == (UV)RX_OFFS(rx)[0].end));
1411 PUTBACK; /* EVAL blocks may use stack */
1412 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1417 LEAVE_SCOPE(oldsave);
1423 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1424 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1428 #ifdef PERL_OLD_COPY_ON_WRITE
1430 sv_force_normal_flags(TARG, 0);
1432 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1433 &PL_vtbl_mglob, NULL, 0);
1435 if (RX_OFFS(rx)[0].start != -1) {
1436 mg->mg_len = RX_OFFS(rx)[0].end;
1437 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1438 mg->mg_flags |= MGf_MINMATCH;
1440 mg->mg_flags &= ~MGf_MINMATCH;
1443 LEAVE_SCOPE(oldsave);
1447 yup: /* Confirmed by INTUIT */
1449 RX_MATCH_TAINTED_on(rx);
1450 TAINT_IF(RX_MATCH_TAINTED(rx));
1452 if (dynpm->op_pmflags & PMf_ONCE) {
1454 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1456 dynpm->op_pmflags |= PMf_USED;
1459 if (RX_MATCH_COPIED(rx))
1460 Safefree(RX_SUBBEG(rx));
1461 RX_MATCH_COPIED_off(rx);
1462 RX_SUBBEG(rx) = NULL;
1464 /* FIXME - should rx->subbeg be const char *? */
1465 RX_SUBBEG(rx) = (char *) truebase;
1466 RX_OFFS(rx)[0].start = s - truebase;
1467 if (RX_MATCH_UTF8(rx)) {
1468 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1469 RX_OFFS(rx)[0].end = t - truebase;
1472 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1474 RX_SUBLEN(rx) = strend - truebase;
1477 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1479 #ifdef PERL_OLD_COPY_ON_WRITE
1480 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1482 PerlIO_printf(Perl_debug_log,
1483 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1484 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1487 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1489 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1490 assert (SvPOKp(RX_SAVED_COPY(rx)));
1495 RX_SUBBEG(rx) = savepvn(t, strend - t);
1496 #ifdef PERL_OLD_COPY_ON_WRITE
1497 RX_SAVED_COPY(rx) = NULL;
1500 RX_SUBLEN(rx) = strend - t;
1501 RX_MATCH_COPIED_on(rx);
1502 off = RX_OFFS(rx)[0].start = s - t;
1503 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1505 else { /* startp/endp are used by @- @+. */
1506 RX_OFFS(rx)[0].start = s - truebase;
1507 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1509 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1511 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1512 LEAVE_SCOPE(oldsave);
1517 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1518 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1519 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1524 LEAVE_SCOPE(oldsave);
1525 if (gimme == G_ARRAY)
1531 Perl_do_readline(pTHX)
1533 dVAR; dSP; dTARGETSTACKED;
1538 register IO * const io = GvIO(PL_last_in_gv);
1539 register const I32 type = PL_op->op_type;
1540 const I32 gimme = GIMME_V;
1543 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1546 XPUSHs(SvTIED_obj((SV*)io, mg));
1549 call_method("READLINE", gimme);
1552 if (gimme == G_SCALAR) {
1553 SV* const result = POPs;
1554 SvSetSV_nosteal(TARG, result);
1564 if (IoFLAGS(io) & IOf_ARGV) {
1565 if (IoFLAGS(io) & IOf_START) {
1567 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1568 IoFLAGS(io) &= ~IOf_START;
1569 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1570 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1571 SvSETMAGIC(GvSV(PL_last_in_gv));
1576 fp = nextargv(PL_last_in_gv);
1577 if (!fp) { /* Note: fp != IoIFP(io) */
1578 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1581 else if (type == OP_GLOB)
1582 fp = Perl_start_glob(aTHX_ POPs, io);
1584 else if (type == OP_GLOB)
1586 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1587 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1591 if ((!io || !(IoFLAGS(io) & IOf_START))
1592 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1594 if (type == OP_GLOB)
1595 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1596 "glob failed (can't start child: %s)",
1599 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1601 if (gimme == G_SCALAR) {
1602 /* undef TARG, and push that undefined value */
1603 if (type != OP_RCATLINE) {
1604 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1612 if (gimme == G_SCALAR) {
1614 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1617 if (type == OP_RCATLINE)
1618 SvPV_force_nolen(sv);
1622 else if (isGV_with_GP(sv)) {
1623 SvPV_force_nolen(sv);
1625 SvUPGRADE(sv, SVt_PV);
1626 tmplen = SvLEN(sv); /* remember if already alloced */
1627 if (!tmplen && !SvREADONLY(sv))
1628 Sv_Grow(sv, 80); /* try short-buffering it */
1630 if (type == OP_RCATLINE && SvOK(sv)) {
1632 SvPV_force_nolen(sv);
1638 sv = sv_2mortal(newSV(80));
1642 /* This should not be marked tainted if the fp is marked clean */
1643 #define MAYBE_TAINT_LINE(io, sv) \
1644 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1649 /* delay EOF state for a snarfed empty file */
1650 #define SNARF_EOF(gimme,rs,io,sv) \
1651 (gimme != G_SCALAR || SvCUR(sv) \
1652 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1656 if (!sv_gets(sv, fp, offset)
1658 || SNARF_EOF(gimme, PL_rs, io, sv)
1659 || PerlIO_error(fp)))
1661 PerlIO_clearerr(fp);
1662 if (IoFLAGS(io) & IOf_ARGV) {
1663 fp = nextargv(PL_last_in_gv);
1666 (void)do_close(PL_last_in_gv, FALSE);
1668 else if (type == OP_GLOB) {
1669 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1670 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1671 "glob failed (child exited with status %d%s)",
1672 (int)(STATUS_CURRENT >> 8),
1673 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1676 if (gimme == G_SCALAR) {
1677 if (type != OP_RCATLINE) {
1678 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1684 MAYBE_TAINT_LINE(io, sv);
1687 MAYBE_TAINT_LINE(io, sv);
1689 IoFLAGS(io) |= IOf_NOLINE;
1693 if (type == OP_GLOB) {
1696 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1697 char * const tmps = SvEND(sv) - 1;
1698 if (*tmps == *SvPVX_const(PL_rs)) {
1700 SvCUR_set(sv, SvCUR(sv) - 1);
1703 for (t1 = SvPVX_const(sv); *t1; t1++)
1704 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1705 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1707 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1708 (void)POPs; /* Unmatched wildcard? Chuck it... */
1711 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1712 if (ckWARN(WARN_UTF8)) {
1713 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1714 const STRLEN len = SvCUR(sv) - offset;
1717 if (!is_utf8_string_loc(s, len, &f))
1718 /* Emulate :encoding(utf8) warning in the same case. */
1719 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1720 "utf8 \"\\x%02X\" does not map to Unicode",
1721 f < (U8*)SvEND(sv) ? *f : 0);
1724 if (gimme == G_ARRAY) {
1725 if (SvLEN(sv) - SvCUR(sv) > 20) {
1726 SvPV_shrink_to_cur(sv);
1728 sv = sv_2mortal(newSV(80));
1731 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1732 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1733 const STRLEN new_len
1734 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1735 SvPV_renew(sv, new_len);
1744 register PERL_CONTEXT *cx;
1745 I32 gimme = OP_GIMME(PL_op, -1);
1748 if (cxstack_ix >= 0)
1749 gimme = cxstack[cxstack_ix].blk_gimme;
1757 PUSHBLOCK(cx, CXt_BLOCK, SP);
1767 SV * const keysv = POPs;
1768 HV * const hv = (HV*)POPs;
1769 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1770 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1772 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1775 if (SvTYPE(hv) != SVt_PVHV)
1778 if (PL_op->op_private & OPpLVAL_INTRO) {
1781 /* does the element we're localizing already exist? */
1782 preeminent = /* can we determine whether it exists? */
1784 || mg_find((SV*)hv, PERL_MAGIC_env)
1785 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1786 /* Try to preserve the existenceness of a tied hash
1787 * element by using EXISTS and DELETE if possible.
1788 * Fallback to FETCH and STORE otherwise */
1789 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1790 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1791 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1793 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1795 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1796 svp = he ? &HeVAL(he) : NULL;
1798 if (!svp || *svp == &PL_sv_undef) {
1802 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1804 lv = sv_newmortal();
1805 sv_upgrade(lv, SVt_PVLV);
1807 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1808 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1809 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1814 if (PL_op->op_private & OPpLVAL_INTRO) {
1815 if (HvNAME_get(hv) && isGV(*svp))
1816 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1820 const char * const key = SvPV_const(keysv, keylen);
1821 SAVEDELETE(hv, savepvn(key,keylen),
1822 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1824 save_helem(hv, keysv, svp);
1827 else if (PL_op->op_private & OPpDEREF)
1828 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1830 sv = (svp ? *svp : &PL_sv_undef);
1831 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1832 * Pushing the magical RHS on to the stack is useless, since
1833 * that magic is soon destined to be misled by the local(),
1834 * and thus the later pp_sassign() will fail to mg_get() the
1835 * old value. This should also cure problems with delayed
1836 * mg_get()s. GSAR 98-07-03 */
1837 if (!lval && SvGMAGICAL(sv))
1838 sv = sv_mortalcopy(sv);
1846 register PERL_CONTEXT *cx;
1851 if (PL_op->op_flags & OPf_SPECIAL) {
1852 cx = &cxstack[cxstack_ix];
1853 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1858 gimme = OP_GIMME(PL_op, -1);
1860 if (cxstack_ix >= 0)
1861 gimme = cxstack[cxstack_ix].blk_gimme;
1867 if (gimme == G_VOID)
1869 else if (gimme == G_SCALAR) {
1873 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1876 *MARK = sv_mortalcopy(TOPs);
1879 *MARK = &PL_sv_undef;
1883 else if (gimme == G_ARRAY) {
1884 /* in case LEAVE wipes old return values */
1886 for (mark = newsp + 1; mark <= SP; mark++) {
1887 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1888 *mark = sv_mortalcopy(*mark);
1889 TAINT_NOT; /* Each item is independent */
1893 PL_curpm = newpm; /* Don't pop $1 et al till now */
1903 register PERL_CONTEXT *cx;
1909 cx = &cxstack[cxstack_ix];
1910 if (!CxTYPE_is_LOOP(cx))
1911 DIE(aTHX_ "panic: pp_iter");
1913 itersvp = CxITERVAR(cx);
1914 av = cx->blk_loop.iterary;
1915 if (SvTYPE(av) != SVt_PVAV) {
1916 /* iterate ($min .. $max) */
1917 if (cx->blk_loop.iterlval) {
1918 /* string increment */
1919 register SV* cur = cx->blk_loop.iterlval;
1923 SvPV_const((SV*)av, maxlen) : (const char *)"";
1924 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1925 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1926 /* safe to reuse old SV */
1927 sv_setsv(*itersvp, cur);
1931 /* we need a fresh SV every time so that loop body sees a
1932 * completely new SV for closures/references to work as
1935 *itersvp = newSVsv(cur);
1936 SvREFCNT_dec(oldsv);
1938 if (strEQ(SvPVX_const(cur), max))
1939 sv_setiv(cur, 0); /* terminate next time */
1946 /* integer increment */
1947 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1950 /* don't risk potential race */
1951 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1952 /* safe to reuse old SV */
1953 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1957 /* we need a fresh SV every time so that loop body sees a
1958 * completely new SV for closures/references to work as they
1961 *itersvp = newSViv(cx->blk_loop.iterix++);
1962 SvREFCNT_dec(oldsv);
1965 /* Handle end of range at IV_MAX */
1966 if ((cx->blk_loop.iterix == IV_MIN) &&
1967 (cx->blk_loop.itermax == IV_MAX))
1969 cx->blk_loop.iterix++;
1970 cx->blk_loop.itermax++;
1977 if (PL_op->op_private & OPpITER_REVERSED) {
1978 /* In reverse, use itermax as the min :-) */
1979 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1982 if (SvMAGICAL(av) || AvREIFY(av)) {
1983 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1984 sv = svp ? *svp : NULL;
1987 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1991 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1995 if (SvMAGICAL(av) || AvREIFY(av)) {
1996 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1997 sv = svp ? *svp : NULL;
2000 sv = AvARRAY(av)[++cx->blk_loop.iterix];
2004 if (sv && SvIS_FREED(sv)) {
2006 Perl_croak(aTHX_ "Use of freed value in iteration");
2013 if (av != PL_curstack && sv == &PL_sv_undef) {
2014 SV *lv = cx->blk_loop.iterlval;
2015 if (lv && SvREFCNT(lv) > 1) {
2020 SvREFCNT_dec(LvTARG(lv));
2022 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
2024 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2026 LvTARG(lv) = SvREFCNT_inc_simple(av);
2027 LvTARGOFF(lv) = cx->blk_loop.iterix;
2028 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2033 *itersvp = SvREFCNT_inc_simple_NN(sv);
2034 SvREFCNT_dec(oldsv);
2042 register PMOP *pm = cPMOP;
2057 register REGEXP *rx = PM_GETRE(pm);
2059 int force_on_match = 0;
2060 const I32 oldsave = PL_savestack_ix;
2062 bool doutf8 = FALSE;
2064 #ifdef PERL_OLD_COPY_ON_WRITE
2069 /* known replacement string? */
2070 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2071 if (PL_op->op_flags & OPf_STACKED)
2073 else if (PL_op->op_private & OPpTARGET_MY)
2080 #ifdef PERL_OLD_COPY_ON_WRITE
2081 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2082 because they make integers such as 256 "false". */
2083 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2086 sv_force_normal_flags(TARG,0);
2089 #ifdef PERL_OLD_COPY_ON_WRITE
2093 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2094 || SvTYPE(TARG) > SVt_PVLV)
2095 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2096 DIE(aTHX_ PL_no_modify);
2099 s = SvPV_mutable(TARG, len);
2100 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2102 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2103 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2108 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2112 DIE(aTHX_ "panic: pp_subst");
2115 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2116 maxiters = 2 * slen + 10; /* We can match twice at each
2117 position, once with zero-length,
2118 second time with non-zero. */
2120 if (!RX_PRELEN(rx) && PL_curpm) {
2124 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2125 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2126 ? REXEC_COPY_STR : 0;
2128 r_flags |= REXEC_SCREAM;
2131 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2133 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2137 /* How to do it in subst? */
2138 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2140 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2141 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2142 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2143 && (r_flags & REXEC_SCREAM))))
2148 /* only replace once? */
2149 once = !(rpm->op_pmflags & PMf_GLOBAL);
2150 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2151 r_flags | REXEC_CHECKED);
2152 /* known replacement string? */
2154 /* replacement needing upgrading? */
2155 if (DO_UTF8(TARG) && !doutf8) {
2156 nsv = sv_newmortal();
2159 sv_recode_to_utf8(nsv, PL_encoding);
2161 sv_utf8_upgrade(nsv);
2162 c = SvPV_const(nsv, clen);
2166 c = SvPV_const(dstr, clen);
2167 doutf8 = DO_UTF8(dstr);
2175 /* can do inplace substitution? */
2177 #ifdef PERL_OLD_COPY_ON_WRITE
2180 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2181 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2182 && (!doutf8 || SvUTF8(TARG))) {
2187 LEAVE_SCOPE(oldsave);
2190 #ifdef PERL_OLD_COPY_ON_WRITE
2191 if (SvIsCOW(TARG)) {
2192 assert (!force_on_match);
2196 if (force_on_match) {
2198 s = SvPV_force(TARG, len);
2203 SvSCREAM_off(TARG); /* disable possible screamer */
2205 rxtainted |= RX_MATCH_TAINTED(rx);
2206 m = orig + RX_OFFS(rx)[0].start;
2207 d = orig + RX_OFFS(rx)[0].end;
2209 if (m - s > strend - d) { /* faster to shorten from end */
2211 Copy(c, m, clen, char);
2216 Move(d, m, i, char);
2220 SvCUR_set(TARG, m - s);
2222 else if ((i = m - s)) { /* faster from front */
2225 Move(s, d - i, i, char);
2228 Copy(c, m, clen, char);
2233 Copy(c, d, clen, char);
2238 TAINT_IF(rxtainted & 1);
2244 if (iters++ > maxiters)
2245 DIE(aTHX_ "Substitution loop");
2246 rxtainted |= RX_MATCH_TAINTED(rx);
2247 m = RX_OFFS(rx)[0].start + orig;
2250 Move(s, d, i, char);
2254 Copy(c, d, clen, char);
2257 s = RX_OFFS(rx)[0].end + orig;
2258 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2260 /* don't match same null twice */
2261 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2264 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2265 Move(s, d, i+1, char); /* include the NUL */
2267 TAINT_IF(rxtainted & 1);
2271 (void)SvPOK_only_UTF8(TARG);
2272 TAINT_IF(rxtainted);
2273 if (SvSMAGICAL(TARG)) {
2281 LEAVE_SCOPE(oldsave);
2287 if (force_on_match) {
2289 s = SvPV_force(TARG, len);
2292 #ifdef PERL_OLD_COPY_ON_WRITE
2295 rxtainted |= RX_MATCH_TAINTED(rx);
2296 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2300 register PERL_CONTEXT *cx;
2303 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2305 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2307 if (iters++ > maxiters)
2308 DIE(aTHX_ "Substitution loop");
2309 rxtainted |= RX_MATCH_TAINTED(rx);
2310 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2313 orig = RX_SUBBEG(rx);
2315 strend = s + (strend - m);
2317 m = RX_OFFS(rx)[0].start + orig;
2318 if (doutf8 && !SvUTF8(dstr))
2319 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2321 sv_catpvn(dstr, s, m-s);
2322 s = RX_OFFS(rx)[0].end + orig;
2324 sv_catpvn(dstr, c, clen);
2327 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2328 TARG, NULL, r_flags));
2329 if (doutf8 && !DO_UTF8(TARG))
2330 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2332 sv_catpvn(dstr, s, strend - s);
2334 #ifdef PERL_OLD_COPY_ON_WRITE
2335 /* The match may make the string COW. If so, brilliant, because that's
2336 just saved us one malloc, copy and free - the regexp has donated
2337 the old buffer, and we malloc an entirely new one, rather than the
2338 regexp malloc()ing a buffer and copying our original, only for
2339 us to throw it away here during the substitution. */
2340 if (SvIsCOW(TARG)) {
2341 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2347 SvPV_set(TARG, SvPVX(dstr));
2348 SvCUR_set(TARG, SvCUR(dstr));
2349 SvLEN_set(TARG, SvLEN(dstr));
2350 doutf8 |= DO_UTF8(dstr);
2351 SvPV_set(dstr, NULL);
2353 TAINT_IF(rxtainted & 1);
2357 (void)SvPOK_only(TARG);
2360 TAINT_IF(rxtainted);
2363 LEAVE_SCOPE(oldsave);
2372 LEAVE_SCOPE(oldsave);
2381 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2382 ++*PL_markstack_ptr;
2383 LEAVE; /* exit inner scope */
2386 if (PL_stack_base + *PL_markstack_ptr > SP) {
2388 const I32 gimme = GIMME_V;
2390 LEAVE; /* exit outer scope */
2391 (void)POPMARK; /* pop src */
2392 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2393 (void)POPMARK; /* pop dst */
2394 SP = PL_stack_base + POPMARK; /* pop original mark */
2395 if (gimme == G_SCALAR) {
2396 if (PL_op->op_private & OPpGREP_LEX) {
2397 SV* const sv = sv_newmortal();
2398 sv_setiv(sv, items);
2406 else if (gimme == G_ARRAY)
2413 ENTER; /* enter inner scope */
2416 src = PL_stack_base[*PL_markstack_ptr];
2418 if (PL_op->op_private & OPpGREP_LEX)
2419 PAD_SVl(PL_op->op_targ) = src;
2423 RETURNOP(cLOGOP->op_other);
2434 register PERL_CONTEXT *cx;
2437 if (CxMULTICALL(&cxstack[cxstack_ix]))
2441 cxstack_ix++; /* temporarily protect top context */
2444 if (gimme == G_SCALAR) {
2447 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2449 *MARK = SvREFCNT_inc(TOPs);
2454 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2456 *MARK = sv_mortalcopy(sv);
2461 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2465 *MARK = &PL_sv_undef;
2469 else if (gimme == G_ARRAY) {
2470 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2471 if (!SvTEMP(*MARK)) {
2472 *MARK = sv_mortalcopy(*MARK);
2473 TAINT_NOT; /* Each item is independent */
2481 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2482 PL_curpm = newpm; /* ... and pop $1 et al */
2485 return cx->blk_sub.retop;
2488 /* This duplicates the above code because the above code must not
2489 * get any slower by more conditions */
2497 register PERL_CONTEXT *cx;
2500 if (CxMULTICALL(&cxstack[cxstack_ix]))
2504 cxstack_ix++; /* temporarily protect top context */
2508 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2509 /* We are an argument to a function or grep().
2510 * This kind of lvalueness was legal before lvalue
2511 * subroutines too, so be backward compatible:
2512 * cannot report errors. */
2514 /* Scalar context *is* possible, on the LHS of -> only,
2515 * as in f()->meth(). But this is not an lvalue. */
2516 if (gimme == G_SCALAR)
2518 if (gimme == G_ARRAY) {
2519 if (!CvLVALUE(cx->blk_sub.cv))
2520 goto temporise_array;
2521 EXTEND_MORTAL(SP - newsp);
2522 for (mark = newsp + 1; mark <= SP; mark++) {
2525 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2526 *mark = sv_mortalcopy(*mark);
2528 /* Can be a localized value subject to deletion. */
2529 PL_tmps_stack[++PL_tmps_ix] = *mark;
2530 SvREFCNT_inc_void(*mark);
2535 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2536 /* Here we go for robustness, not for speed, so we change all
2537 * the refcounts so the caller gets a live guy. Cannot set
2538 * TEMP, so sv_2mortal is out of question. */
2539 if (!CvLVALUE(cx->blk_sub.cv)) {
2545 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2547 if (gimme == G_SCALAR) {
2551 /* Temporaries are bad unless they happen to be elements
2552 * of a tied hash or array */
2553 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2554 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2560 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2561 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2562 : "a readonly value" : "a temporary");
2564 else { /* Can be a localized value
2565 * subject to deletion. */
2566 PL_tmps_stack[++PL_tmps_ix] = *mark;
2567 SvREFCNT_inc_void(*mark);
2570 else { /* Should not happen? */
2576 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2577 (MARK > SP ? "Empty array" : "Array"));
2581 else if (gimme == G_ARRAY) {
2582 EXTEND_MORTAL(SP - newsp);
2583 for (mark = newsp + 1; mark <= SP; mark++) {
2584 if (*mark != &PL_sv_undef
2585 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2586 /* Might be flattened array after $#array = */
2593 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2594 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2597 /* Can be a localized value subject to deletion. */
2598 PL_tmps_stack[++PL_tmps_ix] = *mark;
2599 SvREFCNT_inc_void(*mark);
2605 if (gimme == G_SCALAR) {
2609 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2611 *MARK = SvREFCNT_inc(TOPs);
2616 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2618 *MARK = sv_mortalcopy(sv);
2623 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2627 *MARK = &PL_sv_undef;
2631 else if (gimme == G_ARRAY) {
2633 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2634 if (!SvTEMP(*MARK)) {
2635 *MARK = sv_mortalcopy(*MARK);
2636 TAINT_NOT; /* Each item is independent */
2645 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2646 PL_curpm = newpm; /* ... and pop $1 et al */
2649 return cx->blk_sub.retop;
2657 register PERL_CONTEXT *cx;
2659 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2662 DIE(aTHX_ "Not a CODE reference");
2663 switch (SvTYPE(sv)) {
2664 /* This is overwhelming the most common case: */
2666 if (!(cv = GvCVu((GV*)sv))) {
2668 cv = sv_2cv(sv, &stash, &gv, 0);
2680 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2682 SP = PL_stack_base + POPMARK;
2685 if (SvGMAGICAL(sv)) {
2690 sym = SvPVX_const(sv);
2698 sym = SvPV_const(sv, len);
2701 DIE(aTHX_ PL_no_usym, "a subroutine");
2702 if (PL_op->op_private & HINT_STRICT_REFS)
2703 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2704 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2709 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2710 tryAMAGICunDEREF(to_cv);
2713 if (SvTYPE(cv) == SVt_PVCV)
2718 DIE(aTHX_ "Not a CODE reference");
2719 /* This is the second most common case: */
2729 if (!CvROOT(cv) && !CvXSUB(cv)) {
2733 /* anonymous or undef'd function leaves us no recourse */
2734 if (CvANON(cv) || !(gv = CvGV(cv)))
2735 DIE(aTHX_ "Undefined subroutine called");
2737 /* autoloaded stub? */
2738 if (cv != GvCV(gv)) {
2741 /* should call AUTOLOAD now? */
2744 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2751 sub_name = sv_newmortal();
2752 gv_efullname3(sub_name, gv, NULL);
2753 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2757 DIE(aTHX_ "Not a CODE reference");
2762 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2763 Perl_get_db_sub(aTHX_ &sv, cv);
2765 PL_curcopdb = PL_curcop;
2766 cv = GvCV(PL_DBsub);
2768 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2769 DIE(aTHX_ "No DB::sub routine defined");
2772 if (!(CvISXSUB(cv))) {
2773 /* This path taken at least 75% of the time */
2775 register I32 items = SP - MARK;
2776 AV* const padlist = CvPADLIST(cv);
2777 PUSHBLOCK(cx, CXt_SUB, MARK);
2779 cx->blk_sub.retop = PL_op->op_next;
2781 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2782 * that eval'' ops within this sub know the correct lexical space.
2783 * Owing the speed considerations, we choose instead to search for
2784 * the cv using find_runcv() when calling doeval().
2786 if (CvDEPTH(cv) >= 2) {
2787 PERL_STACK_OVERFLOW_CHECK();
2788 pad_push(padlist, CvDEPTH(cv));
2791 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2793 AV* const av = (AV*)PAD_SVl(0);
2795 /* @_ is normally not REAL--this should only ever
2796 * happen when DB::sub() calls things that modify @_ */
2801 cx->blk_sub.savearray = GvAV(PL_defgv);
2802 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2803 CX_CURPAD_SAVE(cx->blk_sub);
2804 cx->blk_sub.argarray = av;
2807 if (items > AvMAX(av) + 1) {
2808 SV **ary = AvALLOC(av);
2809 if (AvARRAY(av) != ary) {
2810 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2813 if (items > AvMAX(av) + 1) {
2814 AvMAX(av) = items - 1;
2815 Renew(ary,items,SV*);
2820 Copy(MARK,AvARRAY(av),items,SV*);
2821 AvFILLp(av) = items - 1;
2829 /* warning must come *after* we fully set up the context
2830 * stuff so that __WARN__ handlers can safely dounwind()
2833 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2834 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2835 sub_crush_depth(cv);
2837 DEBUG_S(PerlIO_printf(Perl_debug_log,
2838 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2840 RETURNOP(CvSTART(cv));
2843 I32 markix = TOPMARK;
2848 /* Need to copy @_ to stack. Alternative may be to
2849 * switch stack to @_, and copy return values
2850 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2851 AV * const av = GvAV(PL_defgv);
2852 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2855 /* Mark is at the end of the stack. */
2857 Copy(AvARRAY(av), SP + 1, items, SV*);
2862 /* We assume first XSUB in &DB::sub is the called one. */
2864 SAVEVPTR(PL_curcop);
2865 PL_curcop = PL_curcopdb;
2868 /* Do we need to open block here? XXXX */
2869 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2870 (void)(*CvXSUB(cv))(aTHX_ cv);
2872 /* Enforce some sanity in scalar context. */
2873 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2874 if (markix > PL_stack_sp - PL_stack_base)
2875 *(PL_stack_base + markix) = &PL_sv_undef;
2877 *(PL_stack_base + markix) = *PL_stack_sp;
2878 PL_stack_sp = PL_stack_base + markix;
2886 Perl_sub_crush_depth(pTHX_ CV *cv)
2889 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2891 SV* const tmpstr = sv_newmortal();
2892 gv_efullname3(tmpstr, CvGV(cv), NULL);
2893 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2902 SV* const elemsv = POPs;
2903 IV elem = SvIV(elemsv);
2904 AV* const av = (AV*)POPs;
2905 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2906 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2909 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2910 Perl_warner(aTHX_ packWARN(WARN_MISC),
2911 "Use of reference \"%"SVf"\" as array index",
2914 elem -= CopARYBASE_get(PL_curcop);
2915 if (SvTYPE(av) != SVt_PVAV)
2917 svp = av_fetch(av, elem, lval && !defer);
2919 #ifdef PERL_MALLOC_WRAP
2920 if (SvUOK(elemsv)) {
2921 const UV uv = SvUV(elemsv);
2922 elem = uv > IV_MAX ? IV_MAX : uv;
2924 else if (SvNOK(elemsv))
2925 elem = (IV)SvNV(elemsv);
2927 static const char oom_array_extend[] =
2928 "Out of memory during array extend"; /* Duplicated in av.c */
2929 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2932 if (!svp || *svp == &PL_sv_undef) {
2935 DIE(aTHX_ PL_no_aelem, elem);
2936 lv = sv_newmortal();
2937 sv_upgrade(lv, SVt_PVLV);
2939 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2940 LvTARG(lv) = SvREFCNT_inc_simple(av);
2941 LvTARGOFF(lv) = elem;
2946 if (PL_op->op_private & OPpLVAL_INTRO)
2947 save_aelem(av, elem, svp);
2948 else if (PL_op->op_private & OPpDEREF)
2949 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2951 sv = (svp ? *svp : &PL_sv_undef);
2952 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2953 sv = sv_mortalcopy(sv);
2959 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2964 Perl_croak(aTHX_ PL_no_modify);
2965 prepare_SV_for_RV(sv);
2968 SvRV_set(sv, newSV(0));
2971 SvRV_set(sv, (SV*)newAV());
2974 SvRV_set(sv, (SV*)newHV());
2985 SV* const sv = TOPs;
2988 SV* const rsv = SvRV(sv);
2989 if (SvTYPE(rsv) == SVt_PVCV) {
2995 SETs(method_common(sv, NULL));
3002 SV* const sv = cSVOP_sv;
3003 U32 hash = SvSHARED_HASH(sv);
3005 XPUSHs(method_common(sv, &hash));
3010 S_method_common(pTHX_ SV* meth, U32* hashp)
3017 const char* packname = NULL;
3020 const char * const name = SvPV_const(meth, namelen);
3021 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3024 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3032 /* this isn't a reference */
3033 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3034 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3036 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3043 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3044 !(ob=(SV*)GvIO(iogv)))
3046 /* this isn't the name of a filehandle either */
3048 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3049 ? !isIDFIRST_utf8((U8*)packname)
3050 : !isIDFIRST(*packname)
3053 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3054 SvOK(sv) ? "without a package or object reference"
3055 : "on an undefined value");
3057 /* assume it's a package name */
3058 stash = gv_stashpvn(packname, packlen, 0);
3062 SV* const ref = newSViv(PTR2IV(stash));
3063 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3067 /* it _is_ a filehandle name -- replace with a reference */
3068 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3071 /* if we got here, ob should be a reference or a glob */
3072 if (!ob || !(SvOBJECT(ob)
3073 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3076 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3077 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3081 stash = SvSTASH(ob);
3084 /* NOTE: stash may be null, hope hv_fetch_ent and
3085 gv_fetchmethod can cope (it seems they can) */
3087 /* shortcut for simple names */
3089 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3091 gv = (GV*)HeVAL(he);
3092 if (isGV(gv) && GvCV(gv) &&
3093 (!GvCVGEN(gv) || GvCVGEN(gv)
3094 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3095 return (SV*)GvCV(gv);
3099 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3102 /* This code tries to figure out just what went wrong with
3103 gv_fetchmethod. It therefore needs to duplicate a lot of
3104 the internals of that function. We can't move it inside
3105 Perl_gv_fetchmethod_autoload(), however, since that would
3106 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3109 const char* leaf = name;
3110 const char* sep = NULL;
3113 for (p = name; *p; p++) {
3115 sep = p, leaf = p + 1;
3116 else if (*p == ':' && *(p + 1) == ':')
3117 sep = p, leaf = p + 2;
3119 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3120 /* the method name is unqualified or starts with SUPER:: */
3121 #ifndef USE_ITHREADS
3123 stash = CopSTASH(PL_curcop);
3125 bool need_strlen = 1;
3127 packname = CopSTASHPV(PL_curcop);
3132 HEK * const packhek = HvNAME_HEK(stash);
3134 packname = HEK_KEY(packhek);
3135 packlen = HEK_LEN(packhek);
3147 "Can't use anonymous symbol table for method lookup");
3151 packlen = strlen(packname);
3156 /* the method name is qualified */
3158 packlen = sep - name;
3161 /* we're relying on gv_fetchmethod not autovivifying the stash */
3162 if (gv_stashpvn(packname, packlen, 0)) {
3164 "Can't locate object method \"%s\" via package \"%.*s\"",
3165 leaf, (int)packlen, packname);
3169 "Can't locate object method \"%s\" via package \"%.*s\""
3170 " (perhaps you forgot to load \"%.*s\"?)",
3171 leaf, (int)packlen, packname, (int)packlen, packname);
3174 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3179 * c-indentation-style: bsd
3181 * indent-tabs-mode: t
3184 * ex: set ts=8 sts=4 sw=4 noet: