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 = Perl_av_arylen_p(aTHX_ (AV*)av);
301 sv_upgrade(*sv, SVt_PVMG);
302 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
310 dSP; dTARGET; dPOPss;
312 if (PL_op->op_flags & OPf_MOD || LVRET) {
313 if (SvTYPE(TARG) < SVt_PVLV) {
314 sv_upgrade(TARG, SVt_PVLV);
315 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
319 if (LvTARG(TARG) != sv) {
321 SvREFCNT_dec(LvTARG(TARG));
322 LvTARG(TARG) = SvREFCNT_inc(sv);
324 PUSHs(TARG); /* no SvSETMAGIC */
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 HEK *hek = HvNAME_HEK(GvSTASH(gv));
604 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
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 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3363 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3365 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3367 (void) POPs; /* Ignore the argument value. */
3368 value = UNICODE_REPLACEMENT;
3374 SvUPGRADE(TARG,SVt_PV);
3376 if (value > 255 && !IN_BYTES) {
3377 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3378 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3379 SvCUR_set(TARG, tmps - SvPVX(TARG));
3381 (void)SvPOK_only(TARG);
3390 *tmps++ = (char)value;
3392 (void)SvPOK_only(TARG);
3393 if (PL_encoding && !IN_BYTES) {
3394 sv_recode_to_utf8(TARG, PL_encoding);
3396 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3397 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3401 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3402 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3418 char *tmps = SvPV(left, len);
3420 if (DO_UTF8(left)) {
3421 /* If Unicode, try to downgrade.
3422 * If not possible, croak.
3423 * Yes, we made this up. */
3424 SV* tsv = sv_2mortal(newSVsv(left));
3427 sv_utf8_downgrade(tsv, FALSE);
3430 # ifdef USE_ITHREADS
3432 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3433 /* This should be threadsafe because in ithreads there is only
3434 * one thread per interpreter. If this would not be true,
3435 * we would need a mutex to protect this malloc. */
3436 PL_reentrant_buffer->_crypt_struct_buffer =
3437 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3438 #if defined(__GLIBC__) || defined(__EMX__)
3439 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3440 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3441 /* work around glibc-2.2.5 bug */
3442 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3446 # endif /* HAS_CRYPT_R */
3447 # endif /* USE_ITHREADS */
3449 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3451 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3457 "The crypt() function is unimplemented due to excessive paranoia.");
3470 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3471 UTF8_IS_START(*s)) {
3472 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3476 utf8_to_uvchr(s, &ulen);
3477 toTITLE_utf8(s, tmpbuf, &tculen);
3478 utf8_to_uvchr(tmpbuf, 0);
3480 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3482 /* slen is the byte length of the whole SV.
3483 * ulen is the byte length of the original Unicode character
3484 * stored as UTF-8 at s.
3485 * tculen is the byte length of the freshly titlecased
3486 * Unicode character stored as UTF-8 at tmpbuf.
3487 * We first set the result to be the titlecased character,
3488 * and then append the rest of the SV data. */
3489 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3491 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3496 s = (U8*)SvPV_force_nomg(sv, slen);
3497 Copy(tmpbuf, s, tculen, U8);
3501 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3503 SvUTF8_off(TARG); /* decontaminate */
3504 sv_setsv_nomg(TARG, sv);
3508 s = (U8*)SvPV_force_nomg(sv, slen);
3510 if (IN_LOCALE_RUNTIME) {
3513 *s = toUPPER_LC(*s);
3532 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3533 UTF8_IS_START(*s)) {
3535 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3539 toLOWER_utf8(s, tmpbuf, &ulen);
3540 uv = utf8_to_uvchr(tmpbuf, 0);
3541 tend = uvchr_to_utf8(tmpbuf, uv);
3543 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3545 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3547 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3552 s = (U8*)SvPV_force_nomg(sv, slen);
3553 Copy(tmpbuf, s, ulen, U8);
3557 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3559 SvUTF8_off(TARG); /* decontaminate */
3560 sv_setsv_nomg(TARG, sv);
3564 s = (U8*)SvPV_force_nomg(sv, slen);
3566 if (IN_LOCALE_RUNTIME) {
3569 *s = toLOWER_LC(*s);
3592 U8 tmpbuf[UTF8_MAXBYTES+1];
3594 s = (U8*)SvPV_nomg(sv,len);
3596 SvUTF8_off(TARG); /* decontaminate */
3597 sv_setpvn(TARG, "", 0);
3601 STRLEN min = len + 1;
3603 SvUPGRADE(TARG, SVt_PV);
3605 (void)SvPOK_only(TARG);
3606 d = (U8*)SvPVX(TARG);
3609 STRLEN u = UTF8SKIP(s);
3611 toUPPER_utf8(s, tmpbuf, &ulen);
3612 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3613 /* If the eventually required minimum size outgrows
3614 * the available space, we need to grow. */
3615 UV o = d - (U8*)SvPVX(TARG);
3617 /* If someone uppercases one million U+03B0s we
3618 * SvGROW() one million times. Or we could try
3619 * guessing how much to allocate without allocating
3620 * too much. Such is life. */
3622 d = (U8*)SvPVX(TARG) + o;
3624 Copy(tmpbuf, d, ulen, U8);
3630 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3635 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3637 SvUTF8_off(TARG); /* decontaminate */
3638 sv_setsv_nomg(TARG, sv);
3642 s = (U8*)SvPV_force_nomg(sv, len);
3644 register U8 *send = s + len;
3646 if (IN_LOCALE_RUNTIME) {
3649 for (; s < send; s++)
3650 *s = toUPPER_LC(*s);
3653 for (; s < send; s++)
3675 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3677 s = (U8*)SvPV_nomg(sv,len);
3679 SvUTF8_off(TARG); /* decontaminate */
3680 sv_setpvn(TARG, "", 0);
3684 STRLEN min = len + 1;
3686 SvUPGRADE(TARG, SVt_PV);
3688 (void)SvPOK_only(TARG);
3689 d = (U8*)SvPVX(TARG);
3692 STRLEN u = UTF8SKIP(s);
3693 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3695 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3696 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3698 * Now if the sigma is NOT followed by
3699 * /$ignorable_sequence$cased_letter/;
3700 * and it IS preceded by
3701 * /$cased_letter$ignorable_sequence/;
3702 * where $ignorable_sequence is
3703 * [\x{2010}\x{AD}\p{Mn}]*
3704 * and $cased_letter is
3705 * [\p{Ll}\p{Lo}\p{Lt}]
3706 * then it should be mapped to 0x03C2,
3707 * (GREEK SMALL LETTER FINAL SIGMA),
3708 * instead of staying 0x03A3.
3709 * "should be": in other words,
3710 * this is not implemented yet.
3711 * See lib/unicore/SpecialCasing.txt.
3714 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3715 /* If the eventually required minimum size outgrows
3716 * the available space, we need to grow. */
3717 UV o = d - (U8*)SvPVX(TARG);
3719 /* If someone lowercases one million U+0130s we
3720 * SvGROW() one million times. Or we could try
3721 * guessing how much to allocate without allocating.
3722 * too much. Such is life. */
3724 d = (U8*)SvPVX(TARG) + o;
3726 Copy(tmpbuf, d, ulen, U8);
3732 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3737 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3739 SvUTF8_off(TARG); /* decontaminate */
3740 sv_setsv_nomg(TARG, sv);
3745 s = (U8*)SvPV_force_nomg(sv, len);
3747 register U8 *send = s + len;
3749 if (IN_LOCALE_RUNTIME) {
3752 for (; s < send; s++)
3753 *s = toLOWER_LC(*s);
3756 for (; s < send; s++)
3770 register char *s = SvPV(sv,len);
3773 SvUTF8_off(TARG); /* decontaminate */
3775 SvUPGRADE(TARG, SVt_PV);
3776 SvGROW(TARG, (len * 2) + 1);
3780 if (UTF8_IS_CONTINUED(*s)) {
3781 STRLEN ulen = UTF8SKIP(s);
3805 SvCUR_set(TARG, d - SvPVX(TARG));
3806 (void)SvPOK_only_UTF8(TARG);
3809 sv_setpvn(TARG, s, len);
3811 if (SvSMAGICAL(TARG))
3820 dSP; dMARK; dORIGMARK;
3822 register AV* av = (AV*)POPs;
3823 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3824 I32 arybase = PL_curcop->cop_arybase;
3827 if (SvTYPE(av) == SVt_PVAV) {
3828 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3830 for (svp = MARK + 1; svp <= SP; svp++) {
3835 if (max > AvMAX(av))
3838 while (++MARK <= SP) {
3839 elem = SvIVx(*MARK);
3843 svp = av_fetch(av, elem, lval);
3845 if (!svp || *svp == &PL_sv_undef)
3846 DIE(aTHX_ PL_no_aelem, elem);
3847 if (PL_op->op_private & OPpLVAL_INTRO)
3848 save_aelem(av, elem, svp);
3850 *MARK = svp ? *svp : &PL_sv_undef;
3853 if (GIMME != G_ARRAY) {
3855 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3861 /* Associative arrays. */
3866 HV *hash = (HV*)POPs;
3868 const I32 gimme = GIMME_V;
3871 /* might clobber stack_sp */
3872 entry = hv_iternext(hash);
3877 SV* sv = hv_iterkeysv(entry);
3878 PUSHs(sv); /* won't clobber stack_sp */
3879 if (gimme == G_ARRAY) {
3882 /* might clobber stack_sp */
3883 val = hv_iterval(hash, entry);
3888 else if (gimme == G_SCALAR)
3907 const I32 gimme = GIMME_V;
3908 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3912 if (PL_op->op_private & OPpSLICE) {
3916 hvtype = SvTYPE(hv);
3917 if (hvtype == SVt_PVHV) { /* hash element */
3918 while (++MARK <= SP) {
3919 sv = hv_delete_ent(hv, *MARK, discard, 0);
3920 *MARK = sv ? sv : &PL_sv_undef;
3923 else if (hvtype == SVt_PVAV) { /* array element */
3924 if (PL_op->op_flags & OPf_SPECIAL) {
3925 while (++MARK <= SP) {
3926 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3927 *MARK = sv ? sv : &PL_sv_undef;
3932 DIE(aTHX_ "Not a HASH reference");
3935 else if (gimme == G_SCALAR) {
3940 *++MARK = &PL_sv_undef;
3947 if (SvTYPE(hv) == SVt_PVHV)
3948 sv = hv_delete_ent(hv, keysv, discard, 0);
3949 else if (SvTYPE(hv) == SVt_PVAV) {
3950 if (PL_op->op_flags & OPf_SPECIAL)
3951 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3953 DIE(aTHX_ "panic: avhv_delete no longer supported");
3956 DIE(aTHX_ "Not a HASH reference");
3971 if (PL_op->op_private & OPpEXISTS_SUB) {
3975 cv = sv_2cv(sv, &hv, &gv, FALSE);
3978 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3984 if (SvTYPE(hv) == SVt_PVHV) {
3985 if (hv_exists_ent(hv, tmpsv, 0))
3988 else if (SvTYPE(hv) == SVt_PVAV) {
3989 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3990 if (av_exists((AV*)hv, SvIV(tmpsv)))
3995 DIE(aTHX_ "Not a HASH reference");
4002 dSP; dMARK; dORIGMARK;
4003 register HV *hv = (HV*)POPs;
4004 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4005 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
4006 bool other_magic = FALSE;
4012 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4013 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4014 /* Try to preserve the existenceness of a tied hash
4015 * element by using EXISTS and DELETE if possible.
4016 * Fallback to FETCH and STORE otherwise */
4017 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4018 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4019 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4022 while (++MARK <= SP) {
4026 bool preeminent = FALSE;
4029 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4030 hv_exists_ent(hv, keysv, 0);
4033 he = hv_fetch_ent(hv, keysv, lval, 0);
4034 svp = he ? &HeVAL(he) : 0;
4037 if (!svp || *svp == &PL_sv_undef) {
4038 DIE(aTHX_ PL_no_helem_sv, keysv);
4042 save_helem(hv, keysv, svp);
4045 char *key = SvPV(keysv, keylen);
4046 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4050 *MARK = svp ? *svp : &PL_sv_undef;
4052 if (GIMME != G_ARRAY) {
4054 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4060 /* List operators. */
4065 if (GIMME != G_ARRAY) {
4067 *MARK = *SP; /* unwanted list, return last item */
4069 *MARK = &PL_sv_undef;
4078 SV **lastrelem = PL_stack_sp;
4079 SV **lastlelem = PL_stack_base + POPMARK;
4080 SV **firstlelem = PL_stack_base + POPMARK + 1;
4081 register SV **firstrelem = lastlelem + 1;
4082 I32 arybase = PL_curcop->cop_arybase;
4083 I32 lval = PL_op->op_flags & OPf_MOD;
4084 I32 is_something_there = lval;
4086 register I32 max = lastrelem - lastlelem;
4087 register SV **lelem;
4090 if (GIMME != G_ARRAY) {
4091 ix = SvIVx(*lastlelem);
4096 if (ix < 0 || ix >= max)
4097 *firstlelem = &PL_sv_undef;
4099 *firstlelem = firstrelem[ix];
4105 SP = firstlelem - 1;
4109 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4115 if (ix < 0 || ix >= max)
4116 *lelem = &PL_sv_undef;
4118 is_something_there = TRUE;
4119 if (!(*lelem = firstrelem[ix]))
4120 *lelem = &PL_sv_undef;
4123 if (is_something_there)
4126 SP = firstlelem - 1;
4132 dSP; dMARK; dORIGMARK;
4133 I32 items = SP - MARK;
4134 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4135 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4142 dSP; dMARK; dORIGMARK;
4143 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4147 SV *val = NEWSV(46, 0);
4149 sv_setsv(val, *++MARK);
4150 else if (ckWARN(WARN_MISC))
4151 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4152 (void)hv_store_ent(hv,key,val,0);
4161 dVAR; dSP; dMARK; dORIGMARK;
4162 register AV *ary = (AV*)*++MARK;
4166 register I32 offset;
4167 register I32 length;
4174 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4175 *MARK-- = SvTIED_obj((SV*)ary, mg);
4179 call_method("SPLICE",GIMME_V);
4188 offset = i = SvIVx(*MARK);
4190 offset += AvFILLp(ary) + 1;
4192 offset -= PL_curcop->cop_arybase;
4194 DIE(aTHX_ PL_no_aelem, i);
4196 length = SvIVx(*MARK++);
4198 length += AvFILLp(ary) - offset + 1;
4204 length = AvMAX(ary) + 1; /* close enough to infinity */
4208 length = AvMAX(ary) + 1;
4210 if (offset > AvFILLp(ary) + 1) {
4211 if (ckWARN(WARN_MISC))
4212 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4213 offset = AvFILLp(ary) + 1;
4215 after = AvFILLp(ary) + 1 - (offset + length);
4216 if (after < 0) { /* not that much array */
4217 length += after; /* offset+length now in array */
4223 /* At this point, MARK .. SP-1 is our new LIST */
4226 diff = newlen - length;
4227 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4230 /* make new elements SVs now: avoid problems if they're from the array */
4231 for (dst = MARK, i = newlen; i; i--) {
4233 *dst++ = newSVsv(h);
4236 if (diff < 0) { /* shrinking the area */
4238 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4239 Copy(MARK, tmparyval, newlen, SV*);
4242 MARK = ORIGMARK + 1;
4243 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4244 MEXTEND(MARK, length);
4245 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4247 EXTEND_MORTAL(length);
4248 for (i = length, dst = MARK; i; i--) {
4249 sv_2mortal(*dst); /* free them eventualy */
4256 *MARK = AvARRAY(ary)[offset+length-1];
4259 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4260 SvREFCNT_dec(*dst++); /* free them now */
4263 AvFILLp(ary) += diff;
4265 /* pull up or down? */
4267 if (offset < after) { /* easier to pull up */
4268 if (offset) { /* esp. if nothing to pull */
4269 src = &AvARRAY(ary)[offset-1];
4270 dst = src - diff; /* diff is negative */
4271 for (i = offset; i > 0; i--) /* can't trust Copy */
4275 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4279 if (after) { /* anything to pull down? */
4280 src = AvARRAY(ary) + offset + length;
4281 dst = src + diff; /* diff is negative */
4282 Move(src, dst, after, SV*);
4284 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4285 /* avoid later double free */
4289 dst[--i] = &PL_sv_undef;
4292 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4293 Safefree(tmparyval);
4296 else { /* no, expanding (or same) */
4298 New(452, tmparyval, length, SV*); /* so remember deletion */
4299 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4302 if (diff > 0) { /* expanding */
4304 /* push up or down? */
4306 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4310 Move(src, dst, offset, SV*);
4312 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4314 AvFILLp(ary) += diff;
4317 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4318 av_extend(ary, AvFILLp(ary) + diff);
4319 AvFILLp(ary) += diff;
4322 dst = AvARRAY(ary) + AvFILLp(ary);
4324 for (i = after; i; i--) {
4332 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4335 MARK = ORIGMARK + 1;
4336 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4338 Copy(tmparyval, MARK, length, SV*);
4340 EXTEND_MORTAL(length);
4341 for (i = length, dst = MARK; i; i--) {
4342 sv_2mortal(*dst); /* free them eventualy */
4346 Safefree(tmparyval);
4350 else if (length--) {
4351 *MARK = tmparyval[length];
4354 while (length-- > 0)
4355 SvREFCNT_dec(tmparyval[length]);
4357 Safefree(tmparyval);
4360 *MARK = &PL_sv_undef;
4368 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4369 register AV *ary = (AV*)*++MARK;
4370 register SV *sv = &PL_sv_undef;
4373 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4374 *MARK-- = SvTIED_obj((SV*)ary, mg);
4378 call_method("PUSH",G_SCALAR|G_DISCARD);
4383 /* Why no pre-extend of ary here ? */
4384 for (++MARK; MARK <= SP; MARK++) {
4387 sv_setsv(sv, *MARK);
4392 PUSHi( AvFILL(ary) + 1 );
4400 SV *sv = av_pop(av);
4402 (void)sv_2mortal(sv);
4411 SV *sv = av_shift(av);
4416 (void)sv_2mortal(sv);
4423 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4424 register AV *ary = (AV*)*++MARK;
4429 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4430 *MARK-- = SvTIED_obj((SV*)ary, mg);
4434 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4439 av_unshift(ary, SP - MARK);
4441 sv = newSVsv(*++MARK);
4442 (void)av_store(ary, i++, sv);
4446 PUSHi( AvFILL(ary) + 1 );
4456 if (GIMME == G_ARRAY) {
4463 /* safe as long as stack cannot get extended in the above */
4468 register char *down;
4474 SvUTF8_off(TARG); /* decontaminate */
4476 do_join(TARG, &PL_sv_no, MARK, SP);
4478 sv_setsv(TARG, (SP > MARK)
4480 : (padoff_du = find_rundefsvoffset(),
4481 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4482 ? DEFSV : PAD_SVl(padoff_du)));
4483 up = SvPV_force(TARG, len);
4485 if (DO_UTF8(TARG)) { /* first reverse each character */
4486 U8* s = (U8*)SvPVX(TARG);
4487 U8* send = (U8*)(s + len);
4489 if (UTF8_IS_INVARIANT(*s)) {
4494 if (!utf8_to_uvchr(s, 0))
4498 down = (char*)(s - 1);
4499 /* reverse this character */
4503 *down-- = (char)tmp;
4509 down = SvPVX(TARG) + len - 1;
4513 *down-- = (char)tmp;
4515 (void)SvPOK_only_UTF8(TARG);
4527 register IV limit = POPi; /* note, negative is forever */
4530 register char *s = SvPV(sv, len);
4531 bool do_utf8 = DO_UTF8(sv);
4532 char *strend = s + len;
4534 register REGEXP *rx;
4538 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4539 I32 maxiters = slen + 10;
4542 I32 origlimit = limit;
4545 const I32 gimme = GIMME_V;
4546 const I32 oldsave = PL_savestack_ix;
4547 I32 make_mortal = 1;
4549 MAGIC *mg = (MAGIC *) NULL;
4552 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4557 DIE(aTHX_ "panic: pp_split");
4560 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4561 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4563 RX_MATCH_UTF8_set(rx, do_utf8);
4565 if (pm->op_pmreplroot) {
4567 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4569 ary = GvAVn((GV*)pm->op_pmreplroot);
4572 else if (gimme != G_ARRAY)
4573 ary = GvAVn(PL_defgv);
4576 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4582 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4584 XPUSHs(SvTIED_obj((SV*)ary, mg));
4590 for (i = AvFILLp(ary); i >= 0; i--)
4591 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4593 /* temporarily switch stacks */
4594 SAVESWITCHSTACK(PL_curstack, ary);
4598 base = SP - PL_stack_base;
4600 if (pm->op_pmflags & PMf_SKIPWHITE) {
4601 if (pm->op_pmflags & PMf_LOCALE) {
4602 while (isSPACE_LC(*s))
4610 if (pm->op_pmflags & PMf_MULTILINE) {
4615 limit = maxiters + 2;
4616 if (pm->op_pmflags & PMf_WHITE) {
4619 while (m < strend &&
4620 !((pm->op_pmflags & PMf_LOCALE)
4621 ? isSPACE_LC(*m) : isSPACE(*m)))
4626 dstr = newSVpvn(s, m-s);
4630 (void)SvUTF8_on(dstr);
4634 while (s < strend &&
4635 ((pm->op_pmflags & PMf_LOCALE)
4636 ? isSPACE_LC(*s) : isSPACE(*s)))
4640 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4643 for (m = s; m < strend && *m != '\n'; m++) ;
4647 dstr = newSVpvn(s, m-s);
4651 (void)SvUTF8_on(dstr);
4656 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4657 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4658 && (rx->reganch & ROPT_CHECK_ALL)
4659 && !(rx->reganch & ROPT_ANCH)) {
4660 int tail = (rx->reganch & RE_INTUIT_TAIL);
4661 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4664 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4666 char c = *SvPV(csv, n_a);
4669 for (m = s; m < strend && *m != c; m++) ;
4672 dstr = newSVpvn(s, m-s);
4676 (void)SvUTF8_on(dstr);
4678 /* The rx->minlen is in characters but we want to step
4679 * s ahead by bytes. */
4681 s = (char*)utf8_hop((U8*)m, len);
4683 s = m + len; /* Fake \n at the end */
4687 while (s < strend && --limit &&
4688 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4689 csv, multiline ? FBMrf_MULTILINE : 0)) )
4691 dstr = newSVpvn(s, m-s);
4695 (void)SvUTF8_on(dstr);
4697 /* The rx->minlen is in characters but we want to step
4698 * s ahead by bytes. */
4700 s = (char*)utf8_hop((U8*)m, len);
4702 s = m + len; /* Fake \n at the end */
4707 maxiters += slen * rx->nparens;
4708 while (s < strend && --limit)
4711 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4715 TAINT_IF(RX_MATCH_TAINTED(rx));
4716 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4721 strend = s + (strend - m);
4723 m = rx->startp[0] + orig;
4724 dstr = newSVpvn(s, m-s);
4728 (void)SvUTF8_on(dstr);
4731 for (i = 1; i <= (I32)rx->nparens; i++) {
4732 s = rx->startp[i] + orig;
4733 m = rx->endp[i] + orig;
4735 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4736 parens that didn't match -- they should be set to
4737 undef, not the empty string */
4738 if (m >= orig && s >= orig) {
4739 dstr = newSVpvn(s, m-s);
4742 dstr = &PL_sv_undef; /* undef, not "" */
4746 (void)SvUTF8_on(dstr);
4750 s = rx->endp[0] + orig;
4754 iters = (SP - PL_stack_base) - base;
4755 if (iters > maxiters)
4756 DIE(aTHX_ "Split loop");
4758 /* keep field after final delim? */
4759 if (s < strend || (iters && origlimit)) {
4760 STRLEN l = strend - s;
4761 dstr = newSVpvn(s, l);
4765 (void)SvUTF8_on(dstr);
4769 else if (!origlimit) {
4770 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4771 if (TOPs && !make_mortal)
4774 *SP-- = &PL_sv_undef;
4779 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4783 if (SvSMAGICAL(ary)) {
4788 if (gimme == G_ARRAY) {
4790 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4798 call_method("PUSH",G_SCALAR|G_DISCARD);
4801 if (gimme == G_ARRAY) {
4802 /* EXTEND should not be needed - we just popped them */
4804 for (i=0; i < iters; i++) {
4805 SV **svp = av_fetch(ary, i, FALSE);
4806 PUSHs((svp) ? *svp : &PL_sv_undef);
4813 if (gimme == G_ARRAY)
4828 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4829 || SvTYPE(retsv) == SVt_PVCV) {
4830 retsv = refto(retsv);
4838 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4843 * c-indentation-style: bsd
4845 * indent-tabs-mode: t
4848 * ex: set ts=8 sts=4 sw=4 noet: