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
392 || code == -KEY_exec || code == -KEY_system)
394 while (i < MAXO) { /* The slow way. */
395 if (strEQ(s + 6, PL_op_name[i])
396 || strEQ(s + 6, PL_op_desc[i]))
402 goto nonesuch; /* Should not happen... */
404 oa = PL_opargs[i] >> OASHIFT;
406 if (oa & OA_OPTIONAL && !seen_question) {
410 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
411 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
412 /* But globs are already references (kinda) */
413 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
417 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
421 ret = sv_2mortal(newSVpvn(str, n - 1));
423 else if (code) /* Non-Overridable */
425 else { /* None such */
427 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
431 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
433 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
442 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
444 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
460 if (GIMME != G_ARRAY) {
464 *MARK = &PL_sv_undef;
465 *MARK = refto(*MARK);
469 EXTEND_MORTAL(SP - MARK);
471 *MARK = refto(*MARK);
476 S_refto(pTHX_ SV *sv)
480 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
483 if (!(sv = LvTARG(sv)))
486 (void)SvREFCNT_inc(sv);
488 else if (SvTYPE(sv) == SVt_PVAV) {
489 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
492 (void)SvREFCNT_inc(sv);
494 else if (SvPADTMP(sv) && !IS_PADGV(sv))
498 (void)SvREFCNT_inc(sv);
501 sv_upgrade(rv, SVt_RV);
515 if (sv && SvGMAGICAL(sv))
518 if (!sv || !SvROK(sv))
522 pv = sv_reftype(sv,TRUE);
523 PUSHp(pv, strlen(pv));
533 stash = CopSTASH(PL_curcop);
539 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
540 Perl_croak(aTHX_ "Attempt to bless into a reference");
542 if (ckWARN(WARN_MISC) && len == 0)
543 Perl_warner(aTHX_ packWARN(WARN_MISC),
544 "Explicit blessing to '' (assuming package main)");
545 stash = gv_stashpvn(ptr, len, TRUE);
548 (void)sv_bless(TOPs, stash);
562 elem = SvPV(sv, n_a);
567 /* elem will always be NUL terminated. */
568 const char *elem2 = elem + 1;
571 if (strEQ(elem2, "RRAY"))
572 tmpRef = (SV*)GvAV(gv);
575 if (strEQ(elem2, "ODE"))
576 tmpRef = (SV*)GvCVu(gv);
579 if (strEQ(elem2, "ILEHANDLE")) {
580 /* finally deprecated in 5.8.0 */
581 deprecate("*glob{FILEHANDLE}");
582 tmpRef = (SV*)GvIOp(gv);
585 if (strEQ(elem2, "ORMAT"))
586 tmpRef = (SV*)GvFORM(gv);
589 if (strEQ(elem2, "LOB"))
593 if (strEQ(elem2, "ASH"))
594 tmpRef = (SV*)GvHV(gv);
597 if (*elem2 == 'O' && !elem[2])
598 tmpRef = (SV*)GvIOp(gv);
601 if (strEQ(elem2, "AME"))
602 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
605 if (strEQ(elem2, "ACKAGE")) {
606 const char *name = HvNAME(GvSTASH(gv));
607 sv = newSVpv(name ? name : "__ANON__", 0);
611 if (strEQ(elem2, "CALAR"))
626 /* Pattern matching */
631 register unsigned char *s;
634 register I32 *sfirst;
638 if (sv == PL_lastscream) {
644 SvSCREAM_off(PL_lastscream);
645 SvREFCNT_dec(PL_lastscream);
647 PL_lastscream = SvREFCNT_inc(sv);
650 s = (unsigned char*)(SvPV(sv, len));
654 if (pos > PL_maxscream) {
655 if (PL_maxscream < 0) {
656 PL_maxscream = pos + 80;
657 New(301, PL_screamfirst, 256, I32);
658 New(302, PL_screamnext, PL_maxscream, I32);
661 PL_maxscream = pos + pos / 4;
662 Renew(PL_screamnext, PL_maxscream, I32);
666 sfirst = PL_screamfirst;
667 snext = PL_screamnext;
669 if (!sfirst || !snext)
670 DIE(aTHX_ "do_study: out of memory");
672 for (ch = 256; ch; --ch)
679 snext[pos] = sfirst[ch] - pos;
686 /* piggyback on m//g magic */
687 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
696 if (PL_op->op_flags & OPf_STACKED)
698 else if (PL_op->op_private & OPpTARGET_MY)
704 TARG = sv_newmortal();
709 /* Lvalue operators. */
721 dSP; dMARK; dTARGET; dORIGMARK;
723 do_chop(TARG, *++MARK);
732 SETi(do_chomp(TOPs));
739 register I32 count = 0;
742 count += do_chomp(POPs);
753 if (!sv || !SvANY(sv))
755 switch (SvTYPE(sv)) {
757 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
758 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
762 if (HvARRAY(sv) || SvGMAGICAL(sv)
763 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
767 if (CvROOT(sv) || CvXSUB(sv))
784 if (!PL_op->op_private) {
793 SV_CHECK_THINKFIRST_COW_DROP(sv);
795 switch (SvTYPE(sv)) {
805 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
806 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
807 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
811 /* let user-undef'd sub keep its identity */
812 GV* gv = CvGV((CV*)sv);
819 SvSetMagicSV(sv, &PL_sv_undef);
823 Newz(602, gp, 1, GP);
824 GvGP(sv) = gp_ref(gp);
825 GvSV(sv) = NEWSV(72,0);
826 GvLINE(sv) = CopLINE(PL_curcop);
832 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
834 SvPV_set(sv, Nullch);
847 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
848 DIE(aTHX_ PL_no_modify);
849 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
850 && SvIVX(TOPs) != IV_MIN)
852 SvIV_set(TOPs, SvIVX(TOPs) - 1);
853 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
864 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
865 DIE(aTHX_ PL_no_modify);
866 sv_setsv(TARG, TOPs);
867 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
868 && SvIVX(TOPs) != IV_MAX)
870 SvIV_set(TOPs, SvIVX(TOPs) + 1);
871 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
876 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
886 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
887 DIE(aTHX_ PL_no_modify);
888 sv_setsv(TARG, TOPs);
889 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
890 && SvIVX(TOPs) != IV_MIN)
892 SvIV_set(TOPs, SvIVX(TOPs) - 1);
893 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
902 /* Ordinary operators. */
907 #ifdef PERL_PRESERVE_IVUV
910 tryAMAGICbin(pow,opASSIGN);
911 #ifdef PERL_PRESERVE_IVUV
912 /* For integer to integer power, we do the calculation by hand wherever
913 we're sure it is safe; otherwise we call pow() and try to convert to
914 integer afterwards. */
918 bool baseuok = SvUOK(TOPm1s);
922 baseuv = SvUVX(TOPm1s);
924 IV iv = SvIVX(TOPm1s);
927 baseuok = TRUE; /* effectively it's a UV now */
929 baseuv = -iv; /* abs, baseuok == false records sign */
943 goto float_it; /* Can't do negative powers this way. */
946 /* now we have integer ** positive integer. */
949 /* foo & (foo - 1) is zero only for a power of 2. */
950 if (!(baseuv & (baseuv - 1))) {
951 /* We are raising power-of-2 to a positive integer.
952 The logic here will work for any base (even non-integer
953 bases) but it can be less accurate than
954 pow (base,power) or exp (power * log (base)) when the
955 intermediate values start to spill out of the mantissa.
956 With powers of 2 we know this can't happen.
957 And powers of 2 are the favourite thing for perl
958 programmers to notice ** not doing what they mean. */
960 NV base = baseuok ? baseuv : -(NV)baseuv;
963 for (; power; base *= base, n++) {
964 /* Do I look like I trust gcc with long longs here?
966 UV bit = (UV)1 << (UV)n;
969 /* Only bother to clear the bit if it is set. */
971 /* Avoid squaring base again if we're done. */
972 if (power == 0) break;
980 register unsigned int highbit = 8 * sizeof(UV);
981 register unsigned int lowbit = 0;
982 register unsigned int diff;
983 bool odd_power = (bool)(power & 1);
984 while ((diff = (highbit - lowbit) >> 1)) {
985 if (baseuv & ~((1 << (lowbit + diff)) - 1))
990 /* we now have baseuv < 2 ** highbit */
991 if (power * highbit <= 8 * sizeof(UV)) {
992 /* result will definitely fit in UV, so use UV math
993 on same algorithm as above */
994 register UV result = 1;
995 register UV base = baseuv;
997 for (; power; base *= base, n++) {
998 register UV bit = (UV)1 << (UV)n;
1002 if (power == 0) break;
1006 if (baseuok || !odd_power)
1007 /* answer is positive */
1009 else if (result <= (UV)IV_MAX)
1010 /* answer negative, fits in IV */
1011 SETi( -(IV)result );
1012 else if (result == (UV)IV_MIN)
1013 /* 2's complement assumption: special case IV_MIN */
1016 /* answer negative, doesn't fit */
1017 SETn( -(NV)result );
1028 SETn( Perl_pow( left, right) );
1029 #ifdef PERL_PRESERVE_IVUV
1039 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1040 #ifdef PERL_PRESERVE_IVUV
1043 /* Unless the left argument is integer in range we are going to have to
1044 use NV maths. Hence only attempt to coerce the right argument if
1045 we know the left is integer. */
1046 /* Left operand is defined, so is it IV? */
1047 SvIV_please(TOPm1s);
1048 if (SvIOK(TOPm1s)) {
1049 bool auvok = SvUOK(TOPm1s);
1050 bool buvok = SvUOK(TOPs);
1051 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1052 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1059 alow = SvUVX(TOPm1s);
1061 IV aiv = SvIVX(TOPm1s);
1064 auvok = TRUE; /* effectively it's a UV now */
1066 alow = -aiv; /* abs, auvok == false records sign */
1072 IV biv = SvIVX(TOPs);
1075 buvok = TRUE; /* effectively it's a UV now */
1077 blow = -biv; /* abs, buvok == false records sign */
1081 /* If this does sign extension on unsigned it's time for plan B */
1082 ahigh = alow >> (4 * sizeof (UV));
1084 bhigh = blow >> (4 * sizeof (UV));
1086 if (ahigh && bhigh) {
1087 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1088 which is overflow. Drop to NVs below. */
1089 } else if (!ahigh && !bhigh) {
1090 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1091 so the unsigned multiply cannot overflow. */
1092 UV product = alow * blow;
1093 if (auvok == buvok) {
1094 /* -ve * -ve or +ve * +ve gives a +ve result. */
1098 } else if (product <= (UV)IV_MIN) {
1099 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1100 /* -ve result, which could overflow an IV */
1102 SETi( -(IV)product );
1104 } /* else drop to NVs below. */
1106 /* One operand is large, 1 small */
1109 /* swap the operands */
1111 bhigh = blow; /* bhigh now the temp var for the swap */
1115 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1116 multiplies can't overflow. shift can, add can, -ve can. */
1117 product_middle = ahigh * blow;
1118 if (!(product_middle & topmask)) {
1119 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1121 product_middle <<= (4 * sizeof (UV));
1122 product_low = alow * blow;
1124 /* as for pp_add, UV + something mustn't get smaller.
1125 IIRC ANSI mandates this wrapping *behaviour* for
1126 unsigned whatever the actual representation*/
1127 product_low += product_middle;
1128 if (product_low >= product_middle) {
1129 /* didn't overflow */
1130 if (auvok == buvok) {
1131 /* -ve * -ve or +ve * +ve gives a +ve result. */
1133 SETu( product_low );
1135 } else if (product_low <= (UV)IV_MIN) {
1136 /* 2s complement assumption again */
1137 /* -ve result, which could overflow an IV */
1139 SETi( -(IV)product_low );
1141 } /* else drop to NVs below. */
1143 } /* product_middle too large */
1144 } /* ahigh && bhigh */
1145 } /* SvIOK(TOPm1s) */
1150 SETn( left * right );
1157 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1158 /* Only try to do UV divide first
1159 if ((SLOPPYDIVIDE is true) or
1160 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1162 The assumption is that it is better to use floating point divide
1163 whenever possible, only doing integer divide first if we can't be sure.
1164 If NV_PRESERVES_UV is true then we know at compile time that no UV
1165 can be too large to preserve, so don't need to compile the code to
1166 test the size of UVs. */
1169 # define PERL_TRY_UV_DIVIDE
1170 /* ensure that 20./5. == 4. */
1172 # ifdef PERL_PRESERVE_IVUV
1173 # ifndef NV_PRESERVES_UV
1174 # define PERL_TRY_UV_DIVIDE
1179 #ifdef PERL_TRY_UV_DIVIDE
1182 SvIV_please(TOPm1s);
1183 if (SvIOK(TOPm1s)) {
1184 bool left_non_neg = SvUOK(TOPm1s);
1185 bool right_non_neg = SvUOK(TOPs);
1189 if (right_non_neg) {
1190 right = SvUVX(TOPs);
1193 IV biv = SvIVX(TOPs);
1196 right_non_neg = TRUE; /* effectively it's a UV now */
1202 /* historically undef()/0 gives a "Use of uninitialized value"
1203 warning before dieing, hence this test goes here.
1204 If it were immediately before the second SvIV_please, then
1205 DIE() would be invoked before left was even inspected, so
1206 no inpsection would give no warning. */
1208 DIE(aTHX_ "Illegal division by zero");
1211 left = SvUVX(TOPm1s);
1214 IV aiv = SvIVX(TOPm1s);
1217 left_non_neg = TRUE; /* effectively it's a UV now */
1226 /* For sloppy divide we always attempt integer division. */
1228 /* Otherwise we only attempt it if either or both operands
1229 would not be preserved by an NV. If both fit in NVs
1230 we fall through to the NV divide code below. However,
1231 as left >= right to ensure integer result here, we know that
1232 we can skip the test on the right operand - right big
1233 enough not to be preserved can't get here unless left is
1236 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1239 /* Integer division can't overflow, but it can be imprecise. */
1240 UV result = left / right;
1241 if (result * right == left) {
1242 SP--; /* result is valid */
1243 if (left_non_neg == right_non_neg) {
1244 /* signs identical, result is positive. */
1248 /* 2s complement assumption */
1249 if (result <= (UV)IV_MIN)
1250 SETi( -(IV)result );
1252 /* It's exact but too negative for IV. */
1253 SETn( -(NV)result );
1256 } /* tried integer divide but it was not an integer result */
1257 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1258 } /* left wasn't SvIOK */
1259 } /* right wasn't SvIOK */
1260 #endif /* PERL_TRY_UV_DIVIDE */
1264 DIE(aTHX_ "Illegal division by zero");
1265 PUSHn( left / right );
1272 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1276 bool left_neg = FALSE;
1277 bool right_neg = FALSE;
1278 bool use_double = FALSE;
1279 bool dright_valid = FALSE;
1285 right_neg = !SvUOK(TOPs);
1287 right = SvUVX(POPs);
1289 IV biv = SvIVX(POPs);
1292 right_neg = FALSE; /* effectively it's a UV now */
1300 right_neg = dright < 0;
1303 if (dright < UV_MAX_P1) {
1304 right = U_V(dright);
1305 dright_valid = TRUE; /* In case we need to use double below. */
1311 /* At this point use_double is only true if right is out of range for
1312 a UV. In range NV has been rounded down to nearest UV and
1313 use_double false. */
1315 if (!use_double && SvIOK(TOPs)) {
1317 left_neg = !SvUOK(TOPs);
1321 IV aiv = SvIVX(POPs);
1324 left_neg = FALSE; /* effectively it's a UV now */
1333 left_neg = dleft < 0;
1337 /* This should be exactly the 5.6 behaviour - if left and right are
1338 both in range for UV then use U_V() rather than floor. */
1340 if (dleft < UV_MAX_P1) {
1341 /* right was in range, so is dleft, so use UVs not double.
1345 /* left is out of range for UV, right was in range, so promote
1346 right (back) to double. */
1348 /* The +0.5 is used in 5.6 even though it is not strictly
1349 consistent with the implicit +0 floor in the U_V()
1350 inside the #if 1. */
1351 dleft = Perl_floor(dleft + 0.5);
1354 dright = Perl_floor(dright + 0.5);
1364 DIE(aTHX_ "Illegal modulus zero");
1366 dans = Perl_fmod(dleft, dright);
1367 if ((left_neg != right_neg) && dans)
1368 dans = dright - dans;
1371 sv_setnv(TARG, dans);
1377 DIE(aTHX_ "Illegal modulus zero");
1380 if ((left_neg != right_neg) && ans)
1383 /* XXX may warn: unary minus operator applied to unsigned type */
1384 /* could change -foo to be (~foo)+1 instead */
1385 if (ans <= ~((UV)IV_MAX)+1)
1386 sv_setiv(TARG, ~ans+1);
1388 sv_setnv(TARG, -(NV)ans);
1391 sv_setuv(TARG, ans);
1400 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1410 count = IV_MAX; /* The best we can do? */
1421 else if (SvNOKp(sv)) {
1430 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1432 I32 items = SP - MARK;
1434 static const char oom_list_extend[] =
1435 "Out of memory during list extend";
1437 max = items * count;
1438 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1439 /* Did the max computation overflow? */
1440 if (items > 0 && max > 0 && (max < items || max < count))
1441 Perl_croak(aTHX_ oom_list_extend);
1446 /* This code was intended to fix 20010809.028:
1449 for (($x =~ /./g) x 2) {
1450 print chop; # "abcdabcd" expected as output.
1453 * but that change (#11635) broke this code:
1455 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1457 * I can't think of a better fix that doesn't introduce
1458 * an efficiency hit by copying the SVs. The stack isn't
1459 * refcounted, and mortalisation obviously doesn't
1460 * Do The Right Thing when the stack has more than
1461 * one pointer to the same mortal value.
1465 *SP = sv_2mortal(newSVsv(*SP));
1475 repeatcpy((char*)(MARK + items), (char*)MARK,
1476 items * sizeof(SV*), count - 1);
1479 else if (count <= 0)
1482 else { /* Note: mark already snarfed by pp_list */
1486 static const char oom_string_extend[] =
1487 "Out of memory during string extend";
1489 SvSetSV(TARG, tmpstr);
1490 SvPV_force(TARG, len);
1491 isutf = DO_UTF8(TARG);
1496 STRLEN max = (UV)count * len;
1497 if (len > ((MEM_SIZE)~0)/count)
1498 Perl_croak(aTHX_ oom_string_extend);
1499 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1500 SvGROW(TARG, max + 1);
1501 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1502 SvCUR_set(TARG, SvCUR(TARG) * count);
1504 *SvEND(TARG) = '\0';
1507 (void)SvPOK_only_UTF8(TARG);
1509 (void)SvPOK_only(TARG);
1511 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1512 /* The parser saw this as a list repeat, and there
1513 are probably several items on the stack. But we're
1514 in scalar context, and there's no pp_list to save us
1515 now. So drop the rest of the items -- robin@kitsite.com
1528 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1529 useleft = USE_LEFT(TOPm1s);
1530 #ifdef PERL_PRESERVE_IVUV
1531 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1532 "bad things" happen if you rely on signed integers wrapping. */
1535 /* Unless the left argument is integer in range we are going to have to
1536 use NV maths. Hence only attempt to coerce the right argument if
1537 we know the left is integer. */
1538 register UV auv = 0;
1544 a_valid = auvok = 1;
1545 /* left operand is undef, treat as zero. */
1547 /* Left operand is defined, so is it IV? */
1548 SvIV_please(TOPm1s);
1549 if (SvIOK(TOPm1s)) {
1550 if ((auvok = SvUOK(TOPm1s)))
1551 auv = SvUVX(TOPm1s);
1553 register IV aiv = SvIVX(TOPm1s);
1556 auvok = 1; /* Now acting as a sign flag. */
1557 } else { /* 2s complement assumption for IV_MIN */
1565 bool result_good = 0;
1568 bool buvok = SvUOK(TOPs);
1573 register IV biv = SvIVX(TOPs);
1580 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1581 else "IV" now, independent of how it came in.
1582 if a, b represents positive, A, B negative, a maps to -A etc
1587 all UV maths. negate result if A negative.
1588 subtract if signs same, add if signs differ. */
1590 if (auvok ^ buvok) {
1599 /* Must get smaller */
1604 if (result <= buv) {
1605 /* result really should be -(auv-buv). as its negation
1606 of true value, need to swap our result flag */
1618 if (result <= (UV)IV_MIN)
1619 SETi( -(IV)result );
1621 /* result valid, but out of range for IV. */
1622 SETn( -(NV)result );
1626 } /* Overflow, drop through to NVs. */
1630 useleft = USE_LEFT(TOPm1s);
1634 /* left operand is undef, treat as zero - value */
1638 SETn( TOPn - value );
1645 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1648 if (PL_op->op_private & HINT_INTEGER) {
1662 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1665 if (PL_op->op_private & HINT_INTEGER) {
1679 dSP; tryAMAGICbinSET(lt,0);
1680 #ifdef PERL_PRESERVE_IVUV
1683 SvIV_please(TOPm1s);
1684 if (SvIOK(TOPm1s)) {
1685 bool auvok = SvUOK(TOPm1s);
1686 bool buvok = SvUOK(TOPs);
1688 if (!auvok && !buvok) { /* ## IV < IV ## */
1689 IV aiv = SvIVX(TOPm1s);
1690 IV biv = SvIVX(TOPs);
1693 SETs(boolSV(aiv < biv));
1696 if (auvok && buvok) { /* ## UV < UV ## */
1697 UV auv = SvUVX(TOPm1s);
1698 UV buv = SvUVX(TOPs);
1701 SETs(boolSV(auv < buv));
1704 if (auvok) { /* ## UV < IV ## */
1711 /* As (a) is a UV, it's >=0, so it cannot be < */
1716 SETs(boolSV(auv < (UV)biv));
1719 { /* ## IV < UV ## */
1723 aiv = SvIVX(TOPm1s);
1725 /* As (b) is a UV, it's >=0, so it must be < */
1732 SETs(boolSV((UV)aiv < buv));
1738 #ifndef NV_PRESERVES_UV
1739 #ifdef PERL_PRESERVE_IVUV
1742 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1744 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1750 SETs(boolSV(TOPn < value));
1757 dSP; tryAMAGICbinSET(gt,0);
1758 #ifdef PERL_PRESERVE_IVUV
1761 SvIV_please(TOPm1s);
1762 if (SvIOK(TOPm1s)) {
1763 bool auvok = SvUOK(TOPm1s);
1764 bool buvok = SvUOK(TOPs);
1766 if (!auvok && !buvok) { /* ## IV > IV ## */
1767 IV aiv = SvIVX(TOPm1s);
1768 IV biv = SvIVX(TOPs);
1771 SETs(boolSV(aiv > biv));
1774 if (auvok && buvok) { /* ## UV > UV ## */
1775 UV auv = SvUVX(TOPm1s);
1776 UV buv = SvUVX(TOPs);
1779 SETs(boolSV(auv > buv));
1782 if (auvok) { /* ## UV > IV ## */
1789 /* As (a) is a UV, it's >=0, so it must be > */
1794 SETs(boolSV(auv > (UV)biv));
1797 { /* ## IV > UV ## */
1801 aiv = SvIVX(TOPm1s);
1803 /* As (b) is a UV, it's >=0, so it cannot be > */
1810 SETs(boolSV((UV)aiv > buv));
1816 #ifndef NV_PRESERVES_UV
1817 #ifdef PERL_PRESERVE_IVUV
1820 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1822 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1828 SETs(boolSV(TOPn > value));
1835 dSP; tryAMAGICbinSET(le,0);
1836 #ifdef PERL_PRESERVE_IVUV
1839 SvIV_please(TOPm1s);
1840 if (SvIOK(TOPm1s)) {
1841 bool auvok = SvUOK(TOPm1s);
1842 bool buvok = SvUOK(TOPs);
1844 if (!auvok && !buvok) { /* ## IV <= IV ## */
1845 IV aiv = SvIVX(TOPm1s);
1846 IV biv = SvIVX(TOPs);
1849 SETs(boolSV(aiv <= biv));
1852 if (auvok && buvok) { /* ## UV <= UV ## */
1853 UV auv = SvUVX(TOPm1s);
1854 UV buv = SvUVX(TOPs);
1857 SETs(boolSV(auv <= buv));
1860 if (auvok) { /* ## UV <= IV ## */
1867 /* As (a) is a UV, it's >=0, so a cannot be <= */
1872 SETs(boolSV(auv <= (UV)biv));
1875 { /* ## IV <= UV ## */
1879 aiv = SvIVX(TOPm1s);
1881 /* As (b) is a UV, it's >=0, so a must be <= */
1888 SETs(boolSV((UV)aiv <= buv));
1894 #ifndef NV_PRESERVES_UV
1895 #ifdef PERL_PRESERVE_IVUV
1898 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1900 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1906 SETs(boolSV(TOPn <= value));
1913 dSP; tryAMAGICbinSET(ge,0);
1914 #ifdef PERL_PRESERVE_IVUV
1917 SvIV_please(TOPm1s);
1918 if (SvIOK(TOPm1s)) {
1919 bool auvok = SvUOK(TOPm1s);
1920 bool buvok = SvUOK(TOPs);
1922 if (!auvok && !buvok) { /* ## IV >= IV ## */
1923 IV aiv = SvIVX(TOPm1s);
1924 IV biv = SvIVX(TOPs);
1927 SETs(boolSV(aiv >= biv));
1930 if (auvok && buvok) { /* ## UV >= UV ## */
1931 UV auv = SvUVX(TOPm1s);
1932 UV buv = SvUVX(TOPs);
1935 SETs(boolSV(auv >= buv));
1938 if (auvok) { /* ## UV >= IV ## */
1945 /* As (a) is a UV, it's >=0, so it must be >= */
1950 SETs(boolSV(auv >= (UV)biv));
1953 { /* ## IV >= UV ## */
1957 aiv = SvIVX(TOPm1s);
1959 /* As (b) is a UV, it's >=0, so a cannot be >= */
1966 SETs(boolSV((UV)aiv >= buv));
1972 #ifndef NV_PRESERVES_UV
1973 #ifdef PERL_PRESERVE_IVUV
1976 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1978 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1984 SETs(boolSV(TOPn >= value));
1991 dSP; tryAMAGICbinSET(ne,0);
1992 #ifndef NV_PRESERVES_UV
1993 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1995 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1999 #ifdef PERL_PRESERVE_IVUV
2002 SvIV_please(TOPm1s);
2003 if (SvIOK(TOPm1s)) {
2004 bool auvok = SvUOK(TOPm1s);
2005 bool buvok = SvUOK(TOPs);
2007 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2008 /* Casting IV to UV before comparison isn't going to matter
2009 on 2s complement. On 1s complement or sign&magnitude
2010 (if we have any of them) it could make negative zero
2011 differ from normal zero. As I understand it. (Need to
2012 check - is negative zero implementation defined behaviour
2014 UV buv = SvUVX(POPs);
2015 UV auv = SvUVX(TOPs);
2017 SETs(boolSV(auv != buv));
2020 { /* ## Mixed IV,UV ## */
2024 /* != is commutative so swap if needed (save code) */
2026 /* swap. top of stack (b) is the iv */
2030 /* As (a) is a UV, it's >0, so it cannot be == */
2039 /* As (b) is a UV, it's >0, so it cannot be == */
2043 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2045 SETs(boolSV((UV)iv != uv));
2053 SETs(boolSV(TOPn != value));
2060 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2061 #ifndef NV_PRESERVES_UV
2062 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2063 UV right = PTR2UV(SvRV(POPs));
2064 UV left = PTR2UV(SvRV(TOPs));
2065 SETi((left > right) - (left < right));
2069 #ifdef PERL_PRESERVE_IVUV
2070 /* Fortunately it seems NaN isn't IOK */
2073 SvIV_please(TOPm1s);
2074 if (SvIOK(TOPm1s)) {
2075 bool leftuvok = SvUOK(TOPm1s);
2076 bool rightuvok = SvUOK(TOPs);
2078 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2079 IV leftiv = SvIVX(TOPm1s);
2080 IV rightiv = SvIVX(TOPs);
2082 if (leftiv > rightiv)
2084 else if (leftiv < rightiv)
2088 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2089 UV leftuv = SvUVX(TOPm1s);
2090 UV rightuv = SvUVX(TOPs);
2092 if (leftuv > rightuv)
2094 else if (leftuv < rightuv)
2098 } else if (leftuvok) { /* ## UV <=> IV ## */
2102 rightiv = SvIVX(TOPs);
2104 /* As (a) is a UV, it's >=0, so it cannot be < */
2107 leftuv = SvUVX(TOPm1s);
2108 if (leftuv > (UV)rightiv) {
2110 } else if (leftuv < (UV)rightiv) {
2116 } else { /* ## IV <=> UV ## */
2120 leftiv = SvIVX(TOPm1s);
2122 /* As (b) is a UV, it's >=0, so it must be < */
2125 rightuv = SvUVX(TOPs);
2126 if ((UV)leftiv > rightuv) {
2128 } else if ((UV)leftiv < rightuv) {
2146 if (Perl_isnan(left) || Perl_isnan(right)) {
2150 value = (left > right) - (left < right);
2154 else if (left < right)
2156 else if (left > right)
2170 dSP; tryAMAGICbinSET(slt,0);
2173 int cmp = (IN_LOCALE_RUNTIME
2174 ? sv_cmp_locale(left, right)
2175 : sv_cmp(left, right));
2176 SETs(boolSV(cmp < 0));
2183 dSP; tryAMAGICbinSET(sgt,0);
2186 int cmp = (IN_LOCALE_RUNTIME
2187 ? sv_cmp_locale(left, right)
2188 : sv_cmp(left, right));
2189 SETs(boolSV(cmp > 0));
2196 dSP; tryAMAGICbinSET(sle,0);
2199 int cmp = (IN_LOCALE_RUNTIME
2200 ? sv_cmp_locale(left, right)
2201 : sv_cmp(left, right));
2202 SETs(boolSV(cmp <= 0));
2209 dSP; tryAMAGICbinSET(sge,0);
2212 int cmp = (IN_LOCALE_RUNTIME
2213 ? sv_cmp_locale(left, right)
2214 : sv_cmp(left, right));
2215 SETs(boolSV(cmp >= 0));
2222 dSP; tryAMAGICbinSET(seq,0);
2225 SETs(boolSV(sv_eq(left, right)));
2232 dSP; tryAMAGICbinSET(sne,0);
2235 SETs(boolSV(!sv_eq(left, right)));
2242 dSP; dTARGET; tryAMAGICbin(scmp,0);
2245 int cmp = (IN_LOCALE_RUNTIME
2246 ? sv_cmp_locale(left, right)
2247 : sv_cmp(left, right));
2255 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2258 if (SvGMAGICAL(left)) mg_get(left);
2259 if (SvGMAGICAL(right)) mg_get(right);
2260 if (SvNIOKp(left) || SvNIOKp(right)) {
2261 if (PL_op->op_private & HINT_INTEGER) {
2262 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2266 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2271 do_vop(PL_op->op_type, TARG, left, right);
2280 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2283 if (SvGMAGICAL(left)) mg_get(left);
2284 if (SvGMAGICAL(right)) mg_get(right);
2285 if (SvNIOKp(left) || SvNIOKp(right)) {
2286 if (PL_op->op_private & HINT_INTEGER) {
2287 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2291 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2296 do_vop(PL_op->op_type, TARG, left, right);
2305 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2308 if (SvGMAGICAL(left)) mg_get(left);
2309 if (SvGMAGICAL(right)) mg_get(right);
2310 if (SvNIOKp(left) || SvNIOKp(right)) {
2311 if (PL_op->op_private & HINT_INTEGER) {
2312 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2316 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2321 do_vop(PL_op->op_type, TARG, left, right);
2330 dSP; dTARGET; tryAMAGICun(neg);
2333 int flags = SvFLAGS(sv);
2336 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2337 /* It's publicly an integer, or privately an integer-not-float */
2340 if (SvIVX(sv) == IV_MIN) {
2341 /* 2s complement assumption. */
2342 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2345 else if (SvUVX(sv) <= IV_MAX) {
2350 else if (SvIVX(sv) != IV_MIN) {
2354 #ifdef PERL_PRESERVE_IVUV
2363 else if (SvPOKp(sv)) {
2365 char *s = SvPV(sv, len);
2366 if (isIDFIRST(*s)) {
2367 sv_setpvn(TARG, "-", 1);
2370 else if (*s == '+' || *s == '-') {
2372 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2374 else if (DO_UTF8(sv)) {
2377 goto oops_its_an_int;
2379 sv_setnv(TARG, -SvNV(sv));
2381 sv_setpvn(TARG, "-", 1);
2388 goto oops_its_an_int;
2389 sv_setnv(TARG, -SvNV(sv));
2401 dSP; tryAMAGICunSET(not);
2402 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2408 dSP; dTARGET; tryAMAGICun(compl);
2414 if (PL_op->op_private & HINT_INTEGER) {
2415 IV i = ~SvIV_nomg(sv);
2419 UV u = ~SvUV_nomg(sv);
2428 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2429 sv_setsv_nomg(TARG, sv);
2430 tmps = (U8*)SvPV_force(TARG, len);
2433 /* Calculate exact length, let's not estimate. */
2442 while (tmps < send) {
2443 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2444 tmps += UTF8SKIP(tmps);
2445 targlen += UNISKIP(~c);
2451 /* Now rewind strings and write them. */
2455 Newz(0, result, targlen + 1, U8);
2456 while (tmps < send) {
2457 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2458 tmps += UTF8SKIP(tmps);
2459 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2463 sv_setpvn(TARG, (char*)result, targlen);
2467 Newz(0, result, nchar + 1, U8);
2468 while (tmps < send) {
2469 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2470 tmps += UTF8SKIP(tmps);
2475 sv_setpvn(TARG, (char*)result, nchar);
2484 register long *tmpl;
2485 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2488 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2493 for ( ; anum > 0; anum--, tmps++)
2502 /* integer versions of some of the above */
2506 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2509 SETi( left * right );
2516 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2520 DIE(aTHX_ "Illegal division by zero");
2521 value = POPi / value;
2530 /* This is the vanilla old i_modulo. */
2531 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2535 DIE(aTHX_ "Illegal modulus zero");
2536 SETi( left % right );
2541 #if defined(__GLIBC__) && IVSIZE == 8
2545 /* This is the i_modulo with the workaround for the _moddi3 bug
2546 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2547 * See below for pp_i_modulo. */
2548 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2552 DIE(aTHX_ "Illegal modulus zero");
2553 SETi( left % PERL_ABS(right) );
2561 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2565 DIE(aTHX_ "Illegal modulus zero");
2566 /* The assumption is to use hereafter the old vanilla version... */
2568 PL_ppaddr[OP_I_MODULO] =
2569 &Perl_pp_i_modulo_0;
2570 /* .. but if we have glibc, we might have a buggy _moddi3
2571 * (at least glicb 2.2.5 is known to have this bug), in other
2572 * words our integer modulus with negative quad as the second
2573 * argument might be broken. Test for this and re-patch the
2574 * opcode dispatch table if that is the case, remembering to
2575 * also apply the workaround so that this first round works
2576 * right, too. See [perl #9402] for more information. */
2577 #if defined(__GLIBC__) && IVSIZE == 8
2581 /* Cannot do this check with inlined IV constants since
2582 * that seems to work correctly even with the buggy glibc. */
2584 /* Yikes, we have the bug.
2585 * Patch in the workaround version. */
2587 PL_ppaddr[OP_I_MODULO] =
2588 &Perl_pp_i_modulo_1;
2589 /* Make certain we work right this time, too. */
2590 right = PERL_ABS(right);
2594 SETi( left % right );
2601 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2604 SETi( left + right );
2611 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2614 SETi( left - right );
2621 dSP; tryAMAGICbinSET(lt,0);
2624 SETs(boolSV(left < right));
2631 dSP; tryAMAGICbinSET(gt,0);
2634 SETs(boolSV(left > right));
2641 dSP; tryAMAGICbinSET(le,0);
2644 SETs(boolSV(left <= right));
2651 dSP; tryAMAGICbinSET(ge,0);
2654 SETs(boolSV(left >= right));
2661 dSP; tryAMAGICbinSET(eq,0);
2664 SETs(boolSV(left == right));
2671 dSP; tryAMAGICbinSET(ne,0);
2674 SETs(boolSV(left != right));
2681 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2688 else if (left < right)
2699 dSP; dTARGET; tryAMAGICun(neg);
2704 /* High falutin' math. */
2708 dSP; dTARGET; tryAMAGICbin(atan2,0);
2711 SETn(Perl_atan2(left, right));
2718 dSP; dTARGET; tryAMAGICun(sin);
2722 value = Perl_sin(value);
2730 dSP; dTARGET; tryAMAGICun(cos);
2734 value = Perl_cos(value);
2740 /* Support Configure command-line overrides for rand() functions.
2741 After 5.005, perhaps we should replace this by Configure support
2742 for drand48(), random(), or rand(). For 5.005, though, maintain
2743 compatibility by calling rand() but allow the user to override it.
2744 See INSTALL for details. --Andy Dougherty 15 July 1998
2746 /* Now it's after 5.005, and Configure supports drand48() and random(),
2747 in addition to rand(). So the overrides should not be needed any more.
2748 --Jarkko Hietaniemi 27 September 1998
2751 #ifndef HAS_DRAND48_PROTO
2752 extern double drand48 (void);
2765 if (!PL_srand_called) {
2766 (void)seedDrand01((Rand_seed_t)seed());
2767 PL_srand_called = TRUE;
2782 (void)seedDrand01((Rand_seed_t)anum);
2783 PL_srand_called = TRUE;
2790 dSP; dTARGET; tryAMAGICun(exp);
2794 value = Perl_exp(value);
2802 dSP; dTARGET; tryAMAGICun(log);
2807 SET_NUMERIC_STANDARD();
2808 DIE(aTHX_ "Can't take log of %"NVgf, value);
2810 value = Perl_log(value);
2818 dSP; dTARGET; tryAMAGICun(sqrt);
2823 SET_NUMERIC_STANDARD();
2824 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2826 value = Perl_sqrt(value);
2834 dSP; dTARGET; tryAMAGICun(int);
2837 IV iv = TOPi; /* attempt to convert to IV if possible. */
2838 /* XXX it's arguable that compiler casting to IV might be subtly
2839 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2840 else preferring IV has introduced a subtle behaviour change bug. OTOH
2841 relying on floating point to be accurate is a bug. */
2845 else if (SvIOK(TOPs)) {
2854 if (value < (NV)UV_MAX + 0.5) {
2857 SETn(Perl_floor(value));
2861 if (value > (NV)IV_MIN - 0.5) {
2864 SETn(Perl_ceil(value));
2874 dSP; dTARGET; tryAMAGICun(abs);
2876 /* This will cache the NV value if string isn't actually integer */
2881 else if (SvIOK(TOPs)) {
2882 /* IVX is precise */
2884 SETu(TOPu); /* force it to be numeric only */
2892 /* 2s complement assumption. Also, not really needed as
2893 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2913 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2919 tmps = (SvPVx(sv, len));
2921 /* If Unicode, try to downgrade
2922 * If not possible, croak. */
2923 SV* tsv = sv_2mortal(newSVsv(sv));
2926 sv_utf8_downgrade(tsv, FALSE);
2929 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2930 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2943 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2949 tmps = (SvPVx(sv, len));
2951 /* If Unicode, try to downgrade
2952 * If not possible, croak. */
2953 SV* tsv = sv_2mortal(newSVsv(sv));
2956 sv_utf8_downgrade(tsv, FALSE);
2959 while (*tmps && len && isSPACE(*tmps))
2964 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2965 else if (*tmps == 'b')
2966 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2968 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2970 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2987 SETi(sv_len_utf8(sv));
3003 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3005 const I32 arybase = PL_curcop->cop_arybase;
3007 const char *repl = 0;
3009 int num_args = PL_op->op_private & 7;
3010 bool repl_need_utf8_upgrade = FALSE;
3011 bool repl_is_utf8 = FALSE;
3013 SvTAINTED_off(TARG); /* decontaminate */
3014 SvUTF8_off(TARG); /* decontaminate */
3018 repl = SvPV(repl_sv, repl_len);
3019 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3029 sv_utf8_upgrade(sv);
3031 else if (DO_UTF8(sv))
3032 repl_need_utf8_upgrade = TRUE;
3034 tmps = SvPV(sv, curlen);
3036 utf8_curlen = sv_len_utf8(sv);
3037 if (utf8_curlen == curlen)
3040 curlen = utf8_curlen;
3045 if (pos >= arybase) {
3063 else if (len >= 0) {
3065 if (rem > (I32)curlen)
3080 Perl_croak(aTHX_ "substr outside of string");
3081 if (ckWARN(WARN_SUBSTR))
3082 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3089 sv_pos_u2b(sv, &pos, &rem);
3091 /* we either return a PV or an LV. If the TARG hasn't been used
3092 * before, or is of that type, reuse it; otherwise use a mortal
3093 * instead. Note that LVs can have an extended lifetime, so also
3094 * dont reuse if refcount > 1 (bug #20933) */
3095 if (SvTYPE(TARG) > SVt_NULL) {
3096 if ( (SvTYPE(TARG) == SVt_PVLV)
3097 ? (!lvalue || SvREFCNT(TARG) > 1)
3100 TARG = sv_newmortal();
3104 sv_setpvn(TARG, tmps, rem);
3105 #ifdef USE_LOCALE_COLLATE
3106 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3111 SV* repl_sv_copy = NULL;
3113 if (repl_need_utf8_upgrade) {
3114 repl_sv_copy = newSVsv(repl_sv);
3115 sv_utf8_upgrade(repl_sv_copy);
3116 repl = SvPV(repl_sv_copy, repl_len);
3117 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3119 sv_insert(sv, pos, rem, repl, repl_len);
3123 SvREFCNT_dec(repl_sv_copy);
3125 else if (lvalue) { /* it's an lvalue! */
3126 if (!SvGMAGICAL(sv)) {
3130 if (ckWARN(WARN_SUBSTR))
3131 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3132 "Attempt to use reference as lvalue in substr");
3134 if (SvOK(sv)) /* is it defined ? */
3135 (void)SvPOK_only_UTF8(sv);
3137 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3140 if (SvTYPE(TARG) < SVt_PVLV) {
3141 sv_upgrade(TARG, SVt_PVLV);
3142 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3148 if (LvTARG(TARG) != sv) {
3150 SvREFCNT_dec(LvTARG(TARG));
3151 LvTARG(TARG) = SvREFCNT_inc(sv);
3153 LvTARGOFF(TARG) = upos;
3154 LvTARGLEN(TARG) = urem;
3158 PUSHs(TARG); /* avoid SvSETMAGIC here */
3165 register IV size = POPi;
3166 register IV offset = POPi;
3167 register SV *src = POPs;
3168 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3170 SvTAINTED_off(TARG); /* decontaminate */
3171 if (lvalue) { /* it's an lvalue! */
3172 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3173 TARG = sv_newmortal();
3174 if (SvTYPE(TARG) < SVt_PVLV) {
3175 sv_upgrade(TARG, SVt_PVLV);
3176 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3179 if (LvTARG(TARG) != src) {
3181 SvREFCNT_dec(LvTARG(TARG));
3182 LvTARG(TARG) = SvREFCNT_inc(src);
3184 LvTARGOFF(TARG) = offset;
3185 LvTARGLEN(TARG) = size;
3188 sv_setuv(TARG, do_vecget(src, offset, size));
3204 I32 arybase = PL_curcop->cop_arybase;
3211 offset = POPi - arybase;
3214 big_utf8 = DO_UTF8(big);
3215 little_utf8 = DO_UTF8(little);
3216 if (big_utf8 ^ little_utf8) {
3217 /* One needs to be upgraded. */
3218 SV *bytes = little_utf8 ? big : little;
3220 char *p = SvPV(bytes, len);
3222 temp = newSVpvn(p, len);
3225 sv_recode_to_utf8(temp, PL_encoding);
3227 sv_utf8_upgrade(temp);
3236 if (big_utf8 && offset > 0)
3237 sv_pos_u2b(big, &offset, 0);
3238 tmps = SvPV(big, biglen);
3241 else if (offset > (I32)biglen)
3243 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3244 (unsigned char*)tmps + biglen, little, 0)))
3247 retval = tmps2 - tmps;
3248 if (retval > 0 && big_utf8)
3249 sv_pos_b2u(big, &retval);
3252 PUSHi(retval + arybase);
3268 I32 arybase = PL_curcop->cop_arybase;
3276 big_utf8 = DO_UTF8(big);
3277 little_utf8 = DO_UTF8(little);
3278 if (big_utf8 ^ little_utf8) {
3279 /* One needs to be upgraded. */
3280 SV *bytes = little_utf8 ? big : little;
3282 char *p = SvPV(bytes, len);
3284 temp = newSVpvn(p, len);
3287 sv_recode_to_utf8(temp, PL_encoding);
3289 sv_utf8_upgrade(temp);
3298 tmps2 = SvPV(little, llen);
3299 tmps = SvPV(big, blen);
3304 if (offset > 0 && big_utf8)
3305 sv_pos_u2b(big, &offset, 0);
3306 offset = offset - arybase + llen;
3310 else if (offset > (I32)blen)
3312 if (!(tmps2 = rninstr(tmps, tmps + offset,
3313 tmps2, tmps2 + llen)))
3316 retval = tmps2 - tmps;
3317 if (retval > 0 && big_utf8)
3318 sv_pos_b2u(big, &retval);
3321 PUSHi(retval + arybase);
3327 dSP; dMARK; dORIGMARK; dTARGET;
3328 do_sprintf(TARG, SP-MARK, MARK+1);
3329 TAINT_IF(SvTAINTED(TARG));
3330 if (DO_UTF8(*(MARK+1)))
3342 U8 *s = (U8*)SvPVx(argsv, len);
3345 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3346 tmpsv = sv_2mortal(newSVsv(argsv));
3347 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3351 XPUSHu(DO_UTF8(argsv) ?
3352 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3364 (void)SvUPGRADE(TARG,SVt_PV);
3366 if (value > 255 && !IN_BYTES) {
3367 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3368 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3369 SvCUR_set(TARG, tmps - SvPVX(TARG));
3371 (void)SvPOK_only(TARG);
3380 *tmps++ = (char)value;
3382 (void)SvPOK_only(TARG);
3383 if (PL_encoding && !IN_BYTES) {
3384 sv_recode_to_utf8(TARG, PL_encoding);
3386 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3387 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3391 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3392 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3408 char *tmps = SvPV(left, len);
3410 if (DO_UTF8(left)) {
3411 /* If Unicode, try to downgrade.
3412 * If not possible, croak.
3413 * Yes, we made this up. */
3414 SV* tsv = sv_2mortal(newSVsv(left));
3417 sv_utf8_downgrade(tsv, FALSE);
3420 # ifdef USE_ITHREADS
3422 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3423 /* This should be threadsafe because in ithreads there is only
3424 * one thread per interpreter. If this would not be true,
3425 * we would need a mutex to protect this malloc. */
3426 PL_reentrant_buffer->_crypt_struct_buffer =
3427 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3428 #if defined(__GLIBC__) || defined(__EMX__)
3429 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3430 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3431 /* work around glibc-2.2.5 bug */
3432 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3436 # endif /* HAS_CRYPT_R */
3437 # endif /* USE_ITHREADS */
3439 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3441 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3447 "The crypt() function is unimplemented due to excessive paranoia.");
3460 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3461 UTF8_IS_START(*s)) {
3462 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3466 utf8_to_uvchr(s, &ulen);
3467 toTITLE_utf8(s, tmpbuf, &tculen);
3468 utf8_to_uvchr(tmpbuf, 0);
3470 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3472 /* slen is the byte length of the whole SV.
3473 * ulen is the byte length of the original Unicode character
3474 * stored as UTF-8 at s.
3475 * tculen is the byte length of the freshly titlecased
3476 * Unicode character stored as UTF-8 at tmpbuf.
3477 * We first set the result to be the titlecased character,
3478 * and then append the rest of the SV data. */
3479 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3481 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3486 s = (U8*)SvPV_force_nomg(sv, slen);
3487 Copy(tmpbuf, s, tculen, U8);
3491 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3493 SvUTF8_off(TARG); /* decontaminate */
3494 sv_setsv_nomg(TARG, sv);
3498 s = (U8*)SvPV_force_nomg(sv, slen);
3500 if (IN_LOCALE_RUNTIME) {
3503 *s = toUPPER_LC(*s);
3522 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3523 UTF8_IS_START(*s)) {
3525 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3529 toLOWER_utf8(s, tmpbuf, &ulen);
3530 uv = utf8_to_uvchr(tmpbuf, 0);
3531 tend = uvchr_to_utf8(tmpbuf, uv);
3533 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3535 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3537 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3542 s = (U8*)SvPV_force_nomg(sv, slen);
3543 Copy(tmpbuf, s, ulen, U8);
3547 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3549 SvUTF8_off(TARG); /* decontaminate */
3550 sv_setsv_nomg(TARG, sv);
3554 s = (U8*)SvPV_force_nomg(sv, slen);
3556 if (IN_LOCALE_RUNTIME) {
3559 *s = toLOWER_LC(*s);
3582 U8 tmpbuf[UTF8_MAXBYTES+1];
3584 s = (U8*)SvPV_nomg(sv,len);
3586 SvUTF8_off(TARG); /* decontaminate */
3587 sv_setpvn(TARG, "", 0);
3591 STRLEN min = len + 1;
3593 (void)SvUPGRADE(TARG, SVt_PV);
3595 (void)SvPOK_only(TARG);
3596 d = (U8*)SvPVX(TARG);
3599 STRLEN u = UTF8SKIP(s);
3601 toUPPER_utf8(s, tmpbuf, &ulen);
3602 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3603 /* If the eventually required minimum size outgrows
3604 * the available space, we need to grow. */
3605 UV o = d - (U8*)SvPVX(TARG);
3607 /* If someone uppercases one million U+03B0s we
3608 * SvGROW() one million times. Or we could try
3609 * guessing how much to allocate without allocating
3610 * too much. Such is life. */
3612 d = (U8*)SvPVX(TARG) + o;
3614 Copy(tmpbuf, d, ulen, U8);
3620 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3625 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3627 SvUTF8_off(TARG); /* decontaminate */
3628 sv_setsv_nomg(TARG, sv);
3632 s = (U8*)SvPV_force_nomg(sv, len);
3634 register U8 *send = s + len;
3636 if (IN_LOCALE_RUNTIME) {
3639 for (; s < send; s++)
3640 *s = toUPPER_LC(*s);
3643 for (; s < send; s++)
3665 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3667 s = (U8*)SvPV_nomg(sv,len);
3669 SvUTF8_off(TARG); /* decontaminate */
3670 sv_setpvn(TARG, "", 0);
3674 STRLEN min = len + 1;
3676 (void)SvUPGRADE(TARG, SVt_PV);
3678 (void)SvPOK_only(TARG);
3679 d = (U8*)SvPVX(TARG);
3682 STRLEN u = UTF8SKIP(s);
3683 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3685 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3686 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3688 * Now if the sigma is NOT followed by
3689 * /$ignorable_sequence$cased_letter/;
3690 * and it IS preceded by
3691 * /$cased_letter$ignorable_sequence/;
3692 * where $ignorable_sequence is
3693 * [\x{2010}\x{AD}\p{Mn}]*
3694 * and $cased_letter is
3695 * [\p{Ll}\p{Lo}\p{Lt}]
3696 * then it should be mapped to 0x03C2,
3697 * (GREEK SMALL LETTER FINAL SIGMA),
3698 * instead of staying 0x03A3.
3699 * "should be": in other words,
3700 * this is not implemented yet.
3701 * See lib/unicore/SpecialCasing.txt.
3704 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3705 /* If the eventually required minimum size outgrows
3706 * the available space, we need to grow. */
3707 UV o = d - (U8*)SvPVX(TARG);
3709 /* If someone lowercases one million U+0130s we
3710 * SvGROW() one million times. Or we could try
3711 * guessing how much to allocate without allocating.
3712 * too much. Such is life. */
3714 d = (U8*)SvPVX(TARG) + o;
3716 Copy(tmpbuf, d, ulen, U8);
3722 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3727 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3729 SvUTF8_off(TARG); /* decontaminate */
3730 sv_setsv_nomg(TARG, sv);
3735 s = (U8*)SvPV_force_nomg(sv, len);
3737 register U8 *send = s + len;
3739 if (IN_LOCALE_RUNTIME) {
3742 for (; s < send; s++)
3743 *s = toLOWER_LC(*s);
3746 for (; s < send; s++)
3760 register char *s = SvPV(sv,len);
3763 SvUTF8_off(TARG); /* decontaminate */
3765 (void)SvUPGRADE(TARG, SVt_PV);
3766 SvGROW(TARG, (len * 2) + 1);
3770 if (UTF8_IS_CONTINUED(*s)) {
3771 STRLEN ulen = UTF8SKIP(s);
3795 SvCUR_set(TARG, d - SvPVX(TARG));
3796 (void)SvPOK_only_UTF8(TARG);
3799 sv_setpvn(TARG, s, len);
3801 if (SvSMAGICAL(TARG))
3810 dSP; dMARK; dORIGMARK;
3812 register AV* av = (AV*)POPs;
3813 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3814 I32 arybase = PL_curcop->cop_arybase;
3817 if (SvTYPE(av) == SVt_PVAV) {
3818 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3820 for (svp = MARK + 1; svp <= SP; svp++) {
3825 if (max > AvMAX(av))
3828 while (++MARK <= SP) {
3829 elem = SvIVx(*MARK);
3833 svp = av_fetch(av, elem, lval);
3835 if (!svp || *svp == &PL_sv_undef)
3836 DIE(aTHX_ PL_no_aelem, elem);
3837 if (PL_op->op_private & OPpLVAL_INTRO)
3838 save_aelem(av, elem, svp);
3840 *MARK = svp ? *svp : &PL_sv_undef;
3843 if (GIMME != G_ARRAY) {
3845 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3851 /* Associative arrays. */
3856 HV *hash = (HV*)POPs;
3858 I32 gimme = GIMME_V;
3861 /* might clobber stack_sp */
3862 entry = hv_iternext(hash);
3867 SV* sv = hv_iterkeysv(entry);
3868 PUSHs(sv); /* won't clobber stack_sp */
3869 if (gimme == G_ARRAY) {
3872 /* might clobber stack_sp */
3873 val = hv_iterval(hash, entry);
3878 else if (gimme == G_SCALAR)
3897 I32 gimme = GIMME_V;
3898 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3902 if (PL_op->op_private & OPpSLICE) {
3906 hvtype = SvTYPE(hv);
3907 if (hvtype == SVt_PVHV) { /* hash element */
3908 while (++MARK <= SP) {
3909 sv = hv_delete_ent(hv, *MARK, discard, 0);
3910 *MARK = sv ? sv : &PL_sv_undef;
3913 else if (hvtype == SVt_PVAV) { /* array element */
3914 if (PL_op->op_flags & OPf_SPECIAL) {
3915 while (++MARK <= SP) {
3916 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3917 *MARK = sv ? sv : &PL_sv_undef;
3922 DIE(aTHX_ "Not a HASH reference");
3925 else if (gimme == G_SCALAR) {
3930 *++MARK = &PL_sv_undef;
3937 if (SvTYPE(hv) == SVt_PVHV)
3938 sv = hv_delete_ent(hv, keysv, discard, 0);
3939 else if (SvTYPE(hv) == SVt_PVAV) {
3940 if (PL_op->op_flags & OPf_SPECIAL)
3941 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3943 DIE(aTHX_ "panic: avhv_delete no longer supported");
3946 DIE(aTHX_ "Not a HASH reference");
3961 if (PL_op->op_private & OPpEXISTS_SUB) {
3965 cv = sv_2cv(sv, &hv, &gv, FALSE);
3968 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3974 if (SvTYPE(hv) == SVt_PVHV) {
3975 if (hv_exists_ent(hv, tmpsv, 0))
3978 else if (SvTYPE(hv) == SVt_PVAV) {
3979 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3980 if (av_exists((AV*)hv, SvIV(tmpsv)))
3985 DIE(aTHX_ "Not a HASH reference");
3992 dSP; dMARK; dORIGMARK;
3993 register HV *hv = (HV*)POPs;
3994 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3995 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3996 bool other_magic = FALSE;
4002 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4003 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4004 /* Try to preserve the existenceness of a tied hash
4005 * element by using EXISTS and DELETE if possible.
4006 * Fallback to FETCH and STORE otherwise */
4007 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4008 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4009 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4012 while (++MARK <= SP) {
4016 bool preeminent = FALSE;
4019 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4020 hv_exists_ent(hv, keysv, 0);
4023 he = hv_fetch_ent(hv, keysv, lval, 0);
4024 svp = he ? &HeVAL(he) : 0;
4027 if (!svp || *svp == &PL_sv_undef) {
4029 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
4033 save_helem(hv, keysv, svp);
4036 char *key = SvPV(keysv, keylen);
4037 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4041 *MARK = svp ? *svp : &PL_sv_undef;
4043 if (GIMME != G_ARRAY) {
4045 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4051 /* List operators. */
4056 if (GIMME != G_ARRAY) {
4058 *MARK = *SP; /* unwanted list, return last item */
4060 *MARK = &PL_sv_undef;
4069 SV **lastrelem = PL_stack_sp;
4070 SV **lastlelem = PL_stack_base + POPMARK;
4071 SV **firstlelem = PL_stack_base + POPMARK + 1;
4072 register SV **firstrelem = lastlelem + 1;
4073 I32 arybase = PL_curcop->cop_arybase;
4074 I32 lval = PL_op->op_flags & OPf_MOD;
4075 I32 is_something_there = lval;
4077 register I32 max = lastrelem - lastlelem;
4078 register SV **lelem;
4081 if (GIMME != G_ARRAY) {
4082 ix = SvIVx(*lastlelem);
4087 if (ix < 0 || ix >= max)
4088 *firstlelem = &PL_sv_undef;
4090 *firstlelem = firstrelem[ix];
4096 SP = firstlelem - 1;
4100 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4106 if (ix < 0 || ix >= max)
4107 *lelem = &PL_sv_undef;
4109 is_something_there = TRUE;
4110 if (!(*lelem = firstrelem[ix]))
4111 *lelem = &PL_sv_undef;
4114 if (is_something_there)
4117 SP = firstlelem - 1;
4123 dSP; dMARK; dORIGMARK;
4124 I32 items = SP - MARK;
4125 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4126 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4133 dSP; dMARK; dORIGMARK;
4134 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4138 SV *val = NEWSV(46, 0);
4140 sv_setsv(val, *++MARK);
4141 else if (ckWARN(WARN_MISC))
4142 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4143 (void)hv_store_ent(hv,key,val,0);
4152 dVAR; dSP; dMARK; dORIGMARK;
4153 register AV *ary = (AV*)*++MARK;
4157 register I32 offset;
4158 register I32 length;
4165 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4166 *MARK-- = SvTIED_obj((SV*)ary, mg);
4170 call_method("SPLICE",GIMME_V);
4179 offset = i = SvIVx(*MARK);
4181 offset += AvFILLp(ary) + 1;
4183 offset -= PL_curcop->cop_arybase;
4185 DIE(aTHX_ PL_no_aelem, i);
4187 length = SvIVx(*MARK++);
4189 length += AvFILLp(ary) - offset + 1;
4195 length = AvMAX(ary) + 1; /* close enough to infinity */
4199 length = AvMAX(ary) + 1;
4201 if (offset > AvFILLp(ary) + 1) {
4202 if (ckWARN(WARN_MISC))
4203 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4204 offset = AvFILLp(ary) + 1;
4206 after = AvFILLp(ary) + 1 - (offset + length);
4207 if (after < 0) { /* not that much array */
4208 length += after; /* offset+length now in array */
4214 /* At this point, MARK .. SP-1 is our new LIST */
4217 diff = newlen - length;
4218 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4221 /* make new elements SVs now: avoid problems if they're from the array */
4222 for (dst = MARK, i = newlen; i; i--) {
4224 *dst++ = newSVsv(h);
4227 if (diff < 0) { /* shrinking the area */
4229 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4230 Copy(MARK, tmparyval, newlen, SV*);
4233 MARK = ORIGMARK + 1;
4234 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4235 MEXTEND(MARK, length);
4236 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4238 EXTEND_MORTAL(length);
4239 for (i = length, dst = MARK; i; i--) {
4240 sv_2mortal(*dst); /* free them eventualy */
4247 *MARK = AvARRAY(ary)[offset+length-1];
4250 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4251 SvREFCNT_dec(*dst++); /* free them now */
4254 AvFILLp(ary) += diff;
4256 /* pull up or down? */
4258 if (offset < after) { /* easier to pull up */
4259 if (offset) { /* esp. if nothing to pull */
4260 src = &AvARRAY(ary)[offset-1];
4261 dst = src - diff; /* diff is negative */
4262 for (i = offset; i > 0; i--) /* can't trust Copy */
4266 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4270 if (after) { /* anything to pull down? */
4271 src = AvARRAY(ary) + offset + length;
4272 dst = src + diff; /* diff is negative */
4273 Move(src, dst, after, SV*);
4275 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4276 /* avoid later double free */
4280 dst[--i] = &PL_sv_undef;
4283 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4284 Safefree(tmparyval);
4287 else { /* no, expanding (or same) */
4289 New(452, tmparyval, length, SV*); /* so remember deletion */
4290 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4293 if (diff > 0) { /* expanding */
4295 /* push up or down? */
4297 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4301 Move(src, dst, offset, SV*);
4303 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4305 AvFILLp(ary) += diff;
4308 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4309 av_extend(ary, AvFILLp(ary) + diff);
4310 AvFILLp(ary) += diff;
4313 dst = AvARRAY(ary) + AvFILLp(ary);
4315 for (i = after; i; i--) {
4323 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4326 MARK = ORIGMARK + 1;
4327 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4329 Copy(tmparyval, MARK, length, SV*);
4331 EXTEND_MORTAL(length);
4332 for (i = length, dst = MARK; i; i--) {
4333 sv_2mortal(*dst); /* free them eventualy */
4337 Safefree(tmparyval);
4341 else if (length--) {
4342 *MARK = tmparyval[length];
4345 while (length-- > 0)
4346 SvREFCNT_dec(tmparyval[length]);
4348 Safefree(tmparyval);
4351 *MARK = &PL_sv_undef;
4359 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4360 register AV *ary = (AV*)*++MARK;
4361 register SV *sv = &PL_sv_undef;
4364 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4365 *MARK-- = SvTIED_obj((SV*)ary, mg);
4369 call_method("PUSH",G_SCALAR|G_DISCARD);
4374 /* Why no pre-extend of ary here ? */
4375 for (++MARK; MARK <= SP; MARK++) {
4378 sv_setsv(sv, *MARK);
4383 PUSHi( AvFILL(ary) + 1 );
4391 SV *sv = av_pop(av);
4393 (void)sv_2mortal(sv);
4402 SV *sv = av_shift(av);
4407 (void)sv_2mortal(sv);
4414 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4415 register AV *ary = (AV*)*++MARK;
4420 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4421 *MARK-- = SvTIED_obj((SV*)ary, mg);
4425 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4430 av_unshift(ary, SP - MARK);
4432 sv = newSVsv(*++MARK);
4433 (void)av_store(ary, i++, sv);
4437 PUSHi( AvFILL(ary) + 1 );
4447 if (GIMME == G_ARRAY) {
4454 /* safe as long as stack cannot get extended in the above */
4459 register char *down;
4465 SvUTF8_off(TARG); /* decontaminate */
4467 do_join(TARG, &PL_sv_no, MARK, SP);
4469 sv_setsv(TARG, (SP > MARK)
4471 : (padoff_du = find_rundefsvoffset(),
4472 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4473 ? DEFSV : PAD_SVl(padoff_du)));
4474 up = SvPV_force(TARG, len);
4476 if (DO_UTF8(TARG)) { /* first reverse each character */
4477 U8* s = (U8*)SvPVX(TARG);
4478 U8* send = (U8*)(s + len);
4480 if (UTF8_IS_INVARIANT(*s)) {
4485 if (!utf8_to_uvchr(s, 0))
4489 down = (char*)(s - 1);
4490 /* reverse this character */
4494 *down-- = (char)tmp;
4500 down = SvPVX(TARG) + len - 1;
4504 *down-- = (char)tmp;
4506 (void)SvPOK_only_UTF8(TARG);
4518 register IV limit = POPi; /* note, negative is forever */
4521 register char *s = SvPV(sv, len);
4522 bool do_utf8 = DO_UTF8(sv);
4523 char *strend = s + len;
4525 register REGEXP *rx;
4529 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4530 I32 maxiters = slen + 10;
4533 I32 origlimit = limit;
4536 I32 gimme = GIMME_V;
4537 I32 oldsave = PL_savestack_ix;
4538 I32 make_mortal = 1;
4540 MAGIC *mg = (MAGIC *) NULL;
4543 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4548 DIE(aTHX_ "panic: pp_split");
4551 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4552 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4554 RX_MATCH_UTF8_set(rx, do_utf8);
4556 if (pm->op_pmreplroot) {
4558 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4560 ary = GvAVn((GV*)pm->op_pmreplroot);
4563 else if (gimme != G_ARRAY)
4564 ary = GvAVn(PL_defgv);
4567 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4573 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4575 XPUSHs(SvTIED_obj((SV*)ary, mg));
4581 for (i = AvFILLp(ary); i >= 0; i--)
4582 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4584 /* temporarily switch stacks */
4585 SAVESWITCHSTACK(PL_curstack, ary);
4589 base = SP - PL_stack_base;
4591 if (pm->op_pmflags & PMf_SKIPWHITE) {
4592 if (pm->op_pmflags & PMf_LOCALE) {
4593 while (isSPACE_LC(*s))
4601 if (pm->op_pmflags & PMf_MULTILINE) {
4606 limit = maxiters + 2;
4607 if (pm->op_pmflags & PMf_WHITE) {
4610 while (m < strend &&
4611 !((pm->op_pmflags & PMf_LOCALE)
4612 ? isSPACE_LC(*m) : isSPACE(*m)))
4617 dstr = newSVpvn(s, m-s);
4621 (void)SvUTF8_on(dstr);
4625 while (s < strend &&
4626 ((pm->op_pmflags & PMf_LOCALE)
4627 ? isSPACE_LC(*s) : isSPACE(*s)))
4631 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4634 for (m = s; m < strend && *m != '\n'; m++) ;
4638 dstr = newSVpvn(s, m-s);
4642 (void)SvUTF8_on(dstr);
4647 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4648 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4649 && (rx->reganch & ROPT_CHECK_ALL)
4650 && !(rx->reganch & ROPT_ANCH)) {
4651 int tail = (rx->reganch & RE_INTUIT_TAIL);
4652 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4655 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4657 char c = *SvPV(csv, n_a);
4660 for (m = s; m < strend && *m != c; m++) ;
4663 dstr = newSVpvn(s, m-s);
4667 (void)SvUTF8_on(dstr);
4669 /* The rx->minlen is in characters but we want to step
4670 * s ahead by bytes. */
4672 s = (char*)utf8_hop((U8*)m, len);
4674 s = m + len; /* Fake \n at the end */
4679 while (s < strend && --limit &&
4680 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4681 csv, multiline ? FBMrf_MULTILINE : 0)) )
4684 dstr = newSVpvn(s, m-s);
4688 (void)SvUTF8_on(dstr);
4690 /* The rx->minlen is in characters but we want to step
4691 * s ahead by bytes. */
4693 s = (char*)utf8_hop((U8*)m, len);
4695 s = m + len; /* Fake \n at the end */
4700 maxiters += slen * rx->nparens;
4701 while (s < strend && --limit)
4704 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4708 TAINT_IF(RX_MATCH_TAINTED(rx));
4709 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4714 strend = s + (strend - m);
4716 m = rx->startp[0] + orig;
4717 dstr = newSVpvn(s, m-s);
4721 (void)SvUTF8_on(dstr);
4724 for (i = 1; i <= (I32)rx->nparens; i++) {
4725 s = rx->startp[i] + orig;
4726 m = rx->endp[i] + orig;
4728 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4729 parens that didn't match -- they should be set to
4730 undef, not the empty string */
4731 if (m >= orig && s >= orig) {
4732 dstr = newSVpvn(s, m-s);
4735 dstr = &PL_sv_undef; /* undef, not "" */
4739 (void)SvUTF8_on(dstr);
4743 s = rx->endp[0] + orig;
4747 iters = (SP - PL_stack_base) - base;
4748 if (iters > maxiters)
4749 DIE(aTHX_ "Split loop");
4751 /* keep field after final delim? */
4752 if (s < strend || (iters && origlimit)) {
4753 STRLEN l = strend - s;
4754 dstr = newSVpvn(s, l);
4758 (void)SvUTF8_on(dstr);
4762 else if (!origlimit) {
4763 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4764 if (TOPs && !make_mortal)
4767 *SP-- = &PL_sv_undef;
4772 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4776 if (SvSMAGICAL(ary)) {
4781 if (gimme == G_ARRAY) {
4783 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4791 call_method("PUSH",G_SCALAR|G_DISCARD);
4794 if (gimme == G_ARRAY) {
4795 /* EXTEND should not be needed - we just popped them */
4797 for (i=0; i < iters; i++) {
4798 SV **svp = av_fetch(ary, i, FALSE);
4799 PUSHs((svp) ? *svp : &PL_sv_undef);
4806 if (gimme == G_ARRAY)
4821 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4822 || SvTYPE(retsv) == SVt_PVCV) {
4823 retsv = refto(retsv);
4831 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4836 * c-indentation-style: bsd
4838 * indent-tabs-mode: t
4841 * vim: shiftwidth=4: