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 I32 maxarg = AvFILL((AV*)TARG) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV **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* sv = sv_newmortal();
97 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* 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 *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) {
172 if (cUNOP->op_targ) {
174 SV *namesv = PAD_SV(cUNOP->op_targ);
175 name = SvPV(namesv, len);
176 gv = (GV*)NEWSV(0,0);
177 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
180 name = CopSTASHPV(PL_curcop);
183 if (SvTYPE(sv) < SVt_RV)
184 sv_upgrade(sv, SVt_RV);
190 SvRV_set(sv, (SV*)gv);
195 if (PL_op->op_flags & OPf_REF ||
196 PL_op->op_private & HINT_STRICT_REFS)
197 DIE(aTHX_ PL_no_usym, "a symbol");
198 if (ckWARN(WARN_UNINITIALIZED))
202 if ((PL_op->op_flags & OPf_SPECIAL) &&
203 !(PL_op->op_flags & OPf_MOD))
205 SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
207 && (!is_gv_magical_sv(sv,0)
208 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
214 if (PL_op->op_private & HINT_STRICT_REFS)
215 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
216 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
220 if (PL_op->op_private & OPpLVAL_INTRO)
221 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
233 tryAMAGICunDEREF(to_sv);
236 switch (SvTYPE(sv)) {
240 DIE(aTHX_ "Not a SCALAR reference");
246 if (SvTYPE(gv) != SVt_PVGV) {
247 if (SvGMAGICAL(sv)) {
253 if (PL_op->op_flags & OPf_REF ||
254 PL_op->op_private & HINT_STRICT_REFS)
255 DIE(aTHX_ PL_no_usym, "a SCALAR");
256 if (ckWARN(WARN_UNINITIALIZED))
260 if ((PL_op->op_flags & OPf_SPECIAL) &&
261 !(PL_op->op_flags & OPf_MOD))
263 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
265 && (!is_gv_magical_sv(sv, 0)
266 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
272 if (PL_op->op_private & HINT_STRICT_REFS)
273 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
274 gv = (GV*)gv_fetchsv(sv, 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 const char *name = HvNAME(GvSTASH(gv));
608 sv = newSVpv(name ? name : "__ANON__", 0);
612 if (strEQ(elem2, "CALAR"))
627 /* Pattern matching */
632 register unsigned char *s;
635 register I32 *sfirst;
639 if (sv == PL_lastscream) {
645 SvSCREAM_off(PL_lastscream);
646 SvREFCNT_dec(PL_lastscream);
648 PL_lastscream = SvREFCNT_inc(sv);
651 s = (unsigned char*)(SvPV(sv, len));
655 if (pos > PL_maxscream) {
656 if (PL_maxscream < 0) {
657 PL_maxscream = pos + 80;
658 New(301, PL_screamfirst, 256, I32);
659 New(302, PL_screamnext, PL_maxscream, I32);
662 PL_maxscream = pos + pos / 4;
663 Renew(PL_screamnext, PL_maxscream, I32);
667 sfirst = PL_screamfirst;
668 snext = PL_screamnext;
670 if (!sfirst || !snext)
671 DIE(aTHX_ "do_study: out of memory");
673 for (ch = 256; ch; --ch)
680 snext[pos] = sfirst[ch] - pos;
687 /* piggyback on m//g magic */
688 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
697 if (PL_op->op_flags & OPf_STACKED)
699 else if (PL_op->op_private & OPpTARGET_MY)
705 TARG = sv_newmortal();
710 /* Lvalue operators. */
722 dSP; dMARK; dTARGET; dORIGMARK;
724 do_chop(TARG, *++MARK);
733 SETi(do_chomp(TOPs));
740 register I32 count = 0;
743 count += do_chomp(POPs);
754 if (!sv || !SvANY(sv))
756 switch (SvTYPE(sv)) {
758 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
759 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
763 if (HvARRAY(sv) || SvGMAGICAL(sv)
764 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
768 if (CvROOT(sv) || CvXSUB(sv))
785 if (!PL_op->op_private) {
794 SV_CHECK_THINKFIRST_COW_DROP(sv);
796 switch (SvTYPE(sv)) {
806 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
807 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
808 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
812 /* let user-undef'd sub keep its identity */
813 GV* gv = CvGV((CV*)sv);
820 SvSetMagicSV(sv, &PL_sv_undef);
824 Newz(602, gp, 1, GP);
825 GvGP(sv) = gp_ref(gp);
826 GvSV(sv) = NEWSV(72,0);
827 GvLINE(sv) = CopLINE(PL_curcop);
833 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
835 SvPV_set(sv, Nullch);
848 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
849 DIE(aTHX_ PL_no_modify);
850 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
851 && SvIVX(TOPs) != IV_MIN)
853 SvIV_set(TOPs, SvIVX(TOPs) - 1);
854 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
865 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
866 DIE(aTHX_ PL_no_modify);
867 sv_setsv(TARG, TOPs);
868 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
869 && SvIVX(TOPs) != IV_MAX)
871 SvIV_set(TOPs, SvIVX(TOPs) + 1);
872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
877 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
887 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
888 DIE(aTHX_ PL_no_modify);
889 sv_setsv(TARG, TOPs);
890 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
891 && SvIVX(TOPs) != IV_MIN)
893 SvIV_set(TOPs, SvIVX(TOPs) - 1);
894 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
903 /* Ordinary operators. */
908 #ifdef PERL_PRESERVE_IVUV
911 tryAMAGICbin(pow,opASSIGN);
912 #ifdef PERL_PRESERVE_IVUV
913 /* For integer to integer power, we do the calculation by hand wherever
914 we're sure it is safe; otherwise we call pow() and try to convert to
915 integer afterwards. */
919 bool baseuok = SvUOK(TOPm1s);
923 baseuv = SvUVX(TOPm1s);
925 IV iv = SvIVX(TOPm1s);
928 baseuok = TRUE; /* effectively it's a UV now */
930 baseuv = -iv; /* abs, baseuok == false records sign */
944 goto float_it; /* Can't do negative powers this way. */
947 /* now we have integer ** positive integer. */
950 /* foo & (foo - 1) is zero only for a power of 2. */
951 if (!(baseuv & (baseuv - 1))) {
952 /* We are raising power-of-2 to a positive integer.
953 The logic here will work for any base (even non-integer
954 bases) but it can be less accurate than
955 pow (base,power) or exp (power * log (base)) when the
956 intermediate values start to spill out of the mantissa.
957 With powers of 2 we know this can't happen.
958 And powers of 2 are the favourite thing for perl
959 programmers to notice ** not doing what they mean. */
961 NV base = baseuok ? baseuv : -(NV)baseuv;
964 for (; power; base *= base, n++) {
965 /* Do I look like I trust gcc with long longs here?
967 UV bit = (UV)1 << (UV)n;
970 /* Only bother to clear the bit if it is set. */
972 /* Avoid squaring base again if we're done. */
973 if (power == 0) break;
981 register unsigned int highbit = 8 * sizeof(UV);
982 register unsigned int lowbit = 0;
983 register unsigned int diff;
984 bool odd_power = (bool)(power & 1);
985 while ((diff = (highbit - lowbit) >> 1)) {
986 if (baseuv & ~((1 << (lowbit + diff)) - 1))
991 /* we now have baseuv < 2 ** highbit */
992 if (power * highbit <= 8 * sizeof(UV)) {
993 /* result will definitely fit in UV, so use UV math
994 on same algorithm as above */
995 register UV result = 1;
996 register UV base = baseuv;
998 for (; power; base *= base, n++) {
999 register UV bit = (UV)1 << (UV)n;
1003 if (power == 0) break;
1007 if (baseuok || !odd_power)
1008 /* answer is positive */
1010 else if (result <= (UV)IV_MAX)
1011 /* answer negative, fits in IV */
1012 SETi( -(IV)result );
1013 else if (result == (UV)IV_MIN)
1014 /* 2's complement assumption: special case IV_MIN */
1017 /* answer negative, doesn't fit */
1018 SETn( -(NV)result );
1029 SETn( Perl_pow( left, right) );
1030 #ifdef PERL_PRESERVE_IVUV
1040 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1041 #ifdef PERL_PRESERVE_IVUV
1044 /* Unless the left argument is integer in range we are going to have to
1045 use NV maths. Hence only attempt to coerce the right argument if
1046 we know the left is integer. */
1047 /* Left operand is defined, so is it IV? */
1048 SvIV_please(TOPm1s);
1049 if (SvIOK(TOPm1s)) {
1050 bool auvok = SvUOK(TOPm1s);
1051 bool buvok = SvUOK(TOPs);
1052 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1053 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1060 alow = SvUVX(TOPm1s);
1062 IV aiv = SvIVX(TOPm1s);
1065 auvok = TRUE; /* effectively it's a UV now */
1067 alow = -aiv; /* abs, auvok == false records sign */
1073 IV biv = SvIVX(TOPs);
1076 buvok = TRUE; /* effectively it's a UV now */
1078 blow = -biv; /* abs, buvok == false records sign */
1082 /* If this does sign extension on unsigned it's time for plan B */
1083 ahigh = alow >> (4 * sizeof (UV));
1085 bhigh = blow >> (4 * sizeof (UV));
1087 if (ahigh && bhigh) {
1088 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1089 which is overflow. Drop to NVs below. */
1090 } else if (!ahigh && !bhigh) {
1091 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1092 so the unsigned multiply cannot overflow. */
1093 UV product = alow * blow;
1094 if (auvok == buvok) {
1095 /* -ve * -ve or +ve * +ve gives a +ve result. */
1099 } else if (product <= (UV)IV_MIN) {
1100 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1101 /* -ve result, which could overflow an IV */
1103 SETi( -(IV)product );
1105 } /* else drop to NVs below. */
1107 /* One operand is large, 1 small */
1110 /* swap the operands */
1112 bhigh = blow; /* bhigh now the temp var for the swap */
1116 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1117 multiplies can't overflow. shift can, add can, -ve can. */
1118 product_middle = ahigh * blow;
1119 if (!(product_middle & topmask)) {
1120 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1122 product_middle <<= (4 * sizeof (UV));
1123 product_low = alow * blow;
1125 /* as for pp_add, UV + something mustn't get smaller.
1126 IIRC ANSI mandates this wrapping *behaviour* for
1127 unsigned whatever the actual representation*/
1128 product_low += product_middle;
1129 if (product_low >= product_middle) {
1130 /* didn't overflow */
1131 if (auvok == buvok) {
1132 /* -ve * -ve or +ve * +ve gives a +ve result. */
1134 SETu( product_low );
1136 } else if (product_low <= (UV)IV_MIN) {
1137 /* 2s complement assumption again */
1138 /* -ve result, which could overflow an IV */
1140 SETi( -(IV)product_low );
1142 } /* else drop to NVs below. */
1144 } /* product_middle too large */
1145 } /* ahigh && bhigh */
1146 } /* SvIOK(TOPm1s) */
1151 SETn( left * right );
1158 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1159 /* Only try to do UV divide first
1160 if ((SLOPPYDIVIDE is true) or
1161 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1163 The assumption is that it is better to use floating point divide
1164 whenever possible, only doing integer divide first if we can't be sure.
1165 If NV_PRESERVES_UV is true then we know at compile time that no UV
1166 can be too large to preserve, so don't need to compile the code to
1167 test the size of UVs. */
1170 # define PERL_TRY_UV_DIVIDE
1171 /* ensure that 20./5. == 4. */
1173 # ifdef PERL_PRESERVE_IVUV
1174 # ifndef NV_PRESERVES_UV
1175 # define PERL_TRY_UV_DIVIDE
1180 #ifdef PERL_TRY_UV_DIVIDE
1183 SvIV_please(TOPm1s);
1184 if (SvIOK(TOPm1s)) {
1185 bool left_non_neg = SvUOK(TOPm1s);
1186 bool right_non_neg = SvUOK(TOPs);
1190 if (right_non_neg) {
1191 right = SvUVX(TOPs);
1194 IV biv = SvIVX(TOPs);
1197 right_non_neg = TRUE; /* effectively it's a UV now */
1203 /* historically undef()/0 gives a "Use of uninitialized value"
1204 warning before dieing, hence this test goes here.
1205 If it were immediately before the second SvIV_please, then
1206 DIE() would be invoked before left was even inspected, so
1207 no inpsection would give no warning. */
1209 DIE(aTHX_ "Illegal division by zero");
1212 left = SvUVX(TOPm1s);
1215 IV aiv = SvIVX(TOPm1s);
1218 left_non_neg = TRUE; /* effectively it's a UV now */
1227 /* For sloppy divide we always attempt integer division. */
1229 /* Otherwise we only attempt it if either or both operands
1230 would not be preserved by an NV. If both fit in NVs
1231 we fall through to the NV divide code below. However,
1232 as left >= right to ensure integer result here, we know that
1233 we can skip the test on the right operand - right big
1234 enough not to be preserved can't get here unless left is
1237 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1240 /* Integer division can't overflow, but it can be imprecise. */
1241 UV result = left / right;
1242 if (result * right == left) {
1243 SP--; /* result is valid */
1244 if (left_non_neg == right_non_neg) {
1245 /* signs identical, result is positive. */
1249 /* 2s complement assumption */
1250 if (result <= (UV)IV_MIN)
1251 SETi( -(IV)result );
1253 /* It's exact but too negative for IV. */
1254 SETn( -(NV)result );
1257 } /* tried integer divide but it was not an integer result */
1258 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1259 } /* left wasn't SvIOK */
1260 } /* right wasn't SvIOK */
1261 #endif /* PERL_TRY_UV_DIVIDE */
1265 DIE(aTHX_ "Illegal division by zero");
1266 PUSHn( left / right );
1273 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1277 bool left_neg = FALSE;
1278 bool right_neg = FALSE;
1279 bool use_double = FALSE;
1280 bool dright_valid = FALSE;
1286 right_neg = !SvUOK(TOPs);
1288 right = SvUVX(POPs);
1290 IV biv = SvIVX(POPs);
1293 right_neg = FALSE; /* effectively it's a UV now */
1301 right_neg = dright < 0;
1304 if (dright < UV_MAX_P1) {
1305 right = U_V(dright);
1306 dright_valid = TRUE; /* In case we need to use double below. */
1312 /* At this point use_double is only true if right is out of range for
1313 a UV. In range NV has been rounded down to nearest UV and
1314 use_double false. */
1316 if (!use_double && SvIOK(TOPs)) {
1318 left_neg = !SvUOK(TOPs);
1322 IV aiv = SvIVX(POPs);
1325 left_neg = FALSE; /* effectively it's a UV now */
1334 left_neg = dleft < 0;
1338 /* This should be exactly the 5.6 behaviour - if left and right are
1339 both in range for UV then use U_V() rather than floor. */
1341 if (dleft < UV_MAX_P1) {
1342 /* right was in range, so is dleft, so use UVs not double.
1346 /* left is out of range for UV, right was in range, so promote
1347 right (back) to double. */
1349 /* The +0.5 is used in 5.6 even though it is not strictly
1350 consistent with the implicit +0 floor in the U_V()
1351 inside the #if 1. */
1352 dleft = Perl_floor(dleft + 0.5);
1355 dright = Perl_floor(dright + 0.5);
1365 DIE(aTHX_ "Illegal modulus zero");
1367 dans = Perl_fmod(dleft, dright);
1368 if ((left_neg != right_neg) && dans)
1369 dans = dright - dans;
1372 sv_setnv(TARG, dans);
1378 DIE(aTHX_ "Illegal modulus zero");
1381 if ((left_neg != right_neg) && ans)
1384 /* XXX may warn: unary minus operator applied to unsigned type */
1385 /* could change -foo to be (~foo)+1 instead */
1386 if (ans <= ~((UV)IV_MAX)+1)
1387 sv_setiv(TARG, ~ans+1);
1389 sv_setnv(TARG, -(NV)ans);
1392 sv_setuv(TARG, ans);
1401 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1411 count = IV_MAX; /* The best we can do? */
1422 else if (SvNOKp(sv)) {
1431 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1433 I32 items = SP - MARK;
1435 static const char oom_list_extend[] =
1436 "Out of memory during list extend";
1438 max = items * count;
1439 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1440 /* Did the max computation overflow? */
1441 if (items > 0 && max > 0 && (max < items || max < count))
1442 Perl_croak(aTHX_ oom_list_extend);
1447 /* This code was intended to fix 20010809.028:
1450 for (($x =~ /./g) x 2) {
1451 print chop; # "abcdabcd" expected as output.
1454 * but that change (#11635) broke this code:
1456 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1458 * I can't think of a better fix that doesn't introduce
1459 * an efficiency hit by copying the SVs. The stack isn't
1460 * refcounted, and mortalisation obviously doesn't
1461 * Do The Right Thing when the stack has more than
1462 * one pointer to the same mortal value.
1466 *SP = sv_2mortal(newSVsv(*SP));
1476 repeatcpy((char*)(MARK + items), (char*)MARK,
1477 items * sizeof(SV*), count - 1);
1480 else if (count <= 0)
1483 else { /* Note: mark already snarfed by pp_list */
1487 static const char oom_string_extend[] =
1488 "Out of memory during string extend";
1490 SvSetSV(TARG, tmpstr);
1491 SvPV_force(TARG, len);
1492 isutf = DO_UTF8(TARG);
1497 STRLEN max = (UV)count * len;
1498 if (len > ((MEM_SIZE)~0)/count)
1499 Perl_croak(aTHX_ oom_string_extend);
1500 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1501 SvGROW(TARG, max + 1);
1502 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1503 SvCUR_set(TARG, SvCUR(TARG) * count);
1505 *SvEND(TARG) = '\0';
1508 (void)SvPOK_only_UTF8(TARG);
1510 (void)SvPOK_only(TARG);
1512 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1513 /* The parser saw this as a list repeat, and there
1514 are probably several items on the stack. But we're
1515 in scalar context, and there's no pp_list to save us
1516 now. So drop the rest of the items -- robin@kitsite.com
1529 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1530 useleft = USE_LEFT(TOPm1s);
1531 #ifdef PERL_PRESERVE_IVUV
1532 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1533 "bad things" happen if you rely on signed integers wrapping. */
1536 /* Unless the left argument is integer in range we are going to have to
1537 use NV maths. Hence only attempt to coerce the right argument if
1538 we know the left is integer. */
1539 register UV auv = 0;
1545 a_valid = auvok = 1;
1546 /* left operand is undef, treat as zero. */
1548 /* Left operand is defined, so is it IV? */
1549 SvIV_please(TOPm1s);
1550 if (SvIOK(TOPm1s)) {
1551 if ((auvok = SvUOK(TOPm1s)))
1552 auv = SvUVX(TOPm1s);
1554 register IV aiv = SvIVX(TOPm1s);
1557 auvok = 1; /* Now acting as a sign flag. */
1558 } else { /* 2s complement assumption for IV_MIN */
1566 bool result_good = 0;
1569 bool buvok = SvUOK(TOPs);
1574 register IV biv = SvIVX(TOPs);
1581 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1582 else "IV" now, independent of how it came in.
1583 if a, b represents positive, A, B negative, a maps to -A etc
1588 all UV maths. negate result if A negative.
1589 subtract if signs same, add if signs differ. */
1591 if (auvok ^ buvok) {
1600 /* Must get smaller */
1605 if (result <= buv) {
1606 /* result really should be -(auv-buv). as its negation
1607 of true value, need to swap our result flag */
1619 if (result <= (UV)IV_MIN)
1620 SETi( -(IV)result );
1622 /* result valid, but out of range for IV. */
1623 SETn( -(NV)result );
1627 } /* Overflow, drop through to NVs. */
1631 useleft = USE_LEFT(TOPm1s);
1635 /* left operand is undef, treat as zero - value */
1639 SETn( TOPn - value );
1646 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1649 if (PL_op->op_private & HINT_INTEGER) {
1663 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1666 if (PL_op->op_private & HINT_INTEGER) {
1680 dSP; tryAMAGICbinSET(lt,0);
1681 #ifdef PERL_PRESERVE_IVUV
1684 SvIV_please(TOPm1s);
1685 if (SvIOK(TOPm1s)) {
1686 bool auvok = SvUOK(TOPm1s);
1687 bool buvok = SvUOK(TOPs);
1689 if (!auvok && !buvok) { /* ## IV < IV ## */
1690 IV aiv = SvIVX(TOPm1s);
1691 IV biv = SvIVX(TOPs);
1694 SETs(boolSV(aiv < biv));
1697 if (auvok && buvok) { /* ## UV < UV ## */
1698 UV auv = SvUVX(TOPm1s);
1699 UV buv = SvUVX(TOPs);
1702 SETs(boolSV(auv < buv));
1705 if (auvok) { /* ## UV < IV ## */
1712 /* As (a) is a UV, it's >=0, so it cannot be < */
1717 SETs(boolSV(auv < (UV)biv));
1720 { /* ## IV < UV ## */
1724 aiv = SvIVX(TOPm1s);
1726 /* As (b) is a UV, it's >=0, so it must be < */
1733 SETs(boolSV((UV)aiv < buv));
1739 #ifndef NV_PRESERVES_UV
1740 #ifdef PERL_PRESERVE_IVUV
1743 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1745 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1751 SETs(boolSV(TOPn < value));
1758 dSP; tryAMAGICbinSET(gt,0);
1759 #ifdef PERL_PRESERVE_IVUV
1762 SvIV_please(TOPm1s);
1763 if (SvIOK(TOPm1s)) {
1764 bool auvok = SvUOK(TOPm1s);
1765 bool buvok = SvUOK(TOPs);
1767 if (!auvok && !buvok) { /* ## IV > IV ## */
1768 IV aiv = SvIVX(TOPm1s);
1769 IV biv = SvIVX(TOPs);
1772 SETs(boolSV(aiv > biv));
1775 if (auvok && buvok) { /* ## UV > UV ## */
1776 UV auv = SvUVX(TOPm1s);
1777 UV buv = SvUVX(TOPs);
1780 SETs(boolSV(auv > buv));
1783 if (auvok) { /* ## UV > IV ## */
1790 /* As (a) is a UV, it's >=0, so it must be > */
1795 SETs(boolSV(auv > (UV)biv));
1798 { /* ## IV > UV ## */
1802 aiv = SvIVX(TOPm1s);
1804 /* As (b) is a UV, it's >=0, so it cannot be > */
1811 SETs(boolSV((UV)aiv > buv));
1817 #ifndef NV_PRESERVES_UV
1818 #ifdef PERL_PRESERVE_IVUV
1821 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1823 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1829 SETs(boolSV(TOPn > value));
1836 dSP; tryAMAGICbinSET(le,0);
1837 #ifdef PERL_PRESERVE_IVUV
1840 SvIV_please(TOPm1s);
1841 if (SvIOK(TOPm1s)) {
1842 bool auvok = SvUOK(TOPm1s);
1843 bool buvok = SvUOK(TOPs);
1845 if (!auvok && !buvok) { /* ## IV <= IV ## */
1846 IV aiv = SvIVX(TOPm1s);
1847 IV biv = SvIVX(TOPs);
1850 SETs(boolSV(aiv <= biv));
1853 if (auvok && buvok) { /* ## UV <= UV ## */
1854 UV auv = SvUVX(TOPm1s);
1855 UV buv = SvUVX(TOPs);
1858 SETs(boolSV(auv <= buv));
1861 if (auvok) { /* ## UV <= IV ## */
1868 /* As (a) is a UV, it's >=0, so a cannot be <= */
1873 SETs(boolSV(auv <= (UV)biv));
1876 { /* ## IV <= UV ## */
1880 aiv = SvIVX(TOPm1s);
1882 /* As (b) is a UV, it's >=0, so a must be <= */
1889 SETs(boolSV((UV)aiv <= buv));
1895 #ifndef NV_PRESERVES_UV
1896 #ifdef PERL_PRESERVE_IVUV
1899 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1901 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1907 SETs(boolSV(TOPn <= value));
1914 dSP; tryAMAGICbinSET(ge,0);
1915 #ifdef PERL_PRESERVE_IVUV
1918 SvIV_please(TOPm1s);
1919 if (SvIOK(TOPm1s)) {
1920 bool auvok = SvUOK(TOPm1s);
1921 bool buvok = SvUOK(TOPs);
1923 if (!auvok && !buvok) { /* ## IV >= IV ## */
1924 IV aiv = SvIVX(TOPm1s);
1925 IV biv = SvIVX(TOPs);
1928 SETs(boolSV(aiv >= biv));
1931 if (auvok && buvok) { /* ## UV >= UV ## */
1932 UV auv = SvUVX(TOPm1s);
1933 UV buv = SvUVX(TOPs);
1936 SETs(boolSV(auv >= buv));
1939 if (auvok) { /* ## UV >= IV ## */
1946 /* As (a) is a UV, it's >=0, so it must be >= */
1951 SETs(boolSV(auv >= (UV)biv));
1954 { /* ## IV >= UV ## */
1958 aiv = SvIVX(TOPm1s);
1960 /* As (b) is a UV, it's >=0, so a cannot be >= */
1967 SETs(boolSV((UV)aiv >= buv));
1973 #ifndef NV_PRESERVES_UV
1974 #ifdef PERL_PRESERVE_IVUV
1977 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1979 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1985 SETs(boolSV(TOPn >= value));
1992 dSP; tryAMAGICbinSET(ne,0);
1993 #ifndef NV_PRESERVES_UV
1994 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1996 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2000 #ifdef PERL_PRESERVE_IVUV
2003 SvIV_please(TOPm1s);
2004 if (SvIOK(TOPm1s)) {
2005 bool auvok = SvUOK(TOPm1s);
2006 bool buvok = SvUOK(TOPs);
2008 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2009 /* Casting IV to UV before comparison isn't going to matter
2010 on 2s complement. On 1s complement or sign&magnitude
2011 (if we have any of them) it could make negative zero
2012 differ from normal zero. As I understand it. (Need to
2013 check - is negative zero implementation defined behaviour
2015 UV buv = SvUVX(POPs);
2016 UV auv = SvUVX(TOPs);
2018 SETs(boolSV(auv != buv));
2021 { /* ## Mixed IV,UV ## */
2025 /* != is commutative so swap if needed (save code) */
2027 /* swap. top of stack (b) is the iv */
2031 /* As (a) is a UV, it's >0, so it cannot be == */
2040 /* As (b) is a UV, it's >0, so it cannot be == */
2044 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2046 SETs(boolSV((UV)iv != uv));
2054 SETs(boolSV(TOPn != value));
2061 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2062 #ifndef NV_PRESERVES_UV
2063 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2064 UV right = PTR2UV(SvRV(POPs));
2065 UV left = PTR2UV(SvRV(TOPs));
2066 SETi((left > right) - (left < right));
2070 #ifdef PERL_PRESERVE_IVUV
2071 /* Fortunately it seems NaN isn't IOK */
2074 SvIV_please(TOPm1s);
2075 if (SvIOK(TOPm1s)) {
2076 bool leftuvok = SvUOK(TOPm1s);
2077 bool rightuvok = SvUOK(TOPs);
2079 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2080 IV leftiv = SvIVX(TOPm1s);
2081 IV rightiv = SvIVX(TOPs);
2083 if (leftiv > rightiv)
2085 else if (leftiv < rightiv)
2089 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2090 UV leftuv = SvUVX(TOPm1s);
2091 UV rightuv = SvUVX(TOPs);
2093 if (leftuv > rightuv)
2095 else if (leftuv < rightuv)
2099 } else if (leftuvok) { /* ## UV <=> IV ## */
2103 rightiv = SvIVX(TOPs);
2105 /* As (a) is a UV, it's >=0, so it cannot be < */
2108 leftuv = SvUVX(TOPm1s);
2109 if (leftuv > (UV)rightiv) {
2111 } else if (leftuv < (UV)rightiv) {
2117 } else { /* ## IV <=> UV ## */
2121 leftiv = SvIVX(TOPm1s);
2123 /* As (b) is a UV, it's >=0, so it must be < */
2126 rightuv = SvUVX(TOPs);
2127 if ((UV)leftiv > rightuv) {
2129 } else if ((UV)leftiv < rightuv) {
2147 if (Perl_isnan(left) || Perl_isnan(right)) {
2151 value = (left > right) - (left < right);
2155 else if (left < right)
2157 else if (left > right)
2171 dSP; tryAMAGICbinSET(slt,0);
2174 int cmp = (IN_LOCALE_RUNTIME
2175 ? sv_cmp_locale(left, right)
2176 : sv_cmp(left, right));
2177 SETs(boolSV(cmp < 0));
2184 dSP; tryAMAGICbinSET(sgt,0);
2187 int cmp = (IN_LOCALE_RUNTIME
2188 ? sv_cmp_locale(left, right)
2189 : sv_cmp(left, right));
2190 SETs(boolSV(cmp > 0));
2197 dSP; tryAMAGICbinSET(sle,0);
2200 int cmp = (IN_LOCALE_RUNTIME
2201 ? sv_cmp_locale(left, right)
2202 : sv_cmp(left, right));
2203 SETs(boolSV(cmp <= 0));
2210 dSP; tryAMAGICbinSET(sge,0);
2213 int cmp = (IN_LOCALE_RUNTIME
2214 ? sv_cmp_locale(left, right)
2215 : sv_cmp(left, right));
2216 SETs(boolSV(cmp >= 0));
2223 dSP; tryAMAGICbinSET(seq,0);
2226 SETs(boolSV(sv_eq(left, right)));
2233 dSP; tryAMAGICbinSET(sne,0);
2236 SETs(boolSV(!sv_eq(left, right)));
2243 dSP; dTARGET; tryAMAGICbin(scmp,0);
2246 int cmp = (IN_LOCALE_RUNTIME
2247 ? sv_cmp_locale(left, right)
2248 : sv_cmp(left, right));
2256 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2259 if (SvGMAGICAL(left)) mg_get(left);
2260 if (SvGMAGICAL(right)) mg_get(right);
2261 if (SvNIOKp(left) || SvNIOKp(right)) {
2262 if (PL_op->op_private & HINT_INTEGER) {
2263 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2267 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2272 do_vop(PL_op->op_type, TARG, left, right);
2281 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2284 if (SvGMAGICAL(left)) mg_get(left);
2285 if (SvGMAGICAL(right)) mg_get(right);
2286 if (SvNIOKp(left) || SvNIOKp(right)) {
2287 if (PL_op->op_private & HINT_INTEGER) {
2288 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2292 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2297 do_vop(PL_op->op_type, TARG, left, right);
2306 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2309 if (SvGMAGICAL(left)) mg_get(left);
2310 if (SvGMAGICAL(right)) mg_get(right);
2311 if (SvNIOKp(left) || SvNIOKp(right)) {
2312 if (PL_op->op_private & HINT_INTEGER) {
2313 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2317 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2322 do_vop(PL_op->op_type, TARG, left, right);
2331 dSP; dTARGET; tryAMAGICun(neg);
2334 int flags = SvFLAGS(sv);
2337 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2338 /* It's publicly an integer, or privately an integer-not-float */
2341 if (SvIVX(sv) == IV_MIN) {
2342 /* 2s complement assumption. */
2343 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2346 else if (SvUVX(sv) <= IV_MAX) {
2351 else if (SvIVX(sv) != IV_MIN) {
2355 #ifdef PERL_PRESERVE_IVUV
2364 else if (SvPOKp(sv)) {
2366 char *s = SvPV(sv, len);
2367 if (isIDFIRST(*s)) {
2368 sv_setpvn(TARG, "-", 1);
2371 else if (*s == '+' || *s == '-') {
2373 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2375 else if (DO_UTF8(sv)) {
2378 goto oops_its_an_int;
2380 sv_setnv(TARG, -SvNV(sv));
2382 sv_setpvn(TARG, "-", 1);
2389 goto oops_its_an_int;
2390 sv_setnv(TARG, -SvNV(sv));
2402 dSP; tryAMAGICunSET(not);
2403 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2409 dSP; dTARGET; tryAMAGICun(compl);
2415 if (PL_op->op_private & HINT_INTEGER) {
2416 IV i = ~SvIV_nomg(sv);
2420 UV u = ~SvUV_nomg(sv);
2429 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2430 sv_setsv_nomg(TARG, sv);
2431 tmps = (U8*)SvPV_force(TARG, len);
2434 /* Calculate exact length, let's not estimate. */
2443 while (tmps < send) {
2444 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2445 tmps += UTF8SKIP(tmps);
2446 targlen += UNISKIP(~c);
2452 /* Now rewind strings and write them. */
2456 Newz(0, result, targlen + 1, U8);
2457 while (tmps < send) {
2458 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2459 tmps += UTF8SKIP(tmps);
2460 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2464 sv_setpvn(TARG, (char*)result, targlen);
2468 Newz(0, result, nchar + 1, U8);
2469 while (tmps < send) {
2470 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2471 tmps += UTF8SKIP(tmps);
2476 sv_setpvn(TARG, (char*)result, nchar);
2485 register long *tmpl;
2486 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2489 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2494 for ( ; anum > 0; anum--, tmps++)
2503 /* integer versions of some of the above */
2507 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2510 SETi( left * right );
2517 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2521 DIE(aTHX_ "Illegal division by zero");
2522 value = POPi / value;
2531 /* This is the vanilla old i_modulo. */
2532 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2536 DIE(aTHX_ "Illegal modulus zero");
2537 SETi( left % right );
2542 #if defined(__GLIBC__) && IVSIZE == 8
2546 /* This is the i_modulo with the workaround for the _moddi3 bug
2547 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2548 * See below for pp_i_modulo. */
2549 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2553 DIE(aTHX_ "Illegal modulus zero");
2554 SETi( left % PERL_ABS(right) );
2562 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2566 DIE(aTHX_ "Illegal modulus zero");
2567 /* The assumption is to use hereafter the old vanilla version... */
2569 PL_ppaddr[OP_I_MODULO] =
2570 &Perl_pp_i_modulo_0;
2571 /* .. but if we have glibc, we might have a buggy _moddi3
2572 * (at least glicb 2.2.5 is known to have this bug), in other
2573 * words our integer modulus with negative quad as the second
2574 * argument might be broken. Test for this and re-patch the
2575 * opcode dispatch table if that is the case, remembering to
2576 * also apply the workaround so that this first round works
2577 * right, too. See [perl #9402] for more information. */
2578 #if defined(__GLIBC__) && IVSIZE == 8
2582 /* Cannot do this check with inlined IV constants since
2583 * that seems to work correctly even with the buggy glibc. */
2585 /* Yikes, we have the bug.
2586 * Patch in the workaround version. */
2588 PL_ppaddr[OP_I_MODULO] =
2589 &Perl_pp_i_modulo_1;
2590 /* Make certain we work right this time, too. */
2591 right = PERL_ABS(right);
2595 SETi( left % right );
2602 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2605 SETi( left + right );
2612 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2615 SETi( left - right );
2622 dSP; tryAMAGICbinSET(lt,0);
2625 SETs(boolSV(left < right));
2632 dSP; tryAMAGICbinSET(gt,0);
2635 SETs(boolSV(left > right));
2642 dSP; tryAMAGICbinSET(le,0);
2645 SETs(boolSV(left <= right));
2652 dSP; tryAMAGICbinSET(ge,0);
2655 SETs(boolSV(left >= right));
2662 dSP; tryAMAGICbinSET(eq,0);
2665 SETs(boolSV(left == right));
2672 dSP; tryAMAGICbinSET(ne,0);
2675 SETs(boolSV(left != right));
2682 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2689 else if (left < right)
2700 dSP; dTARGET; tryAMAGICun(neg);
2705 /* High falutin' math. */
2709 dSP; dTARGET; tryAMAGICbin(atan2,0);
2712 SETn(Perl_atan2(left, right));
2719 dSP; dTARGET; tryAMAGICun(sin);
2723 value = Perl_sin(value);
2731 dSP; dTARGET; tryAMAGICun(cos);
2735 value = Perl_cos(value);
2741 /* Support Configure command-line overrides for rand() functions.
2742 After 5.005, perhaps we should replace this by Configure support
2743 for drand48(), random(), or rand(). For 5.005, though, maintain
2744 compatibility by calling rand() but allow the user to override it.
2745 See INSTALL for details. --Andy Dougherty 15 July 1998
2747 /* Now it's after 5.005, and Configure supports drand48() and random(),
2748 in addition to rand(). So the overrides should not be needed any more.
2749 --Jarkko Hietaniemi 27 September 1998
2752 #ifndef HAS_DRAND48_PROTO
2753 extern double drand48 (void);
2766 if (!PL_srand_called) {
2767 (void)seedDrand01((Rand_seed_t)seed());
2768 PL_srand_called = TRUE;
2783 (void)seedDrand01((Rand_seed_t)anum);
2784 PL_srand_called = TRUE;
2791 dSP; dTARGET; tryAMAGICun(exp);
2795 value = Perl_exp(value);
2803 dSP; dTARGET; tryAMAGICun(log);
2808 SET_NUMERIC_STANDARD();
2809 DIE(aTHX_ "Can't take log of %"NVgf, value);
2811 value = Perl_log(value);
2819 dSP; dTARGET; tryAMAGICun(sqrt);
2824 SET_NUMERIC_STANDARD();
2825 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2827 value = Perl_sqrt(value);
2835 dSP; dTARGET; tryAMAGICun(int);
2838 IV iv = TOPi; /* attempt to convert to IV if possible. */
2839 /* XXX it's arguable that compiler casting to IV might be subtly
2840 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2841 else preferring IV has introduced a subtle behaviour change bug. OTOH
2842 relying on floating point to be accurate is a bug. */
2846 else if (SvIOK(TOPs)) {
2855 if (value < (NV)UV_MAX + 0.5) {
2858 SETn(Perl_floor(value));
2862 if (value > (NV)IV_MIN - 0.5) {
2865 SETn(Perl_ceil(value));
2875 dSP; dTARGET; tryAMAGICun(abs);
2877 /* This will cache the NV value if string isn't actually integer */
2882 else if (SvIOK(TOPs)) {
2883 /* IVX is precise */
2885 SETu(TOPu); /* force it to be numeric only */
2893 /* 2s complement assumption. Also, not really needed as
2894 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2914 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2920 tmps = (SvPVx(sv, len));
2922 /* If Unicode, try to downgrade
2923 * If not possible, croak. */
2924 SV* tsv = sv_2mortal(newSVsv(sv));
2927 sv_utf8_downgrade(tsv, FALSE);
2930 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2931 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2944 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2950 tmps = (SvPVx(sv, len));
2952 /* If Unicode, try to downgrade
2953 * If not possible, croak. */
2954 SV* tsv = sv_2mortal(newSVsv(sv));
2957 sv_utf8_downgrade(tsv, FALSE);
2960 while (*tmps && len && isSPACE(*tmps))
2965 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2966 else if (*tmps == 'b')
2967 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2969 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2971 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2988 SETi(sv_len_utf8(sv));
3004 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3006 const I32 arybase = PL_curcop->cop_arybase;
3008 const char *repl = 0;
3010 int num_args = PL_op->op_private & 7;
3011 bool repl_need_utf8_upgrade = FALSE;
3012 bool repl_is_utf8 = FALSE;
3014 SvTAINTED_off(TARG); /* decontaminate */
3015 SvUTF8_off(TARG); /* decontaminate */
3019 repl = SvPV(repl_sv, repl_len);
3020 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3030 sv_utf8_upgrade(sv);
3032 else if (DO_UTF8(sv))
3033 repl_need_utf8_upgrade = TRUE;
3035 tmps = SvPV(sv, curlen);
3037 utf8_curlen = sv_len_utf8(sv);
3038 if (utf8_curlen == curlen)
3041 curlen = utf8_curlen;
3046 if (pos >= arybase) {
3064 else if (len >= 0) {
3066 if (rem > (I32)curlen)
3081 Perl_croak(aTHX_ "substr outside of string");
3082 if (ckWARN(WARN_SUBSTR))
3083 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3090 sv_pos_u2b(sv, &pos, &rem);
3092 /* we either return a PV or an LV. If the TARG hasn't been used
3093 * before, or is of that type, reuse it; otherwise use a mortal
3094 * instead. Note that LVs can have an extended lifetime, so also
3095 * dont reuse if refcount > 1 (bug #20933) */
3096 if (SvTYPE(TARG) > SVt_NULL) {
3097 if ( (SvTYPE(TARG) == SVt_PVLV)
3098 ? (!lvalue || SvREFCNT(TARG) > 1)
3101 TARG = sv_newmortal();
3105 sv_setpvn(TARG, tmps, rem);
3106 #ifdef USE_LOCALE_COLLATE
3107 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3112 SV* repl_sv_copy = NULL;
3114 if (repl_need_utf8_upgrade) {
3115 repl_sv_copy = newSVsv(repl_sv);
3116 sv_utf8_upgrade(repl_sv_copy);
3117 repl = SvPV(repl_sv_copy, repl_len);
3118 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3120 sv_insert(sv, pos, rem, repl, repl_len);
3124 SvREFCNT_dec(repl_sv_copy);
3126 else if (lvalue) { /* it's an lvalue! */
3127 if (!SvGMAGICAL(sv)) {
3131 if (ckWARN(WARN_SUBSTR))
3132 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3133 "Attempt to use reference as lvalue in substr");
3135 if (SvOK(sv)) /* is it defined ? */
3136 (void)SvPOK_only_UTF8(sv);
3138 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3141 if (SvTYPE(TARG) < SVt_PVLV) {
3142 sv_upgrade(TARG, SVt_PVLV);
3143 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3149 if (LvTARG(TARG) != sv) {
3151 SvREFCNT_dec(LvTARG(TARG));
3152 LvTARG(TARG) = SvREFCNT_inc(sv);
3154 LvTARGOFF(TARG) = upos;
3155 LvTARGLEN(TARG) = urem;
3159 PUSHs(TARG); /* avoid SvSETMAGIC here */
3166 register IV size = POPi;
3167 register IV offset = POPi;
3168 register SV *src = POPs;
3169 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3171 SvTAINTED_off(TARG); /* decontaminate */
3172 if (lvalue) { /* it's an lvalue! */
3173 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3174 TARG = sv_newmortal();
3175 if (SvTYPE(TARG) < SVt_PVLV) {
3176 sv_upgrade(TARG, SVt_PVLV);
3177 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3180 if (LvTARG(TARG) != src) {
3182 SvREFCNT_dec(LvTARG(TARG));
3183 LvTARG(TARG) = SvREFCNT_inc(src);
3185 LvTARGOFF(TARG) = offset;
3186 LvTARGLEN(TARG) = size;
3189 sv_setuv(TARG, do_vecget(src, offset, size));
3205 I32 arybase = PL_curcop->cop_arybase;
3212 offset = POPi - arybase;
3215 big_utf8 = DO_UTF8(big);
3216 little_utf8 = DO_UTF8(little);
3217 if (big_utf8 ^ little_utf8) {
3218 /* One needs to be upgraded. */
3219 SV *bytes = little_utf8 ? big : little;
3221 char *p = SvPV(bytes, len);
3223 temp = newSVpvn(p, len);
3226 sv_recode_to_utf8(temp, PL_encoding);
3228 sv_utf8_upgrade(temp);
3237 if (big_utf8 && offset > 0)
3238 sv_pos_u2b(big, &offset, 0);
3239 tmps = SvPV(big, biglen);
3242 else if (offset > (I32)biglen)
3244 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3245 (unsigned char*)tmps + biglen, little, 0)))
3248 retval = tmps2 - tmps;
3249 if (retval > 0 && big_utf8)
3250 sv_pos_b2u(big, &retval);
3253 PUSHi(retval + arybase);
3269 I32 arybase = PL_curcop->cop_arybase;
3277 big_utf8 = DO_UTF8(big);
3278 little_utf8 = DO_UTF8(little);
3279 if (big_utf8 ^ little_utf8) {
3280 /* One needs to be upgraded. */
3281 SV *bytes = little_utf8 ? big : little;
3283 char *p = SvPV(bytes, len);
3285 temp = newSVpvn(p, len);
3288 sv_recode_to_utf8(temp, PL_encoding);
3290 sv_utf8_upgrade(temp);
3299 tmps2 = SvPV(little, llen);
3300 tmps = SvPV(big, blen);
3305 if (offset > 0 && big_utf8)
3306 sv_pos_u2b(big, &offset, 0);
3307 offset = offset - arybase + llen;
3311 else if (offset > (I32)blen)
3313 if (!(tmps2 = rninstr(tmps, tmps + offset,
3314 tmps2, tmps2 + llen)))
3317 retval = tmps2 - tmps;
3318 if (retval > 0 && big_utf8)
3319 sv_pos_b2u(big, &retval);
3322 PUSHi(retval + arybase);
3328 dSP; dMARK; dORIGMARK; dTARGET;
3329 do_sprintf(TARG, SP-MARK, MARK+1);
3330 TAINT_IF(SvTAINTED(TARG));
3331 if (DO_UTF8(*(MARK+1)))
3343 U8 *s = (U8*)SvPVx(argsv, len);
3346 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3347 tmpsv = sv_2mortal(newSVsv(argsv));
3348 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3352 XPUSHu(DO_UTF8(argsv) ?
3353 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3365 (void)SvUPGRADE(TARG,SVt_PV);
3367 if (value > 255 && !IN_BYTES) {
3368 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3369 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3370 SvCUR_set(TARG, tmps - SvPVX(TARG));
3372 (void)SvPOK_only(TARG);
3381 *tmps++ = (char)value;
3383 (void)SvPOK_only(TARG);
3384 if (PL_encoding && !IN_BYTES) {
3385 sv_recode_to_utf8(TARG, PL_encoding);
3387 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3388 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3392 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3393 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3409 char *tmps = SvPV(left, len);
3411 if (DO_UTF8(left)) {
3412 /* If Unicode, try to downgrade.
3413 * If not possible, croak.
3414 * Yes, we made this up. */
3415 SV* tsv = sv_2mortal(newSVsv(left));
3418 sv_utf8_downgrade(tsv, FALSE);
3421 # ifdef USE_ITHREADS
3423 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3424 /* This should be threadsafe because in ithreads there is only
3425 * one thread per interpreter. If this would not be true,
3426 * we would need a mutex to protect this malloc. */
3427 PL_reentrant_buffer->_crypt_struct_buffer =
3428 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3429 #if defined(__GLIBC__) || defined(__EMX__)
3430 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3431 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3432 /* work around glibc-2.2.5 bug */
3433 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3437 # endif /* HAS_CRYPT_R */
3438 # endif /* USE_ITHREADS */
3440 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3442 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3448 "The crypt() function is unimplemented due to excessive paranoia.");
3461 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3462 UTF8_IS_START(*s)) {
3463 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3467 utf8_to_uvchr(s, &ulen);
3468 toTITLE_utf8(s, tmpbuf, &tculen);
3469 utf8_to_uvchr(tmpbuf, 0);
3471 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3473 /* slen is the byte length of the whole SV.
3474 * ulen is the byte length of the original Unicode character
3475 * stored as UTF-8 at s.
3476 * tculen is the byte length of the freshly titlecased
3477 * Unicode character stored as UTF-8 at tmpbuf.
3478 * We first set the result to be the titlecased character,
3479 * and then append the rest of the SV data. */
3480 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3482 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3487 s = (U8*)SvPV_force_nomg(sv, slen);
3488 Copy(tmpbuf, s, tculen, U8);
3492 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3494 SvUTF8_off(TARG); /* decontaminate */
3495 sv_setsv_nomg(TARG, sv);
3499 s = (U8*)SvPV_force_nomg(sv, slen);
3501 if (IN_LOCALE_RUNTIME) {
3504 *s = toUPPER_LC(*s);
3523 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3524 UTF8_IS_START(*s)) {
3526 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3530 toLOWER_utf8(s, tmpbuf, &ulen);
3531 uv = utf8_to_uvchr(tmpbuf, 0);
3532 tend = uvchr_to_utf8(tmpbuf, uv);
3534 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3536 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3538 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3543 s = (U8*)SvPV_force_nomg(sv, slen);
3544 Copy(tmpbuf, s, ulen, U8);
3548 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3550 SvUTF8_off(TARG); /* decontaminate */
3551 sv_setsv_nomg(TARG, sv);
3555 s = (U8*)SvPV_force_nomg(sv, slen);
3557 if (IN_LOCALE_RUNTIME) {
3560 *s = toLOWER_LC(*s);
3583 U8 tmpbuf[UTF8_MAXBYTES+1];
3585 s = (U8*)SvPV_nomg(sv,len);
3587 SvUTF8_off(TARG); /* decontaminate */
3588 sv_setpvn(TARG, "", 0);
3592 STRLEN min = len + 1;
3594 (void)SvUPGRADE(TARG, SVt_PV);
3596 (void)SvPOK_only(TARG);
3597 d = (U8*)SvPVX(TARG);
3600 STRLEN u = UTF8SKIP(s);
3602 toUPPER_utf8(s, tmpbuf, &ulen);
3603 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3604 /* If the eventually required minimum size outgrows
3605 * the available space, we need to grow. */
3606 UV o = d - (U8*)SvPVX(TARG);
3608 /* If someone uppercases one million U+03B0s we
3609 * SvGROW() one million times. Or we could try
3610 * guessing how much to allocate without allocating
3611 * too much. Such is life. */
3613 d = (U8*)SvPVX(TARG) + o;
3615 Copy(tmpbuf, d, ulen, U8);
3621 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3626 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3628 SvUTF8_off(TARG); /* decontaminate */
3629 sv_setsv_nomg(TARG, sv);
3633 s = (U8*)SvPV_force_nomg(sv, len);
3635 register U8 *send = s + len;
3637 if (IN_LOCALE_RUNTIME) {
3640 for (; s < send; s++)
3641 *s = toUPPER_LC(*s);
3644 for (; s < send; s++)
3666 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3668 s = (U8*)SvPV_nomg(sv,len);
3670 SvUTF8_off(TARG); /* decontaminate */
3671 sv_setpvn(TARG, "", 0);
3675 STRLEN min = len + 1;
3677 (void)SvUPGRADE(TARG, SVt_PV);
3679 (void)SvPOK_only(TARG);
3680 d = (U8*)SvPVX(TARG);
3683 STRLEN u = UTF8SKIP(s);
3684 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3686 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3687 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3689 * Now if the sigma is NOT followed by
3690 * /$ignorable_sequence$cased_letter/;
3691 * and it IS preceded by
3692 * /$cased_letter$ignorable_sequence/;
3693 * where $ignorable_sequence is
3694 * [\x{2010}\x{AD}\p{Mn}]*
3695 * and $cased_letter is
3696 * [\p{Ll}\p{Lo}\p{Lt}]
3697 * then it should be mapped to 0x03C2,
3698 * (GREEK SMALL LETTER FINAL SIGMA),
3699 * instead of staying 0x03A3.
3700 * "should be": in other words,
3701 * this is not implemented yet.
3702 * See lib/unicore/SpecialCasing.txt.
3705 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3706 /* If the eventually required minimum size outgrows
3707 * the available space, we need to grow. */
3708 UV o = d - (U8*)SvPVX(TARG);
3710 /* If someone lowercases one million U+0130s we
3711 * SvGROW() one million times. Or we could try
3712 * guessing how much to allocate without allocating.
3713 * too much. Such is life. */
3715 d = (U8*)SvPVX(TARG) + o;
3717 Copy(tmpbuf, d, ulen, U8);
3723 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3728 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3730 SvUTF8_off(TARG); /* decontaminate */
3731 sv_setsv_nomg(TARG, sv);
3736 s = (U8*)SvPV_force_nomg(sv, len);
3738 register U8 *send = s + len;
3740 if (IN_LOCALE_RUNTIME) {
3743 for (; s < send; s++)
3744 *s = toLOWER_LC(*s);
3747 for (; s < send; s++)
3761 register char *s = SvPV(sv,len);
3764 SvUTF8_off(TARG); /* decontaminate */
3766 (void)SvUPGRADE(TARG, SVt_PV);
3767 SvGROW(TARG, (len * 2) + 1);
3771 if (UTF8_IS_CONTINUED(*s)) {
3772 STRLEN ulen = UTF8SKIP(s);
3796 SvCUR_set(TARG, d - SvPVX(TARG));
3797 (void)SvPOK_only_UTF8(TARG);
3800 sv_setpvn(TARG, s, len);
3802 if (SvSMAGICAL(TARG))
3811 dSP; dMARK; dORIGMARK;
3813 register AV* av = (AV*)POPs;
3814 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3815 I32 arybase = PL_curcop->cop_arybase;
3818 if (SvTYPE(av) == SVt_PVAV) {
3819 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3821 for (svp = MARK + 1; svp <= SP; svp++) {
3826 if (max > AvMAX(av))
3829 while (++MARK <= SP) {
3830 elem = SvIVx(*MARK);
3834 svp = av_fetch(av, elem, lval);
3836 if (!svp || *svp == &PL_sv_undef)
3837 DIE(aTHX_ PL_no_aelem, elem);
3838 if (PL_op->op_private & OPpLVAL_INTRO)
3839 save_aelem(av, elem, svp);
3841 *MARK = svp ? *svp : &PL_sv_undef;
3844 if (GIMME != G_ARRAY) {
3846 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3852 /* Associative arrays. */
3857 HV *hash = (HV*)POPs;
3859 I32 gimme = GIMME_V;
3862 /* might clobber stack_sp */
3863 entry = hv_iternext(hash);
3868 SV* sv = hv_iterkeysv(entry);
3869 PUSHs(sv); /* won't clobber stack_sp */
3870 if (gimme == G_ARRAY) {
3873 /* might clobber stack_sp */
3874 val = hv_iterval(hash, entry);
3879 else if (gimme == G_SCALAR)
3898 I32 gimme = GIMME_V;
3899 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3903 if (PL_op->op_private & OPpSLICE) {
3907 hvtype = SvTYPE(hv);
3908 if (hvtype == SVt_PVHV) { /* hash element */
3909 while (++MARK <= SP) {
3910 sv = hv_delete_ent(hv, *MARK, discard, 0);
3911 *MARK = sv ? sv : &PL_sv_undef;
3914 else if (hvtype == SVt_PVAV) { /* array element */
3915 if (PL_op->op_flags & OPf_SPECIAL) {
3916 while (++MARK <= SP) {
3917 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3918 *MARK = sv ? sv : &PL_sv_undef;
3923 DIE(aTHX_ "Not a HASH reference");
3926 else if (gimme == G_SCALAR) {
3931 *++MARK = &PL_sv_undef;
3938 if (SvTYPE(hv) == SVt_PVHV)
3939 sv = hv_delete_ent(hv, keysv, discard, 0);
3940 else if (SvTYPE(hv) == SVt_PVAV) {
3941 if (PL_op->op_flags & OPf_SPECIAL)
3942 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3944 DIE(aTHX_ "panic: avhv_delete no longer supported");
3947 DIE(aTHX_ "Not a HASH reference");
3962 if (PL_op->op_private & OPpEXISTS_SUB) {
3966 cv = sv_2cv(sv, &hv, &gv, FALSE);
3969 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3975 if (SvTYPE(hv) == SVt_PVHV) {
3976 if (hv_exists_ent(hv, tmpsv, 0))
3979 else if (SvTYPE(hv) == SVt_PVAV) {
3980 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3981 if (av_exists((AV*)hv, SvIV(tmpsv)))
3986 DIE(aTHX_ "Not a HASH reference");
3993 dSP; dMARK; dORIGMARK;
3994 register HV *hv = (HV*)POPs;
3995 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3996 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3997 bool other_magic = FALSE;
4003 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4004 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4005 /* Try to preserve the existenceness of a tied hash
4006 * element by using EXISTS and DELETE if possible.
4007 * Fallback to FETCH and STORE otherwise */
4008 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4009 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4010 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4013 while (++MARK <= SP) {
4017 bool preeminent = FALSE;
4020 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4021 hv_exists_ent(hv, keysv, 0);
4024 he = hv_fetch_ent(hv, keysv, lval, 0);
4025 svp = he ? &HeVAL(he) : 0;
4028 if (!svp || *svp == &PL_sv_undef) {
4030 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
4034 save_helem(hv, keysv, svp);
4037 char *key = SvPV(keysv, keylen);
4038 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4042 *MARK = svp ? *svp : &PL_sv_undef;
4044 if (GIMME != G_ARRAY) {
4046 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4052 /* List operators. */
4057 if (GIMME != G_ARRAY) {
4059 *MARK = *SP; /* unwanted list, return last item */
4061 *MARK = &PL_sv_undef;
4070 SV **lastrelem = PL_stack_sp;
4071 SV **lastlelem = PL_stack_base + POPMARK;
4072 SV **firstlelem = PL_stack_base + POPMARK + 1;
4073 register SV **firstrelem = lastlelem + 1;
4074 I32 arybase = PL_curcop->cop_arybase;
4075 I32 lval = PL_op->op_flags & OPf_MOD;
4076 I32 is_something_there = lval;
4078 register I32 max = lastrelem - lastlelem;
4079 register SV **lelem;
4082 if (GIMME != G_ARRAY) {
4083 ix = SvIVx(*lastlelem);
4088 if (ix < 0 || ix >= max)
4089 *firstlelem = &PL_sv_undef;
4091 *firstlelem = firstrelem[ix];
4097 SP = firstlelem - 1;
4101 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4107 if (ix < 0 || ix >= max)
4108 *lelem = &PL_sv_undef;
4110 is_something_there = TRUE;
4111 if (!(*lelem = firstrelem[ix]))
4112 *lelem = &PL_sv_undef;
4115 if (is_something_there)
4118 SP = firstlelem - 1;
4124 dSP; dMARK; dORIGMARK;
4125 I32 items = SP - MARK;
4126 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4127 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4134 dSP; dMARK; dORIGMARK;
4135 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4139 SV *val = NEWSV(46, 0);
4141 sv_setsv(val, *++MARK);
4142 else if (ckWARN(WARN_MISC))
4143 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4144 (void)hv_store_ent(hv,key,val,0);
4153 dVAR; dSP; dMARK; dORIGMARK;
4154 register AV *ary = (AV*)*++MARK;
4158 register I32 offset;
4159 register I32 length;
4166 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4167 *MARK-- = SvTIED_obj((SV*)ary, mg);
4171 call_method("SPLICE",GIMME_V);
4180 offset = i = SvIVx(*MARK);
4182 offset += AvFILLp(ary) + 1;
4184 offset -= PL_curcop->cop_arybase;
4186 DIE(aTHX_ PL_no_aelem, i);
4188 length = SvIVx(*MARK++);
4190 length += AvFILLp(ary) - offset + 1;
4196 length = AvMAX(ary) + 1; /* close enough to infinity */
4200 length = AvMAX(ary) + 1;
4202 if (offset > AvFILLp(ary) + 1) {
4203 if (ckWARN(WARN_MISC))
4204 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4205 offset = AvFILLp(ary) + 1;
4207 after = AvFILLp(ary) + 1 - (offset + length);
4208 if (after < 0) { /* not that much array */
4209 length += after; /* offset+length now in array */
4215 /* At this point, MARK .. SP-1 is our new LIST */
4218 diff = newlen - length;
4219 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4222 /* make new elements SVs now: avoid problems if they're from the array */
4223 for (dst = MARK, i = newlen; i; i--) {
4225 *dst++ = newSVsv(h);
4228 if (diff < 0) { /* shrinking the area */
4230 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4231 Copy(MARK, tmparyval, newlen, SV*);
4234 MARK = ORIGMARK + 1;
4235 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4236 MEXTEND(MARK, length);
4237 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4239 EXTEND_MORTAL(length);
4240 for (i = length, dst = MARK; i; i--) {
4241 sv_2mortal(*dst); /* free them eventualy */
4248 *MARK = AvARRAY(ary)[offset+length-1];
4251 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4252 SvREFCNT_dec(*dst++); /* free them now */
4255 AvFILLp(ary) += diff;
4257 /* pull up or down? */
4259 if (offset < after) { /* easier to pull up */
4260 if (offset) { /* esp. if nothing to pull */
4261 src = &AvARRAY(ary)[offset-1];
4262 dst = src - diff; /* diff is negative */
4263 for (i = offset; i > 0; i--) /* can't trust Copy */
4267 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4271 if (after) { /* anything to pull down? */
4272 src = AvARRAY(ary) + offset + length;
4273 dst = src + diff; /* diff is negative */
4274 Move(src, dst, after, SV*);
4276 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4277 /* avoid later double free */
4281 dst[--i] = &PL_sv_undef;
4284 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4285 Safefree(tmparyval);
4288 else { /* no, expanding (or same) */
4290 New(452, tmparyval, length, SV*); /* so remember deletion */
4291 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4294 if (diff > 0) { /* expanding */
4296 /* push up or down? */
4298 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4302 Move(src, dst, offset, SV*);
4304 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4306 AvFILLp(ary) += diff;
4309 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4310 av_extend(ary, AvFILLp(ary) + diff);
4311 AvFILLp(ary) += diff;
4314 dst = AvARRAY(ary) + AvFILLp(ary);
4316 for (i = after; i; i--) {
4324 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4327 MARK = ORIGMARK + 1;
4328 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4330 Copy(tmparyval, MARK, length, SV*);
4332 EXTEND_MORTAL(length);
4333 for (i = length, dst = MARK; i; i--) {
4334 sv_2mortal(*dst); /* free them eventualy */
4338 Safefree(tmparyval);
4342 else if (length--) {
4343 *MARK = tmparyval[length];
4346 while (length-- > 0)
4347 SvREFCNT_dec(tmparyval[length]);
4349 Safefree(tmparyval);
4352 *MARK = &PL_sv_undef;
4360 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4361 register AV *ary = (AV*)*++MARK;
4362 register SV *sv = &PL_sv_undef;
4365 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4366 *MARK-- = SvTIED_obj((SV*)ary, mg);
4370 call_method("PUSH",G_SCALAR|G_DISCARD);
4375 /* Why no pre-extend of ary here ? */
4376 for (++MARK; MARK <= SP; MARK++) {
4379 sv_setsv(sv, *MARK);
4384 PUSHi( AvFILL(ary) + 1 );
4392 SV *sv = av_pop(av);
4394 (void)sv_2mortal(sv);
4403 SV *sv = av_shift(av);
4408 (void)sv_2mortal(sv);
4415 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4416 register AV *ary = (AV*)*++MARK;
4421 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4422 *MARK-- = SvTIED_obj((SV*)ary, mg);
4426 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4431 av_unshift(ary, SP - MARK);
4433 sv = newSVsv(*++MARK);
4434 (void)av_store(ary, i++, sv);
4438 PUSHi( AvFILL(ary) + 1 );
4448 if (GIMME == G_ARRAY) {
4455 /* safe as long as stack cannot get extended in the above */
4460 register char *down;
4466 SvUTF8_off(TARG); /* decontaminate */
4468 do_join(TARG, &PL_sv_no, MARK, SP);
4470 sv_setsv(TARG, (SP > MARK)
4472 : (padoff_du = find_rundefsvoffset(),
4473 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4474 ? DEFSV : PAD_SVl(padoff_du)));
4475 up = SvPV_force(TARG, len);
4477 if (DO_UTF8(TARG)) { /* first reverse each character */
4478 U8* s = (U8*)SvPVX(TARG);
4479 U8* send = (U8*)(s + len);
4481 if (UTF8_IS_INVARIANT(*s)) {
4486 if (!utf8_to_uvchr(s, 0))
4490 down = (char*)(s - 1);
4491 /* reverse this character */
4495 *down-- = (char)tmp;
4501 down = SvPVX(TARG) + len - 1;
4505 *down-- = (char)tmp;
4507 (void)SvPOK_only_UTF8(TARG);
4519 register IV limit = POPi; /* note, negative is forever */
4522 register char *s = SvPV(sv, len);
4523 bool do_utf8 = DO_UTF8(sv);
4524 char *strend = s + len;
4526 register REGEXP *rx;
4530 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4531 I32 maxiters = slen + 10;
4534 I32 origlimit = limit;
4537 I32 gimme = GIMME_V;
4538 I32 oldsave = PL_savestack_ix;
4539 I32 make_mortal = 1;
4541 MAGIC *mg = (MAGIC *) NULL;
4544 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4549 DIE(aTHX_ "panic: pp_split");
4552 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4553 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4555 RX_MATCH_UTF8_set(rx, do_utf8);
4557 if (pm->op_pmreplroot) {
4559 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4561 ary = GvAVn((GV*)pm->op_pmreplroot);
4564 else if (gimme != G_ARRAY)
4565 ary = GvAVn(PL_defgv);
4568 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4574 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4576 XPUSHs(SvTIED_obj((SV*)ary, mg));
4582 for (i = AvFILLp(ary); i >= 0; i--)
4583 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4585 /* temporarily switch stacks */
4586 SAVESWITCHSTACK(PL_curstack, ary);
4590 base = SP - PL_stack_base;
4592 if (pm->op_pmflags & PMf_SKIPWHITE) {
4593 if (pm->op_pmflags & PMf_LOCALE) {
4594 while (isSPACE_LC(*s))
4602 if (pm->op_pmflags & PMf_MULTILINE) {
4607 limit = maxiters + 2;
4608 if (pm->op_pmflags & PMf_WHITE) {
4611 while (m < strend &&
4612 !((pm->op_pmflags & PMf_LOCALE)
4613 ? isSPACE_LC(*m) : isSPACE(*m)))
4618 dstr = newSVpvn(s, m-s);
4622 (void)SvUTF8_on(dstr);
4626 while (s < strend &&
4627 ((pm->op_pmflags & PMf_LOCALE)
4628 ? isSPACE_LC(*s) : isSPACE(*s)))
4632 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4635 for (m = s; m < strend && *m != '\n'; m++) ;
4639 dstr = newSVpvn(s, m-s);
4643 (void)SvUTF8_on(dstr);
4648 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4649 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4650 && (rx->reganch & ROPT_CHECK_ALL)
4651 && !(rx->reganch & ROPT_ANCH)) {
4652 int tail = (rx->reganch & RE_INTUIT_TAIL);
4653 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4656 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4658 char c = *SvPV(csv, n_a);
4661 for (m = s; m < strend && *m != c; m++) ;
4664 dstr = newSVpvn(s, m-s);
4668 (void)SvUTF8_on(dstr);
4670 /* The rx->minlen is in characters but we want to step
4671 * s ahead by bytes. */
4673 s = (char*)utf8_hop((U8*)m, len);
4675 s = m + len; /* Fake \n at the end */
4680 while (s < strend && --limit &&
4681 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4682 csv, multiline ? FBMrf_MULTILINE : 0)) )
4685 dstr = newSVpvn(s, m-s);
4689 (void)SvUTF8_on(dstr);
4691 /* The rx->minlen is in characters but we want to step
4692 * s ahead by bytes. */
4694 s = (char*)utf8_hop((U8*)m, len);
4696 s = m + len; /* Fake \n at the end */
4701 maxiters += slen * rx->nparens;
4702 while (s < strend && --limit)
4705 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4709 TAINT_IF(RX_MATCH_TAINTED(rx));
4710 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4715 strend = s + (strend - m);
4717 m = rx->startp[0] + orig;
4718 dstr = newSVpvn(s, m-s);
4722 (void)SvUTF8_on(dstr);
4725 for (i = 1; i <= (I32)rx->nparens; i++) {
4726 s = rx->startp[i] + orig;
4727 m = rx->endp[i] + orig;
4729 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4730 parens that didn't match -- they should be set to
4731 undef, not the empty string */
4732 if (m >= orig && s >= orig) {
4733 dstr = newSVpvn(s, m-s);
4736 dstr = &PL_sv_undef; /* undef, not "" */
4740 (void)SvUTF8_on(dstr);
4744 s = rx->endp[0] + orig;
4748 iters = (SP - PL_stack_base) - base;
4749 if (iters > maxiters)
4750 DIE(aTHX_ "Split loop");
4752 /* keep field after final delim? */
4753 if (s < strend || (iters && origlimit)) {
4754 STRLEN l = strend - s;
4755 dstr = newSVpvn(s, l);
4759 (void)SvUTF8_on(dstr);
4763 else if (!origlimit) {
4764 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4765 if (TOPs && !make_mortal)
4768 *SP-- = &PL_sv_undef;
4773 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4777 if (SvSMAGICAL(ary)) {
4782 if (gimme == G_ARRAY) {
4784 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4792 call_method("PUSH",G_SCALAR|G_DISCARD);
4795 if (gimme == G_ARRAY) {
4796 /* EXTEND should not be needed - we just popped them */
4798 for (i=0; i < iters; i++) {
4799 SV **svp = av_fetch(ary, i, FALSE);
4800 PUSHs((svp) ? *svp : &PL_sv_undef);
4807 if (gimme == G_ARRAY)
4822 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4823 || SvTYPE(retsv) == SVt_PVCV) {
4824 retsv = refto(retsv);
4832 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4837 * c-indentation-style: bsd
4839 * indent-tabs-mode: t
4842 * vim: shiftwidth=4: