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);
136 RETURN; /* ignore assignment */
139 if (PL_tainting && PL_tainted && !SvTAINTED(left))
141 if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
142 SV * const cv = SvRV(left);
143 const U32 cv_type = SvTYPE(cv);
144 const U32 gv_type = SvTYPE(right);
145 const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
151 /* Can do the optimisation if right (LVALUE) is not a typeglob,
152 left (RVALUE) is a reference to something, and we're in void
154 if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
155 /* Is the target symbol table currently empty? */
156 GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
157 if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
158 /* Good. Create a new proxy constant subroutine in the target.
159 The gv becomes a(nother) reference to the constant. */
160 SV *const value = SvRV(cv);
162 SvUPGRADE((SV *)gv, SVt_RV);
163 SvPCS_IMPORTED_on(gv);
165 SvREFCNT_inc_simple_void(value);
171 /* Need to fix things up. */
172 if (gv_type != SVt_PVGV) {
173 /* Need to fix GV. */
174 right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
178 /* We've been returned a constant rather than a full subroutine,
179 but they expect a subroutine reference to apply. */
181 SvREFCNT_inc_void(SvRV(cv));
182 /* newCONSTSUB takes a reference count on the passed in SV
183 from us. We set the name to NULL, otherwise we get into
184 all sorts of fun as the reference to our new sub is
185 donated to the GV that we're about to assign to.
187 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
193 if (strEQ(GvNAME(right),"isa")) {
198 SvSetMagicSV(right, left);
207 RETURNOP(cLOGOP->op_other);
209 RETURNOP(cLOGOP->op_next);
216 TAINT_NOT; /* Each statement is presumed innocent */
217 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
219 oldsave = PL_scopestack[PL_scopestack_ix - 1];
220 LEAVE_SCOPE(oldsave);
226 dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
231 const char *rpv = NULL;
233 bool rcopied = FALSE;
235 if (TARG == right && right != left) {
236 /* mg_get(right) may happen here ... */
237 rpv = SvPV_const(right, rlen);
238 rbyte = !DO_UTF8(right);
239 right = sv_2mortal(newSVpvn(rpv, rlen));
240 rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
246 const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
247 lbyte = !DO_UTF8(left);
248 sv_setpvn(TARG, lpv, llen);
254 else { /* TARG == left */
256 SvGETMAGIC(left); /* or mg_get(left) may happen here */
258 if (left == right && ckWARN(WARN_UNINITIALIZED))
259 report_uninit(right);
260 sv_setpvn(left, "", 0);
262 (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
263 lbyte = !DO_UTF8(left);
268 /* or mg_get(right) may happen here */
270 rpv = SvPV_const(right, rlen);
271 rbyte = !DO_UTF8(right);
273 if (lbyte != rbyte) {
275 sv_utf8_upgrade_nomg(TARG);
278 right = sv_2mortal(newSVpvn(rpv, rlen));
279 sv_utf8_upgrade_nomg(right);
280 rpv = SvPV_const(right, rlen);
283 sv_catpvn_nomg(TARG, rpv, rlen);
294 if (PL_op->op_flags & OPf_MOD) {
295 if (PL_op->op_private & OPpLVAL_INTRO)
296 if (!(PL_op->op_private & OPpPAD_STATE))
297 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
298 if (PL_op->op_private & OPpDEREF) {
300 vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
310 tryAMAGICunTARGET(iter, 0);
311 PL_last_in_gv = (GV*)(*PL_stack_sp--);
312 if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
313 if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
314 PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
317 XPUSHs((SV*)PL_last_in_gv);
320 PL_last_in_gv = (GV*)(*PL_stack_sp--);
323 return do_readline();
328 dVAR; dSP; tryAMAGICbinSET(eq,0);
329 #ifndef NV_PRESERVES_UV
330 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
332 SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
336 #ifdef PERL_PRESERVE_IVUV
339 /* Unless the left argument is integer in range we are going
340 to have to use NV maths. Hence only attempt to coerce the
341 right argument if we know the left is integer. */
344 const bool auvok = SvUOK(TOPm1s);
345 const bool buvok = SvUOK(TOPs);
347 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
348 /* Casting IV to UV before comparison isn't going to matter
349 on 2s complement. On 1s complement or sign&magnitude
350 (if we have any of them) it could to make negative zero
351 differ from normal zero. As I understand it. (Need to
352 check - is negative zero implementation defined behaviour
354 const UV buv = SvUVX(POPs);
355 const UV auv = SvUVX(TOPs);
357 SETs(boolSV(auv == buv));
360 { /* ## Mixed IV,UV ## */
364 /* == is commutative so doesn't matter which is left or right */
366 /* top of stack (b) is the iv */
375 /* As uv is a UV, it's >0, so it cannot be == */
378 /* we know iv is >= 0 */
379 SETs(boolSV((UV)iv == SvUVX(uvp)));
386 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
388 if (Perl_isnan(left) || Perl_isnan(right))
390 SETs(boolSV(left == right));
393 SETs(boolSV(TOPn == value));
402 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
403 DIE(aTHX_ PL_no_modify);
404 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
405 && SvIVX(TOPs) != IV_MAX)
407 SvIV_set(TOPs, SvIVX(TOPs) + 1);
408 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
410 else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
422 if (PL_op->op_type == OP_OR)
424 RETURNOP(cLOGOP->op_other);
433 const int op_type = PL_op->op_type;
434 const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
438 if (!sv || !SvANY(sv)) {
439 if (op_type == OP_DOR)
441 RETURNOP(cLOGOP->op_other);
443 } else if (op_type == OP_DEFINED) {
445 if (!sv || !SvANY(sv))
448 DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
451 switch (SvTYPE(sv)) {
453 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
457 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
461 if (CvROOT(sv) || CvXSUB(sv))
474 if(op_type == OP_DOR)
476 RETURNOP(cLOGOP->op_other);
478 /* assuming OP_DEFINED */
486 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
487 useleft = USE_LEFT(TOPm1s);
488 #ifdef PERL_PRESERVE_IVUV
489 /* We must see if we can perform the addition with integers if possible,
490 as the integer code detects overflow while the NV code doesn't.
491 If either argument hasn't had a numeric conversion yet attempt to get
492 the IV. It's important to do this now, rather than just assuming that
493 it's not IOK as a PV of "9223372036854775806" may not take well to NV
494 addition, and an SV which is NOK, NV=6.0 ought to be coerced to
495 integer in case the second argument is IV=9223372036854775806
496 We can (now) rely on sv_2iv to do the right thing, only setting the
497 public IOK flag if the value in the NV (or PV) slot is truly integer.
499 A side effect is that this also aggressively prefers integer maths over
500 fp maths for integer values.
502 How to detect overflow?
504 C 99 section 6.2.6.1 says
506 The range of nonnegative values of a signed integer type is a subrange
507 of the corresponding unsigned integer type, and the representation of
508 the same value in each type is the same. A computation involving
509 unsigned operands can never overflow, because a result that cannot be
510 represented by the resulting unsigned integer type is reduced modulo
511 the number that is one greater than the largest value that can be
512 represented by the resulting type.
516 which I read as "unsigned ints wrap."
518 signed integer overflow seems to be classed as "exception condition"
520 If an exceptional condition occurs during the evaluation of an
521 expression (that is, if the result is not mathematically defined or not
522 in the range of representable values for its type), the behavior is
525 (6.5, the 5th paragraph)
527 I had assumed that on 2s complement machines signed arithmetic would
528 wrap, hence coded pp_add and pp_subtract on the assumption that
529 everything perl builds on would be happy. After much wailing and
530 gnashing of teeth it would seem that irix64 knows its ANSI spec well,
531 knows that it doesn't need to, and doesn't. Bah. Anyway, the all-
532 unsigned code below is actually shorter than the old code. :-)
537 /* Unless the left argument is integer in range we are going to have to
538 use NV maths. Hence only attempt to coerce the right argument if
539 we know the left is integer. */
547 /* left operand is undef, treat as zero. + 0 is identity,
548 Could SETi or SETu right now, but space optimise by not adding
549 lots of code to speed up what is probably a rarish case. */
551 /* Left operand is defined, so is it IV? */
554 if ((auvok = SvUOK(TOPm1s)))
557 register const IV aiv = SvIVX(TOPm1s);
560 auvok = 1; /* Now acting as a sign flag. */
561 } else { /* 2s complement assumption for IV_MIN */
569 bool result_good = 0;
572 bool buvok = SvUOK(TOPs);
577 register const IV biv = SvIVX(TOPs);
584 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
585 else "IV" now, independent of how it came in.
586 if a, b represents positive, A, B negative, a maps to -A etc
591 all UV maths. negate result if A negative.
592 add if signs same, subtract if signs differ. */
598 /* Must get smaller */
604 /* result really should be -(auv-buv). as its negation
605 of true value, need to swap our result flag */
622 if (result <= (UV)IV_MIN)
625 /* result valid, but out of range for IV. */
630 } /* Overflow, drop through to NVs. */
637 /* left operand is undef, treat as zero. + 0.0 is identity. */
641 SETn( value + TOPn );
649 AV * const av = PL_op->op_flags & OPf_SPECIAL ?
650 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
651 const U32 lval = PL_op->op_flags & OPf_MOD;
652 SV** const svp = av_fetch(av, PL_op->op_private, lval);
653 SV *sv = (svp ? *svp : &PL_sv_undef);
655 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
656 sv = sv_mortalcopy(sv);
663 dVAR; dSP; dMARK; dTARGET;
665 do_join(TARG, *MARK, MARK, SP);
676 * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
677 * will be enough to hold an OP*.
679 SV* const sv = sv_newmortal();
680 sv_upgrade(sv, SVt_PVLV);
682 Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
690 /* Oversized hot code. */
694 dVAR; dSP; dMARK; dORIGMARK;
698 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
700 if (gv && (io = GvIO(gv))
701 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
704 if (MARK == ORIGMARK) {
705 /* If using default handle then we need to make space to
706 * pass object as 1st arg, so move other args up ...
710 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
714 *MARK = SvTIED_obj((SV*)io, mg);
717 call_method("PRINT", G_SCALAR);
725 if (!(io = GvIO(gv))) {
726 if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
727 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
729 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
730 report_evil_fh(gv, io, PL_op->op_type);
731 SETERRNO(EBADF,RMS_IFI);
734 else if (!(fp = IoOFP(io))) {
735 if (ckWARN2(WARN_CLOSED, WARN_IO)) {
737 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
738 else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
739 report_evil_fh(gv, io, PL_op->op_type);
741 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
746 if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
748 if (!do_print(*MARK, fp))
752 if (!do_print(PL_ofs_sv, fp)) { /* $, */
761 if (!do_print(*MARK, fp))
769 if (PL_op->op_type == OP_SAY) {
770 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
773 else if (PL_ors_sv && SvOK(PL_ors_sv))
774 if (!do_print(PL_ors_sv, fp)) /* $\ */
777 if (IoFLAGS(io) & IOf_FLUSH)
778 if (PerlIO_flush(fp) == EOF)
788 XPUSHs(&PL_sv_undef);
795 const I32 gimme = GIMME_V;
796 static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
797 static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
798 static const char an_array[] = "an ARRAY";
799 static const char a_hash[] = "a HASH";
800 const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
801 const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
805 tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
808 if (SvTYPE(sv) != type)
809 DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
810 if (PL_op->op_flags & OPf_REF) {
815 if (gimme != G_ARRAY)
816 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
817 : return_hash_to_lvalue_scalar);
821 else if (PL_op->op_flags & OPf_MOD
822 && PL_op->op_private & OPpLVAL_INTRO)
823 Perl_croak(aTHX_ PL_no_localize_ref);
826 if (SvTYPE(sv) == type) {
827 if (PL_op->op_flags & OPf_REF) {
832 if (gimme != G_ARRAY)
834 is_pp_rv2av ? return_array_to_lvalue_scalar
835 : return_hash_to_lvalue_scalar);
843 if (SvTYPE(sv) != SVt_PVGV) {
844 if (SvGMAGICAL(sv)) {
849 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
857 sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
858 if (PL_op->op_private & OPpLVAL_INTRO)
859 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
860 if (PL_op->op_flags & OPf_REF) {
865 if (gimme != G_ARRAY)
867 is_pp_rv2av ? return_array_to_lvalue_scalar
868 : return_hash_to_lvalue_scalar);
876 AV *const av = (AV*)sv;
877 /* The guts of pp_rv2av, with no intenting change to preserve history
878 (until such time as we get tools that can do blame annotation across
879 whitespace changes. */
880 if (gimme == G_ARRAY) {
881 const I32 maxarg = AvFILL(av) + 1;
882 (void)POPs; /* XXXX May be optimized away? */
884 if (SvRMAGICAL(av)) {
886 for (i=0; i < (U32)maxarg; i++) {
887 SV ** const svp = av_fetch(av, i, FALSE);
888 /* See note in pp_helem, and bug id #27839 */
890 ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
895 Copy(AvARRAY(av), SP+1, maxarg, SV*);
899 else if (gimme == G_SCALAR) {
901 const I32 maxarg = AvFILL(av) + 1;
905 /* The guts of pp_rv2hv */
906 if (gimme == G_ARRAY) { /* array wanted */
910 else if (gimme == G_SCALAR) {
912 TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
921 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
928 if (ckWARN(WARN_MISC)) {
930 if (relem == firstrelem &&
932 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
933 SvTYPE(SvRV(*relem)) == SVt_PVHV))
935 err = "Reference found where even-sized list expected";
938 err = "Odd number of elements in hash assignment";
939 Perl_warner(aTHX_ packWARN(WARN_MISC), err);
943 didstore = hv_store_ent(hash,*relem,tmpstr,0);
944 if (SvMAGICAL(hash)) {
945 if (SvSMAGICAL(tmpstr))
957 SV **lastlelem = PL_stack_sp;
958 SV **lastrelem = PL_stack_base + POPMARK;
959 SV **firstrelem = PL_stack_base + POPMARK + 1;
960 SV **firstlelem = lastrelem + 1;
973 SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet */
975 if (PL_op->op_private & OPpASSIGN_STATE) {
976 if (SvPADSTALE(*firstlelem))
977 SvPADSTALE_off(*firstlelem);
979 RETURN; /* ignore assignment */
982 PL_delaymagic = DM_DELAY; /* catch simultaneous items */
985 /* If there's a common identifier on both sides we have to take
986 * special care that assigning the identifier on the left doesn't
987 * clobber a value on the right that's used later in the list.
989 if (PL_op->op_private & (OPpASSIGN_COMMON)) {
990 EXTEND_MORTAL(lastrelem - firstrelem + 1);
991 for (relem = firstrelem; relem <= lastrelem; relem++) {
993 TAINT_NOT; /* Each item is independent */
994 *relem = sv_mortalcopy(sv);
1004 while (lelem <= lastlelem) {
1005 TAINT_NOT; /* Each item stands on its own, taintwise. */
1007 switch (SvTYPE(sv)) {
1010 magic = SvMAGICAL(ary) != 0;
1012 av_extend(ary, lastrelem - relem);
1014 while (relem <= lastrelem) { /* gobble up all the rest */
1017 sv = newSVsv(*relem);
1019 didstore = av_store(ary,i++,sv);
1029 case SVt_PVHV: { /* normal hash */
1033 magic = SvMAGICAL(hash) != 0;
1035 firsthashrelem = relem;
1037 while (relem < lastrelem) { /* gobble up all the rest */
1039 sv = *relem ? *relem : &PL_sv_no;
1043 sv_setsv(tmpstr,*relem); /* value */
1044 *(relem++) = tmpstr;
1045 if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1046 /* key overwrites an existing entry */
1048 didstore = hv_store_ent(hash,sv,tmpstr,0);
1050 if (SvSMAGICAL(tmpstr))
1057 if (relem == lastrelem) {
1058 do_oddball(hash, relem, firstrelem);
1064 if (SvIMMORTAL(sv)) {
1065 if (relem <= lastrelem)
1069 if (relem <= lastrelem) {
1070 sv_setsv(sv, *relem);
1074 sv_setsv(sv, &PL_sv_undef);
1079 if (PL_delaymagic & ~DM_DELAY) {
1080 if (PL_delaymagic & DM_UID) {
1081 #ifdef HAS_SETRESUID
1082 (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1083 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1086 # ifdef HAS_SETREUID
1087 (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
1088 (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1091 if ((PL_delaymagic & DM_UID) == DM_RUID) {
1092 (void)setruid(PL_uid);
1093 PL_delaymagic &= ~DM_RUID;
1095 # endif /* HAS_SETRUID */
1097 if ((PL_delaymagic & DM_UID) == DM_EUID) {
1098 (void)seteuid(PL_euid);
1099 PL_delaymagic &= ~DM_EUID;
1101 # endif /* HAS_SETEUID */
1102 if (PL_delaymagic & DM_UID) {
1103 if (PL_uid != PL_euid)
1104 DIE(aTHX_ "No setreuid available");
1105 (void)PerlProc_setuid(PL_uid);
1107 # endif /* HAS_SETREUID */
1108 #endif /* HAS_SETRESUID */
1109 PL_uid = PerlProc_getuid();
1110 PL_euid = PerlProc_geteuid();
1112 if (PL_delaymagic & DM_GID) {
1113 #ifdef HAS_SETRESGID
1114 (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1115 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1118 # ifdef HAS_SETREGID
1119 (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
1120 (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1123 if ((PL_delaymagic & DM_GID) == DM_RGID) {
1124 (void)setrgid(PL_gid);
1125 PL_delaymagic &= ~DM_RGID;
1127 # endif /* HAS_SETRGID */
1129 if ((PL_delaymagic & DM_GID) == DM_EGID) {
1130 (void)setegid(PL_egid);
1131 PL_delaymagic &= ~DM_EGID;
1133 # endif /* HAS_SETEGID */
1134 if (PL_delaymagic & DM_GID) {
1135 if (PL_gid != PL_egid)
1136 DIE(aTHX_ "No setregid available");
1137 (void)PerlProc_setgid(PL_gid);
1139 # endif /* HAS_SETREGID */
1140 #endif /* HAS_SETRESGID */
1141 PL_gid = PerlProc_getgid();
1142 PL_egid = PerlProc_getegid();
1144 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1148 if (gimme == G_VOID)
1149 SP = firstrelem - 1;
1150 else if (gimme == G_SCALAR) {
1153 SETi(lastrelem - firstrelem + 1 - duplicates);
1160 /* Removes from the stack the entries which ended up as
1161 * duplicated keys in the hash (fix for [perl #24380]) */
1162 Move(firsthashrelem + duplicates,
1163 firsthashrelem, duplicates, SV**);
1164 lastrelem -= duplicates;
1169 SP = firstrelem + (lastlelem - firstlelem);
1170 lelem = firstlelem + (relem - firstrelem);
1172 *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1180 register PMOP * const pm = cPMOP;
1181 SV * const rv = sv_newmortal();
1182 SV * const sv = newSVrv(rv, "Regexp");
1183 if (pm->op_pmdynflags & PMdf_TAINTED)
1185 sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1193 register PMOP *pm = cPMOP;
1195 register const char *t;
1196 register const char *s;
1199 I32 r_flags = REXEC_CHECKED;
1200 const char *truebase; /* Start of string */
1201 register REGEXP *rx = PM_GETRE(pm);
1203 const I32 gimme = GIMME;
1206 const I32 oldsave = PL_savestack_ix;
1207 I32 update_minmatch = 1;
1208 I32 had_zerolen = 0;
1211 if (PL_op->op_flags & OPf_STACKED)
1213 else if (PL_op->op_private & OPpTARGET_MY)
1220 PUTBACK; /* EVAL blocks need stack_sp. */
1221 s = SvPV_const(TARG, len);
1223 DIE(aTHX_ "panic: pp_match");
1225 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1226 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1229 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1231 /* PMdf_USED is set after a ?? matches once */
1232 if (pm->op_pmdynflags & PMdf_USED) {
1234 if (gimme == G_ARRAY)
1239 /* empty pattern special-cased to use last successful pattern if possible */
1240 if (!rx->prelen && PL_curpm) {
1245 if (rx->minlen > (I32)len)
1250 /* XXXX What part of this is needed with true \G-support? */
1251 if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1252 rx->offs[0].start = -1;
1253 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1254 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1255 if (mg && mg->mg_len >= 0) {
1256 if (!(rx->extflags & RXf_GPOS_SEEN))
1257 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1258 else if (rx->extflags & RXf_ANCH_GPOS) {
1259 r_flags |= REXEC_IGNOREPOS;
1260 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1261 } else if (rx->extflags & RXf_GPOS_FLOAT)
1264 rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1265 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1266 update_minmatch = 0;
1270 /* remove comment to get faster /g but possibly unsafe $1 vars after a
1271 match. Test for the unsafe vars will fail as well*/
1272 if (( /* !global && */ rx->nparens)
1273 || SvTEMP(TARG) || PL_sawampersand ||
1274 (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
1275 r_flags |= REXEC_COPY_STR;
1277 r_flags |= REXEC_SCREAM;
1280 if (global && rx->offs[0].start != -1) {
1281 t = s = rx->offs[0].end + truebase - rx->gofs;
1282 if ((s + rx->minlen) > strend || s < truebase)
1284 if (update_minmatch++)
1285 minmatch = had_zerolen;
1287 if (rx->extflags & RXf_USE_INTUIT &&
1288 DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1289 /* FIXME - can PL_bostr be made const char *? */
1290 PL_bostr = (char *)truebase;
1291 s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1295 if ( (rx->extflags & RXf_CHECK_ALL)
1297 && !(pm->op_pmflags & PMf_KEEPCOPY)
1298 && ((rx->extflags & RXf_NOSCAN)
1299 || !((rx->extflags & RXf_INTUIT_TAIL)
1300 && (r_flags & REXEC_SCREAM)))
1301 && !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
1304 if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1307 if (dynpm->op_pmflags & PMf_ONCE)
1308 dynpm->op_pmdynflags |= PMdf_USED;
1317 RX_MATCH_TAINTED_on(rx);
1318 TAINT_IF(RX_MATCH_TAINTED(rx));
1319 if (gimme == G_ARRAY) {
1320 const I32 nparens = rx->nparens;
1321 I32 i = (global && !nparens) ? 1 : 0;
1323 SPAGAIN; /* EVAL blocks could move the stack. */
1324 EXTEND(SP, nparens + i);
1325 EXTEND_MORTAL(nparens + i);
1326 for (i = !i; i <= nparens; i++) {
1327 PUSHs(sv_newmortal());
1328 if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1329 const I32 len = rx->offs[i].end - rx->offs[i].start;
1330 s = rx->offs[i].start + truebase;
1331 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1332 len < 0 || len > strend - s)
1333 DIE(aTHX_ "panic: pp_match start/end pointers");
1334 sv_setpvn(*SP, s, len);
1335 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1340 if (dynpm->op_pmflags & PMf_CONTINUE) {
1342 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1343 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1345 #ifdef PERL_OLD_COPY_ON_WRITE
1347 sv_force_normal_flags(TARG, 0);
1349 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1350 &PL_vtbl_mglob, NULL, 0);
1352 if (rx->offs[0].start != -1) {
1353 mg->mg_len = rx->offs[0].end;
1354 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1355 mg->mg_flags |= MGf_MINMATCH;
1357 mg->mg_flags &= ~MGf_MINMATCH;
1360 had_zerolen = (rx->offs[0].start != -1
1361 && (rx->offs[0].start + rx->gofs
1362 == (UV)rx->offs[0].end));
1363 PUTBACK; /* EVAL blocks may use stack */
1364 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1369 LEAVE_SCOPE(oldsave);
1375 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1376 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1380 #ifdef PERL_OLD_COPY_ON_WRITE
1382 sv_force_normal_flags(TARG, 0);
1384 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1385 &PL_vtbl_mglob, NULL, 0);
1387 if (rx->offs[0].start != -1) {
1388 mg->mg_len = rx->offs[0].end;
1389 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1390 mg->mg_flags |= MGf_MINMATCH;
1392 mg->mg_flags &= ~MGf_MINMATCH;
1395 LEAVE_SCOPE(oldsave);
1399 yup: /* Confirmed by INTUIT */
1401 RX_MATCH_TAINTED_on(rx);
1402 TAINT_IF(RX_MATCH_TAINTED(rx));
1404 if (dynpm->op_pmflags & PMf_ONCE)
1405 dynpm->op_pmdynflags |= PMdf_USED;
1406 if (RX_MATCH_COPIED(rx))
1407 Safefree(rx->subbeg);
1408 RX_MATCH_COPIED_off(rx);
1411 /* FIXME - should rx->subbeg be const char *? */
1412 rx->subbeg = (char *) truebase;
1413 rx->offs[0].start = s - truebase;
1414 if (RX_MATCH_UTF8(rx)) {
1415 char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1416 rx->offs[0].end = t - truebase;
1419 rx->offs[0].end = s - truebase + rx->minlenret;
1421 rx->sublen = strend - truebase;
1424 if (PL_sawampersand || pm->op_pmflags & PMf_KEEPCOPY) {
1426 #ifdef PERL_OLD_COPY_ON_WRITE
1427 if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1429 PerlIO_printf(Perl_debug_log,
1430 "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1431 (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1434 rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1435 rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1436 assert (SvPOKp(rx->saved_copy));
1441 rx->subbeg = savepvn(t, strend - t);
1442 #ifdef PERL_OLD_COPY_ON_WRITE
1443 rx->saved_copy = NULL;
1446 rx->sublen = strend - t;
1447 RX_MATCH_COPIED_on(rx);
1448 off = rx->offs[0].start = s - t;
1449 rx->offs[0].end = off + rx->minlenret;
1451 else { /* startp/endp are used by @- @+. */
1452 rx->offs[0].start = s - truebase;
1453 rx->offs[0].end = s - truebase + rx->minlenret;
1455 /* including rx->nparens in the below code seems highly suspicious.
1457 rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
1458 LEAVE_SCOPE(oldsave);
1463 if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1464 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1465 MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1470 LEAVE_SCOPE(oldsave);
1471 if (gimme == G_ARRAY)
1477 Perl_do_readline(pTHX)
1479 dVAR; dSP; dTARGETSTACKED;
1484 register IO * const io = GvIO(PL_last_in_gv);
1485 register const I32 type = PL_op->op_type;
1486 const I32 gimme = GIMME_V;
1489 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1492 XPUSHs(SvTIED_obj((SV*)io, mg));
1495 call_method("READLINE", gimme);
1498 if (gimme == G_SCALAR) {
1499 SV* const result = POPs;
1500 SvSetSV_nosteal(TARG, result);
1510 if (IoFLAGS(io) & IOf_ARGV) {
1511 if (IoFLAGS(io) & IOf_START) {
1513 if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1514 IoFLAGS(io) &= ~IOf_START;
1515 do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1516 sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1517 SvSETMAGIC(GvSV(PL_last_in_gv));
1522 fp = nextargv(PL_last_in_gv);
1523 if (!fp) { /* Note: fp != IoIFP(io) */
1524 (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1527 else if (type == OP_GLOB)
1528 fp = Perl_start_glob(aTHX_ POPs, io);
1530 else if (type == OP_GLOB)
1532 else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1533 report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1537 if ((!io || !(IoFLAGS(io) & IOf_START))
1538 && ckWARN2(WARN_GLOB, WARN_CLOSED))
1540 if (type == OP_GLOB)
1541 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1542 "glob failed (can't start child: %s)",
1545 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1547 if (gimme == G_SCALAR) {
1548 /* undef TARG, and push that undefined value */
1549 if (type != OP_RCATLINE) {
1550 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1558 if (gimme == G_SCALAR) {
1560 if (type == OP_RCATLINE && SvGMAGICAL(sv))
1563 if (type == OP_RCATLINE)
1564 SvPV_force_nolen(sv);
1568 else if (isGV_with_GP(sv)) {
1569 SvPV_force_nolen(sv);
1571 SvUPGRADE(sv, SVt_PV);
1572 tmplen = SvLEN(sv); /* remember if already alloced */
1573 if (!tmplen && !SvREADONLY(sv))
1574 Sv_Grow(sv, 80); /* try short-buffering it */
1576 if (type == OP_RCATLINE && SvOK(sv)) {
1578 SvPV_force_nolen(sv);
1584 sv = sv_2mortal(newSV(80));
1588 /* This should not be marked tainted if the fp is marked clean */
1589 #define MAYBE_TAINT_LINE(io, sv) \
1590 if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1595 /* delay EOF state for a snarfed empty file */
1596 #define SNARF_EOF(gimme,rs,io,sv) \
1597 (gimme != G_SCALAR || SvCUR(sv) \
1598 || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1602 if (!sv_gets(sv, fp, offset)
1604 || SNARF_EOF(gimme, PL_rs, io, sv)
1605 || PerlIO_error(fp)))
1607 PerlIO_clearerr(fp);
1608 if (IoFLAGS(io) & IOf_ARGV) {
1609 fp = nextargv(PL_last_in_gv);
1612 (void)do_close(PL_last_in_gv, FALSE);
1614 else if (type == OP_GLOB) {
1615 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1616 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1617 "glob failed (child exited with status %d%s)",
1618 (int)(STATUS_CURRENT >> 8),
1619 (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1622 if (gimme == G_SCALAR) {
1623 if (type != OP_RCATLINE) {
1624 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1630 MAYBE_TAINT_LINE(io, sv);
1633 MAYBE_TAINT_LINE(io, sv);
1635 IoFLAGS(io) |= IOf_NOLINE;
1639 if (type == OP_GLOB) {
1642 if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1643 char * const tmps = SvEND(sv) - 1;
1644 if (*tmps == *SvPVX_const(PL_rs)) {
1646 SvCUR_set(sv, SvCUR(sv) - 1);
1649 for (t1 = SvPVX_const(sv); *t1; t1++)
1650 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1651 strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1653 if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1654 (void)POPs; /* Unmatched wildcard? Chuck it... */
1657 } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1658 if (ckWARN(WARN_UTF8)) {
1659 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1660 const STRLEN len = SvCUR(sv) - offset;
1663 if (!is_utf8_string_loc(s, len, &f))
1664 /* Emulate :encoding(utf8) warning in the same case. */
1665 Perl_warner(aTHX_ packWARN(WARN_UTF8),
1666 "utf8 \"\\x%02X\" does not map to Unicode",
1667 f < (U8*)SvEND(sv) ? *f : 0);
1670 if (gimme == G_ARRAY) {
1671 if (SvLEN(sv) - SvCUR(sv) > 20) {
1672 SvPV_shrink_to_cur(sv);
1674 sv = sv_2mortal(newSV(80));
1677 else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1678 /* try to reclaim a bit of scalar space (only on 1st alloc) */
1679 const STRLEN new_len
1680 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1681 SvPV_renew(sv, new_len);
1690 register PERL_CONTEXT *cx;
1691 I32 gimme = OP_GIMME(PL_op, -1);
1694 if (cxstack_ix >= 0)
1695 gimme = cxstack[cxstack_ix].blk_gimme;
1703 PUSHBLOCK(cx, CXt_BLOCK, SP);
1713 SV * const keysv = POPs;
1714 HV * const hv = (HV*)POPs;
1715 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1716 const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1718 const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1721 if (SvTYPE(hv) != SVt_PVHV)
1724 if (PL_op->op_private & OPpLVAL_INTRO) {
1727 /* does the element we're localizing already exist? */
1728 preeminent = /* can we determine whether it exists? */
1730 || mg_find((SV*)hv, PERL_MAGIC_env)
1731 || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1732 /* Try to preserve the existenceness of a tied hash
1733 * element by using EXISTS and DELETE if possible.
1734 * Fallback to FETCH and STORE otherwise */
1735 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1736 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1737 && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1739 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1741 he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1742 svp = he ? &HeVAL(he) : NULL;
1744 if (!svp || *svp == &PL_sv_undef) {
1748 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1750 lv = sv_newmortal();
1751 sv_upgrade(lv, SVt_PVLV);
1753 sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1754 SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1755 LvTARG(lv) = SvREFCNT_inc_simple(hv);
1760 if (PL_op->op_private & OPpLVAL_INTRO) {
1761 if (HvNAME_get(hv) && isGV(*svp))
1762 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1766 const char * const key = SvPV_const(keysv, keylen);
1767 SAVEDELETE(hv, savepvn(key,keylen),
1768 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1770 save_helem(hv, keysv, svp);
1773 else if (PL_op->op_private & OPpDEREF)
1774 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1776 sv = (svp ? *svp : &PL_sv_undef);
1777 /* This makes C<local $tied{foo} = $tied{foo}> possible.
1778 * Pushing the magical RHS on to the stack is useless, since
1779 * that magic is soon destined to be misled by the local(),
1780 * and thus the later pp_sassign() will fail to mg_get() the
1781 * old value. This should also cure problems with delayed
1782 * mg_get()s. GSAR 98-07-03 */
1783 if (!lval && SvGMAGICAL(sv))
1784 sv = sv_mortalcopy(sv);
1792 register PERL_CONTEXT *cx;
1797 if (PL_op->op_flags & OPf_SPECIAL) {
1798 cx = &cxstack[cxstack_ix];
1799 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
1804 gimme = OP_GIMME(PL_op, -1);
1806 if (cxstack_ix >= 0)
1807 gimme = cxstack[cxstack_ix].blk_gimme;
1813 if (gimme == G_VOID)
1815 else if (gimme == G_SCALAR) {
1819 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1822 *MARK = sv_mortalcopy(TOPs);
1825 *MARK = &PL_sv_undef;
1829 else if (gimme == G_ARRAY) {
1830 /* in case LEAVE wipes old return values */
1832 for (mark = newsp + 1; mark <= SP; mark++) {
1833 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1834 *mark = sv_mortalcopy(*mark);
1835 TAINT_NOT; /* Each item is independent */
1839 PL_curpm = newpm; /* Don't pop $1 et al till now */
1849 register PERL_CONTEXT *cx;
1855 cx = &cxstack[cxstack_ix];
1856 if (CxTYPE(cx) != CXt_LOOP)
1857 DIE(aTHX_ "panic: pp_iter");
1859 itersvp = CxITERVAR(cx);
1860 av = cx->blk_loop.iterary;
1861 if (SvTYPE(av) != SVt_PVAV) {
1862 /* iterate ($min .. $max) */
1863 if (cx->blk_loop.iterlval) {
1864 /* string increment */
1865 register SV* cur = cx->blk_loop.iterlval;
1869 SvPV_const((SV*)av, maxlen) : (const char *)"";
1870 if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1871 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1872 /* safe to reuse old SV */
1873 sv_setsv(*itersvp, cur);
1877 /* we need a fresh SV every time so that loop body sees a
1878 * completely new SV for closures/references to work as
1881 *itersvp = newSVsv(cur);
1882 SvREFCNT_dec(oldsv);
1884 if (strEQ(SvPVX_const(cur), max))
1885 sv_setiv(cur, 0); /* terminate next time */
1892 /* integer increment */
1893 if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1896 /* don't risk potential race */
1897 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1898 /* safe to reuse old SV */
1899 sv_setiv(*itersvp, cx->blk_loop.iterix++);
1903 /* we need a fresh SV every time so that loop body sees a
1904 * completely new SV for closures/references to work as they
1907 *itersvp = newSViv(cx->blk_loop.iterix++);
1908 SvREFCNT_dec(oldsv);
1914 if (PL_op->op_private & OPpITER_REVERSED) {
1915 /* In reverse, use itermax as the min :-) */
1916 if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1919 if (SvMAGICAL(av) || AvREIFY(av)) {
1920 SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1921 sv = svp ? *svp : NULL;
1924 sv = AvARRAY(av)[--cx->blk_loop.iterix];
1928 if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1932 if (SvMAGICAL(av) || AvREIFY(av)) {
1933 SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1934 sv = svp ? *svp : NULL;
1937 sv = AvARRAY(av)[++cx->blk_loop.iterix];
1941 if (sv && SvIS_FREED(sv)) {
1943 Perl_croak(aTHX_ "Use of freed value in iteration");
1950 if (av != PL_curstack && sv == &PL_sv_undef) {
1951 SV *lv = cx->blk_loop.iterlval;
1952 if (lv && SvREFCNT(lv) > 1) {
1957 SvREFCNT_dec(LvTARG(lv));
1959 lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1961 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1963 LvTARG(lv) = SvREFCNT_inc_simple(av);
1964 LvTARGOFF(lv) = cx->blk_loop.iterix;
1965 LvTARGLEN(lv) = (STRLEN)UV_MAX;
1970 *itersvp = SvREFCNT_inc_simple_NN(sv);
1971 SvREFCNT_dec(oldsv);
1979 register PMOP *pm = cPMOP;
1994 register REGEXP *rx = PM_GETRE(pm);
1996 int force_on_match = 0;
1997 const I32 oldsave = PL_savestack_ix;
1999 bool doutf8 = FALSE;
2000 #ifdef PERL_OLD_COPY_ON_WRITE
2005 /* known replacement string? */
2006 register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2007 if (PL_op->op_flags & OPf_STACKED)
2009 else if (PL_op->op_private & OPpTARGET_MY)
2016 #ifdef PERL_OLD_COPY_ON_WRITE
2017 /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2018 because they make integers such as 256 "false". */
2019 is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2022 sv_force_normal_flags(TARG,0);
2025 #ifdef PERL_OLD_COPY_ON_WRITE
2029 || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2030 || SvTYPE(TARG) > SVt_PVLV)
2031 && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2032 DIE(aTHX_ PL_no_modify);
2035 s = SvPV_mutable(TARG, len);
2036 if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2038 rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2039 (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2044 RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2048 DIE(aTHX_ "panic: pp_subst");
2051 slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2052 maxiters = 2 * slen + 10; /* We can match twice at each
2053 position, once with zero-length,
2054 second time with non-zero. */
2056 if (!rx->prelen && PL_curpm) {
2060 r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2061 || (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)) )
2062 ? REXEC_COPY_STR : 0;
2064 r_flags |= REXEC_SCREAM;
2067 if (rx->extflags & RXf_USE_INTUIT) {
2069 s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2073 /* How to do it in subst? */
2074 /* if ( (rx->extflags & RXf_CHECK_ALL)
2076 && !(pm->op_pmflags & PMf_KEEPCOPY)
2077 && ((rx->extflags & RXf_NOSCAN)
2078 || !((rx->extflags & RXf_INTUIT_TAIL)
2079 && (r_flags & REXEC_SCREAM))))
2084 /* only replace once? */
2085 once = !(rpm->op_pmflags & PMf_GLOBAL);
2087 /* known replacement string? */
2089 /* replacement needing upgrading? */
2090 if (DO_UTF8(TARG) && !doutf8) {
2091 nsv = sv_newmortal();
2094 sv_recode_to_utf8(nsv, PL_encoding);
2096 sv_utf8_upgrade(nsv);
2097 c = SvPV_const(nsv, clen);
2101 c = SvPV_const(dstr, clen);
2102 doutf8 = DO_UTF8(dstr);
2110 /* can do inplace substitution? */
2112 #ifdef PERL_OLD_COPY_ON_WRITE
2115 && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2116 && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2117 && (!doutf8 || SvUTF8(TARG))) {
2118 if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2119 r_flags | REXEC_CHECKED))
2123 LEAVE_SCOPE(oldsave);
2126 #ifdef PERL_OLD_COPY_ON_WRITE
2127 if (SvIsCOW(TARG)) {
2128 assert (!force_on_match);
2132 if (force_on_match) {
2134 s = SvPV_force(TARG, len);
2139 SvSCREAM_off(TARG); /* disable possible screamer */
2141 rxtainted |= RX_MATCH_TAINTED(rx);
2142 m = orig + rx->offs[0].start;
2143 d = orig + rx->offs[0].end;
2145 if (m - s > strend - d) { /* faster to shorten from end */
2147 Copy(c, m, clen, char);
2152 Move(d, m, i, char);
2156 SvCUR_set(TARG, m - s);
2158 else if ((i = m - s)) { /* faster from front */
2166 Copy(c, m, clen, char);
2171 Copy(c, d, clen, char);
2176 TAINT_IF(rxtainted & 1);
2182 if (iters++ > maxiters)
2183 DIE(aTHX_ "Substitution loop");
2184 rxtainted |= RX_MATCH_TAINTED(rx);
2185 m = rx->offs[0].start + orig;
2188 Move(s, d, i, char);
2192 Copy(c, d, clen, char);
2195 s = rx->offs[0].end + orig;
2196 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2198 /* don't match same null twice */
2199 REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2202 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2203 Move(s, d, i+1, char); /* include the NUL */
2205 TAINT_IF(rxtainted & 1);
2207 PUSHs(sv_2mortal(newSViv((I32)iters)));
2209 (void)SvPOK_only_UTF8(TARG);
2210 TAINT_IF(rxtainted);
2211 if (SvSMAGICAL(TARG)) {
2219 LEAVE_SCOPE(oldsave);
2223 if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2224 r_flags | REXEC_CHECKED))
2226 if (force_on_match) {
2228 s = SvPV_force(TARG, len);
2231 #ifdef PERL_OLD_COPY_ON_WRITE
2234 rxtainted |= RX_MATCH_TAINTED(rx);
2235 dstr = newSVpvn(m, s-m);
2241 register PERL_CONTEXT *cx;
2244 RETURNOP(cPMOP->op_pmreplroot);
2246 r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2248 if (iters++ > maxiters)
2249 DIE(aTHX_ "Substitution loop");
2250 rxtainted |= RX_MATCH_TAINTED(rx);
2251 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2256 strend = s + (strend - m);
2258 m = rx->offs[0].start + orig;
2259 if (doutf8 && !SvUTF8(dstr))
2260 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2262 sv_catpvn(dstr, s, m-s);
2263 s = rx->offs[0].end + orig;
2265 sv_catpvn(dstr, c, clen);
2268 } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2269 TARG, NULL, r_flags));
2270 if (doutf8 && !DO_UTF8(TARG))
2271 sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2273 sv_catpvn(dstr, s, strend - s);
2275 #ifdef PERL_OLD_COPY_ON_WRITE
2276 /* The match may make the string COW. If so, brilliant, because that's
2277 just saved us one malloc, copy and free - the regexp has donated
2278 the old buffer, and we malloc an entirely new one, rather than the
2279 regexp malloc()ing a buffer and copying our original, only for
2280 us to throw it away here during the substitution. */
2281 if (SvIsCOW(TARG)) {
2282 sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2288 SvPV_set(TARG, SvPVX(dstr));
2289 SvCUR_set(TARG, SvCUR(dstr));
2290 SvLEN_set(TARG, SvLEN(dstr));
2291 doutf8 |= DO_UTF8(dstr);
2292 SvPV_set(dstr, NULL);
2294 TAINT_IF(rxtainted & 1);
2296 PUSHs(sv_2mortal(newSViv((I32)iters)));
2298 (void)SvPOK_only(TARG);
2301 TAINT_IF(rxtainted);
2304 LEAVE_SCOPE(oldsave);
2313 LEAVE_SCOPE(oldsave);
2322 PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2323 ++*PL_markstack_ptr;
2324 LEAVE; /* exit inner scope */
2327 if (PL_stack_base + *PL_markstack_ptr > SP) {
2329 const I32 gimme = GIMME_V;
2331 LEAVE; /* exit outer scope */
2332 (void)POPMARK; /* pop src */
2333 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2334 (void)POPMARK; /* pop dst */
2335 SP = PL_stack_base + POPMARK; /* pop original mark */
2336 if (gimme == G_SCALAR) {
2337 if (PL_op->op_private & OPpGREP_LEX) {
2338 SV* const sv = sv_newmortal();
2339 sv_setiv(sv, items);
2347 else if (gimme == G_ARRAY)
2354 ENTER; /* enter inner scope */
2357 src = PL_stack_base[*PL_markstack_ptr];
2359 if (PL_op->op_private & OPpGREP_LEX)
2360 PAD_SVl(PL_op->op_targ) = src;
2364 RETURNOP(cLOGOP->op_other);
2375 register PERL_CONTEXT *cx;
2378 if (CxMULTICALL(&cxstack[cxstack_ix]))
2382 cxstack_ix++; /* temporarily protect top context */
2385 if (gimme == G_SCALAR) {
2388 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2390 *MARK = SvREFCNT_inc(TOPs);
2395 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2397 *MARK = sv_mortalcopy(sv);
2402 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2406 *MARK = &PL_sv_undef;
2410 else if (gimme == G_ARRAY) {
2411 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2412 if (!SvTEMP(*MARK)) {
2413 *MARK = sv_mortalcopy(*MARK);
2414 TAINT_NOT; /* Each item is independent */
2422 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2423 PL_curpm = newpm; /* ... and pop $1 et al */
2426 return cx->blk_sub.retop;
2429 /* This duplicates the above code because the above code must not
2430 * get any slower by more conditions */
2438 register PERL_CONTEXT *cx;
2441 if (CxMULTICALL(&cxstack[cxstack_ix]))
2445 cxstack_ix++; /* temporarily protect top context */
2449 if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2450 /* We are an argument to a function or grep().
2451 * This kind of lvalueness was legal before lvalue
2452 * subroutines too, so be backward compatible:
2453 * cannot report errors. */
2455 /* Scalar context *is* possible, on the LHS of -> only,
2456 * as in f()->meth(). But this is not an lvalue. */
2457 if (gimme == G_SCALAR)
2459 if (gimme == G_ARRAY) {
2460 if (!CvLVALUE(cx->blk_sub.cv))
2461 goto temporise_array;
2462 EXTEND_MORTAL(SP - newsp);
2463 for (mark = newsp + 1; mark <= SP; mark++) {
2466 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2467 *mark = sv_mortalcopy(*mark);
2469 /* Can be a localized value subject to deletion. */
2470 PL_tmps_stack[++PL_tmps_ix] = *mark;
2471 SvREFCNT_inc_void(*mark);
2476 else if (cx->blk_sub.lval) { /* Leave it as it is if we can. */
2477 /* Here we go for robustness, not for speed, so we change all
2478 * the refcounts so the caller gets a live guy. Cannot set
2479 * TEMP, so sv_2mortal is out of question. */
2480 if (!CvLVALUE(cx->blk_sub.cv)) {
2486 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2488 if (gimme == G_SCALAR) {
2492 /* Temporaries are bad unless they happen to be elements
2493 * of a tied hash or array */
2494 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2495 !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2501 DIE(aTHX_ "Can't return %s from lvalue subroutine",
2502 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2503 : "a readonly value" : "a temporary");
2505 else { /* Can be a localized value
2506 * subject to deletion. */
2507 PL_tmps_stack[++PL_tmps_ix] = *mark;
2508 SvREFCNT_inc_void(*mark);
2511 else { /* Should not happen? */
2517 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2518 (MARK > SP ? "Empty array" : "Array"));
2522 else if (gimme == G_ARRAY) {
2523 EXTEND_MORTAL(SP - newsp);
2524 for (mark = newsp + 1; mark <= SP; mark++) {
2525 if (*mark != &PL_sv_undef
2526 && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2527 /* Might be flattened array after $#array = */
2534 DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2535 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2538 /* Can be a localized value subject to deletion. */
2539 PL_tmps_stack[++PL_tmps_ix] = *mark;
2540 SvREFCNT_inc_void(*mark);
2546 if (gimme == G_SCALAR) {
2550 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2552 *MARK = SvREFCNT_inc(TOPs);
2557 sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2559 *MARK = sv_mortalcopy(sv);
2564 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2568 *MARK = &PL_sv_undef;
2572 else if (gimme == G_ARRAY) {
2574 for (MARK = newsp + 1; MARK <= SP; MARK++) {
2575 if (!SvTEMP(*MARK)) {
2576 *MARK = sv_mortalcopy(*MARK);
2577 TAINT_NOT; /* Each item is independent */
2586 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2587 PL_curpm = newpm; /* ... and pop $1 et al */
2590 return cx->blk_sub.retop;
2598 register PERL_CONTEXT *cx;
2600 const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2603 DIE(aTHX_ "Not a CODE reference");
2604 switch (SvTYPE(sv)) {
2605 /* This is overwhelming the most common case: */
2607 if (!(cv = GvCVu((GV*)sv))) {
2609 cv = sv_2cv(sv, &stash, &gv, 0);
2621 if (sv == &PL_sv_yes) { /* unfound import, ignore */
2623 SP = PL_stack_base + POPMARK;
2626 if (SvGMAGICAL(sv)) {
2631 sym = SvPVX_const(sv);
2639 sym = SvPV_const(sv, len);
2642 DIE(aTHX_ PL_no_usym, "a subroutine");
2643 if (PL_op->op_private & HINT_STRICT_REFS)
2644 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2645 cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2650 SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
2651 tryAMAGICunDEREF(to_cv);
2654 if (SvTYPE(cv) == SVt_PVCV)
2659 DIE(aTHX_ "Not a CODE reference");
2660 /* This is the second most common case: */
2670 if (!CvROOT(cv) && !CvXSUB(cv)) {
2674 /* anonymous or undef'd function leaves us no recourse */
2675 if (CvANON(cv) || !(gv = CvGV(cv)))
2676 DIE(aTHX_ "Undefined subroutine called");
2678 /* autoloaded stub? */
2679 if (cv != GvCV(gv)) {
2682 /* should call AUTOLOAD now? */
2685 if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2692 sub_name = sv_newmortal();
2693 gv_efullname3(sub_name, gv, NULL);
2694 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2698 DIE(aTHX_ "Not a CODE reference");
2703 if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2704 if (CvASSERTION(cv) && PL_DBassertion)
2705 sv_setiv(PL_DBassertion, 1);
2707 Perl_get_db_sub(aTHX_ &sv, cv);
2709 PL_curcopdb = PL_curcop;
2710 cv = GvCV(PL_DBsub);
2712 if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2713 DIE(aTHX_ "No DB::sub routine defined");
2716 if (!(CvISXSUB(cv))) {
2717 /* This path taken at least 75% of the time */
2719 register I32 items = SP - MARK;
2720 AV* const padlist = CvPADLIST(cv);
2721 PUSHBLOCK(cx, CXt_SUB, MARK);
2723 cx->blk_sub.retop = PL_op->op_next;
2725 /* XXX This would be a natural place to set C<PL_compcv = cv> so
2726 * that eval'' ops within this sub know the correct lexical space.
2727 * Owing the speed considerations, we choose instead to search for
2728 * the cv using find_runcv() when calling doeval().
2730 if (CvDEPTH(cv) >= 2) {
2731 PERL_STACK_OVERFLOW_CHECK();
2732 pad_push(padlist, CvDEPTH(cv));
2735 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2737 AV* const av = (AV*)PAD_SVl(0);
2739 /* @_ is normally not REAL--this should only ever
2740 * happen when DB::sub() calls things that modify @_ */
2745 cx->blk_sub.savearray = GvAV(PL_defgv);
2746 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2747 CX_CURPAD_SAVE(cx->blk_sub);
2748 cx->blk_sub.argarray = av;
2751 if (items > AvMAX(av) + 1) {
2752 SV **ary = AvALLOC(av);
2753 if (AvARRAY(av) != ary) {
2754 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2757 if (items > AvMAX(av) + 1) {
2758 AvMAX(av) = items - 1;
2759 Renew(ary,items,SV*);
2764 Copy(MARK,AvARRAY(av),items,SV*);
2765 AvFILLp(av) = items - 1;
2773 /* warning must come *after* we fully set up the context
2774 * stuff so that __WARN__ handlers can safely dounwind()
2777 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2778 && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2779 sub_crush_depth(cv);
2781 DEBUG_S(PerlIO_printf(Perl_debug_log,
2782 "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2784 RETURNOP(CvSTART(cv));
2787 I32 markix = TOPMARK;
2792 /* Need to copy @_ to stack. Alternative may be to
2793 * switch stack to @_, and copy return values
2794 * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2795 AV * const av = GvAV(PL_defgv);
2796 const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
2799 /* Mark is at the end of the stack. */
2801 Copy(AvARRAY(av), SP + 1, items, SV*);
2806 /* We assume first XSUB in &DB::sub is the called one. */
2808 SAVEVPTR(PL_curcop);
2809 PL_curcop = PL_curcopdb;
2812 /* Do we need to open block here? XXXX */
2813 if (CvXSUB(cv)) /* XXX this is supposed to be true */
2814 (void)(*CvXSUB(cv))(aTHX_ cv);
2816 /* Enforce some sanity in scalar context. */
2817 if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2818 if (markix > PL_stack_sp - PL_stack_base)
2819 *(PL_stack_base + markix) = &PL_sv_undef;
2821 *(PL_stack_base + markix) = *PL_stack_sp;
2822 PL_stack_sp = PL_stack_base + markix;
2830 Perl_sub_crush_depth(pTHX_ CV *cv)
2833 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2835 SV* const tmpstr = sv_newmortal();
2836 gv_efullname3(tmpstr, CvGV(cv), NULL);
2837 Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2846 SV* const elemsv = POPs;
2847 IV elem = SvIV(elemsv);
2848 AV* const av = (AV*)POPs;
2849 const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2850 const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2853 if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2854 Perl_warner(aTHX_ packWARN(WARN_MISC),
2855 "Use of reference \"%"SVf"\" as array index",
2858 elem -= CopARYBASE_get(PL_curcop);
2859 if (SvTYPE(av) != SVt_PVAV)
2861 svp = av_fetch(av, elem, lval && !defer);
2863 #ifdef PERL_MALLOC_WRAP
2864 if (SvUOK(elemsv)) {
2865 const UV uv = SvUV(elemsv);
2866 elem = uv > IV_MAX ? IV_MAX : uv;
2868 else if (SvNOK(elemsv))
2869 elem = (IV)SvNV(elemsv);
2871 static const char oom_array_extend[] =
2872 "Out of memory during array extend"; /* Duplicated in av.c */
2873 MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2876 if (!svp || *svp == &PL_sv_undef) {
2879 DIE(aTHX_ PL_no_aelem, elem);
2880 lv = sv_newmortal();
2881 sv_upgrade(lv, SVt_PVLV);
2883 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2884 LvTARG(lv) = SvREFCNT_inc_simple(av);
2885 LvTARGOFF(lv) = elem;
2890 if (PL_op->op_private & OPpLVAL_INTRO)
2891 save_aelem(av, elem, svp);
2892 else if (PL_op->op_private & OPpDEREF)
2893 vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2895 sv = (svp ? *svp : &PL_sv_undef);
2896 if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
2897 sv = sv_mortalcopy(sv);
2903 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2908 Perl_croak(aTHX_ PL_no_modify);
2909 if (SvTYPE(sv) < SVt_RV)
2910 sv_upgrade(sv, SVt_RV);
2911 else if (SvTYPE(sv) >= SVt_PV) {
2918 SvRV_set(sv, newSV(0));
2921 SvRV_set(sv, (SV*)newAV());
2924 SvRV_set(sv, (SV*)newHV());
2935 SV* const sv = TOPs;
2938 SV* const rsv = SvRV(sv);
2939 if (SvTYPE(rsv) == SVt_PVCV) {
2945 SETs(method_common(sv, NULL));
2952 SV* const sv = cSVOP_sv;
2953 U32 hash = SvSHARED_HASH(sv);
2955 XPUSHs(method_common(sv, &hash));
2960 S_method_common(pTHX_ SV* meth, U32* hashp)
2967 const char* packname = NULL;
2970 const char * const name = SvPV_const(meth, namelen);
2971 SV * const sv = *(PL_stack_base + TOPMARK + 1);
2974 Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2982 /* this isn't a reference */
2983 if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2984 const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2986 stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2993 !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2994 !(ob=(SV*)GvIO(iogv)))
2996 /* this isn't the name of a filehandle either */
2998 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2999 ? !isIDFIRST_utf8((U8*)packname)
3000 : !isIDFIRST(*packname)
3003 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3004 SvOK(sv) ? "without a package or object reference"
3005 : "on an undefined value");
3007 /* assume it's a package name */
3008 stash = gv_stashpvn(packname, packlen, 0);
3012 SV* const ref = newSViv(PTR2IV(stash));
3013 hv_store(PL_stashcache, packname, packlen, ref, 0);
3017 /* it _is_ a filehandle name -- replace with a reference */
3018 *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3021 /* if we got here, ob should be a reference or a glob */
3022 if (!ob || !(SvOBJECT(ob)
3023 || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3026 Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3027 (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3031 stash = SvSTASH(ob);
3034 /* NOTE: stash may be null, hope hv_fetch_ent and
3035 gv_fetchmethod can cope (it seems they can) */
3037 /* shortcut for simple names */
3039 const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3041 gv = (GV*)HeVAL(he);
3042 if (isGV(gv) && GvCV(gv) &&
3043 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3044 return (SV*)GvCV(gv);
3048 gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3051 /* This code tries to figure out just what went wrong with
3052 gv_fetchmethod. It therefore needs to duplicate a lot of
3053 the internals of that function. We can't move it inside
3054 Perl_gv_fetchmethod_autoload(), however, since that would
3055 cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3058 const char* leaf = name;
3059 const char* sep = NULL;
3062 for (p = name; *p; p++) {
3064 sep = p, leaf = p + 1;
3065 else if (*p == ':' && *(p + 1) == ':')
3066 sep = p, leaf = p + 2;
3068 if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3069 /* the method name is unqualified or starts with SUPER:: */
3070 bool need_strlen = 1;
3072 packname = CopSTASHPV(PL_curcop);
3075 HEK * const packhek = HvNAME_HEK(stash);
3077 packname = HEK_KEY(packhek);
3078 packlen = HEK_LEN(packhek);
3088 "Can't use anonymous symbol table for method lookup");
3090 else if (need_strlen)
3091 packlen = strlen(packname);
3095 /* the method name is qualified */
3097 packlen = sep - name;
3100 /* we're relying on gv_fetchmethod not autovivifying the stash */
3101 if (gv_stashpvn(packname, packlen, 0)) {
3103 "Can't locate object method \"%s\" via package \"%.*s\"",
3104 leaf, (int)packlen, packname);
3108 "Can't locate object method \"%s\" via package \"%.*s\""
3109 " (perhaps you forgot to load \"%.*s\"?)",
3110 leaf, (int)packlen, packname, (int)packlen, packname);
3113 return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3118 * c-indentation-style: bsd
3120 * indent-tabs-mode: t
3123 * ex: set ts=8 sts=4 sw=4 noet: