3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
51 if (GIMME_V == G_SCALAR)
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
70 if (PL_op->op_flags & OPf_REF) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL((AV*)TARG) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV **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 const I32 maxarg = AvFILL((AV*)TARG) + 1;
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
112 if (PL_op->op_flags & OPf_REF)
115 if (GIMME == G_SCALAR)
116 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
120 if (gimme == G_ARRAY) {
123 else if (gimme == G_SCALAR) {
124 SV* 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) {
171 if (cUNOP->op_targ) {
173 SV *namesv = PAD_SV(cUNOP->op_targ);
174 const char *name = SvPV(namesv, len);
175 gv = (GV*)NEWSV(0,0);
176 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
179 const char *name = CopSTASHPV(PL_curcop);
182 if (SvTYPE(sv) < SVt_RV)
183 sv_upgrade(sv, SVt_RV);
184 if (SvPVX_const(sv)) {
189 SvRV_set(sv, (SV*)gv);
194 if (PL_op->op_flags & OPf_REF ||
195 PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_usym, "a symbol");
197 if (ckWARN(WARN_UNINITIALIZED))
201 if ((PL_op->op_flags & OPf_SPECIAL) &&
202 !(PL_op->op_flags & OPf_MOD))
204 SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
206 && (!is_gv_magical_sv(sv,0)
207 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
213 if (PL_op->op_private & HINT_STRICT_REFS)
214 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
215 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
219 if (PL_op->op_private & OPpLVAL_INTRO)
220 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
232 tryAMAGICunDEREF(to_sv);
235 switch (SvTYPE(sv)) {
239 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
252 if (PL_op->op_flags & OPf_REF ||
253 PL_op->op_private & HINT_STRICT_REFS)
254 DIE(aTHX_ PL_no_usym, "a SCALAR");
255 if (ckWARN(WARN_UNINITIALIZED))
259 if ((PL_op->op_flags & OPf_SPECIAL) &&
260 !(PL_op->op_flags & OPf_MOD))
262 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
264 && (!is_gv_magical_sv(sv, 0)
265 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
271 if (PL_op->op_private & HINT_STRICT_REFS)
272 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
273 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
278 if (PL_op->op_flags & OPf_MOD) {
279 if (PL_op->op_private & OPpLVAL_INTRO) {
280 if (cUNOP->op_first->op_type == OP_NULL)
281 sv = save_scalar((GV*)TOPs);
283 sv = save_scalar(gv);
285 Perl_croak(aTHX_ PL_no_localize_ref);
287 else if (PL_op->op_private & OPpDEREF)
288 vivify_ref(sv, PL_op->op_private & OPpDEREF);
298 SV *sv = AvARYLEN(av);
300 AvARYLEN(av) = sv = NEWSV(0,0);
301 sv_upgrade(sv, SVt_IV);
302 sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
310 dSP; dTARGET; dPOPss;
312 if (PL_op->op_flags & OPf_MOD || LVRET) {
313 if (SvTYPE(TARG) < SVt_PVLV) {
314 sv_upgrade(TARG, SVt_PVLV);
315 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
319 if (LvTARG(TARG) != sv) {
321 SvREFCNT_dec(LvTARG(TARG));
322 LvTARG(TARG) = SvREFCNT_inc(sv);
324 PUSHs(TARG); /* no SvSETMAGIC */
330 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
331 mg = mg_find(sv, PERL_MAGIC_regex_global);
332 if (mg && mg->mg_len >= 0) {
336 PUSHi(i + PL_curcop->cop_arybase);
350 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
351 /* (But not in defined().) */
352 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
355 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
356 if ((PL_op->op_private & OPpLVAL_INTRO)) {
357 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
360 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
364 cv = (CV*)&PL_sv_undef;
378 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
379 const char *s = SvPVX_const(TOPs);
380 if (strnEQ(s, "CORE::", 6)) {
381 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
382 if (code < 0) { /* Overridable. */
383 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
384 int i = 0, n = 0, seen_question = 0;
386 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
388 if (code == -KEY_chop || code == -KEY_chomp
389 || code == -KEY_exec || code == -KEY_system)
391 while (i < MAXO) { /* The slow way. */
392 if (strEQ(s + 6, PL_op_name[i])
393 || strEQ(s + 6, PL_op_desc[i]))
399 goto nonesuch; /* Should not happen... */
401 oa = PL_opargs[i] >> OASHIFT;
403 if (oa & OA_OPTIONAL && !seen_question) {
407 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
408 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
409 /* But globs are already references (kinda) */
410 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
414 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
418 ret = sv_2mortal(newSVpvn(str, n - 1));
420 else if (code) /* Non-Overridable */
422 else { /* None such */
424 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
428 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
430 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
439 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
441 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
457 if (GIMME != G_ARRAY) {
461 *MARK = &PL_sv_undef;
462 *MARK = refto(*MARK);
466 EXTEND_MORTAL(SP - MARK);
468 *MARK = refto(*MARK);
473 S_refto(pTHX_ SV *sv)
477 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
480 if (!(sv = LvTARG(sv)))
483 (void)SvREFCNT_inc(sv);
485 else if (SvTYPE(sv) == SVt_PVAV) {
486 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
489 (void)SvREFCNT_inc(sv);
491 else if (SvPADTMP(sv) && !IS_PADGV(sv))
495 (void)SvREFCNT_inc(sv);
498 sv_upgrade(rv, SVt_RV);
512 if (sv && SvGMAGICAL(sv))
515 if (!sv || !SvROK(sv))
519 pv = sv_reftype(sv,TRUE);
520 PUSHp(pv, strlen(pv));
530 stash = CopSTASH(PL_curcop);
536 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
537 Perl_croak(aTHX_ "Attempt to bless into a reference");
539 if (ckWARN(WARN_MISC) && len == 0)
540 Perl_warner(aTHX_ packWARN(WARN_MISC),
541 "Explicit blessing to '' (assuming package main)");
542 stash = gv_stashpvn(ptr, len, TRUE);
545 (void)sv_bless(TOPs, stash);
559 elem = SvPV(sv, n_a);
564 /* elem will always be NUL terminated. */
565 const char *elem2 = elem + 1;
568 if (strEQ(elem2, "RRAY"))
569 tmpRef = (SV*)GvAV(gv);
572 if (strEQ(elem2, "ODE"))
573 tmpRef = (SV*)GvCVu(gv);
576 if (strEQ(elem2, "ILEHANDLE")) {
577 /* finally deprecated in 5.8.0 */
578 deprecate("*glob{FILEHANDLE}");
579 tmpRef = (SV*)GvIOp(gv);
582 if (strEQ(elem2, "ORMAT"))
583 tmpRef = (SV*)GvFORM(gv);
586 if (strEQ(elem2, "LOB"))
590 if (strEQ(elem2, "ASH"))
591 tmpRef = (SV*)GvHV(gv);
594 if (*elem2 == 'O' && !elem[2])
595 tmpRef = (SV*)GvIOp(gv);
598 if (strEQ(elem2, "AME"))
599 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
602 if (strEQ(elem2, "ACKAGE")) {
603 const char *name = HvNAME_get(GvSTASH(gv));
604 sv = newSVpv(name ? name : "__ANON__", 0);
608 if (strEQ(elem2, "CALAR"))
623 /* Pattern matching */
628 register unsigned char *s;
631 register I32 *sfirst;
635 if (sv == PL_lastscream) {
641 SvSCREAM_off(PL_lastscream);
642 SvREFCNT_dec(PL_lastscream);
644 PL_lastscream = SvREFCNT_inc(sv);
647 s = (unsigned char*)(SvPV(sv, len));
651 if (pos > PL_maxscream) {
652 if (PL_maxscream < 0) {
653 PL_maxscream = pos + 80;
654 New(301, PL_screamfirst, 256, I32);
655 New(302, PL_screamnext, PL_maxscream, I32);
658 PL_maxscream = pos + pos / 4;
659 Renew(PL_screamnext, PL_maxscream, I32);
663 sfirst = PL_screamfirst;
664 snext = PL_screamnext;
666 if (!sfirst || !snext)
667 DIE(aTHX_ "do_study: out of memory");
669 for (ch = 256; ch; --ch)
676 snext[pos] = sfirst[ch] - pos;
683 /* piggyback on m//g magic */
684 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
693 if (PL_op->op_flags & OPf_STACKED)
695 else if (PL_op->op_private & OPpTARGET_MY)
701 TARG = sv_newmortal();
706 /* Lvalue operators. */
718 dSP; dMARK; dTARGET; dORIGMARK;
720 do_chop(TARG, *++MARK);
729 SETi(do_chomp(TOPs));
736 register I32 count = 0;
739 count += do_chomp(POPs);
750 if (!sv || !SvANY(sv))
752 switch (SvTYPE(sv)) {
754 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
755 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
759 if (HvARRAY(sv) || SvGMAGICAL(sv)
760 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
764 if (CvROOT(sv) || CvXSUB(sv))
781 if (!PL_op->op_private) {
790 SV_CHECK_THINKFIRST_COW_DROP(sv);
792 switch (SvTYPE(sv)) {
802 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
803 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
804 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
808 /* let user-undef'd sub keep its identity */
809 GV* gv = CvGV((CV*)sv);
816 SvSetMagicSV(sv, &PL_sv_undef);
820 Newz(602, gp, 1, GP);
821 GvGP(sv) = gp_ref(gp);
822 GvSV(sv) = NEWSV(72,0);
823 GvLINE(sv) = CopLINE(PL_curcop);
829 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
831 SvPV_set(sv, Nullch);
844 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
845 DIE(aTHX_ PL_no_modify);
846 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
847 && SvIVX(TOPs) != IV_MIN)
849 SvIV_set(TOPs, SvIVX(TOPs) - 1);
850 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
861 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
862 DIE(aTHX_ PL_no_modify);
863 sv_setsv(TARG, TOPs);
864 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
865 && SvIVX(TOPs) != IV_MAX)
867 SvIV_set(TOPs, SvIVX(TOPs) + 1);
868 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
873 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
883 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
884 DIE(aTHX_ PL_no_modify);
885 sv_setsv(TARG, TOPs);
886 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
887 && SvIVX(TOPs) != IV_MIN)
889 SvIV_set(TOPs, SvIVX(TOPs) - 1);
890 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
899 /* Ordinary operators. */
904 #ifdef PERL_PRESERVE_IVUV
907 tryAMAGICbin(pow,opASSIGN);
908 #ifdef PERL_PRESERVE_IVUV
909 /* For integer to integer power, we do the calculation by hand wherever
910 we're sure it is safe; otherwise we call pow() and try to convert to
911 integer afterwards. */
915 bool baseuok = SvUOK(TOPm1s);
919 baseuv = SvUVX(TOPm1s);
921 IV iv = SvIVX(TOPm1s);
924 baseuok = TRUE; /* effectively it's a UV now */
926 baseuv = -iv; /* abs, baseuok == false records sign */
940 goto float_it; /* Can't do negative powers this way. */
943 /* now we have integer ** positive integer. */
946 /* foo & (foo - 1) is zero only for a power of 2. */
947 if (!(baseuv & (baseuv - 1))) {
948 /* We are raising power-of-2 to a positive integer.
949 The logic here will work for any base (even non-integer
950 bases) but it can be less accurate than
951 pow (base,power) or exp (power * log (base)) when the
952 intermediate values start to spill out of the mantissa.
953 With powers of 2 we know this can't happen.
954 And powers of 2 are the favourite thing for perl
955 programmers to notice ** not doing what they mean. */
957 NV base = baseuok ? baseuv : -(NV)baseuv;
960 for (; power; base *= base, n++) {
961 /* Do I look like I trust gcc with long longs here?
963 UV bit = (UV)1 << (UV)n;
966 /* Only bother to clear the bit if it is set. */
968 /* Avoid squaring base again if we're done. */
969 if (power == 0) break;
977 register unsigned int highbit = 8 * sizeof(UV);
978 register unsigned int lowbit = 0;
979 register unsigned int diff;
980 bool odd_power = (bool)(power & 1);
981 while ((diff = (highbit - lowbit) >> 1)) {
982 if (baseuv & ~((1 << (lowbit + diff)) - 1))
987 /* we now have baseuv < 2 ** highbit */
988 if (power * highbit <= 8 * sizeof(UV)) {
989 /* result will definitely fit in UV, so use UV math
990 on same algorithm as above */
991 register UV result = 1;
992 register UV base = baseuv;
994 for (; power; base *= base, n++) {
995 register UV bit = (UV)1 << (UV)n;
999 if (power == 0) break;
1003 if (baseuok || !odd_power)
1004 /* answer is positive */
1006 else if (result <= (UV)IV_MAX)
1007 /* answer negative, fits in IV */
1008 SETi( -(IV)result );
1009 else if (result == (UV)IV_MIN)
1010 /* 2's complement assumption: special case IV_MIN */
1013 /* answer negative, doesn't fit */
1014 SETn( -(NV)result );
1025 SETn( Perl_pow( left, right) );
1026 #ifdef PERL_PRESERVE_IVUV
1036 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1037 #ifdef PERL_PRESERVE_IVUV
1040 /* Unless the left argument is integer in range we are going to have to
1041 use NV maths. Hence only attempt to coerce the right argument if
1042 we know the left is integer. */
1043 /* Left operand is defined, so is it IV? */
1044 SvIV_please(TOPm1s);
1045 if (SvIOK(TOPm1s)) {
1046 bool auvok = SvUOK(TOPm1s);
1047 bool buvok = SvUOK(TOPs);
1048 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1049 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1056 alow = SvUVX(TOPm1s);
1058 IV aiv = SvIVX(TOPm1s);
1061 auvok = TRUE; /* effectively it's a UV now */
1063 alow = -aiv; /* abs, auvok == false records sign */
1069 IV biv = SvIVX(TOPs);
1072 buvok = TRUE; /* effectively it's a UV now */
1074 blow = -biv; /* abs, buvok == false records sign */
1078 /* If this does sign extension on unsigned it's time for plan B */
1079 ahigh = alow >> (4 * sizeof (UV));
1081 bhigh = blow >> (4 * sizeof (UV));
1083 if (ahigh && bhigh) {
1084 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1085 which is overflow. Drop to NVs below. */
1086 } else if (!ahigh && !bhigh) {
1087 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1088 so the unsigned multiply cannot overflow. */
1089 UV product = alow * blow;
1090 if (auvok == buvok) {
1091 /* -ve * -ve or +ve * +ve gives a +ve result. */
1095 } else if (product <= (UV)IV_MIN) {
1096 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1097 /* -ve result, which could overflow an IV */
1099 SETi( -(IV)product );
1101 } /* else drop to NVs below. */
1103 /* One operand is large, 1 small */
1106 /* swap the operands */
1108 bhigh = blow; /* bhigh now the temp var for the swap */
1112 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1113 multiplies can't overflow. shift can, add can, -ve can. */
1114 product_middle = ahigh * blow;
1115 if (!(product_middle & topmask)) {
1116 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1118 product_middle <<= (4 * sizeof (UV));
1119 product_low = alow * blow;
1121 /* as for pp_add, UV + something mustn't get smaller.
1122 IIRC ANSI mandates this wrapping *behaviour* for
1123 unsigned whatever the actual representation*/
1124 product_low += product_middle;
1125 if (product_low >= product_middle) {
1126 /* didn't overflow */
1127 if (auvok == buvok) {
1128 /* -ve * -ve or +ve * +ve gives a +ve result. */
1130 SETu( product_low );
1132 } else if (product_low <= (UV)IV_MIN) {
1133 /* 2s complement assumption again */
1134 /* -ve result, which could overflow an IV */
1136 SETi( -(IV)product_low );
1138 } /* else drop to NVs below. */
1140 } /* product_middle too large */
1141 } /* ahigh && bhigh */
1142 } /* SvIOK(TOPm1s) */
1147 SETn( left * right );
1154 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1155 /* Only try to do UV divide first
1156 if ((SLOPPYDIVIDE is true) or
1157 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1159 The assumption is that it is better to use floating point divide
1160 whenever possible, only doing integer divide first if we can't be sure.
1161 If NV_PRESERVES_UV is true then we know at compile time that no UV
1162 can be too large to preserve, so don't need to compile the code to
1163 test the size of UVs. */
1166 # define PERL_TRY_UV_DIVIDE
1167 /* ensure that 20./5. == 4. */
1169 # ifdef PERL_PRESERVE_IVUV
1170 # ifndef NV_PRESERVES_UV
1171 # define PERL_TRY_UV_DIVIDE
1176 #ifdef PERL_TRY_UV_DIVIDE
1179 SvIV_please(TOPm1s);
1180 if (SvIOK(TOPm1s)) {
1181 bool left_non_neg = SvUOK(TOPm1s);
1182 bool right_non_neg = SvUOK(TOPs);
1186 if (right_non_neg) {
1187 right = SvUVX(TOPs);
1190 IV biv = SvIVX(TOPs);
1193 right_non_neg = TRUE; /* effectively it's a UV now */
1199 /* historically undef()/0 gives a "Use of uninitialized value"
1200 warning before dieing, hence this test goes here.
1201 If it were immediately before the second SvIV_please, then
1202 DIE() would be invoked before left was even inspected, so
1203 no inpsection would give no warning. */
1205 DIE(aTHX_ "Illegal division by zero");
1208 left = SvUVX(TOPm1s);
1211 IV aiv = SvIVX(TOPm1s);
1214 left_non_neg = TRUE; /* effectively it's a UV now */
1223 /* For sloppy divide we always attempt integer division. */
1225 /* Otherwise we only attempt it if either or both operands
1226 would not be preserved by an NV. If both fit in NVs
1227 we fall through to the NV divide code below. However,
1228 as left >= right to ensure integer result here, we know that
1229 we can skip the test on the right operand - right big
1230 enough not to be preserved can't get here unless left is
1233 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1236 /* Integer division can't overflow, but it can be imprecise. */
1237 UV result = left / right;
1238 if (result * right == left) {
1239 SP--; /* result is valid */
1240 if (left_non_neg == right_non_neg) {
1241 /* signs identical, result is positive. */
1245 /* 2s complement assumption */
1246 if (result <= (UV)IV_MIN)
1247 SETi( -(IV)result );
1249 /* It's exact but too negative for IV. */
1250 SETn( -(NV)result );
1253 } /* tried integer divide but it was not an integer result */
1254 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1255 } /* left wasn't SvIOK */
1256 } /* right wasn't SvIOK */
1257 #endif /* PERL_TRY_UV_DIVIDE */
1261 DIE(aTHX_ "Illegal division by zero");
1262 PUSHn( left / right );
1269 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1273 bool left_neg = FALSE;
1274 bool right_neg = FALSE;
1275 bool use_double = FALSE;
1276 bool dright_valid = FALSE;
1282 right_neg = !SvUOK(TOPs);
1284 right = SvUVX(POPs);
1286 IV biv = SvIVX(POPs);
1289 right_neg = FALSE; /* effectively it's a UV now */
1297 right_neg = dright < 0;
1300 if (dright < UV_MAX_P1) {
1301 right = U_V(dright);
1302 dright_valid = TRUE; /* In case we need to use double below. */
1308 /* At this point use_double is only true if right is out of range for
1309 a UV. In range NV has been rounded down to nearest UV and
1310 use_double false. */
1312 if (!use_double && SvIOK(TOPs)) {
1314 left_neg = !SvUOK(TOPs);
1318 IV aiv = SvIVX(POPs);
1321 left_neg = FALSE; /* effectively it's a UV now */
1330 left_neg = dleft < 0;
1334 /* This should be exactly the 5.6 behaviour - if left and right are
1335 both in range for UV then use U_V() rather than floor. */
1337 if (dleft < UV_MAX_P1) {
1338 /* right was in range, so is dleft, so use UVs not double.
1342 /* left is out of range for UV, right was in range, so promote
1343 right (back) to double. */
1345 /* The +0.5 is used in 5.6 even though it is not strictly
1346 consistent with the implicit +0 floor in the U_V()
1347 inside the #if 1. */
1348 dleft = Perl_floor(dleft + 0.5);
1351 dright = Perl_floor(dright + 0.5);
1361 DIE(aTHX_ "Illegal modulus zero");
1363 dans = Perl_fmod(dleft, dright);
1364 if ((left_neg != right_neg) && dans)
1365 dans = dright - dans;
1368 sv_setnv(TARG, dans);
1374 DIE(aTHX_ "Illegal modulus zero");
1377 if ((left_neg != right_neg) && ans)
1380 /* XXX may warn: unary minus operator applied to unsigned type */
1381 /* could change -foo to be (~foo)+1 instead */
1382 if (ans <= ~((UV)IV_MAX)+1)
1383 sv_setiv(TARG, ~ans+1);
1385 sv_setnv(TARG, -(NV)ans);
1388 sv_setuv(TARG, ans);
1397 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1407 count = IV_MAX; /* The best we can do? */
1418 else if (SvNOKp(sv)) {
1427 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1429 I32 items = SP - MARK;
1431 static const char oom_list_extend[] =
1432 "Out of memory during list extend";
1434 max = items * count;
1435 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1436 /* Did the max computation overflow? */
1437 if (items > 0 && max > 0 && (max < items || max < count))
1438 Perl_croak(aTHX_ oom_list_extend);
1443 /* This code was intended to fix 20010809.028:
1446 for (($x =~ /./g) x 2) {
1447 print chop; # "abcdabcd" expected as output.
1450 * but that change (#11635) broke this code:
1452 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1454 * I can't think of a better fix that doesn't introduce
1455 * an efficiency hit by copying the SVs. The stack isn't
1456 * refcounted, and mortalisation obviously doesn't
1457 * Do The Right Thing when the stack has more than
1458 * one pointer to the same mortal value.
1462 *SP = sv_2mortal(newSVsv(*SP));
1472 repeatcpy((char*)(MARK + items), (char*)MARK,
1473 items * sizeof(SV*), count - 1);
1476 else if (count <= 0)
1479 else { /* Note: mark already snarfed by pp_list */
1483 static const char oom_string_extend[] =
1484 "Out of memory during string extend";
1486 SvSetSV(TARG, tmpstr);
1487 SvPV_force(TARG, len);
1488 isutf = DO_UTF8(TARG);
1493 STRLEN max = (UV)count * len;
1494 if (len > ((MEM_SIZE)~0)/count)
1495 Perl_croak(aTHX_ oom_string_extend);
1496 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1497 SvGROW(TARG, max + 1);
1498 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1499 SvCUR_set(TARG, SvCUR(TARG) * count);
1501 *SvEND(TARG) = '\0';
1504 (void)SvPOK_only_UTF8(TARG);
1506 (void)SvPOK_only(TARG);
1508 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1509 /* The parser saw this as a list repeat, and there
1510 are probably several items on the stack. But we're
1511 in scalar context, and there's no pp_list to save us
1512 now. So drop the rest of the items -- robin@kitsite.com
1525 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1526 useleft = USE_LEFT(TOPm1s);
1527 #ifdef PERL_PRESERVE_IVUV
1528 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1529 "bad things" happen if you rely on signed integers wrapping. */
1532 /* Unless the left argument is integer in range we are going to have to
1533 use NV maths. Hence only attempt to coerce the right argument if
1534 we know the left is integer. */
1535 register UV auv = 0;
1541 a_valid = auvok = 1;
1542 /* left operand is undef, treat as zero. */
1544 /* Left operand is defined, so is it IV? */
1545 SvIV_please(TOPm1s);
1546 if (SvIOK(TOPm1s)) {
1547 if ((auvok = SvUOK(TOPm1s)))
1548 auv = SvUVX(TOPm1s);
1550 register IV aiv = SvIVX(TOPm1s);
1553 auvok = 1; /* Now acting as a sign flag. */
1554 } else { /* 2s complement assumption for IV_MIN */
1562 bool result_good = 0;
1565 bool buvok = SvUOK(TOPs);
1570 register IV biv = SvIVX(TOPs);
1577 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1578 else "IV" now, independent of how it came in.
1579 if a, b represents positive, A, B negative, a maps to -A etc
1584 all UV maths. negate result if A negative.
1585 subtract if signs same, add if signs differ. */
1587 if (auvok ^ buvok) {
1596 /* Must get smaller */
1601 if (result <= buv) {
1602 /* result really should be -(auv-buv). as its negation
1603 of true value, need to swap our result flag */
1615 if (result <= (UV)IV_MIN)
1616 SETi( -(IV)result );
1618 /* result valid, but out of range for IV. */
1619 SETn( -(NV)result );
1623 } /* Overflow, drop through to NVs. */
1627 useleft = USE_LEFT(TOPm1s);
1631 /* left operand is undef, treat as zero - value */
1635 SETn( TOPn - value );
1642 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1645 if (PL_op->op_private & HINT_INTEGER) {
1659 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1662 if (PL_op->op_private & HINT_INTEGER) {
1676 dSP; tryAMAGICbinSET(lt,0);
1677 #ifdef PERL_PRESERVE_IVUV
1680 SvIV_please(TOPm1s);
1681 if (SvIOK(TOPm1s)) {
1682 bool auvok = SvUOK(TOPm1s);
1683 bool buvok = SvUOK(TOPs);
1685 if (!auvok && !buvok) { /* ## IV < IV ## */
1686 IV aiv = SvIVX(TOPm1s);
1687 IV biv = SvIVX(TOPs);
1690 SETs(boolSV(aiv < biv));
1693 if (auvok && buvok) { /* ## UV < UV ## */
1694 UV auv = SvUVX(TOPm1s);
1695 UV buv = SvUVX(TOPs);
1698 SETs(boolSV(auv < buv));
1701 if (auvok) { /* ## UV < IV ## */
1708 /* As (a) is a UV, it's >=0, so it cannot be < */
1713 SETs(boolSV(auv < (UV)biv));
1716 { /* ## IV < UV ## */
1720 aiv = SvIVX(TOPm1s);
1722 /* As (b) is a UV, it's >=0, so it must be < */
1729 SETs(boolSV((UV)aiv < buv));
1735 #ifndef NV_PRESERVES_UV
1736 #ifdef PERL_PRESERVE_IVUV
1739 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1741 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1747 SETs(boolSV(TOPn < value));
1754 dSP; tryAMAGICbinSET(gt,0);
1755 #ifdef PERL_PRESERVE_IVUV
1758 SvIV_please(TOPm1s);
1759 if (SvIOK(TOPm1s)) {
1760 bool auvok = SvUOK(TOPm1s);
1761 bool buvok = SvUOK(TOPs);
1763 if (!auvok && !buvok) { /* ## IV > IV ## */
1764 IV aiv = SvIVX(TOPm1s);
1765 IV biv = SvIVX(TOPs);
1768 SETs(boolSV(aiv > biv));
1771 if (auvok && buvok) { /* ## UV > UV ## */
1772 UV auv = SvUVX(TOPm1s);
1773 UV buv = SvUVX(TOPs);
1776 SETs(boolSV(auv > buv));
1779 if (auvok) { /* ## UV > IV ## */
1786 /* As (a) is a UV, it's >=0, so it must be > */
1791 SETs(boolSV(auv > (UV)biv));
1794 { /* ## IV > UV ## */
1798 aiv = SvIVX(TOPm1s);
1800 /* As (b) is a UV, it's >=0, so it cannot be > */
1807 SETs(boolSV((UV)aiv > buv));
1813 #ifndef NV_PRESERVES_UV
1814 #ifdef PERL_PRESERVE_IVUV
1817 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1819 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1825 SETs(boolSV(TOPn > value));
1832 dSP; tryAMAGICbinSET(le,0);
1833 #ifdef PERL_PRESERVE_IVUV
1836 SvIV_please(TOPm1s);
1837 if (SvIOK(TOPm1s)) {
1838 bool auvok = SvUOK(TOPm1s);
1839 bool buvok = SvUOK(TOPs);
1841 if (!auvok && !buvok) { /* ## IV <= IV ## */
1842 IV aiv = SvIVX(TOPm1s);
1843 IV biv = SvIVX(TOPs);
1846 SETs(boolSV(aiv <= biv));
1849 if (auvok && buvok) { /* ## UV <= UV ## */
1850 UV auv = SvUVX(TOPm1s);
1851 UV buv = SvUVX(TOPs);
1854 SETs(boolSV(auv <= buv));
1857 if (auvok) { /* ## UV <= IV ## */
1864 /* As (a) is a UV, it's >=0, so a cannot be <= */
1869 SETs(boolSV(auv <= (UV)biv));
1872 { /* ## IV <= UV ## */
1876 aiv = SvIVX(TOPm1s);
1878 /* As (b) is a UV, it's >=0, so a must be <= */
1885 SETs(boolSV((UV)aiv <= buv));
1891 #ifndef NV_PRESERVES_UV
1892 #ifdef PERL_PRESERVE_IVUV
1895 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1897 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1903 SETs(boolSV(TOPn <= value));
1910 dSP; tryAMAGICbinSET(ge,0);
1911 #ifdef PERL_PRESERVE_IVUV
1914 SvIV_please(TOPm1s);
1915 if (SvIOK(TOPm1s)) {
1916 bool auvok = SvUOK(TOPm1s);
1917 bool buvok = SvUOK(TOPs);
1919 if (!auvok && !buvok) { /* ## IV >= IV ## */
1920 IV aiv = SvIVX(TOPm1s);
1921 IV biv = SvIVX(TOPs);
1924 SETs(boolSV(aiv >= biv));
1927 if (auvok && buvok) { /* ## UV >= UV ## */
1928 UV auv = SvUVX(TOPm1s);
1929 UV buv = SvUVX(TOPs);
1932 SETs(boolSV(auv >= buv));
1935 if (auvok) { /* ## UV >= IV ## */
1942 /* As (a) is a UV, it's >=0, so it must be >= */
1947 SETs(boolSV(auv >= (UV)biv));
1950 { /* ## IV >= UV ## */
1954 aiv = SvIVX(TOPm1s);
1956 /* As (b) is a UV, it's >=0, so a cannot be >= */
1963 SETs(boolSV((UV)aiv >= buv));
1969 #ifndef NV_PRESERVES_UV
1970 #ifdef PERL_PRESERVE_IVUV
1973 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1975 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1981 SETs(boolSV(TOPn >= value));
1988 dSP; tryAMAGICbinSET(ne,0);
1989 #ifndef NV_PRESERVES_UV
1990 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1992 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1996 #ifdef PERL_PRESERVE_IVUV
1999 SvIV_please(TOPm1s);
2000 if (SvIOK(TOPm1s)) {
2001 bool auvok = SvUOK(TOPm1s);
2002 bool buvok = SvUOK(TOPs);
2004 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2005 /* Casting IV to UV before comparison isn't going to matter
2006 on 2s complement. On 1s complement or sign&magnitude
2007 (if we have any of them) it could make negative zero
2008 differ from normal zero. As I understand it. (Need to
2009 check - is negative zero implementation defined behaviour
2011 UV buv = SvUVX(POPs);
2012 UV auv = SvUVX(TOPs);
2014 SETs(boolSV(auv != buv));
2017 { /* ## Mixed IV,UV ## */
2021 /* != is commutative so swap if needed (save code) */
2023 /* swap. top of stack (b) is the iv */
2027 /* As (a) is a UV, it's >0, so it cannot be == */
2036 /* As (b) is a UV, it's >0, so it cannot be == */
2040 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2042 SETs(boolSV((UV)iv != uv));
2050 SETs(boolSV(TOPn != value));
2057 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2058 #ifndef NV_PRESERVES_UV
2059 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2060 UV right = PTR2UV(SvRV(POPs));
2061 UV left = PTR2UV(SvRV(TOPs));
2062 SETi((left > right) - (left < right));
2066 #ifdef PERL_PRESERVE_IVUV
2067 /* Fortunately it seems NaN isn't IOK */
2070 SvIV_please(TOPm1s);
2071 if (SvIOK(TOPm1s)) {
2072 bool leftuvok = SvUOK(TOPm1s);
2073 bool rightuvok = SvUOK(TOPs);
2075 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2076 IV leftiv = SvIVX(TOPm1s);
2077 IV rightiv = SvIVX(TOPs);
2079 if (leftiv > rightiv)
2081 else if (leftiv < rightiv)
2085 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2086 UV leftuv = SvUVX(TOPm1s);
2087 UV rightuv = SvUVX(TOPs);
2089 if (leftuv > rightuv)
2091 else if (leftuv < rightuv)
2095 } else if (leftuvok) { /* ## UV <=> IV ## */
2099 rightiv = SvIVX(TOPs);
2101 /* As (a) is a UV, it's >=0, so it cannot be < */
2104 leftuv = SvUVX(TOPm1s);
2105 if (leftuv > (UV)rightiv) {
2107 } else if (leftuv < (UV)rightiv) {
2113 } else { /* ## IV <=> UV ## */
2117 leftiv = SvIVX(TOPm1s);
2119 /* As (b) is a UV, it's >=0, so it must be < */
2122 rightuv = SvUVX(TOPs);
2123 if ((UV)leftiv > rightuv) {
2125 } else if ((UV)leftiv < rightuv) {
2143 if (Perl_isnan(left) || Perl_isnan(right)) {
2147 value = (left > right) - (left < right);
2151 else if (left < right)
2153 else if (left > right)
2167 dSP; tryAMAGICbinSET(slt,0);
2170 int cmp = (IN_LOCALE_RUNTIME
2171 ? sv_cmp_locale(left, right)
2172 : sv_cmp(left, right));
2173 SETs(boolSV(cmp < 0));
2180 dSP; tryAMAGICbinSET(sgt,0);
2183 int cmp = (IN_LOCALE_RUNTIME
2184 ? sv_cmp_locale(left, right)
2185 : sv_cmp(left, right));
2186 SETs(boolSV(cmp > 0));
2193 dSP; tryAMAGICbinSET(sle,0);
2196 int cmp = (IN_LOCALE_RUNTIME
2197 ? sv_cmp_locale(left, right)
2198 : sv_cmp(left, right));
2199 SETs(boolSV(cmp <= 0));
2206 dSP; tryAMAGICbinSET(sge,0);
2209 int cmp = (IN_LOCALE_RUNTIME
2210 ? sv_cmp_locale(left, right)
2211 : sv_cmp(left, right));
2212 SETs(boolSV(cmp >= 0));
2219 dSP; tryAMAGICbinSET(seq,0);
2222 SETs(boolSV(sv_eq(left, right)));
2229 dSP; tryAMAGICbinSET(sne,0);
2232 SETs(boolSV(!sv_eq(left, right)));
2239 dSP; dTARGET; tryAMAGICbin(scmp,0);
2242 int cmp = (IN_LOCALE_RUNTIME
2243 ? sv_cmp_locale(left, right)
2244 : sv_cmp(left, right));
2252 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2255 if (SvGMAGICAL(left)) mg_get(left);
2256 if (SvGMAGICAL(right)) mg_get(right);
2257 if (SvNIOKp(left) || SvNIOKp(right)) {
2258 if (PL_op->op_private & HINT_INTEGER) {
2259 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2263 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2268 do_vop(PL_op->op_type, TARG, left, right);
2277 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2280 if (SvGMAGICAL(left)) mg_get(left);
2281 if (SvGMAGICAL(right)) mg_get(right);
2282 if (SvNIOKp(left) || SvNIOKp(right)) {
2283 if (PL_op->op_private & HINT_INTEGER) {
2284 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2288 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2293 do_vop(PL_op->op_type, TARG, left, right);
2302 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2305 if (SvGMAGICAL(left)) mg_get(left);
2306 if (SvGMAGICAL(right)) mg_get(right);
2307 if (SvNIOKp(left) || SvNIOKp(right)) {
2308 if (PL_op->op_private & HINT_INTEGER) {
2309 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2313 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2318 do_vop(PL_op->op_type, TARG, left, right);
2327 dSP; dTARGET; tryAMAGICun(neg);
2330 int flags = SvFLAGS(sv);
2333 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2334 /* It's publicly an integer, or privately an integer-not-float */
2337 if (SvIVX(sv) == IV_MIN) {
2338 /* 2s complement assumption. */
2339 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2342 else if (SvUVX(sv) <= IV_MAX) {
2347 else if (SvIVX(sv) != IV_MIN) {
2351 #ifdef PERL_PRESERVE_IVUV
2360 else if (SvPOKp(sv)) {
2362 char *s = SvPV(sv, len);
2363 if (isIDFIRST(*s)) {
2364 sv_setpvn(TARG, "-", 1);
2367 else if (*s == '+' || *s == '-') {
2369 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2371 else if (DO_UTF8(sv)) {
2374 goto oops_its_an_int;
2376 sv_setnv(TARG, -SvNV(sv));
2378 sv_setpvn(TARG, "-", 1);
2385 goto oops_its_an_int;
2386 sv_setnv(TARG, -SvNV(sv));
2398 dSP; tryAMAGICunSET(not);
2399 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2405 dSP; dTARGET; tryAMAGICun(compl);
2411 if (PL_op->op_private & HINT_INTEGER) {
2412 IV i = ~SvIV_nomg(sv);
2416 UV u = ~SvUV_nomg(sv);
2425 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2426 sv_setsv_nomg(TARG, sv);
2427 tmps = (U8*)SvPV_force(TARG, len);
2430 /* Calculate exact length, let's not estimate. */
2439 while (tmps < send) {
2440 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2441 tmps += UTF8SKIP(tmps);
2442 targlen += UNISKIP(~c);
2448 /* Now rewind strings and write them. */
2452 Newz(0, result, targlen + 1, U8);
2453 while (tmps < send) {
2454 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2455 tmps += UTF8SKIP(tmps);
2456 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2460 sv_setpvn(TARG, (char*)result, targlen);
2464 Newz(0, result, nchar + 1, U8);
2465 while (tmps < send) {
2466 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2467 tmps += UTF8SKIP(tmps);
2472 sv_setpvn(TARG, (char*)result, nchar);
2481 register long *tmpl;
2482 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2485 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2490 for ( ; anum > 0; anum--, tmps++)
2499 /* integer versions of some of the above */
2503 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2506 SETi( left * right );
2513 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2517 DIE(aTHX_ "Illegal division by zero");
2518 value = POPi / value;
2527 /* This is the vanilla old i_modulo. */
2528 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2532 DIE(aTHX_ "Illegal modulus zero");
2533 SETi( left % right );
2538 #if defined(__GLIBC__) && IVSIZE == 8
2542 /* This is the i_modulo with the workaround for the _moddi3 bug
2543 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2544 * See below for pp_i_modulo. */
2545 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2549 DIE(aTHX_ "Illegal modulus zero");
2550 SETi( left % PERL_ABS(right) );
2558 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2562 DIE(aTHX_ "Illegal modulus zero");
2563 /* The assumption is to use hereafter the old vanilla version... */
2565 PL_ppaddr[OP_I_MODULO] =
2566 &Perl_pp_i_modulo_0;
2567 /* .. but if we have glibc, we might have a buggy _moddi3
2568 * (at least glicb 2.2.5 is known to have this bug), in other
2569 * words our integer modulus with negative quad as the second
2570 * argument might be broken. Test for this and re-patch the
2571 * opcode dispatch table if that is the case, remembering to
2572 * also apply the workaround so that this first round works
2573 * right, too. See [perl #9402] for more information. */
2574 #if defined(__GLIBC__) && IVSIZE == 8
2578 /* Cannot do this check with inlined IV constants since
2579 * that seems to work correctly even with the buggy glibc. */
2581 /* Yikes, we have the bug.
2582 * Patch in the workaround version. */
2584 PL_ppaddr[OP_I_MODULO] =
2585 &Perl_pp_i_modulo_1;
2586 /* Make certain we work right this time, too. */
2587 right = PERL_ABS(right);
2591 SETi( left % right );
2598 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2601 SETi( left + right );
2608 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2611 SETi( left - right );
2618 dSP; tryAMAGICbinSET(lt,0);
2621 SETs(boolSV(left < right));
2628 dSP; tryAMAGICbinSET(gt,0);
2631 SETs(boolSV(left > right));
2638 dSP; tryAMAGICbinSET(le,0);
2641 SETs(boolSV(left <= right));
2648 dSP; tryAMAGICbinSET(ge,0);
2651 SETs(boolSV(left >= right));
2658 dSP; tryAMAGICbinSET(eq,0);
2661 SETs(boolSV(left == right));
2668 dSP; tryAMAGICbinSET(ne,0);
2671 SETs(boolSV(left != right));
2678 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2685 else if (left < right)
2696 dSP; dTARGET; tryAMAGICun(neg);
2701 /* High falutin' math. */
2705 dSP; dTARGET; tryAMAGICbin(atan2,0);
2708 SETn(Perl_atan2(left, right));
2715 dSP; dTARGET; tryAMAGICun(sin);
2719 value = Perl_sin(value);
2727 dSP; dTARGET; tryAMAGICun(cos);
2731 value = Perl_cos(value);
2737 /* Support Configure command-line overrides for rand() functions.
2738 After 5.005, perhaps we should replace this by Configure support
2739 for drand48(), random(), or rand(). For 5.005, though, maintain
2740 compatibility by calling rand() but allow the user to override it.
2741 See INSTALL for details. --Andy Dougherty 15 July 1998
2743 /* Now it's after 5.005, and Configure supports drand48() and random(),
2744 in addition to rand(). So the overrides should not be needed any more.
2745 --Jarkko Hietaniemi 27 September 1998
2748 #ifndef HAS_DRAND48_PROTO
2749 extern double drand48 (void);
2762 if (!PL_srand_called) {
2763 (void)seedDrand01((Rand_seed_t)seed());
2764 PL_srand_called = TRUE;
2779 (void)seedDrand01((Rand_seed_t)anum);
2780 PL_srand_called = TRUE;
2787 dSP; dTARGET; tryAMAGICun(exp);
2791 value = Perl_exp(value);
2799 dSP; dTARGET; tryAMAGICun(log);
2804 SET_NUMERIC_STANDARD();
2805 DIE(aTHX_ "Can't take log of %"NVgf, value);
2807 value = Perl_log(value);
2815 dSP; dTARGET; tryAMAGICun(sqrt);
2820 SET_NUMERIC_STANDARD();
2821 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2823 value = Perl_sqrt(value);
2831 dSP; dTARGET; tryAMAGICun(int);
2834 IV iv = TOPi; /* attempt to convert to IV if possible. */
2835 /* XXX it's arguable that compiler casting to IV might be subtly
2836 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2837 else preferring IV has introduced a subtle behaviour change bug. OTOH
2838 relying on floating point to be accurate is a bug. */
2842 else if (SvIOK(TOPs)) {
2851 if (value < (NV)UV_MAX + 0.5) {
2854 SETn(Perl_floor(value));
2858 if (value > (NV)IV_MIN - 0.5) {
2861 SETn(Perl_ceil(value));
2871 dSP; dTARGET; tryAMAGICun(abs);
2873 /* This will cache the NV value if string isn't actually integer */
2878 else if (SvIOK(TOPs)) {
2879 /* IVX is precise */
2881 SETu(TOPu); /* force it to be numeric only */
2889 /* 2s complement assumption. Also, not really needed as
2890 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2910 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2916 tmps = (SvPVx(sv, len));
2918 /* If Unicode, try to downgrade
2919 * If not possible, croak. */
2920 SV* tsv = sv_2mortal(newSVsv(sv));
2923 sv_utf8_downgrade(tsv, FALSE);
2926 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2927 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2940 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2946 tmps = (SvPVx(sv, len));
2948 /* If Unicode, try to downgrade
2949 * If not possible, croak. */
2950 SV* tsv = sv_2mortal(newSVsv(sv));
2953 sv_utf8_downgrade(tsv, FALSE);
2956 while (*tmps && len && isSPACE(*tmps))
2961 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2962 else if (*tmps == 'b')
2963 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2965 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2967 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2984 SETi(sv_len_utf8(sv));
3000 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3002 const I32 arybase = PL_curcop->cop_arybase;
3004 const char *repl = 0;
3006 int num_args = PL_op->op_private & 7;
3007 bool repl_need_utf8_upgrade = FALSE;
3008 bool repl_is_utf8 = FALSE;
3010 SvTAINTED_off(TARG); /* decontaminate */
3011 SvUTF8_off(TARG); /* decontaminate */
3015 repl = SvPV(repl_sv, repl_len);
3016 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3026 sv_utf8_upgrade(sv);
3028 else if (DO_UTF8(sv))
3029 repl_need_utf8_upgrade = TRUE;
3031 tmps = SvPV(sv, curlen);
3033 utf8_curlen = sv_len_utf8(sv);
3034 if (utf8_curlen == curlen)
3037 curlen = utf8_curlen;
3042 if (pos >= arybase) {
3060 else if (len >= 0) {
3062 if (rem > (I32)curlen)
3077 Perl_croak(aTHX_ "substr outside of string");
3078 if (ckWARN(WARN_SUBSTR))
3079 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3086 sv_pos_u2b(sv, &pos, &rem);
3088 /* we either return a PV or an LV. If the TARG hasn't been used
3089 * before, or is of that type, reuse it; otherwise use a mortal
3090 * instead. Note that LVs can have an extended lifetime, so also
3091 * dont reuse if refcount > 1 (bug #20933) */
3092 if (SvTYPE(TARG) > SVt_NULL) {
3093 if ( (SvTYPE(TARG) == SVt_PVLV)
3094 ? (!lvalue || SvREFCNT(TARG) > 1)
3097 TARG = sv_newmortal();
3101 sv_setpvn(TARG, tmps, rem);
3102 #ifdef USE_LOCALE_COLLATE
3103 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3108 SV* repl_sv_copy = NULL;
3110 if (repl_need_utf8_upgrade) {
3111 repl_sv_copy = newSVsv(repl_sv);
3112 sv_utf8_upgrade(repl_sv_copy);
3113 repl = SvPV(repl_sv_copy, repl_len);
3114 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3116 sv_insert(sv, pos, rem, repl, repl_len);
3120 SvREFCNT_dec(repl_sv_copy);
3122 else if (lvalue) { /* it's an lvalue! */
3123 if (!SvGMAGICAL(sv)) {
3127 if (ckWARN(WARN_SUBSTR))
3128 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3129 "Attempt to use reference as lvalue in substr");
3131 if (SvOK(sv)) /* is it defined ? */
3132 (void)SvPOK_only_UTF8(sv);
3134 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3137 if (SvTYPE(TARG) < SVt_PVLV) {
3138 sv_upgrade(TARG, SVt_PVLV);
3139 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3145 if (LvTARG(TARG) != sv) {
3147 SvREFCNT_dec(LvTARG(TARG));
3148 LvTARG(TARG) = SvREFCNT_inc(sv);
3150 LvTARGOFF(TARG) = upos;
3151 LvTARGLEN(TARG) = urem;
3155 PUSHs(TARG); /* avoid SvSETMAGIC here */
3162 register IV size = POPi;
3163 register IV offset = POPi;
3164 register SV *src = POPs;
3165 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3167 SvTAINTED_off(TARG); /* decontaminate */
3168 if (lvalue) { /* it's an lvalue! */
3169 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3170 TARG = sv_newmortal();
3171 if (SvTYPE(TARG) < SVt_PVLV) {
3172 sv_upgrade(TARG, SVt_PVLV);
3173 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3176 if (LvTARG(TARG) != src) {
3178 SvREFCNT_dec(LvTARG(TARG));
3179 LvTARG(TARG) = SvREFCNT_inc(src);
3181 LvTARGOFF(TARG) = offset;
3182 LvTARGLEN(TARG) = size;
3185 sv_setuv(TARG, do_vecget(src, offset, size));
3201 I32 arybase = PL_curcop->cop_arybase;
3208 offset = POPi - arybase;
3211 big_utf8 = DO_UTF8(big);
3212 little_utf8 = DO_UTF8(little);
3213 if (big_utf8 ^ little_utf8) {
3214 /* One needs to be upgraded. */
3215 SV *bytes = little_utf8 ? big : little;
3217 char *p = SvPV(bytes, len);
3219 temp = newSVpvn(p, len);
3222 sv_recode_to_utf8(temp, PL_encoding);
3224 sv_utf8_upgrade(temp);
3233 if (big_utf8 && offset > 0)
3234 sv_pos_u2b(big, &offset, 0);
3235 tmps = SvPV(big, biglen);
3238 else if (offset > (I32)biglen)
3240 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3241 (unsigned char*)tmps + biglen, little, 0)))
3244 retval = tmps2 - tmps;
3245 if (retval > 0 && big_utf8)
3246 sv_pos_b2u(big, &retval);
3249 PUSHi(retval + arybase);
3265 I32 arybase = PL_curcop->cop_arybase;
3273 big_utf8 = DO_UTF8(big);
3274 little_utf8 = DO_UTF8(little);
3275 if (big_utf8 ^ little_utf8) {
3276 /* One needs to be upgraded. */
3277 SV *bytes = little_utf8 ? big : little;
3279 char *p = SvPV(bytes, len);
3281 temp = newSVpvn(p, len);
3284 sv_recode_to_utf8(temp, PL_encoding);
3286 sv_utf8_upgrade(temp);
3295 tmps2 = SvPV(little, llen);
3296 tmps = SvPV(big, blen);
3301 if (offset > 0 && big_utf8)
3302 sv_pos_u2b(big, &offset, 0);
3303 offset = offset - arybase + llen;
3307 else if (offset > (I32)blen)
3309 if (!(tmps2 = rninstr(tmps, tmps + offset,
3310 tmps2, tmps2 + llen)))
3313 retval = tmps2 - tmps;
3314 if (retval > 0 && big_utf8)
3315 sv_pos_b2u(big, &retval);
3318 PUSHi(retval + arybase);
3324 dSP; dMARK; dORIGMARK; dTARGET;
3325 do_sprintf(TARG, SP-MARK, MARK+1);
3326 TAINT_IF(SvTAINTED(TARG));
3327 if (DO_UTF8(*(MARK+1)))
3339 U8 *s = (U8*)SvPVx(argsv, len);
3342 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3343 tmpsv = sv_2mortal(newSVsv(argsv));
3344 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3348 XPUSHu(DO_UTF8(argsv) ?
3349 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3361 (void)SvUPGRADE(TARG,SVt_PV);
3363 if (value > 255 && !IN_BYTES) {
3364 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3365 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3366 SvCUR_set(TARG, tmps - SvPVX(TARG));
3368 (void)SvPOK_only(TARG);
3377 *tmps++ = (char)value;
3379 (void)SvPOK_only(TARG);
3380 if (PL_encoding && !IN_BYTES) {
3381 sv_recode_to_utf8(TARG, PL_encoding);
3383 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3384 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3388 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3389 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3405 char *tmps = SvPV(left, len);
3407 if (DO_UTF8(left)) {
3408 /* If Unicode, try to downgrade.
3409 * If not possible, croak.
3410 * Yes, we made this up. */
3411 SV* tsv = sv_2mortal(newSVsv(left));
3414 sv_utf8_downgrade(tsv, FALSE);
3417 # ifdef USE_ITHREADS
3419 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3420 /* This should be threadsafe because in ithreads there is only
3421 * one thread per interpreter. If this would not be true,
3422 * we would need a mutex to protect this malloc. */
3423 PL_reentrant_buffer->_crypt_struct_buffer =
3424 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3425 #if defined(__GLIBC__) || defined(__EMX__)
3426 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3427 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3428 /* work around glibc-2.2.5 bug */
3429 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3433 # endif /* HAS_CRYPT_R */
3434 # endif /* USE_ITHREADS */
3436 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3438 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3444 "The crypt() function is unimplemented due to excessive paranoia.");
3457 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3458 UTF8_IS_START(*s)) {
3459 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3463 utf8_to_uvchr(s, &ulen);
3464 toTITLE_utf8(s, tmpbuf, &tculen);
3465 utf8_to_uvchr(tmpbuf, 0);
3467 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3469 /* slen is the byte length of the whole SV.
3470 * ulen is the byte length of the original Unicode character
3471 * stored as UTF-8 at s.
3472 * tculen is the byte length of the freshly titlecased
3473 * Unicode character stored as UTF-8 at tmpbuf.
3474 * We first set the result to be the titlecased character,
3475 * and then append the rest of the SV data. */
3476 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3478 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3483 s = (U8*)SvPV_force_nomg(sv, slen);
3484 Copy(tmpbuf, s, tculen, U8);
3488 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3490 SvUTF8_off(TARG); /* decontaminate */
3491 sv_setsv_nomg(TARG, sv);
3495 s = (U8*)SvPV_force_nomg(sv, slen);
3497 if (IN_LOCALE_RUNTIME) {
3500 *s = toUPPER_LC(*s);
3519 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3520 UTF8_IS_START(*s)) {
3522 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3526 toLOWER_utf8(s, tmpbuf, &ulen);
3527 uv = utf8_to_uvchr(tmpbuf, 0);
3528 tend = uvchr_to_utf8(tmpbuf, uv);
3530 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3532 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3534 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3539 s = (U8*)SvPV_force_nomg(sv, slen);
3540 Copy(tmpbuf, s, ulen, U8);
3544 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3546 SvUTF8_off(TARG); /* decontaminate */
3547 sv_setsv_nomg(TARG, sv);
3551 s = (U8*)SvPV_force_nomg(sv, slen);
3553 if (IN_LOCALE_RUNTIME) {
3556 *s = toLOWER_LC(*s);
3579 U8 tmpbuf[UTF8_MAXBYTES+1];
3581 s = (U8*)SvPV_nomg(sv,len);
3583 SvUTF8_off(TARG); /* decontaminate */
3584 sv_setpvn(TARG, "", 0);
3588 STRLEN min = len + 1;
3590 (void)SvUPGRADE(TARG, SVt_PV);
3592 (void)SvPOK_only(TARG);
3593 d = (U8*)SvPVX(TARG);
3596 STRLEN u = UTF8SKIP(s);
3598 toUPPER_utf8(s, tmpbuf, &ulen);
3599 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3600 /* If the eventually required minimum size outgrows
3601 * the available space, we need to grow. */
3602 UV o = d - (U8*)SvPVX(TARG);
3604 /* If someone uppercases one million U+03B0s we
3605 * SvGROW() one million times. Or we could try
3606 * guessing how much to allocate without allocating
3607 * too much. Such is life. */
3609 d = (U8*)SvPVX(TARG) + o;
3611 Copy(tmpbuf, d, ulen, U8);
3617 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3622 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3624 SvUTF8_off(TARG); /* decontaminate */
3625 sv_setsv_nomg(TARG, sv);
3629 s = (U8*)SvPV_force_nomg(sv, len);
3631 register U8 *send = s + len;
3633 if (IN_LOCALE_RUNTIME) {
3636 for (; s < send; s++)
3637 *s = toUPPER_LC(*s);
3640 for (; s < send; s++)
3662 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3664 s = (U8*)SvPV_nomg(sv,len);
3666 SvUTF8_off(TARG); /* decontaminate */
3667 sv_setpvn(TARG, "", 0);
3671 STRLEN min = len + 1;
3673 (void)SvUPGRADE(TARG, SVt_PV);
3675 (void)SvPOK_only(TARG);
3676 d = (U8*)SvPVX(TARG);
3679 STRLEN u = UTF8SKIP(s);
3680 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3682 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3683 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3685 * Now if the sigma is NOT followed by
3686 * /$ignorable_sequence$cased_letter/;
3687 * and it IS preceded by
3688 * /$cased_letter$ignorable_sequence/;
3689 * where $ignorable_sequence is
3690 * [\x{2010}\x{AD}\p{Mn}]*
3691 * and $cased_letter is
3692 * [\p{Ll}\p{Lo}\p{Lt}]
3693 * then it should be mapped to 0x03C2,
3694 * (GREEK SMALL LETTER FINAL SIGMA),
3695 * instead of staying 0x03A3.
3696 * "should be": in other words,
3697 * this is not implemented yet.
3698 * See lib/unicore/SpecialCasing.txt.
3701 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3702 /* If the eventually required minimum size outgrows
3703 * the available space, we need to grow. */
3704 UV o = d - (U8*)SvPVX(TARG);
3706 /* If someone lowercases one million U+0130s we
3707 * SvGROW() one million times. Or we could try
3708 * guessing how much to allocate without allocating.
3709 * too much. Such is life. */
3711 d = (U8*)SvPVX(TARG) + o;
3713 Copy(tmpbuf, d, ulen, U8);
3719 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3724 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3726 SvUTF8_off(TARG); /* decontaminate */
3727 sv_setsv_nomg(TARG, sv);
3732 s = (U8*)SvPV_force_nomg(sv, len);
3734 register U8 *send = s + len;
3736 if (IN_LOCALE_RUNTIME) {
3739 for (; s < send; s++)
3740 *s = toLOWER_LC(*s);
3743 for (; s < send; s++)
3757 register char *s = SvPV(sv,len);
3760 SvUTF8_off(TARG); /* decontaminate */
3762 (void)SvUPGRADE(TARG, SVt_PV);
3763 SvGROW(TARG, (len * 2) + 1);
3767 if (UTF8_IS_CONTINUED(*s)) {
3768 STRLEN ulen = UTF8SKIP(s);
3792 SvCUR_set(TARG, d - SvPVX(TARG));
3793 (void)SvPOK_only_UTF8(TARG);
3796 sv_setpvn(TARG, s, len);
3798 if (SvSMAGICAL(TARG))
3807 dSP; dMARK; dORIGMARK;
3809 register AV* av = (AV*)POPs;
3810 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3811 I32 arybase = PL_curcop->cop_arybase;
3814 if (SvTYPE(av) == SVt_PVAV) {
3815 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3817 for (svp = MARK + 1; svp <= SP; svp++) {
3822 if (max > AvMAX(av))
3825 while (++MARK <= SP) {
3826 elem = SvIVx(*MARK);
3830 svp = av_fetch(av, elem, lval);
3832 if (!svp || *svp == &PL_sv_undef)
3833 DIE(aTHX_ PL_no_aelem, elem);
3834 if (PL_op->op_private & OPpLVAL_INTRO)
3835 save_aelem(av, elem, svp);
3837 *MARK = svp ? *svp : &PL_sv_undef;
3840 if (GIMME != G_ARRAY) {
3842 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3848 /* Associative arrays. */
3853 HV *hash = (HV*)POPs;
3855 const I32 gimme = GIMME_V;
3858 /* might clobber stack_sp */
3859 entry = hv_iternext(hash);
3864 SV* sv = hv_iterkeysv(entry);
3865 PUSHs(sv); /* won't clobber stack_sp */
3866 if (gimme == G_ARRAY) {
3869 /* might clobber stack_sp */
3870 val = hv_iterval(hash, entry);
3875 else if (gimme == G_SCALAR)
3894 const I32 gimme = GIMME_V;
3895 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3899 if (PL_op->op_private & OPpSLICE) {
3903 hvtype = SvTYPE(hv);
3904 if (hvtype == SVt_PVHV) { /* hash element */
3905 while (++MARK <= SP) {
3906 sv = hv_delete_ent(hv, *MARK, discard, 0);
3907 *MARK = sv ? sv : &PL_sv_undef;
3910 else if (hvtype == SVt_PVAV) { /* array element */
3911 if (PL_op->op_flags & OPf_SPECIAL) {
3912 while (++MARK <= SP) {
3913 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3914 *MARK = sv ? sv : &PL_sv_undef;
3919 DIE(aTHX_ "Not a HASH reference");
3922 else if (gimme == G_SCALAR) {
3927 *++MARK = &PL_sv_undef;
3934 if (SvTYPE(hv) == SVt_PVHV)
3935 sv = hv_delete_ent(hv, keysv, discard, 0);
3936 else if (SvTYPE(hv) == SVt_PVAV) {
3937 if (PL_op->op_flags & OPf_SPECIAL)
3938 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3940 DIE(aTHX_ "panic: avhv_delete no longer supported");
3943 DIE(aTHX_ "Not a HASH reference");
3958 if (PL_op->op_private & OPpEXISTS_SUB) {
3962 cv = sv_2cv(sv, &hv, &gv, FALSE);
3965 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3971 if (SvTYPE(hv) == SVt_PVHV) {
3972 if (hv_exists_ent(hv, tmpsv, 0))
3975 else if (SvTYPE(hv) == SVt_PVAV) {
3976 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3977 if (av_exists((AV*)hv, SvIV(tmpsv)))
3982 DIE(aTHX_ "Not a HASH reference");
3989 dSP; dMARK; dORIGMARK;
3990 register HV *hv = (HV*)POPs;
3991 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3992 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3993 bool other_magic = FALSE;
3999 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4000 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4001 /* Try to preserve the existenceness of a tied hash
4002 * element by using EXISTS and DELETE if possible.
4003 * Fallback to FETCH and STORE otherwise */
4004 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4005 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4006 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4009 while (++MARK <= SP) {
4013 bool preeminent = FALSE;
4016 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4017 hv_exists_ent(hv, keysv, 0);
4020 he = hv_fetch_ent(hv, keysv, lval, 0);
4021 svp = he ? &HeVAL(he) : 0;
4024 if (!svp || *svp == &PL_sv_undef) {
4025 DIE(aTHX_ PL_no_helem_sv, keysv);
4029 save_helem(hv, keysv, svp);
4032 char *key = SvPV(keysv, keylen);
4033 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4037 *MARK = svp ? *svp : &PL_sv_undef;
4039 if (GIMME != G_ARRAY) {
4041 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4047 /* List operators. */
4052 if (GIMME != G_ARRAY) {
4054 *MARK = *SP; /* unwanted list, return last item */
4056 *MARK = &PL_sv_undef;
4065 SV **lastrelem = PL_stack_sp;
4066 SV **lastlelem = PL_stack_base + POPMARK;
4067 SV **firstlelem = PL_stack_base + POPMARK + 1;
4068 register SV **firstrelem = lastlelem + 1;
4069 I32 arybase = PL_curcop->cop_arybase;
4070 I32 lval = PL_op->op_flags & OPf_MOD;
4071 I32 is_something_there = lval;
4073 register I32 max = lastrelem - lastlelem;
4074 register SV **lelem;
4077 if (GIMME != G_ARRAY) {
4078 ix = SvIVx(*lastlelem);
4083 if (ix < 0 || ix >= max)
4084 *firstlelem = &PL_sv_undef;
4086 *firstlelem = firstrelem[ix];
4092 SP = firstlelem - 1;
4096 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4102 if (ix < 0 || ix >= max)
4103 *lelem = &PL_sv_undef;
4105 is_something_there = TRUE;
4106 if (!(*lelem = firstrelem[ix]))
4107 *lelem = &PL_sv_undef;
4110 if (is_something_there)
4113 SP = firstlelem - 1;
4119 dSP; dMARK; dORIGMARK;
4120 I32 items = SP - MARK;
4121 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4122 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4129 dSP; dMARK; dORIGMARK;
4130 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4134 SV *val = NEWSV(46, 0);
4136 sv_setsv(val, *++MARK);
4137 else if (ckWARN(WARN_MISC))
4138 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4139 (void)hv_store_ent(hv,key,val,0);
4148 dVAR; dSP; dMARK; dORIGMARK;
4149 register AV *ary = (AV*)*++MARK;
4153 register I32 offset;
4154 register I32 length;
4161 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4162 *MARK-- = SvTIED_obj((SV*)ary, mg);
4166 call_method("SPLICE",GIMME_V);
4175 offset = i = SvIVx(*MARK);
4177 offset += AvFILLp(ary) + 1;
4179 offset -= PL_curcop->cop_arybase;
4181 DIE(aTHX_ PL_no_aelem, i);
4183 length = SvIVx(*MARK++);
4185 length += AvFILLp(ary) - offset + 1;
4191 length = AvMAX(ary) + 1; /* close enough to infinity */
4195 length = AvMAX(ary) + 1;
4197 if (offset > AvFILLp(ary) + 1) {
4198 if (ckWARN(WARN_MISC))
4199 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4200 offset = AvFILLp(ary) + 1;
4202 after = AvFILLp(ary) + 1 - (offset + length);
4203 if (after < 0) { /* not that much array */
4204 length += after; /* offset+length now in array */
4210 /* At this point, MARK .. SP-1 is our new LIST */
4213 diff = newlen - length;
4214 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4217 /* make new elements SVs now: avoid problems if they're from the array */
4218 for (dst = MARK, i = newlen; i; i--) {
4220 *dst++ = newSVsv(h);
4223 if (diff < 0) { /* shrinking the area */
4225 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4226 Copy(MARK, tmparyval, newlen, SV*);
4229 MARK = ORIGMARK + 1;
4230 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4231 MEXTEND(MARK, length);
4232 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4234 EXTEND_MORTAL(length);
4235 for (i = length, dst = MARK; i; i--) {
4236 sv_2mortal(*dst); /* free them eventualy */
4243 *MARK = AvARRAY(ary)[offset+length-1];
4246 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4247 SvREFCNT_dec(*dst++); /* free them now */
4250 AvFILLp(ary) += diff;
4252 /* pull up or down? */
4254 if (offset < after) { /* easier to pull up */
4255 if (offset) { /* esp. if nothing to pull */
4256 src = &AvARRAY(ary)[offset-1];
4257 dst = src - diff; /* diff is negative */
4258 for (i = offset; i > 0; i--) /* can't trust Copy */
4262 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4266 if (after) { /* anything to pull down? */
4267 src = AvARRAY(ary) + offset + length;
4268 dst = src + diff; /* diff is negative */
4269 Move(src, dst, after, SV*);
4271 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4272 /* avoid later double free */
4276 dst[--i] = &PL_sv_undef;
4279 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4280 Safefree(tmparyval);
4283 else { /* no, expanding (or same) */
4285 New(452, tmparyval, length, SV*); /* so remember deletion */
4286 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4289 if (diff > 0) { /* expanding */
4291 /* push up or down? */
4293 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4297 Move(src, dst, offset, SV*);
4299 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4301 AvFILLp(ary) += diff;
4304 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4305 av_extend(ary, AvFILLp(ary) + diff);
4306 AvFILLp(ary) += diff;
4309 dst = AvARRAY(ary) + AvFILLp(ary);
4311 for (i = after; i; i--) {
4319 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4322 MARK = ORIGMARK + 1;
4323 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4325 Copy(tmparyval, MARK, length, SV*);
4327 EXTEND_MORTAL(length);
4328 for (i = length, dst = MARK; i; i--) {
4329 sv_2mortal(*dst); /* free them eventualy */
4333 Safefree(tmparyval);
4337 else if (length--) {
4338 *MARK = tmparyval[length];
4341 while (length-- > 0)
4342 SvREFCNT_dec(tmparyval[length]);
4344 Safefree(tmparyval);
4347 *MARK = &PL_sv_undef;
4355 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4356 register AV *ary = (AV*)*++MARK;
4357 register SV *sv = &PL_sv_undef;
4360 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4361 *MARK-- = SvTIED_obj((SV*)ary, mg);
4365 call_method("PUSH",G_SCALAR|G_DISCARD);
4370 /* Why no pre-extend of ary here ? */
4371 for (++MARK; MARK <= SP; MARK++) {
4374 sv_setsv(sv, *MARK);
4379 PUSHi( AvFILL(ary) + 1 );
4387 SV *sv = av_pop(av);
4389 (void)sv_2mortal(sv);
4398 SV *sv = av_shift(av);
4403 (void)sv_2mortal(sv);
4410 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4411 register AV *ary = (AV*)*++MARK;
4416 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4417 *MARK-- = SvTIED_obj((SV*)ary, mg);
4421 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4426 av_unshift(ary, SP - MARK);
4428 sv = newSVsv(*++MARK);
4429 (void)av_store(ary, i++, sv);
4433 PUSHi( AvFILL(ary) + 1 );
4443 if (GIMME == G_ARRAY) {
4450 /* safe as long as stack cannot get extended in the above */
4455 register char *down;
4461 SvUTF8_off(TARG); /* decontaminate */
4463 do_join(TARG, &PL_sv_no, MARK, SP);
4465 sv_setsv(TARG, (SP > MARK)
4467 : (padoff_du = find_rundefsvoffset(),
4468 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4469 ? DEFSV : PAD_SVl(padoff_du)));
4470 up = SvPV_force(TARG, len);
4472 if (DO_UTF8(TARG)) { /* first reverse each character */
4473 U8* s = (U8*)SvPVX(TARG);
4474 U8* send = (U8*)(s + len);
4476 if (UTF8_IS_INVARIANT(*s)) {
4481 if (!utf8_to_uvchr(s, 0))
4485 down = (char*)(s - 1);
4486 /* reverse this character */
4490 *down-- = (char)tmp;
4496 down = SvPVX(TARG) + len - 1;
4500 *down-- = (char)tmp;
4502 (void)SvPOK_only_UTF8(TARG);
4514 register IV limit = POPi; /* note, negative is forever */
4517 register char *s = SvPV(sv, len);
4518 bool do_utf8 = DO_UTF8(sv);
4519 char *strend = s + len;
4521 register REGEXP *rx;
4525 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4526 I32 maxiters = slen + 10;
4529 I32 origlimit = limit;
4532 const I32 gimme = GIMME_V;
4533 const I32 oldsave = PL_savestack_ix;
4534 I32 make_mortal = 1;
4536 MAGIC *mg = (MAGIC *) NULL;
4539 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4544 DIE(aTHX_ "panic: pp_split");
4547 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4548 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4550 RX_MATCH_UTF8_set(rx, do_utf8);
4552 if (pm->op_pmreplroot) {
4554 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4556 ary = GvAVn((GV*)pm->op_pmreplroot);
4559 else if (gimme != G_ARRAY)
4560 ary = GvAVn(PL_defgv);
4563 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4569 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4571 XPUSHs(SvTIED_obj((SV*)ary, mg));
4577 for (i = AvFILLp(ary); i >= 0; i--)
4578 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4580 /* temporarily switch stacks */
4581 SAVESWITCHSTACK(PL_curstack, ary);
4585 base = SP - PL_stack_base;
4587 if (pm->op_pmflags & PMf_SKIPWHITE) {
4588 if (pm->op_pmflags & PMf_LOCALE) {
4589 while (isSPACE_LC(*s))
4597 if (pm->op_pmflags & PMf_MULTILINE) {
4602 limit = maxiters + 2;
4603 if (pm->op_pmflags & PMf_WHITE) {
4606 while (m < strend &&
4607 !((pm->op_pmflags & PMf_LOCALE)
4608 ? isSPACE_LC(*m) : isSPACE(*m)))
4613 dstr = newSVpvn(s, m-s);
4617 (void)SvUTF8_on(dstr);
4621 while (s < strend &&
4622 ((pm->op_pmflags & PMf_LOCALE)
4623 ? isSPACE_LC(*s) : isSPACE(*s)))
4627 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4630 for (m = s; m < strend && *m != '\n'; m++) ;
4634 dstr = newSVpvn(s, m-s);
4638 (void)SvUTF8_on(dstr);
4643 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4644 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4645 && (rx->reganch & ROPT_CHECK_ALL)
4646 && !(rx->reganch & ROPT_ANCH)) {
4647 int tail = (rx->reganch & RE_INTUIT_TAIL);
4648 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4651 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4653 char c = *SvPV(csv, n_a);
4656 for (m = s; m < strend && *m != c; m++) ;
4659 dstr = newSVpvn(s, m-s);
4663 (void)SvUTF8_on(dstr);
4665 /* The rx->minlen is in characters but we want to step
4666 * s ahead by bytes. */
4668 s = (char*)utf8_hop((U8*)m, len);
4670 s = m + len; /* Fake \n at the end */
4674 while (s < strend && --limit &&
4675 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4676 csv, multiline ? FBMrf_MULTILINE : 0)) )
4678 dstr = newSVpvn(s, m-s);
4682 (void)SvUTF8_on(dstr);
4684 /* The rx->minlen is in characters but we want to step
4685 * s ahead by bytes. */
4687 s = (char*)utf8_hop((U8*)m, len);
4689 s = m + len; /* Fake \n at the end */
4694 maxiters += slen * rx->nparens;
4695 while (s < strend && --limit)
4698 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4702 TAINT_IF(RX_MATCH_TAINTED(rx));
4703 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4708 strend = s + (strend - m);
4710 m = rx->startp[0] + orig;
4711 dstr = newSVpvn(s, m-s);
4715 (void)SvUTF8_on(dstr);
4718 for (i = 1; i <= (I32)rx->nparens; i++) {
4719 s = rx->startp[i] + orig;
4720 m = rx->endp[i] + orig;
4722 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4723 parens that didn't match -- they should be set to
4724 undef, not the empty string */
4725 if (m >= orig && s >= orig) {
4726 dstr = newSVpvn(s, m-s);
4729 dstr = &PL_sv_undef; /* undef, not "" */
4733 (void)SvUTF8_on(dstr);
4737 s = rx->endp[0] + orig;
4741 iters = (SP - PL_stack_base) - base;
4742 if (iters > maxiters)
4743 DIE(aTHX_ "Split loop");
4745 /* keep field after final delim? */
4746 if (s < strend || (iters && origlimit)) {
4747 STRLEN l = strend - s;
4748 dstr = newSVpvn(s, l);
4752 (void)SvUTF8_on(dstr);
4756 else if (!origlimit) {
4757 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4758 if (TOPs && !make_mortal)
4761 *SP-- = &PL_sv_undef;
4766 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4770 if (SvSMAGICAL(ary)) {
4775 if (gimme == G_ARRAY) {
4777 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4785 call_method("PUSH",G_SCALAR|G_DISCARD);
4788 if (gimme == G_ARRAY) {
4789 /* EXTEND should not be needed - we just popped them */
4791 for (i=0; i < iters; i++) {
4792 SV **svp = av_fetch(ary, i, FALSE);
4793 PUSHs((svp) ? *svp : &PL_sv_undef);
4800 if (gimme == G_ARRAY)
4815 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4816 || SvTYPE(retsv) == SVt_PVCV) {
4817 retsv = refto(retsv);
4825 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4830 * c-indentation-style: bsd
4832 * indent-tabs-mode: t
4835 * ex: set ts=8 sts=4 sw=4 noet: