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 PUSHMARK(PL_stack_sp);
99 XPUSHs((SV*)cGVOP_gv);
109 if (PL_op->op_type == OP_AND)
111 RETURNOP(cLOGOP->op_other);
117 dVAR; dSP; dPOPTOPssrl;
119 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
120 SV * const temp = left;
121 left = right; right = temp;
123 if (PL_tainting && PL_tainted && !SvTAINTED(left))
125 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
126 SV * const cv = SvRV(left);
127 const U32 cv_type = SvTYPE(cv);
128 const U32 gv_type = SvTYPE(right);
129 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
135 /* Can do the optimisation if right (LVALUE) is not a typeglob,
136 left (RVALUE) is a reference to something, and we're in void
138 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
139 /* Is the target symbol table currently empty? */
140 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
141 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
142 /* Good. Create a new proxy constant subroutine in the target.
143 The gv becomes a(nother) reference to the constant. */
144 SV *const value = SvRV(cv);
146 SvUPGRADE((SV *)gv, SVt_IV);
147 SvPCS_IMPORTED_on(gv);
149 SvREFCNT_inc_simple_void(value);
155 /* Need to fix things up. */
156 if (gv_type != SVt_PVGV) {
157 /* Need to fix GV. */
158 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
162 /* We've been returned a constant rather than a full subroutine,
163 but they expect a subroutine reference to apply. */
166 SvREFCNT_inc_void(SvRV(cv));
167 /* newCONSTSUB takes a reference count on the passed in SV
168 from us. We set the name to NULL, otherwise we get into
169 all sorts of fun as the reference to our new sub is
170 donated to the GV that we're about to assign to.
172 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
177 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
179 First: ops for \&{"BONK"}; return us the constant in the
181 Second: ops for *{"BONK"} cause that symbol table entry
182 (and our reference to it) to be upgraded from RV
184 Thirdly: We get here. cv is actually PVGV now, and its
185 GvCV() is actually the subroutine we're looking for
187 So change the reference so that it points to the subroutine
188 of that typeglob, as that's what they were after all along.
190 GV *const upgraded = (GV *) cv;
191 CV *const source = GvCV(upgraded);
194 assert(CvFLAGS(source) & CVf_CONST);
196 SvREFCNT_inc_void(source);
197 SvREFCNT_dec(upgraded);
198 SvRV_set(left, (SV *)source);
203 SvSetMagicSV(right, left);
212 RETURNOP(cLOGOP->op_other);
214 RETURNOP(cLOGOP->op_next);
221 TAINT_NOT; /* Each statement is presumed innocent */
222 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
224 oldsave = PL_scopestack[PL_scopestack_ix - 1];
225 LEAVE_SCOPE(oldsave);
231 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
236 const char *rpv = NULL;
238 bool rcopied = FALSE;
240 if (TARG == right && right != left) {
241 /* mg_get(right) may happen here ... */
242 rpv = SvPV_const(right, rlen);
243 rbyte = !DO_UTF8(right);
244 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
245 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
251 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
252 lbyte = !DO_UTF8(left);
253 sv_setpvn(TARG, lpv, llen);
259 else { /* TARG == left */
261 SvGETMAGIC(left); /* or mg_get(left) may happen here */
263 if (left == right && ckWARN(WARN_UNINITIALIZED))
264 report_uninit(right);
265 sv_setpvn(left, "", 0);
267 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
268 lbyte = !DO_UTF8(left);
273 /* or mg_get(right) may happen here */
275 rpv = SvPV_const(right, rlen);
276 rbyte = !DO_UTF8(right);
278 if (lbyte != rbyte) {
280 sv_utf8_upgrade_nomg(TARG);
283 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
284 sv_utf8_upgrade_nomg(right);
285 rpv = SvPV_const(right, rlen);
288 sv_catpvn_nomg(TARG, rpv, rlen);
299 if (PL_op->op_flags & OPf_MOD) {
300 if (PL_op->op_private & OPpLVAL_INTRO)
301 if (!(PL_op->op_private & OPpPAD_STATE))
302 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
303 if (PL_op->op_private & OPpDEREF) {
305 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
315 tryAMAGICunTARGET(iter, 0);
316 PL_last_in_gv = (GV*)(*PL_stack_sp--);
317 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
318 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
319 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
322 XPUSHs((SV*)PL_last_in_gv);
325 PL_last_in_gv = (GV*)(*PL_stack_sp--);
328 return do_readline();
333 dVAR; dSP; tryAMAGICbinSET(eq,0);
334 #ifndef NV_PRESERVES_UV
335 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
337 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
341 #ifdef PERL_PRESERVE_IVUV
344 /* Unless the left argument is integer in range we are going
345 to have to use NV maths. Hence only attempt to coerce the
346 right argument if we know the left is integer. */
349 const bool auvok = SvUOK(TOPm1s);
350 const bool buvok = SvUOK(TOPs);
352 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
353 /* Casting IV to UV before comparison isn't going to matter
354 on 2s complement. On 1s complement or sign&magnitude
355 (if we have any of them) it could to make negative zero
356 differ from normal zero. As I understand it. (Need to
357 check - is negative zero implementation defined behaviour
359 const UV buv = SvUVX(POPs);
360 const UV auv = SvUVX(TOPs);
362 SETs(boolSV(auv == buv));
365 { /* ## Mixed IV,UV ## */
369 /* == is commutative so doesn't matter which is left or right */
371 /* top of stack (b) is the iv */
380 /* As uv is a UV, it's >0, so it cannot be == */
383 /* we know iv is >= 0 */
384 SETs(boolSV((UV)iv == SvUVX(uvp)));
391 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
393 if (Perl_isnan(left) || Perl_isnan(right))
395 SETs(boolSV(left == right));
398 SETs(boolSV(TOPn == value));
407 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
408 DIE(aTHX_ PL_no_modify);
409 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
410 && SvIVX(TOPs) != IV_MAX)
412 SvIV_set(TOPs, SvIVX(TOPs) + 1);
413 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
415 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
427 if (PL_op->op_type == OP_OR)
429 RETURNOP(cLOGOP->op_other);
438 const int op_type = PL_op->op_type;
439 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
443 if (!sv || !SvANY(sv)) {
444 if (op_type == OP_DOR)
446 RETURNOP(cLOGOP->op_other);
452 if (!sv || !SvANY(sv))
457 switch (SvTYPE(sv)) {
459 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
463 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
467 if (CvROOT(sv) || CvXSUB(sv))
480 if(op_type == OP_DOR)
482 RETURNOP(cLOGOP->op_other);
484 /* assuming OP_DEFINED */
492 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
493 tryAMAGICbin(add,opASSIGN);
494 svl = sv_2num(TOPm1s);
496 useleft = USE_LEFT(svl);
497 #ifdef PERL_PRESERVE_IVUV
498 /* We must see if we can perform the addition with integers if possible,
499 as the integer code detects overflow while the NV code doesn't.
500 If either argument hasn't had a numeric conversion yet attempt to get
501 the IV. It's important to do this now, rather than just assuming that
502 it's not IOK as a PV of "9223372036854775806" may not take well to NV
503 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
504 integer in case the second argument is IV=9223372036854775806
505 We can (now) rely on sv_2iv to do the right thing, only setting the
506 public IOK flag if the value in the NV (or PV) slot is truly integer.
508 A side effect is that this also aggressively prefers integer maths over
509 fp maths for integer values.
511 How to detect overflow?
513 C 99 section 6.2.6.1 says
515 The range of nonnegative values of a signed integer type is a subrange
516 of the corresponding unsigned integer type, and the representation of
517 the same value in each type is the same. A computation involving
518 unsigned operands can never overflow, because a result that cannot be
519 represented by the resulting unsigned integer type is reduced modulo
520 the number that is one greater than the largest value that can be
521 represented by the resulting type.
525 which I read as "unsigned ints wrap."
527 signed integer overflow seems to be classed as "exception condition"
529 If an exceptional condition occurs during the evaluation of an
530 expression (that is, if the result is not mathematically defined or not
531 in the range of representable values for its type), the behavior is
534 (6.5, the 5th paragraph)
536 I had assumed that on 2s complement machines signed arithmetic would
537 wrap, hence coded pp_add and pp_subtract on the assumption that
538 everything perl builds on would be happy. After much wailing and
539 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
540 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
541 unsigned code below is actually shorter than the old code. :-)
546 /* Unless the left argument is integer in range we are going to have to
547 use NV maths. Hence only attempt to coerce the right argument if
548 we know the left is integer. */
556 /* left operand is undef, treat as zero. + 0 is identity,
557 Could SETi or SETu right now, but space optimise by not adding
558 lots of code to speed up what is probably a rarish case. */
560 /* Left operand is defined, so is it IV? */
563 if ((auvok = SvUOK(svl)))
566 register const IV aiv = SvIVX(svl);
569 auvok = 1; /* Now acting as a sign flag. */
570 } else { /* 2s complement assumption for IV_MIN */
578 bool result_good = 0;
581 bool buvok = SvUOK(svr);
586 register const IV biv = SvIVX(svr);
593 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
594 else "IV" now, independent of how it came in.
595 if a, b represents positive, A, B negative, a maps to -A etc
600 all UV maths. negate result if A negative.
601 add if signs same, subtract if signs differ. */
607 /* Must get smaller */
613 /* result really should be -(auv-buv). as its negation
614 of true value, need to swap our result flag */
631 if (result <= (UV)IV_MIN)
634 /* result valid, but out of range for IV. */
639 } /* Overflow, drop through to NVs. */
644 NV value = SvNV(svr);
647 /* left operand is undef, treat as zero. + 0.0 is identity. */
651 SETn( value + SvNV(svl) );
659 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
660 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
661 const U32 lval = PL_op->op_flags & OPf_MOD;
662 SV** const svp = av_fetch(av, PL_op->op_private, lval);
663 SV *sv = (svp ? *svp : &PL_sv_undef);
665 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
666 sv = sv_mortalcopy(sv);
673 dVAR; dSP; dMARK; dTARGET;
675 do_join(TARG, *MARK, MARK, SP);
686 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
687 * will be enough to hold an OP*.
689 SV* const sv = sv_newmortal();
690 sv_upgrade(sv, SVt_PVLV);
692 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
700 /* Oversized hot code. */
704 dVAR; dSP; dMARK; dORIGMARK;
708 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
710 if (gv && (io = GvIO(gv))
711 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
714 if (MARK == ORIGMARK) {
715 /* If using default handle then we need to make space to
716 * pass object as 1st arg, so move other args up ...
720 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
724 *MARK = SvTIED_obj((SV*)io, mg);
727 if( PL_op->op_type == OP_SAY ) {
728 /* local $\ = "\n" */
729 SAVEGENERICSV(PL_ors_sv);
730 PL_ors_sv = newSVpvs("\n");
732 call_method("PRINT", G_SCALAR);
740 if (!(io = GvIO(gv))) {
741 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
742 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
744 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
745 report_evil_fh(gv, io, PL_op->op_type);
746 SETERRNO(EBADF,RMS_IFI);
749 else if (!(fp = IoOFP(io))) {
750 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
752 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
753 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
754 report_evil_fh(gv, io, PL_op->op_type);
756 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
761 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
763 if (!do_print(*MARK, fp))
767 if (!do_print(PL_ofs_sv, fp)) { /* $, */
776 if (!do_print(*MARK, fp))
784 if (PL_op->op_type == OP_SAY) {
785 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
788 else if (PL_ors_sv && SvOK(PL_ors_sv))
789 if (!do_print(PL_ors_sv, fp)) /* $\ */
792 if (IoFLAGS(io) & IOf_FLUSH)
793 if (PerlIO_flush(fp) == EOF)
803 XPUSHs(&PL_sv_undef);
810 const I32 gimme = GIMME_V;
811 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
812 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
813 static const char an_array[] = "an ARRAY";
814 static const char a_hash[] = "a HASH";
815 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
816 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
820 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
823 if (SvTYPE(sv) != type)
824 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
825 if (PL_op->op_flags & OPf_REF) {
830 if (gimme != G_ARRAY)
831 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
832 : return_hash_to_lvalue_scalar);
836 else if (PL_op->op_flags & OPf_MOD
837 && PL_op->op_private & OPpLVAL_INTRO)
838 Perl_croak(aTHX_ PL_no_localize_ref);
841 if (SvTYPE(sv) == type) {
842 if (PL_op->op_flags & OPf_REF) {
847 if (gimme != G_ARRAY)
849 is_pp_rv2av ? return_array_to_lvalue_scalar
850 : return_hash_to_lvalue_scalar);
858 if (SvTYPE(sv) != SVt_PVGV) {
859 if (SvGMAGICAL(sv)) {
864 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
872 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
873 if (PL_op->op_private & OPpLVAL_INTRO)
874 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
875 if (PL_op->op_flags & OPf_REF) {
880 if (gimme != G_ARRAY)
882 is_pp_rv2av ? return_array_to_lvalue_scalar
883 : return_hash_to_lvalue_scalar);
891 AV *const av = (AV*)sv;
892 /* The guts of pp_rv2av, with no intenting change to preserve history
893 (until such time as we get tools that can do blame annotation across
894 whitespace changes. */
895 if (gimme == G_ARRAY) {
896 const I32 maxarg = AvFILL(av) + 1;
897 (void)POPs; /* XXXX May be optimized away? */
899 if (SvRMAGICAL(av)) {
901 for (i=0; i < (U32)maxarg; i++) {
902 SV ** const svp = av_fetch(av, i, FALSE);
903 /* See note in pp_helem, and bug id #27839 */
905 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
910 Copy(AvARRAY(av), SP+1, maxarg, SV*);
914 else if (gimme == G_SCALAR) {
916 const I32 maxarg = AvFILL(av) + 1;
920 /* The guts of pp_rv2hv */
921 if (gimme == G_ARRAY) { /* array wanted */
925 else if (gimme == G_SCALAR) {
927 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
936 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
943 if (ckWARN(WARN_MISC)) {
945 if (relem == firstrelem &&
947 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
948 SvTYPE(SvRV(*relem)) == SVt_PVHV))
950 err = "Reference found where even-sized list expected";
953 err = "Odd number of elements in hash assignment";
954 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
958 didstore = hv_store_ent(hash,*relem,tmpstr,0);
959 if (SvMAGICAL(hash)) {
960 if (SvSMAGICAL(tmpstr))
972 SV **lastlelem = PL_stack_sp;
973 SV **lastrelem = PL_stack_base + POPMARK;
974 SV **firstrelem = PL_stack_base + POPMARK + 1;
975 SV **firstlelem = lastrelem + 1;
988 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
990 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
993 /* If there's a common identifier on both sides we have to take
994 * special care that assigning the identifier on the left doesn't
995 * clobber a value on the right that's used later in the list.
997 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
998 EXTEND_MORTAL(lastrelem - firstrelem + 1);
999 for (relem = firstrelem; relem <= lastrelem; relem++) {
1000 if ((sv = *relem)) {
1001 TAINT_NOT; /* Each item is independent */
1002 *relem = sv_mortalcopy(sv);
1012 while (lelem <= lastlelem) {
1013 TAINT_NOT; /* Each item stands on its own, taintwise. */
1015 switch (SvTYPE(sv)) {
1018 magic = SvMAGICAL(ary) != 0;
1020 av_extend(ary, lastrelem - relem);
1022 while (relem <= lastrelem) { /* gobble up all the rest */
1025 sv = newSVsv(*relem);
1027 didstore = av_store(ary,i++,sv);
1036 if (PL_delaymagic & DM_ARRAY)
1037 SvSETMAGIC((SV*)ary);
1039 case SVt_PVHV: { /* normal hash */
1043 magic = SvMAGICAL(hash) != 0;
1045 firsthashrelem = relem;
1047 while (relem < lastrelem) { /* gobble up all the rest */
1049 sv = *relem ? *relem : &PL_sv_no;
1053 sv_setsv(tmpstr,*relem); /* value */
1054 *(relem++) = tmpstr;
1055 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1056 /* key overwrites an existing entry */
1058 didstore = hv_store_ent(hash,sv,tmpstr,0);
1060 if (SvSMAGICAL(tmpstr))
1067 if (relem == lastrelem) {
1068 do_oddball(hash, relem, firstrelem);
1074 if (SvIMMORTAL(sv)) {
1075 if (relem <= lastrelem)
1079 if (relem <= lastrelem) {
1080 sv_setsv(sv, *relem);
1084 sv_setsv(sv, &PL_sv_undef);
1089 if (PL_delaymagic & ~DM_DELAY) {
1090 if (PL_delaymagic & DM_UID) {
1091 #ifdef HAS_SETRESUID
1092 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1093 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1096 # ifdef HAS_SETREUID
1097 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1098 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1101 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1102 (void)setruid(PL_uid);
1103 PL_delaymagic &= ~DM_RUID;
1105 # endif /* HAS_SETRUID */
1107 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1108 (void)seteuid(PL_euid);
1109 PL_delaymagic &= ~DM_EUID;
1111 # endif /* HAS_SETEUID */
1112 if (PL_delaymagic & DM_UID) {
1113 if (PL_uid != PL_euid)
1114 DIE(aTHX_ "No setreuid available");
1115 (void)PerlProc_setuid(PL_uid);
1117 # endif /* HAS_SETREUID */
1118 #endif /* HAS_SETRESUID */
1119 PL_uid = PerlProc_getuid();
1120 PL_euid = PerlProc_geteuid();
1122 if (PL_delaymagic & DM_GID) {
1123 #ifdef HAS_SETRESGID
1124 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1125 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1128 # ifdef HAS_SETREGID
1129 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1130 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1133 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1134 (void)setrgid(PL_gid);
1135 PL_delaymagic &= ~DM_RGID;
1137 # endif /* HAS_SETRGID */
1139 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1140 (void)setegid(PL_egid);
1141 PL_delaymagic &= ~DM_EGID;
1143 # endif /* HAS_SETEGID */
1144 if (PL_delaymagic & DM_GID) {
1145 if (PL_gid != PL_egid)
1146 DIE(aTHX_ "No setregid available");
1147 (void)PerlProc_setgid(PL_gid);
1149 # endif /* HAS_SETREGID */
1150 #endif /* HAS_SETRESGID */
1151 PL_gid = PerlProc_getgid();
1152 PL_egid = PerlProc_getegid();
1154 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1158 if (gimme == G_VOID)
1159 SP = firstrelem - 1;
1160 else if (gimme == G_SCALAR) {
1163 SETi(lastrelem - firstrelem + 1 - duplicates);
1170 /* Removes from the stack the entries which ended up as
1171 * duplicated keys in the hash (fix for [perl #24380]) */
1172 Move(firsthashrelem + duplicates,
1173 firsthashrelem, duplicates, SV**);
1174 lastrelem -= duplicates;
1179 SP = firstrelem + (lastlelem - firstlelem);
1180 lelem = firstlelem + (relem - firstrelem);
1182 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1191 register PMOP * const pm = cPMOP;
1192 REGEXP * rx = PM_GETRE(pm);
1193 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1194 SV * const rv = sv_newmortal();
1196 SvUPGRADE(rv, SVt_IV);
1197 /* This RV is about to own a reference to the regexp. (In addition to the
1198 reference already owned by the PMOP. */
1200 SvRV_set(rv, (SV*) rx);
1204 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1205 (void)sv_bless(rv, stash);
1208 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1217 register PMOP *pm = cPMOP;
1219 register const char *t;
1220 register const char *s;
1223 U8 r_flags = REXEC_CHECKED;
1224 const char *truebase; /* Start of string */
1225 register REGEXP *rx = PM_GETRE(pm);
1227 const I32 gimme = GIMME;
1230 const I32 oldsave = PL_savestack_ix;
1231 I32 update_minmatch = 1;
1232 I32 had_zerolen = 0;
1235 if (PL_op->op_flags & OPf_STACKED)
1237 else if (PL_op->op_private & OPpTARGET_MY)
1244 PUTBACK; /* EVAL blocks need stack_sp. */
1245 s = SvPV_const(TARG, len);
1247 DIE(aTHX_ "panic: pp_match");
1249 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1250 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1253 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1255 /* PMdf_USED is set after a ?? matches once */
1258 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1260 pm->op_pmflags & PMf_USED
1264 if (gimme == G_ARRAY)
1271 /* empty pattern special-cased to use last successful pattern if possible */
1272 if (!RX_PRELEN(rx) && PL_curpm) {
1277 if (RX_MINLEN(rx) > (I32)len)
1282 /* XXXX What part of this is needed with true \G-support? */
1283 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1284 RX_OFFS(rx)[0].start = -1;
1285 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1286 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1287 if (mg && mg->mg_len >= 0) {
1288 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1289 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1290 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1291 r_flags |= REXEC_IGNOREPOS;
1292 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1293 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1296 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1297 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1298 update_minmatch = 0;
1302 /* XXX: comment out !global get safe $1 vars after a
1303 match, BUT be aware that this leads to dramatic slowdowns on
1304 /g matches against large strings. So far a solution to this problem
1305 appears to be quite tricky.
1306 Test for the unsafe vars are TODO for now. */
1307 if (( !global && RX_NPARENS(rx))
1308 || SvTEMP(TARG) || PL_sawampersand ||
1309 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1310 r_flags |= REXEC_COPY_STR;
1312 r_flags |= REXEC_SCREAM;
1315 if (global && RX_OFFS(rx)[0].start != -1) {
1316 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1317 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1319 if (update_minmatch++)
1320 minmatch = had_zerolen;
1322 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1323 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1324 /* FIXME - can PL_bostr be made const char *? */
1325 PL_bostr = (char *)truebase;
1326 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1330 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1332 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1333 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1334 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1335 && (r_flags & REXEC_SCREAM)))
1336 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1339 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1340 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1343 if (dynpm->op_pmflags & PMf_ONCE) {
1345 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1347 dynpm->op_pmflags |= PMf_USED;
1358 RX_MATCH_TAINTED_on(rx);
1359 TAINT_IF(RX_MATCH_TAINTED(rx));
1360 if (gimme == G_ARRAY) {
1361 const I32 nparens = RX_NPARENS(rx);
1362 I32 i = (global && !nparens) ? 1 : 0;
1364 SPAGAIN; /* EVAL blocks could move the stack. */
1365 EXTEND(SP, nparens + i);
1366 EXTEND_MORTAL(nparens + i);
1367 for (i = !i; i <= nparens; i++) {
1368 PUSHs(sv_newmortal());
1369 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1370 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1371 s = RX_OFFS(rx)[i].start + truebase;
1372 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1373 len < 0 || len > strend - s)
1374 DIE(aTHX_ "panic: pp_match start/end pointers");
1375 sv_setpvn(*SP, s, len);
1376 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1381 if (dynpm->op_pmflags & PMf_CONTINUE) {
1383 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1384 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1386 #ifdef PERL_OLD_COPY_ON_WRITE
1388 sv_force_normal_flags(TARG, 0);
1390 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1391 &PL_vtbl_mglob, NULL, 0);
1393 if (RX_OFFS(rx)[0].start != -1) {
1394 mg->mg_len = RX_OFFS(rx)[0].end;
1395 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1396 mg->mg_flags |= MGf_MINMATCH;
1398 mg->mg_flags &= ~MGf_MINMATCH;
1401 had_zerolen = (RX_OFFS(rx)[0].start != -1
1402 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1403 == (UV)RX_OFFS(rx)[0].end));
1404 PUTBACK; /* EVAL blocks may use stack */
1405 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1410 LEAVE_SCOPE(oldsave);
1416 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1417 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1421 #ifdef PERL_OLD_COPY_ON_WRITE
1423 sv_force_normal_flags(TARG, 0);
1425 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1426 &PL_vtbl_mglob, NULL, 0);
1428 if (RX_OFFS(rx)[0].start != -1) {
1429 mg->mg_len = RX_OFFS(rx)[0].end;
1430 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1431 mg->mg_flags |= MGf_MINMATCH;
1433 mg->mg_flags &= ~MGf_MINMATCH;
1436 LEAVE_SCOPE(oldsave);
1440 yup: /* Confirmed by INTUIT */
1442 RX_MATCH_TAINTED_on(rx);
1443 TAINT_IF(RX_MATCH_TAINTED(rx));
1445 if (dynpm->op_pmflags & PMf_ONCE) {
1447 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1449 dynpm->op_pmflags |= PMf_USED;
1452 if (RX_MATCH_COPIED(rx))
1453 Safefree(RX_SUBBEG(rx));
1454 RX_MATCH_COPIED_off(rx);
1455 RX_SUBBEG(rx) = NULL;
1457 /* FIXME - should rx->subbeg be const char *? */
1458 RX_SUBBEG(rx) = (char *) truebase;
1459 RX_OFFS(rx)[0].start = s - truebase;
1460 if (RX_MATCH_UTF8(rx)) {
1461 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1462 RX_OFFS(rx)[0].end = t - truebase;
1465 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1467 RX_SUBLEN(rx) = strend - truebase;
1470 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1472 #ifdef PERL_OLD_COPY_ON_WRITE
1473 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1475 PerlIO_printf(Perl_debug_log,
1476 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1477 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1480 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1482 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1483 assert (SvPOKp(RX_SAVED_COPY(rx)));
1488 RX_SUBBEG(rx) = savepvn(t, strend - t);
1489 #ifdef PERL_OLD_COPY_ON_WRITE
1490 RX_SAVED_COPY(rx) = NULL;
1493 RX_SUBLEN(rx) = strend - t;
1494 RX_MATCH_COPIED_on(rx);
1495 off = RX_OFFS(rx)[0].start = s - t;
1496 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1498 else { /* startp/endp are used by @- @+. */
1499 RX_OFFS(rx)[0].start = s - truebase;
1500 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1502 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1504 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1505 LEAVE_SCOPE(oldsave);
1510 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1511 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1512 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1517 LEAVE_SCOPE(oldsave);
1518 if (gimme == G_ARRAY)
1524 Perl_do_readline(pTHX)
1526 dVAR; dSP; dTARGETSTACKED;
1531 register IO * const io = GvIO(PL_last_in_gv);
1532 register const I32 type = PL_op->op_type;
1533 const I32 gimme = GIMME_V;
1536 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1539 XPUSHs(SvTIED_obj((SV*)io, mg));
1542 call_method("READLINE", gimme);
1545 if (gimme == G_SCALAR) {
1546 SV* const result = POPs;
1547 SvSetSV_nosteal(TARG, result);
1557 if (IoFLAGS(io) & IOf_ARGV) {
1558 if (IoFLAGS(io) & IOf_START) {
1560 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1561 IoFLAGS(io) &= ~IOf_START;
1562 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1563 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1564 SvSETMAGIC(GvSV(PL_last_in_gv));
1569 fp = nextargv(PL_last_in_gv);
1570 if (!fp) { /* Note: fp != IoIFP(io) */
1571 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1574 else if (type == OP_GLOB)
1575 fp = Perl_start_glob(aTHX_ POPs, io);
1577 else if (type == OP_GLOB)
1579 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1580 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1584 if ((!io || !(IoFLAGS(io) & IOf_START))
1585 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1587 if (type == OP_GLOB)
1588 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1589 "glob failed (can't start child: %s)",
1592 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1594 if (gimme == G_SCALAR) {
1595 /* undef TARG, and push that undefined value */
1596 if (type != OP_RCATLINE) {
1597 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1605 if (gimme == G_SCALAR) {
1607 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1610 if (type == OP_RCATLINE)
1611 SvPV_force_nolen(sv);
1615 else if (isGV_with_GP(sv)) {
1616 SvPV_force_nolen(sv);
1618 SvUPGRADE(sv, SVt_PV);
1619 tmplen = SvLEN(sv); /* remember if already alloced */
1620 if (!tmplen && !SvREADONLY(sv))
1621 Sv_Grow(sv, 80); /* try short-buffering it */
1623 if (type == OP_RCATLINE && SvOK(sv)) {
1625 SvPV_force_nolen(sv);
1631 sv = sv_2mortal(newSV(80));
1635 /* This should not be marked tainted if the fp is marked clean */
1636 #define MAYBE_TAINT_LINE(io, sv) \
1637 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1642 /* delay EOF state for a snarfed empty file */
1643 #define SNARF_EOF(gimme,rs,io,sv) \
1644 (gimme != G_SCALAR || SvCUR(sv) \
1645 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1649 if (!sv_gets(sv, fp, offset)
1651 || SNARF_EOF(gimme, PL_rs, io, sv)
1652 || PerlIO_error(fp)))
1654 PerlIO_clearerr(fp);
1655 if (IoFLAGS(io) & IOf_ARGV) {
1656 fp = nextargv(PL_last_in_gv);
1659 (void)do_close(PL_last_in_gv, FALSE);
1661 else if (type == OP_GLOB) {
1662 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1663 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1664 "glob failed (child exited with status %d%s)",
1665 (int)(STATUS_CURRENT >> 8),
1666 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1669 if (gimme == G_SCALAR) {
1670 if (type != OP_RCATLINE) {
1671 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1677 MAYBE_TAINT_LINE(io, sv);
1680 MAYBE_TAINT_LINE(io, sv);
1682 IoFLAGS(io) |= IOf_NOLINE;
1686 if (type == OP_GLOB) {
1689 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1690 char * const tmps = SvEND(sv) - 1;
1691 if (*tmps == *SvPVX_const(PL_rs)) {
1693 SvCUR_set(sv, SvCUR(sv) - 1);
1696 for (t1 = SvPVX_const(sv); *t1; t1++)
1697 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1698 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1700 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1701 (void)POPs; /* Unmatched wildcard? Chuck it... */
1704 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1705 if (ckWARN(WARN_UTF8)) {
1706 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1707 const STRLEN len = SvCUR(sv) - offset;
1710 if (!is_utf8_string_loc(s, len, &f))
1711 /* Emulate :encoding(utf8) warning in the same case. */
1712 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1713 "utf8 \"\\x%02X\" does not map to Unicode",
1714 f < (U8*)SvEND(sv) ? *f : 0);
1717 if (gimme == G_ARRAY) {
1718 if (SvLEN(sv) - SvCUR(sv) > 20) {
1719 SvPV_shrink_to_cur(sv);
1721 sv = sv_2mortal(newSV(80));
1724 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1725 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1726 const STRLEN new_len
1727 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1728 SvPV_renew(sv, new_len);
1737 register PERL_CONTEXT *cx;
1738 I32 gimme = OP_GIMME(PL_op, -1);
1741 if (cxstack_ix >= 0)
1742 gimme = cxstack[cxstack_ix].blk_gimme;
1750 PUSHBLOCK(cx, CXt_BLOCK, SP);
1760 SV * const keysv = POPs;
1761 HV * const hv = (HV*)POPs;
1762 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1763 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1765 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1768 if (SvTYPE(hv) != SVt_PVHV)
1771 if (PL_op->op_private & OPpLVAL_INTRO) {
1774 /* does the element we're localizing already exist? */
1775 preeminent = /* can we determine whether it exists? */
1777 || mg_find((SV*)hv, PERL_MAGIC_env)
1778 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1779 /* Try to preserve the existenceness of a tied hash
1780 * element by using EXISTS and DELETE if possible.
1781 * Fallback to FETCH and STORE otherwise */
1782 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1783 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1784 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1786 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1788 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1789 svp = he ? &HeVAL(he) : NULL;
1791 if (!svp || *svp == &PL_sv_undef) {
1795 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1797 lv = sv_newmortal();
1798 sv_upgrade(lv, SVt_PVLV);
1800 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1801 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1802 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1807 if (PL_op->op_private & OPpLVAL_INTRO) {
1808 if (HvNAME_get(hv) && isGV(*svp))
1809 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1813 const char * const key = SvPV_const(keysv, keylen);
1814 SAVEDELETE(hv, savepvn(key,keylen),
1815 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1817 save_helem(hv, keysv, svp);
1820 else if (PL_op->op_private & OPpDEREF)
1821 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1823 sv = (svp ? *svp : &PL_sv_undef);
1824 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1825 * Pushing the magical RHS on to the stack is useless, since
1826 * that magic is soon destined to be misled by the local(),
1827 * and thus the later pp_sassign() will fail to mg_get() the
1828 * old value. This should also cure problems with delayed
1829 * mg_get()s. GSAR 98-07-03 */
1830 if (!lval && SvGMAGICAL(sv))
1831 sv = sv_mortalcopy(sv);
1839 register PERL_CONTEXT *cx;
1844 if (PL_op->op_flags & OPf_SPECIAL) {
1845 cx = &cxstack[cxstack_ix];
1846 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1851 gimme = OP_GIMME(PL_op, -1);
1853 if (cxstack_ix >= 0)
1854 gimme = cxstack[cxstack_ix].blk_gimme;
1860 if (gimme == G_VOID)
1862 else if (gimme == G_SCALAR) {
1866 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1869 *MARK = sv_mortalcopy(TOPs);
1872 *MARK = &PL_sv_undef;
1876 else if (gimme == G_ARRAY) {
1877 /* in case LEAVE wipes old return values */
1879 for (mark = newsp + 1; mark <= SP; mark++) {
1880 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1881 *mark = sv_mortalcopy(*mark);
1882 TAINT_NOT; /* Each item is independent */
1886 PL_curpm = newpm; /* Don't pop $1 et al till now */
1896 register PERL_CONTEXT *cx;
1899 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1900 bool av_is_stack = FALSE;
1903 cx = &cxstack[cxstack_ix];
1904 if (!CxTYPE_is_LOOP(cx))
1905 DIE(aTHX_ "panic: pp_iter");
1907 itersvp = CxITERVAR(cx);
1908 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1909 /* string increment */
1910 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1911 SV *end = cx->blk_loop.state_u.lazysv.end;
1912 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1913 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1915 const char *max = SvPV_const(end, maxlen);
1916 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1917 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1918 /* safe to reuse old SV */
1919 sv_setsv(*itersvp, cur);
1923 /* we need a fresh SV every time so that loop body sees a
1924 * completely new SV for closures/references to work as
1927 *itersvp = newSVsv(cur);
1928 SvREFCNT_dec(oldsv);
1930 if (strEQ(SvPVX_const(cur), max))
1931 sv_setiv(cur, 0); /* terminate next time */
1938 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1939 /* integer increment */
1940 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1943 /* don't risk potential race */
1944 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1945 /* safe to reuse old SV */
1946 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1950 /* we need a fresh SV every time so that loop body sees a
1951 * completely new SV for closures/references to work as they
1954 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1955 SvREFCNT_dec(oldsv);
1958 /* Handle end of range at IV_MAX */
1959 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1960 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1962 cx->blk_loop.state_u.lazyiv.cur++;
1963 cx->blk_loop.state_u.lazyiv.end++;
1970 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1971 av = cx->blk_loop.state_u.ary.ary;
1976 if (PL_op->op_private & OPpITER_REVERSED) {
1977 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1978 ? cx->blk_loop.resetsp + 1 : 0))
1981 if (SvMAGICAL(av) || AvREIFY(av)) {
1982 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1983 sv = svp ? *svp : NULL;
1986 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1990 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1994 if (SvMAGICAL(av) || AvREIFY(av)) {
1995 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1996 sv = svp ? *svp : NULL;
1999 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2003 if (sv && SvIS_FREED(sv)) {
2005 Perl_croak(aTHX_ "Use of freed value in iteration");
2010 SvREFCNT_inc_simple_void_NN(sv);
2014 if (!av_is_stack && sv == &PL_sv_undef) {
2015 SV *lv = newSV_type(SVt_PVLV);
2017 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2018 LvTARG(lv) = SvREFCNT_inc_simple(av);
2019 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2020 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2026 SvREFCNT_dec(oldsv);
2034 register PMOP *pm = cPMOP;
2049 register REGEXP *rx = PM_GETRE(pm);
2051 int force_on_match = 0;
2052 const I32 oldsave = PL_savestack_ix;
2054 bool doutf8 = FALSE;
2056 #ifdef PERL_OLD_COPY_ON_WRITE
2061 /* known replacement string? */
2062 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2063 if (PL_op->op_flags & OPf_STACKED)
2065 else if (PL_op->op_private & OPpTARGET_MY)
2072 #ifdef PERL_OLD_COPY_ON_WRITE
2073 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2074 because they make integers such as 256 "false". */
2075 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2078 sv_force_normal_flags(TARG,0);
2081 #ifdef PERL_OLD_COPY_ON_WRITE
2085 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2086 || SvTYPE(TARG) > SVt_PVLV)
2087 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2088 DIE(aTHX_ PL_no_modify);
2091 s = SvPV_mutable(TARG, len);
2092 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2094 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2095 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2100 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2104 DIE(aTHX_ "panic: pp_subst");
2107 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2108 maxiters = 2 * slen + 10; /* We can match twice at each
2109 position, once with zero-length,
2110 second time with non-zero. */
2112 if (!RX_PRELEN(rx) && PL_curpm) {
2116 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2117 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2118 ? REXEC_COPY_STR : 0;
2120 r_flags |= REXEC_SCREAM;
2123 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2125 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2129 /* How to do it in subst? */
2130 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2132 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2133 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2134 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2135 && (r_flags & REXEC_SCREAM))))
2140 /* only replace once? */
2141 once = !(rpm->op_pmflags & PMf_GLOBAL);
2142 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2143 r_flags | REXEC_CHECKED);
2144 /* known replacement string? */
2146 /* replacement needing upgrading? */
2147 if (DO_UTF8(TARG) && !doutf8) {
2148 nsv = sv_newmortal();
2151 sv_recode_to_utf8(nsv, PL_encoding);
2153 sv_utf8_upgrade(nsv);
2154 c = SvPV_const(nsv, clen);
2158 c = SvPV_const(dstr, clen);
2159 doutf8 = DO_UTF8(dstr);
2167 /* can do inplace substitution? */
2169 #ifdef PERL_OLD_COPY_ON_WRITE
2172 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2173 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2174 && (!doutf8 || SvUTF8(TARG))) {
2179 LEAVE_SCOPE(oldsave);
2182 #ifdef PERL_OLD_COPY_ON_WRITE
2183 if (SvIsCOW(TARG)) {
2184 assert (!force_on_match);
2188 if (force_on_match) {
2190 s = SvPV_force(TARG, len);
2195 SvSCREAM_off(TARG); /* disable possible screamer */
2197 rxtainted |= RX_MATCH_TAINTED(rx);
2198 m = orig + RX_OFFS(rx)[0].start;
2199 d = orig + RX_OFFS(rx)[0].end;
2201 if (m - s > strend - d) { /* faster to shorten from end */
2203 Copy(c, m, clen, char);
2208 Move(d, m, i, char);
2212 SvCUR_set(TARG, m - s);
2214 else if ((i = m - s)) { /* faster from front */
2217 Move(s, d - i, i, char);
2220 Copy(c, m, clen, char);
2225 Copy(c, d, clen, char);
2230 TAINT_IF(rxtainted & 1);
2236 if (iters++ > maxiters)
2237 DIE(aTHX_ "Substitution loop");
2238 rxtainted |= RX_MATCH_TAINTED(rx);
2239 m = RX_OFFS(rx)[0].start + orig;
2242 Move(s, d, i, char);
2246 Copy(c, d, clen, char);
2249 s = RX_OFFS(rx)[0].end + orig;
2250 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2252 /* don't match same null twice */
2253 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2256 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2257 Move(s, d, i+1, char); /* include the NUL */
2259 TAINT_IF(rxtainted & 1);
2263 (void)SvPOK_only_UTF8(TARG);
2264 TAINT_IF(rxtainted);
2265 if (SvSMAGICAL(TARG)) {
2273 LEAVE_SCOPE(oldsave);
2279 if (force_on_match) {
2281 s = SvPV_force(TARG, len);
2284 #ifdef PERL_OLD_COPY_ON_WRITE
2287 rxtainted |= RX_MATCH_TAINTED(rx);
2288 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2292 register PERL_CONTEXT *cx;
2295 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2297 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2299 if (iters++ > maxiters)
2300 DIE(aTHX_ "Substitution loop");
2301 rxtainted |= RX_MATCH_TAINTED(rx);
2302 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2305 orig = RX_SUBBEG(rx);
2307 strend = s + (strend - m);
2309 m = RX_OFFS(rx)[0].start + orig;
2310 if (doutf8 && !SvUTF8(dstr))
2311 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2313 sv_catpvn(dstr, s, m-s);
2314 s = RX_OFFS(rx)[0].end + orig;
2316 sv_catpvn(dstr, c, clen);
2319 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2320 TARG, NULL, r_flags));
2321 if (doutf8 && !DO_UTF8(TARG))
2322 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2324 sv_catpvn(dstr, s, strend - s);
2326 #ifdef PERL_OLD_COPY_ON_WRITE
2327 /* The match may make the string COW. If so, brilliant, because that's
2328 just saved us one malloc, copy and free - the regexp has donated
2329 the old buffer, and we malloc an entirely new one, rather than the
2330 regexp malloc()ing a buffer and copying our original, only for
2331 us to throw it away here during the substitution. */
2332 if (SvIsCOW(TARG)) {
2333 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2339 SvPV_set(TARG, SvPVX(dstr));
2340 SvCUR_set(TARG, SvCUR(dstr));
2341 SvLEN_set(TARG, SvLEN(dstr));
2342 doutf8 |= DO_UTF8(dstr);
2343 SvPV_set(dstr, NULL);
2345 TAINT_IF(rxtainted & 1);
2349 (void)SvPOK_only(TARG);
2352 TAINT_IF(rxtainted);
2355 LEAVE_SCOPE(oldsave);
2364 LEAVE_SCOPE(oldsave);
2373 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2374 ++*PL_markstack_ptr;
2375 LEAVE; /* exit inner scope */
2378 if (PL_stack_base + *PL_markstack_ptr > SP) {
2380 const I32 gimme = GIMME_V;
2382 LEAVE; /* exit outer scope */
2383 (void)POPMARK; /* pop src */
2384 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2385 (void)POPMARK; /* pop dst */
2386 SP = PL_stack_base + POPMARK; /* pop original mark */
2387 if (gimme == G_SCALAR) {
2388 if (PL_op->op_private & OPpGREP_LEX) {
2389 SV* const sv = sv_newmortal();
2390 sv_setiv(sv, items);
2398 else if (gimme == G_ARRAY)
2405 ENTER; /* enter inner scope */
2408 src = PL_stack_base[*PL_markstack_ptr];
2410 if (PL_op->op_private & OPpGREP_LEX)
2411 PAD_SVl(PL_op->op_targ) = src;
2415 RETURNOP(cLOGOP->op_other);
2426 register PERL_CONTEXT *cx;
2429 if (CxMULTICALL(&cxstack[cxstack_ix]))
2433 cxstack_ix++; /* temporarily protect top context */
2436 if (gimme == G_SCALAR) {
2439 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2441 *MARK = SvREFCNT_inc(TOPs);
2446 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2448 *MARK = sv_mortalcopy(sv);
2453 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2457 *MARK = &PL_sv_undef;
2461 else if (gimme == G_ARRAY) {
2462 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2463 if (!SvTEMP(*MARK)) {
2464 *MARK = sv_mortalcopy(*MARK);
2465 TAINT_NOT; /* Each item is independent */
2473 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2474 PL_curpm = newpm; /* ... and pop $1 et al */
2477 return cx->blk_sub.retop;
2480 /* This duplicates the above code because the above code must not
2481 * get any slower by more conditions */
2489 register PERL_CONTEXT *cx;
2492 if (CxMULTICALL(&cxstack[cxstack_ix]))
2496 cxstack_ix++; /* temporarily protect top context */
2500 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2501 /* We are an argument to a function or grep().
2502 * This kind of lvalueness was legal before lvalue
2503 * subroutines too, so be backward compatible:
2504 * cannot report errors. */
2506 /* Scalar context *is* possible, on the LHS of -> only,
2507 * as in f()->meth(). But this is not an lvalue. */
2508 if (gimme == G_SCALAR)
2510 if (gimme == G_ARRAY) {
2511 if (!CvLVALUE(cx->blk_sub.cv))
2512 goto temporise_array;
2513 EXTEND_MORTAL(SP - newsp);
2514 for (mark = newsp + 1; mark <= SP; mark++) {
2517 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2518 *mark = sv_mortalcopy(*mark);
2520 /* Can be a localized value subject to deletion. */
2521 PL_tmps_stack[++PL_tmps_ix] = *mark;
2522 SvREFCNT_inc_void(*mark);
2527 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2528 /* Here we go for robustness, not for speed, so we change all
2529 * the refcounts so the caller gets a live guy. Cannot set
2530 * TEMP, so sv_2mortal is out of question. */
2531 if (!CvLVALUE(cx->blk_sub.cv)) {
2537 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2539 if (gimme == G_SCALAR) {
2543 /* Temporaries are bad unless they happen to be elements
2544 * of a tied hash or array */
2545 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2546 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2552 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2553 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2554 : "a readonly value" : "a temporary");
2556 else { /* Can be a localized value
2557 * subject to deletion. */
2558 PL_tmps_stack[++PL_tmps_ix] = *mark;
2559 SvREFCNT_inc_void(*mark);
2562 else { /* Should not happen? */
2568 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2569 (MARK > SP ? "Empty array" : "Array"));
2573 else if (gimme == G_ARRAY) {
2574 EXTEND_MORTAL(SP - newsp);
2575 for (mark = newsp + 1; mark <= SP; mark++) {
2576 if (*mark != &PL_sv_undef
2577 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2578 /* Might be flattened array after $#array = */
2585 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2586 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2589 /* Can be a localized value subject to deletion. */
2590 PL_tmps_stack[++PL_tmps_ix] = *mark;
2591 SvREFCNT_inc_void(*mark);
2597 if (gimme == G_SCALAR) {
2601 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2603 *MARK = SvREFCNT_inc(TOPs);
2608 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2610 *MARK = sv_mortalcopy(sv);
2615 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2619 *MARK = &PL_sv_undef;
2623 else if (gimme == G_ARRAY) {
2625 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2626 if (!SvTEMP(*MARK)) {
2627 *MARK = sv_mortalcopy(*MARK);
2628 TAINT_NOT; /* Each item is independent */
2637 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2638 PL_curpm = newpm; /* ... and pop $1 et al */
2641 return cx->blk_sub.retop;
2649 register PERL_CONTEXT *cx;
2651 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2654 DIE(aTHX_ "Not a CODE reference");
2655 switch (SvTYPE(sv)) {
2656 /* This is overwhelming the most common case: */
2658 if (!(cv = GvCVu((GV*)sv))) {
2660 cv = sv_2cv(sv, &stash, &gv, 0);
2672 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2674 SP = PL_stack_base + POPMARK;
2677 if (SvGMAGICAL(sv)) {
2682 sym = SvPVX_const(sv);
2690 sym = SvPV_const(sv, len);
2693 DIE(aTHX_ PL_no_usym, "a subroutine");
2694 if (PL_op->op_private & HINT_STRICT_REFS)
2695 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2696 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2701 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2702 tryAMAGICunDEREF(to_cv);
2705 if (SvTYPE(cv) == SVt_PVCV)
2710 DIE(aTHX_ "Not a CODE reference");
2711 /* This is the second most common case: */
2721 if (!CvROOT(cv) && !CvXSUB(cv)) {
2725 /* anonymous or undef'd function leaves us no recourse */
2726 if (CvANON(cv) || !(gv = CvGV(cv)))
2727 DIE(aTHX_ "Undefined subroutine called");
2729 /* autoloaded stub? */
2730 if (cv != GvCV(gv)) {
2733 /* should call AUTOLOAD now? */
2736 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2743 sub_name = sv_newmortal();
2744 gv_efullname3(sub_name, gv, NULL);
2745 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2749 DIE(aTHX_ "Not a CODE reference");
2754 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2755 Perl_get_db_sub(aTHX_ &sv, cv);
2757 PL_curcopdb = PL_curcop;
2758 cv = GvCV(PL_DBsub);
2760 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2761 DIE(aTHX_ "No DB::sub routine defined");
2764 if (!(CvISXSUB(cv))) {
2765 /* This path taken at least 75% of the time */
2767 register I32 items = SP - MARK;
2768 AV* const padlist = CvPADLIST(cv);
2769 PUSHBLOCK(cx, CXt_SUB, MARK);
2771 cx->blk_sub.retop = PL_op->op_next;
2773 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2774 * that eval'' ops within this sub know the correct lexical space.
2775 * Owing the speed considerations, we choose instead to search for
2776 * the cv using find_runcv() when calling doeval().
2778 if (CvDEPTH(cv) >= 2) {
2779 PERL_STACK_OVERFLOW_CHECK();
2780 pad_push(padlist, CvDEPTH(cv));
2783 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2785 AV* const av = (AV*)PAD_SVl(0);
2787 /* @_ is normally not REAL--this should only ever
2788 * happen when DB::sub() calls things that modify @_ */
2793 cx->blk_sub.savearray = GvAV(PL_defgv);
2794 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2795 CX_CURPAD_SAVE(cx->blk_sub);
2796 cx->blk_sub.argarray = av;
2799 if (items > AvMAX(av) + 1) {
2800 SV **ary = AvALLOC(av);
2801 if (AvARRAY(av) != ary) {
2802 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2805 if (items > AvMAX(av) + 1) {
2806 AvMAX(av) = items - 1;
2807 Renew(ary,items,SV*);
2812 Copy(MARK,AvARRAY(av),items,SV*);
2813 AvFILLp(av) = items - 1;
2821 /* warning must come *after* we fully set up the context
2822 * stuff so that __WARN__ handlers can safely dounwind()
2825 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2826 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2827 sub_crush_depth(cv);
2829 DEBUG_S(PerlIO_printf(Perl_debug_log,
2830 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2832 RETURNOP(CvSTART(cv));
2835 I32 markix = TOPMARK;
2840 /* Need to copy @_ to stack. Alternative may be to
2841 * switch stack to @_, and copy return values
2842 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2843 AV * const av = GvAV(PL_defgv);
2844 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2847 /* Mark is at the end of the stack. */
2849 Copy(AvARRAY(av), SP + 1, items, SV*);
2854 /* We assume first XSUB in &DB::sub is the called one. */
2856 SAVEVPTR(PL_curcop);
2857 PL_curcop = PL_curcopdb;
2860 /* Do we need to open block here? XXXX */
2861 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2862 (void)(*CvXSUB(cv))(aTHX_ cv);
2864 /* Enforce some sanity in scalar context. */
2865 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2866 if (markix > PL_stack_sp - PL_stack_base)
2867 *(PL_stack_base + markix) = &PL_sv_undef;
2869 *(PL_stack_base + markix) = *PL_stack_sp;
2870 PL_stack_sp = PL_stack_base + markix;
2878 Perl_sub_crush_depth(pTHX_ CV *cv)
2881 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2883 SV* const tmpstr = sv_newmortal();
2884 gv_efullname3(tmpstr, CvGV(cv), NULL);
2885 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2894 SV* const elemsv = POPs;
2895 IV elem = SvIV(elemsv);
2896 AV* const av = (AV*)POPs;
2897 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2898 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2901 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2902 Perl_warner(aTHX_ packWARN(WARN_MISC),
2903 "Use of reference \"%"SVf"\" as array index",
2906 elem -= CopARYBASE_get(PL_curcop);
2907 if (SvTYPE(av) != SVt_PVAV)
2909 svp = av_fetch(av, elem, lval && !defer);
2911 #ifdef PERL_MALLOC_WRAP
2912 if (SvUOK(elemsv)) {
2913 const UV uv = SvUV(elemsv);
2914 elem = uv > IV_MAX ? IV_MAX : uv;
2916 else if (SvNOK(elemsv))
2917 elem = (IV)SvNV(elemsv);
2919 static const char oom_array_extend[] =
2920 "Out of memory during array extend"; /* Duplicated in av.c */
2921 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2924 if (!svp || *svp == &PL_sv_undef) {
2927 DIE(aTHX_ PL_no_aelem, elem);
2928 lv = sv_newmortal();
2929 sv_upgrade(lv, SVt_PVLV);
2931 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2932 LvTARG(lv) = SvREFCNT_inc_simple(av);
2933 LvTARGOFF(lv) = elem;
2938 if (PL_op->op_private & OPpLVAL_INTRO)
2939 save_aelem(av, elem, svp);
2940 else if (PL_op->op_private & OPpDEREF)
2941 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2943 sv = (svp ? *svp : &PL_sv_undef);
2944 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2945 sv = sv_mortalcopy(sv);
2951 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2956 Perl_croak(aTHX_ PL_no_modify);
2957 prepare_SV_for_RV(sv);
2960 SvRV_set(sv, newSV(0));
2963 SvRV_set(sv, (SV*)newAV());
2966 SvRV_set(sv, (SV*)newHV());
2977 SV* const sv = TOPs;
2980 SV* const rsv = SvRV(sv);
2981 if (SvTYPE(rsv) == SVt_PVCV) {
2987 SETs(method_common(sv, NULL));
2994 SV* const sv = cSVOP_sv;
2995 U32 hash = SvSHARED_HASH(sv);
2997 XPUSHs(method_common(sv, &hash));
3002 S_method_common(pTHX_ SV* meth, U32* hashp)
3009 const char* packname = NULL;
3012 const char * const name = SvPV_const(meth, namelen);
3013 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3016 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3024 /* this isn't a reference */
3025 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3026 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3028 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3035 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3036 !(ob=(SV*)GvIO(iogv)))
3038 /* this isn't the name of a filehandle either */
3040 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3041 ? !isIDFIRST_utf8((U8*)packname)
3042 : !isIDFIRST(*packname)
3045 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3046 SvOK(sv) ? "without a package or object reference"
3047 : "on an undefined value");
3049 /* assume it's a package name */
3050 stash = gv_stashpvn(packname, packlen, 0);
3054 SV* const ref = newSViv(PTR2IV(stash));
3055 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3059 /* it _is_ a filehandle name -- replace with a reference */
3060 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3063 /* if we got here, ob should be a reference or a glob */
3064 if (!ob || !(SvOBJECT(ob)
3065 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3068 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3069 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3073 stash = SvSTASH(ob);
3076 /* NOTE: stash may be null, hope hv_fetch_ent and
3077 gv_fetchmethod can cope (it seems they can) */
3079 /* shortcut for simple names */
3081 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3083 gv = (GV*)HeVAL(he);
3084 if (isGV(gv) && GvCV(gv) &&
3085 (!GvCVGEN(gv) || GvCVGEN(gv)
3086 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3087 return (SV*)GvCV(gv);
3091 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3094 /* This code tries to figure out just what went wrong with
3095 gv_fetchmethod. It therefore needs to duplicate a lot of
3096 the internals of that function. We can't move it inside
3097 Perl_gv_fetchmethod_autoload(), however, since that would
3098 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3101 const char* leaf = name;
3102 const char* sep = NULL;
3105 for (p = name; *p; p++) {
3107 sep = p, leaf = p + 1;
3108 else if (*p == ':' && *(p + 1) == ':')
3109 sep = p, leaf = p + 2;
3111 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3112 /* the method name is unqualified or starts with SUPER:: */
3113 #ifndef USE_ITHREADS
3115 stash = CopSTASH(PL_curcop);
3117 bool need_strlen = 1;
3119 packname = CopSTASHPV(PL_curcop);
3124 HEK * const packhek = HvNAME_HEK(stash);
3126 packname = HEK_KEY(packhek);
3127 packlen = HEK_LEN(packhek);
3139 "Can't use anonymous symbol table for method lookup");
3143 packlen = strlen(packname);
3148 /* the method name is qualified */
3150 packlen = sep - name;
3153 /* we're relying on gv_fetchmethod not autovivifying the stash */
3154 if (gv_stashpvn(packname, packlen, 0)) {
3156 "Can't locate object method \"%s\" via package \"%.*s\"",
3157 leaf, (int)packlen, packname);
3161 "Can't locate object method \"%s\" via package \"%.*s\""
3162 " (perhaps you forgot to load \"%.*s\"?)",
3163 leaf, (int)packlen, packname, (int)packlen, packname);
3166 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3171 * c-indentation-style: bsd
3173 * indent-tabs-mode: t
3176 * ex: set ts=8 sts=4 sw=4 noet: