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);
38 /* variations on pp_null */
43 if (GIMME_V == G_SCALAR)
59 if (PL_op->op_private & OPpLVAL_INTRO)
60 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
62 if (PL_op->op_flags & OPf_REF) {
66 if (GIMME == G_SCALAR)
67 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
72 if (gimme == G_ARRAY) {
73 I32 maxarg = AvFILL((AV*)TARG) + 1;
75 if (SvMAGICAL(TARG)) {
77 for (i=0; i < (U32)maxarg; i++) {
78 SV **svp = av_fetch((AV*)TARG, i, FALSE);
79 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
83 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
87 else if (gimme == G_SCALAR) {
88 SV* sv = sv_newmortal();
89 I32 maxarg = AvFILL((AV*)TARG) + 1;
102 if (PL_op->op_private & OPpLVAL_INTRO)
103 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
104 if (PL_op->op_flags & OPf_REF)
107 if (GIMME == G_SCALAR)
108 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
112 if (gimme == G_ARRAY) {
115 else if (gimme == G_SCALAR) {
116 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
124 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
135 tryAMAGICunDEREF(to_gv);
138 if (SvTYPE(sv) == SVt_PVIO) {
139 GV *gv = (GV*) sv_newmortal();
140 gv_init(gv, 0, "", 0, 0);
141 GvIOp(gv) = (IO *)sv;
142 (void)SvREFCNT_inc(sv);
145 else if (SvTYPE(sv) != SVt_PVGV)
146 DIE(aTHX_ "Not a GLOB reference");
149 if (SvTYPE(sv) != SVt_PVGV) {
153 if (SvGMAGICAL(sv)) {
158 if (!SvOK(sv) && sv != &PL_sv_undef) {
159 /* If this is a 'my' scalar and flag is set then vivify
163 Perl_croak(aTHX_ PL_no_modify);
164 if (PL_op->op_private & OPpDEREF) {
167 if (cUNOP->op_targ) {
169 SV *namesv = PAD_SV(cUNOP->op_targ);
170 name = SvPV(namesv, len);
171 gv = (GV*)NEWSV(0,0);
172 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
175 name = CopSTASHPV(PL_curcop);
178 if (SvTYPE(sv) < SVt_RV)
179 sv_upgrade(sv, SVt_RV);
181 SvOOK_off(sv); /* backoff */
184 SvLEN(sv)=SvCUR(sv)=0;
191 if (PL_op->op_flags & OPf_REF ||
192 PL_op->op_private & HINT_STRICT_REFS)
193 DIE(aTHX_ PL_no_usym, "a symbol");
194 if (ckWARN(WARN_UNINITIALIZED))
199 if ((PL_op->op_flags & OPf_SPECIAL) &&
200 !(PL_op->op_flags & OPf_MOD))
202 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
204 && (!is_gv_magical(sym,len,0)
205 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
211 if (PL_op->op_private & HINT_STRICT_REFS)
212 DIE(aTHX_ PL_no_symref, sym, "a symbol");
213 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
230 tryAMAGICunDEREF(to_sv);
233 switch (SvTYPE(sv)) {
237 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))
260 if ((PL_op->op_flags & OPf_SPECIAL) &&
261 !(PL_op->op_flags & OPf_MOD))
263 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
265 && (!is_gv_magical(sym,len,0)
266 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
272 if (PL_op->op_private & HINT_STRICT_REFS)
273 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
274 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
279 if (PL_op->op_flags & OPf_MOD) {
280 if (PL_op->op_private & OPpLVAL_INTRO) {
281 if (cUNOP->op_first->op_type == OP_NULL)
282 sv = save_scalar((GV*)TOPs);
284 sv = save_scalar(gv);
286 Perl_croak(aTHX_ PL_no_localize_ref);
288 else if (PL_op->op_private & OPpDEREF)
289 vivify_ref(sv, PL_op->op_private & OPpDEREF);
299 SV *sv = AvARYLEN(av);
301 AvARYLEN(av) = sv = NEWSV(0,0);
302 sv_upgrade(sv, SVt_IV);
303 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
311 dSP; dTARGET; dPOPss;
313 if (PL_op->op_flags & OPf_MOD || LVRET) {
314 if (SvTYPE(TARG) < SVt_PVLV) {
315 sv_upgrade(TARG, SVt_PVLV);
316 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
320 if (LvTARG(TARG) != sv) {
322 SvREFCNT_dec(LvTARG(TARG));
323 LvTARG(TARG) = SvREFCNT_inc(sv);
325 PUSHs(TARG); /* no SvSETMAGIC */
331 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
332 mg = mg_find(sv, PERL_MAGIC_regex_global);
333 if (mg && mg->mg_len >= 0) {
337 PUSHi(i + PL_curcop->cop_arybase);
351 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
352 /* (But not in defined().) */
353 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
356 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
357 if ((PL_op->op_private & OPpLVAL_INTRO)) {
358 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
361 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
365 cv = (CV*)&PL_sv_undef;
379 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
380 char *s = SvPVX(TOPs);
381 if (strnEQ(s, "CORE::", 6)) {
384 code = keyword(s + 6, SvCUR(TOPs) - 6);
385 if (code < 0) { /* Overridable. */
386 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
387 int i = 0, n = 0, seen_question = 0;
389 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
391 if (code == -KEY_chop || code == -KEY_chomp)
393 while (i < MAXO) { /* The slow way. */
394 if (strEQ(s + 6, PL_op_name[i])
395 || strEQ(s + 6, PL_op_desc[i]))
401 goto nonesuch; /* Should not happen... */
403 oa = PL_opargs[i] >> OASHIFT;
405 if (oa & OA_OPTIONAL && !seen_question) {
409 else if (n && str[0] == ';' && seen_question)
410 goto set; /* XXXX system, exec */
411 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
412 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
413 /* But globs are already references (kinda) */
414 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
418 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
422 ret = sv_2mortal(newSVpvn(str, n - 1));
424 else if (code) /* Non-Overridable */
426 else { /* None such */
428 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
432 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
434 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
443 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
445 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
461 if (GIMME != G_ARRAY) {
465 *MARK = &PL_sv_undef;
466 *MARK = refto(*MARK);
470 EXTEND_MORTAL(SP - MARK);
472 *MARK = refto(*MARK);
477 S_refto(pTHX_ SV *sv)
481 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
484 if (!(sv = LvTARG(sv)))
487 (void)SvREFCNT_inc(sv);
489 else if (SvTYPE(sv) == SVt_PVAV) {
490 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
493 (void)SvREFCNT_inc(sv);
495 else if (SvPADTMP(sv) && !IS_PADGV(sv))
499 (void)SvREFCNT_inc(sv);
502 sv_upgrade(rv, SVt_RV);
516 if (sv && SvGMAGICAL(sv))
519 if (!sv || !SvROK(sv))
523 pv = sv_reftype(sv,TRUE);
524 PUSHp(pv, strlen(pv));
534 stash = CopSTASH(PL_curcop);
540 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
541 Perl_croak(aTHX_ "Attempt to bless into a reference");
543 if (ckWARN(WARN_MISC) && len == 0)
544 Perl_warner(aTHX_ packWARN(WARN_MISC),
545 "Explicit blessing to '' (assuming package main)");
546 stash = gv_stashpvn(ptr, len, TRUE);
549 (void)sv_bless(TOPs, stash);
563 elem = SvPV(sv, n_a);
568 /* elem will always be NUL terminated. */
569 const char *elem2 = elem + 1;
572 if (strEQ(elem2, "RRAY"))
573 tmpRef = (SV*)GvAV(gv);
576 if (strEQ(elem2, "ODE"))
577 tmpRef = (SV*)GvCVu(gv);
580 if (strEQ(elem2, "ILEHANDLE")) {
581 /* finally deprecated in 5.8.0 */
582 deprecate("*glob{FILEHANDLE}");
583 tmpRef = (SV*)GvIOp(gv);
586 if (strEQ(elem2, "ORMAT"))
587 tmpRef = (SV*)GvFORM(gv);
590 if (strEQ(elem2, "LOB"))
594 if (strEQ(elem2, "ASH"))
595 tmpRef = (SV*)GvHV(gv);
598 if (*elem2 == 'O' && !elem[2])
599 tmpRef = (SV*)GvIOp(gv);
602 if (strEQ(elem2, "AME"))
603 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
606 if (strEQ(elem2, "ACKAGE")) {
607 if (HvNAME(GvSTASH(gv)))
608 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
610 sv = newSVpv("__ANON__",0);
614 if (strEQ(elem2, "CALAR"))
629 /* Pattern matching */
634 register unsigned char *s;
637 register I32 *sfirst;
641 if (sv == PL_lastscream) {
647 SvSCREAM_off(PL_lastscream);
648 SvREFCNT_dec(PL_lastscream);
650 PL_lastscream = SvREFCNT_inc(sv);
653 s = (unsigned char*)(SvPV(sv, len));
657 if (pos > PL_maxscream) {
658 if (PL_maxscream < 0) {
659 PL_maxscream = pos + 80;
660 New(301, PL_screamfirst, 256, I32);
661 New(302, PL_screamnext, PL_maxscream, I32);
664 PL_maxscream = pos + pos / 4;
665 Renew(PL_screamnext, PL_maxscream, I32);
669 sfirst = PL_screamfirst;
670 snext = PL_screamnext;
672 if (!sfirst || !snext)
673 DIE(aTHX_ "do_study: out of memory");
675 for (ch = 256; ch; --ch)
682 snext[pos] = sfirst[ch] - pos;
689 /* piggyback on m//g magic */
690 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
699 if (PL_op->op_flags & OPf_STACKED)
701 else if (PL_op->op_private & OPpTARGET_MY)
707 TARG = sv_newmortal();
712 /* Lvalue operators. */
724 dSP; dMARK; dTARGET; dORIGMARK;
726 do_chop(TARG, *++MARK);
735 SETi(do_chomp(TOPs));
742 register I32 count = 0;
745 count += do_chomp(POPs);
756 if (!sv || !SvANY(sv))
758 switch (SvTYPE(sv)) {
760 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
761 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
765 if (HvARRAY(sv) || SvGMAGICAL(sv)
766 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
770 if (CvROOT(sv) || CvXSUB(sv))
787 if (!PL_op->op_private) {
796 SV_CHECK_THINKFIRST_COW_DROP(sv);
798 switch (SvTYPE(sv)) {
808 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
809 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
810 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
814 /* let user-undef'd sub keep its identity */
815 GV* gv = CvGV((CV*)sv);
822 SvSetMagicSV(sv, &PL_sv_undef);
826 Newz(602, gp, 1, GP);
827 GvGP(sv) = gp_ref(gp);
828 GvSV(sv) = NEWSV(72,0);
829 GvLINE(sv) = CopLINE(PL_curcop);
835 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
838 SvPV_set(sv, Nullch);
851 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
852 DIE(aTHX_ PL_no_modify);
853 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
854 && SvIVX(TOPs) != IV_MIN)
857 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
868 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
869 DIE(aTHX_ PL_no_modify);
870 sv_setsv(TARG, TOPs);
871 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
872 && SvIVX(TOPs) != IV_MAX)
875 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
880 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
890 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
891 DIE(aTHX_ PL_no_modify);
892 sv_setsv(TARG, TOPs);
893 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
894 && SvIVX(TOPs) != IV_MIN)
897 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
906 /* Ordinary operators. */
911 #ifdef PERL_PRESERVE_IVUV
914 tryAMAGICbin(pow,opASSIGN);
915 #ifdef PERL_PRESERVE_IVUV
916 /* For integer to integer power, we do the calculation by hand wherever
917 we're sure it is safe; otherwise we call pow() and try to convert to
918 integer afterwards. */
922 bool baseuok = SvUOK(TOPm1s);
926 baseuv = SvUVX(TOPm1s);
928 IV iv = SvIVX(TOPm1s);
931 baseuok = TRUE; /* effectively it's a UV now */
933 baseuv = -iv; /* abs, baseuok == false records sign */
947 goto float_it; /* Can't do negative powers this way. */
950 /* now we have integer ** positive integer. */
953 /* foo & (foo - 1) is zero only for a power of 2. */
954 if (!(baseuv & (baseuv - 1))) {
955 /* We are raising power-of-2 to a positive integer.
956 The logic here will work for any base (even non-integer
957 bases) but it can be less accurate than
958 pow (base,power) or exp (power * log (base)) when the
959 intermediate values start to spill out of the mantissa.
960 With powers of 2 we know this can't happen.
961 And powers of 2 are the favourite thing for perl
962 programmers to notice ** not doing what they mean. */
964 NV base = baseuok ? baseuv : -(NV)baseuv;
967 for (; power; base *= base, n++) {
968 /* Do I look like I trust gcc with long longs here?
970 UV bit = (UV)1 << (UV)n;
973 /* Only bother to clear the bit if it is set. */
975 /* Avoid squaring base again if we're done. */
976 if (power == 0) break;
984 register unsigned int highbit = 8 * sizeof(UV);
985 register unsigned int lowbit = 0;
986 register unsigned int diff;
987 bool odd_power = (bool)(power & 1);
988 while ((diff = (highbit - lowbit) >> 1)) {
989 if (baseuv & ~((1 << (lowbit + diff)) - 1))
994 /* we now have baseuv < 2 ** highbit */
995 if (power * highbit <= 8 * sizeof(UV)) {
996 /* result will definitely fit in UV, so use UV math
997 on same algorithm as above */
998 register UV result = 1;
999 register UV base = baseuv;
1001 for (; power; base *= base, n++) {
1002 register UV bit = (UV)1 << (UV)n;
1006 if (power == 0) break;
1010 if (baseuok || !odd_power)
1011 /* answer is positive */
1013 else if (result <= (UV)IV_MAX)
1014 /* answer negative, fits in IV */
1015 SETi( -(IV)result );
1016 else if (result == (UV)IV_MIN)
1017 /* 2's complement assumption: special case IV_MIN */
1020 /* answer negative, doesn't fit */
1021 SETn( -(NV)result );
1032 SETn( Perl_pow( left, right) );
1033 #ifdef PERL_PRESERVE_IVUV
1043 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1044 #ifdef PERL_PRESERVE_IVUV
1047 /* Unless the left argument is integer in range we are going to have to
1048 use NV maths. Hence only attempt to coerce the right argument if
1049 we know the left is integer. */
1050 /* Left operand is defined, so is it IV? */
1051 SvIV_please(TOPm1s);
1052 if (SvIOK(TOPm1s)) {
1053 bool auvok = SvUOK(TOPm1s);
1054 bool buvok = SvUOK(TOPs);
1055 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1056 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1063 alow = SvUVX(TOPm1s);
1065 IV aiv = SvIVX(TOPm1s);
1068 auvok = TRUE; /* effectively it's a UV now */
1070 alow = -aiv; /* abs, auvok == false records sign */
1076 IV biv = SvIVX(TOPs);
1079 buvok = TRUE; /* effectively it's a UV now */
1081 blow = -biv; /* abs, buvok == false records sign */
1085 /* If this does sign extension on unsigned it's time for plan B */
1086 ahigh = alow >> (4 * sizeof (UV));
1088 bhigh = blow >> (4 * sizeof (UV));
1090 if (ahigh && bhigh) {
1091 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1092 which is overflow. Drop to NVs below. */
1093 } else if (!ahigh && !bhigh) {
1094 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1095 so the unsigned multiply cannot overflow. */
1096 UV product = alow * blow;
1097 if (auvok == buvok) {
1098 /* -ve * -ve or +ve * +ve gives a +ve result. */
1102 } else if (product <= (UV)IV_MIN) {
1103 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1104 /* -ve result, which could overflow an IV */
1106 SETi( -(IV)product );
1108 } /* else drop to NVs below. */
1110 /* One operand is large, 1 small */
1113 /* swap the operands */
1115 bhigh = blow; /* bhigh now the temp var for the swap */
1119 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1120 multiplies can't overflow. shift can, add can, -ve can. */
1121 product_middle = ahigh * blow;
1122 if (!(product_middle & topmask)) {
1123 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1125 product_middle <<= (4 * sizeof (UV));
1126 product_low = alow * blow;
1128 /* as for pp_add, UV + something mustn't get smaller.
1129 IIRC ANSI mandates this wrapping *behaviour* for
1130 unsigned whatever the actual representation*/
1131 product_low += product_middle;
1132 if (product_low >= product_middle) {
1133 /* didn't overflow */
1134 if (auvok == buvok) {
1135 /* -ve * -ve or +ve * +ve gives a +ve result. */
1137 SETu( product_low );
1139 } else if (product_low <= (UV)IV_MIN) {
1140 /* 2s complement assumption again */
1141 /* -ve result, which could overflow an IV */
1143 SETi( -(IV)product_low );
1145 } /* else drop to NVs below. */
1147 } /* product_middle too large */
1148 } /* ahigh && bhigh */
1149 } /* SvIOK(TOPm1s) */
1154 SETn( left * right );
1161 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1162 /* Only try to do UV divide first
1163 if ((SLOPPYDIVIDE is true) or
1164 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1166 The assumption is that it is better to use floating point divide
1167 whenever possible, only doing integer divide first if we can't be sure.
1168 If NV_PRESERVES_UV is true then we know at compile time that no UV
1169 can be too large to preserve, so don't need to compile the code to
1170 test the size of UVs. */
1173 # define PERL_TRY_UV_DIVIDE
1174 /* ensure that 20./5. == 4. */
1176 # ifdef PERL_PRESERVE_IVUV
1177 # ifndef NV_PRESERVES_UV
1178 # define PERL_TRY_UV_DIVIDE
1183 #ifdef PERL_TRY_UV_DIVIDE
1186 SvIV_please(TOPm1s);
1187 if (SvIOK(TOPm1s)) {
1188 bool left_non_neg = SvUOK(TOPm1s);
1189 bool right_non_neg = SvUOK(TOPs);
1193 if (right_non_neg) {
1194 right = SvUVX(TOPs);
1197 IV biv = SvIVX(TOPs);
1200 right_non_neg = TRUE; /* effectively it's a UV now */
1206 /* historically undef()/0 gives a "Use of uninitialized value"
1207 warning before dieing, hence this test goes here.
1208 If it were immediately before the second SvIV_please, then
1209 DIE() would be invoked before left was even inspected, so
1210 no inpsection would give no warning. */
1212 DIE(aTHX_ "Illegal division by zero");
1215 left = SvUVX(TOPm1s);
1218 IV aiv = SvIVX(TOPm1s);
1221 left_non_neg = TRUE; /* effectively it's a UV now */
1230 /* For sloppy divide we always attempt integer division. */
1232 /* Otherwise we only attempt it if either or both operands
1233 would not be preserved by an NV. If both fit in NVs
1234 we fall through to the NV divide code below. However,
1235 as left >= right to ensure integer result here, we know that
1236 we can skip the test on the right operand - right big
1237 enough not to be preserved can't get here unless left is
1240 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1243 /* Integer division can't overflow, but it can be imprecise. */
1244 UV result = left / right;
1245 if (result * right == left) {
1246 SP--; /* result is valid */
1247 if (left_non_neg == right_non_neg) {
1248 /* signs identical, result is positive. */
1252 /* 2s complement assumption */
1253 if (result <= (UV)IV_MIN)
1254 SETi( -(IV)result );
1256 /* It's exact but too negative for IV. */
1257 SETn( -(NV)result );
1260 } /* tried integer divide but it was not an integer result */
1261 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1262 } /* left wasn't SvIOK */
1263 } /* right wasn't SvIOK */
1264 #endif /* PERL_TRY_UV_DIVIDE */
1268 DIE(aTHX_ "Illegal division by zero");
1269 PUSHn( left / right );
1276 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1280 bool left_neg = FALSE;
1281 bool right_neg = FALSE;
1282 bool use_double = FALSE;
1283 bool dright_valid = FALSE;
1289 right_neg = !SvUOK(TOPs);
1291 right = SvUVX(POPs);
1293 IV biv = SvIVX(POPs);
1296 right_neg = FALSE; /* effectively it's a UV now */
1304 right_neg = dright < 0;
1307 if (dright < UV_MAX_P1) {
1308 right = U_V(dright);
1309 dright_valid = TRUE; /* In case we need to use double below. */
1315 /* At this point use_double is only true if right is out of range for
1316 a UV. In range NV has been rounded down to nearest UV and
1317 use_double false. */
1319 if (!use_double && SvIOK(TOPs)) {
1321 left_neg = !SvUOK(TOPs);
1325 IV aiv = SvIVX(POPs);
1328 left_neg = FALSE; /* effectively it's a UV now */
1337 left_neg = dleft < 0;
1341 /* This should be exactly the 5.6 behaviour - if left and right are
1342 both in range for UV then use U_V() rather than floor. */
1344 if (dleft < UV_MAX_P1) {
1345 /* right was in range, so is dleft, so use UVs not double.
1349 /* left is out of range for UV, right was in range, so promote
1350 right (back) to double. */
1352 /* The +0.5 is used in 5.6 even though it is not strictly
1353 consistent with the implicit +0 floor in the U_V()
1354 inside the #if 1. */
1355 dleft = Perl_floor(dleft + 0.5);
1358 dright = Perl_floor(dright + 0.5);
1368 DIE(aTHX_ "Illegal modulus zero");
1370 dans = Perl_fmod(dleft, dright);
1371 if ((left_neg != right_neg) && dans)
1372 dans = dright - dans;
1375 sv_setnv(TARG, dans);
1381 DIE(aTHX_ "Illegal modulus zero");
1384 if ((left_neg != right_neg) && ans)
1387 /* XXX may warn: unary minus operator applied to unsigned type */
1388 /* could change -foo to be (~foo)+1 instead */
1389 if (ans <= ~((UV)IV_MAX)+1)
1390 sv_setiv(TARG, ~ans+1);
1392 sv_setnv(TARG, -(NV)ans);
1395 sv_setuv(TARG, ans);
1404 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1414 count = IV_MAX; /* The best we can do? */
1425 else if (SvNOKp(sv)) {
1434 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1436 I32 items = SP - MARK;
1438 static const char oom_list_extend[] =
1439 "Out of memory during list extend";
1441 max = items * count;
1442 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1443 /* Did the max computation overflow? */
1444 if (items > 0 && max > 0 && (max < items || max < count))
1445 Perl_croak(aTHX_ oom_list_extend);
1450 /* This code was intended to fix 20010809.028:
1453 for (($x =~ /./g) x 2) {
1454 print chop; # "abcdabcd" expected as output.
1457 * but that change (#11635) broke this code:
1459 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1461 * I can't think of a better fix that doesn't introduce
1462 * an efficiency hit by copying the SVs. The stack isn't
1463 * refcounted, and mortalisation obviously doesn't
1464 * Do The Right Thing when the stack has more than
1465 * one pointer to the same mortal value.
1469 *SP = sv_2mortal(newSVsv(*SP));
1479 repeatcpy((char*)(MARK + items), (char*)MARK,
1480 items * sizeof(SV*), count - 1);
1483 else if (count <= 0)
1486 else { /* Note: mark already snarfed by pp_list */
1490 static const char oom_string_extend[] =
1491 "Out of memory during string extend";
1493 SvSetSV(TARG, tmpstr);
1494 SvPV_force(TARG, len);
1495 isutf = DO_UTF8(TARG);
1500 IV max = count * len;
1501 if (len > ((MEM_SIZE)~0)/count)
1502 Perl_croak(aTHX_ oom_string_extend);
1503 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1504 SvGROW(TARG, (count * len) + 1);
1505 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1506 SvCUR(TARG) *= count;
1508 *SvEND(TARG) = '\0';
1511 (void)SvPOK_only_UTF8(TARG);
1513 (void)SvPOK_only(TARG);
1515 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1516 /* The parser saw this as a list repeat, and there
1517 are probably several items on the stack. But we're
1518 in scalar context, and there's no pp_list to save us
1519 now. So drop the rest of the items -- robin@kitsite.com
1532 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1533 useleft = USE_LEFT(TOPm1s);
1534 #ifdef PERL_PRESERVE_IVUV
1535 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1536 "bad things" happen if you rely on signed integers wrapping. */
1539 /* Unless the left argument is integer in range we are going to have to
1540 use NV maths. Hence only attempt to coerce the right argument if
1541 we know the left is integer. */
1542 register UV auv = 0;
1548 a_valid = auvok = 1;
1549 /* left operand is undef, treat as zero. */
1551 /* Left operand is defined, so is it IV? */
1552 SvIV_please(TOPm1s);
1553 if (SvIOK(TOPm1s)) {
1554 if ((auvok = SvUOK(TOPm1s)))
1555 auv = SvUVX(TOPm1s);
1557 register IV aiv = SvIVX(TOPm1s);
1560 auvok = 1; /* Now acting as a sign flag. */
1561 } else { /* 2s complement assumption for IV_MIN */
1569 bool result_good = 0;
1572 bool buvok = SvUOK(TOPs);
1577 register IV biv = SvIVX(TOPs);
1584 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1585 else "IV" now, independent of how it came in.
1586 if a, b represents positive, A, B negative, a maps to -A etc
1591 all UV maths. negate result if A negative.
1592 subtract if signs same, add if signs differ. */
1594 if (auvok ^ buvok) {
1603 /* Must get smaller */
1608 if (result <= buv) {
1609 /* result really should be -(auv-buv). as its negation
1610 of true value, need to swap our result flag */
1622 if (result <= (UV)IV_MIN)
1623 SETi( -(IV)result );
1625 /* result valid, but out of range for IV. */
1626 SETn( -(NV)result );
1630 } /* Overflow, drop through to NVs. */
1634 useleft = USE_LEFT(TOPm1s);
1638 /* left operand is undef, treat as zero - value */
1642 SETn( TOPn - value );
1649 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1652 if (PL_op->op_private & HINT_INTEGER) {
1666 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1669 if (PL_op->op_private & HINT_INTEGER) {
1683 dSP; tryAMAGICbinSET(lt,0);
1684 #ifdef PERL_PRESERVE_IVUV
1687 SvIV_please(TOPm1s);
1688 if (SvIOK(TOPm1s)) {
1689 bool auvok = SvUOK(TOPm1s);
1690 bool buvok = SvUOK(TOPs);
1692 if (!auvok && !buvok) { /* ## IV < IV ## */
1693 IV aiv = SvIVX(TOPm1s);
1694 IV biv = SvIVX(TOPs);
1697 SETs(boolSV(aiv < biv));
1700 if (auvok && buvok) { /* ## UV < UV ## */
1701 UV auv = SvUVX(TOPm1s);
1702 UV buv = SvUVX(TOPs);
1705 SETs(boolSV(auv < buv));
1708 if (auvok) { /* ## UV < IV ## */
1715 /* As (a) is a UV, it's >=0, so it cannot be < */
1720 SETs(boolSV(auv < (UV)biv));
1723 { /* ## IV < UV ## */
1727 aiv = SvIVX(TOPm1s);
1729 /* As (b) is a UV, it's >=0, so it must be < */
1736 SETs(boolSV((UV)aiv < buv));
1742 #ifndef NV_PRESERVES_UV
1743 #ifdef PERL_PRESERVE_IVUV
1746 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1748 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1754 SETs(boolSV(TOPn < value));
1761 dSP; tryAMAGICbinSET(gt,0);
1762 #ifdef PERL_PRESERVE_IVUV
1765 SvIV_please(TOPm1s);
1766 if (SvIOK(TOPm1s)) {
1767 bool auvok = SvUOK(TOPm1s);
1768 bool buvok = SvUOK(TOPs);
1770 if (!auvok && !buvok) { /* ## IV > IV ## */
1771 IV aiv = SvIVX(TOPm1s);
1772 IV biv = SvIVX(TOPs);
1775 SETs(boolSV(aiv > biv));
1778 if (auvok && buvok) { /* ## UV > UV ## */
1779 UV auv = SvUVX(TOPm1s);
1780 UV buv = SvUVX(TOPs);
1783 SETs(boolSV(auv > buv));
1786 if (auvok) { /* ## UV > IV ## */
1793 /* As (a) is a UV, it's >=0, so it must be > */
1798 SETs(boolSV(auv > (UV)biv));
1801 { /* ## IV > UV ## */
1805 aiv = SvIVX(TOPm1s);
1807 /* As (b) is a UV, it's >=0, so it cannot be > */
1814 SETs(boolSV((UV)aiv > buv));
1820 #ifndef NV_PRESERVES_UV
1821 #ifdef PERL_PRESERVE_IVUV
1824 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1826 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1832 SETs(boolSV(TOPn > value));
1839 dSP; tryAMAGICbinSET(le,0);
1840 #ifdef PERL_PRESERVE_IVUV
1843 SvIV_please(TOPm1s);
1844 if (SvIOK(TOPm1s)) {
1845 bool auvok = SvUOK(TOPm1s);
1846 bool buvok = SvUOK(TOPs);
1848 if (!auvok && !buvok) { /* ## IV <= IV ## */
1849 IV aiv = SvIVX(TOPm1s);
1850 IV biv = SvIVX(TOPs);
1853 SETs(boolSV(aiv <= biv));
1856 if (auvok && buvok) { /* ## UV <= UV ## */
1857 UV auv = SvUVX(TOPm1s);
1858 UV buv = SvUVX(TOPs);
1861 SETs(boolSV(auv <= buv));
1864 if (auvok) { /* ## UV <= IV ## */
1871 /* As (a) is a UV, it's >=0, so a cannot be <= */
1876 SETs(boolSV(auv <= (UV)biv));
1879 { /* ## IV <= UV ## */
1883 aiv = SvIVX(TOPm1s);
1885 /* As (b) is a UV, it's >=0, so a must be <= */
1892 SETs(boolSV((UV)aiv <= buv));
1898 #ifndef NV_PRESERVES_UV
1899 #ifdef PERL_PRESERVE_IVUV
1902 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1904 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1910 SETs(boolSV(TOPn <= value));
1917 dSP; tryAMAGICbinSET(ge,0);
1918 #ifdef PERL_PRESERVE_IVUV
1921 SvIV_please(TOPm1s);
1922 if (SvIOK(TOPm1s)) {
1923 bool auvok = SvUOK(TOPm1s);
1924 bool buvok = SvUOK(TOPs);
1926 if (!auvok && !buvok) { /* ## IV >= IV ## */
1927 IV aiv = SvIVX(TOPm1s);
1928 IV biv = SvIVX(TOPs);
1931 SETs(boolSV(aiv >= biv));
1934 if (auvok && buvok) { /* ## UV >= UV ## */
1935 UV auv = SvUVX(TOPm1s);
1936 UV buv = SvUVX(TOPs);
1939 SETs(boolSV(auv >= buv));
1942 if (auvok) { /* ## UV >= IV ## */
1949 /* As (a) is a UV, it's >=0, so it must be >= */
1954 SETs(boolSV(auv >= (UV)biv));
1957 { /* ## IV >= UV ## */
1961 aiv = SvIVX(TOPm1s);
1963 /* As (b) is a UV, it's >=0, so a cannot be >= */
1970 SETs(boolSV((UV)aiv >= buv));
1976 #ifndef NV_PRESERVES_UV
1977 #ifdef PERL_PRESERVE_IVUV
1980 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1982 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1988 SETs(boolSV(TOPn >= value));
1995 dSP; tryAMAGICbinSET(ne,0);
1996 #ifndef NV_PRESERVES_UV
1997 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1999 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2003 #ifdef PERL_PRESERVE_IVUV
2006 SvIV_please(TOPm1s);
2007 if (SvIOK(TOPm1s)) {
2008 bool auvok = SvUOK(TOPm1s);
2009 bool buvok = SvUOK(TOPs);
2011 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2012 /* Casting IV to UV before comparison isn't going to matter
2013 on 2s complement. On 1s complement or sign&magnitude
2014 (if we have any of them) it could make negative zero
2015 differ from normal zero. As I understand it. (Need to
2016 check - is negative zero implementation defined behaviour
2018 UV buv = SvUVX(POPs);
2019 UV auv = SvUVX(TOPs);
2021 SETs(boolSV(auv != buv));
2024 { /* ## Mixed IV,UV ## */
2028 /* != is commutative so swap if needed (save code) */
2030 /* swap. top of stack (b) is the iv */
2034 /* As (a) is a UV, it's >0, so it cannot be == */
2043 /* As (b) is a UV, it's >0, so it cannot be == */
2047 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2049 SETs(boolSV((UV)iv != uv));
2057 SETs(boolSV(TOPn != value));
2064 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2065 #ifndef NV_PRESERVES_UV
2066 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2067 UV right = PTR2UV(SvRV(POPs));
2068 UV left = PTR2UV(SvRV(TOPs));
2069 SETi((left > right) - (left < right));
2073 #ifdef PERL_PRESERVE_IVUV
2074 /* Fortunately it seems NaN isn't IOK */
2077 SvIV_please(TOPm1s);
2078 if (SvIOK(TOPm1s)) {
2079 bool leftuvok = SvUOK(TOPm1s);
2080 bool rightuvok = SvUOK(TOPs);
2082 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2083 IV leftiv = SvIVX(TOPm1s);
2084 IV rightiv = SvIVX(TOPs);
2086 if (leftiv > rightiv)
2088 else if (leftiv < rightiv)
2092 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2093 UV leftuv = SvUVX(TOPm1s);
2094 UV rightuv = SvUVX(TOPs);
2096 if (leftuv > rightuv)
2098 else if (leftuv < rightuv)
2102 } else if (leftuvok) { /* ## UV <=> IV ## */
2106 rightiv = SvIVX(TOPs);
2108 /* As (a) is a UV, it's >=0, so it cannot be < */
2111 leftuv = SvUVX(TOPm1s);
2112 if (leftuv > (UV)rightiv) {
2114 } else if (leftuv < (UV)rightiv) {
2120 } else { /* ## IV <=> UV ## */
2124 leftiv = SvIVX(TOPm1s);
2126 /* As (b) is a UV, it's >=0, so it must be < */
2129 rightuv = SvUVX(TOPs);
2130 if ((UV)leftiv > rightuv) {
2132 } else if ((UV)leftiv < rightuv) {
2150 if (Perl_isnan(left) || Perl_isnan(right)) {
2154 value = (left > right) - (left < right);
2158 else if (left < right)
2160 else if (left > right)
2174 dSP; tryAMAGICbinSET(slt,0);
2177 int cmp = (IN_LOCALE_RUNTIME
2178 ? sv_cmp_locale(left, right)
2179 : sv_cmp(left, right));
2180 SETs(boolSV(cmp < 0));
2187 dSP; tryAMAGICbinSET(sgt,0);
2190 int cmp = (IN_LOCALE_RUNTIME
2191 ? sv_cmp_locale(left, right)
2192 : sv_cmp(left, right));
2193 SETs(boolSV(cmp > 0));
2200 dSP; tryAMAGICbinSET(sle,0);
2203 int cmp = (IN_LOCALE_RUNTIME
2204 ? sv_cmp_locale(left, right)
2205 : sv_cmp(left, right));
2206 SETs(boolSV(cmp <= 0));
2213 dSP; tryAMAGICbinSET(sge,0);
2216 int cmp = (IN_LOCALE_RUNTIME
2217 ? sv_cmp_locale(left, right)
2218 : sv_cmp(left, right));
2219 SETs(boolSV(cmp >= 0));
2226 dSP; tryAMAGICbinSET(seq,0);
2229 SETs(boolSV(sv_eq(left, right)));
2236 dSP; tryAMAGICbinSET(sne,0);
2239 SETs(boolSV(!sv_eq(left, right)));
2246 dSP; dTARGET; tryAMAGICbin(scmp,0);
2249 int cmp = (IN_LOCALE_RUNTIME
2250 ? sv_cmp_locale(left, right)
2251 : sv_cmp(left, right));
2259 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2262 if (SvGMAGICAL(left)) mg_get(left);
2263 if (SvGMAGICAL(right)) mg_get(right);
2264 if (SvNIOKp(left) || SvNIOKp(right)) {
2265 if (PL_op->op_private & HINT_INTEGER) {
2266 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2270 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2275 do_vop(PL_op->op_type, TARG, left, right);
2284 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2287 if (SvGMAGICAL(left)) mg_get(left);
2288 if (SvGMAGICAL(right)) mg_get(right);
2289 if (SvNIOKp(left) || SvNIOKp(right)) {
2290 if (PL_op->op_private & HINT_INTEGER) {
2291 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2295 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2300 do_vop(PL_op->op_type, TARG, left, right);
2309 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2312 if (SvGMAGICAL(left)) mg_get(left);
2313 if (SvGMAGICAL(right)) mg_get(right);
2314 if (SvNIOKp(left) || SvNIOKp(right)) {
2315 if (PL_op->op_private & HINT_INTEGER) {
2316 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2320 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2325 do_vop(PL_op->op_type, TARG, left, right);
2334 dSP; dTARGET; tryAMAGICun(neg);
2337 int flags = SvFLAGS(sv);
2340 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2341 /* It's publicly an integer, or privately an integer-not-float */
2344 if (SvIVX(sv) == IV_MIN) {
2345 /* 2s complement assumption. */
2346 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2349 else if (SvUVX(sv) <= IV_MAX) {
2354 else if (SvIVX(sv) != IV_MIN) {
2358 #ifdef PERL_PRESERVE_IVUV
2367 else if (SvPOKp(sv)) {
2369 char *s = SvPV(sv, len);
2370 if (isIDFIRST(*s)) {
2371 sv_setpvn(TARG, "-", 1);
2374 else if (*s == '+' || *s == '-') {
2376 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2378 else if (DO_UTF8(sv)) {
2381 goto oops_its_an_int;
2383 sv_setnv(TARG, -SvNV(sv));
2385 sv_setpvn(TARG, "-", 1);
2392 goto oops_its_an_int;
2393 sv_setnv(TARG, -SvNV(sv));
2405 dSP; tryAMAGICunSET(not);
2406 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2412 dSP; dTARGET; tryAMAGICun(compl);
2418 if (PL_op->op_private & HINT_INTEGER) {
2419 IV i = ~SvIV_nomg(sv);
2423 UV u = ~SvUV_nomg(sv);
2432 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2433 sv_setsv_nomg(TARG, sv);
2434 tmps = (U8*)SvPV_force(TARG, len);
2437 /* Calculate exact length, let's not estimate. */
2446 while (tmps < send) {
2447 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2448 tmps += UTF8SKIP(tmps);
2449 targlen += UNISKIP(~c);
2455 /* Now rewind strings and write them. */
2459 Newz(0, result, targlen + 1, U8);
2460 while (tmps < send) {
2461 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2462 tmps += UTF8SKIP(tmps);
2463 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2467 sv_setpvn(TARG, (char*)result, targlen);
2471 Newz(0, result, nchar + 1, U8);
2472 while (tmps < send) {
2473 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2474 tmps += UTF8SKIP(tmps);
2479 sv_setpvn(TARG, (char*)result, nchar);
2488 register long *tmpl;
2489 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2492 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2497 for ( ; anum > 0; anum--, tmps++)
2506 /* integer versions of some of the above */
2510 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2513 SETi( left * right );
2520 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2524 DIE(aTHX_ "Illegal division by zero");
2525 value = POPi / value;
2534 /* This is the vanilla old i_modulo. */
2535 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2539 DIE(aTHX_ "Illegal modulus zero");
2540 SETi( left % right );
2545 #if defined(__GLIBC__) && IVSIZE == 8
2549 /* This is the i_modulo with the workaround for the _moddi3 bug
2550 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2551 * See below for pp_i_modulo. */
2552 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2556 DIE(aTHX_ "Illegal modulus zero");
2557 SETi( left % PERL_ABS(right) );
2565 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2569 DIE(aTHX_ "Illegal modulus zero");
2570 /* The assumption is to use hereafter the old vanilla version... */
2572 PL_ppaddr[OP_I_MODULO] =
2573 &Perl_pp_i_modulo_0;
2574 /* .. but if we have glibc, we might have a buggy _moddi3
2575 * (at least glicb 2.2.5 is known to have this bug), in other
2576 * words our integer modulus with negative quad as the second
2577 * argument might be broken. Test for this and re-patch the
2578 * opcode dispatch table if that is the case, remembering to
2579 * also apply the workaround so that this first round works
2580 * right, too. See [perl #9402] for more information. */
2581 #if defined(__GLIBC__) && IVSIZE == 8
2585 /* Cannot do this check with inlined IV constants since
2586 * that seems to work correctly even with the buggy glibc. */
2588 /* Yikes, we have the bug.
2589 * Patch in the workaround version. */
2591 PL_ppaddr[OP_I_MODULO] =
2592 &Perl_pp_i_modulo_1;
2593 /* Make certain we work right this time, too. */
2594 right = PERL_ABS(right);
2598 SETi( left % right );
2605 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2608 SETi( left + right );
2615 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2618 SETi( left - right );
2625 dSP; tryAMAGICbinSET(lt,0);
2628 SETs(boolSV(left < right));
2635 dSP; tryAMAGICbinSET(gt,0);
2638 SETs(boolSV(left > right));
2645 dSP; tryAMAGICbinSET(le,0);
2648 SETs(boolSV(left <= right));
2655 dSP; tryAMAGICbinSET(ge,0);
2658 SETs(boolSV(left >= right));
2665 dSP; tryAMAGICbinSET(eq,0);
2668 SETs(boolSV(left == right));
2675 dSP; tryAMAGICbinSET(ne,0);
2678 SETs(boolSV(left != right));
2685 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2692 else if (left < right)
2703 dSP; dTARGET; tryAMAGICun(neg);
2708 /* High falutin' math. */
2712 dSP; dTARGET; tryAMAGICbin(atan2,0);
2715 SETn(Perl_atan2(left, right));
2722 dSP; dTARGET; tryAMAGICun(sin);
2726 value = Perl_sin(value);
2734 dSP; dTARGET; tryAMAGICun(cos);
2738 value = Perl_cos(value);
2744 /* Support Configure command-line overrides for rand() functions.
2745 After 5.005, perhaps we should replace this by Configure support
2746 for drand48(), random(), or rand(). For 5.005, though, maintain
2747 compatibility by calling rand() but allow the user to override it.
2748 See INSTALL for details. --Andy Dougherty 15 July 1998
2750 /* Now it's after 5.005, and Configure supports drand48() and random(),
2751 in addition to rand(). So the overrides should not be needed any more.
2752 --Jarkko Hietaniemi 27 September 1998
2755 #ifndef HAS_DRAND48_PROTO
2756 extern double drand48 (void);
2769 if (!PL_srand_called) {
2770 (void)seedDrand01((Rand_seed_t)seed());
2771 PL_srand_called = TRUE;
2786 (void)seedDrand01((Rand_seed_t)anum);
2787 PL_srand_called = TRUE;
2794 dSP; dTARGET; tryAMAGICun(exp);
2798 value = Perl_exp(value);
2806 dSP; dTARGET; tryAMAGICun(log);
2811 SET_NUMERIC_STANDARD();
2812 DIE(aTHX_ "Can't take log of %"NVgf, value);
2814 value = Perl_log(value);
2822 dSP; dTARGET; tryAMAGICun(sqrt);
2827 SET_NUMERIC_STANDARD();
2828 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2830 value = Perl_sqrt(value);
2838 dSP; dTARGET; tryAMAGICun(int);
2841 IV iv = TOPi; /* attempt to convert to IV if possible. */
2842 /* XXX it's arguable that compiler casting to IV might be subtly
2843 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2844 else preferring IV has introduced a subtle behaviour change bug. OTOH
2845 relying on floating point to be accurate is a bug. */
2849 else if (SvIOK(TOPs)) {
2858 if (value < (NV)UV_MAX + 0.5) {
2861 SETn(Perl_floor(value));
2865 if (value > (NV)IV_MIN - 0.5) {
2868 SETn(Perl_ceil(value));
2878 dSP; dTARGET; tryAMAGICun(abs);
2880 /* This will cache the NV value if string isn't actually integer */
2885 else if (SvIOK(TOPs)) {
2886 /* IVX is precise */
2888 SETu(TOPu); /* force it to be numeric only */
2896 /* 2s complement assumption. Also, not really needed as
2897 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2917 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2923 tmps = (SvPVx(sv, len));
2925 /* If Unicode, try to downgrade
2926 * If not possible, croak. */
2927 SV* tsv = sv_2mortal(newSVsv(sv));
2930 sv_utf8_downgrade(tsv, FALSE);
2933 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2934 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2947 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2953 tmps = (SvPVx(sv, len));
2955 /* If Unicode, try to downgrade
2956 * If not possible, croak. */
2957 SV* tsv = sv_2mortal(newSVsv(sv));
2960 sv_utf8_downgrade(tsv, FALSE);
2963 while (*tmps && len && isSPACE(*tmps))
2968 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2969 else if (*tmps == 'b')
2970 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2972 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2974 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2991 SETi(sv_len_utf8(sv));
3007 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3009 I32 arybase = PL_curcop->cop_arybase;
3013 int num_args = PL_op->op_private & 7;
3014 bool repl_need_utf8_upgrade = FALSE;
3015 bool repl_is_utf8 = FALSE;
3017 SvTAINTED_off(TARG); /* decontaminate */
3018 SvUTF8_off(TARG); /* decontaminate */
3022 repl = SvPV(repl_sv, repl_len);
3023 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3033 sv_utf8_upgrade(sv);
3035 else if (DO_UTF8(sv))
3036 repl_need_utf8_upgrade = TRUE;
3038 tmps = SvPV(sv, curlen);
3040 utf8_curlen = sv_len_utf8(sv);
3041 if (utf8_curlen == curlen)
3044 curlen = utf8_curlen;
3049 if (pos >= arybase) {
3067 else if (len >= 0) {
3069 if (rem > (I32)curlen)
3084 Perl_croak(aTHX_ "substr outside of string");
3085 if (ckWARN(WARN_SUBSTR))
3086 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3093 sv_pos_u2b(sv, &pos, &rem);
3095 /* we either return a PV or an LV. If the TARG hasn't been used
3096 * before, or is of that type, reuse it; otherwise use a mortal
3097 * instead. Note that LVs can have an extended lifetime, so also
3098 * dont reuse if refcount > 1 (bug #20933) */
3099 if (SvTYPE(TARG) > SVt_NULL) {
3100 if ( (SvTYPE(TARG) == SVt_PVLV)
3101 ? (!lvalue || SvREFCNT(TARG) > 1)
3104 TARG = sv_newmortal();
3108 sv_setpvn(TARG, tmps, rem);
3109 #ifdef USE_LOCALE_COLLATE
3110 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3115 SV* repl_sv_copy = NULL;
3117 if (repl_need_utf8_upgrade) {
3118 repl_sv_copy = newSVsv(repl_sv);
3119 sv_utf8_upgrade(repl_sv_copy);
3120 repl = SvPV(repl_sv_copy, repl_len);
3121 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3123 sv_insert(sv, pos, rem, repl, repl_len);
3127 SvREFCNT_dec(repl_sv_copy);
3129 else if (lvalue) { /* it's an lvalue! */
3130 if (!SvGMAGICAL(sv)) {
3134 if (ckWARN(WARN_SUBSTR))
3135 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3136 "Attempt to use reference as lvalue in substr");
3138 if (SvOK(sv)) /* is it defined ? */
3139 (void)SvPOK_only_UTF8(sv);
3141 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3144 if (SvTYPE(TARG) < SVt_PVLV) {
3145 sv_upgrade(TARG, SVt_PVLV);
3146 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3152 if (LvTARG(TARG) != sv) {
3154 SvREFCNT_dec(LvTARG(TARG));
3155 LvTARG(TARG) = SvREFCNT_inc(sv);
3157 LvTARGOFF(TARG) = upos;
3158 LvTARGLEN(TARG) = urem;
3162 PUSHs(TARG); /* avoid SvSETMAGIC here */
3169 register IV size = POPi;
3170 register IV offset = POPi;
3171 register SV *src = POPs;
3172 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3174 SvTAINTED_off(TARG); /* decontaminate */
3175 if (lvalue) { /* it's an lvalue! */
3176 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3177 TARG = sv_newmortal();
3178 if (SvTYPE(TARG) < SVt_PVLV) {
3179 sv_upgrade(TARG, SVt_PVLV);
3180 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3183 if (LvTARG(TARG) != src) {
3185 SvREFCNT_dec(LvTARG(TARG));
3186 LvTARG(TARG) = SvREFCNT_inc(src);
3188 LvTARGOFF(TARG) = offset;
3189 LvTARGLEN(TARG) = size;
3192 sv_setuv(TARG, do_vecget(src, offset, size));
3207 I32 arybase = PL_curcop->cop_arybase;
3212 offset = POPi - arybase;
3215 tmps = SvPV(big, biglen);
3216 if (offset > 0 && DO_UTF8(big))
3217 sv_pos_u2b(big, &offset, 0);
3220 else if (offset > (I32)biglen)
3222 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3223 (unsigned char*)tmps + biglen, little, 0)))
3226 retval = tmps2 - tmps;
3227 if (retval > 0 && DO_UTF8(big))
3228 sv_pos_b2u(big, &retval);
3229 PUSHi(retval + arybase);
3244 I32 arybase = PL_curcop->cop_arybase;
3250 tmps2 = SvPV(little, llen);
3251 tmps = SvPV(big, blen);
3255 if (offset > 0 && DO_UTF8(big))
3256 sv_pos_u2b(big, &offset, 0);
3257 offset = offset - arybase + llen;
3261 else if (offset > (I32)blen)
3263 if (!(tmps2 = rninstr(tmps, tmps + offset,
3264 tmps2, tmps2 + llen)))
3267 retval = tmps2 - tmps;
3268 if (retval > 0 && DO_UTF8(big))
3269 sv_pos_b2u(big, &retval);
3270 PUSHi(retval + arybase);
3276 dSP; dMARK; dORIGMARK; dTARGET;
3277 do_sprintf(TARG, SP-MARK, MARK+1);
3278 TAINT_IF(SvTAINTED(TARG));
3279 if (DO_UTF8(*(MARK+1)))
3291 U8 *s = (U8*)SvPVx(argsv, len);
3294 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3295 tmpsv = sv_2mortal(newSVsv(argsv));
3296 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3300 XPUSHu(DO_UTF8(argsv) ?
3301 utf8n_to_uvchr(s, UTF8_MAXLEN, 0, UTF8_ALLOW_ANYUV) :
3313 (void)SvUPGRADE(TARG,SVt_PV);
3315 if (value > 255 && !IN_BYTES) {
3316 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3317 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3318 SvCUR_set(TARG, tmps - SvPVX(TARG));
3320 (void)SvPOK_only(TARG);
3329 *tmps++ = (char)value;
3331 (void)SvPOK_only(TARG);
3332 if (PL_encoding && !IN_BYTES) {
3333 sv_recode_to_utf8(TARG, PL_encoding);
3335 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3336 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3340 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3341 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3357 char *tmps = SvPV(left, len);
3359 if (DO_UTF8(left)) {
3360 /* If Unicode, try to downgrade.
3361 * If not possible, croak.
3362 * Yes, we made this up. */
3363 SV* tsv = sv_2mortal(newSVsv(left));
3366 sv_utf8_downgrade(tsv, FALSE);
3369 # ifdef USE_ITHREADS
3371 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3372 /* This should be threadsafe because in ithreads there is only
3373 * one thread per interpreter. If this would not be true,
3374 * we would need a mutex to protect this malloc. */
3375 PL_reentrant_buffer->_crypt_struct_buffer =
3376 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3377 #if defined(__GLIBC__) || defined(__EMX__)
3378 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3379 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3380 /* work around glibc-2.2.5 bug */
3381 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3385 # endif /* HAS_CRYPT_R */
3386 # endif /* USE_ITHREADS */
3388 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3390 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3396 "The crypt() function is unimplemented due to excessive paranoia.");
3409 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3410 UTF8_IS_START(*s)) {
3411 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3415 utf8_to_uvchr(s, &ulen);
3416 toTITLE_utf8(s, tmpbuf, &tculen);
3417 utf8_to_uvchr(tmpbuf, 0);
3419 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3421 /* slen is the byte length of the whole SV.
3422 * ulen is the byte length of the original Unicode character
3423 * stored as UTF-8 at s.
3424 * tculen is the byte length of the freshly titlecased
3425 * Unicode character stored as UTF-8 at tmpbuf.
3426 * We first set the result to be the titlecased character,
3427 * and then append the rest of the SV data. */
3428 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3430 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3435 s = (U8*)SvPV_force_nomg(sv, slen);
3436 Copy(tmpbuf, s, tculen, U8);
3440 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3442 SvUTF8_off(TARG); /* decontaminate */
3443 sv_setsv_nomg(TARG, sv);
3447 s = (U8*)SvPV_force_nomg(sv, slen);
3449 if (IN_LOCALE_RUNTIME) {
3452 *s = toUPPER_LC(*s);
3471 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3472 UTF8_IS_START(*s)) {
3474 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3478 toLOWER_utf8(s, tmpbuf, &ulen);
3479 uv = utf8_to_uvchr(tmpbuf, 0);
3480 tend = uvchr_to_utf8(tmpbuf, uv);
3482 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3484 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3486 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3491 s = (U8*)SvPV_force_nomg(sv, slen);
3492 Copy(tmpbuf, s, ulen, U8);
3496 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3498 SvUTF8_off(TARG); /* decontaminate */
3499 sv_setsv_nomg(TARG, sv);
3503 s = (U8*)SvPV_force_nomg(sv, slen);
3505 if (IN_LOCALE_RUNTIME) {
3508 *s = toLOWER_LC(*s);
3531 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3533 s = (U8*)SvPV_nomg(sv,len);
3535 SvUTF8_off(TARG); /* decontaminate */
3536 sv_setpvn(TARG, "", 0);
3540 STRLEN nchar = utf8_length(s, s + len);
3542 (void)SvUPGRADE(TARG, SVt_PV);
3543 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3544 (void)SvPOK_only(TARG);
3545 d = (U8*)SvPVX(TARG);
3548 toUPPER_utf8(s, tmpbuf, &ulen);
3549 Copy(tmpbuf, d, ulen, U8);
3555 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3560 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3562 SvUTF8_off(TARG); /* decontaminate */
3563 sv_setsv_nomg(TARG, sv);
3567 s = (U8*)SvPV_force_nomg(sv, len);
3569 register U8 *send = s + len;
3571 if (IN_LOCALE_RUNTIME) {
3574 for (; s < send; s++)
3575 *s = toUPPER_LC(*s);
3578 for (; s < send; s++)
3600 U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
3602 s = (U8*)SvPV_nomg(sv,len);
3604 SvUTF8_off(TARG); /* decontaminate */
3605 sv_setpvn(TARG, "", 0);
3609 STRLEN nchar = utf8_length(s, s + len);
3611 (void)SvUPGRADE(TARG, SVt_PV);
3612 SvGROW(TARG, (nchar * UTF8_MAXLEN_UCLC) + 1);
3613 (void)SvPOK_only(TARG);
3614 d = (U8*)SvPVX(TARG);
3617 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3618 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
3619 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3621 * Now if the sigma is NOT followed by
3622 * /$ignorable_sequence$cased_letter/;
3623 * and it IS preceded by
3624 * /$cased_letter$ignorable_sequence/;
3625 * where $ignorable_sequence is
3626 * [\x{2010}\x{AD}\p{Mn}]*
3627 * and $cased_letter is
3628 * [\p{Ll}\p{Lo}\p{Lt}]
3629 * then it should be mapped to 0x03C2,
3630 * (GREEK SMALL LETTER FINAL SIGMA),
3631 * instead of staying 0x03A3.
3632 * See lib/unicore/SpecCase.txt.
3635 Copy(tmpbuf, d, ulen, U8);
3641 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3646 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3648 SvUTF8_off(TARG); /* decontaminate */
3649 sv_setsv_nomg(TARG, sv);
3654 s = (U8*)SvPV_force_nomg(sv, len);
3656 register U8 *send = s + len;
3658 if (IN_LOCALE_RUNTIME) {
3661 for (; s < send; s++)
3662 *s = toLOWER_LC(*s);
3665 for (; s < send; s++)
3679 register char *s = SvPV(sv,len);
3682 SvUTF8_off(TARG); /* decontaminate */
3684 (void)SvUPGRADE(TARG, SVt_PV);
3685 SvGROW(TARG, (len * 2) + 1);
3689 if (UTF8_IS_CONTINUED(*s)) {
3690 STRLEN ulen = UTF8SKIP(s);
3714 SvCUR_set(TARG, d - SvPVX(TARG));
3715 (void)SvPOK_only_UTF8(TARG);
3718 sv_setpvn(TARG, s, len);
3720 if (SvSMAGICAL(TARG))
3729 dSP; dMARK; dORIGMARK;
3731 register AV* av = (AV*)POPs;
3732 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3733 I32 arybase = PL_curcop->cop_arybase;
3736 if (SvTYPE(av) == SVt_PVAV) {
3737 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3739 for (svp = MARK + 1; svp <= SP; svp++) {
3744 if (max > AvMAX(av))
3747 while (++MARK <= SP) {
3748 elem = SvIVx(*MARK);
3752 svp = av_fetch(av, elem, lval);
3754 if (!svp || *svp == &PL_sv_undef)
3755 DIE(aTHX_ PL_no_aelem, elem);
3756 if (PL_op->op_private & OPpLVAL_INTRO)
3757 save_aelem(av, elem, svp);
3759 *MARK = svp ? *svp : &PL_sv_undef;
3762 if (GIMME != G_ARRAY) {
3764 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3770 /* Associative arrays. */
3775 HV *hash = (HV*)POPs;
3777 I32 gimme = GIMME_V;
3780 /* might clobber stack_sp */
3781 entry = hv_iternext(hash);
3786 SV* sv = hv_iterkeysv(entry);
3787 PUSHs(sv); /* won't clobber stack_sp */
3788 if (gimme == G_ARRAY) {
3791 /* might clobber stack_sp */
3792 val = hv_iterval(hash, entry);
3797 else if (gimme == G_SCALAR)
3816 I32 gimme = GIMME_V;
3817 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3821 if (PL_op->op_private & OPpSLICE) {
3825 hvtype = SvTYPE(hv);
3826 if (hvtype == SVt_PVHV) { /* hash element */
3827 while (++MARK <= SP) {
3828 sv = hv_delete_ent(hv, *MARK, discard, 0);
3829 *MARK = sv ? sv : &PL_sv_undef;
3832 else if (hvtype == SVt_PVAV) { /* array element */
3833 if (PL_op->op_flags & OPf_SPECIAL) {
3834 while (++MARK <= SP) {
3835 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3836 *MARK = sv ? sv : &PL_sv_undef;
3841 DIE(aTHX_ "Not a HASH reference");
3844 else if (gimme == G_SCALAR) {
3849 *++MARK = &PL_sv_undef;
3856 if (SvTYPE(hv) == SVt_PVHV)
3857 sv = hv_delete_ent(hv, keysv, discard, 0);
3858 else if (SvTYPE(hv) == SVt_PVAV) {
3859 if (PL_op->op_flags & OPf_SPECIAL)
3860 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3862 DIE(aTHX_ "panic: avhv_delete no longer supported");
3865 DIE(aTHX_ "Not a HASH reference");
3880 if (PL_op->op_private & OPpEXISTS_SUB) {
3884 cv = sv_2cv(sv, &hv, &gv, FALSE);
3887 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3893 if (SvTYPE(hv) == SVt_PVHV) {
3894 if (hv_exists_ent(hv, tmpsv, 0))
3897 else if (SvTYPE(hv) == SVt_PVAV) {
3898 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3899 if (av_exists((AV*)hv, SvIV(tmpsv)))
3904 DIE(aTHX_ "Not a HASH reference");
3911 dSP; dMARK; dORIGMARK;
3912 register HV *hv = (HV*)POPs;
3913 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3914 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3915 bool other_magic = FALSE;
3921 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3922 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3923 /* Try to preserve the existenceness of a tied hash
3924 * element by using EXISTS and DELETE if possible.
3925 * Fallback to FETCH and STORE otherwise */
3926 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3927 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3928 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3931 while (++MARK <= SP) {
3935 bool preeminent = FALSE;
3938 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3939 hv_exists_ent(hv, keysv, 0);
3942 he = hv_fetch_ent(hv, keysv, lval, 0);
3943 svp = he ? &HeVAL(he) : 0;
3946 if (!svp || *svp == &PL_sv_undef) {
3948 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
3952 save_helem(hv, keysv, svp);
3955 char *key = SvPV(keysv, keylen);
3956 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3960 *MARK = svp ? *svp : &PL_sv_undef;
3962 if (GIMME != G_ARRAY) {
3964 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3970 /* List operators. */
3975 if (GIMME != G_ARRAY) {
3977 *MARK = *SP; /* unwanted list, return last item */
3979 *MARK = &PL_sv_undef;
3988 SV **lastrelem = PL_stack_sp;
3989 SV **lastlelem = PL_stack_base + POPMARK;
3990 SV **firstlelem = PL_stack_base + POPMARK + 1;
3991 register SV **firstrelem = lastlelem + 1;
3992 I32 arybase = PL_curcop->cop_arybase;
3993 I32 lval = PL_op->op_flags & OPf_MOD;
3994 I32 is_something_there = lval;
3996 register I32 max = lastrelem - lastlelem;
3997 register SV **lelem;
4000 if (GIMME != G_ARRAY) {
4001 ix = SvIVx(*lastlelem);
4006 if (ix < 0 || ix >= max)
4007 *firstlelem = &PL_sv_undef;
4009 *firstlelem = firstrelem[ix];
4015 SP = firstlelem - 1;
4019 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4025 if (ix < 0 || ix >= max)
4026 *lelem = &PL_sv_undef;
4028 is_something_there = TRUE;
4029 if (!(*lelem = firstrelem[ix]))
4030 *lelem = &PL_sv_undef;
4033 if (is_something_there)
4036 SP = firstlelem - 1;
4042 dSP; dMARK; dORIGMARK;
4043 I32 items = SP - MARK;
4044 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4045 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4052 dSP; dMARK; dORIGMARK;
4053 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4057 SV *val = NEWSV(46, 0);
4059 sv_setsv(val, *++MARK);
4060 else if (ckWARN(WARN_MISC))
4061 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4062 (void)hv_store_ent(hv,key,val,0);
4071 dSP; dMARK; dORIGMARK;
4072 register AV *ary = (AV*)*++MARK;
4076 register I32 offset;
4077 register I32 length;
4084 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4085 *MARK-- = SvTIED_obj((SV*)ary, mg);
4089 call_method("SPLICE",GIMME_V);
4098 offset = i = SvIVx(*MARK);
4100 offset += AvFILLp(ary) + 1;
4102 offset -= PL_curcop->cop_arybase;
4104 DIE(aTHX_ PL_no_aelem, i);
4106 length = SvIVx(*MARK++);
4108 length += AvFILLp(ary) - offset + 1;
4114 length = AvMAX(ary) + 1; /* close enough to infinity */
4118 length = AvMAX(ary) + 1;
4120 if (offset > AvFILLp(ary) + 1) {
4121 if (ckWARN(WARN_MISC))
4122 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4123 offset = AvFILLp(ary) + 1;
4125 after = AvFILLp(ary) + 1 - (offset + length);
4126 if (after < 0) { /* not that much array */
4127 length += after; /* offset+length now in array */
4133 /* At this point, MARK .. SP-1 is our new LIST */
4136 diff = newlen - length;
4137 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4140 /* make new elements SVs now: avoid problems if they're from the array */
4141 for (dst = MARK, i = newlen; i; i--) {
4143 *dst = NEWSV(46, 0);
4144 sv_setsv(*dst++, h);
4147 if (diff < 0) { /* shrinking the area */
4149 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4150 Copy(MARK, tmparyval, newlen, SV*);
4153 MARK = ORIGMARK + 1;
4154 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4155 MEXTEND(MARK, length);
4156 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4158 EXTEND_MORTAL(length);
4159 for (i = length, dst = MARK; i; i--) {
4160 sv_2mortal(*dst); /* free them eventualy */
4167 *MARK = AvARRAY(ary)[offset+length-1];
4170 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4171 SvREFCNT_dec(*dst++); /* free them now */
4174 AvFILLp(ary) += diff;
4176 /* pull up or down? */
4178 if (offset < after) { /* easier to pull up */
4179 if (offset) { /* esp. if nothing to pull */
4180 src = &AvARRAY(ary)[offset-1];
4181 dst = src - diff; /* diff is negative */
4182 for (i = offset; i > 0; i--) /* can't trust Copy */
4186 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
4190 if (after) { /* anything to pull down? */
4191 src = AvARRAY(ary) + offset + length;
4192 dst = src + diff; /* diff is negative */
4193 Move(src, dst, after, SV*);
4195 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4196 /* avoid later double free */
4200 dst[--i] = &PL_sv_undef;
4203 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4204 Safefree(tmparyval);
4207 else { /* no, expanding (or same) */
4209 New(452, tmparyval, length, SV*); /* so remember deletion */
4210 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4213 if (diff > 0) { /* expanding */
4215 /* push up or down? */
4217 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4221 Move(src, dst, offset, SV*);
4223 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
4225 AvFILLp(ary) += diff;
4228 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4229 av_extend(ary, AvFILLp(ary) + diff);
4230 AvFILLp(ary) += diff;
4233 dst = AvARRAY(ary) + AvFILLp(ary);
4235 for (i = after; i; i--) {
4243 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4246 MARK = ORIGMARK + 1;
4247 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4249 Copy(tmparyval, MARK, length, SV*);
4251 EXTEND_MORTAL(length);
4252 for (i = length, dst = MARK; i; i--) {
4253 sv_2mortal(*dst); /* free them eventualy */
4257 Safefree(tmparyval);
4261 else if (length--) {
4262 *MARK = tmparyval[length];
4265 while (length-- > 0)
4266 SvREFCNT_dec(tmparyval[length]);
4268 Safefree(tmparyval);
4271 *MARK = &PL_sv_undef;
4279 dSP; dMARK; dORIGMARK; dTARGET;
4280 register AV *ary = (AV*)*++MARK;
4281 register SV *sv = &PL_sv_undef;
4284 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4285 *MARK-- = SvTIED_obj((SV*)ary, mg);
4289 call_method("PUSH",G_SCALAR|G_DISCARD);
4294 /* Why no pre-extend of ary here ? */
4295 for (++MARK; MARK <= SP; MARK++) {
4298 sv_setsv(sv, *MARK);
4303 PUSHi( AvFILL(ary) + 1 );
4311 SV *sv = av_pop(av);
4313 (void)sv_2mortal(sv);
4322 SV *sv = av_shift(av);
4327 (void)sv_2mortal(sv);
4334 dSP; dMARK; dORIGMARK; dTARGET;
4335 register AV *ary = (AV*)*++MARK;
4340 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4341 *MARK-- = SvTIED_obj((SV*)ary, mg);
4345 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4350 av_unshift(ary, SP - MARK);
4353 sv_setsv(sv, *++MARK);
4354 (void)av_store(ary, i++, sv);
4358 PUSHi( AvFILL(ary) + 1 );
4368 if (GIMME == G_ARRAY) {
4375 /* safe as long as stack cannot get extended in the above */
4380 register char *down;
4386 SvUTF8_off(TARG); /* decontaminate */
4388 do_join(TARG, &PL_sv_no, MARK, SP);
4390 sv_setsv(TARG, (SP > MARK)
4392 : (padoff_du = find_rundefsvoffset(),
4393 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4394 ? DEFSV : PAD_SVl(padoff_du)));
4395 up = SvPV_force(TARG, len);
4397 if (DO_UTF8(TARG)) { /* first reverse each character */
4398 U8* s = (U8*)SvPVX(TARG);
4399 U8* send = (U8*)(s + len);
4401 if (UTF8_IS_INVARIANT(*s)) {
4406 if (!utf8_to_uvchr(s, 0))
4410 down = (char*)(s - 1);
4411 /* reverse this character */
4415 *down-- = (char)tmp;
4421 down = SvPVX(TARG) + len - 1;
4425 *down-- = (char)tmp;
4427 (void)SvPOK_only_UTF8(TARG);
4439 register IV limit = POPi; /* note, negative is forever */
4442 register char *s = SvPV(sv, len);
4443 bool do_utf8 = DO_UTF8(sv);
4444 char *strend = s + len;
4446 register REGEXP *rx;
4450 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4451 I32 maxiters = slen + 10;
4454 I32 origlimit = limit;
4457 I32 gimme = GIMME_V;
4458 I32 oldsave = PL_savestack_ix;
4459 I32 make_mortal = 1;
4461 MAGIC *mg = (MAGIC *) NULL;
4464 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4469 DIE(aTHX_ "panic: pp_split");
4472 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4473 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4475 RX_MATCH_UTF8_set(rx, do_utf8);
4477 if (pm->op_pmreplroot) {
4479 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4481 ary = GvAVn((GV*)pm->op_pmreplroot);
4484 else if (gimme != G_ARRAY)
4485 ary = GvAVn(PL_defgv);
4488 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4494 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4496 XPUSHs(SvTIED_obj((SV*)ary, mg));
4502 for (i = AvFILLp(ary); i >= 0; i--)
4503 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4505 /* temporarily switch stacks */
4506 SAVESWITCHSTACK(PL_curstack, ary);
4510 base = SP - PL_stack_base;
4512 if (pm->op_pmflags & PMf_SKIPWHITE) {
4513 if (pm->op_pmflags & PMf_LOCALE) {
4514 while (isSPACE_LC(*s))
4522 if (pm->op_pmflags & PMf_MULTILINE) {
4527 limit = maxiters + 2;
4528 if (pm->op_pmflags & PMf_WHITE) {
4531 while (m < strend &&
4532 !((pm->op_pmflags & PMf_LOCALE)
4533 ? isSPACE_LC(*m) : isSPACE(*m)))
4538 dstr = NEWSV(30, m-s);
4539 sv_setpvn(dstr, s, m-s);
4543 (void)SvUTF8_on(dstr);
4547 while (s < strend &&
4548 ((pm->op_pmflags & PMf_LOCALE)
4549 ? isSPACE_LC(*s) : isSPACE(*s)))
4553 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4556 for (m = s; m < strend && *m != '\n'; m++) ;
4560 dstr = NEWSV(30, m-s);
4561 sv_setpvn(dstr, s, m-s);
4565 (void)SvUTF8_on(dstr);
4570 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4571 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4572 && (rx->reganch & ROPT_CHECK_ALL)
4573 && !(rx->reganch & ROPT_ANCH)) {
4574 int tail = (rx->reganch & RE_INTUIT_TAIL);
4575 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4578 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4580 char c = *SvPV(csv, n_a);
4583 for (m = s; m < strend && *m != c; m++) ;
4586 dstr = NEWSV(30, m-s);
4587 sv_setpvn(dstr, s, m-s);
4591 (void)SvUTF8_on(dstr);
4593 /* The rx->minlen is in characters but we want to step
4594 * s ahead by bytes. */
4596 s = (char*)utf8_hop((U8*)m, len);
4598 s = m + len; /* Fake \n at the end */
4603 while (s < strend && --limit &&
4604 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4605 csv, multiline ? FBMrf_MULTILINE : 0)) )
4608 dstr = NEWSV(31, m-s);
4609 sv_setpvn(dstr, s, m-s);
4613 (void)SvUTF8_on(dstr);
4615 /* The rx->minlen is in characters but we want to step
4616 * s ahead by bytes. */
4618 s = (char*)utf8_hop((U8*)m, len);
4620 s = m + len; /* Fake \n at the end */
4625 maxiters += slen * rx->nparens;
4626 while (s < strend && --limit)
4629 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4633 TAINT_IF(RX_MATCH_TAINTED(rx));
4634 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4639 strend = s + (strend - m);
4641 m = rx->startp[0] + orig;
4642 dstr = NEWSV(32, m-s);
4643 sv_setpvn(dstr, s, m-s);
4647 (void)SvUTF8_on(dstr);
4650 for (i = 1; i <= (I32)rx->nparens; i++) {
4651 s = rx->startp[i] + orig;
4652 m = rx->endp[i] + orig;
4654 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4655 parens that didn't match -- they should be set to
4656 undef, not the empty string */
4657 if (m >= orig && s >= orig) {
4658 dstr = NEWSV(33, m-s);
4659 sv_setpvn(dstr, s, m-s);
4662 dstr = &PL_sv_undef; /* undef, not "" */
4666 (void)SvUTF8_on(dstr);
4670 s = rx->endp[0] + orig;
4674 iters = (SP - PL_stack_base) - base;
4675 if (iters > maxiters)
4676 DIE(aTHX_ "Split loop");
4678 /* keep field after final delim? */
4679 if (s < strend || (iters && origlimit)) {
4680 STRLEN l = strend - s;
4681 dstr = NEWSV(34, l);
4682 sv_setpvn(dstr, s, l);
4686 (void)SvUTF8_on(dstr);
4690 else if (!origlimit) {
4691 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4692 if (TOPs && !make_mortal)
4695 *SP-- = &PL_sv_undef;
4700 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4704 if (SvSMAGICAL(ary)) {
4709 if (gimme == G_ARRAY) {
4711 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4719 call_method("PUSH",G_SCALAR|G_DISCARD);
4722 if (gimme == G_ARRAY) {
4723 /* EXTEND should not be needed - we just popped them */
4725 for (i=0; i < iters; i++) {
4726 SV **svp = av_fetch(ary, i, FALSE);
4727 PUSHs((svp) ? *svp : &PL_sv_undef);
4734 if (gimme == G_ARRAY)
4749 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4750 || SvTYPE(retsv) == SVt_PVCV) {
4751 retsv = refto(retsv);
4759 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");