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 const char *s = SvPV_const(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 = (SvPV_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);
2923 tmps = SvPV_const(tsv, len);
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 = (SvPV_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);
2953 tmps = SvPV_const(tsv, len);
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_const(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)) {
3124 SvPV_force_nolen(sv);
3125 if (ckWARN(WARN_SUBSTR))
3126 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3127 "Attempt to use reference as lvalue in substr");
3129 if (SvOK(sv)) /* is it defined ? */
3130 (void)SvPOK_only_UTF8(sv);
3132 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3135 if (SvTYPE(TARG) < SVt_PVLV) {
3136 sv_upgrade(TARG, SVt_PVLV);
3137 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3143 if (LvTARG(TARG) != sv) {
3145 SvREFCNT_dec(LvTARG(TARG));
3146 LvTARG(TARG) = SvREFCNT_inc(sv);
3148 LvTARGOFF(TARG) = upos;
3149 LvTARGLEN(TARG) = urem;
3153 PUSHs(TARG); /* avoid SvSETMAGIC here */
3160 register IV size = POPi;
3161 register IV offset = POPi;
3162 register SV *src = POPs;
3163 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3165 SvTAINTED_off(TARG); /* decontaminate */
3166 if (lvalue) { /* it's an lvalue! */
3167 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3168 TARG = sv_newmortal();
3169 if (SvTYPE(TARG) < SVt_PVLV) {
3170 sv_upgrade(TARG, SVt_PVLV);
3171 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3174 if (LvTARG(TARG) != src) {
3176 SvREFCNT_dec(LvTARG(TARG));
3177 LvTARG(TARG) = SvREFCNT_inc(src);
3179 LvTARGOFF(TARG) = offset;
3180 LvTARGLEN(TARG) = size;
3183 sv_setuv(TARG, do_vecget(src, offset, size));
3199 I32 arybase = PL_curcop->cop_arybase;
3206 offset = POPi - arybase;
3209 big_utf8 = DO_UTF8(big);
3210 little_utf8 = DO_UTF8(little);
3211 if (big_utf8 ^ little_utf8) {
3212 /* One needs to be upgraded. */
3213 SV *bytes = little_utf8 ? big : little;
3215 const char *p = SvPV_const(bytes, len);
3217 temp = newSVpvn(p, len);
3220 sv_recode_to_utf8(temp, PL_encoding);
3222 sv_utf8_upgrade(temp);
3231 if (big_utf8 && offset > 0)
3232 sv_pos_u2b(big, &offset, 0);
3233 tmps = SvPV_const(big, biglen);
3236 else if (offset > (I32)biglen)
3238 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3239 (unsigned char*)tmps + biglen, little, 0)))
3242 retval = tmps2 - tmps;
3243 if (retval > 0 && big_utf8)
3244 sv_pos_b2u(big, &retval);
3247 PUSHi(retval + arybase);
3263 I32 arybase = PL_curcop->cop_arybase;
3271 big_utf8 = DO_UTF8(big);
3272 little_utf8 = DO_UTF8(little);
3273 if (big_utf8 ^ little_utf8) {
3274 /* One needs to be upgraded. */
3275 SV *bytes = little_utf8 ? big : little;
3277 const char *p = SvPV_const(bytes, len);
3279 temp = newSVpvn(p, len);
3282 sv_recode_to_utf8(temp, PL_encoding);
3284 sv_utf8_upgrade(temp);
3293 tmps2 = SvPV_const(little, llen);
3294 tmps = SvPV_const(big, blen);
3299 if (offset > 0 && big_utf8)
3300 sv_pos_u2b(big, &offset, 0);
3301 offset = offset - arybase + llen;
3305 else if (offset > (I32)blen)
3307 if (!(tmps2 = rninstr(tmps, tmps + offset,
3308 tmps2, tmps2 + llen)))
3311 retval = tmps2 - tmps;
3312 if (retval > 0 && big_utf8)
3313 sv_pos_b2u(big, &retval);
3316 PUSHi(retval + arybase);
3322 dSP; dMARK; dORIGMARK; dTARGET;
3323 do_sprintf(TARG, SP-MARK, MARK+1);
3324 TAINT_IF(SvTAINTED(TARG));
3325 if (DO_UTF8(*(MARK+1)))
3337 const U8 *s = (U8*)SvPV_const(argsv, len);
3340 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3341 tmpsv = sv_2mortal(newSVsv(argsv));
3342 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3346 XPUSHu(DO_UTF8(argsv) ?
3347 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3359 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3361 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3363 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3365 (void) POPs; /* Ignore the argument value. */
3366 value = UNICODE_REPLACEMENT;
3372 SvUPGRADE(TARG,SVt_PV);
3374 if (value > 255 && !IN_BYTES) {
3375 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3376 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3377 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3379 (void)SvPOK_only(TARG);
3388 *tmps++ = (char)value;
3390 (void)SvPOK_only(TARG);
3391 if (PL_encoding && !IN_BYTES) {
3392 sv_recode_to_utf8(TARG, PL_encoding);
3394 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3395 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3399 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3400 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3415 const char *tmps = SvPV_const(left, len);
3417 if (DO_UTF8(left)) {
3418 /* If Unicode, try to downgrade.
3419 * If not possible, croak.
3420 * Yes, we made this up. */
3421 SV* tsv = sv_2mortal(newSVsv(left));
3424 sv_utf8_downgrade(tsv, FALSE);
3425 tmps = SvPV_const(tsv, len);
3427 # ifdef USE_ITHREADS
3429 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3430 /* This should be threadsafe because in ithreads there is only
3431 * one thread per interpreter. If this would not be true,
3432 * we would need a mutex to protect this malloc. */
3433 PL_reentrant_buffer->_crypt_struct_buffer =
3434 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3435 #if defined(__GLIBC__) || defined(__EMX__)
3436 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3437 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3438 /* work around glibc-2.2.5 bug */
3439 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3443 # endif /* HAS_CRYPT_R */
3444 # endif /* USE_ITHREADS */
3446 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3448 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3454 "The crypt() function is unimplemented due to excessive paranoia.");
3467 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3468 UTF8_IS_START(*s)) {
3469 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3473 utf8_to_uvchr(s, &ulen);
3474 toTITLE_utf8(s, tmpbuf, &tculen);
3475 utf8_to_uvchr(tmpbuf, 0);
3477 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3479 /* slen is the byte length of the whole SV.
3480 * ulen is the byte length of the original Unicode character
3481 * stored as UTF-8 at s.
3482 * tculen is the byte length of the freshly titlecased
3483 * Unicode character stored as UTF-8 at tmpbuf.
3484 * We first set the result to be the titlecased character,
3485 * and then append the rest of the SV data. */
3486 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3488 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3493 s = (U8*)SvPV_force_nomg(sv, slen);
3494 Copy(tmpbuf, s, tculen, U8);
3499 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3501 SvUTF8_off(TARG); /* decontaminate */
3502 sv_setsv_nomg(TARG, sv);
3506 s1 = (U8*)SvPV_force_nomg(sv, slen);
3508 if (IN_LOCALE_RUNTIME) {
3511 *s1 = toUPPER_LC(*s1);
3530 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3531 UTF8_IS_START(*s)) {
3533 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3537 toLOWER_utf8(s, tmpbuf, &ulen);
3538 uv = utf8_to_uvchr(tmpbuf, 0);
3539 tend = uvchr_to_utf8(tmpbuf, uv);
3541 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3543 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3545 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3550 s = (U8*)SvPV_force_nomg(sv, slen);
3551 Copy(tmpbuf, s, ulen, U8);
3556 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3558 SvUTF8_off(TARG); /* decontaminate */
3559 sv_setsv_nomg(TARG, sv);
3563 s1 = (U8*)SvPV_force_nomg(sv, slen);
3565 if (IN_LOCALE_RUNTIME) {
3568 *s1 = toLOWER_LC(*s1);
3591 U8 tmpbuf[UTF8_MAXBYTES+1];
3593 s = (const U8*)SvPV_nomg_const(sv,len);
3595 SvUTF8_off(TARG); /* decontaminate */
3596 sv_setpvn(TARG, "", 0);
3600 STRLEN min = len + 1;
3602 SvUPGRADE(TARG, SVt_PV);
3604 (void)SvPOK_only(TARG);
3605 d = (U8*)SvPVX(TARG);
3608 STRLEN u = UTF8SKIP(s);
3610 toUPPER_utf8(s, tmpbuf, &ulen);
3611 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3612 /* If the eventually required minimum size outgrows
3613 * the available space, we need to grow. */
3614 UV o = d - (U8*)SvPVX_const(TARG);
3616 /* If someone uppercases one million U+03B0s we
3617 * SvGROW() one million times. Or we could try
3618 * guessing how much to allocate without allocating
3619 * too much. Such is life. */
3621 d = (U8*)SvPVX(TARG) + o;
3623 Copy(tmpbuf, d, ulen, U8);
3629 SvCUR_set(TARG, d - (U8*)SvPVX_const(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 const 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 = (const U8*)SvPV_nomg_const(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_const(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_const(TARG));
3738 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3740 SvUTF8_off(TARG); /* decontaminate */
3741 sv_setsv_nomg(TARG, sv);
3746 s = (U8*)SvPV_force_nomg(sv, len);
3748 register U8 *send = s + len;
3750 if (IN_LOCALE_RUNTIME) {
3753 for (; s < send; s++)
3754 *s = toLOWER_LC(*s);
3757 for (; s < send; s++)
3771 const register char *s = SvPV_const(sv,len);
3774 SvUTF8_off(TARG); /* decontaminate */
3776 SvUPGRADE(TARG, SVt_PV);
3777 SvGROW(TARG, (len * 2) + 1);
3781 if (UTF8_IS_CONTINUED(*s)) {
3782 STRLEN ulen = UTF8SKIP(s);
3806 SvCUR_set(TARG, d - SvPVX_const(TARG));
3807 (void)SvPOK_only_UTF8(TARG);
3810 sv_setpvn(TARG, s, len);
3812 if (SvSMAGICAL(TARG))
3821 dSP; dMARK; dORIGMARK;
3823 register AV* av = (AV*)POPs;
3824 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3825 I32 arybase = PL_curcop->cop_arybase;
3828 if (SvTYPE(av) == SVt_PVAV) {
3829 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3831 for (svp = MARK + 1; svp <= SP; svp++) {
3836 if (max > AvMAX(av))
3839 while (++MARK <= SP) {
3840 elem = SvIVx(*MARK);
3844 svp = av_fetch(av, elem, lval);
3846 if (!svp || *svp == &PL_sv_undef)
3847 DIE(aTHX_ PL_no_aelem, elem);
3848 if (PL_op->op_private & OPpLVAL_INTRO)
3849 save_aelem(av, elem, svp);
3851 *MARK = svp ? *svp : &PL_sv_undef;
3854 if (GIMME != G_ARRAY) {
3856 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3862 /* Associative arrays. */
3867 HV *hash = (HV*)POPs;
3869 const I32 gimme = GIMME_V;
3872 /* might clobber stack_sp */
3873 entry = hv_iternext(hash);
3878 SV* sv = hv_iterkeysv(entry);
3879 PUSHs(sv); /* won't clobber stack_sp */
3880 if (gimme == G_ARRAY) {
3883 /* might clobber stack_sp */
3884 val = hv_iterval(hash, entry);
3889 else if (gimme == G_SCALAR)
3908 const I32 gimme = GIMME_V;
3909 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3913 if (PL_op->op_private & OPpSLICE) {
3917 hvtype = SvTYPE(hv);
3918 if (hvtype == SVt_PVHV) { /* hash element */
3919 while (++MARK <= SP) {
3920 sv = hv_delete_ent(hv, *MARK, discard, 0);
3921 *MARK = sv ? sv : &PL_sv_undef;
3924 else if (hvtype == SVt_PVAV) { /* array element */
3925 if (PL_op->op_flags & OPf_SPECIAL) {
3926 while (++MARK <= SP) {
3927 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3928 *MARK = sv ? sv : &PL_sv_undef;
3933 DIE(aTHX_ "Not a HASH reference");
3936 else if (gimme == G_SCALAR) {
3941 *++MARK = &PL_sv_undef;
3948 if (SvTYPE(hv) == SVt_PVHV)
3949 sv = hv_delete_ent(hv, keysv, discard, 0);
3950 else if (SvTYPE(hv) == SVt_PVAV) {
3951 if (PL_op->op_flags & OPf_SPECIAL)
3952 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3954 DIE(aTHX_ "panic: avhv_delete no longer supported");
3957 DIE(aTHX_ "Not a HASH reference");
3972 if (PL_op->op_private & OPpEXISTS_SUB) {
3976 cv = sv_2cv(sv, &hv, &gv, FALSE);
3979 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3985 if (SvTYPE(hv) == SVt_PVHV) {
3986 if (hv_exists_ent(hv, tmpsv, 0))
3989 else if (SvTYPE(hv) == SVt_PVAV) {
3990 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3991 if (av_exists((AV*)hv, SvIV(tmpsv)))
3996 DIE(aTHX_ "Not a HASH reference");
4003 dSP; dMARK; dORIGMARK;
4004 register HV *hv = (HV*)POPs;
4005 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4006 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
4007 bool other_magic = FALSE;
4013 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4014 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4015 /* Try to preserve the existenceness of a tied hash
4016 * element by using EXISTS and DELETE if possible.
4017 * Fallback to FETCH and STORE otherwise */
4018 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4019 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4020 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4023 while (++MARK <= SP) {
4027 bool preeminent = FALSE;
4030 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4031 hv_exists_ent(hv, keysv, 0);
4034 he = hv_fetch_ent(hv, keysv, lval, 0);
4035 svp = he ? &HeVAL(he) : 0;
4038 if (!svp || *svp == &PL_sv_undef) {
4039 DIE(aTHX_ PL_no_helem_sv, keysv);
4043 save_helem(hv, keysv, svp);
4046 const char *key = SvPV_const(keysv, keylen);
4047 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4051 *MARK = svp ? *svp : &PL_sv_undef;
4053 if (GIMME != G_ARRAY) {
4055 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4061 /* List operators. */
4066 if (GIMME != G_ARRAY) {
4068 *MARK = *SP; /* unwanted list, return last item */
4070 *MARK = &PL_sv_undef;
4079 SV **lastrelem = PL_stack_sp;
4080 SV **lastlelem = PL_stack_base + POPMARK;
4081 SV **firstlelem = PL_stack_base + POPMARK + 1;
4082 register SV **firstrelem = lastlelem + 1;
4083 I32 arybase = PL_curcop->cop_arybase;
4084 I32 lval = PL_op->op_flags & OPf_MOD;
4085 I32 is_something_there = lval;
4087 register I32 max = lastrelem - lastlelem;
4088 register SV **lelem;
4091 if (GIMME != G_ARRAY) {
4092 ix = SvIVx(*lastlelem);
4097 if (ix < 0 || ix >= max)
4098 *firstlelem = &PL_sv_undef;
4100 *firstlelem = firstrelem[ix];
4106 SP = firstlelem - 1;
4110 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4116 if (ix < 0 || ix >= max)
4117 *lelem = &PL_sv_undef;
4119 is_something_there = TRUE;
4120 if (!(*lelem = firstrelem[ix]))
4121 *lelem = &PL_sv_undef;
4124 if (is_something_there)
4127 SP = firstlelem - 1;
4133 dSP; dMARK; dORIGMARK;
4134 I32 items = SP - MARK;
4135 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4136 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4143 dSP; dMARK; dORIGMARK;
4144 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4148 SV *val = NEWSV(46, 0);
4150 sv_setsv(val, *++MARK);
4151 else if (ckWARN(WARN_MISC))
4152 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4153 (void)hv_store_ent(hv,key,val,0);
4162 dVAR; dSP; dMARK; dORIGMARK;
4163 register AV *ary = (AV*)*++MARK;
4167 register I32 offset;
4168 register I32 length;
4175 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4176 *MARK-- = SvTIED_obj((SV*)ary, mg);
4180 call_method("SPLICE",GIMME_V);
4189 offset = i = SvIVx(*MARK);
4191 offset += AvFILLp(ary) + 1;
4193 offset -= PL_curcop->cop_arybase;
4195 DIE(aTHX_ PL_no_aelem, i);
4197 length = SvIVx(*MARK++);
4199 length += AvFILLp(ary) - offset + 1;
4205 length = AvMAX(ary) + 1; /* close enough to infinity */
4209 length = AvMAX(ary) + 1;
4211 if (offset > AvFILLp(ary) + 1) {
4212 if (ckWARN(WARN_MISC))
4213 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4214 offset = AvFILLp(ary) + 1;
4216 after = AvFILLp(ary) + 1 - (offset + length);
4217 if (after < 0) { /* not that much array */
4218 length += after; /* offset+length now in array */
4224 /* At this point, MARK .. SP-1 is our new LIST */
4227 diff = newlen - length;
4228 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4231 /* make new elements SVs now: avoid problems if they're from the array */
4232 for (dst = MARK, i = newlen; i; i--) {
4234 *dst++ = newSVsv(h);
4237 if (diff < 0) { /* shrinking the area */
4239 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4240 Copy(MARK, tmparyval, newlen, SV*);
4243 MARK = ORIGMARK + 1;
4244 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4245 MEXTEND(MARK, length);
4246 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4248 EXTEND_MORTAL(length);
4249 for (i = length, dst = MARK; i; i--) {
4250 sv_2mortal(*dst); /* free them eventualy */
4257 *MARK = AvARRAY(ary)[offset+length-1];
4260 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4261 SvREFCNT_dec(*dst++); /* free them now */
4264 AvFILLp(ary) += diff;
4266 /* pull up or down? */
4268 if (offset < after) { /* easier to pull up */
4269 if (offset) { /* esp. if nothing to pull */
4270 src = &AvARRAY(ary)[offset-1];
4271 dst = src - diff; /* diff is negative */
4272 for (i = offset; i > 0; i--) /* can't trust Copy */
4276 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4280 if (after) { /* anything to pull down? */
4281 src = AvARRAY(ary) + offset + length;
4282 dst = src + diff; /* diff is negative */
4283 Move(src, dst, after, SV*);
4285 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4286 /* avoid later double free */
4290 dst[--i] = &PL_sv_undef;
4293 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4294 Safefree(tmparyval);
4297 else { /* no, expanding (or same) */
4299 New(452, tmparyval, length, SV*); /* so remember deletion */
4300 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4303 if (diff > 0) { /* expanding */
4305 /* push up or down? */
4307 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4311 Move(src, dst, offset, SV*);
4313 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4315 AvFILLp(ary) += diff;
4318 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4319 av_extend(ary, AvFILLp(ary) + diff);
4320 AvFILLp(ary) += diff;
4323 dst = AvARRAY(ary) + AvFILLp(ary);
4325 for (i = after; i; i--) {
4333 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4336 MARK = ORIGMARK + 1;
4337 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4339 Copy(tmparyval, MARK, length, SV*);
4341 EXTEND_MORTAL(length);
4342 for (i = length, dst = MARK; i; i--) {
4343 sv_2mortal(*dst); /* free them eventualy */
4347 Safefree(tmparyval);
4351 else if (length--) {
4352 *MARK = tmparyval[length];
4355 while (length-- > 0)
4356 SvREFCNT_dec(tmparyval[length]);
4358 Safefree(tmparyval);
4361 *MARK = &PL_sv_undef;
4369 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4370 register AV *ary = (AV*)*++MARK;
4371 register SV *sv = &PL_sv_undef;
4374 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4375 *MARK-- = SvTIED_obj((SV*)ary, mg);
4379 call_method("PUSH",G_SCALAR|G_DISCARD);
4384 /* Why no pre-extend of ary here ? */
4385 for (++MARK; MARK <= SP; MARK++) {
4388 sv_setsv(sv, *MARK);
4393 PUSHi( AvFILL(ary) + 1 );
4401 SV *sv = av_pop(av);
4403 (void)sv_2mortal(sv);
4412 SV *sv = av_shift(av);
4417 (void)sv_2mortal(sv);
4424 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4425 register AV *ary = (AV*)*++MARK;
4430 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4431 *MARK-- = SvTIED_obj((SV*)ary, mg);
4435 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4440 av_unshift(ary, SP - MARK);
4442 sv = newSVsv(*++MARK);
4443 (void)av_store(ary, i++, sv);
4447 PUSHi( AvFILL(ary) + 1 );
4457 if (GIMME == G_ARRAY) {
4464 /* safe as long as stack cannot get extended in the above */
4469 register char *down;
4475 SvUTF8_off(TARG); /* decontaminate */
4477 do_join(TARG, &PL_sv_no, MARK, SP);
4479 sv_setsv(TARG, (SP > MARK)
4481 : (padoff_du = find_rundefsvoffset(),
4482 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4483 ? DEFSV : PAD_SVl(padoff_du)));
4484 up = SvPV_force(TARG, len);
4486 if (DO_UTF8(TARG)) { /* first reverse each character */
4487 U8* s = (U8*)SvPVX(TARG);
4488 const U8* send = (U8*)(s + len);
4490 if (UTF8_IS_INVARIANT(*s)) {
4495 if (!utf8_to_uvchr(s, 0))
4499 down = (char*)(s - 1);
4500 /* reverse this character */
4504 *down-- = (char)tmp;
4510 down = SvPVX(TARG) + len - 1;
4514 *down-- = (char)tmp;
4516 (void)SvPOK_only_UTF8(TARG);
4528 register IV limit = POPi; /* note, negative is forever */
4531 register const char *s = SvPV_const(sv, len);
4532 bool do_utf8 = DO_UTF8(sv);
4533 const char *strend = s + len;
4535 register REGEXP *rx;
4537 register const char *m;
4539 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4540 I32 maxiters = slen + 10;
4543 I32 origlimit = limit;
4546 const I32 gimme = GIMME_V;
4547 const I32 oldsave = PL_savestack_ix;
4548 I32 make_mortal = 1;
4550 MAGIC *mg = (MAGIC *) NULL;
4553 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4558 DIE(aTHX_ "panic: pp_split");
4561 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4562 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4564 RX_MATCH_UTF8_set(rx, do_utf8);
4566 if (pm->op_pmreplroot) {
4568 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4570 ary = GvAVn((GV*)pm->op_pmreplroot);
4573 else if (gimme != G_ARRAY)
4574 ary = GvAVn(PL_defgv);
4577 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4583 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4585 XPUSHs(SvTIED_obj((SV*)ary, mg));
4591 for (i = AvFILLp(ary); i >= 0; i--)
4592 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4594 /* temporarily switch stacks */
4595 SAVESWITCHSTACK(PL_curstack, ary);
4599 base = SP - PL_stack_base;
4601 if (pm->op_pmflags & PMf_SKIPWHITE) {
4602 if (pm->op_pmflags & PMf_LOCALE) {
4603 while (isSPACE_LC(*s))
4611 if (pm->op_pmflags & PMf_MULTILINE) {
4616 limit = maxiters + 2;
4617 if (pm->op_pmflags & PMf_WHITE) {
4620 while (m < strend &&
4621 !((pm->op_pmflags & PMf_LOCALE)
4622 ? isSPACE_LC(*m) : isSPACE(*m)))
4627 dstr = newSVpvn(s, m-s);
4631 (void)SvUTF8_on(dstr);
4635 while (s < strend &&
4636 ((pm->op_pmflags & PMf_LOCALE)
4637 ? isSPACE_LC(*s) : isSPACE(*s)))
4641 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4643 for (m = s; m < strend && *m != '\n'; m++)
4648 dstr = newSVpvn(s, m-s);
4652 (void)SvUTF8_on(dstr);
4657 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4658 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4659 && (rx->reganch & ROPT_CHECK_ALL)
4660 && !(rx->reganch & ROPT_ANCH)) {
4661 int tail = (rx->reganch & RE_INTUIT_TAIL);
4662 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4665 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4666 char c = *SvPV_nolen_const(csv);
4668 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, (char*)s, (char*)strend, (char*)orig, 1 ,
4716 TAINT_IF(RX_MATCH_TAINTED(rx));
4717 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4722 strend = s + (strend - m);
4724 m = rx->startp[0] + orig;
4725 dstr = newSVpvn(s, m-s);
4729 (void)SvUTF8_on(dstr);
4732 for (i = 1; i <= (I32)rx->nparens; i++) {
4733 s = rx->startp[i] + orig;
4734 m = rx->endp[i] + orig;
4736 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4737 parens that didn't match -- they should be set to
4738 undef, not the empty string */
4739 if (m >= orig && s >= orig) {
4740 dstr = newSVpvn(s, m-s);
4743 dstr = &PL_sv_undef; /* undef, not "" */
4747 (void)SvUTF8_on(dstr);
4751 s = rx->endp[0] + orig;
4755 iters = (SP - PL_stack_base) - base;
4756 if (iters > maxiters)
4757 DIE(aTHX_ "Split loop");
4759 /* keep field after final delim? */
4760 if (s < strend || (iters && origlimit)) {
4761 STRLEN l = strend - s;
4762 dstr = newSVpvn(s, l);
4766 (void)SvUTF8_on(dstr);
4770 else if (!origlimit) {
4771 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4772 if (TOPs && !make_mortal)
4775 *SP-- = &PL_sv_undef;
4780 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4784 if (SvSMAGICAL(ary)) {
4789 if (gimme == G_ARRAY) {
4791 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4799 call_method("PUSH",G_SCALAR|G_DISCARD);
4802 if (gimme == G_ARRAY) {
4803 /* EXTEND should not be needed - we just popped them */
4805 for (i=0; i < iters; i++) {
4806 SV **svp = av_fetch(ary, i, FALSE);
4807 PUSHs((svp) ? *svp : &PL_sv_undef);
4814 if (gimme == G_ARRAY)
4829 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4830 || SvTYPE(retsv) == SVt_PVCV) {
4831 retsv = refto(retsv);
4839 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4844 * c-indentation-style: bsd
4846 * indent-tabs-mode: t
4849 * ex: set ts=8 sts=4 sw=4 noet: