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 XPUSHs(sv_2mortal((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv)));
56 PL_curcop = (COP*)PL_op;
57 TAINT_NOT; /* Each statement is presumed innocent */
58 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
68 if (PL_op->op_private & OPpLVAL_INTRO)
69 PUSHs(save_scalar(cGVOP_gv));
71 PUSHs(GvSVn(cGVOP_gv));
84 PL_curcop = (COP*)PL_op;
91 PUSHMARK(PL_stack_sp);
106 XPUSHs((SV*)cGVOP_gv);
116 if (PL_op->op_type == OP_AND)
118 RETURNOP(cLOGOP->op_other);
124 dVAR; dSP; dPOPTOPssrl;
126 if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
127 SV * const temp = left;
128 left = right; right = temp;
130 else if (PL_op->op_private & OPpASSIGN_STATE) {
131 if (SvPADSTALE(right))
132 SvPADSTALE_off(right);
134 RETURN; /* ignore assignment */
136 if (PL_tainting && PL_tainted && !SvTAINTED(left))
138 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
139 SV * const cv = SvRV(left);
140 const U32 cv_type = SvTYPE(cv);
141 const U32 gv_type = SvTYPE(right);
142 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
148 /* Can do the optimisation if right (LVALUE) is not a typeglob,
149 left (RVALUE) is a reference to something, and we're in void
151 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
152 /* Is the target symbol table currently empty? */
153 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
154 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
155 /* Good. Create a new proxy constant subroutine in the target.
156 The gv becomes a(nother) reference to the constant. */
157 SV *const value = SvRV(cv);
159 SvUPGRADE((SV *)gv, SVt_RV);
160 SvPCS_IMPORTED_on(gv);
162 SvREFCNT_inc_simple_void(value);
168 /* Need to fix things up. */
169 if (gv_type != SVt_PVGV) {
170 /* Need to fix GV. */
171 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
175 /* We've been returned a constant rather than a full subroutine,
176 but they expect a subroutine reference to apply. */
178 SvREFCNT_inc_void(SvRV(cv));
179 /* newCONSTSUB takes a reference count on the passed in SV
180 from us. We set the name to NULL, otherwise we get into
181 all sorts of fun as the reference to our new sub is
182 donated to the GV that we're about to assign to.
184 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
190 if (strEQ(GvNAME(right),"isa")) {
195 SvSetMagicSV(right, left);
204 RETURNOP(cLOGOP->op_other);
206 RETURNOP(cLOGOP->op_next);
213 TAINT_NOT; /* Each statement is presumed innocent */
214 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
216 oldsave = PL_scopestack[PL_scopestack_ix - 1];
217 LEAVE_SCOPE(oldsave);
223 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
228 const char *rpv = NULL;
230 bool rcopied = FALSE;
232 if (TARG == right && right != left) {
233 /* mg_get(right) may happen here ... */
234 rpv = SvPV_const(right, rlen);
235 rbyte = !DO_UTF8(right);
236 right = sv_2mortal(newSVpvn(rpv, rlen));
237 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
243 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
244 lbyte = !DO_UTF8(left);
245 sv_setpvn(TARG, lpv, llen);
251 else { /* TARG == left */
253 SvGETMAGIC(left); /* or mg_get(left) may happen here */
255 if (left == right && ckWARN(WARN_UNINITIALIZED))
256 report_uninit(right);
257 sv_setpvn(left, "", 0);
259 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
260 lbyte = !DO_UTF8(left);
265 /* or mg_get(right) may happen here */
267 rpv = SvPV_const(right, rlen);
268 rbyte = !DO_UTF8(right);
270 if (lbyte != rbyte) {
272 sv_utf8_upgrade_nomg(TARG);
275 right = sv_2mortal(newSVpvn(rpv, rlen));
276 sv_utf8_upgrade_nomg(right);
277 rpv = SvPV_const(right, rlen);
280 sv_catpvn_nomg(TARG, rpv, rlen);
291 if (PL_op->op_flags & OPf_MOD) {
292 if (PL_op->op_private & OPpLVAL_INTRO)
293 if (!(PL_op->op_private & OPpPAD_STATE))
294 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
295 if (PL_op->op_private & OPpDEREF) {
297 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
307 tryAMAGICunTARGET(iter, 0);
308 PL_last_in_gv = (GV*)(*PL_stack_sp--);
309 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
310 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
311 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
314 XPUSHs((SV*)PL_last_in_gv);
317 PL_last_in_gv = (GV*)(*PL_stack_sp--);
320 return do_readline();
325 dVAR; dSP; tryAMAGICbinSET(eq,0);
326 #ifndef NV_PRESERVES_UV
327 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
329 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
333 #ifdef PERL_PRESERVE_IVUV
336 /* Unless the left argument is integer in range we are going
337 to have to use NV maths. Hence only attempt to coerce the
338 right argument if we know the left is integer. */
341 const bool auvok = SvUOK(TOPm1s);
342 const bool buvok = SvUOK(TOPs);
344 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
345 /* Casting IV to UV before comparison isn't going to matter
346 on 2s complement. On 1s complement or sign&magnitude
347 (if we have any of them) it could to make negative zero
348 differ from normal zero. As I understand it. (Need to
349 check - is negative zero implementation defined behaviour
351 const UV buv = SvUVX(POPs);
352 const UV auv = SvUVX(TOPs);
354 SETs(boolSV(auv == buv));
357 { /* ## Mixed IV,UV ## */
361 /* == is commutative so doesn't matter which is left or right */
363 /* top of stack (b) is the iv */
372 /* As uv is a UV, it's >0, so it cannot be == */
375 /* we know iv is >= 0 */
376 SETs(boolSV((UV)iv == SvUVX(uvp)));
383 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
385 if (Perl_isnan(left) || Perl_isnan(right))
387 SETs(boolSV(left == right));
390 SETs(boolSV(TOPn == value));
399 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
400 DIE(aTHX_ PL_no_modify);
401 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
402 && SvIVX(TOPs) != IV_MAX)
404 SvIV_set(TOPs, SvIVX(TOPs) + 1);
405 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
407 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
419 if (PL_op->op_type == OP_OR)
421 RETURNOP(cLOGOP->op_other);
430 const int op_type = PL_op->op_type;
431 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
435 if (!sv || !SvANY(sv)) {
436 if (op_type == OP_DOR)
438 RETURNOP(cLOGOP->op_other);
440 } else if (op_type == OP_DEFINED) {
442 if (!sv || !SvANY(sv))
445 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
448 switch (SvTYPE(sv)) {
450 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
454 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
458 if (CvROOT(sv) || CvXSUB(sv))
471 if(op_type == OP_DOR)
473 RETURNOP(cLOGOP->op_other);
475 /* assuming OP_DEFINED */
483 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
484 useleft = USE_LEFT(TOPm1s);
485 #ifdef PERL_PRESERVE_IVUV
486 /* We must see if we can perform the addition with integers if possible,
487 as the integer code detects overflow while the NV code doesn't.
488 If either argument hasn't had a numeric conversion yet attempt to get
489 the IV. It's important to do this now, rather than just assuming that
490 it's not IOK as a PV of "9223372036854775806" may not take well to NV
491 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
492 integer in case the second argument is IV=9223372036854775806
493 We can (now) rely on sv_2iv to do the right thing, only setting the
494 public IOK flag if the value in the NV (or PV) slot is truly integer.
496 A side effect is that this also aggressively prefers integer maths over
497 fp maths for integer values.
499 How to detect overflow?
501 C 99 section 6.2.6.1 says
503 The range of nonnegative values of a signed integer type is a subrange
504 of the corresponding unsigned integer type, and the representation of
505 the same value in each type is the same. A computation involving
506 unsigned operands can never overflow, because a result that cannot be
507 represented by the resulting unsigned integer type is reduced modulo
508 the number that is one greater than the largest value that can be
509 represented by the resulting type.
513 which I read as "unsigned ints wrap."
515 signed integer overflow seems to be classed as "exception condition"
517 If an exceptional condition occurs during the evaluation of an
518 expression (that is, if the result is not mathematically defined or not
519 in the range of representable values for its type), the behavior is
522 (6.5, the 5th paragraph)
524 I had assumed that on 2s complement machines signed arithmetic would
525 wrap, hence coded pp_add and pp_subtract on the assumption that
526 everything perl builds on would be happy. After much wailing and
527 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
528 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
529 unsigned code below is actually shorter than the old code. :-)
534 /* Unless the left argument is integer in range we are going to have to
535 use NV maths. Hence only attempt to coerce the right argument if
536 we know the left is integer. */
544 /* left operand is undef, treat as zero. + 0 is identity,
545 Could SETi or SETu right now, but space optimise by not adding
546 lots of code to speed up what is probably a rarish case. */
548 /* Left operand is defined, so is it IV? */
551 if ((auvok = SvUOK(TOPm1s)))
554 register const IV aiv = SvIVX(TOPm1s);
557 auvok = 1; /* Now acting as a sign flag. */
558 } else { /* 2s complement assumption for IV_MIN */
566 bool result_good = 0;
569 bool buvok = SvUOK(TOPs);
574 register const IV biv = SvIVX(TOPs);
581 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
582 else "IV" now, independent of how it came in.
583 if a, b represents positive, A, B negative, a maps to -A etc
588 all UV maths. negate result if A negative.
589 add if signs same, subtract if signs differ. */
595 /* Must get smaller */
601 /* result really should be -(auv-buv). as its negation
602 of true value, need to swap our result flag */
619 if (result <= (UV)IV_MIN)
622 /* result valid, but out of range for IV. */
627 } /* Overflow, drop through to NVs. */
634 /* left operand is undef, treat as zero. + 0.0 is identity. */
638 SETn( value + TOPn );
646 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
647 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
648 const U32 lval = PL_op->op_flags & OPf_MOD;
649 SV** const svp = av_fetch(av, PL_op->op_private, lval);
650 SV *sv = (svp ? *svp : &PL_sv_undef);
652 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
653 sv = sv_mortalcopy(sv);
660 dVAR; dSP; dMARK; dTARGET;
662 do_join(TARG, *MARK, MARK, SP);
673 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
674 * will be enough to hold an OP*.
676 SV* const sv = sv_newmortal();
677 sv_upgrade(sv, SVt_PVLV);
679 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
687 /* Oversized hot code. */
691 dVAR; dSP; dMARK; dORIGMARK;
695 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
697 if (gv && (io = GvIO(gv))
698 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
701 if (MARK == ORIGMARK) {
702 /* If using default handle then we need to make space to
703 * pass object as 1st arg, so move other args up ...
707 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
711 *MARK = SvTIED_obj((SV*)io, mg);
714 call_method("PRINT", G_SCALAR);
722 if (!(io = GvIO(gv))) {
723 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
724 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
726 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
727 report_evil_fh(gv, io, PL_op->op_type);
728 SETERRNO(EBADF,RMS_IFI);
731 else if (!(fp = IoOFP(io))) {
732 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
734 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
735 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
736 report_evil_fh(gv, io, PL_op->op_type);
738 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
743 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
745 if (!do_print(*MARK, fp))
749 if (!do_print(PL_ofs_sv, fp)) { /* $, */
758 if (!do_print(*MARK, fp))
766 if (PL_op->op_type == OP_SAY) {
767 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
770 else if (PL_ors_sv && SvOK(PL_ors_sv))
771 if (!do_print(PL_ors_sv, fp)) /* $\ */
774 if (IoFLAGS(io) & IOf_FLUSH)
775 if (PerlIO_flush(fp) == EOF)
785 XPUSHs(&PL_sv_undef);
792 const I32 gimme = GIMME_V;
793 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
794 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
795 static const char an_array[] = "an ARRAY";
796 static const char a_hash[] = "a HASH";
797 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
798 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
802 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
805 if (SvTYPE(sv) != type)
806 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
807 if (PL_op->op_flags & OPf_REF) {
812 if (gimme != G_ARRAY)
813 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
814 : return_hash_to_lvalue_scalar);
818 else if (PL_op->op_flags & OPf_MOD
819 && PL_op->op_private & OPpLVAL_INTRO)
820 Perl_croak(aTHX_ PL_no_localize_ref);
823 if (SvTYPE(sv) == type) {
824 if (PL_op->op_flags & OPf_REF) {
829 if (gimme != G_ARRAY)
831 is_pp_rv2av ? return_array_to_lvalue_scalar
832 : return_hash_to_lvalue_scalar);
840 if (SvTYPE(sv) != SVt_PVGV) {
841 if (SvGMAGICAL(sv)) {
846 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
854 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
855 if (PL_op->op_private & OPpLVAL_INTRO)
856 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
857 if (PL_op->op_flags & OPf_REF) {
862 if (gimme != G_ARRAY)
864 is_pp_rv2av ? return_array_to_lvalue_scalar
865 : return_hash_to_lvalue_scalar);
873 AV *const av = (AV*)sv;
874 /* The guts of pp_rv2av, with no intenting change to preserve history
875 (until such time as we get tools that can do blame annotation across
876 whitespace changes. */
877 if (gimme == G_ARRAY) {
878 const I32 maxarg = AvFILL(av) + 1;
879 (void)POPs; /* XXXX May be optimized away? */
881 if (SvRMAGICAL(av)) {
883 for (i=0; i < (U32)maxarg; i++) {
884 SV ** const svp = av_fetch(av, i, FALSE);
885 /* See note in pp_helem, and bug id #27839 */
887 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
892 Copy(AvARRAY(av), SP+1, maxarg, SV*);
896 else if (gimme == G_SCALAR) {
898 const I32 maxarg = AvFILL(av) + 1;
902 /* The guts of pp_rv2hv */
903 if (gimme == G_ARRAY) { /* array wanted */
907 else if (gimme == G_SCALAR) {
909 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
918 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
925 if (ckWARN(WARN_MISC)) {
927 if (relem == firstrelem &&
929 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
930 SvTYPE(SvRV(*relem)) == SVt_PVHV))
932 err = "Reference found where even-sized list expected";
935 err = "Odd number of elements in hash assignment";
936 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
940 didstore = hv_store_ent(hash,*relem,tmpstr,0);
941 if (SvMAGICAL(hash)) {
942 if (SvSMAGICAL(tmpstr))
954 SV **lastlelem = PL_stack_sp;
955 SV **lastrelem = PL_stack_base + POPMARK;
956 SV **firstrelem = PL_stack_base + POPMARK + 1;
957 SV **firstlelem = lastrelem + 1;
970 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
973 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
976 /* If there's a common identifier on both sides we have to take
977 * special care that assigning the identifier on the left doesn't
978 * clobber a value on the right that's used later in the list.
980 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
981 EXTEND_MORTAL(lastrelem - firstrelem + 1);
982 for (relem = firstrelem; relem <= lastrelem; relem++) {
984 TAINT_NOT; /* Each item is independent */
985 *relem = sv_mortalcopy(sv);
989 if (PL_op->op_private & OPpASSIGN_STATE) {
990 if (SvPADSTALE(*firstlelem))
991 SvPADSTALE_off(*firstlelem);
993 RETURN; /* ignore assignment */
1001 while (lelem <= lastlelem) {
1002 TAINT_NOT; /* Each item stands on its own, taintwise. */
1004 switch (SvTYPE(sv)) {
1007 magic = SvMAGICAL(ary) != 0;
1009 av_extend(ary, lastrelem - relem);
1011 while (relem <= lastrelem) { /* gobble up all the rest */
1014 sv = newSVsv(*relem);
1016 didstore = av_store(ary,i++,sv);
1026 case SVt_PVHV: { /* normal hash */
1030 magic = SvMAGICAL(hash) != 0;
1032 firsthashrelem = relem;
1034 while (relem < lastrelem) { /* gobble up all the rest */
1036 sv = *relem ? *relem : &PL_sv_no;
1040 sv_setsv(tmpstr,*relem); /* value */
1041 *(relem++) = tmpstr;
1042 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1043 /* key overwrites an existing entry */
1045 didstore = hv_store_ent(hash,sv,tmpstr,0);
1047 if (SvSMAGICAL(tmpstr))
1054 if (relem == lastrelem) {
1055 do_oddball(hash, relem, firstrelem);
1061 if (SvIMMORTAL(sv)) {
1062 if (relem <= lastrelem)
1066 if (relem <= lastrelem) {
1067 sv_setsv(sv, *relem);
1071 sv_setsv(sv, &PL_sv_undef);
1076 if (PL_delaymagic & ~DM_DELAY) {
1077 if (PL_delaymagic & DM_UID) {
1078 #ifdef HAS_SETRESUID
1079 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1080 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1083 # ifdef HAS_SETREUID
1084 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1085 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1088 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1089 (void)setruid(PL_uid);
1090 PL_delaymagic &= ~DM_RUID;
1092 # endif /* HAS_SETRUID */
1094 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1095 (void)seteuid(PL_euid);
1096 PL_delaymagic &= ~DM_EUID;
1098 # endif /* HAS_SETEUID */
1099 if (PL_delaymagic & DM_UID) {
1100 if (PL_uid != PL_euid)
1101 DIE(aTHX_ "No setreuid available");
1102 (void)PerlProc_setuid(PL_uid);
1104 # endif /* HAS_SETREUID */
1105 #endif /* HAS_SETRESUID */
1106 PL_uid = PerlProc_getuid();
1107 PL_euid = PerlProc_geteuid();
1109 if (PL_delaymagic & DM_GID) {
1110 #ifdef HAS_SETRESGID
1111 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1112 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1115 # ifdef HAS_SETREGID
1116 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1117 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1120 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1121 (void)setrgid(PL_gid);
1122 PL_delaymagic &= ~DM_RGID;
1124 # endif /* HAS_SETRGID */
1126 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1127 (void)setegid(PL_egid);
1128 PL_delaymagic &= ~DM_EGID;
1130 # endif /* HAS_SETEGID */
1131 if (PL_delaymagic & DM_GID) {
1132 if (PL_gid != PL_egid)
1133 DIE(aTHX_ "No setregid available");
1134 (void)PerlProc_setgid(PL_gid);
1136 # endif /* HAS_SETREGID */
1137 #endif /* HAS_SETRESGID */
1138 PL_gid = PerlProc_getgid();
1139 PL_egid = PerlProc_getegid();
1141 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1145 if (gimme == G_VOID)
1146 SP = firstrelem - 1;
1147 else if (gimme == G_SCALAR) {
1150 SETi(lastrelem - firstrelem + 1 - duplicates);
1157 /* Removes from the stack the entries which ended up as
1158 * duplicated keys in the hash (fix for [perl #24380]) */
1159 Move(firsthashrelem + duplicates,
1160 firsthashrelem, duplicates, SV**);
1161 lastrelem -= duplicates;
1166 SP = firstrelem + (lastlelem - firstlelem);
1167 lelem = firstlelem + (relem - firstrelem);
1169 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1177 register PMOP * const pm = cPMOP;
1178 SV * const rv = sv_newmortal();
1179 SV * const sv = newSVrv(rv, "Regexp");
1180 if (pm->op_pmdynflags & PMdf_TAINTED)
1182 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1190 register PMOP *pm = cPMOP;
1192 register const char *t;
1193 register const char *s;
1196 I32 r_flags = REXEC_CHECKED;
1197 const char *truebase; /* Start of string */
1198 register REGEXP *rx = PM_GETRE(pm);
1200 const I32 gimme = GIMME;
1203 const I32 oldsave = PL_savestack_ix;
1204 I32 update_minmatch = 1;
1205 I32 had_zerolen = 0;
1208 if (PL_op->op_flags & OPf_STACKED)
1210 else if (PL_op->op_private & OPpTARGET_MY)
1217 PUTBACK; /* EVAL blocks need stack_sp. */
1218 s = SvPV_const(TARG, len);
1220 DIE(aTHX_ "panic: pp_match");
1222 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1223 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1226 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1228 /* PMdf_USED is set after a ?? matches once */
1229 if (pm->op_pmdynflags & PMdf_USED) {
1231 if (gimme == G_ARRAY)
1236 /* empty pattern special-cased to use last successful pattern if possible */
1237 if (!rx->prelen && PL_curpm) {
1242 if (rx->minlen > (I32)len)
1247 /* XXXX What part of this is needed with true \G-support? */
1248 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1250 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1251 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1252 if (mg && mg->mg_len >= 0) {
1253 if (!(rx->extflags & RXf_GPOS_SEEN))
1254 rx->endp[0] = rx->startp[0] = mg->mg_len;
1255 else if (rx->extflags & RXf_ANCH_GPOS) {
1256 r_flags |= REXEC_IGNOREPOS;
1257 rx->endp[0] = rx->startp[0] = mg->mg_len;
1258 } else if (rx->extflags & RXf_GPOS_FLOAT)
1261 rx->endp[0] = rx->startp[0] = mg->mg_len;
1262 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1263 update_minmatch = 0;
1267 /* remove comment to get faster /g but possibly unsafe $1 vars after a
1268 match. Test for the unsafe vars will fail as well*/
1269 if (( /* !global && */ rx->nparens)
1270 || SvTEMP(TARG) || PL_sawampersand ||
1271 (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
1272 r_flags |= REXEC_COPY_STR;
1274 r_flags |= REXEC_SCREAM;
1277 if (global && rx->startp[0] != -1) {
1278 t = s = rx->endp[0] + truebase - rx->gofs;
1279 if ((s + rx->minlen) > strend || s < truebase)
1281 if (update_minmatch++)
1282 minmatch = had_zerolen;
1284 if (rx->extflags & RXf_USE_INTUIT &&
1285 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1286 /* FIXME - can PL_bostr be made const char *? */
1287 PL_bostr = (char *)truebase;
1288 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1292 if ( (rx->extflags & RXf_CHECK_ALL)
1294 && !(pm->op_pmflags & PMf_KEEPCOPY)
1295 && ((rx->extflags & RXf_NOSCAN)
1296 || !((rx->extflags & RXf_INTUIT_TAIL)
1297 && (r_flags & REXEC_SCREAM)))
1298 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1301 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1304 if (dynpm->op_pmflags & PMf_ONCE)
1305 dynpm->op_pmdynflags |= PMdf_USED;
1314 RX_MATCH_TAINTED_on(rx);
1315 TAINT_IF(RX_MATCH_TAINTED(rx));
1316 if (gimme == G_ARRAY) {
1317 const I32 nparens = rx->nparens;
1318 I32 i = (global && !nparens) ? 1 : 0;
1320 SPAGAIN; /* EVAL blocks could move the stack. */
1321 EXTEND(SP, nparens + i);
1322 EXTEND_MORTAL(nparens + i);
1323 for (i = !i; i <= nparens; i++) {
1324 PUSHs(sv_newmortal());
1325 if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1326 const I32 len = rx->endp[i] - rx->startp[i];
1327 s = rx->startp[i] + truebase;
1328 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1329 len < 0 || len > strend - s)
1330 DIE(aTHX_ "panic: pp_match start/end pointers");
1331 sv_setpvn(*SP, s, len);
1332 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1337 if (dynpm->op_pmflags & PMf_CONTINUE) {
1339 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1340 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1342 #ifdef PERL_OLD_COPY_ON_WRITE
1344 sv_force_normal_flags(TARG, 0);
1346 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1347 &PL_vtbl_mglob, NULL, 0);
1349 if (rx->startp[0] != -1) {
1350 mg->mg_len = rx->endp[0];
1351 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1352 mg->mg_flags |= MGf_MINMATCH;
1354 mg->mg_flags &= ~MGf_MINMATCH;
1357 had_zerolen = (rx->startp[0] != -1
1358 && rx->startp[0] + rx->gofs == (UV)rx->endp[0]);
1359 PUTBACK; /* EVAL blocks may use stack */
1360 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1365 LEAVE_SCOPE(oldsave);
1371 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1372 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1376 #ifdef PERL_OLD_COPY_ON_WRITE
1378 sv_force_normal_flags(TARG, 0);
1380 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1381 &PL_vtbl_mglob, NULL, 0);
1383 if (rx->startp[0] != -1) {
1384 mg->mg_len = rx->endp[0];
1385 if (rx->startp[0] + rx->gofs == (UV)rx->endp[0])
1386 mg->mg_flags |= MGf_MINMATCH;
1388 mg->mg_flags &= ~MGf_MINMATCH;
1391 LEAVE_SCOPE(oldsave);
1395 yup: /* Confirmed by INTUIT */
1397 RX_MATCH_TAINTED_on(rx);
1398 TAINT_IF(RX_MATCH_TAINTED(rx));
1400 if (dynpm->op_pmflags & PMf_ONCE)
1401 dynpm->op_pmdynflags |= PMdf_USED;
1402 if (RX_MATCH_COPIED(rx))
1403 Safefree(rx->subbeg);
1404 RX_MATCH_COPIED_off(rx);
1407 /* FIXME - should rx->subbeg be const char *? */
1408 rx->subbeg = (char *) truebase;
1409 rx->startp[0] = s - truebase;
1410 if (RX_MATCH_UTF8(rx)) {
1411 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1412 rx->endp[0] = t - truebase;
1415 rx->endp[0] = s - truebase + rx->minlenret;
1417 rx->sublen = strend - truebase;
1420 if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
1422 #ifdef PERL_OLD_COPY_ON_WRITE
1423 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1425 PerlIO_printf(Perl_debug_log,
1426 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1427 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1430 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1431 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1432 assert (SvPOKp(rx->saved_copy));
1437 rx->subbeg = savepvn(t, strend - t);
1438 #ifdef PERL_OLD_COPY_ON_WRITE
1439 rx->saved_copy = NULL;
1442 rx->sublen = strend - t;
1443 RX_MATCH_COPIED_on(rx);
1444 off = rx->startp[0] = s - t;
1445 rx->endp[0] = off + rx->minlenret;
1447 else { /* startp/endp are used by @- @+. */
1448 rx->startp[0] = s - truebase;
1449 rx->endp[0] = s - truebase + rx->minlenret;
1451 /* including rx->nparens in the below code seems highly suspicious.
1453 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1454 LEAVE_SCOPE(oldsave);
1459 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1460 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1461 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1466 LEAVE_SCOPE(oldsave);
1467 if (gimme == G_ARRAY)
1473 Perl_do_readline(pTHX)
1475 dVAR; dSP; dTARGETSTACKED;
1480 register IO * const io = GvIO(PL_last_in_gv);
1481 register const I32 type = PL_op->op_type;
1482 const I32 gimme = GIMME_V;
1485 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1488 XPUSHs(SvTIED_obj((SV*)io, mg));
1491 call_method("READLINE", gimme);
1494 if (gimme == G_SCALAR) {
1495 SV* const result = POPs;
1496 SvSetSV_nosteal(TARG, result);
1506 if (IoFLAGS(io) & IOf_ARGV) {
1507 if (IoFLAGS(io) & IOf_START) {
1509 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1510 IoFLAGS(io) &= ~IOf_START;
1511 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1512 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1513 SvSETMAGIC(GvSV(PL_last_in_gv));
1518 fp = nextargv(PL_last_in_gv);
1519 if (!fp) { /* Note: fp != IoIFP(io) */
1520 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1523 else if (type == OP_GLOB)
1524 fp = Perl_start_glob(aTHX_ POPs, io);
1526 else if (type == OP_GLOB)
1528 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1529 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1533 if ((!io || !(IoFLAGS(io) & IOf_START))
1534 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1536 if (type == OP_GLOB)
1537 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1538 "glob failed (can't start child: %s)",
1541 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1543 if (gimme == G_SCALAR) {
1544 /* undef TARG, and push that undefined value */
1545 if (type != OP_RCATLINE) {
1546 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1554 if (gimme == G_SCALAR) {
1556 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1559 if (type == OP_RCATLINE)
1560 SvPV_force_nolen(sv);
1564 else if (isGV_with_GP(sv)) {
1565 SvPV_force_nolen(sv);
1567 SvUPGRADE(sv, SVt_PV);
1568 tmplen = SvLEN(sv); /* remember if already alloced */
1569 if (!tmplen && !SvREADONLY(sv))
1570 Sv_Grow(sv, 80); /* try short-buffering it */
1572 if (type == OP_RCATLINE && SvOK(sv)) {
1574 SvPV_force_nolen(sv);
1580 sv = sv_2mortal(newSV(80));
1584 /* This should not be marked tainted if the fp is marked clean */
1585 #define MAYBE_TAINT_LINE(io, sv) \
1586 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1591 /* delay EOF state for a snarfed empty file */
1592 #define SNARF_EOF(gimme,rs,io,sv) \
1593 (gimme != G_SCALAR || SvCUR(sv) \
1594 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1598 if (!sv_gets(sv, fp, offset)
1600 || SNARF_EOF(gimme, PL_rs, io, sv)
1601 || PerlIO_error(fp)))
1603 PerlIO_clearerr(fp);
1604 if (IoFLAGS(io) & IOf_ARGV) {
1605 fp = nextargv(PL_last_in_gv);
1608 (void)do_close(PL_last_in_gv, FALSE);
1610 else if (type == OP_GLOB) {
1611 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1612 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1613 "glob failed (child exited with status %d%s)",
1614 (int)(STATUS_CURRENT >> 8),
1615 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1618 if (gimme == G_SCALAR) {
1619 if (type != OP_RCATLINE) {
1620 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1626 MAYBE_TAINT_LINE(io, sv);
1629 MAYBE_TAINT_LINE(io, sv);
1631 IoFLAGS(io) |= IOf_NOLINE;
1635 if (type == OP_GLOB) {
1638 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1639 char * const tmps = SvEND(sv) - 1;
1640 if (*tmps == *SvPVX_const(PL_rs)) {
1642 SvCUR_set(sv, SvCUR(sv) - 1);
1645 for (t1 = SvPVX_const(sv); *t1; t1++)
1646 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1647 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1649 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1650 (void)POPs; /* Unmatched wildcard? Chuck it... */
1653 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1654 if (ckWARN(WARN_UTF8)) {
1655 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1656 const STRLEN len = SvCUR(sv) - offset;
1659 if (!is_utf8_string_loc(s, len, &f))
1660 /* Emulate :encoding(utf8) warning in the same case. */
1661 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1662 "utf8 \"\\x%02X\" does not map to Unicode",
1663 f < (U8*)SvEND(sv) ? *f : 0);
1666 if (gimme == G_ARRAY) {
1667 if (SvLEN(sv) - SvCUR(sv) > 20) {
1668 SvPV_shrink_to_cur(sv);
1670 sv = sv_2mortal(newSV(80));
1673 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1674 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1675 const STRLEN new_len
1676 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1677 SvPV_renew(sv, new_len);
1686 register PERL_CONTEXT *cx;
1687 I32 gimme = OP_GIMME(PL_op, -1);
1690 if (cxstack_ix >= 0)
1691 gimme = cxstack[cxstack_ix].blk_gimme;
1699 PUSHBLOCK(cx, CXt_BLOCK, SP);
1709 SV * const keysv = POPs;
1710 HV * const hv = (HV*)POPs;
1711 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1712 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1714 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1717 if (SvTYPE(hv) != SVt_PVHV)
1720 if (PL_op->op_private & OPpLVAL_INTRO) {
1723 /* does the element we're localizing already exist? */
1724 preeminent = /* can we determine whether it exists? */
1726 || mg_find((SV*)hv, PERL_MAGIC_env)
1727 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1728 /* Try to preserve the existenceness of a tied hash
1729 * element by using EXISTS and DELETE if possible.
1730 * Fallback to FETCH and STORE otherwise */
1731 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1732 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1733 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1735 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1737 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1738 svp = he ? &HeVAL(he) : NULL;
1740 if (!svp || *svp == &PL_sv_undef) {
1744 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1746 lv = sv_newmortal();
1747 sv_upgrade(lv, SVt_PVLV);
1749 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1750 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1751 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1756 if (PL_op->op_private & OPpLVAL_INTRO) {
1757 if (HvNAME_get(hv) && isGV(*svp))
1758 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1762 const char * const key = SvPV_const(keysv, keylen);
1763 SAVEDELETE(hv, savepvn(key,keylen),
1764 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1766 save_helem(hv, keysv, svp);
1769 else if (PL_op->op_private & OPpDEREF)
1770 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1772 sv = (svp ? *svp : &PL_sv_undef);
1773 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1774 * Pushing the magical RHS on to the stack is useless, since
1775 * that magic is soon destined to be misled by the local(),
1776 * and thus the later pp_sassign() will fail to mg_get() the
1777 * old value. This should also cure problems with delayed
1778 * mg_get()s. GSAR 98-07-03 */
1779 if (!lval && SvGMAGICAL(sv))
1780 sv = sv_mortalcopy(sv);
1788 register PERL_CONTEXT *cx;
1793 if (PL_op->op_flags & OPf_SPECIAL) {
1794 cx = &cxstack[cxstack_ix];
1795 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1800 gimme = OP_GIMME(PL_op, -1);
1802 if (cxstack_ix >= 0)
1803 gimme = cxstack[cxstack_ix].blk_gimme;
1809 if (gimme == G_VOID)
1811 else if (gimme == G_SCALAR) {
1815 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1818 *MARK = sv_mortalcopy(TOPs);
1821 *MARK = &PL_sv_undef;
1825 else if (gimme == G_ARRAY) {
1826 /* in case LEAVE wipes old return values */
1828 for (mark = newsp + 1; mark <= SP; mark++) {
1829 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1830 *mark = sv_mortalcopy(*mark);
1831 TAINT_NOT; /* Each item is independent */
1835 PL_curpm = newpm; /* Don't pop $1 et al till now */
1845 register PERL_CONTEXT *cx;
1851 cx = &cxstack[cxstack_ix];
1852 if (CxTYPE(cx) != CXt_LOOP)
1853 DIE(aTHX_ "panic: pp_iter");
1855 itersvp = CxITERVAR(cx);
1856 av = cx->blk_loop.iterary;
1857 if (SvTYPE(av) != SVt_PVAV) {
1858 /* iterate ($min .. $max) */
1859 if (cx->blk_loop.iterlval) {
1860 /* string increment */
1861 register SV* cur = cx->blk_loop.iterlval;
1865 SvPV_const((SV*)av, maxlen) : (const char *)"";
1866 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1867 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1868 /* safe to reuse old SV */
1869 sv_setsv(*itersvp, cur);
1873 /* we need a fresh SV every time so that loop body sees a
1874 * completely new SV for closures/references to work as
1877 *itersvp = newSVsv(cur);
1878 SvREFCNT_dec(oldsv);
1880 if (strEQ(SvPVX_const(cur), max))
1881 sv_setiv(cur, 0); /* terminate next time */
1888 /* integer increment */
1889 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1892 /* don't risk potential race */
1893 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1894 /* safe to reuse old SV */
1895 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1899 /* we need a fresh SV every time so that loop body sees a
1900 * completely new SV for closures/references to work as they
1903 *itersvp = newSViv(cx->blk_loop.iterix++);
1904 SvREFCNT_dec(oldsv);
1910 if (PL_op->op_private & OPpITER_REVERSED) {
1911 /* In reverse, use itermax as the min :-) */
1912 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1915 if (SvMAGICAL(av) || AvREIFY(av)) {
1916 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1917 sv = svp ? *svp : NULL;
1920 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1924 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1928 if (SvMAGICAL(av) || AvREIFY(av)) {
1929 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1930 sv = svp ? *svp : NULL;
1933 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1937 if (sv && SvIS_FREED(sv)) {
1939 Perl_croak(aTHX_ "Use of freed value in iteration");
1946 if (av != PL_curstack && sv == &PL_sv_undef) {
1947 SV *lv = cx->blk_loop.iterlval;
1948 if (lv && SvREFCNT(lv) > 1) {
1953 SvREFCNT_dec(LvTARG(lv));
1955 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1957 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1959 LvTARG(lv) = SvREFCNT_inc_simple(av);
1960 LvTARGOFF(lv) = cx->blk_loop.iterix;
1961 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1966 *itersvp = SvREFCNT_inc_simple_NN(sv);
1967 SvREFCNT_dec(oldsv);
1975 register PMOP *pm = cPMOP;
1990 register REGEXP *rx = PM_GETRE(pm);
1992 int force_on_match = 0;
1993 const I32 oldsave = PL_savestack_ix;
1995 bool doutf8 = FALSE;
1996 #ifdef PERL_OLD_COPY_ON_WRITE
2001 /* known replacement string? */
2002 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2003 if (PL_op->op_flags & OPf_STACKED)
2005 else if (PL_op->op_private & OPpTARGET_MY)
2012 #ifdef PERL_OLD_COPY_ON_WRITE
2013 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2014 because they make integers such as 256 "false". */
2015 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2018 sv_force_normal_flags(TARG,0);
2021 #ifdef PERL_OLD_COPY_ON_WRITE
2025 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2026 || SvTYPE(TARG) > SVt_PVLV)
2027 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2028 DIE(aTHX_ PL_no_modify);
2031 s = SvPV_mutable(TARG, len);
2032 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2034 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2035 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2040 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2044 DIE(aTHX_ "panic: pp_subst");
2047 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2048 maxiters = 2 * slen + 10; /* We can match twice at each
2049 position, once with zero-length,
2050 second time with non-zero. */
2052 if (!rx->prelen && PL_curpm) {
2056 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2057 || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
2058 ? REXEC_COPY_STR : 0;
2060 r_flags |= REXEC_SCREAM;
2063 if (rx->extflags & RXf_USE_INTUIT) {
2065 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2069 /* How to do it in subst? */
2070 /* if ( (rx->extflags & RXf_CHECK_ALL)
2072 && !(pm->op_pmflags & PMf_KEEPCOPY)
2073 && ((rx->extflags & RXf_NOSCAN)
2074 || !((rx->extflags & RXf_INTUIT_TAIL)
2075 && (r_flags & REXEC_SCREAM))))
2080 /* only replace once? */
2081 once = !(rpm->op_pmflags & PMf_GLOBAL);
2083 /* known replacement string? */
2085 /* replacement needing upgrading? */
2086 if (DO_UTF8(TARG) && !doutf8) {
2087 nsv = sv_newmortal();
2090 sv_recode_to_utf8(nsv, PL_encoding);
2092 sv_utf8_upgrade(nsv);
2093 c = SvPV_const(nsv, clen);
2097 c = SvPV_const(dstr, clen);
2098 doutf8 = DO_UTF8(dstr);
2106 /* can do inplace substitution? */
2108 #ifdef PERL_OLD_COPY_ON_WRITE
2111 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2112 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2113 && (!doutf8 || SvUTF8(TARG))) {
2114 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2115 r_flags | REXEC_CHECKED))
2119 LEAVE_SCOPE(oldsave);
2122 #ifdef PERL_OLD_COPY_ON_WRITE
2123 if (SvIsCOW(TARG)) {
2124 assert (!force_on_match);
2128 if (force_on_match) {
2130 s = SvPV_force(TARG, len);
2135 SvSCREAM_off(TARG); /* disable possible screamer */
2137 rxtainted |= RX_MATCH_TAINTED(rx);
2138 m = orig + rx->startp[0];
2139 d = orig + rx->endp[0];
2141 if (m - s > strend - d) { /* faster to shorten from end */
2143 Copy(c, m, clen, char);
2148 Move(d, m, i, char);
2152 SvCUR_set(TARG, m - s);
2154 else if ((i = m - s)) { /* faster from front */
2162 Copy(c, m, clen, char);
2167 Copy(c, d, clen, char);
2172 TAINT_IF(rxtainted & 1);
2178 if (iters++ > maxiters)
2179 DIE(aTHX_ "Substitution loop");
2180 rxtainted |= RX_MATCH_TAINTED(rx);
2181 m = rx->startp[0] + orig;
2184 Move(s, d, i, char);
2188 Copy(c, d, clen, char);
2191 s = rx->endp[0] + orig;
2192 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2194 /* don't match same null twice */
2195 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2198 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2199 Move(s, d, i+1, char); /* include the NUL */
2201 TAINT_IF(rxtainted & 1);
2203 PUSHs(sv_2mortal(newSViv((I32)iters)));
2205 (void)SvPOK_only_UTF8(TARG);
2206 TAINT_IF(rxtainted);
2207 if (SvSMAGICAL(TARG)) {
2215 LEAVE_SCOPE(oldsave);
2219 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2220 r_flags | REXEC_CHECKED))
2222 if (force_on_match) {
2224 s = SvPV_force(TARG, len);
2227 #ifdef PERL_OLD_COPY_ON_WRITE
2230 rxtainted |= RX_MATCH_TAINTED(rx);
2231 dstr = newSVpvn(m, s-m);
2237 register PERL_CONTEXT *cx;
2240 RETURNOP(cPMOP->op_pmreplroot);
2242 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2244 if (iters++ > maxiters)
2245 DIE(aTHX_ "Substitution loop");
2246 rxtainted |= RX_MATCH_TAINTED(rx);
2247 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2252 strend = s + (strend - m);
2254 m = rx->startp[0] + orig;
2255 if (doutf8 && !SvUTF8(dstr))
2256 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2258 sv_catpvn(dstr, s, m-s);
2259 s = rx->endp[0] + orig;
2261 sv_catpvn(dstr, c, clen);
2264 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2265 TARG, NULL, r_flags));
2266 if (doutf8 && !DO_UTF8(TARG))
2267 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2269 sv_catpvn(dstr, s, strend - s);
2271 #ifdef PERL_OLD_COPY_ON_WRITE
2272 /* The match may make the string COW. If so, brilliant, because that's
2273 just saved us one malloc, copy and free - the regexp has donated
2274 the old buffer, and we malloc an entirely new one, rather than the
2275 regexp malloc()ing a buffer and copying our original, only for
2276 us to throw it away here during the substitution. */
2277 if (SvIsCOW(TARG)) {
2278 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2284 SvPV_set(TARG, SvPVX(dstr));
2285 SvCUR_set(TARG, SvCUR(dstr));
2286 SvLEN_set(TARG, SvLEN(dstr));
2287 doutf8 |= DO_UTF8(dstr);
2288 SvPV_set(dstr, NULL);
2290 TAINT_IF(rxtainted & 1);
2292 PUSHs(sv_2mortal(newSViv((I32)iters)));
2294 (void)SvPOK_only(TARG);
2297 TAINT_IF(rxtainted);
2300 LEAVE_SCOPE(oldsave);
2309 LEAVE_SCOPE(oldsave);
2318 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2319 ++*PL_markstack_ptr;
2320 LEAVE; /* exit inner scope */
2323 if (PL_stack_base + *PL_markstack_ptr > SP) {
2325 const I32 gimme = GIMME_V;
2327 LEAVE; /* exit outer scope */
2328 (void)POPMARK; /* pop src */
2329 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2330 (void)POPMARK; /* pop dst */
2331 SP = PL_stack_base + POPMARK; /* pop original mark */
2332 if (gimme == G_SCALAR) {
2333 if (PL_op->op_private & OPpGREP_LEX) {
2334 SV* const sv = sv_newmortal();
2335 sv_setiv(sv, items);
2343 else if (gimme == G_ARRAY)
2350 ENTER; /* enter inner scope */
2353 src = PL_stack_base[*PL_markstack_ptr];
2355 if (PL_op->op_private & OPpGREP_LEX)
2356 PAD_SVl(PL_op->op_targ) = src;
2360 RETURNOP(cLOGOP->op_other);
2371 register PERL_CONTEXT *cx;
2374 if (CxMULTICALL(&cxstack[cxstack_ix]))
2378 cxstack_ix++; /* temporarily protect top context */
2381 if (gimme == G_SCALAR) {
2384 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2386 *MARK = SvREFCNT_inc(TOPs);
2391 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2393 *MARK = sv_mortalcopy(sv);
2398 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2402 *MARK = &PL_sv_undef;
2406 else if (gimme == G_ARRAY) {
2407 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2408 if (!SvTEMP(*MARK)) {
2409 *MARK = sv_mortalcopy(*MARK);
2410 TAINT_NOT; /* Each item is independent */
2418 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2419 PL_curpm = newpm; /* ... and pop $1 et al */
2422 return cx->blk_sub.retop;
2425 /* This duplicates the above code because the above code must not
2426 * get any slower by more conditions */
2434 register PERL_CONTEXT *cx;
2437 if (CxMULTICALL(&cxstack[cxstack_ix]))
2441 cxstack_ix++; /* temporarily protect top context */
2445 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2446 /* We are an argument to a function or grep().
2447 * This kind of lvalueness was legal before lvalue
2448 * subroutines too, so be backward compatible:
2449 * cannot report errors. */
2451 /* Scalar context *is* possible, on the LHS of -> only,
2452 * as in f()->meth(). But this is not an lvalue. */
2453 if (gimme == G_SCALAR)
2455 if (gimme == G_ARRAY) {
2456 if (!CvLVALUE(cx->blk_sub.cv))
2457 goto temporise_array;
2458 EXTEND_MORTAL(SP - newsp);
2459 for (mark = newsp + 1; mark <= SP; mark++) {
2462 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2463 *mark = sv_mortalcopy(*mark);
2465 /* Can be a localized value subject to deletion. */
2466 PL_tmps_stack[++PL_tmps_ix] = *mark;
2467 SvREFCNT_inc_void(*mark);
2472 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2473 /* Here we go for robustness, not for speed, so we change all
2474 * the refcounts so the caller gets a live guy. Cannot set
2475 * TEMP, so sv_2mortal is out of question. */
2476 if (!CvLVALUE(cx->blk_sub.cv)) {
2482 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2484 if (gimme == G_SCALAR) {
2488 /* Temporaries are bad unless they happen to be elements
2489 * of a tied hash or array */
2490 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2491 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2497 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2498 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2499 : "a readonly value" : "a temporary");
2501 else { /* Can be a localized value
2502 * subject to deletion. */
2503 PL_tmps_stack[++PL_tmps_ix] = *mark;
2504 SvREFCNT_inc_void(*mark);
2507 else { /* Should not happen? */
2513 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2514 (MARK > SP ? "Empty array" : "Array"));
2518 else if (gimme == G_ARRAY) {
2519 EXTEND_MORTAL(SP - newsp);
2520 for (mark = newsp + 1; mark <= SP; mark++) {
2521 if (*mark != &PL_sv_undef
2522 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2523 /* Might be flattened array after $#array = */
2530 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2531 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2534 /* Can be a localized value subject to deletion. */
2535 PL_tmps_stack[++PL_tmps_ix] = *mark;
2536 SvREFCNT_inc_void(*mark);
2542 if (gimme == G_SCALAR) {
2546 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2548 *MARK = SvREFCNT_inc(TOPs);
2553 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2555 *MARK = sv_mortalcopy(sv);
2560 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2564 *MARK = &PL_sv_undef;
2568 else if (gimme == G_ARRAY) {
2570 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2571 if (!SvTEMP(*MARK)) {
2572 *MARK = sv_mortalcopy(*MARK);
2573 TAINT_NOT; /* Each item is independent */
2582 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2583 PL_curpm = newpm; /* ... and pop $1 et al */
2586 return cx->blk_sub.retop;
2594 register PERL_CONTEXT *cx;
2596 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2599 DIE(aTHX_ "Not a CODE reference");
2600 switch (SvTYPE(sv)) {
2601 /* This is overwhelming the most common case: */
2603 if (!(cv = GvCVu((GV*)sv))) {
2605 cv = sv_2cv(sv, &stash, &gv, 0);
2617 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2619 SP = PL_stack_base + POPMARK;
2622 if (SvGMAGICAL(sv)) {
2627 sym = SvPVX_const(sv);
2635 sym = SvPV_const(sv, len);
2638 DIE(aTHX_ PL_no_usym, "a subroutine");
2639 if (PL_op->op_private & HINT_STRICT_REFS)
2640 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2641 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2646 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2647 tryAMAGICunDEREF(to_cv);
2650 if (SvTYPE(cv) == SVt_PVCV)
2655 DIE(aTHX_ "Not a CODE reference");
2656 /* This is the second most common case: */
2666 if (!CvROOT(cv) && !CvXSUB(cv)) {
2670 /* anonymous or undef'd function leaves us no recourse */
2671 if (CvANON(cv) || !(gv = CvGV(cv)))
2672 DIE(aTHX_ "Undefined subroutine called");
2674 /* autoloaded stub? */
2675 if (cv != GvCV(gv)) {
2678 /* should call AUTOLOAD now? */
2681 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2688 sub_name = sv_newmortal();
2689 gv_efullname3(sub_name, gv, NULL);
2690 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2694 DIE(aTHX_ "Not a CODE reference");
2699 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2700 if (CvASSERTION(cv) && PL_DBassertion)
2701 sv_setiv(PL_DBassertion, 1);
2703 Perl_get_db_sub(aTHX_ &sv, cv);
2705 PL_curcopdb = PL_curcop;
2706 cv = GvCV(PL_DBsub);
2708 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2709 DIE(aTHX_ "No DB::sub routine defined");
2712 if (!(CvISXSUB(cv))) {
2713 /* This path taken at least 75% of the time */
2715 register I32 items = SP - MARK;
2716 AV* const padlist = CvPADLIST(cv);
2717 PUSHBLOCK(cx, CXt_SUB, MARK);
2719 cx->blk_sub.retop = PL_op->op_next;
2721 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2722 * that eval'' ops within this sub know the correct lexical space.
2723 * Owing the speed considerations, we choose instead to search for
2724 * the cv using find_runcv() when calling doeval().
2726 if (CvDEPTH(cv) >= 2) {
2727 PERL_STACK_OVERFLOW_CHECK();
2728 pad_push(padlist, CvDEPTH(cv));
2731 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2733 AV* const av = (AV*)PAD_SVl(0);
2735 /* @_ is normally not REAL--this should only ever
2736 * happen when DB::sub() calls things that modify @_ */
2741 cx->blk_sub.savearray = GvAV(PL_defgv);
2742 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2743 CX_CURPAD_SAVE(cx->blk_sub);
2744 cx->blk_sub.argarray = av;
2747 if (items > AvMAX(av) + 1) {
2748 SV **ary = AvALLOC(av);
2749 if (AvARRAY(av) != ary) {
2750 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2753 if (items > AvMAX(av) + 1) {
2754 AvMAX(av) = items - 1;
2755 Renew(ary,items,SV*);
2760 Copy(MARK,AvARRAY(av),items,SV*);
2761 AvFILLp(av) = items - 1;
2769 /* warning must come *after* we fully set up the context
2770 * stuff so that __WARN__ handlers can safely dounwind()
2773 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2774 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2775 sub_crush_depth(cv);
2777 DEBUG_S(PerlIO_printf(Perl_debug_log,
2778 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2780 RETURNOP(CvSTART(cv));
2783 I32 markix = TOPMARK;
2788 /* Need to copy @_ to stack. Alternative may be to
2789 * switch stack to @_, and copy return values
2790 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2791 AV * const av = GvAV(PL_defgv);
2792 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2795 /* Mark is at the end of the stack. */
2797 Copy(AvARRAY(av), SP + 1, items, SV*);
2802 /* We assume first XSUB in &DB::sub is the called one. */
2804 SAVEVPTR(PL_curcop);
2805 PL_curcop = PL_curcopdb;
2808 /* Do we need to open block here? XXXX */
2809 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2810 (void)(*CvXSUB(cv))(aTHX_ cv);
2812 /* Enforce some sanity in scalar context. */
2813 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2814 if (markix > PL_stack_sp - PL_stack_base)
2815 *(PL_stack_base + markix) = &PL_sv_undef;
2817 *(PL_stack_base + markix) = *PL_stack_sp;
2818 PL_stack_sp = PL_stack_base + markix;
2826 Perl_sub_crush_depth(pTHX_ CV *cv)
2829 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2831 SV* const tmpstr = sv_newmortal();
2832 gv_efullname3(tmpstr, CvGV(cv), NULL);
2833 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2842 SV* const elemsv = POPs;
2843 IV elem = SvIV(elemsv);
2844 AV* const av = (AV*)POPs;
2845 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2846 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2849 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2850 Perl_warner(aTHX_ packWARN(WARN_MISC),
2851 "Use of reference \"%"SVf"\" as array index",
2854 elem -= CopARYBASE_get(PL_curcop);
2855 if (SvTYPE(av) != SVt_PVAV)
2857 svp = av_fetch(av, elem, lval && !defer);
2859 #ifdef PERL_MALLOC_WRAP
2860 if (SvUOK(elemsv)) {
2861 const UV uv = SvUV(elemsv);
2862 elem = uv > IV_MAX ? IV_MAX : uv;
2864 else if (SvNOK(elemsv))
2865 elem = (IV)SvNV(elemsv);
2867 static const char oom_array_extend[] =
2868 "Out of memory during array extend"; /* Duplicated in av.c */
2869 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2872 if (!svp || *svp == &PL_sv_undef) {
2875 DIE(aTHX_ PL_no_aelem, elem);
2876 lv = sv_newmortal();
2877 sv_upgrade(lv, SVt_PVLV);
2879 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2880 LvTARG(lv) = SvREFCNT_inc_simple(av);
2881 LvTARGOFF(lv) = elem;
2886 if (PL_op->op_private & OPpLVAL_INTRO)
2887 save_aelem(av, elem, svp);
2888 else if (PL_op->op_private & OPpDEREF)
2889 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2891 sv = (svp ? *svp : &PL_sv_undef);
2892 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2893 sv = sv_mortalcopy(sv);
2899 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2904 Perl_croak(aTHX_ PL_no_modify);
2905 if (SvTYPE(sv) < SVt_RV)
2906 sv_upgrade(sv, SVt_RV);
2907 else if (SvTYPE(sv) >= SVt_PV) {
2914 SvRV_set(sv, newSV(0));
2917 SvRV_set(sv, (SV*)newAV());
2920 SvRV_set(sv, (SV*)newHV());
2931 SV* const sv = TOPs;
2934 SV* const rsv = SvRV(sv);
2935 if (SvTYPE(rsv) == SVt_PVCV) {
2941 SETs(method_common(sv, NULL));
2948 SV* const sv = cSVOP_sv;
2949 U32 hash = SvSHARED_HASH(sv);
2951 XPUSHs(method_common(sv, &hash));
2956 S_method_common(pTHX_ SV* meth, U32* hashp)
2963 const char* packname = NULL;
2966 const char * const name = SvPV_const(meth, namelen);
2967 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2970 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2978 /* this isn't a reference */
2979 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2980 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2982 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2989 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2990 !(ob=(SV*)GvIO(iogv)))
2992 /* this isn't the name of a filehandle either */
2994 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2995 ? !isIDFIRST_utf8((U8*)packname)
2996 : !isIDFIRST(*packname)
2999 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3000 SvOK(sv) ? "without a package or object reference"
3001 : "on an undefined value");
3003 /* assume it's a package name */
3004 stash = gv_stashpvn(packname, packlen, 0);
3008 SV* const ref = newSViv(PTR2IV(stash));
3009 hv_store(PL_stashcache, packname, packlen, ref, 0);
3013 /* it _is_ a filehandle name -- replace with a reference */
3014 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3017 /* if we got here, ob should be a reference or a glob */
3018 if (!ob || !(SvOBJECT(ob)
3019 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3022 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3026 stash = SvSTASH(ob);
3029 /* NOTE: stash may be null, hope hv_fetch_ent and
3030 gv_fetchmethod can cope (it seems they can) */
3032 /* shortcut for simple names */
3034 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3036 gv = (GV*)HeVAL(he);
3037 if (isGV(gv) && GvCV(gv) &&
3038 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3039 return (SV*)GvCV(gv);
3043 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3046 /* This code tries to figure out just what went wrong with
3047 gv_fetchmethod. It therefore needs to duplicate a lot of
3048 the internals of that function. We can't move it inside
3049 Perl_gv_fetchmethod_autoload(), however, since that would
3050 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3053 const char* leaf = name;
3054 const char* sep = NULL;
3057 for (p = name; *p; p++) {
3059 sep = p, leaf = p + 1;
3060 else if (*p == ':' && *(p + 1) == ':')
3061 sep = p, leaf = p + 2;
3063 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3064 /* the method name is unqualified or starts with SUPER:: */
3065 bool need_strlen = 1;
3067 packname = CopSTASHPV(PL_curcop);
3070 HEK * const packhek = HvNAME_HEK(stash);
3072 packname = HEK_KEY(packhek);
3073 packlen = HEK_LEN(packhek);
3083 "Can't use anonymous symbol table for method lookup");
3085 else if (need_strlen)
3086 packlen = strlen(packname);
3090 /* the method name is qualified */
3092 packlen = sep - name;
3095 /* we're relying on gv_fetchmethod not autovivifying the stash */
3096 if (gv_stashpvn(packname, packlen, 0)) {
3098 "Can't locate object method \"%s\" via package \"%.*s\"",
3099 leaf, (int)packlen, packname);
3103 "Can't locate object method \"%s\" via package \"%.*s\""
3104 " (perhaps you forgot to load \"%.*s\"?)",
3105 leaf, (int)packlen, packname, (int)packlen, packname);
3108 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3113 * c-indentation-style: bsd
3115 * indent-tabs-mode: t
3118 * ex: set ts=8 sts=4 sw=4 noet: