3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
51 if (GIMME_V == G_SCALAR)
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
70 if (PL_op->op_flags & OPf_REF) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL((AV*)TARG) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV ** const svp = av_fetch((AV*)TARG, i, FALSE);
87 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
91 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
95 else if (gimme == G_SCALAR) {
96 SV* const sv = sv_newmortal();
97 const I32 maxarg = AvFILL((AV*)TARG) + 1;
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
112 if (PL_op->op_flags & OPf_REF)
115 if (GIMME == G_SCALAR)
116 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
120 if (gimme == G_ARRAY) {
123 else if (gimme == G_SCALAR) {
124 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
132 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
143 tryAMAGICunDEREF(to_gv);
146 if (SvTYPE(sv) == SVt_PVIO) {
147 GV * const gv = (GV*) sv_newmortal();
148 gv_init(gv, 0, "", 0, 0);
149 GvIOp(gv) = (IO *)sv;
150 (void)SvREFCNT_inc(sv);
153 else if (SvTYPE(sv) != SVt_PVGV)
154 DIE(aTHX_ "Not a GLOB reference");
157 if (SvTYPE(sv) != SVt_PVGV) {
158 if (SvGMAGICAL(sv)) {
163 if (!SvOK(sv) && sv != &PL_sv_undef) {
164 /* If this is a 'my' scalar and flag is set then vivify
168 Perl_croak(aTHX_ PL_no_modify);
169 if (PL_op->op_private & OPpDEREF) {
171 if (cUNOP->op_targ) {
173 SV *namesv = PAD_SV(cUNOP->op_targ);
174 const char *name = SvPV(namesv, len);
175 gv = (GV*)NEWSV(0,0);
176 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
179 const char *name = CopSTASHPV(PL_curcop);
182 if (SvTYPE(sv) < SVt_RV)
183 sv_upgrade(sv, SVt_RV);
184 if (SvPVX_const(sv)) {
189 SvRV_set(sv, (SV*)gv);
194 if (PL_op->op_flags & OPf_REF ||
195 PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_usym, "a symbol");
197 if (ckWARN(WARN_UNINITIALIZED))
201 if ((PL_op->op_flags & OPf_SPECIAL) &&
202 !(PL_op->op_flags & OPf_MOD))
204 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
206 && (!is_gv_magical_sv(sv,0)
207 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
213 if (PL_op->op_private & HINT_STRICT_REFS)
214 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
215 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
219 if (PL_op->op_private & OPpLVAL_INTRO)
220 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
232 tryAMAGICunDEREF(to_sv);
235 switch (SvTYPE(sv)) {
239 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
252 if (PL_op->op_flags & OPf_REF ||
253 PL_op->op_private & HINT_STRICT_REFS)
254 DIE(aTHX_ PL_no_usym, "a SCALAR");
255 if (ckWARN(WARN_UNINITIALIZED))
259 if ((PL_op->op_flags & OPf_SPECIAL) &&
260 !(PL_op->op_flags & OPf_MOD))
262 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
264 && (!is_gv_magical_sv(sv, 0)
265 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
271 if (PL_op->op_private & HINT_STRICT_REFS)
272 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
273 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
278 if (PL_op->op_flags & OPf_MOD) {
279 if (PL_op->op_private & OPpLVAL_INTRO) {
280 if (cUNOP->op_first->op_type == OP_NULL)
281 sv = save_scalar((GV*)TOPs);
283 sv = save_scalar(gv);
285 Perl_croak(aTHX_ PL_no_localize_ref);
287 else if (PL_op->op_private & OPpDEREF)
288 vivify_ref(sv, PL_op->op_private & OPpDEREF);
297 AV * const av = (AV*)TOPs;
298 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
301 sv_upgrade(*sv, SVt_PVMG);
302 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
310 dSP; dTARGET; dPOPss;
312 if (PL_op->op_flags & OPf_MOD || LVRET) {
313 if (SvTYPE(TARG) < SVt_PVLV) {
314 sv_upgrade(TARG, SVt_PVLV);
315 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
319 if (LvTARG(TARG) != sv) {
321 SvREFCNT_dec(LvTARG(TARG));
322 LvTARG(TARG) = SvREFCNT_inc(sv);
324 PUSHs(TARG); /* no SvSETMAGIC */
328 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
329 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
330 if (mg && mg->mg_len >= 0) {
334 PUSHi(i + PL_curcop->cop_arybase);
348 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
349 /* (But not in defined().) */
350 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
353 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
354 if ((PL_op->op_private & OPpLVAL_INTRO)) {
355 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
358 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
362 cv = (CV*)&PL_sv_undef;
376 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
377 const char *s = SvPVX_const(TOPs);
378 if (strnEQ(s, "CORE::", 6)) {
379 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
380 if (code < 0) { /* Overridable. */
381 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
382 int i = 0, n = 0, seen_question = 0;
384 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
386 if (code == -KEY_chop || code == -KEY_chomp
387 || code == -KEY_exec || code == -KEY_system)
389 while (i < MAXO) { /* The slow way. */
390 if (strEQ(s + 6, PL_op_name[i])
391 || strEQ(s + 6, PL_op_desc[i]))
397 goto nonesuch; /* Should not happen... */
399 oa = PL_opargs[i] >> OASHIFT;
401 if (oa & OA_OPTIONAL && !seen_question) {
405 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
406 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
407 /* But globs are already references (kinda) */
408 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
412 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
416 ret = sv_2mortal(newSVpvn(str, n - 1));
418 else if (code) /* Non-Overridable */
420 else { /* None such */
422 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
426 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
428 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
437 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
439 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
455 if (GIMME != G_ARRAY) {
459 *MARK = &PL_sv_undef;
460 *MARK = refto(*MARK);
464 EXTEND_MORTAL(SP - MARK);
466 *MARK = refto(*MARK);
471 S_refto(pTHX_ SV *sv)
475 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
478 if (!(sv = LvTARG(sv)))
481 (void)SvREFCNT_inc(sv);
483 else if (SvTYPE(sv) == SVt_PVAV) {
484 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
487 (void)SvREFCNT_inc(sv);
489 else if (SvPADTMP(sv) && !IS_PADGV(sv))
493 (void)SvREFCNT_inc(sv);
496 sv_upgrade(rv, SVt_RV);
506 SV * const sv = POPs;
508 if (sv && SvGMAGICAL(sv))
511 if (!sv || !SvROK(sv))
514 pv = sv_reftype(SvRV(sv),TRUE);
515 PUSHp(pv, strlen(pv));
525 stash = CopSTASH(PL_curcop);
527 SV * const ssv = POPs;
531 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
532 Perl_croak(aTHX_ "Attempt to bless into a reference");
533 ptr = SvPV_const(ssv,len);
534 if (ckWARN(WARN_MISC) && len == 0)
535 Perl_warner(aTHX_ packWARN(WARN_MISC),
536 "Explicit blessing to '' (assuming package main)");
537 stash = gv_stashpvn(ptr, len, TRUE);
540 (void)sv_bless(TOPs, stash);
549 const char * const elem = SvPV_nolen_const(sv);
550 GV * const gv = (GV*)POPs;
551 SV * tmpRef = Nullsv;
555 /* elem will always be NUL terminated. */
556 const char * const second_letter = elem + 1;
559 if (strEQ(second_letter, "RRAY"))
560 tmpRef = (SV*)GvAV(gv);
563 if (strEQ(second_letter, "ODE"))
564 tmpRef = (SV*)GvCVu(gv);
567 if (strEQ(second_letter, "ILEHANDLE")) {
568 /* finally deprecated in 5.8.0 */
569 deprecate("*glob{FILEHANDLE}");
570 tmpRef = (SV*)GvIOp(gv);
573 if (strEQ(second_letter, "ORMAT"))
574 tmpRef = (SV*)GvFORM(gv);
577 if (strEQ(second_letter, "LOB"))
581 if (strEQ(second_letter, "ASH"))
582 tmpRef = (SV*)GvHV(gv);
585 if (*second_letter == 'O' && !elem[2])
586 tmpRef = (SV*)GvIOp(gv);
589 if (strEQ(second_letter, "AME"))
590 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
593 if (strEQ(second_letter, "ACKAGE")) {
594 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
595 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
599 if (strEQ(second_letter, "CALAR"))
614 /* Pattern matching */
619 register unsigned char *s;
622 register I32 *sfirst;
626 if (sv == PL_lastscream) {
632 SvSCREAM_off(PL_lastscream);
633 SvREFCNT_dec(PL_lastscream);
635 PL_lastscream = SvREFCNT_inc(sv);
638 s = (unsigned char*)(SvPV(sv, len));
642 if (pos > PL_maxscream) {
643 if (PL_maxscream < 0) {
644 PL_maxscream = pos + 80;
645 Newx(PL_screamfirst, 256, I32);
646 Newx(PL_screamnext, PL_maxscream, I32);
649 PL_maxscream = pos + pos / 4;
650 Renew(PL_screamnext, PL_maxscream, I32);
654 sfirst = PL_screamfirst;
655 snext = PL_screamnext;
657 if (!sfirst || !snext)
658 DIE(aTHX_ "do_study: out of memory");
660 for (ch = 256; ch; --ch)
665 register const I32 ch = s[pos];
667 snext[pos] = sfirst[ch] - pos;
674 /* piggyback on m//g magic */
675 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
684 if (PL_op->op_flags & OPf_STACKED)
686 else if (PL_op->op_private & OPpTARGET_MY)
692 TARG = sv_newmortal();
697 /* Lvalue operators. */
709 dSP; dMARK; dTARGET; dORIGMARK;
711 do_chop(TARG, *++MARK);
720 SETi(do_chomp(TOPs));
727 register I32 count = 0;
730 count += do_chomp(POPs);
738 register SV* const sv = POPs;
740 if (!sv || !SvANY(sv))
742 switch (SvTYPE(sv)) {
744 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
745 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
749 if (HvARRAY(sv) || SvGMAGICAL(sv)
750 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
754 if (CvROOT(sv) || CvXSUB(sv))
771 if (!PL_op->op_private) {
780 SV_CHECK_THINKFIRST_COW_DROP(sv);
782 switch (SvTYPE(sv)) {
792 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
793 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
794 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
798 /* let user-undef'd sub keep its identity */
799 GV* gv = CvGV((CV*)sv);
806 SvSetMagicSV(sv, &PL_sv_undef);
811 GvGP(sv) = gp_ref(gp);
812 GvSV(sv) = NEWSV(72,0);
813 GvLINE(sv) = CopLINE(PL_curcop);
819 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
821 SvPV_set(sv, Nullch);
834 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
835 DIE(aTHX_ PL_no_modify);
836 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
837 && SvIVX(TOPs) != IV_MIN)
839 SvIV_set(TOPs, SvIVX(TOPs) - 1);
840 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
851 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
852 DIE(aTHX_ PL_no_modify);
853 sv_setsv(TARG, TOPs);
854 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
855 && SvIVX(TOPs) != IV_MAX)
857 SvIV_set(TOPs, SvIVX(TOPs) + 1);
858 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
863 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
873 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
874 DIE(aTHX_ PL_no_modify);
875 sv_setsv(TARG, TOPs);
876 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
877 && SvIVX(TOPs) != IV_MIN)
879 SvIV_set(TOPs, SvIVX(TOPs) - 1);
880 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
889 /* Ordinary operators. */
894 #ifdef PERL_PRESERVE_IVUV
897 tryAMAGICbin(pow,opASSIGN);
898 #ifdef PERL_PRESERVE_IVUV
899 /* For integer to integer power, we do the calculation by hand wherever
900 we're sure it is safe; otherwise we call pow() and try to convert to
901 integer afterwards. */
905 bool baseuok = SvUOK(TOPm1s);
909 baseuv = SvUVX(TOPm1s);
911 const IV iv = SvIVX(TOPm1s);
914 baseuok = TRUE; /* effectively it's a UV now */
916 baseuv = -iv; /* abs, baseuok == false records sign */
930 goto float_it; /* Can't do negative powers this way. */
933 /* now we have integer ** positive integer. */
936 /* foo & (foo - 1) is zero only for a power of 2. */
937 if (!(baseuv & (baseuv - 1))) {
938 /* We are raising power-of-2 to a positive integer.
939 The logic here will work for any base (even non-integer
940 bases) but it can be less accurate than
941 pow (base,power) or exp (power * log (base)) when the
942 intermediate values start to spill out of the mantissa.
943 With powers of 2 we know this can't happen.
944 And powers of 2 are the favourite thing for perl
945 programmers to notice ** not doing what they mean. */
947 NV base = baseuok ? baseuv : -(NV)baseuv;
950 for (; power; base *= base, n++) {
951 /* Do I look like I trust gcc with long longs here?
953 const UV bit = (UV)1 << (UV)n;
956 /* Only bother to clear the bit if it is set. */
958 /* Avoid squaring base again if we're done. */
959 if (power == 0) break;
967 register unsigned int highbit = 8 * sizeof(UV);
968 register unsigned int lowbit = 0;
969 register unsigned int diff;
970 bool odd_power = (bool)(power & 1);
971 while ((diff = (highbit - lowbit) >> 1)) {
972 if (baseuv & ~((1 << (lowbit + diff)) - 1))
977 /* we now have baseuv < 2 ** highbit */
978 if (power * highbit <= 8 * sizeof(UV)) {
979 /* result will definitely fit in UV, so use UV math
980 on same algorithm as above */
981 register UV result = 1;
982 register UV base = baseuv;
984 for (; power; base *= base, n++) {
985 register const UV bit = (UV)1 << (UV)n;
989 if (power == 0) break;
993 if (baseuok || !odd_power)
994 /* answer is positive */
996 else if (result <= (UV)IV_MAX)
997 /* answer negative, fits in IV */
999 else if (result == (UV)IV_MIN)
1000 /* 2's complement assumption: special case IV_MIN */
1003 /* answer negative, doesn't fit */
1004 SETn( -(NV)result );
1015 SETn( Perl_pow( left, right) );
1016 #ifdef PERL_PRESERVE_IVUV
1026 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1027 #ifdef PERL_PRESERVE_IVUV
1030 /* Unless the left argument is integer in range we are going to have to
1031 use NV maths. Hence only attempt to coerce the right argument if
1032 we know the left is integer. */
1033 /* Left operand is defined, so is it IV? */
1034 SvIV_please(TOPm1s);
1035 if (SvIOK(TOPm1s)) {
1036 bool auvok = SvUOK(TOPm1s);
1037 bool buvok = SvUOK(TOPs);
1038 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1039 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1046 alow = SvUVX(TOPm1s);
1048 const IV aiv = SvIVX(TOPm1s);
1051 auvok = TRUE; /* effectively it's a UV now */
1053 alow = -aiv; /* abs, auvok == false records sign */
1059 const IV biv = SvIVX(TOPs);
1062 buvok = TRUE; /* effectively it's a UV now */
1064 blow = -biv; /* abs, buvok == false records sign */
1068 /* If this does sign extension on unsigned it's time for plan B */
1069 ahigh = alow >> (4 * sizeof (UV));
1071 bhigh = blow >> (4 * sizeof (UV));
1073 if (ahigh && bhigh) {
1074 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1075 which is overflow. Drop to NVs below. */
1076 } else if (!ahigh && !bhigh) {
1077 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1078 so the unsigned multiply cannot overflow. */
1079 UV product = alow * blow;
1080 if (auvok == buvok) {
1081 /* -ve * -ve or +ve * +ve gives a +ve result. */
1085 } else if (product <= (UV)IV_MIN) {
1086 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1087 /* -ve result, which could overflow an IV */
1089 SETi( -(IV)product );
1091 } /* else drop to NVs below. */
1093 /* One operand is large, 1 small */
1096 /* swap the operands */
1098 bhigh = blow; /* bhigh now the temp var for the swap */
1102 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1103 multiplies can't overflow. shift can, add can, -ve can. */
1104 product_middle = ahigh * blow;
1105 if (!(product_middle & topmask)) {
1106 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1108 product_middle <<= (4 * sizeof (UV));
1109 product_low = alow * blow;
1111 /* as for pp_add, UV + something mustn't get smaller.
1112 IIRC ANSI mandates this wrapping *behaviour* for
1113 unsigned whatever the actual representation*/
1114 product_low += product_middle;
1115 if (product_low >= product_middle) {
1116 /* didn't overflow */
1117 if (auvok == buvok) {
1118 /* -ve * -ve or +ve * +ve gives a +ve result. */
1120 SETu( product_low );
1122 } else if (product_low <= (UV)IV_MIN) {
1123 /* 2s complement assumption again */
1124 /* -ve result, which could overflow an IV */
1126 SETi( -(IV)product_low );
1128 } /* else drop to NVs below. */
1130 } /* product_middle too large */
1131 } /* ahigh && bhigh */
1132 } /* SvIOK(TOPm1s) */
1137 SETn( left * right );
1144 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1145 /* Only try to do UV divide first
1146 if ((SLOPPYDIVIDE is true) or
1147 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1149 The assumption is that it is better to use floating point divide
1150 whenever possible, only doing integer divide first if we can't be sure.
1151 If NV_PRESERVES_UV is true then we know at compile time that no UV
1152 can be too large to preserve, so don't need to compile the code to
1153 test the size of UVs. */
1156 # define PERL_TRY_UV_DIVIDE
1157 /* ensure that 20./5. == 4. */
1159 # ifdef PERL_PRESERVE_IVUV
1160 # ifndef NV_PRESERVES_UV
1161 # define PERL_TRY_UV_DIVIDE
1166 #ifdef PERL_TRY_UV_DIVIDE
1169 SvIV_please(TOPm1s);
1170 if (SvIOK(TOPm1s)) {
1171 bool left_non_neg = SvUOK(TOPm1s);
1172 bool right_non_neg = SvUOK(TOPs);
1176 if (right_non_neg) {
1177 right = SvUVX(TOPs);
1180 const IV biv = SvIVX(TOPs);
1183 right_non_neg = TRUE; /* effectively it's a UV now */
1189 /* historically undef()/0 gives a "Use of uninitialized value"
1190 warning before dieing, hence this test goes here.
1191 If it were immediately before the second SvIV_please, then
1192 DIE() would be invoked before left was even inspected, so
1193 no inpsection would give no warning. */
1195 DIE(aTHX_ "Illegal division by zero");
1198 left = SvUVX(TOPm1s);
1201 const IV aiv = SvIVX(TOPm1s);
1204 left_non_neg = TRUE; /* effectively it's a UV now */
1213 /* For sloppy divide we always attempt integer division. */
1215 /* Otherwise we only attempt it if either or both operands
1216 would not be preserved by an NV. If both fit in NVs
1217 we fall through to the NV divide code below. However,
1218 as left >= right to ensure integer result here, we know that
1219 we can skip the test on the right operand - right big
1220 enough not to be preserved can't get here unless left is
1223 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1226 /* Integer division can't overflow, but it can be imprecise. */
1227 const UV result = left / right;
1228 if (result * right == left) {
1229 SP--; /* result is valid */
1230 if (left_non_neg == right_non_neg) {
1231 /* signs identical, result is positive. */
1235 /* 2s complement assumption */
1236 if (result <= (UV)IV_MIN)
1237 SETi( -(IV)result );
1239 /* It's exact but too negative for IV. */
1240 SETn( -(NV)result );
1243 } /* tried integer divide but it was not an integer result */
1244 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1245 } /* left wasn't SvIOK */
1246 } /* right wasn't SvIOK */
1247 #endif /* PERL_TRY_UV_DIVIDE */
1251 DIE(aTHX_ "Illegal division by zero");
1252 PUSHn( left / right );
1259 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1263 bool left_neg = FALSE;
1264 bool right_neg = FALSE;
1265 bool use_double = FALSE;
1266 bool dright_valid = FALSE;
1272 right_neg = !SvUOK(TOPs);
1274 right = SvUVX(POPs);
1276 const IV biv = SvIVX(POPs);
1279 right_neg = FALSE; /* effectively it's a UV now */
1287 right_neg = dright < 0;
1290 if (dright < UV_MAX_P1) {
1291 right = U_V(dright);
1292 dright_valid = TRUE; /* In case we need to use double below. */
1298 /* At this point use_double is only true if right is out of range for
1299 a UV. In range NV has been rounded down to nearest UV and
1300 use_double false. */
1302 if (!use_double && SvIOK(TOPs)) {
1304 left_neg = !SvUOK(TOPs);
1308 IV aiv = SvIVX(POPs);
1311 left_neg = FALSE; /* effectively it's a UV now */
1320 left_neg = dleft < 0;
1324 /* This should be exactly the 5.6 behaviour - if left and right are
1325 both in range for UV then use U_V() rather than floor. */
1327 if (dleft < UV_MAX_P1) {
1328 /* right was in range, so is dleft, so use UVs not double.
1332 /* left is out of range for UV, right was in range, so promote
1333 right (back) to double. */
1335 /* The +0.5 is used in 5.6 even though it is not strictly
1336 consistent with the implicit +0 floor in the U_V()
1337 inside the #if 1. */
1338 dleft = Perl_floor(dleft + 0.5);
1341 dright = Perl_floor(dright + 0.5);
1351 DIE(aTHX_ "Illegal modulus zero");
1353 dans = Perl_fmod(dleft, dright);
1354 if ((left_neg != right_neg) && dans)
1355 dans = dright - dans;
1358 sv_setnv(TARG, dans);
1364 DIE(aTHX_ "Illegal modulus zero");
1367 if ((left_neg != right_neg) && ans)
1370 /* XXX may warn: unary minus operator applied to unsigned type */
1371 /* could change -foo to be (~foo)+1 instead */
1372 if (ans <= ~((UV)IV_MAX)+1)
1373 sv_setiv(TARG, ~ans+1);
1375 sv_setnv(TARG, -(NV)ans);
1378 sv_setuv(TARG, ans);
1387 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1395 const UV uv = SvUV(sv);
1397 count = IV_MAX; /* The best we can do? */
1408 else if (SvNOKp(sv)) {
1409 const NV nv = SvNV(sv);
1417 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1419 I32 items = SP - MARK;
1421 static const char oom_list_extend[] =
1422 "Out of memory during list extend";
1424 max = items * count;
1425 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1426 /* Did the max computation overflow? */
1427 if (items > 0 && max > 0 && (max < items || max < count))
1428 Perl_croak(aTHX_ oom_list_extend);
1433 /* This code was intended to fix 20010809.028:
1436 for (($x =~ /./g) x 2) {
1437 print chop; # "abcdabcd" expected as output.
1440 * but that change (#11635) broke this code:
1442 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1444 * I can't think of a better fix that doesn't introduce
1445 * an efficiency hit by copying the SVs. The stack isn't
1446 * refcounted, and mortalisation obviously doesn't
1447 * Do The Right Thing when the stack has more than
1448 * one pointer to the same mortal value.
1452 *SP = sv_2mortal(newSVsv(*SP));
1462 repeatcpy((char*)(MARK + items), (char*)MARK,
1463 items * sizeof(SV*), count - 1);
1466 else if (count <= 0)
1469 else { /* Note: mark already snarfed by pp_list */
1473 static const char oom_string_extend[] =
1474 "Out of memory during string extend";
1476 SvSetSV(TARG, tmpstr);
1477 SvPV_force(TARG, len);
1478 isutf = DO_UTF8(TARG);
1483 STRLEN max = (UV)count * len;
1484 if (len > ((MEM_SIZE)~0)/count)
1485 Perl_croak(aTHX_ oom_string_extend);
1486 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1487 SvGROW(TARG, max + 1);
1488 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1489 SvCUR_set(TARG, SvCUR(TARG) * count);
1491 *SvEND(TARG) = '\0';
1494 (void)SvPOK_only_UTF8(TARG);
1496 (void)SvPOK_only(TARG);
1498 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1499 /* The parser saw this as a list repeat, and there
1500 are probably several items on the stack. But we're
1501 in scalar context, and there's no pp_list to save us
1502 now. So drop the rest of the items -- robin@kitsite.com
1515 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1516 useleft = USE_LEFT(TOPm1s);
1517 #ifdef PERL_PRESERVE_IVUV
1518 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1519 "bad things" happen if you rely on signed integers wrapping. */
1522 /* Unless the left argument is integer in range we are going to have to
1523 use NV maths. Hence only attempt to coerce the right argument if
1524 we know the left is integer. */
1525 register UV auv = 0;
1531 a_valid = auvok = 1;
1532 /* left operand is undef, treat as zero. */
1534 /* Left operand is defined, so is it IV? */
1535 SvIV_please(TOPm1s);
1536 if (SvIOK(TOPm1s)) {
1537 if ((auvok = SvUOK(TOPm1s)))
1538 auv = SvUVX(TOPm1s);
1540 register const IV aiv = SvIVX(TOPm1s);
1543 auvok = 1; /* Now acting as a sign flag. */
1544 } else { /* 2s complement assumption for IV_MIN */
1552 bool result_good = 0;
1555 bool buvok = SvUOK(TOPs);
1560 register const IV biv = SvIVX(TOPs);
1567 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1568 else "IV" now, independent of how it came in.
1569 if a, b represents positive, A, B negative, a maps to -A etc
1574 all UV maths. negate result if A negative.
1575 subtract if signs same, add if signs differ. */
1577 if (auvok ^ buvok) {
1586 /* Must get smaller */
1591 if (result <= buv) {
1592 /* result really should be -(auv-buv). as its negation
1593 of true value, need to swap our result flag */
1605 if (result <= (UV)IV_MIN)
1606 SETi( -(IV)result );
1608 /* result valid, but out of range for IV. */
1609 SETn( -(NV)result );
1613 } /* Overflow, drop through to NVs. */
1617 useleft = USE_LEFT(TOPm1s);
1621 /* left operand is undef, treat as zero - value */
1625 SETn( TOPn - value );
1632 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1634 const IV shift = POPi;
1635 if (PL_op->op_private & HINT_INTEGER) {
1649 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1651 const IV shift = POPi;
1652 if (PL_op->op_private & HINT_INTEGER) {
1666 dSP; tryAMAGICbinSET(lt,0);
1667 #ifdef PERL_PRESERVE_IVUV
1670 SvIV_please(TOPm1s);
1671 if (SvIOK(TOPm1s)) {
1672 bool auvok = SvUOK(TOPm1s);
1673 bool buvok = SvUOK(TOPs);
1675 if (!auvok && !buvok) { /* ## IV < IV ## */
1676 const IV aiv = SvIVX(TOPm1s);
1677 const IV biv = SvIVX(TOPs);
1680 SETs(boolSV(aiv < biv));
1683 if (auvok && buvok) { /* ## UV < UV ## */
1684 const UV auv = SvUVX(TOPm1s);
1685 const UV buv = SvUVX(TOPs);
1688 SETs(boolSV(auv < buv));
1691 if (auvok) { /* ## UV < IV ## */
1693 const IV biv = SvIVX(TOPs);
1696 /* As (a) is a UV, it's >=0, so it cannot be < */
1701 SETs(boolSV(auv < (UV)biv));
1704 { /* ## IV < UV ## */
1705 const IV aiv = SvIVX(TOPm1s);
1709 /* As (b) is a UV, it's >=0, so it must be < */
1716 SETs(boolSV((UV)aiv < buv));
1722 #ifndef NV_PRESERVES_UV
1723 #ifdef PERL_PRESERVE_IVUV
1726 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1728 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1734 SETs(boolSV(TOPn < value));
1741 dSP; tryAMAGICbinSET(gt,0);
1742 #ifdef PERL_PRESERVE_IVUV
1745 SvIV_please(TOPm1s);
1746 if (SvIOK(TOPm1s)) {
1747 bool auvok = SvUOK(TOPm1s);
1748 bool buvok = SvUOK(TOPs);
1750 if (!auvok && !buvok) { /* ## IV > IV ## */
1751 const IV aiv = SvIVX(TOPm1s);
1752 const IV biv = SvIVX(TOPs);
1755 SETs(boolSV(aiv > biv));
1758 if (auvok && buvok) { /* ## UV > UV ## */
1759 const UV auv = SvUVX(TOPm1s);
1760 const UV buv = SvUVX(TOPs);
1763 SETs(boolSV(auv > buv));
1766 if (auvok) { /* ## UV > IV ## */
1768 const IV biv = SvIVX(TOPs);
1772 /* As (a) is a UV, it's >=0, so it must be > */
1777 SETs(boolSV(auv > (UV)biv));
1780 { /* ## IV > UV ## */
1781 const IV aiv = SvIVX(TOPm1s);
1785 /* As (b) is a UV, it's >=0, so it cannot be > */
1792 SETs(boolSV((UV)aiv > buv));
1798 #ifndef NV_PRESERVES_UV
1799 #ifdef PERL_PRESERVE_IVUV
1802 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1804 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1810 SETs(boolSV(TOPn > value));
1817 dSP; tryAMAGICbinSET(le,0);
1818 #ifdef PERL_PRESERVE_IVUV
1821 SvIV_please(TOPm1s);
1822 if (SvIOK(TOPm1s)) {
1823 bool auvok = SvUOK(TOPm1s);
1824 bool buvok = SvUOK(TOPs);
1826 if (!auvok && !buvok) { /* ## IV <= IV ## */
1827 const IV aiv = SvIVX(TOPm1s);
1828 const IV biv = SvIVX(TOPs);
1831 SETs(boolSV(aiv <= biv));
1834 if (auvok && buvok) { /* ## UV <= UV ## */
1835 UV auv = SvUVX(TOPm1s);
1836 UV buv = SvUVX(TOPs);
1839 SETs(boolSV(auv <= buv));
1842 if (auvok) { /* ## UV <= IV ## */
1844 const IV biv = SvIVX(TOPs);
1848 /* As (a) is a UV, it's >=0, so a cannot be <= */
1853 SETs(boolSV(auv <= (UV)biv));
1856 { /* ## IV <= UV ## */
1857 const IV aiv = SvIVX(TOPm1s);
1861 /* As (b) is a UV, it's >=0, so a must be <= */
1868 SETs(boolSV((UV)aiv <= buv));
1874 #ifndef NV_PRESERVES_UV
1875 #ifdef PERL_PRESERVE_IVUV
1878 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1880 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1886 SETs(boolSV(TOPn <= value));
1893 dSP; tryAMAGICbinSET(ge,0);
1894 #ifdef PERL_PRESERVE_IVUV
1897 SvIV_please(TOPm1s);
1898 if (SvIOK(TOPm1s)) {
1899 bool auvok = SvUOK(TOPm1s);
1900 bool buvok = SvUOK(TOPs);
1902 if (!auvok && !buvok) { /* ## IV >= IV ## */
1903 const IV aiv = SvIVX(TOPm1s);
1904 const IV biv = SvIVX(TOPs);
1907 SETs(boolSV(aiv >= biv));
1910 if (auvok && buvok) { /* ## UV >= UV ## */
1911 const UV auv = SvUVX(TOPm1s);
1912 const UV buv = SvUVX(TOPs);
1915 SETs(boolSV(auv >= buv));
1918 if (auvok) { /* ## UV >= IV ## */
1920 const IV biv = SvIVX(TOPs);
1924 /* As (a) is a UV, it's >=0, so it must be >= */
1929 SETs(boolSV(auv >= (UV)biv));
1932 { /* ## IV >= UV ## */
1933 const IV aiv = SvIVX(TOPm1s);
1937 /* As (b) is a UV, it's >=0, so a cannot be >= */
1944 SETs(boolSV((UV)aiv >= buv));
1950 #ifndef NV_PRESERVES_UV
1951 #ifdef PERL_PRESERVE_IVUV
1954 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1956 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1962 SETs(boolSV(TOPn >= value));
1969 dSP; tryAMAGICbinSET(ne,0);
1970 #ifndef NV_PRESERVES_UV
1971 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1973 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1977 #ifdef PERL_PRESERVE_IVUV
1980 SvIV_please(TOPm1s);
1981 if (SvIOK(TOPm1s)) {
1982 bool auvok = SvUOK(TOPm1s);
1983 bool buvok = SvUOK(TOPs);
1985 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1986 /* Casting IV to UV before comparison isn't going to matter
1987 on 2s complement. On 1s complement or sign&magnitude
1988 (if we have any of them) it could make negative zero
1989 differ from normal zero. As I understand it. (Need to
1990 check - is negative zero implementation defined behaviour
1992 const UV buv = SvUVX(POPs);
1993 const UV auv = SvUVX(TOPs);
1995 SETs(boolSV(auv != buv));
1998 { /* ## Mixed IV,UV ## */
2002 /* != is commutative so swap if needed (save code) */
2004 /* swap. top of stack (b) is the iv */
2008 /* As (a) is a UV, it's >0, so it cannot be == */
2017 /* As (b) is a UV, it's >0, so it cannot be == */
2021 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2023 SETs(boolSV((UV)iv != uv));
2031 SETs(boolSV(TOPn != value));
2038 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2039 #ifndef NV_PRESERVES_UV
2040 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2041 UV right = PTR2UV(SvRV(POPs));
2042 UV left = PTR2UV(SvRV(TOPs));
2043 SETi((left > right) - (left < right));
2047 #ifdef PERL_PRESERVE_IVUV
2048 /* Fortunately it seems NaN isn't IOK */
2051 SvIV_please(TOPm1s);
2052 if (SvIOK(TOPm1s)) {
2053 const bool leftuvok = SvUOK(TOPm1s);
2054 const bool rightuvok = SvUOK(TOPs);
2056 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2057 const IV leftiv = SvIVX(TOPm1s);
2058 const IV rightiv = SvIVX(TOPs);
2060 if (leftiv > rightiv)
2062 else if (leftiv < rightiv)
2066 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2067 const UV leftuv = SvUVX(TOPm1s);
2068 const UV rightuv = SvUVX(TOPs);
2070 if (leftuv > rightuv)
2072 else if (leftuv < rightuv)
2076 } else if (leftuvok) { /* ## UV <=> IV ## */
2077 const IV rightiv = SvIVX(TOPs);
2079 /* As (a) is a UV, it's >=0, so it cannot be < */
2082 const UV leftuv = SvUVX(TOPm1s);
2083 if (leftuv > (UV)rightiv) {
2085 } else if (leftuv < (UV)rightiv) {
2091 } else { /* ## IV <=> UV ## */
2092 const IV leftiv = SvIVX(TOPm1s);
2094 /* As (b) is a UV, it's >=0, so it must be < */
2097 const UV rightuv = SvUVX(TOPs);
2098 if ((UV)leftiv > rightuv) {
2100 } else if ((UV)leftiv < rightuv) {
2118 if (Perl_isnan(left) || Perl_isnan(right)) {
2122 value = (left > right) - (left < right);
2126 else if (left < right)
2128 else if (left > right)
2142 dSP; tryAMAGICbinSET(slt,0);
2145 const int cmp = (IN_LOCALE_RUNTIME
2146 ? sv_cmp_locale(left, right)
2147 : sv_cmp(left, right));
2148 SETs(boolSV(cmp < 0));
2155 dSP; tryAMAGICbinSET(sgt,0);
2158 const int cmp = (IN_LOCALE_RUNTIME
2159 ? sv_cmp_locale(left, right)
2160 : sv_cmp(left, right));
2161 SETs(boolSV(cmp > 0));
2168 dSP; tryAMAGICbinSET(sle,0);
2171 const int cmp = (IN_LOCALE_RUNTIME
2172 ? sv_cmp_locale(left, right)
2173 : sv_cmp(left, right));
2174 SETs(boolSV(cmp <= 0));
2181 dSP; tryAMAGICbinSET(sge,0);
2184 const int cmp = (IN_LOCALE_RUNTIME
2185 ? sv_cmp_locale(left, right)
2186 : sv_cmp(left, right));
2187 SETs(boolSV(cmp >= 0));
2194 dSP; tryAMAGICbinSET(seq,0);
2197 SETs(boolSV(sv_eq(left, right)));
2204 dSP; tryAMAGICbinSET(sne,0);
2207 SETs(boolSV(!sv_eq(left, right)));
2214 dSP; dTARGET; tryAMAGICbin(scmp,0);
2217 const int cmp = (IN_LOCALE_RUNTIME
2218 ? sv_cmp_locale(left, right)
2219 : sv_cmp(left, right));
2227 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2230 if (SvGMAGICAL(left)) mg_get(left);
2231 if (SvGMAGICAL(right)) mg_get(right);
2232 if (SvNIOKp(left) || SvNIOKp(right)) {
2233 if (PL_op->op_private & HINT_INTEGER) {
2234 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2238 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2243 do_vop(PL_op->op_type, TARG, left, right);
2252 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2255 if (SvGMAGICAL(left)) mg_get(left);
2256 if (SvGMAGICAL(right)) mg_get(right);
2257 if (SvNIOKp(left) || SvNIOKp(right)) {
2258 if (PL_op->op_private & HINT_INTEGER) {
2259 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2263 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2268 do_vop(PL_op->op_type, TARG, left, right);
2277 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2280 if (SvGMAGICAL(left)) mg_get(left);
2281 if (SvGMAGICAL(right)) mg_get(right);
2282 if (SvNIOKp(left) || SvNIOKp(right)) {
2283 if (PL_op->op_private & HINT_INTEGER) {
2284 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2288 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2293 do_vop(PL_op->op_type, TARG, left, right);
2302 dSP; dTARGET; tryAMAGICun(neg);
2305 const int flags = SvFLAGS(sv);
2308 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2309 /* It's publicly an integer, or privately an integer-not-float */
2312 if (SvIVX(sv) == IV_MIN) {
2313 /* 2s complement assumption. */
2314 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2317 else if (SvUVX(sv) <= IV_MAX) {
2322 else if (SvIVX(sv) != IV_MIN) {
2326 #ifdef PERL_PRESERVE_IVUV
2335 else if (SvPOKp(sv)) {
2337 const char *s = SvPV_const(sv, len);
2338 if (isIDFIRST(*s)) {
2339 sv_setpvn(TARG, "-", 1);
2342 else if (*s == '+' || *s == '-') {
2344 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2346 else if (DO_UTF8(sv)) {
2349 goto oops_its_an_int;
2351 sv_setnv(TARG, -SvNV(sv));
2353 sv_setpvn(TARG, "-", 1);
2360 goto oops_its_an_int;
2361 sv_setnv(TARG, -SvNV(sv));
2373 dSP; tryAMAGICunSET(not);
2374 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2380 dSP; dTARGET; tryAMAGICun(compl);
2386 if (PL_op->op_private & HINT_INTEGER) {
2387 const IV i = ~SvIV_nomg(sv);
2391 const UV u = ~SvUV_nomg(sv);
2400 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2401 sv_setsv_nomg(TARG, sv);
2402 tmps = (U8*)SvPV_force(TARG, len);
2405 /* Calculate exact length, let's not estimate. */
2414 while (tmps < send) {
2415 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2416 tmps += UTF8SKIP(tmps);
2417 targlen += UNISKIP(~c);
2423 /* Now rewind strings and write them. */
2427 Newxz(result, targlen + 1, U8);
2428 while (tmps < send) {
2429 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2430 tmps += UTF8SKIP(tmps);
2431 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2435 sv_setpvn(TARG, (char*)result, targlen);
2439 Newxz(result, nchar + 1, U8);
2440 while (tmps < send) {
2441 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2442 tmps += UTF8SKIP(tmps);
2447 sv_setpvn(TARG, (char*)result, nchar);
2456 register long *tmpl;
2457 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2460 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2465 for ( ; anum > 0; anum--, tmps++)
2474 /* integer versions of some of the above */
2478 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2481 SETi( left * right );
2488 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2492 DIE(aTHX_ "Illegal division by zero");
2493 value = POPi / value;
2502 /* This is the vanilla old i_modulo. */
2503 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2507 DIE(aTHX_ "Illegal modulus zero");
2508 SETi( left % right );
2513 #if defined(__GLIBC__) && IVSIZE == 8
2517 /* This is the i_modulo with the workaround for the _moddi3 bug
2518 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2519 * See below for pp_i_modulo. */
2520 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2524 DIE(aTHX_ "Illegal modulus zero");
2525 SETi( left % PERL_ABS(right) );
2533 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2537 DIE(aTHX_ "Illegal modulus zero");
2538 /* The assumption is to use hereafter the old vanilla version... */
2540 PL_ppaddr[OP_I_MODULO] =
2542 /* .. but if we have glibc, we might have a buggy _moddi3
2543 * (at least glicb 2.2.5 is known to have this bug), in other
2544 * words our integer modulus with negative quad as the second
2545 * argument might be broken. Test for this and re-patch the
2546 * opcode dispatch table if that is the case, remembering to
2547 * also apply the workaround so that this first round works
2548 * right, too. See [perl #9402] for more information. */
2549 #if defined(__GLIBC__) && IVSIZE == 8
2553 /* Cannot do this check with inlined IV constants since
2554 * that seems to work correctly even with the buggy glibc. */
2556 /* Yikes, we have the bug.
2557 * Patch in the workaround version. */
2559 PL_ppaddr[OP_I_MODULO] =
2560 &Perl_pp_i_modulo_1;
2561 /* Make certain we work right this time, too. */
2562 right = PERL_ABS(right);
2566 SETi( left % right );
2573 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2576 SETi( left + right );
2583 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2586 SETi( left - right );
2593 dSP; tryAMAGICbinSET(lt,0);
2596 SETs(boolSV(left < right));
2603 dSP; tryAMAGICbinSET(gt,0);
2606 SETs(boolSV(left > right));
2613 dSP; tryAMAGICbinSET(le,0);
2616 SETs(boolSV(left <= right));
2623 dSP; tryAMAGICbinSET(ge,0);
2626 SETs(boolSV(left >= right));
2633 dSP; tryAMAGICbinSET(eq,0);
2636 SETs(boolSV(left == right));
2643 dSP; tryAMAGICbinSET(ne,0);
2646 SETs(boolSV(left != right));
2653 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2660 else if (left < right)
2671 dSP; dTARGET; tryAMAGICun(neg);
2676 /* High falutin' math. */
2680 dSP; dTARGET; tryAMAGICbin(atan2,0);
2683 SETn(Perl_atan2(left, right));
2690 dSP; dTARGET; tryAMAGICun(sin);
2692 const NV value = POPn;
2693 XPUSHn(Perl_sin(value));
2700 dSP; dTARGET; tryAMAGICun(cos);
2702 const NV value = POPn;
2703 XPUSHn(Perl_cos(value));
2708 /* Support Configure command-line overrides for rand() functions.
2709 After 5.005, perhaps we should replace this by Configure support
2710 for drand48(), random(), or rand(). For 5.005, though, maintain
2711 compatibility by calling rand() but allow the user to override it.
2712 See INSTALL for details. --Andy Dougherty 15 July 1998
2714 /* Now it's after 5.005, and Configure supports drand48() and random(),
2715 in addition to rand(). So the overrides should not be needed any more.
2716 --Jarkko Hietaniemi 27 September 1998
2719 #ifndef HAS_DRAND48_PROTO
2720 extern double drand48 (void);
2733 if (!PL_srand_called) {
2734 (void)seedDrand01((Rand_seed_t)seed());
2735 PL_srand_called = TRUE;
2750 (void)seedDrand01((Rand_seed_t)anum);
2751 PL_srand_called = TRUE;
2758 dSP; dTARGET; tryAMAGICun(exp);
2762 value = Perl_exp(value);
2770 dSP; dTARGET; tryAMAGICun(log);
2772 const NV value = POPn;
2774 SET_NUMERIC_STANDARD();
2775 DIE(aTHX_ "Can't take log of %"NVgf, value);
2777 XPUSHn(Perl_log(value));
2784 dSP; dTARGET; tryAMAGICun(sqrt);
2786 const NV value = POPn;
2788 SET_NUMERIC_STANDARD();
2789 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2791 XPUSHn(Perl_sqrt(value));
2798 dSP; dTARGET; tryAMAGICun(int);
2800 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2801 /* XXX it's arguable that compiler casting to IV might be subtly
2802 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2803 else preferring IV has introduced a subtle behaviour change bug. OTOH
2804 relying on floating point to be accurate is a bug. */
2808 else if (SvIOK(TOPs)) {
2815 const NV value = TOPn;
2817 if (value < (NV)UV_MAX + 0.5) {
2820 SETn(Perl_floor(value));
2824 if (value > (NV)IV_MIN - 0.5) {
2827 SETn(Perl_ceil(value));
2837 dSP; dTARGET; tryAMAGICun(abs);
2839 /* This will cache the NV value if string isn't actually integer */
2844 else if (SvIOK(TOPs)) {
2845 /* IVX is precise */
2847 SETu(TOPu); /* force it to be numeric only */
2855 /* 2s complement assumption. Also, not really needed as
2856 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2862 const NV value = TOPn;
2877 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2881 SV* const sv = POPs;
2883 tmps = (SvPV_const(sv, len));
2885 /* If Unicode, try to downgrade
2886 * If not possible, croak. */
2887 SV* const tsv = sv_2mortal(newSVsv(sv));
2890 sv_utf8_downgrade(tsv, FALSE);
2891 tmps = SvPV_const(tsv, len);
2893 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2894 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2907 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2911 SV* const sv = POPs;
2913 tmps = (SvPV_const(sv, len));
2915 /* If Unicode, try to downgrade
2916 * If not possible, croak. */
2917 SV* const tsv = sv_2mortal(newSVsv(sv));
2920 sv_utf8_downgrade(tsv, FALSE);
2921 tmps = SvPV_const(tsv, len);
2923 while (*tmps && len && isSPACE(*tmps))
2928 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2929 else if (*tmps == 'b')
2930 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2932 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2934 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2951 SETi(sv_len_utf8(sv));
2967 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2969 const I32 arybase = PL_curcop->cop_arybase;
2971 const char *repl = 0;
2973 const int num_args = PL_op->op_private & 7;
2974 bool repl_need_utf8_upgrade = FALSE;
2975 bool repl_is_utf8 = FALSE;
2977 SvTAINTED_off(TARG); /* decontaminate */
2978 SvUTF8_off(TARG); /* decontaminate */
2982 repl = SvPV_const(repl_sv, repl_len);
2983 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2993 sv_utf8_upgrade(sv);
2995 else if (DO_UTF8(sv))
2996 repl_need_utf8_upgrade = TRUE;
2998 tmps = SvPV_const(sv, curlen);
3000 utf8_curlen = sv_len_utf8(sv);
3001 if (utf8_curlen == curlen)
3004 curlen = utf8_curlen;
3009 if (pos >= arybase) {
3027 else if (len >= 0) {
3029 if (rem > (I32)curlen)
3044 Perl_croak(aTHX_ "substr outside of string");
3045 if (ckWARN(WARN_SUBSTR))
3046 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3050 const I32 upos = pos;
3051 const I32 urem = rem;
3053 sv_pos_u2b(sv, &pos, &rem);
3055 /* we either return a PV or an LV. If the TARG hasn't been used
3056 * before, or is of that type, reuse it; otherwise use a mortal
3057 * instead. Note that LVs can have an extended lifetime, so also
3058 * dont reuse if refcount > 1 (bug #20933) */
3059 if (SvTYPE(TARG) > SVt_NULL) {
3060 if ( (SvTYPE(TARG) == SVt_PVLV)
3061 ? (!lvalue || SvREFCNT(TARG) > 1)
3064 TARG = sv_newmortal();
3068 sv_setpvn(TARG, tmps, rem);
3069 #ifdef USE_LOCALE_COLLATE
3070 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3075 SV* repl_sv_copy = NULL;
3077 if (repl_need_utf8_upgrade) {
3078 repl_sv_copy = newSVsv(repl_sv);
3079 sv_utf8_upgrade(repl_sv_copy);
3080 repl = SvPV_const(repl_sv_copy, repl_len);
3081 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3083 sv_insert(sv, pos, rem, repl, repl_len);
3087 SvREFCNT_dec(repl_sv_copy);
3089 else if (lvalue) { /* it's an lvalue! */
3090 if (!SvGMAGICAL(sv)) {
3092 SvPV_force_nolen(sv);
3093 if (ckWARN(WARN_SUBSTR))
3094 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3095 "Attempt to use reference as lvalue in substr");
3097 if (SvOK(sv)) /* is it defined ? */
3098 (void)SvPOK_only_UTF8(sv);
3100 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3103 if (SvTYPE(TARG) < SVt_PVLV) {
3104 sv_upgrade(TARG, SVt_PVLV);
3105 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3111 if (LvTARG(TARG) != sv) {
3113 SvREFCNT_dec(LvTARG(TARG));
3114 LvTARG(TARG) = SvREFCNT_inc(sv);
3116 LvTARGOFF(TARG) = upos;
3117 LvTARGLEN(TARG) = urem;
3121 PUSHs(TARG); /* avoid SvSETMAGIC here */
3128 register const IV size = POPi;
3129 register const IV offset = POPi;
3130 register SV * const src = POPs;
3131 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3133 SvTAINTED_off(TARG); /* decontaminate */
3134 if (lvalue) { /* it's an lvalue! */
3135 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3136 TARG = sv_newmortal();
3137 if (SvTYPE(TARG) < SVt_PVLV) {
3138 sv_upgrade(TARG, SVt_PVLV);
3139 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3142 if (LvTARG(TARG) != src) {
3144 SvREFCNT_dec(LvTARG(TARG));
3145 LvTARG(TARG) = SvREFCNT_inc(src);
3147 LvTARGOFF(TARG) = offset;
3148 LvTARGLEN(TARG) = size;
3151 sv_setuv(TARG, do_vecget(src, offset, size));
3167 const I32 arybase = PL_curcop->cop_arybase;
3174 offset = POPi - arybase;
3177 big_utf8 = DO_UTF8(big);
3178 little_utf8 = DO_UTF8(little);
3179 if (big_utf8 ^ little_utf8) {
3180 /* One needs to be upgraded. */
3181 SV * const bytes = little_utf8 ? big : little;
3183 const char * const p = SvPV_const(bytes, len);
3185 temp = newSVpvn(p, len);
3188 sv_recode_to_utf8(temp, PL_encoding);
3190 sv_utf8_upgrade(temp);
3199 if (big_utf8 && offset > 0)
3200 sv_pos_u2b(big, &offset, 0);
3201 tmps = SvPV_const(big, biglen);
3204 else if (offset > (I32)biglen)
3206 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3207 (unsigned char*)tmps + biglen, little, 0)))
3210 retval = tmps2 - tmps;
3211 if (retval > 0 && big_utf8)
3212 sv_pos_b2u(big, &retval);
3215 PUSHi(retval + arybase);
3231 const I32 arybase = PL_curcop->cop_arybase;
3239 big_utf8 = DO_UTF8(big);
3240 little_utf8 = DO_UTF8(little);
3241 if (big_utf8 ^ little_utf8) {
3242 /* One needs to be upgraded. */
3243 SV * const bytes = little_utf8 ? big : little;
3245 const char *p = SvPV_const(bytes, len);
3247 temp = newSVpvn(p, len);
3250 sv_recode_to_utf8(temp, PL_encoding);
3252 sv_utf8_upgrade(temp);
3261 tmps2 = SvPV_const(little, llen);
3262 tmps = SvPV_const(big, blen);
3267 if (offset > 0 && big_utf8)
3268 sv_pos_u2b(big, &offset, 0);
3269 offset = offset - arybase + llen;
3273 else if (offset > (I32)blen)
3275 if (!(tmps2 = rninstr(tmps, tmps + offset,
3276 tmps2, tmps2 + llen)))
3279 retval = tmps2 - tmps;
3280 if (retval > 0 && big_utf8)
3281 sv_pos_b2u(big, &retval);
3284 PUSHi(retval + arybase);
3290 dSP; dMARK; dORIGMARK; dTARGET;
3291 do_sprintf(TARG, SP-MARK, MARK+1);
3292 TAINT_IF(SvTAINTED(TARG));
3293 if (DO_UTF8(*(MARK+1)))
3305 const U8 *s = (U8*)SvPV_const(argsv, len);
3308 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3309 tmpsv = sv_2mortal(newSVsv(argsv));
3310 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3314 XPUSHu(DO_UTF8(argsv) ?
3315 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3327 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3329 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3331 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3333 (void) POPs; /* Ignore the argument value. */
3334 value = UNICODE_REPLACEMENT;
3340 SvUPGRADE(TARG,SVt_PV);
3342 if (value > 255 && !IN_BYTES) {
3343 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3344 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3345 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3347 (void)SvPOK_only(TARG);
3356 *tmps++ = (char)value;
3358 (void)SvPOK_only(TARG);
3359 if (PL_encoding && !IN_BYTES) {
3360 sv_recode_to_utf8(TARG, PL_encoding);
3362 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3363 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3367 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3368 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3383 const char *tmps = SvPV_const(left, len);
3385 if (DO_UTF8(left)) {
3386 /* If Unicode, try to downgrade.
3387 * If not possible, croak.
3388 * Yes, we made this up. */
3389 SV* const tsv = sv_2mortal(newSVsv(left));
3392 sv_utf8_downgrade(tsv, FALSE);
3393 tmps = SvPV_const(tsv, len);
3395 # ifdef USE_ITHREADS
3397 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3398 /* This should be threadsafe because in ithreads there is only
3399 * one thread per interpreter. If this would not be true,
3400 * we would need a mutex to protect this malloc. */
3401 PL_reentrant_buffer->_crypt_struct_buffer =
3402 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3403 #if defined(__GLIBC__) || defined(__EMX__)
3404 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3405 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3406 /* work around glibc-2.2.5 bug */
3407 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3411 # endif /* HAS_CRYPT_R */
3412 # endif /* USE_ITHREADS */
3414 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3416 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3422 "The crypt() function is unimplemented due to excessive paranoia.");
3435 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3436 UTF8_IS_START(*s)) {
3437 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3441 utf8_to_uvchr(s, &ulen);
3442 toTITLE_utf8(s, tmpbuf, &tculen);
3443 utf8_to_uvchr(tmpbuf, 0);
3445 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3447 /* slen is the byte length of the whole SV.
3448 * ulen is the byte length of the original Unicode character
3449 * stored as UTF-8 at s.
3450 * tculen is the byte length of the freshly titlecased
3451 * Unicode character stored as UTF-8 at tmpbuf.
3452 * We first set the result to be the titlecased character,
3453 * and then append the rest of the SV data. */
3454 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3456 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3461 s = (U8*)SvPV_force_nomg(sv, slen);
3462 Copy(tmpbuf, s, tculen, U8);
3467 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3469 SvUTF8_off(TARG); /* decontaminate */
3470 sv_setsv_nomg(TARG, sv);
3474 s1 = (U8*)SvPV_force_nomg(sv, slen);
3476 if (IN_LOCALE_RUNTIME) {
3479 *s1 = toUPPER_LC(*s1);
3498 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3499 UTF8_IS_START(*s)) {
3501 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3505 toLOWER_utf8(s, tmpbuf, &ulen);
3506 uv = utf8_to_uvchr(tmpbuf, 0);
3507 tend = uvchr_to_utf8(tmpbuf, uv);
3509 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3511 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3513 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3518 s = (U8*)SvPV_force_nomg(sv, slen);
3519 Copy(tmpbuf, s, ulen, U8);
3524 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3526 SvUTF8_off(TARG); /* decontaminate */
3527 sv_setsv_nomg(TARG, sv);
3531 s1 = (U8*)SvPV_force_nomg(sv, slen);
3533 if (IN_LOCALE_RUNTIME) {
3536 *s1 = toLOWER_LC(*s1);
3559 U8 tmpbuf[UTF8_MAXBYTES+1];
3561 s = (const U8*)SvPV_nomg_const(sv,len);
3563 SvUTF8_off(TARG); /* decontaminate */
3564 sv_setpvn(TARG, "", 0);
3568 STRLEN min = len + 1;
3570 SvUPGRADE(TARG, SVt_PV);
3572 (void)SvPOK_only(TARG);
3573 d = (U8*)SvPVX(TARG);
3576 STRLEN u = UTF8SKIP(s);
3578 toUPPER_utf8(s, tmpbuf, &ulen);
3579 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3580 /* If the eventually required minimum size outgrows
3581 * the available space, we need to grow. */
3582 UV o = d - (U8*)SvPVX_const(TARG);
3584 /* If someone uppercases one million U+03B0s we
3585 * SvGROW() one million times. Or we could try
3586 * guessing how much to allocate without allocating
3587 * too much. Such is life. */
3589 d = (U8*)SvPVX(TARG) + o;
3591 Copy(tmpbuf, d, ulen, U8);
3597 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3603 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3605 SvUTF8_off(TARG); /* decontaminate */
3606 sv_setsv_nomg(TARG, sv);
3610 s = (U8*)SvPV_force_nomg(sv, len);
3612 const register U8 *send = s + len;
3614 if (IN_LOCALE_RUNTIME) {
3617 for (; s < send; s++)
3618 *s = toUPPER_LC(*s);
3621 for (; s < send; s++)
3643 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3645 s = (const U8*)SvPV_nomg_const(sv,len);
3647 SvUTF8_off(TARG); /* decontaminate */
3648 sv_setpvn(TARG, "", 0);
3652 STRLEN min = len + 1;
3654 SvUPGRADE(TARG, SVt_PV);
3656 (void)SvPOK_only(TARG);
3657 d = (U8*)SvPVX(TARG);
3660 const STRLEN u = UTF8SKIP(s);
3661 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3663 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3664 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3666 * Now if the sigma is NOT followed by
3667 * /$ignorable_sequence$cased_letter/;
3668 * and it IS preceded by
3669 * /$cased_letter$ignorable_sequence/;
3670 * where $ignorable_sequence is
3671 * [\x{2010}\x{AD}\p{Mn}]*
3672 * and $cased_letter is
3673 * [\p{Ll}\p{Lo}\p{Lt}]
3674 * then it should be mapped to 0x03C2,
3675 * (GREEK SMALL LETTER FINAL SIGMA),
3676 * instead of staying 0x03A3.
3677 * "should be": in other words,
3678 * this is not implemented yet.
3679 * See lib/unicore/SpecialCasing.txt.
3682 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3683 /* If the eventually required minimum size outgrows
3684 * the available space, we need to grow. */
3685 UV o = d - (U8*)SvPVX_const(TARG);
3687 /* If someone lowercases one million U+0130s we
3688 * SvGROW() one million times. Or we could try
3689 * guessing how much to allocate without allocating.
3690 * too much. Such is life. */
3692 d = (U8*)SvPVX(TARG) + o;
3694 Copy(tmpbuf, d, ulen, U8);
3700 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3706 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3708 SvUTF8_off(TARG); /* decontaminate */
3709 sv_setsv_nomg(TARG, sv);
3714 s = (U8*)SvPV_force_nomg(sv, len);
3716 register const U8 * const send = s + len;
3718 if (IN_LOCALE_RUNTIME) {
3721 for (; s < send; s++)
3722 *s = toLOWER_LC(*s);
3725 for (; s < send; s++)
3737 SV * const sv = TOPs;
3739 const register char *s = SvPV_const(sv,len);
3741 SvUTF8_off(TARG); /* decontaminate */
3744 SvUPGRADE(TARG, SVt_PV);
3745 SvGROW(TARG, (len * 2) + 1);
3749 if (UTF8_IS_CONTINUED(*s)) {
3750 STRLEN ulen = UTF8SKIP(s);
3774 SvCUR_set(TARG, d - SvPVX_const(TARG));
3775 (void)SvPOK_only_UTF8(TARG);
3778 sv_setpvn(TARG, s, len);
3780 if (SvSMAGICAL(TARG))
3789 dSP; dMARK; dORIGMARK;
3790 register AV* const av = (AV*)POPs;
3791 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3793 if (SvTYPE(av) == SVt_PVAV) {
3794 const I32 arybase = PL_curcop->cop_arybase;
3795 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3798 for (svp = MARK + 1; svp <= SP; svp++) {
3799 const I32 elem = SvIVx(*svp);
3803 if (max > AvMAX(av))
3806 while (++MARK <= SP) {
3808 I32 elem = SvIVx(*MARK);
3812 svp = av_fetch(av, elem, lval);
3814 if (!svp || *svp == &PL_sv_undef)
3815 DIE(aTHX_ PL_no_aelem, elem);
3816 if (PL_op->op_private & OPpLVAL_INTRO)
3817 save_aelem(av, elem, svp);
3819 *MARK = svp ? *svp : &PL_sv_undef;
3822 if (GIMME != G_ARRAY) {
3824 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3830 /* Associative arrays. */
3835 HV * const hash = (HV*)POPs;
3837 const I32 gimme = GIMME_V;
3840 /* might clobber stack_sp */
3841 entry = hv_iternext(hash);
3846 SV* const sv = hv_iterkeysv(entry);
3847 PUSHs(sv); /* won't clobber stack_sp */
3848 if (gimme == G_ARRAY) {
3851 /* might clobber stack_sp */
3852 val = hv_iterval(hash, entry);
3857 else if (gimme == G_SCALAR)
3876 const I32 gimme = GIMME_V;
3877 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3879 if (PL_op->op_private & OPpSLICE) {
3881 HV * const hv = (HV*)POPs;
3882 const U32 hvtype = SvTYPE(hv);
3883 if (hvtype == SVt_PVHV) { /* hash element */
3884 while (++MARK <= SP) {
3885 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3886 *MARK = sv ? sv : &PL_sv_undef;
3889 else if (hvtype == SVt_PVAV) { /* array element */
3890 if (PL_op->op_flags & OPf_SPECIAL) {
3891 while (++MARK <= SP) {
3892 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3893 *MARK = sv ? sv : &PL_sv_undef;
3898 DIE(aTHX_ "Not a HASH reference");
3901 else if (gimme == G_SCALAR) {
3906 *++MARK = &PL_sv_undef;
3912 HV * const hv = (HV*)POPs;
3914 if (SvTYPE(hv) == SVt_PVHV)
3915 sv = hv_delete_ent(hv, keysv, discard, 0);
3916 else if (SvTYPE(hv) == SVt_PVAV) {
3917 if (PL_op->op_flags & OPf_SPECIAL)
3918 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3920 DIE(aTHX_ "panic: avhv_delete no longer supported");
3923 DIE(aTHX_ "Not a HASH reference");
3938 if (PL_op->op_private & OPpEXISTS_SUB) {
3941 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3944 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3950 if (SvTYPE(hv) == SVt_PVHV) {
3951 if (hv_exists_ent(hv, tmpsv, 0))
3954 else if (SvTYPE(hv) == SVt_PVAV) {
3955 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3956 if (av_exists((AV*)hv, SvIV(tmpsv)))
3961 DIE(aTHX_ "Not a HASH reference");
3968 dSP; dMARK; dORIGMARK;
3969 register HV * const hv = (HV*)POPs;
3970 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3971 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3972 bool other_magic = FALSE;
3978 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3979 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3980 /* Try to preserve the existenceness of a tied hash
3981 * element by using EXISTS and DELETE if possible.
3982 * Fallback to FETCH and STORE otherwise */
3983 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3984 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3985 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3988 while (++MARK <= SP) {
3989 SV * const keysv = *MARK;
3992 bool preeminent = FALSE;
3995 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3996 hv_exists_ent(hv, keysv, 0);
3999 he = hv_fetch_ent(hv, keysv, lval, 0);
4000 svp = he ? &HeVAL(he) : 0;
4003 if (!svp || *svp == &PL_sv_undef) {
4004 DIE(aTHX_ PL_no_helem_sv, keysv);
4008 save_helem(hv, keysv, svp);
4011 const char *key = SvPV_const(keysv, keylen);
4012 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4016 *MARK = svp ? *svp : &PL_sv_undef;
4018 if (GIMME != G_ARRAY) {
4020 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4026 /* List operators. */
4031 if (GIMME != G_ARRAY) {
4033 *MARK = *SP; /* unwanted list, return last item */
4035 *MARK = &PL_sv_undef;
4044 SV ** const lastrelem = PL_stack_sp;
4045 SV ** const lastlelem = PL_stack_base + POPMARK;
4046 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4047 register SV ** const firstrelem = lastlelem + 1;
4048 const I32 arybase = PL_curcop->cop_arybase;
4049 I32 is_something_there = PL_op->op_flags & OPf_MOD;
4051 register const I32 max = lastrelem - lastlelem;
4052 register SV **lelem;
4054 if (GIMME != G_ARRAY) {
4055 I32 ix = SvIVx(*lastlelem);
4060 if (ix < 0 || ix >= max)
4061 *firstlelem = &PL_sv_undef;
4063 *firstlelem = firstrelem[ix];
4069 SP = firstlelem - 1;
4073 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4074 I32 ix = SvIVx(*lelem);
4079 if (ix < 0 || ix >= max)
4080 *lelem = &PL_sv_undef;
4082 is_something_there = TRUE;
4083 if (!(*lelem = firstrelem[ix]))
4084 *lelem = &PL_sv_undef;
4087 if (is_something_there)
4090 SP = firstlelem - 1;
4096 dSP; dMARK; dORIGMARK;
4097 const I32 items = SP - MARK;
4098 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4099 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4106 dSP; dMARK; dORIGMARK;
4107 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4110 SV * const key = *++MARK;
4111 SV * const val = NEWSV(46, 0);
4113 sv_setsv(val, *++MARK);
4114 else if (ckWARN(WARN_MISC))
4115 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4116 (void)hv_store_ent(hv,key,val,0);
4125 dVAR; dSP; dMARK; dORIGMARK;
4126 register AV *ary = (AV*)*++MARK;
4130 register I32 offset;
4131 register I32 length;
4136 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4139 *MARK-- = SvTIED_obj((SV*)ary, mg);
4143 call_method("SPLICE",GIMME_V);
4152 offset = i = SvIVx(*MARK);
4154 offset += AvFILLp(ary) + 1;
4156 offset -= PL_curcop->cop_arybase;
4158 DIE(aTHX_ PL_no_aelem, i);
4160 length = SvIVx(*MARK++);
4162 length += AvFILLp(ary) - offset + 1;
4168 length = AvMAX(ary) + 1; /* close enough to infinity */
4172 length = AvMAX(ary) + 1;
4174 if (offset > AvFILLp(ary) + 1) {
4175 if (ckWARN(WARN_MISC))
4176 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4177 offset = AvFILLp(ary) + 1;
4179 after = AvFILLp(ary) + 1 - (offset + length);
4180 if (after < 0) { /* not that much array */
4181 length += after; /* offset+length now in array */
4187 /* At this point, MARK .. SP-1 is our new LIST */
4190 diff = newlen - length;
4191 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4194 /* make new elements SVs now: avoid problems if they're from the array */
4195 for (dst = MARK, i = newlen; i; i--) {
4196 SV * const h = *dst;
4197 *dst++ = newSVsv(h);
4200 if (diff < 0) { /* shrinking the area */
4202 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4203 Copy(MARK, tmparyval, newlen, SV*);
4206 MARK = ORIGMARK + 1;
4207 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4208 MEXTEND(MARK, length);
4209 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4211 EXTEND_MORTAL(length);
4212 for (i = length, dst = MARK; i; i--) {
4213 sv_2mortal(*dst); /* free them eventualy */
4220 *MARK = AvARRAY(ary)[offset+length-1];
4223 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4224 SvREFCNT_dec(*dst++); /* free them now */
4227 AvFILLp(ary) += diff;
4229 /* pull up or down? */
4231 if (offset < after) { /* easier to pull up */
4232 if (offset) { /* esp. if nothing to pull */
4233 src = &AvARRAY(ary)[offset-1];
4234 dst = src - diff; /* diff is negative */
4235 for (i = offset; i > 0; i--) /* can't trust Copy */
4239 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4243 if (after) { /* anything to pull down? */
4244 src = AvARRAY(ary) + offset + length;
4245 dst = src + diff; /* diff is negative */
4246 Move(src, dst, after, SV*);
4248 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4249 /* avoid later double free */
4253 dst[--i] = &PL_sv_undef;
4256 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4257 Safefree(tmparyval);
4260 else { /* no, expanding (or same) */
4262 Newx(tmparyval, length, SV*); /* so remember deletion */
4263 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4266 if (diff > 0) { /* expanding */
4268 /* push up or down? */
4270 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4274 Move(src, dst, offset, SV*);
4276 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4278 AvFILLp(ary) += diff;
4281 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4282 av_extend(ary, AvFILLp(ary) + diff);
4283 AvFILLp(ary) += diff;
4286 dst = AvARRAY(ary) + AvFILLp(ary);
4288 for (i = after; i; i--) {
4296 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4299 MARK = ORIGMARK + 1;
4300 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4302 Copy(tmparyval, MARK, length, SV*);
4304 EXTEND_MORTAL(length);
4305 for (i = length, dst = MARK; i; i--) {
4306 sv_2mortal(*dst); /* free them eventualy */
4310 Safefree(tmparyval);
4314 else if (length--) {
4315 *MARK = tmparyval[length];
4318 while (length-- > 0)
4319 SvREFCNT_dec(tmparyval[length]);
4321 Safefree(tmparyval);
4324 *MARK = &PL_sv_undef;
4332 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4333 register AV *ary = (AV*)*++MARK;
4334 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4337 *MARK-- = SvTIED_obj((SV*)ary, mg);
4341 call_method("PUSH",G_SCALAR|G_DISCARD);
4346 /* Why no pre-extend of ary here ? */
4347 for (++MARK; MARK <= SP; MARK++) {
4348 SV * const sv = NEWSV(51, 0);
4350 sv_setsv(sv, *MARK);
4355 PUSHi( AvFILL(ary) + 1 );
4362 AV * const av = (AV*)POPs;
4363 SV * const sv = av_pop(av);
4365 (void)sv_2mortal(sv);
4373 AV * const av = (AV*)POPs;
4374 SV * const sv = av_shift(av);
4379 (void)sv_2mortal(sv);
4386 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4387 register AV *ary = (AV*)*++MARK;
4388 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4391 *MARK-- = SvTIED_obj((SV*)ary, mg);
4395 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4401 av_unshift(ary, SP - MARK);
4403 SV * const sv = newSVsv(*++MARK);
4404 (void)av_store(ary, i++, sv);
4408 PUSHi( AvFILL(ary) + 1 );
4415 SV ** const oldsp = SP;
4417 if (GIMME == G_ARRAY) {
4420 register SV * const tmp = *MARK;
4424 /* safe as long as stack cannot get extended in the above */
4429 register char *down;
4435 SvUTF8_off(TARG); /* decontaminate */
4437 do_join(TARG, &PL_sv_no, MARK, SP);
4439 sv_setsv(TARG, (SP > MARK)
4441 : (padoff_du = find_rundefsvoffset(),
4442 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4443 ? DEFSV : PAD_SVl(padoff_du)));
4444 up = SvPV_force(TARG, len);
4446 if (DO_UTF8(TARG)) { /* first reverse each character */
4447 U8* s = (U8*)SvPVX(TARG);
4448 const U8* send = (U8*)(s + len);
4450 if (UTF8_IS_INVARIANT(*s)) {
4455 if (!utf8_to_uvchr(s, 0))
4459 down = (char*)(s - 1);
4460 /* reverse this character */
4464 *down-- = (char)tmp;
4470 down = SvPVX(TARG) + len - 1;
4474 *down-- = (char)tmp;
4476 (void)SvPOK_only_UTF8(TARG);
4488 register IV limit = POPi; /* note, negative is forever */
4489 SV * const sv = POPs;
4491 register const char *s = SvPV_const(sv, len);
4492 const bool do_utf8 = DO_UTF8(sv);
4493 const char *strend = s + len;
4495 register REGEXP *rx;
4497 register const char *m;
4499 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4500 I32 maxiters = slen + 10;
4502 const I32 origlimit = limit;
4505 const I32 gimme = GIMME_V;
4506 const I32 oldsave = PL_savestack_ix;
4507 I32 make_mortal = 1;
4509 MAGIC *mg = (MAGIC *) NULL;
4512 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4517 DIE(aTHX_ "panic: pp_split");
4520 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4521 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4523 RX_MATCH_UTF8_set(rx, do_utf8);
4525 if (pm->op_pmreplroot) {
4527 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4529 ary = GvAVn((GV*)pm->op_pmreplroot);
4532 else if (gimme != G_ARRAY)
4533 ary = GvAVn(PL_defgv);
4536 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4542 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4544 XPUSHs(SvTIED_obj((SV*)ary, mg));
4551 for (i = AvFILLp(ary); i >= 0; i--)
4552 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4554 /* temporarily switch stacks */
4555 SAVESWITCHSTACK(PL_curstack, ary);
4559 base = SP - PL_stack_base;
4561 if (pm->op_pmflags & PMf_SKIPWHITE) {
4562 if (pm->op_pmflags & PMf_LOCALE) {
4563 while (isSPACE_LC(*s))
4571 if (pm->op_pmflags & PMf_MULTILINE) {
4576 limit = maxiters + 2;
4577 if (pm->op_pmflags & PMf_WHITE) {
4580 while (m < strend &&
4581 !((pm->op_pmflags & PMf_LOCALE)
4582 ? isSPACE_LC(*m) : isSPACE(*m)))
4587 dstr = newSVpvn(s, m-s);
4591 (void)SvUTF8_on(dstr);
4595 while (s < strend &&
4596 ((pm->op_pmflags & PMf_LOCALE)
4597 ? isSPACE_LC(*s) : isSPACE(*s)))
4601 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4603 for (m = s; m < strend && *m != '\n'; m++)
4608 dstr = newSVpvn(s, m-s);
4612 (void)SvUTF8_on(dstr);
4617 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4618 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4619 && (rx->reganch & ROPT_CHECK_ALL)
4620 && !(rx->reganch & ROPT_ANCH)) {
4621 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4622 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4625 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4626 const char c = *SvPV_nolen_const(csv);
4628 for (m = s; m < strend && *m != c; m++)
4632 dstr = newSVpvn(s, m-s);
4636 (void)SvUTF8_on(dstr);
4638 /* The rx->minlen is in characters but we want to step
4639 * s ahead by bytes. */
4641 s = (char*)utf8_hop((U8*)m, len);
4643 s = m + len; /* Fake \n at the end */
4647 while (s < strend && --limit &&
4648 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4649 csv, multiline ? FBMrf_MULTILINE : 0)) )
4651 dstr = newSVpvn(s, m-s);
4655 (void)SvUTF8_on(dstr);
4657 /* The rx->minlen is in characters but we want to step
4658 * s ahead by bytes. */
4660 s = (char*)utf8_hop((U8*)m, len);
4662 s = m + len; /* Fake \n at the end */
4667 maxiters += slen * rx->nparens;
4668 while (s < strend && --limit)
4672 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4675 if (rex_return == 0)
4677 TAINT_IF(RX_MATCH_TAINTED(rx));
4678 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4683 strend = s + (strend - m);
4685 m = rx->startp[0] + orig;
4686 dstr = newSVpvn(s, m-s);
4690 (void)SvUTF8_on(dstr);
4694 for (i = 1; i <= (I32)rx->nparens; i++) {
4695 s = rx->startp[i] + orig;
4696 m = rx->endp[i] + orig;
4698 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4699 parens that didn't match -- they should be set to
4700 undef, not the empty string */
4701 if (m >= orig && s >= orig) {
4702 dstr = newSVpvn(s, m-s);
4705 dstr = &PL_sv_undef; /* undef, not "" */
4709 (void)SvUTF8_on(dstr);
4713 s = rx->endp[0] + orig;
4717 iters = (SP - PL_stack_base) - base;
4718 if (iters > maxiters)
4719 DIE(aTHX_ "Split loop");
4721 /* keep field after final delim? */
4722 if (s < strend || (iters && origlimit)) {
4723 const STRLEN l = strend - s;
4724 dstr = newSVpvn(s, l);
4728 (void)SvUTF8_on(dstr);
4732 else if (!origlimit) {
4733 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4734 if (TOPs && !make_mortal)
4737 *SP-- = &PL_sv_undef;
4742 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4746 if (SvSMAGICAL(ary)) {
4751 if (gimme == G_ARRAY) {
4753 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4761 call_method("PUSH",G_SCALAR|G_DISCARD);
4764 if (gimme == G_ARRAY) {
4766 /* EXTEND should not be needed - we just popped them */
4768 for (i=0; i < iters; i++) {
4769 SV **svp = av_fetch(ary, i, FALSE);
4770 PUSHs((svp) ? *svp : &PL_sv_undef);
4777 if (gimme == G_ARRAY)
4792 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4793 || SvTYPE(retsv) == SVt_PVCV) {
4794 retsv = refto(retsv);
4802 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4807 * c-indentation-style: bsd
4809 * indent-tabs-mode: t
4812 * ex: set ts=8 sts=4 sw=4 noet: