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");
538 ptr = SvPV_const(ssv,len);
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);
558 elem = SvPV_nolen_const(sv);
563 /* elem will always be NUL terminated. */
564 const char *elem2 = elem + 1;
567 if (strEQ(elem2, "RRAY"))
568 tmpRef = (SV*)GvAV(gv);
571 if (strEQ(elem2, "ODE"))
572 tmpRef = (SV*)GvCVu(gv);
575 if (strEQ(elem2, "ILEHANDLE")) {
576 /* finally deprecated in 5.8.0 */
577 deprecate("*glob{FILEHANDLE}");
578 tmpRef = (SV*)GvIOp(gv);
581 if (strEQ(elem2, "ORMAT"))
582 tmpRef = (SV*)GvFORM(gv);
585 if (strEQ(elem2, "LOB"))
589 if (strEQ(elem2, "ASH"))
590 tmpRef = (SV*)GvHV(gv);
593 if (*elem2 == 'O' && !elem[2])
594 tmpRef = (SV*)GvIOp(gv);
597 if (strEQ(elem2, "AME"))
598 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
601 if (strEQ(elem2, "ACKAGE")) {
602 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
603 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
607 if (strEQ(elem2, "CALAR"))
622 /* Pattern matching */
627 register unsigned char *s;
630 register I32 *sfirst;
634 if (sv == PL_lastscream) {
640 SvSCREAM_off(PL_lastscream);
641 SvREFCNT_dec(PL_lastscream);
643 PL_lastscream = SvREFCNT_inc(sv);
646 s = (unsigned char*)(SvPV(sv, len));
650 if (pos > PL_maxscream) {
651 if (PL_maxscream < 0) {
652 PL_maxscream = pos + 80;
653 New(301, PL_screamfirst, 256, I32);
654 New(302, PL_screamnext, PL_maxscream, I32);
657 PL_maxscream = pos + pos / 4;
658 Renew(PL_screamnext, PL_maxscream, I32);
662 sfirst = PL_screamfirst;
663 snext = PL_screamnext;
665 if (!sfirst || !snext)
666 DIE(aTHX_ "do_study: out of memory");
668 for (ch = 256; ch; --ch)
675 snext[pos] = sfirst[ch] - pos;
682 /* piggyback on m//g magic */
683 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
692 if (PL_op->op_flags & OPf_STACKED)
694 else if (PL_op->op_private & OPpTARGET_MY)
700 TARG = sv_newmortal();
705 /* Lvalue operators. */
717 dSP; dMARK; dTARGET; dORIGMARK;
719 do_chop(TARG, *++MARK);
728 SETi(do_chomp(TOPs));
735 register I32 count = 0;
738 count += do_chomp(POPs);
749 if (!sv || !SvANY(sv))
751 switch (SvTYPE(sv)) {
753 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
754 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
758 if (HvARRAY(sv) || SvGMAGICAL(sv)
759 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
763 if (CvROOT(sv) || CvXSUB(sv))
780 if (!PL_op->op_private) {
789 SV_CHECK_THINKFIRST_COW_DROP(sv);
791 switch (SvTYPE(sv)) {
801 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
802 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
803 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
807 /* let user-undef'd sub keep its identity */
808 GV* gv = CvGV((CV*)sv);
815 SvSetMagicSV(sv, &PL_sv_undef);
819 Newz(602, gp, 1, GP);
820 GvGP(sv) = gp_ref(gp);
821 GvSV(sv) = NEWSV(72,0);
822 GvLINE(sv) = CopLINE(PL_curcop);
828 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
830 SvPV_set(sv, Nullch);
843 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
844 DIE(aTHX_ PL_no_modify);
845 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
846 && SvIVX(TOPs) != IV_MIN)
848 SvIV_set(TOPs, SvIVX(TOPs) - 1);
849 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
860 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
861 DIE(aTHX_ PL_no_modify);
862 sv_setsv(TARG, TOPs);
863 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
864 && SvIVX(TOPs) != IV_MAX)
866 SvIV_set(TOPs, SvIVX(TOPs) + 1);
867 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
872 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
882 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
883 DIE(aTHX_ PL_no_modify);
884 sv_setsv(TARG, TOPs);
885 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
886 && SvIVX(TOPs) != IV_MIN)
888 SvIV_set(TOPs, SvIVX(TOPs) - 1);
889 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
898 /* Ordinary operators. */
903 #ifdef PERL_PRESERVE_IVUV
906 tryAMAGICbin(pow,opASSIGN);
907 #ifdef PERL_PRESERVE_IVUV
908 /* For integer to integer power, we do the calculation by hand wherever
909 we're sure it is safe; otherwise we call pow() and try to convert to
910 integer afterwards. */
914 bool baseuok = SvUOK(TOPm1s);
918 baseuv = SvUVX(TOPm1s);
920 IV iv = SvIVX(TOPm1s);
923 baseuok = TRUE; /* effectively it's a UV now */
925 baseuv = -iv; /* abs, baseuok == false records sign */
939 goto float_it; /* Can't do negative powers this way. */
942 /* now we have integer ** positive integer. */
945 /* foo & (foo - 1) is zero only for a power of 2. */
946 if (!(baseuv & (baseuv - 1))) {
947 /* We are raising power-of-2 to a positive integer.
948 The logic here will work for any base (even non-integer
949 bases) but it can be less accurate than
950 pow (base,power) or exp (power * log (base)) when the
951 intermediate values start to spill out of the mantissa.
952 With powers of 2 we know this can't happen.
953 And powers of 2 are the favourite thing for perl
954 programmers to notice ** not doing what they mean. */
956 NV base = baseuok ? baseuv : -(NV)baseuv;
959 for (; power; base *= base, n++) {
960 /* Do I look like I trust gcc with long longs here?
962 UV bit = (UV)1 << (UV)n;
965 /* Only bother to clear the bit if it is set. */
967 /* Avoid squaring base again if we're done. */
968 if (power == 0) break;
976 register unsigned int highbit = 8 * sizeof(UV);
977 register unsigned int lowbit = 0;
978 register unsigned int diff;
979 bool odd_power = (bool)(power & 1);
980 while ((diff = (highbit - lowbit) >> 1)) {
981 if (baseuv & ~((1 << (lowbit + diff)) - 1))
986 /* we now have baseuv < 2 ** highbit */
987 if (power * highbit <= 8 * sizeof(UV)) {
988 /* result will definitely fit in UV, so use UV math
989 on same algorithm as above */
990 register UV result = 1;
991 register UV base = baseuv;
993 for (; power; base *= base, n++) {
994 register UV bit = (UV)1 << (UV)n;
998 if (power == 0) break;
1002 if (baseuok || !odd_power)
1003 /* answer is positive */
1005 else if (result <= (UV)IV_MAX)
1006 /* answer negative, fits in IV */
1007 SETi( -(IV)result );
1008 else if (result == (UV)IV_MIN)
1009 /* 2's complement assumption: special case IV_MIN */
1012 /* answer negative, doesn't fit */
1013 SETn( -(NV)result );
1024 SETn( Perl_pow( left, right) );
1025 #ifdef PERL_PRESERVE_IVUV
1035 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1036 #ifdef PERL_PRESERVE_IVUV
1039 /* Unless the left argument is integer in range we are going to have to
1040 use NV maths. Hence only attempt to coerce the right argument if
1041 we know the left is integer. */
1042 /* Left operand is defined, so is it IV? */
1043 SvIV_please(TOPm1s);
1044 if (SvIOK(TOPm1s)) {
1045 bool auvok = SvUOK(TOPm1s);
1046 bool buvok = SvUOK(TOPs);
1047 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1048 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1055 alow = SvUVX(TOPm1s);
1057 IV aiv = SvIVX(TOPm1s);
1060 auvok = TRUE; /* effectively it's a UV now */
1062 alow = -aiv; /* abs, auvok == false records sign */
1068 IV biv = SvIVX(TOPs);
1071 buvok = TRUE; /* effectively it's a UV now */
1073 blow = -biv; /* abs, buvok == false records sign */
1077 /* If this does sign extension on unsigned it's time for plan B */
1078 ahigh = alow >> (4 * sizeof (UV));
1080 bhigh = blow >> (4 * sizeof (UV));
1082 if (ahigh && bhigh) {
1083 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1084 which is overflow. Drop to NVs below. */
1085 } else if (!ahigh && !bhigh) {
1086 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1087 so the unsigned multiply cannot overflow. */
1088 UV product = alow * blow;
1089 if (auvok == buvok) {
1090 /* -ve * -ve or +ve * +ve gives a +ve result. */
1094 } else if (product <= (UV)IV_MIN) {
1095 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1096 /* -ve result, which could overflow an IV */
1098 SETi( -(IV)product );
1100 } /* else drop to NVs below. */
1102 /* One operand is large, 1 small */
1105 /* swap the operands */
1107 bhigh = blow; /* bhigh now the temp var for the swap */
1111 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1112 multiplies can't overflow. shift can, add can, -ve can. */
1113 product_middle = ahigh * blow;
1114 if (!(product_middle & topmask)) {
1115 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1117 product_middle <<= (4 * sizeof (UV));
1118 product_low = alow * blow;
1120 /* as for pp_add, UV + something mustn't get smaller.
1121 IIRC ANSI mandates this wrapping *behaviour* for
1122 unsigned whatever the actual representation*/
1123 product_low += product_middle;
1124 if (product_low >= product_middle) {
1125 /* didn't overflow */
1126 if (auvok == buvok) {
1127 /* -ve * -ve or +ve * +ve gives a +ve result. */
1129 SETu( product_low );
1131 } else if (product_low <= (UV)IV_MIN) {
1132 /* 2s complement assumption again */
1133 /* -ve result, which could overflow an IV */
1135 SETi( -(IV)product_low );
1137 } /* else drop to NVs below. */
1139 } /* product_middle too large */
1140 } /* ahigh && bhigh */
1141 } /* SvIOK(TOPm1s) */
1146 SETn( left * right );
1153 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1154 /* Only try to do UV divide first
1155 if ((SLOPPYDIVIDE is true) or
1156 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1158 The assumption is that it is better to use floating point divide
1159 whenever possible, only doing integer divide first if we can't be sure.
1160 If NV_PRESERVES_UV is true then we know at compile time that no UV
1161 can be too large to preserve, so don't need to compile the code to
1162 test the size of UVs. */
1165 # define PERL_TRY_UV_DIVIDE
1166 /* ensure that 20./5. == 4. */
1168 # ifdef PERL_PRESERVE_IVUV
1169 # ifndef NV_PRESERVES_UV
1170 # define PERL_TRY_UV_DIVIDE
1175 #ifdef PERL_TRY_UV_DIVIDE
1178 SvIV_please(TOPm1s);
1179 if (SvIOK(TOPm1s)) {
1180 bool left_non_neg = SvUOK(TOPm1s);
1181 bool right_non_neg = SvUOK(TOPs);
1185 if (right_non_neg) {
1186 right = SvUVX(TOPs);
1189 IV biv = SvIVX(TOPs);
1192 right_non_neg = TRUE; /* effectively it's a UV now */
1198 /* historically undef()/0 gives a "Use of uninitialized value"
1199 warning before dieing, hence this test goes here.
1200 If it were immediately before the second SvIV_please, then
1201 DIE() would be invoked before left was even inspected, so
1202 no inpsection would give no warning. */
1204 DIE(aTHX_ "Illegal division by zero");
1207 left = SvUVX(TOPm1s);
1210 IV aiv = SvIVX(TOPm1s);
1213 left_non_neg = TRUE; /* effectively it's a UV now */
1222 /* For sloppy divide we always attempt integer division. */
1224 /* Otherwise we only attempt it if either or both operands
1225 would not be preserved by an NV. If both fit in NVs
1226 we fall through to the NV divide code below. However,
1227 as left >= right to ensure integer result here, we know that
1228 we can skip the test on the right operand - right big
1229 enough not to be preserved can't get here unless left is
1232 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1235 /* Integer division can't overflow, but it can be imprecise. */
1236 UV result = left / right;
1237 if (result * right == left) {
1238 SP--; /* result is valid */
1239 if (left_non_neg == right_non_neg) {
1240 /* signs identical, result is positive. */
1244 /* 2s complement assumption */
1245 if (result <= (UV)IV_MIN)
1246 SETi( -(IV)result );
1248 /* It's exact but too negative for IV. */
1249 SETn( -(NV)result );
1252 } /* tried integer divide but it was not an integer result */
1253 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1254 } /* left wasn't SvIOK */
1255 } /* right wasn't SvIOK */
1256 #endif /* PERL_TRY_UV_DIVIDE */
1260 DIE(aTHX_ "Illegal division by zero");
1261 PUSHn( left / right );
1268 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1272 bool left_neg = FALSE;
1273 bool right_neg = FALSE;
1274 bool use_double = FALSE;
1275 bool dright_valid = FALSE;
1281 right_neg = !SvUOK(TOPs);
1283 right = SvUVX(POPs);
1285 IV biv = SvIVX(POPs);
1288 right_neg = FALSE; /* effectively it's a UV now */
1296 right_neg = dright < 0;
1299 if (dright < UV_MAX_P1) {
1300 right = U_V(dright);
1301 dright_valid = TRUE; /* In case we need to use double below. */
1307 /* At this point use_double is only true if right is out of range for
1308 a UV. In range NV has been rounded down to nearest UV and
1309 use_double false. */
1311 if (!use_double && SvIOK(TOPs)) {
1313 left_neg = !SvUOK(TOPs);
1317 IV aiv = SvIVX(POPs);
1320 left_neg = FALSE; /* effectively it's a UV now */
1329 left_neg = dleft < 0;
1333 /* This should be exactly the 5.6 behaviour - if left and right are
1334 both in range for UV then use U_V() rather than floor. */
1336 if (dleft < UV_MAX_P1) {
1337 /* right was in range, so is dleft, so use UVs not double.
1341 /* left is out of range for UV, right was in range, so promote
1342 right (back) to double. */
1344 /* The +0.5 is used in 5.6 even though it is not strictly
1345 consistent with the implicit +0 floor in the U_V()
1346 inside the #if 1. */
1347 dleft = Perl_floor(dleft + 0.5);
1350 dright = Perl_floor(dright + 0.5);
1360 DIE(aTHX_ "Illegal modulus zero");
1362 dans = Perl_fmod(dleft, dright);
1363 if ((left_neg != right_neg) && dans)
1364 dans = dright - dans;
1367 sv_setnv(TARG, dans);
1373 DIE(aTHX_ "Illegal modulus zero");
1376 if ((left_neg != right_neg) && ans)
1379 /* XXX may warn: unary minus operator applied to unsigned type */
1380 /* could change -foo to be (~foo)+1 instead */
1381 if (ans <= ~((UV)IV_MAX)+1)
1382 sv_setiv(TARG, ~ans+1);
1384 sv_setnv(TARG, -(NV)ans);
1387 sv_setuv(TARG, ans);
1396 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1406 count = IV_MAX; /* The best we can do? */
1417 else if (SvNOKp(sv)) {
1426 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1428 I32 items = SP - MARK;
1430 static const char oom_list_extend[] =
1431 "Out of memory during list extend";
1433 max = items * count;
1434 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1435 /* Did the max computation overflow? */
1436 if (items > 0 && max > 0 && (max < items || max < count))
1437 Perl_croak(aTHX_ oom_list_extend);
1442 /* This code was intended to fix 20010809.028:
1445 for (($x =~ /./g) x 2) {
1446 print chop; # "abcdabcd" expected as output.
1449 * but that change (#11635) broke this code:
1451 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1453 * I can't think of a better fix that doesn't introduce
1454 * an efficiency hit by copying the SVs. The stack isn't
1455 * refcounted, and mortalisation obviously doesn't
1456 * Do The Right Thing when the stack has more than
1457 * one pointer to the same mortal value.
1461 *SP = sv_2mortal(newSVsv(*SP));
1471 repeatcpy((char*)(MARK + items), (char*)MARK,
1472 items * sizeof(SV*), count - 1);
1475 else if (count <= 0)
1478 else { /* Note: mark already snarfed by pp_list */
1482 static const char oom_string_extend[] =
1483 "Out of memory during string extend";
1485 SvSetSV(TARG, tmpstr);
1486 SvPV_force(TARG, len);
1487 isutf = DO_UTF8(TARG);
1492 STRLEN max = (UV)count * len;
1493 if (len > ((MEM_SIZE)~0)/count)
1494 Perl_croak(aTHX_ oom_string_extend);
1495 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1496 SvGROW(TARG, max + 1);
1497 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1498 SvCUR_set(TARG, SvCUR(TARG) * count);
1500 *SvEND(TARG) = '\0';
1503 (void)SvPOK_only_UTF8(TARG);
1505 (void)SvPOK_only(TARG);
1507 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1508 /* The parser saw this as a list repeat, and there
1509 are probably several items on the stack. But we're
1510 in scalar context, and there's no pp_list to save us
1511 now. So drop the rest of the items -- robin@kitsite.com
1524 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1525 useleft = USE_LEFT(TOPm1s);
1526 #ifdef PERL_PRESERVE_IVUV
1527 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1528 "bad things" happen if you rely on signed integers wrapping. */
1531 /* Unless the left argument is integer in range we are going to have to
1532 use NV maths. Hence only attempt to coerce the right argument if
1533 we know the left is integer. */
1534 register UV auv = 0;
1540 a_valid = auvok = 1;
1541 /* left operand is undef, treat as zero. */
1543 /* Left operand is defined, so is it IV? */
1544 SvIV_please(TOPm1s);
1545 if (SvIOK(TOPm1s)) {
1546 if ((auvok = SvUOK(TOPm1s)))
1547 auv = SvUVX(TOPm1s);
1549 register IV aiv = SvIVX(TOPm1s);
1552 auvok = 1; /* Now acting as a sign flag. */
1553 } else { /* 2s complement assumption for IV_MIN */
1561 bool result_good = 0;
1564 bool buvok = SvUOK(TOPs);
1569 register IV biv = SvIVX(TOPs);
1576 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1577 else "IV" now, independent of how it came in.
1578 if a, b represents positive, A, B negative, a maps to -A etc
1583 all UV maths. negate result if A negative.
1584 subtract if signs same, add if signs differ. */
1586 if (auvok ^ buvok) {
1595 /* Must get smaller */
1600 if (result <= buv) {
1601 /* result really should be -(auv-buv). as its negation
1602 of true value, need to swap our result flag */
1614 if (result <= (UV)IV_MIN)
1615 SETi( -(IV)result );
1617 /* result valid, but out of range for IV. */
1618 SETn( -(NV)result );
1622 } /* Overflow, drop through to NVs. */
1626 useleft = USE_LEFT(TOPm1s);
1630 /* left operand is undef, treat as zero - value */
1634 SETn( TOPn - value );
1641 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1644 if (PL_op->op_private & HINT_INTEGER) {
1658 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1661 if (PL_op->op_private & HINT_INTEGER) {
1675 dSP; tryAMAGICbinSET(lt,0);
1676 #ifdef PERL_PRESERVE_IVUV
1679 SvIV_please(TOPm1s);
1680 if (SvIOK(TOPm1s)) {
1681 bool auvok = SvUOK(TOPm1s);
1682 bool buvok = SvUOK(TOPs);
1684 if (!auvok && !buvok) { /* ## IV < IV ## */
1685 IV aiv = SvIVX(TOPm1s);
1686 IV biv = SvIVX(TOPs);
1689 SETs(boolSV(aiv < biv));
1692 if (auvok && buvok) { /* ## UV < UV ## */
1693 UV auv = SvUVX(TOPm1s);
1694 UV buv = SvUVX(TOPs);
1697 SETs(boolSV(auv < buv));
1700 if (auvok) { /* ## UV < IV ## */
1707 /* As (a) is a UV, it's >=0, so it cannot be < */
1712 SETs(boolSV(auv < (UV)biv));
1715 { /* ## IV < UV ## */
1719 aiv = SvIVX(TOPm1s);
1721 /* As (b) is a UV, it's >=0, so it must be < */
1728 SETs(boolSV((UV)aiv < buv));
1734 #ifndef NV_PRESERVES_UV
1735 #ifdef PERL_PRESERVE_IVUV
1738 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1740 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1746 SETs(boolSV(TOPn < value));
1753 dSP; tryAMAGICbinSET(gt,0);
1754 #ifdef PERL_PRESERVE_IVUV
1757 SvIV_please(TOPm1s);
1758 if (SvIOK(TOPm1s)) {
1759 bool auvok = SvUOK(TOPm1s);
1760 bool buvok = SvUOK(TOPs);
1762 if (!auvok && !buvok) { /* ## IV > IV ## */
1763 IV aiv = SvIVX(TOPm1s);
1764 IV biv = SvIVX(TOPs);
1767 SETs(boolSV(aiv > biv));
1770 if (auvok && buvok) { /* ## UV > UV ## */
1771 UV auv = SvUVX(TOPm1s);
1772 UV buv = SvUVX(TOPs);
1775 SETs(boolSV(auv > buv));
1778 if (auvok) { /* ## UV > IV ## */
1785 /* As (a) is a UV, it's >=0, so it must be > */
1790 SETs(boolSV(auv > (UV)biv));
1793 { /* ## IV > UV ## */
1797 aiv = SvIVX(TOPm1s);
1799 /* As (b) is a UV, it's >=0, so it cannot be > */
1806 SETs(boolSV((UV)aiv > buv));
1812 #ifndef NV_PRESERVES_UV
1813 #ifdef PERL_PRESERVE_IVUV
1816 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1818 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1824 SETs(boolSV(TOPn > value));
1831 dSP; tryAMAGICbinSET(le,0);
1832 #ifdef PERL_PRESERVE_IVUV
1835 SvIV_please(TOPm1s);
1836 if (SvIOK(TOPm1s)) {
1837 bool auvok = SvUOK(TOPm1s);
1838 bool buvok = SvUOK(TOPs);
1840 if (!auvok && !buvok) { /* ## IV <= IV ## */
1841 IV aiv = SvIVX(TOPm1s);
1842 IV biv = SvIVX(TOPs);
1845 SETs(boolSV(aiv <= biv));
1848 if (auvok && buvok) { /* ## UV <= UV ## */
1849 UV auv = SvUVX(TOPm1s);
1850 UV buv = SvUVX(TOPs);
1853 SETs(boolSV(auv <= buv));
1856 if (auvok) { /* ## UV <= IV ## */
1863 /* As (a) is a UV, it's >=0, so a cannot be <= */
1868 SETs(boolSV(auv <= (UV)biv));
1871 { /* ## IV <= UV ## */
1875 aiv = SvIVX(TOPm1s);
1877 /* As (b) is a UV, it's >=0, so a must be <= */
1884 SETs(boolSV((UV)aiv <= buv));
1890 #ifndef NV_PRESERVES_UV
1891 #ifdef PERL_PRESERVE_IVUV
1894 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1896 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1902 SETs(boolSV(TOPn <= value));
1909 dSP; tryAMAGICbinSET(ge,0);
1910 #ifdef PERL_PRESERVE_IVUV
1913 SvIV_please(TOPm1s);
1914 if (SvIOK(TOPm1s)) {
1915 bool auvok = SvUOK(TOPm1s);
1916 bool buvok = SvUOK(TOPs);
1918 if (!auvok && !buvok) { /* ## IV >= IV ## */
1919 IV aiv = SvIVX(TOPm1s);
1920 IV biv = SvIVX(TOPs);
1923 SETs(boolSV(aiv >= biv));
1926 if (auvok && buvok) { /* ## UV >= UV ## */
1927 UV auv = SvUVX(TOPm1s);
1928 UV buv = SvUVX(TOPs);
1931 SETs(boolSV(auv >= buv));
1934 if (auvok) { /* ## UV >= IV ## */
1941 /* As (a) is a UV, it's >=0, so it must be >= */
1946 SETs(boolSV(auv >= (UV)biv));
1949 { /* ## IV >= UV ## */
1953 aiv = SvIVX(TOPm1s);
1955 /* As (b) is a UV, it's >=0, so a cannot be >= */
1962 SETs(boolSV((UV)aiv >= buv));
1968 #ifndef NV_PRESERVES_UV
1969 #ifdef PERL_PRESERVE_IVUV
1972 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1974 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1980 SETs(boolSV(TOPn >= value));
1987 dSP; tryAMAGICbinSET(ne,0);
1988 #ifndef NV_PRESERVES_UV
1989 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1991 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1995 #ifdef PERL_PRESERVE_IVUV
1998 SvIV_please(TOPm1s);
1999 if (SvIOK(TOPm1s)) {
2000 bool auvok = SvUOK(TOPm1s);
2001 bool buvok = SvUOK(TOPs);
2003 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2004 /* Casting IV to UV before comparison isn't going to matter
2005 on 2s complement. On 1s complement or sign&magnitude
2006 (if we have any of them) it could make negative zero
2007 differ from normal zero. As I understand it. (Need to
2008 check - is negative zero implementation defined behaviour
2010 UV buv = SvUVX(POPs);
2011 UV auv = SvUVX(TOPs);
2013 SETs(boolSV(auv != buv));
2016 { /* ## Mixed IV,UV ## */
2020 /* != is commutative so swap if needed (save code) */
2022 /* swap. top of stack (b) is the iv */
2026 /* As (a) is a UV, it's >0, so it cannot be == */
2035 /* As (b) is a UV, it's >0, so it cannot be == */
2039 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2041 SETs(boolSV((UV)iv != uv));
2049 SETs(boolSV(TOPn != value));
2056 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2057 #ifndef NV_PRESERVES_UV
2058 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2059 UV right = PTR2UV(SvRV(POPs));
2060 UV left = PTR2UV(SvRV(TOPs));
2061 SETi((left > right) - (left < right));
2065 #ifdef PERL_PRESERVE_IVUV
2066 /* Fortunately it seems NaN isn't IOK */
2069 SvIV_please(TOPm1s);
2070 if (SvIOK(TOPm1s)) {
2071 bool leftuvok = SvUOK(TOPm1s);
2072 bool rightuvok = SvUOK(TOPs);
2074 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2075 IV leftiv = SvIVX(TOPm1s);
2076 IV rightiv = SvIVX(TOPs);
2078 if (leftiv > rightiv)
2080 else if (leftiv < rightiv)
2084 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2085 UV leftuv = SvUVX(TOPm1s);
2086 UV rightuv = SvUVX(TOPs);
2088 if (leftuv > rightuv)
2090 else if (leftuv < rightuv)
2094 } else if (leftuvok) { /* ## UV <=> IV ## */
2098 rightiv = SvIVX(TOPs);
2100 /* As (a) is a UV, it's >=0, so it cannot be < */
2103 leftuv = SvUVX(TOPm1s);
2104 if (leftuv > (UV)rightiv) {
2106 } else if (leftuv < (UV)rightiv) {
2112 } else { /* ## IV <=> UV ## */
2116 leftiv = SvIVX(TOPm1s);
2118 /* As (b) is a UV, it's >=0, so it must be < */
2121 rightuv = SvUVX(TOPs);
2122 if ((UV)leftiv > rightuv) {
2124 } else if ((UV)leftiv < rightuv) {
2142 if (Perl_isnan(left) || Perl_isnan(right)) {
2146 value = (left > right) - (left < right);
2150 else if (left < right)
2152 else if (left > right)
2166 dSP; tryAMAGICbinSET(slt,0);
2169 int cmp = (IN_LOCALE_RUNTIME
2170 ? sv_cmp_locale(left, right)
2171 : sv_cmp(left, right));
2172 SETs(boolSV(cmp < 0));
2179 dSP; tryAMAGICbinSET(sgt,0);
2182 int cmp = (IN_LOCALE_RUNTIME
2183 ? sv_cmp_locale(left, right)
2184 : sv_cmp(left, right));
2185 SETs(boolSV(cmp > 0));
2192 dSP; tryAMAGICbinSET(sle,0);
2195 int cmp = (IN_LOCALE_RUNTIME
2196 ? sv_cmp_locale(left, right)
2197 : sv_cmp(left, right));
2198 SETs(boolSV(cmp <= 0));
2205 dSP; tryAMAGICbinSET(sge,0);
2208 int cmp = (IN_LOCALE_RUNTIME
2209 ? sv_cmp_locale(left, right)
2210 : sv_cmp(left, right));
2211 SETs(boolSV(cmp >= 0));
2218 dSP; tryAMAGICbinSET(seq,0);
2221 SETs(boolSV(sv_eq(left, right)));
2228 dSP; tryAMAGICbinSET(sne,0);
2231 SETs(boolSV(!sv_eq(left, right)));
2238 dSP; dTARGET; tryAMAGICbin(scmp,0);
2241 int cmp = (IN_LOCALE_RUNTIME
2242 ? sv_cmp_locale(left, right)
2243 : sv_cmp(left, right));
2251 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2254 if (SvGMAGICAL(left)) mg_get(left);
2255 if (SvGMAGICAL(right)) mg_get(right);
2256 if (SvNIOKp(left) || SvNIOKp(right)) {
2257 if (PL_op->op_private & HINT_INTEGER) {
2258 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2262 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2267 do_vop(PL_op->op_type, TARG, left, right);
2276 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2279 if (SvGMAGICAL(left)) mg_get(left);
2280 if (SvGMAGICAL(right)) mg_get(right);
2281 if (SvNIOKp(left) || SvNIOKp(right)) {
2282 if (PL_op->op_private & HINT_INTEGER) {
2283 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2287 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2292 do_vop(PL_op->op_type, TARG, left, right);
2301 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2304 if (SvGMAGICAL(left)) mg_get(left);
2305 if (SvGMAGICAL(right)) mg_get(right);
2306 if (SvNIOKp(left) || SvNIOKp(right)) {
2307 if (PL_op->op_private & HINT_INTEGER) {
2308 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2312 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2317 do_vop(PL_op->op_type, TARG, left, right);
2326 dSP; dTARGET; tryAMAGICun(neg);
2329 int flags = SvFLAGS(sv);
2332 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2333 /* It's publicly an integer, or privately an integer-not-float */
2336 if (SvIVX(sv) == IV_MIN) {
2337 /* 2s complement assumption. */
2338 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2341 else if (SvUVX(sv) <= IV_MAX) {
2346 else if (SvIVX(sv) != IV_MIN) {
2350 #ifdef PERL_PRESERVE_IVUV
2359 else if (SvPOKp(sv)) {
2361 char *s = SvPV(sv, len);
2362 if (isIDFIRST(*s)) {
2363 sv_setpvn(TARG, "-", 1);
2366 else if (*s == '+' || *s == '-') {
2368 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2370 else if (DO_UTF8(sv)) {
2373 goto oops_its_an_int;
2375 sv_setnv(TARG, -SvNV(sv));
2377 sv_setpvn(TARG, "-", 1);
2384 goto oops_its_an_int;
2385 sv_setnv(TARG, -SvNV(sv));
2397 dSP; tryAMAGICunSET(not);
2398 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2404 dSP; dTARGET; tryAMAGICun(compl);
2410 if (PL_op->op_private & HINT_INTEGER) {
2411 IV i = ~SvIV_nomg(sv);
2415 UV u = ~SvUV_nomg(sv);
2424 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2425 sv_setsv_nomg(TARG, sv);
2426 tmps = (U8*)SvPV_force(TARG, len);
2429 /* Calculate exact length, let's not estimate. */
2438 while (tmps < send) {
2439 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2440 tmps += UTF8SKIP(tmps);
2441 targlen += UNISKIP(~c);
2447 /* Now rewind strings and write them. */
2451 Newz(0, result, targlen + 1, U8);
2452 while (tmps < send) {
2453 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2454 tmps += UTF8SKIP(tmps);
2455 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2459 sv_setpvn(TARG, (char*)result, targlen);
2463 Newz(0, result, nchar + 1, U8);
2464 while (tmps < send) {
2465 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2466 tmps += UTF8SKIP(tmps);
2471 sv_setpvn(TARG, (char*)result, nchar);
2480 register long *tmpl;
2481 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2484 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2489 for ( ; anum > 0; anum--, tmps++)
2498 /* integer versions of some of the above */
2502 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2505 SETi( left * right );
2512 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2516 DIE(aTHX_ "Illegal division by zero");
2517 value = POPi / value;
2526 /* This is the vanilla old i_modulo. */
2527 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2531 DIE(aTHX_ "Illegal modulus zero");
2532 SETi( left % right );
2537 #if defined(__GLIBC__) && IVSIZE == 8
2541 /* This is the i_modulo with the workaround for the _moddi3 bug
2542 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2543 * See below for pp_i_modulo. */
2544 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2548 DIE(aTHX_ "Illegal modulus zero");
2549 SETi( left % PERL_ABS(right) );
2557 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2561 DIE(aTHX_ "Illegal modulus zero");
2562 /* The assumption is to use hereafter the old vanilla version... */
2564 PL_ppaddr[OP_I_MODULO] =
2565 &Perl_pp_i_modulo_0;
2566 /* .. but if we have glibc, we might have a buggy _moddi3
2567 * (at least glicb 2.2.5 is known to have this bug), in other
2568 * words our integer modulus with negative quad as the second
2569 * argument might be broken. Test for this and re-patch the
2570 * opcode dispatch table if that is the case, remembering to
2571 * also apply the workaround so that this first round works
2572 * right, too. See [perl #9402] for more information. */
2573 #if defined(__GLIBC__) && IVSIZE == 8
2577 /* Cannot do this check with inlined IV constants since
2578 * that seems to work correctly even with the buggy glibc. */
2580 /* Yikes, we have the bug.
2581 * Patch in the workaround version. */
2583 PL_ppaddr[OP_I_MODULO] =
2584 &Perl_pp_i_modulo_1;
2585 /* Make certain we work right this time, too. */
2586 right = PERL_ABS(right);
2590 SETi( left % right );
2597 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2600 SETi( left + right );
2607 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2610 SETi( left - right );
2617 dSP; tryAMAGICbinSET(lt,0);
2620 SETs(boolSV(left < right));
2627 dSP; tryAMAGICbinSET(gt,0);
2630 SETs(boolSV(left > right));
2637 dSP; tryAMAGICbinSET(le,0);
2640 SETs(boolSV(left <= right));
2647 dSP; tryAMAGICbinSET(ge,0);
2650 SETs(boolSV(left >= right));
2657 dSP; tryAMAGICbinSET(eq,0);
2660 SETs(boolSV(left == right));
2667 dSP; tryAMAGICbinSET(ne,0);
2670 SETs(boolSV(left != right));
2677 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2684 else if (left < right)
2695 dSP; dTARGET; tryAMAGICun(neg);
2700 /* High falutin' math. */
2704 dSP; dTARGET; tryAMAGICbin(atan2,0);
2707 SETn(Perl_atan2(left, right));
2714 dSP; dTARGET; tryAMAGICun(sin);
2718 value = Perl_sin(value);
2726 dSP; dTARGET; tryAMAGICun(cos);
2730 value = Perl_cos(value);
2736 /* Support Configure command-line overrides for rand() functions.
2737 After 5.005, perhaps we should replace this by Configure support
2738 for drand48(), random(), or rand(). For 5.005, though, maintain
2739 compatibility by calling rand() but allow the user to override it.
2740 See INSTALL for details. --Andy Dougherty 15 July 1998
2742 /* Now it's after 5.005, and Configure supports drand48() and random(),
2743 in addition to rand(). So the overrides should not be needed any more.
2744 --Jarkko Hietaniemi 27 September 1998
2747 #ifndef HAS_DRAND48_PROTO
2748 extern double drand48 (void);
2761 if (!PL_srand_called) {
2762 (void)seedDrand01((Rand_seed_t)seed());
2763 PL_srand_called = TRUE;
2778 (void)seedDrand01((Rand_seed_t)anum);
2779 PL_srand_called = TRUE;
2786 dSP; dTARGET; tryAMAGICun(exp);
2790 value = Perl_exp(value);
2798 dSP; dTARGET; tryAMAGICun(log);
2803 SET_NUMERIC_STANDARD();
2804 DIE(aTHX_ "Can't take log of %"NVgf, value);
2806 value = Perl_log(value);
2814 dSP; dTARGET; tryAMAGICun(sqrt);
2819 SET_NUMERIC_STANDARD();
2820 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2822 value = Perl_sqrt(value);
2830 dSP; dTARGET; tryAMAGICun(int);
2833 IV iv = TOPi; /* attempt to convert to IV if possible. */
2834 /* XXX it's arguable that compiler casting to IV might be subtly
2835 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2836 else preferring IV has introduced a subtle behaviour change bug. OTOH
2837 relying on floating point to be accurate is a bug. */
2841 else if (SvIOK(TOPs)) {
2850 if (value < (NV)UV_MAX + 0.5) {
2853 SETn(Perl_floor(value));
2857 if (value > (NV)IV_MIN - 0.5) {
2860 SETn(Perl_ceil(value));
2870 dSP; dTARGET; tryAMAGICun(abs);
2872 /* This will cache the NV value if string isn't actually integer */
2877 else if (SvIOK(TOPs)) {
2878 /* IVX is precise */
2880 SETu(TOPu); /* force it to be numeric only */
2888 /* 2s complement assumption. Also, not really needed as
2889 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2909 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2915 tmps = (SvPVx_const(sv, len));
2917 /* If Unicode, try to downgrade
2918 * If not possible, croak. */
2919 SV* tsv = sv_2mortal(newSVsv(sv));
2922 sv_utf8_downgrade(tsv, FALSE);
2925 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2926 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2939 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2945 tmps = (SvPVx_const(sv, len));
2947 /* If Unicode, try to downgrade
2948 * If not possible, croak. */
2949 SV* tsv = sv_2mortal(newSVsv(sv));
2952 sv_utf8_downgrade(tsv, FALSE);
2955 while (*tmps && len && isSPACE(*tmps))
2960 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2961 else if (*tmps == 'b')
2962 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2964 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2966 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2983 SETi(sv_len_utf8(sv));
2999 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3001 const I32 arybase = PL_curcop->cop_arybase;
3003 const char *repl = 0;
3005 int num_args = PL_op->op_private & 7;
3006 bool repl_need_utf8_upgrade = FALSE;
3007 bool repl_is_utf8 = FALSE;
3009 SvTAINTED_off(TARG); /* decontaminate */
3010 SvUTF8_off(TARG); /* decontaminate */
3014 repl = SvPV_const(repl_sv, repl_len);
3015 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3025 sv_utf8_upgrade(sv);
3027 else if (DO_UTF8(sv))
3028 repl_need_utf8_upgrade = TRUE;
3030 tmps = SvPV_const(sv, curlen);
3032 utf8_curlen = sv_len_utf8(sv);
3033 if (utf8_curlen == curlen)
3036 curlen = utf8_curlen;
3041 if (pos >= arybase) {
3059 else if (len >= 0) {
3061 if (rem > (I32)curlen)
3076 Perl_croak(aTHX_ "substr outside of string");
3077 if (ckWARN(WARN_SUBSTR))
3078 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3085 sv_pos_u2b(sv, &pos, &rem);
3087 /* we either return a PV or an LV. If the TARG hasn't been used
3088 * before, or is of that type, reuse it; otherwise use a mortal
3089 * instead. Note that LVs can have an extended lifetime, so also
3090 * dont reuse if refcount > 1 (bug #20933) */
3091 if (SvTYPE(TARG) > SVt_NULL) {
3092 if ( (SvTYPE(TARG) == SVt_PVLV)
3093 ? (!lvalue || SvREFCNT(TARG) > 1)
3096 TARG = sv_newmortal();
3100 sv_setpvn(TARG, tmps, rem);
3101 #ifdef USE_LOCALE_COLLATE
3102 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3107 SV* repl_sv_copy = NULL;
3109 if (repl_need_utf8_upgrade) {
3110 repl_sv_copy = newSVsv(repl_sv);
3111 sv_utf8_upgrade(repl_sv_copy);
3112 repl = SvPV(repl_sv_copy, repl_len);
3113 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3115 sv_insert(sv, pos, rem, repl, repl_len);
3119 SvREFCNT_dec(repl_sv_copy);
3121 else if (lvalue) { /* it's an lvalue! */
3122 if (!SvGMAGICAL(sv)) {
3126 if (ckWARN(WARN_SUBSTR))
3127 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3128 "Attempt to use reference as lvalue in substr");
3130 if (SvOK(sv)) /* is it defined ? */
3131 (void)SvPOK_only_UTF8(sv);
3133 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3136 if (SvTYPE(TARG) < SVt_PVLV) {
3137 sv_upgrade(TARG, SVt_PVLV);
3138 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3144 if (LvTARG(TARG) != sv) {
3146 SvREFCNT_dec(LvTARG(TARG));
3147 LvTARG(TARG) = SvREFCNT_inc(sv);
3149 LvTARGOFF(TARG) = upos;
3150 LvTARGLEN(TARG) = urem;
3154 PUSHs(TARG); /* avoid SvSETMAGIC here */
3161 register IV size = POPi;
3162 register IV offset = POPi;
3163 register SV *src = POPs;
3164 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3166 SvTAINTED_off(TARG); /* decontaminate */
3167 if (lvalue) { /* it's an lvalue! */
3168 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3169 TARG = sv_newmortal();
3170 if (SvTYPE(TARG) < SVt_PVLV) {
3171 sv_upgrade(TARG, SVt_PVLV);
3172 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3175 if (LvTARG(TARG) != src) {
3177 SvREFCNT_dec(LvTARG(TARG));
3178 LvTARG(TARG) = SvREFCNT_inc(src);
3180 LvTARGOFF(TARG) = offset;
3181 LvTARGLEN(TARG) = size;
3184 sv_setuv(TARG, do_vecget(src, offset, size));
3200 I32 arybase = PL_curcop->cop_arybase;
3207 offset = POPi - arybase;
3210 big_utf8 = DO_UTF8(big);
3211 little_utf8 = DO_UTF8(little);
3212 if (big_utf8 ^ little_utf8) {
3213 /* One needs to be upgraded. */
3214 SV *bytes = little_utf8 ? big : little;
3216 const char *p = SvPV_const(bytes, len);
3218 temp = newSVpvn(p, len);
3221 sv_recode_to_utf8(temp, PL_encoding);
3223 sv_utf8_upgrade(temp);
3232 if (big_utf8 && offset > 0)
3233 sv_pos_u2b(big, &offset, 0);
3234 tmps = SvPV_const(big, biglen);
3237 else if (offset > (I32)biglen)
3239 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3240 (unsigned char*)tmps + biglen, little, 0)))
3243 retval = tmps2 - tmps;
3244 if (retval > 0 && big_utf8)
3245 sv_pos_b2u(big, &retval);
3248 PUSHi(retval + arybase);
3264 I32 arybase = PL_curcop->cop_arybase;
3272 big_utf8 = DO_UTF8(big);
3273 little_utf8 = DO_UTF8(little);
3274 if (big_utf8 ^ little_utf8) {
3275 /* One needs to be upgraded. */
3276 SV *bytes = little_utf8 ? big : little;
3278 const char *p = SvPV_const(bytes, len);
3280 temp = newSVpvn(p, len);
3283 sv_recode_to_utf8(temp, PL_encoding);
3285 sv_utf8_upgrade(temp);
3294 tmps2 = SvPV_const(little, llen);
3295 tmps = SvPV_const(big, blen);
3300 if (offset > 0 && big_utf8)
3301 sv_pos_u2b(big, &offset, 0);
3302 offset = offset - arybase + llen;
3306 else if (offset > (I32)blen)
3308 if (!(tmps2 = rninstr(tmps, tmps + offset,
3309 tmps2, tmps2 + llen)))
3312 retval = tmps2 - tmps;
3313 if (retval > 0 && big_utf8)
3314 sv_pos_b2u(big, &retval);
3317 PUSHi(retval + arybase);
3323 dSP; dMARK; dORIGMARK; dTARGET;
3324 do_sprintf(TARG, SP-MARK, MARK+1);
3325 TAINT_IF(SvTAINTED(TARG));
3326 if (DO_UTF8(*(MARK+1)))
3338 const U8 *s = (U8*)SvPVx_const(argsv, len);
3341 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3342 tmpsv = sv_2mortal(newSVsv(argsv));
3343 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3347 XPUSHu(DO_UTF8(argsv) ?
3348 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3360 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3362 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3364 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3366 (void) POPs; /* Ignore the argument value. */
3367 value = UNICODE_REPLACEMENT;
3373 SvUPGRADE(TARG,SVt_PV);
3375 if (value > 255 && !IN_BYTES) {
3376 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3377 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3378 SvCUR_set(TARG, tmps - SvPVX(TARG));
3380 (void)SvPOK_only(TARG);
3389 *tmps++ = (char)value;
3391 (void)SvPOK_only(TARG);
3392 if (PL_encoding && !IN_BYTES) {
3393 sv_recode_to_utf8(TARG, PL_encoding);
3395 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3396 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3400 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3401 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3416 const char *tmps = SvPV_const(left, len);
3418 if (DO_UTF8(left)) {
3419 /* If Unicode, try to downgrade.
3420 * If not possible, croak.
3421 * Yes, we made this up. */
3422 SV* tsv = sv_2mortal(newSVsv(left));
3425 sv_utf8_downgrade(tsv, FALSE);
3428 # ifdef USE_ITHREADS
3430 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3431 /* This should be threadsafe because in ithreads there is only
3432 * one thread per interpreter. If this would not be true,
3433 * we would need a mutex to protect this malloc. */
3434 PL_reentrant_buffer->_crypt_struct_buffer =
3435 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3436 #if defined(__GLIBC__) || defined(__EMX__)
3437 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3438 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3439 /* work around glibc-2.2.5 bug */
3440 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3444 # endif /* HAS_CRYPT_R */
3445 # endif /* USE_ITHREADS */
3447 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3449 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3455 "The crypt() function is unimplemented due to excessive paranoia.");
3468 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3469 UTF8_IS_START(*s)) {
3470 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3474 utf8_to_uvchr(s, &ulen);
3475 toTITLE_utf8(s, tmpbuf, &tculen);
3476 utf8_to_uvchr(tmpbuf, 0);
3478 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3480 /* slen is the byte length of the whole SV.
3481 * ulen is the byte length of the original Unicode character
3482 * stored as UTF-8 at s.
3483 * tculen is the byte length of the freshly titlecased
3484 * Unicode character stored as UTF-8 at tmpbuf.
3485 * We first set the result to be the titlecased character,
3486 * and then append the rest of the SV data. */
3487 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3489 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3494 s = (U8*)SvPV_force_nomg(sv, slen);
3495 Copy(tmpbuf, s, tculen, U8);
3500 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3502 SvUTF8_off(TARG); /* decontaminate */
3503 sv_setsv_nomg(TARG, sv);
3507 s1 = (U8*)SvPV_force_nomg(sv, slen);
3509 if (IN_LOCALE_RUNTIME) {
3512 *s1 = toUPPER_LC(*s1);
3531 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3532 UTF8_IS_START(*s)) {
3534 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3538 toLOWER_utf8(s, tmpbuf, &ulen);
3539 uv = utf8_to_uvchr(tmpbuf, 0);
3540 tend = uvchr_to_utf8(tmpbuf, uv);
3542 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3544 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3546 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3551 s = (U8*)SvPV_force_nomg(sv, slen);
3552 Copy(tmpbuf, s, ulen, U8);
3557 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3559 SvUTF8_off(TARG); /* decontaminate */
3560 sv_setsv_nomg(TARG, sv);
3564 s1 = (U8*)SvPV_force_nomg(sv, slen);
3566 if (IN_LOCALE_RUNTIME) {
3569 *s1 = toLOWER_LC(*s1);
3592 U8 tmpbuf[UTF8_MAXBYTES+1];
3594 s = (const U8*)SvPV_nomg_const(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));
3636 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3638 SvUTF8_off(TARG); /* decontaminate */
3639 sv_setsv_nomg(TARG, sv);
3643 s = (U8*)SvPV_force_nomg(sv, len);
3645 const register U8 *send = s + len;
3647 if (IN_LOCALE_RUNTIME) {
3650 for (; s < send; s++)
3651 *s = toUPPER_LC(*s);
3654 for (; s < send; s++)
3676 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3678 s = (const U8*)SvPV_nomg_const(sv,len);
3680 SvUTF8_off(TARG); /* decontaminate */
3681 sv_setpvn(TARG, "", 0);
3685 STRLEN min = len + 1;
3687 SvUPGRADE(TARG, SVt_PV);
3689 (void)SvPOK_only(TARG);
3690 d = (U8*)SvPVX(TARG);
3693 STRLEN u = UTF8SKIP(s);
3694 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3696 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3697 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3699 * Now if the sigma is NOT followed by
3700 * /$ignorable_sequence$cased_letter/;
3701 * and it IS preceded by
3702 * /$cased_letter$ignorable_sequence/;
3703 * where $ignorable_sequence is
3704 * [\x{2010}\x{AD}\p{Mn}]*
3705 * and $cased_letter is
3706 * [\p{Ll}\p{Lo}\p{Lt}]
3707 * then it should be mapped to 0x03C2,
3708 * (GREEK SMALL LETTER FINAL SIGMA),
3709 * instead of staying 0x03A3.
3710 * "should be": in other words,
3711 * this is not implemented yet.
3712 * See lib/unicore/SpecialCasing.txt.
3715 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3716 /* If the eventually required minimum size outgrows
3717 * the available space, we need to grow. */
3718 UV o = d - (U8*)SvPVX(TARG);
3720 /* If someone lowercases one million U+0130s we
3721 * SvGROW() one million times. Or we could try
3722 * guessing how much to allocate without allocating.
3723 * too much. Such is life. */
3725 d = (U8*)SvPVX(TARG) + o;
3727 Copy(tmpbuf, d, ulen, U8);
3733 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3739 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3741 SvUTF8_off(TARG); /* decontaminate */
3742 sv_setsv_nomg(TARG, sv);
3747 s = (U8*)SvPV_force_nomg(sv, len);
3749 register U8 *send = s + len;
3751 if (IN_LOCALE_RUNTIME) {
3754 for (; s < send; s++)
3755 *s = toLOWER_LC(*s);
3758 for (; s < send; s++)
3772 const register char *s = SvPV_const(sv,len);
3775 SvUTF8_off(TARG); /* decontaminate */
3777 SvUPGRADE(TARG, SVt_PV);
3778 SvGROW(TARG, (len * 2) + 1);
3782 if (UTF8_IS_CONTINUED(*s)) {
3783 STRLEN ulen = UTF8SKIP(s);
3807 SvCUR_set(TARG, d - SvPVX(TARG));
3808 (void)SvPOK_only_UTF8(TARG);
3811 sv_setpvn(TARG, s, len);
3813 if (SvSMAGICAL(TARG))
3822 dSP; dMARK; dORIGMARK;
3824 register AV* av = (AV*)POPs;
3825 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3826 I32 arybase = PL_curcop->cop_arybase;
3829 if (SvTYPE(av) == SVt_PVAV) {
3830 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3832 for (svp = MARK + 1; svp <= SP; svp++) {
3837 if (max > AvMAX(av))
3840 while (++MARK <= SP) {
3841 elem = SvIVx(*MARK);
3845 svp = av_fetch(av, elem, lval);
3847 if (!svp || *svp == &PL_sv_undef)
3848 DIE(aTHX_ PL_no_aelem, elem);
3849 if (PL_op->op_private & OPpLVAL_INTRO)
3850 save_aelem(av, elem, svp);
3852 *MARK = svp ? *svp : &PL_sv_undef;
3855 if (GIMME != G_ARRAY) {
3857 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3863 /* Associative arrays. */
3868 HV *hash = (HV*)POPs;
3870 const I32 gimme = GIMME_V;
3873 /* might clobber stack_sp */
3874 entry = hv_iternext(hash);
3879 SV* sv = hv_iterkeysv(entry);
3880 PUSHs(sv); /* won't clobber stack_sp */
3881 if (gimme == G_ARRAY) {
3884 /* might clobber stack_sp */
3885 val = hv_iterval(hash, entry);
3890 else if (gimme == G_SCALAR)
3909 const I32 gimme = GIMME_V;
3910 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3914 if (PL_op->op_private & OPpSLICE) {
3918 hvtype = SvTYPE(hv);
3919 if (hvtype == SVt_PVHV) { /* hash element */
3920 while (++MARK <= SP) {
3921 sv = hv_delete_ent(hv, *MARK, discard, 0);
3922 *MARK = sv ? sv : &PL_sv_undef;
3925 else if (hvtype == SVt_PVAV) { /* array element */
3926 if (PL_op->op_flags & OPf_SPECIAL) {
3927 while (++MARK <= SP) {
3928 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3929 *MARK = sv ? sv : &PL_sv_undef;
3934 DIE(aTHX_ "Not a HASH reference");
3937 else if (gimme == G_SCALAR) {
3942 *++MARK = &PL_sv_undef;
3949 if (SvTYPE(hv) == SVt_PVHV)
3950 sv = hv_delete_ent(hv, keysv, discard, 0);
3951 else if (SvTYPE(hv) == SVt_PVAV) {
3952 if (PL_op->op_flags & OPf_SPECIAL)
3953 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3955 DIE(aTHX_ "panic: avhv_delete no longer supported");
3958 DIE(aTHX_ "Not a HASH reference");
3973 if (PL_op->op_private & OPpEXISTS_SUB) {
3977 cv = sv_2cv(sv, &hv, &gv, FALSE);
3980 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3986 if (SvTYPE(hv) == SVt_PVHV) {
3987 if (hv_exists_ent(hv, tmpsv, 0))
3990 else if (SvTYPE(hv) == SVt_PVAV) {
3991 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3992 if (av_exists((AV*)hv, SvIV(tmpsv)))
3997 DIE(aTHX_ "Not a HASH reference");
4004 dSP; dMARK; dORIGMARK;
4005 register HV *hv = (HV*)POPs;
4006 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4007 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
4008 bool other_magic = FALSE;
4014 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4015 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4016 /* Try to preserve the existenceness of a tied hash
4017 * element by using EXISTS and DELETE if possible.
4018 * Fallback to FETCH and STORE otherwise */
4019 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4020 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4021 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4024 while (++MARK <= SP) {
4028 bool preeminent = FALSE;
4031 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4032 hv_exists_ent(hv, keysv, 0);
4035 he = hv_fetch_ent(hv, keysv, lval, 0);
4036 svp = he ? &HeVAL(he) : 0;
4039 if (!svp || *svp == &PL_sv_undef) {
4040 DIE(aTHX_ PL_no_helem_sv, keysv);
4044 save_helem(hv, keysv, svp);
4047 const char *key = SvPV_const(keysv, keylen);
4048 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4052 *MARK = svp ? *svp : &PL_sv_undef;
4054 if (GIMME != G_ARRAY) {
4056 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4062 /* List operators. */
4067 if (GIMME != G_ARRAY) {
4069 *MARK = *SP; /* unwanted list, return last item */
4071 *MARK = &PL_sv_undef;
4080 SV **lastrelem = PL_stack_sp;
4081 SV **lastlelem = PL_stack_base + POPMARK;
4082 SV **firstlelem = PL_stack_base + POPMARK + 1;
4083 register SV **firstrelem = lastlelem + 1;
4084 I32 arybase = PL_curcop->cop_arybase;
4085 I32 lval = PL_op->op_flags & OPf_MOD;
4086 I32 is_something_there = lval;
4088 register I32 max = lastrelem - lastlelem;
4089 register SV **lelem;
4092 if (GIMME != G_ARRAY) {
4093 ix = SvIVx(*lastlelem);
4098 if (ix < 0 || ix >= max)
4099 *firstlelem = &PL_sv_undef;
4101 *firstlelem = firstrelem[ix];
4107 SP = firstlelem - 1;
4111 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4117 if (ix < 0 || ix >= max)
4118 *lelem = &PL_sv_undef;
4120 is_something_there = TRUE;
4121 if (!(*lelem = firstrelem[ix]))
4122 *lelem = &PL_sv_undef;
4125 if (is_something_there)
4128 SP = firstlelem - 1;
4134 dSP; dMARK; dORIGMARK;
4135 I32 items = SP - MARK;
4136 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4137 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4144 dSP; dMARK; dORIGMARK;
4145 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4149 SV *val = NEWSV(46, 0);
4151 sv_setsv(val, *++MARK);
4152 else if (ckWARN(WARN_MISC))
4153 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4154 (void)hv_store_ent(hv,key,val,0);
4163 dVAR; dSP; dMARK; dORIGMARK;
4164 register AV *ary = (AV*)*++MARK;
4168 register I32 offset;
4169 register I32 length;
4176 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4177 *MARK-- = SvTIED_obj((SV*)ary, mg);
4181 call_method("SPLICE",GIMME_V);
4190 offset = i = SvIVx(*MARK);
4192 offset += AvFILLp(ary) + 1;
4194 offset -= PL_curcop->cop_arybase;
4196 DIE(aTHX_ PL_no_aelem, i);
4198 length = SvIVx(*MARK++);
4200 length += AvFILLp(ary) - offset + 1;
4206 length = AvMAX(ary) + 1; /* close enough to infinity */
4210 length = AvMAX(ary) + 1;
4212 if (offset > AvFILLp(ary) + 1) {
4213 if (ckWARN(WARN_MISC))
4214 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4215 offset = AvFILLp(ary) + 1;
4217 after = AvFILLp(ary) + 1 - (offset + length);
4218 if (after < 0) { /* not that much array */
4219 length += after; /* offset+length now in array */
4225 /* At this point, MARK .. SP-1 is our new LIST */
4228 diff = newlen - length;
4229 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4232 /* make new elements SVs now: avoid problems if they're from the array */
4233 for (dst = MARK, i = newlen; i; i--) {
4235 *dst++ = newSVsv(h);
4238 if (diff < 0) { /* shrinking the area */
4240 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4241 Copy(MARK, tmparyval, newlen, SV*);
4244 MARK = ORIGMARK + 1;
4245 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4246 MEXTEND(MARK, length);
4247 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4249 EXTEND_MORTAL(length);
4250 for (i = length, dst = MARK; i; i--) {
4251 sv_2mortal(*dst); /* free them eventualy */
4258 *MARK = AvARRAY(ary)[offset+length-1];
4261 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4262 SvREFCNT_dec(*dst++); /* free them now */
4265 AvFILLp(ary) += diff;
4267 /* pull up or down? */
4269 if (offset < after) { /* easier to pull up */
4270 if (offset) { /* esp. if nothing to pull */
4271 src = &AvARRAY(ary)[offset-1];
4272 dst = src - diff; /* diff is negative */
4273 for (i = offset; i > 0; i--) /* can't trust Copy */
4277 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4281 if (after) { /* anything to pull down? */
4282 src = AvARRAY(ary) + offset + length;
4283 dst = src + diff; /* diff is negative */
4284 Move(src, dst, after, SV*);
4286 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4287 /* avoid later double free */
4291 dst[--i] = &PL_sv_undef;
4294 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4295 Safefree(tmparyval);
4298 else { /* no, expanding (or same) */
4300 New(452, tmparyval, length, SV*); /* so remember deletion */
4301 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4304 if (diff > 0) { /* expanding */
4306 /* push up or down? */
4308 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4312 Move(src, dst, offset, SV*);
4314 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4316 AvFILLp(ary) += diff;
4319 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4320 av_extend(ary, AvFILLp(ary) + diff);
4321 AvFILLp(ary) += diff;
4324 dst = AvARRAY(ary) + AvFILLp(ary);
4326 for (i = after; i; i--) {
4334 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4337 MARK = ORIGMARK + 1;
4338 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4340 Copy(tmparyval, MARK, length, SV*);
4342 EXTEND_MORTAL(length);
4343 for (i = length, dst = MARK; i; i--) {
4344 sv_2mortal(*dst); /* free them eventualy */
4348 Safefree(tmparyval);
4352 else if (length--) {
4353 *MARK = tmparyval[length];
4356 while (length-- > 0)
4357 SvREFCNT_dec(tmparyval[length]);
4359 Safefree(tmparyval);
4362 *MARK = &PL_sv_undef;
4370 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4371 register AV *ary = (AV*)*++MARK;
4372 register SV *sv = &PL_sv_undef;
4375 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4376 *MARK-- = SvTIED_obj((SV*)ary, mg);
4380 call_method("PUSH",G_SCALAR|G_DISCARD);
4385 /* Why no pre-extend of ary here ? */
4386 for (++MARK; MARK <= SP; MARK++) {
4389 sv_setsv(sv, *MARK);
4394 PUSHi( AvFILL(ary) + 1 );
4402 SV *sv = av_pop(av);
4404 (void)sv_2mortal(sv);
4413 SV *sv = av_shift(av);
4418 (void)sv_2mortal(sv);
4425 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4426 register AV *ary = (AV*)*++MARK;
4431 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4432 *MARK-- = SvTIED_obj((SV*)ary, mg);
4436 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4441 av_unshift(ary, SP - MARK);
4443 sv = newSVsv(*++MARK);
4444 (void)av_store(ary, i++, sv);
4448 PUSHi( AvFILL(ary) + 1 );
4458 if (GIMME == G_ARRAY) {
4465 /* safe as long as stack cannot get extended in the above */
4470 register char *down;
4476 SvUTF8_off(TARG); /* decontaminate */
4478 do_join(TARG, &PL_sv_no, MARK, SP);
4480 sv_setsv(TARG, (SP > MARK)
4482 : (padoff_du = find_rundefsvoffset(),
4483 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4484 ? DEFSV : PAD_SVl(padoff_du)));
4485 up = SvPV_force(TARG, len);
4487 if (DO_UTF8(TARG)) { /* first reverse each character */
4488 U8* s = (U8*)SvPVX(TARG);
4489 U8* send = (U8*)(s + len);
4491 if (UTF8_IS_INVARIANT(*s)) {
4496 if (!utf8_to_uvchr(s, 0))
4500 down = (char*)(s - 1);
4501 /* reverse this character */
4505 *down-- = (char)tmp;
4511 down = SvPVX(TARG) + len - 1;
4515 *down-- = (char)tmp;
4517 (void)SvPOK_only_UTF8(TARG);
4529 register IV limit = POPi; /* note, negative is forever */
4532 register const char *s = SvPV_const(sv, len);
4533 bool do_utf8 = DO_UTF8(sv);
4534 const char *strend = s + len;
4536 register REGEXP *rx;
4538 register const char *m;
4540 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4541 I32 maxiters = slen + 10;
4544 I32 origlimit = limit;
4547 const I32 gimme = GIMME_V;
4548 const I32 oldsave = PL_savestack_ix;
4549 I32 make_mortal = 1;
4551 MAGIC *mg = (MAGIC *) NULL;
4554 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4559 DIE(aTHX_ "panic: pp_split");
4562 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4563 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4565 RX_MATCH_UTF8_set(rx, do_utf8);
4567 if (pm->op_pmreplroot) {
4569 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4571 ary = GvAVn((GV*)pm->op_pmreplroot);
4574 else if (gimme != G_ARRAY)
4575 ary = GvAVn(PL_defgv);
4578 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4584 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4586 XPUSHs(SvTIED_obj((SV*)ary, mg));
4592 for (i = AvFILLp(ary); i >= 0; i--)
4593 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4595 /* temporarily switch stacks */
4596 SAVESWITCHSTACK(PL_curstack, ary);
4600 base = SP - PL_stack_base;
4602 if (pm->op_pmflags & PMf_SKIPWHITE) {
4603 if (pm->op_pmflags & PMf_LOCALE) {
4604 while (isSPACE_LC(*s))
4612 if (pm->op_pmflags & PMf_MULTILINE) {
4617 limit = maxiters + 2;
4618 if (pm->op_pmflags & PMf_WHITE) {
4621 while (m < strend &&
4622 !((pm->op_pmflags & PMf_LOCALE)
4623 ? isSPACE_LC(*m) : isSPACE(*m)))
4628 dstr = newSVpvn(s, m-s);
4632 (void)SvUTF8_on(dstr);
4636 while (s < strend &&
4637 ((pm->op_pmflags & PMf_LOCALE)
4638 ? isSPACE_LC(*s) : isSPACE(*s)))
4642 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4645 for (m = s; m < strend && *m != '\n'; m++) ;
4649 dstr = newSVpvn(s, m-s);
4653 (void)SvUTF8_on(dstr);
4658 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4659 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4660 && (rx->reganch & ROPT_CHECK_ALL)
4661 && !(rx->reganch & ROPT_ANCH)) {
4662 int tail = (rx->reganch & RE_INTUIT_TAIL);
4663 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4666 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4667 char c = *SvPV_nolen_const(csv);
4670 for (m = s; m < strend && *m != c; m++) ;
4673 dstr = newSVpvn(s, m-s);
4677 (void)SvUTF8_on(dstr);
4679 /* The rx->minlen is in characters but we want to step
4680 * s ahead by bytes. */
4682 s = (char*)utf8_hop((U8*)m, len);
4684 s = m + len; /* Fake \n at the end */
4688 while (s < strend && --limit &&
4689 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4690 csv, multiline ? FBMrf_MULTILINE : 0)) )
4692 dstr = newSVpvn(s, m-s);
4696 (void)SvUTF8_on(dstr);
4698 /* The rx->minlen is in characters but we want to step
4699 * s ahead by bytes. */
4701 s = (char*)utf8_hop((U8*)m, len);
4703 s = m + len; /* Fake \n at the end */
4708 maxiters += slen * rx->nparens;
4709 while (s < strend && --limit)
4712 i = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4717 TAINT_IF(RX_MATCH_TAINTED(rx));
4718 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4723 strend = s + (strend - m);
4725 m = rx->startp[0] + orig;
4726 dstr = newSVpvn(s, m-s);
4730 (void)SvUTF8_on(dstr);
4733 for (i = 1; i <= (I32)rx->nparens; i++) {
4734 s = rx->startp[i] + orig;
4735 m = rx->endp[i] + orig;
4737 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4738 parens that didn't match -- they should be set to
4739 undef, not the empty string */
4740 if (m >= orig && s >= orig) {
4741 dstr = newSVpvn(s, m-s);
4744 dstr = &PL_sv_undef; /* undef, not "" */
4748 (void)SvUTF8_on(dstr);
4752 s = rx->endp[0] + orig;
4756 iters = (SP - PL_stack_base) - base;
4757 if (iters > maxiters)
4758 DIE(aTHX_ "Split loop");
4760 /* keep field after final delim? */
4761 if (s < strend || (iters && origlimit)) {
4762 STRLEN l = strend - s;
4763 dstr = newSVpvn(s, l);
4767 (void)SvUTF8_on(dstr);
4771 else if (!origlimit) {
4772 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4773 if (TOPs && !make_mortal)
4776 *SP-- = &PL_sv_undef;
4781 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4785 if (SvSMAGICAL(ary)) {
4790 if (gimme == G_ARRAY) {
4792 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4800 call_method("PUSH",G_SCALAR|G_DISCARD);
4803 if (gimme == G_ARRAY) {
4804 /* EXTEND should not be needed - we just popped them */
4806 for (i=0; i < iters; i++) {
4807 SV **svp = av_fetch(ary, i, FALSE);
4808 PUSHs((svp) ? *svp : &PL_sv_undef);
4815 if (gimme == G_ARRAY)
4830 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4831 || SvTYPE(retsv) == SVt_PVCV) {
4832 retsv = refto(retsv);
4840 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4845 * c-indentation-style: bsd
4847 * indent-tabs-mode: t
4850 * ex: set ts=8 sts=4 sw=4 noet: