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)
940 PERL_ARGS_ASSERT_DO_ODDBALL;
946 if (ckWARN(WARN_MISC)) {
948 if (relem == firstrelem &&
950 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
951 SvTYPE(SvRV(*relem)) == SVt_PVHV))
953 err = "Reference found where even-sized list expected";
956 err = "Odd number of elements in hash assignment";
957 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
961 didstore = hv_store_ent(hash,*relem,tmpstr,0);
962 if (SvMAGICAL(hash)) {
963 if (SvSMAGICAL(tmpstr))
975 SV **lastlelem = PL_stack_sp;
976 SV **lastrelem = PL_stack_base + POPMARK;
977 SV **firstrelem = PL_stack_base + POPMARK + 1;
978 SV **firstlelem = lastrelem + 1;
991 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
993 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
996 /* If there's a common identifier on both sides we have to take
997 * special care that assigning the identifier on the left doesn't
998 * clobber a value on the right that's used later in the list.
1000 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
1001 EXTEND_MORTAL(lastrelem - firstrelem + 1);
1002 for (relem = firstrelem; relem <= lastrelem; relem++) {
1003 if ((sv = *relem)) {
1004 TAINT_NOT; /* Each item is independent */
1005 *relem = sv_mortalcopy(sv);
1015 while (lelem <= lastlelem) {
1016 TAINT_NOT; /* Each item stands on its own, taintwise. */
1018 switch (SvTYPE(sv)) {
1021 magic = SvMAGICAL(ary) != 0;
1023 av_extend(ary, lastrelem - relem);
1025 while (relem <= lastrelem) { /* gobble up all the rest */
1028 sv = newSVsv(*relem);
1030 didstore = av_store(ary,i++,sv);
1039 if (PL_delaymagic & DM_ARRAY)
1040 SvSETMAGIC((SV*)ary);
1042 case SVt_PVHV: { /* normal hash */
1046 magic = SvMAGICAL(hash) != 0;
1048 firsthashrelem = relem;
1050 while (relem < lastrelem) { /* gobble up all the rest */
1052 sv = *relem ? *relem : &PL_sv_no;
1056 sv_setsv(tmpstr,*relem); /* value */
1057 *(relem++) = tmpstr;
1058 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1059 /* key overwrites an existing entry */
1061 didstore = hv_store_ent(hash,sv,tmpstr,0);
1063 if (SvSMAGICAL(tmpstr))
1070 if (relem == lastrelem) {
1071 do_oddball(hash, relem, firstrelem);
1077 if (SvIMMORTAL(sv)) {
1078 if (relem <= lastrelem)
1082 if (relem <= lastrelem) {
1083 sv_setsv(sv, *relem);
1087 sv_setsv(sv, &PL_sv_undef);
1092 if (PL_delaymagic & ~DM_DELAY) {
1093 if (PL_delaymagic & DM_UID) {
1094 #ifdef HAS_SETRESUID
1095 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1096 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1099 # ifdef HAS_SETREUID
1100 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1101 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1104 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1105 (void)setruid(PL_uid);
1106 PL_delaymagic &= ~DM_RUID;
1108 # endif /* HAS_SETRUID */
1110 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1111 (void)seteuid(PL_euid);
1112 PL_delaymagic &= ~DM_EUID;
1114 # endif /* HAS_SETEUID */
1115 if (PL_delaymagic & DM_UID) {
1116 if (PL_uid != PL_euid)
1117 DIE(aTHX_ "No setreuid available");
1118 (void)PerlProc_setuid(PL_uid);
1120 # endif /* HAS_SETREUID */
1121 #endif /* HAS_SETRESUID */
1122 PL_uid = PerlProc_getuid();
1123 PL_euid = PerlProc_geteuid();
1125 if (PL_delaymagic & DM_GID) {
1126 #ifdef HAS_SETRESGID
1127 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1128 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1131 # ifdef HAS_SETREGID
1132 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1133 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1136 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1137 (void)setrgid(PL_gid);
1138 PL_delaymagic &= ~DM_RGID;
1140 # endif /* HAS_SETRGID */
1142 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1143 (void)setegid(PL_egid);
1144 PL_delaymagic &= ~DM_EGID;
1146 # endif /* HAS_SETEGID */
1147 if (PL_delaymagic & DM_GID) {
1148 if (PL_gid != PL_egid)
1149 DIE(aTHX_ "No setregid available");
1150 (void)PerlProc_setgid(PL_gid);
1152 # endif /* HAS_SETREGID */
1153 #endif /* HAS_SETRESGID */
1154 PL_gid = PerlProc_getgid();
1155 PL_egid = PerlProc_getegid();
1157 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1161 if (gimme == G_VOID)
1162 SP = firstrelem - 1;
1163 else if (gimme == G_SCALAR) {
1166 SETi(lastrelem - firstrelem + 1 - duplicates);
1173 /* Removes from the stack the entries which ended up as
1174 * duplicated keys in the hash (fix for [perl #24380]) */
1175 Move(firsthashrelem + duplicates,
1176 firsthashrelem, duplicates, SV**);
1177 lastrelem -= duplicates;
1182 SP = firstrelem + (lastlelem - firstlelem);
1183 lelem = firstlelem + (relem - firstrelem);
1185 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1194 register PMOP * const pm = cPMOP;
1195 REGEXP * rx = PM_GETRE(pm);
1196 SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1197 SV * const rv = sv_newmortal();
1199 SvUPGRADE(rv, SVt_IV);
1200 /* This RV is about to own a reference to the regexp. (In addition to the
1201 reference already owned by the PMOP. */
1203 SvRV_set(rv, (SV*) rx);
1207 HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1208 (void)sv_bless(rv, stash);
1211 if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1220 register PMOP *pm = cPMOP;
1222 register const char *t;
1223 register const char *s;
1226 U8 r_flags = REXEC_CHECKED;
1227 const char *truebase; /* Start of string */
1228 register REGEXP *rx = PM_GETRE(pm);
1230 const I32 gimme = GIMME;
1233 const I32 oldsave = PL_savestack_ix;
1234 I32 update_minmatch = 1;
1235 I32 had_zerolen = 0;
1238 if (PL_op->op_flags & OPf_STACKED)
1240 else if (PL_op->op_private & OPpTARGET_MY)
1247 PUTBACK; /* EVAL blocks need stack_sp. */
1248 s = SvPV_const(TARG, len);
1250 DIE(aTHX_ "panic: pp_match");
1252 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1253 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1256 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1258 /* PMdf_USED is set after a ?? matches once */
1261 SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1263 pm->op_pmflags & PMf_USED
1267 if (gimme == G_ARRAY)
1274 /* empty pattern special-cased to use last successful pattern if possible */
1275 if (!RX_PRELEN(rx) && PL_curpm) {
1280 if (RX_MINLEN(rx) > (I32)len)
1285 /* XXXX What part of this is needed with true \G-support? */
1286 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1287 RX_OFFS(rx)[0].start = -1;
1288 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1289 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1290 if (mg && mg->mg_len >= 0) {
1291 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1292 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1293 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1294 r_flags |= REXEC_IGNOREPOS;
1295 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1296 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1299 RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1300 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1301 update_minmatch = 0;
1305 /* XXX: comment out !global get safe $1 vars after a
1306 match, BUT be aware that this leads to dramatic slowdowns on
1307 /g matches against large strings. So far a solution to this problem
1308 appears to be quite tricky.
1309 Test for the unsafe vars are TODO for now. */
1310 if (( !global && RX_NPARENS(rx))
1311 || SvTEMP(TARG) || PL_sawampersand ||
1312 (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1313 r_flags |= REXEC_COPY_STR;
1315 r_flags |= REXEC_SCREAM;
1318 if (global && RX_OFFS(rx)[0].start != -1) {
1319 t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1320 if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1322 if (update_minmatch++)
1323 minmatch = had_zerolen;
1325 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1326 DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1327 /* FIXME - can PL_bostr be made const char *? */
1328 PL_bostr = (char *)truebase;
1329 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1333 if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1335 && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1336 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1337 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1338 && (r_flags & REXEC_SCREAM)))
1339 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1342 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1343 minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1346 if (dynpm->op_pmflags & PMf_ONCE) {
1348 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1350 dynpm->op_pmflags |= PMf_USED;
1361 RX_MATCH_TAINTED_on(rx);
1362 TAINT_IF(RX_MATCH_TAINTED(rx));
1363 if (gimme == G_ARRAY) {
1364 const I32 nparens = RX_NPARENS(rx);
1365 I32 i = (global && !nparens) ? 1 : 0;
1367 SPAGAIN; /* EVAL blocks could move the stack. */
1368 EXTEND(SP, nparens + i);
1369 EXTEND_MORTAL(nparens + i);
1370 for (i = !i; i <= nparens; i++) {
1371 PUSHs(sv_newmortal());
1372 if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1373 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1374 s = RX_OFFS(rx)[i].start + truebase;
1375 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1376 len < 0 || len > strend - s)
1377 DIE(aTHX_ "panic: pp_match start/end pointers");
1378 sv_setpvn(*SP, s, len);
1379 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1384 if (dynpm->op_pmflags & PMf_CONTINUE) {
1386 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1387 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1389 #ifdef PERL_OLD_COPY_ON_WRITE
1391 sv_force_normal_flags(TARG, 0);
1393 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1394 &PL_vtbl_mglob, NULL, 0);
1396 if (RX_OFFS(rx)[0].start != -1) {
1397 mg->mg_len = RX_OFFS(rx)[0].end;
1398 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1399 mg->mg_flags |= MGf_MINMATCH;
1401 mg->mg_flags &= ~MGf_MINMATCH;
1404 had_zerolen = (RX_OFFS(rx)[0].start != -1
1405 && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1406 == (UV)RX_OFFS(rx)[0].end));
1407 PUTBACK; /* EVAL blocks may use stack */
1408 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1413 LEAVE_SCOPE(oldsave);
1419 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1420 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1424 #ifdef PERL_OLD_COPY_ON_WRITE
1426 sv_force_normal_flags(TARG, 0);
1428 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1429 &PL_vtbl_mglob, NULL, 0);
1431 if (RX_OFFS(rx)[0].start != -1) {
1432 mg->mg_len = RX_OFFS(rx)[0].end;
1433 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1434 mg->mg_flags |= MGf_MINMATCH;
1436 mg->mg_flags &= ~MGf_MINMATCH;
1439 LEAVE_SCOPE(oldsave);
1443 yup: /* Confirmed by INTUIT */
1445 RX_MATCH_TAINTED_on(rx);
1446 TAINT_IF(RX_MATCH_TAINTED(rx));
1448 if (dynpm->op_pmflags & PMf_ONCE) {
1450 SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1452 dynpm->op_pmflags |= PMf_USED;
1455 if (RX_MATCH_COPIED(rx))
1456 Safefree(RX_SUBBEG(rx));
1457 RX_MATCH_COPIED_off(rx);
1458 RX_SUBBEG(rx) = NULL;
1460 /* FIXME - should rx->subbeg be const char *? */
1461 RX_SUBBEG(rx) = (char *) truebase;
1462 RX_OFFS(rx)[0].start = s - truebase;
1463 if (RX_MATCH_UTF8(rx)) {
1464 char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1465 RX_OFFS(rx)[0].end = t - truebase;
1468 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1470 RX_SUBLEN(rx) = strend - truebase;
1473 if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1475 #ifdef PERL_OLD_COPY_ON_WRITE
1476 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1478 PerlIO_printf(Perl_debug_log,
1479 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1480 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1483 RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1485 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1486 assert (SvPOKp(RX_SAVED_COPY(rx)));
1491 RX_SUBBEG(rx) = savepvn(t, strend - t);
1492 #ifdef PERL_OLD_COPY_ON_WRITE
1493 RX_SAVED_COPY(rx) = NULL;
1496 RX_SUBLEN(rx) = strend - t;
1497 RX_MATCH_COPIED_on(rx);
1498 off = RX_OFFS(rx)[0].start = s - t;
1499 RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1501 else { /* startp/endp are used by @- @+. */
1502 RX_OFFS(rx)[0].start = s - truebase;
1503 RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1505 /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1507 RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0; /* used by @-, @+, and $^N */
1508 LEAVE_SCOPE(oldsave);
1513 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1514 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1515 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1520 LEAVE_SCOPE(oldsave);
1521 if (gimme == G_ARRAY)
1527 Perl_do_readline(pTHX)
1529 dVAR; dSP; dTARGETSTACKED;
1534 register IO * const io = GvIO(PL_last_in_gv);
1535 register const I32 type = PL_op->op_type;
1536 const I32 gimme = GIMME_V;
1539 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1542 XPUSHs(SvTIED_obj((SV*)io, mg));
1545 call_method("READLINE", gimme);
1548 if (gimme == G_SCALAR) {
1549 SV* const result = POPs;
1550 SvSetSV_nosteal(TARG, result);
1560 if (IoFLAGS(io) & IOf_ARGV) {
1561 if (IoFLAGS(io) & IOf_START) {
1563 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1564 IoFLAGS(io) &= ~IOf_START;
1565 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1566 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1567 SvSETMAGIC(GvSV(PL_last_in_gv));
1572 fp = nextargv(PL_last_in_gv);
1573 if (!fp) { /* Note: fp != IoIFP(io) */
1574 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1577 else if (type == OP_GLOB)
1578 fp = Perl_start_glob(aTHX_ POPs, io);
1580 else if (type == OP_GLOB)
1582 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1583 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1587 if ((!io || !(IoFLAGS(io) & IOf_START))
1588 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1590 if (type == OP_GLOB)
1591 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1592 "glob failed (can't start child: %s)",
1595 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1597 if (gimme == G_SCALAR) {
1598 /* undef TARG, and push that undefined value */
1599 if (type != OP_RCATLINE) {
1600 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1608 if (gimme == G_SCALAR) {
1610 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1613 if (type == OP_RCATLINE)
1614 SvPV_force_nolen(sv);
1618 else if (isGV_with_GP(sv)) {
1619 SvPV_force_nolen(sv);
1621 SvUPGRADE(sv, SVt_PV);
1622 tmplen = SvLEN(sv); /* remember if already alloced */
1623 if (!tmplen && !SvREADONLY(sv))
1624 Sv_Grow(sv, 80); /* try short-buffering it */
1626 if (type == OP_RCATLINE && SvOK(sv)) {
1628 SvPV_force_nolen(sv);
1634 sv = sv_2mortal(newSV(80));
1638 /* This should not be marked tainted if the fp is marked clean */
1639 #define MAYBE_TAINT_LINE(io, sv) \
1640 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1645 /* delay EOF state for a snarfed empty file */
1646 #define SNARF_EOF(gimme,rs,io,sv) \
1647 (gimme != G_SCALAR || SvCUR(sv) \
1648 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1652 if (!sv_gets(sv, fp, offset)
1654 || SNARF_EOF(gimme, PL_rs, io, sv)
1655 || PerlIO_error(fp)))
1657 PerlIO_clearerr(fp);
1658 if (IoFLAGS(io) & IOf_ARGV) {
1659 fp = nextargv(PL_last_in_gv);
1662 (void)do_close(PL_last_in_gv, FALSE);
1664 else if (type == OP_GLOB) {
1665 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1666 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1667 "glob failed (child exited with status %d%s)",
1668 (int)(STATUS_CURRENT >> 8),
1669 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1672 if (gimme == G_SCALAR) {
1673 if (type != OP_RCATLINE) {
1674 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1680 MAYBE_TAINT_LINE(io, sv);
1683 MAYBE_TAINT_LINE(io, sv);
1685 IoFLAGS(io) |= IOf_NOLINE;
1689 if (type == OP_GLOB) {
1692 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1693 char * const tmps = SvEND(sv) - 1;
1694 if (*tmps == *SvPVX_const(PL_rs)) {
1696 SvCUR_set(sv, SvCUR(sv) - 1);
1699 for (t1 = SvPVX_const(sv); *t1; t1++)
1700 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1701 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1703 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1704 (void)POPs; /* Unmatched wildcard? Chuck it... */
1707 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1708 if (ckWARN(WARN_UTF8)) {
1709 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1710 const STRLEN len = SvCUR(sv) - offset;
1713 if (!is_utf8_string_loc(s, len, &f))
1714 /* Emulate :encoding(utf8) warning in the same case. */
1715 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1716 "utf8 \"\\x%02X\" does not map to Unicode",
1717 f < (U8*)SvEND(sv) ? *f : 0);
1720 if (gimme == G_ARRAY) {
1721 if (SvLEN(sv) - SvCUR(sv) > 20) {
1722 SvPV_shrink_to_cur(sv);
1724 sv = sv_2mortal(newSV(80));
1727 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1728 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1729 const STRLEN new_len
1730 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1731 SvPV_renew(sv, new_len);
1740 register PERL_CONTEXT *cx;
1741 I32 gimme = OP_GIMME(PL_op, -1);
1744 if (cxstack_ix >= 0)
1745 gimme = cxstack[cxstack_ix].blk_gimme;
1753 PUSHBLOCK(cx, CXt_BLOCK, SP);
1763 SV * const keysv = POPs;
1764 HV * const hv = (HV*)POPs;
1765 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1766 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1768 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1771 if (SvTYPE(hv) != SVt_PVHV)
1774 if (PL_op->op_private & OPpLVAL_INTRO) {
1777 /* does the element we're localizing already exist? */
1778 preeminent = /* can we determine whether it exists? */
1780 || mg_find((SV*)hv, PERL_MAGIC_env)
1781 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1782 /* Try to preserve the existenceness of a tied hash
1783 * element by using EXISTS and DELETE if possible.
1784 * Fallback to FETCH and STORE otherwise */
1785 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1786 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1787 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1789 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1791 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1792 svp = he ? &HeVAL(he) : NULL;
1794 if (!svp || *svp == &PL_sv_undef) {
1798 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1800 lv = sv_newmortal();
1801 sv_upgrade(lv, SVt_PVLV);
1803 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1804 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1805 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1810 if (PL_op->op_private & OPpLVAL_INTRO) {
1811 if (HvNAME_get(hv) && isGV(*svp))
1812 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1816 const char * const key = SvPV_const(keysv, keylen);
1817 SAVEDELETE(hv, savepvn(key,keylen),
1818 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1820 save_helem(hv, keysv, svp);
1823 else if (PL_op->op_private & OPpDEREF)
1824 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1826 sv = (svp ? *svp : &PL_sv_undef);
1827 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1828 * Pushing the magical RHS on to the stack is useless, since
1829 * that magic is soon destined to be misled by the local(),
1830 * and thus the later pp_sassign() will fail to mg_get() the
1831 * old value. This should also cure problems with delayed
1832 * mg_get()s. GSAR 98-07-03 */
1833 if (!lval && SvGMAGICAL(sv))
1834 sv = sv_mortalcopy(sv);
1842 register PERL_CONTEXT *cx;
1847 if (PL_op->op_flags & OPf_SPECIAL) {
1848 cx = &cxstack[cxstack_ix];
1849 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1854 gimme = OP_GIMME(PL_op, -1);
1856 if (cxstack_ix >= 0)
1857 gimme = cxstack[cxstack_ix].blk_gimme;
1863 if (gimme == G_VOID)
1865 else if (gimme == G_SCALAR) {
1869 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1872 *MARK = sv_mortalcopy(TOPs);
1875 *MARK = &PL_sv_undef;
1879 else if (gimme == G_ARRAY) {
1880 /* in case LEAVE wipes old return values */
1882 for (mark = newsp + 1; mark <= SP; mark++) {
1883 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1884 *mark = sv_mortalcopy(*mark);
1885 TAINT_NOT; /* Each item is independent */
1889 PL_curpm = newpm; /* Don't pop $1 et al till now */
1899 register PERL_CONTEXT *cx;
1902 AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1903 bool av_is_stack = FALSE;
1906 cx = &cxstack[cxstack_ix];
1907 if (!CxTYPE_is_LOOP(cx))
1908 DIE(aTHX_ "panic: pp_iter");
1910 itersvp = CxITERVAR(cx);
1911 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1912 /* string increment */
1913 SV* cur = cx->blk_loop.state_u.lazysv.cur;
1914 SV *end = cx->blk_loop.state_u.lazysv.end;
1915 /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1916 It has SvPVX of "" and SvCUR of 0, which is what we want. */
1918 const char *max = SvPV_const(end, maxlen);
1919 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1920 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1921 /* safe to reuse old SV */
1922 sv_setsv(*itersvp, cur);
1926 /* we need a fresh SV every time so that loop body sees a
1927 * completely new SV for closures/references to work as
1930 *itersvp = newSVsv(cur);
1931 SvREFCNT_dec(oldsv);
1933 if (strEQ(SvPVX_const(cur), max))
1934 sv_setiv(cur, 0); /* terminate next time */
1941 else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1942 /* integer increment */
1943 if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1946 /* don't risk potential race */
1947 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1948 /* safe to reuse old SV */
1949 sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1953 /* we need a fresh SV every time so that loop body sees a
1954 * completely new SV for closures/references to work as they
1957 *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1958 SvREFCNT_dec(oldsv);
1961 /* Handle end of range at IV_MAX */
1962 if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1963 (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1965 cx->blk_loop.state_u.lazyiv.cur++;
1966 cx->blk_loop.state_u.lazyiv.end++;
1973 assert(CxTYPE(cx) == CXt_LOOP_FOR);
1974 av = cx->blk_loop.state_u.ary.ary;
1979 if (PL_op->op_private & OPpITER_REVERSED) {
1980 if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1981 ? cx->blk_loop.resetsp + 1 : 0))
1984 if (SvMAGICAL(av) || AvREIFY(av)) {
1985 SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1986 sv = svp ? *svp : NULL;
1989 sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1993 if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1997 if (SvMAGICAL(av) || AvREIFY(av)) {
1998 SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1999 sv = svp ? *svp : NULL;
2002 sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2006 if (sv && SvIS_FREED(sv)) {
2008 Perl_croak(aTHX_ "Use of freed value in iteration");
2013 SvREFCNT_inc_simple_void_NN(sv);
2017 if (!av_is_stack && sv == &PL_sv_undef) {
2018 SV *lv = newSV_type(SVt_PVLV);
2020 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2021 LvTARG(lv) = SvREFCNT_inc_simple(av);
2022 LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2023 LvTARGLEN(lv) = (STRLEN)UV_MAX;
2029 SvREFCNT_dec(oldsv);
2037 register PMOP *pm = cPMOP;
2052 register REGEXP *rx = PM_GETRE(pm);
2054 int force_on_match = 0;
2055 const I32 oldsave = PL_savestack_ix;
2057 bool doutf8 = FALSE;
2059 #ifdef PERL_OLD_COPY_ON_WRITE
2064 /* known replacement string? */
2065 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2066 if (PL_op->op_flags & OPf_STACKED)
2068 else if (PL_op->op_private & OPpTARGET_MY)
2075 #ifdef PERL_OLD_COPY_ON_WRITE
2076 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2077 because they make integers such as 256 "false". */
2078 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2081 sv_force_normal_flags(TARG,0);
2084 #ifdef PERL_OLD_COPY_ON_WRITE
2088 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2089 || SvTYPE(TARG) > SVt_PVLV)
2090 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2091 DIE(aTHX_ PL_no_modify);
2094 s = SvPV_mutable(TARG, len);
2095 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2097 rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2098 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2103 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2107 DIE(aTHX_ "panic: pp_subst");
2110 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2111 maxiters = 2 * slen + 10; /* We can match twice at each
2112 position, once with zero-length,
2113 second time with non-zero. */
2115 if (!RX_PRELEN(rx) && PL_curpm) {
2119 r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2120 || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2121 ? REXEC_COPY_STR : 0;
2123 r_flags |= REXEC_SCREAM;
2126 if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2128 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2132 /* How to do it in subst? */
2133 /* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2135 && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2136 && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2137 || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2138 && (r_flags & REXEC_SCREAM))))
2143 /* only replace once? */
2144 once = !(rpm->op_pmflags & PMf_GLOBAL);
2145 matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2146 r_flags | REXEC_CHECKED);
2147 /* known replacement string? */
2149 /* replacement needing upgrading? */
2150 if (DO_UTF8(TARG) && !doutf8) {
2151 nsv = sv_newmortal();
2154 sv_recode_to_utf8(nsv, PL_encoding);
2156 sv_utf8_upgrade(nsv);
2157 c = SvPV_const(nsv, clen);
2161 c = SvPV_const(dstr, clen);
2162 doutf8 = DO_UTF8(dstr);
2170 /* can do inplace substitution? */
2172 #ifdef PERL_OLD_COPY_ON_WRITE
2175 && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2176 && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2177 && (!doutf8 || SvUTF8(TARG))) {
2182 LEAVE_SCOPE(oldsave);
2185 #ifdef PERL_OLD_COPY_ON_WRITE
2186 if (SvIsCOW(TARG)) {
2187 assert (!force_on_match);
2191 if (force_on_match) {
2193 s = SvPV_force(TARG, len);
2198 SvSCREAM_off(TARG); /* disable possible screamer */
2200 rxtainted |= RX_MATCH_TAINTED(rx);
2201 m = orig + RX_OFFS(rx)[0].start;
2202 d = orig + RX_OFFS(rx)[0].end;
2204 if (m - s > strend - d) { /* faster to shorten from end */
2206 Copy(c, m, clen, char);
2211 Move(d, m, i, char);
2215 SvCUR_set(TARG, m - s);
2217 else if ((i = m - s)) { /* faster from front */
2220 Move(s, d - i, i, char);
2223 Copy(c, m, clen, char);
2228 Copy(c, d, clen, char);
2233 TAINT_IF(rxtainted & 1);
2239 if (iters++ > maxiters)
2240 DIE(aTHX_ "Substitution loop");
2241 rxtainted |= RX_MATCH_TAINTED(rx);
2242 m = RX_OFFS(rx)[0].start + orig;
2245 Move(s, d, i, char);
2249 Copy(c, d, clen, char);
2252 s = RX_OFFS(rx)[0].end + orig;
2253 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2255 /* don't match same null twice */
2256 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2259 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2260 Move(s, d, i+1, char); /* include the NUL */
2262 TAINT_IF(rxtainted & 1);
2266 (void)SvPOK_only_UTF8(TARG);
2267 TAINT_IF(rxtainted);
2268 if (SvSMAGICAL(TARG)) {
2276 LEAVE_SCOPE(oldsave);
2282 if (force_on_match) {
2284 s = SvPV_force(TARG, len);
2287 #ifdef PERL_OLD_COPY_ON_WRITE
2290 rxtainted |= RX_MATCH_TAINTED(rx);
2291 dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2295 register PERL_CONTEXT *cx;
2298 RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2300 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2302 if (iters++ > maxiters)
2303 DIE(aTHX_ "Substitution loop");
2304 rxtainted |= RX_MATCH_TAINTED(rx);
2305 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2308 orig = RX_SUBBEG(rx);
2310 strend = s + (strend - m);
2312 m = RX_OFFS(rx)[0].start + orig;
2313 if (doutf8 && !SvUTF8(dstr))
2314 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2316 sv_catpvn(dstr, s, m-s);
2317 s = RX_OFFS(rx)[0].end + orig;
2319 sv_catpvn(dstr, c, clen);
2322 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2323 TARG, NULL, r_flags));
2324 if (doutf8 && !DO_UTF8(TARG))
2325 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2327 sv_catpvn(dstr, s, strend - s);
2329 #ifdef PERL_OLD_COPY_ON_WRITE
2330 /* The match may make the string COW. If so, brilliant, because that's
2331 just saved us one malloc, copy and free - the regexp has donated
2332 the old buffer, and we malloc an entirely new one, rather than the
2333 regexp malloc()ing a buffer and copying our original, only for
2334 us to throw it away here during the substitution. */
2335 if (SvIsCOW(TARG)) {
2336 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2342 SvPV_set(TARG, SvPVX(dstr));
2343 SvCUR_set(TARG, SvCUR(dstr));
2344 SvLEN_set(TARG, SvLEN(dstr));
2345 doutf8 |= DO_UTF8(dstr);
2346 SvPV_set(dstr, NULL);
2348 TAINT_IF(rxtainted & 1);
2352 (void)SvPOK_only(TARG);
2355 TAINT_IF(rxtainted);
2358 LEAVE_SCOPE(oldsave);
2367 LEAVE_SCOPE(oldsave);
2376 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2377 ++*PL_markstack_ptr;
2378 LEAVE; /* exit inner scope */
2381 if (PL_stack_base + *PL_markstack_ptr > SP) {
2383 const I32 gimme = GIMME_V;
2385 LEAVE; /* exit outer scope */
2386 (void)POPMARK; /* pop src */
2387 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2388 (void)POPMARK; /* pop dst */
2389 SP = PL_stack_base + POPMARK; /* pop original mark */
2390 if (gimme == G_SCALAR) {
2391 if (PL_op->op_private & OPpGREP_LEX) {
2392 SV* const sv = sv_newmortal();
2393 sv_setiv(sv, items);
2401 else if (gimme == G_ARRAY)
2408 ENTER; /* enter inner scope */
2411 src = PL_stack_base[*PL_markstack_ptr];
2413 if (PL_op->op_private & OPpGREP_LEX)
2414 PAD_SVl(PL_op->op_targ) = src;
2418 RETURNOP(cLOGOP->op_other);
2429 register PERL_CONTEXT *cx;
2432 if (CxMULTICALL(&cxstack[cxstack_ix]))
2436 cxstack_ix++; /* temporarily protect top context */
2439 if (gimme == G_SCALAR) {
2442 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2444 *MARK = SvREFCNT_inc(TOPs);
2449 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2451 *MARK = sv_mortalcopy(sv);
2456 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2460 *MARK = &PL_sv_undef;
2464 else if (gimme == G_ARRAY) {
2465 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2466 if (!SvTEMP(*MARK)) {
2467 *MARK = sv_mortalcopy(*MARK);
2468 TAINT_NOT; /* Each item is independent */
2476 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2477 PL_curpm = newpm; /* ... and pop $1 et al */
2480 return cx->blk_sub.retop;
2483 /* This duplicates the above code because the above code must not
2484 * get any slower by more conditions */
2492 register PERL_CONTEXT *cx;
2495 if (CxMULTICALL(&cxstack[cxstack_ix]))
2499 cxstack_ix++; /* temporarily protect top context */
2503 if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2504 /* We are an argument to a function or grep().
2505 * This kind of lvalueness was legal before lvalue
2506 * subroutines too, so be backward compatible:
2507 * cannot report errors. */
2509 /* Scalar context *is* possible, on the LHS of -> only,
2510 * as in f()->meth(). But this is not an lvalue. */
2511 if (gimme == G_SCALAR)
2513 if (gimme == G_ARRAY) {
2514 if (!CvLVALUE(cx->blk_sub.cv))
2515 goto temporise_array;
2516 EXTEND_MORTAL(SP - newsp);
2517 for (mark = newsp + 1; mark <= SP; mark++) {
2520 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2521 *mark = sv_mortalcopy(*mark);
2523 /* Can be a localized value subject to deletion. */
2524 PL_tmps_stack[++PL_tmps_ix] = *mark;
2525 SvREFCNT_inc_void(*mark);
2530 else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
2531 /* Here we go for robustness, not for speed, so we change all
2532 * the refcounts so the caller gets a live guy. Cannot set
2533 * TEMP, so sv_2mortal is out of question. */
2534 if (!CvLVALUE(cx->blk_sub.cv)) {
2540 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2542 if (gimme == G_SCALAR) {
2546 /* Temporaries are bad unless they happen to be elements
2547 * of a tied hash or array */
2548 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2549 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2555 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2556 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2557 : "a readonly value" : "a temporary");
2559 else { /* Can be a localized value
2560 * subject to deletion. */
2561 PL_tmps_stack[++PL_tmps_ix] = *mark;
2562 SvREFCNT_inc_void(*mark);
2565 else { /* Should not happen? */
2571 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2572 (MARK > SP ? "Empty array" : "Array"));
2576 else if (gimme == G_ARRAY) {
2577 EXTEND_MORTAL(SP - newsp);
2578 for (mark = newsp + 1; mark <= SP; mark++) {
2579 if (*mark != &PL_sv_undef
2580 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2581 /* Might be flattened array after $#array = */
2588 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2589 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2592 /* Can be a localized value subject to deletion. */
2593 PL_tmps_stack[++PL_tmps_ix] = *mark;
2594 SvREFCNT_inc_void(*mark);
2600 if (gimme == G_SCALAR) {
2604 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2606 *MARK = SvREFCNT_inc(TOPs);
2611 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2613 *MARK = sv_mortalcopy(sv);
2618 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2622 *MARK = &PL_sv_undef;
2626 else if (gimme == G_ARRAY) {
2628 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2629 if (!SvTEMP(*MARK)) {
2630 *MARK = sv_mortalcopy(*MARK);
2631 TAINT_NOT; /* Each item is independent */
2640 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2641 PL_curpm = newpm; /* ... and pop $1 et al */
2644 return cx->blk_sub.retop;
2652 register PERL_CONTEXT *cx;
2654 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2657 DIE(aTHX_ "Not a CODE reference");
2658 switch (SvTYPE(sv)) {
2659 /* This is overwhelming the most common case: */
2661 if (!(cv = GvCVu((GV*)sv))) {
2663 cv = sv_2cv(sv, &stash, &gv, 0);
2675 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2677 SP = PL_stack_base + POPMARK;
2680 if (SvGMAGICAL(sv)) {
2685 sym = SvPVX_const(sv);
2693 sym = SvPV_const(sv, len);
2696 DIE(aTHX_ PL_no_usym, "a subroutine");
2697 if (PL_op->op_private & HINT_STRICT_REFS)
2698 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2699 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2704 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2705 tryAMAGICunDEREF(to_cv);
2708 if (SvTYPE(cv) == SVt_PVCV)
2713 DIE(aTHX_ "Not a CODE reference");
2714 /* This is the second most common case: */
2724 if (!CvROOT(cv) && !CvXSUB(cv)) {
2728 /* anonymous or undef'd function leaves us no recourse */
2729 if (CvANON(cv) || !(gv = CvGV(cv)))
2730 DIE(aTHX_ "Undefined subroutine called");
2732 /* autoloaded stub? */
2733 if (cv != GvCV(gv)) {
2736 /* should call AUTOLOAD now? */
2739 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2746 sub_name = sv_newmortal();
2747 gv_efullname3(sub_name, gv, NULL);
2748 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2752 DIE(aTHX_ "Not a CODE reference");
2757 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2758 Perl_get_db_sub(aTHX_ &sv, cv);
2760 PL_curcopdb = PL_curcop;
2761 cv = GvCV(PL_DBsub);
2763 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2764 DIE(aTHX_ "No DB::sub routine defined");
2767 if (!(CvISXSUB(cv))) {
2768 /* This path taken at least 75% of the time */
2770 register I32 items = SP - MARK;
2771 AV* const padlist = CvPADLIST(cv);
2772 PUSHBLOCK(cx, CXt_SUB, MARK);
2774 cx->blk_sub.retop = PL_op->op_next;
2776 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2777 * that eval'' ops within this sub know the correct lexical space.
2778 * Owing the speed considerations, we choose instead to search for
2779 * the cv using find_runcv() when calling doeval().
2781 if (CvDEPTH(cv) >= 2) {
2782 PERL_STACK_OVERFLOW_CHECK();
2783 pad_push(padlist, CvDEPTH(cv));
2786 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2788 AV* const av = (AV*)PAD_SVl(0);
2790 /* @_ is normally not REAL--this should only ever
2791 * happen when DB::sub() calls things that modify @_ */
2796 cx->blk_sub.savearray = GvAV(PL_defgv);
2797 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2798 CX_CURPAD_SAVE(cx->blk_sub);
2799 cx->blk_sub.argarray = av;
2802 if (items > AvMAX(av) + 1) {
2803 SV **ary = AvALLOC(av);
2804 if (AvARRAY(av) != ary) {
2805 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2808 if (items > AvMAX(av) + 1) {
2809 AvMAX(av) = items - 1;
2810 Renew(ary,items,SV*);
2815 Copy(MARK,AvARRAY(av),items,SV*);
2816 AvFILLp(av) = items - 1;
2824 /* warning must come *after* we fully set up the context
2825 * stuff so that __WARN__ handlers can safely dounwind()
2828 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2829 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2830 sub_crush_depth(cv);
2832 DEBUG_S(PerlIO_printf(Perl_debug_log,
2833 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2835 RETURNOP(CvSTART(cv));
2838 I32 markix = TOPMARK;
2843 /* Need to copy @_ to stack. Alternative may be to
2844 * switch stack to @_, and copy return values
2845 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2846 AV * const av = GvAV(PL_defgv);
2847 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2850 /* Mark is at the end of the stack. */
2852 Copy(AvARRAY(av), SP + 1, items, SV*);
2857 /* We assume first XSUB in &DB::sub is the called one. */
2859 SAVEVPTR(PL_curcop);
2860 PL_curcop = PL_curcopdb;
2863 /* Do we need to open block here? XXXX */
2864 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2865 (void)(*CvXSUB(cv))(aTHX_ cv);
2867 /* Enforce some sanity in scalar context. */
2868 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2869 if (markix > PL_stack_sp - PL_stack_base)
2870 *(PL_stack_base + markix) = &PL_sv_undef;
2872 *(PL_stack_base + markix) = *PL_stack_sp;
2873 PL_stack_sp = PL_stack_base + markix;
2881 Perl_sub_crush_depth(pTHX_ CV *cv)
2883 PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2886 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2888 SV* const tmpstr = sv_newmortal();
2889 gv_efullname3(tmpstr, CvGV(cv), NULL);
2890 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2899 SV* const elemsv = POPs;
2900 IV elem = SvIV(elemsv);
2901 AV* const av = (AV*)POPs;
2902 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2903 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2906 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2907 Perl_warner(aTHX_ packWARN(WARN_MISC),
2908 "Use of reference \"%"SVf"\" as array index",
2911 elem -= CopARYBASE_get(PL_curcop);
2912 if (SvTYPE(av) != SVt_PVAV)
2914 svp = av_fetch(av, elem, lval && !defer);
2916 #ifdef PERL_MALLOC_WRAP
2917 if (SvUOK(elemsv)) {
2918 const UV uv = SvUV(elemsv);
2919 elem = uv > IV_MAX ? IV_MAX : uv;
2921 else if (SvNOK(elemsv))
2922 elem = (IV)SvNV(elemsv);
2924 static const char oom_array_extend[] =
2925 "Out of memory during array extend"; /* Duplicated in av.c */
2926 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2929 if (!svp || *svp == &PL_sv_undef) {
2932 DIE(aTHX_ PL_no_aelem, elem);
2933 lv = sv_newmortal();
2934 sv_upgrade(lv, SVt_PVLV);
2936 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2937 LvTARG(lv) = SvREFCNT_inc_simple(av);
2938 LvTARGOFF(lv) = elem;
2943 if (PL_op->op_private & OPpLVAL_INTRO)
2944 save_aelem(av, elem, svp);
2945 else if (PL_op->op_private & OPpDEREF)
2946 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2948 sv = (svp ? *svp : &PL_sv_undef);
2949 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2950 sv = sv_mortalcopy(sv);
2956 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2958 PERL_ARGS_ASSERT_VIVIFY_REF;
2963 Perl_croak(aTHX_ PL_no_modify);
2964 prepare_SV_for_RV(sv);
2967 SvRV_set(sv, newSV(0));
2970 SvRV_set(sv, (SV*)newAV());
2973 SvRV_set(sv, (SV*)newHV());
2984 SV* const sv = TOPs;
2987 SV* const rsv = SvRV(sv);
2988 if (SvTYPE(rsv) == SVt_PVCV) {
2994 SETs(method_common(sv, NULL));
3001 SV* const sv = cSVOP_sv;
3002 U32 hash = SvSHARED_HASH(sv);
3004 XPUSHs(method_common(sv, &hash));
3009 S_method_common(pTHX_ SV* meth, U32* hashp)
3016 const char* packname = NULL;
3019 const char * const name = SvPV_const(meth, namelen);
3020 SV * const sv = *(PL_stack_base + TOPMARK + 1);
3022 PERL_ARGS_ASSERT_METHOD_COMMON;
3025 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3033 /* this isn't a reference */
3034 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3035 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3037 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3044 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3045 !(ob=(SV*)GvIO(iogv)))
3047 /* this isn't the name of a filehandle either */
3049 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3050 ? !isIDFIRST_utf8((U8*)packname)
3051 : !isIDFIRST(*packname)
3054 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3055 SvOK(sv) ? "without a package or object reference"
3056 : "on an undefined value");
3058 /* assume it's a package name */
3059 stash = gv_stashpvn(packname, packlen, 0);
3063 SV* const ref = newSViv(PTR2IV(stash));
3064 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3068 /* it _is_ a filehandle name -- replace with a reference */
3069 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3072 /* if we got here, ob should be a reference or a glob */
3073 if (!ob || !(SvOBJECT(ob)
3074 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3077 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3078 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3082 stash = SvSTASH(ob);
3085 /* NOTE: stash may be null, hope hv_fetch_ent and
3086 gv_fetchmethod can cope (it seems they can) */
3088 /* shortcut for simple names */
3090 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3092 gv = (GV*)HeVAL(he);
3093 if (isGV(gv) && GvCV(gv) &&
3094 (!GvCVGEN(gv) || GvCVGEN(gv)
3095 == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3096 return (SV*)GvCV(gv);
3100 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3103 /* This code tries to figure out just what went wrong with
3104 gv_fetchmethod. It therefore needs to duplicate a lot of
3105 the internals of that function. We can't move it inside
3106 Perl_gv_fetchmethod_autoload(), however, since that would
3107 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3110 const char* leaf = name;
3111 const char* sep = NULL;
3114 for (p = name; *p; p++) {
3116 sep = p, leaf = p + 1;
3117 else if (*p == ':' && *(p + 1) == ':')
3118 sep = p, leaf = p + 2;
3120 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3121 /* the method name is unqualified or starts with SUPER:: */
3122 #ifndef USE_ITHREADS
3124 stash = CopSTASH(PL_curcop);
3126 bool need_strlen = 1;
3128 packname = CopSTASHPV(PL_curcop);
3133 HEK * const packhek = HvNAME_HEK(stash);
3135 packname = HEK_KEY(packhek);
3136 packlen = HEK_LEN(packhek);
3148 "Can't use anonymous symbol table for method lookup");
3152 packlen = strlen(packname);
3157 /* the method name is qualified */
3159 packlen = sep - name;
3162 /* we're relying on gv_fetchmethod not autovivifying the stash */
3163 if (gv_stashpvn(packname, packlen, 0)) {
3165 "Can't locate object method \"%s\" via package \"%.*s\"",
3166 leaf, (int)packlen, packname);
3170 "Can't locate object method \"%s\" via package \"%.*s\""
3171 " (perhaps you forgot to load \"%.*s\"?)",
3172 leaf, (int)packlen, packname, (int)packlen, packname);
3175 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3180 * c-indentation-style: bsd
3182 * indent-tabs-mode: t
3185 * ex: set ts=8 sts=4 sw=4 noet: