3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
51 if (GIMME_V == G_SCALAR)
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
70 if (PL_op->op_flags & OPf_REF) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL((AV*)TARG) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV **svp = av_fetch((AV*)TARG, i, FALSE);
87 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
91 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
95 else if (gimme == G_SCALAR) {
96 SV* sv = sv_newmortal();
97 const I32 maxarg = AvFILL((AV*)TARG) + 1;
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
112 if (PL_op->op_flags & OPf_REF)
115 if (GIMME == G_SCALAR)
116 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
120 if (gimme == G_ARRAY) {
123 else if (gimme == G_SCALAR) {
124 SV* sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
132 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
143 tryAMAGICunDEREF(to_gv);
146 if (SvTYPE(sv) == SVt_PVIO) {
147 GV *gv = (GV*) sv_newmortal();
148 gv_init(gv, 0, "", 0, 0);
149 GvIOp(gv) = (IO *)sv;
150 (void)SvREFCNT_inc(sv);
153 else if (SvTYPE(sv) != SVt_PVGV)
154 DIE(aTHX_ "Not a GLOB reference");
157 if (SvTYPE(sv) != SVt_PVGV) {
158 if (SvGMAGICAL(sv)) {
163 if (!SvOK(sv) && sv != &PL_sv_undef) {
164 /* If this is a 'my' scalar and flag is set then vivify
168 Perl_croak(aTHX_ PL_no_modify);
169 if (PL_op->op_private & OPpDEREF) {
171 if (cUNOP->op_targ) {
173 SV *namesv = PAD_SV(cUNOP->op_targ);
174 const char *name = SvPV(namesv, len);
175 gv = (GV*)NEWSV(0,0);
176 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
179 const char *name = CopSTASHPV(PL_curcop);
182 if (SvTYPE(sv) < SVt_RV)
183 sv_upgrade(sv, SVt_RV);
184 if (SvPVX_const(sv)) {
189 SvRV_set(sv, (SV*)gv);
194 if (PL_op->op_flags & OPf_REF ||
195 PL_op->op_private & HINT_STRICT_REFS)
196 DIE(aTHX_ PL_no_usym, "a symbol");
197 if (ckWARN(WARN_UNINITIALIZED))
201 if ((PL_op->op_flags & OPf_SPECIAL) &&
202 !(PL_op->op_flags & OPf_MOD))
204 SV * temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
206 && (!is_gv_magical_sv(sv,0)
207 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
213 if (PL_op->op_private & HINT_STRICT_REFS)
214 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
215 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
219 if (PL_op->op_private & OPpLVAL_INTRO)
220 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
232 tryAMAGICunDEREF(to_sv);
235 switch (SvTYPE(sv)) {
239 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
252 if (PL_op->op_flags & OPf_REF ||
253 PL_op->op_private & HINT_STRICT_REFS)
254 DIE(aTHX_ PL_no_usym, "a SCALAR");
255 if (ckWARN(WARN_UNINITIALIZED))
259 if ((PL_op->op_flags & OPf_SPECIAL) &&
260 !(PL_op->op_flags & OPf_MOD))
262 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
264 && (!is_gv_magical_sv(sv, 0)
265 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
271 if (PL_op->op_private & HINT_STRICT_REFS)
272 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
273 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
278 if (PL_op->op_flags & OPf_MOD) {
279 if (PL_op->op_private & OPpLVAL_INTRO) {
280 if (cUNOP->op_first->op_type == OP_NULL)
281 sv = save_scalar((GV*)TOPs);
283 sv = save_scalar(gv);
285 Perl_croak(aTHX_ PL_no_localize_ref);
287 else if (PL_op->op_private & OPpDEREF)
288 vivify_ref(sv, PL_op->op_private & OPpDEREF);
298 SV **sv = Perl_av_arylen_p(aTHX_ (AV*)av);
301 sv_upgrade(*sv, SVt_PVMG);
302 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
310 dSP; dTARGET; dPOPss;
312 if (PL_op->op_flags & OPf_MOD || LVRET) {
313 if (SvTYPE(TARG) < SVt_PVLV) {
314 sv_upgrade(TARG, SVt_PVLV);
315 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
319 if (LvTARG(TARG) != sv) {
321 SvREFCNT_dec(LvTARG(TARG));
322 LvTARG(TARG) = SvREFCNT_inc(sv);
324 PUSHs(TARG); /* no SvSETMAGIC */
330 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
331 mg = mg_find(sv, PERL_MAGIC_regex_global);
332 if (mg && mg->mg_len >= 0) {
336 PUSHi(i + PL_curcop->cop_arybase);
350 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
351 /* (But not in defined().) */
352 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
355 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
356 if ((PL_op->op_private & OPpLVAL_INTRO)) {
357 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
360 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
364 cv = (CV*)&PL_sv_undef;
378 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
379 const char *s = SvPVX_const(TOPs);
380 if (strnEQ(s, "CORE::", 6)) {
381 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
382 if (code < 0) { /* Overridable. */
383 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
384 int i = 0, n = 0, seen_question = 0;
386 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
388 if (code == -KEY_chop || code == -KEY_chomp
389 || code == -KEY_exec || code == -KEY_system)
391 while (i < MAXO) { /* The slow way. */
392 if (strEQ(s + 6, PL_op_name[i])
393 || strEQ(s + 6, PL_op_desc[i]))
399 goto nonesuch; /* Should not happen... */
401 oa = PL_opargs[i] >> OASHIFT;
403 if (oa & OA_OPTIONAL && !seen_question) {
407 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
408 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
409 /* But globs are already references (kinda) */
410 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
414 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
418 ret = sv_2mortal(newSVpvn(str, n - 1));
420 else if (code) /* Non-Overridable */
422 else { /* None such */
424 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
428 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
430 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
439 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
441 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
457 if (GIMME != G_ARRAY) {
461 *MARK = &PL_sv_undef;
462 *MARK = refto(*MARK);
466 EXTEND_MORTAL(SP - MARK);
468 *MARK = refto(*MARK);
473 S_refto(pTHX_ SV *sv)
477 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
480 if (!(sv = LvTARG(sv)))
483 (void)SvREFCNT_inc(sv);
485 else if (SvTYPE(sv) == SVt_PVAV) {
486 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
489 (void)SvREFCNT_inc(sv);
491 else if (SvPADTMP(sv) && !IS_PADGV(sv))
495 (void)SvREFCNT_inc(sv);
498 sv_upgrade(rv, SVt_RV);
512 if (sv && SvGMAGICAL(sv))
515 if (!sv || !SvROK(sv))
519 pv = sv_reftype(sv,TRUE);
520 PUSHp(pv, strlen(pv));
530 stash = CopSTASH(PL_curcop);
536 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
537 Perl_croak(aTHX_ "Attempt to bless into a reference");
539 if (ckWARN(WARN_MISC) && len == 0)
540 Perl_warner(aTHX_ packWARN(WARN_MISC),
541 "Explicit blessing to '' (assuming package main)");
542 stash = gv_stashpvn(ptr, len, TRUE);
545 (void)sv_bless(TOPs, stash);
559 elem = SvPV(sv, n_a);
564 /* elem will always be NUL terminated. */
565 const char *elem2 = elem + 1;
568 if (strEQ(elem2, "RRAY"))
569 tmpRef = (SV*)GvAV(gv);
572 if (strEQ(elem2, "ODE"))
573 tmpRef = (SV*)GvCVu(gv);
576 if (strEQ(elem2, "ILEHANDLE")) {
577 /* finally deprecated in 5.8.0 */
578 deprecate("*glob{FILEHANDLE}");
579 tmpRef = (SV*)GvIOp(gv);
582 if (strEQ(elem2, "ORMAT"))
583 tmpRef = (SV*)GvFORM(gv);
586 if (strEQ(elem2, "LOB"))
590 if (strEQ(elem2, "ASH"))
591 tmpRef = (SV*)GvHV(gv);
594 if (*elem2 == 'O' && !elem[2])
595 tmpRef = (SV*)GvIOp(gv);
598 if (strEQ(elem2, "AME"))
599 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
602 if (strEQ(elem2, "ACKAGE")) {
603 const char *name = HvNAME_get(GvSTASH(gv));
604 sv = newSVpvn(name ? name : "__ANON__",
605 name ? HvNAMELEN_get(GvSTASH(gv)) : 8);
609 if (strEQ(elem2, "CALAR"))
624 /* Pattern matching */
629 register unsigned char *s;
632 register I32 *sfirst;
636 if (sv == PL_lastscream) {
642 SvSCREAM_off(PL_lastscream);
643 SvREFCNT_dec(PL_lastscream);
645 PL_lastscream = SvREFCNT_inc(sv);
648 s = (unsigned char*)(SvPV(sv, len));
652 if (pos > PL_maxscream) {
653 if (PL_maxscream < 0) {
654 PL_maxscream = pos + 80;
655 New(301, PL_screamfirst, 256, I32);
656 New(302, PL_screamnext, PL_maxscream, I32);
659 PL_maxscream = pos + pos / 4;
660 Renew(PL_screamnext, PL_maxscream, I32);
664 sfirst = PL_screamfirst;
665 snext = PL_screamnext;
667 if (!sfirst || !snext)
668 DIE(aTHX_ "do_study: out of memory");
670 for (ch = 256; ch; --ch)
677 snext[pos] = sfirst[ch] - pos;
684 /* piggyback on m//g magic */
685 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
694 if (PL_op->op_flags & OPf_STACKED)
696 else if (PL_op->op_private & OPpTARGET_MY)
702 TARG = sv_newmortal();
707 /* Lvalue operators. */
719 dSP; dMARK; dTARGET; dORIGMARK;
721 do_chop(TARG, *++MARK);
730 SETi(do_chomp(TOPs));
737 register I32 count = 0;
740 count += do_chomp(POPs);
751 if (!sv || !SvANY(sv))
753 switch (SvTYPE(sv)) {
755 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
756 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
760 if (HvARRAY(sv) || SvGMAGICAL(sv)
761 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
765 if (CvROOT(sv) || CvXSUB(sv))
782 if (!PL_op->op_private) {
791 SV_CHECK_THINKFIRST_COW_DROP(sv);
793 switch (SvTYPE(sv)) {
803 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
804 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
805 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
809 /* let user-undef'd sub keep its identity */
810 GV* gv = CvGV((CV*)sv);
817 SvSetMagicSV(sv, &PL_sv_undef);
821 Newz(602, gp, 1, GP);
822 GvGP(sv) = gp_ref(gp);
823 GvSV(sv) = NEWSV(72,0);
824 GvLINE(sv) = CopLINE(PL_curcop);
830 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
832 SvPV_set(sv, Nullch);
845 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
846 DIE(aTHX_ PL_no_modify);
847 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
848 && SvIVX(TOPs) != IV_MIN)
850 SvIV_set(TOPs, SvIVX(TOPs) - 1);
851 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
862 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
863 DIE(aTHX_ PL_no_modify);
864 sv_setsv(TARG, TOPs);
865 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
866 && SvIVX(TOPs) != IV_MAX)
868 SvIV_set(TOPs, SvIVX(TOPs) + 1);
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
874 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
884 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
885 DIE(aTHX_ PL_no_modify);
886 sv_setsv(TARG, TOPs);
887 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
888 && SvIVX(TOPs) != IV_MIN)
890 SvIV_set(TOPs, SvIVX(TOPs) - 1);
891 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
900 /* Ordinary operators. */
905 #ifdef PERL_PRESERVE_IVUV
908 tryAMAGICbin(pow,opASSIGN);
909 #ifdef PERL_PRESERVE_IVUV
910 /* For integer to integer power, we do the calculation by hand wherever
911 we're sure it is safe; otherwise we call pow() and try to convert to
912 integer afterwards. */
916 bool baseuok = SvUOK(TOPm1s);
920 baseuv = SvUVX(TOPm1s);
922 IV iv = SvIVX(TOPm1s);
925 baseuok = TRUE; /* effectively it's a UV now */
927 baseuv = -iv; /* abs, baseuok == false records sign */
941 goto float_it; /* Can't do negative powers this way. */
944 /* now we have integer ** positive integer. */
947 /* foo & (foo - 1) is zero only for a power of 2. */
948 if (!(baseuv & (baseuv - 1))) {
949 /* We are raising power-of-2 to a positive integer.
950 The logic here will work for any base (even non-integer
951 bases) but it can be less accurate than
952 pow (base,power) or exp (power * log (base)) when the
953 intermediate values start to spill out of the mantissa.
954 With powers of 2 we know this can't happen.
955 And powers of 2 are the favourite thing for perl
956 programmers to notice ** not doing what they mean. */
958 NV base = baseuok ? baseuv : -(NV)baseuv;
961 for (; power; base *= base, n++) {
962 /* Do I look like I trust gcc with long longs here?
964 UV bit = (UV)1 << (UV)n;
967 /* Only bother to clear the bit if it is set. */
969 /* Avoid squaring base again if we're done. */
970 if (power == 0) break;
978 register unsigned int highbit = 8 * sizeof(UV);
979 register unsigned int lowbit = 0;
980 register unsigned int diff;
981 bool odd_power = (bool)(power & 1);
982 while ((diff = (highbit - lowbit) >> 1)) {
983 if (baseuv & ~((1 << (lowbit + diff)) - 1))
988 /* we now have baseuv < 2 ** highbit */
989 if (power * highbit <= 8 * sizeof(UV)) {
990 /* result will definitely fit in UV, so use UV math
991 on same algorithm as above */
992 register UV result = 1;
993 register UV base = baseuv;
995 for (; power; base *= base, n++) {
996 register UV bit = (UV)1 << (UV)n;
1000 if (power == 0) break;
1004 if (baseuok || !odd_power)
1005 /* answer is positive */
1007 else if (result <= (UV)IV_MAX)
1008 /* answer negative, fits in IV */
1009 SETi( -(IV)result );
1010 else if (result == (UV)IV_MIN)
1011 /* 2's complement assumption: special case IV_MIN */
1014 /* answer negative, doesn't fit */
1015 SETn( -(NV)result );
1026 SETn( Perl_pow( left, right) );
1027 #ifdef PERL_PRESERVE_IVUV
1037 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1038 #ifdef PERL_PRESERVE_IVUV
1041 /* Unless the left argument is integer in range we are going to have to
1042 use NV maths. Hence only attempt to coerce the right argument if
1043 we know the left is integer. */
1044 /* Left operand is defined, so is it IV? */
1045 SvIV_please(TOPm1s);
1046 if (SvIOK(TOPm1s)) {
1047 bool auvok = SvUOK(TOPm1s);
1048 bool buvok = SvUOK(TOPs);
1049 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1050 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1057 alow = SvUVX(TOPm1s);
1059 IV aiv = SvIVX(TOPm1s);
1062 auvok = TRUE; /* effectively it's a UV now */
1064 alow = -aiv; /* abs, auvok == false records sign */
1070 IV biv = SvIVX(TOPs);
1073 buvok = TRUE; /* effectively it's a UV now */
1075 blow = -biv; /* abs, buvok == false records sign */
1079 /* If this does sign extension on unsigned it's time for plan B */
1080 ahigh = alow >> (4 * sizeof (UV));
1082 bhigh = blow >> (4 * sizeof (UV));
1084 if (ahigh && bhigh) {
1085 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1086 which is overflow. Drop to NVs below. */
1087 } else if (!ahigh && !bhigh) {
1088 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1089 so the unsigned multiply cannot overflow. */
1090 UV product = alow * blow;
1091 if (auvok == buvok) {
1092 /* -ve * -ve or +ve * +ve gives a +ve result. */
1096 } else if (product <= (UV)IV_MIN) {
1097 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1098 /* -ve result, which could overflow an IV */
1100 SETi( -(IV)product );
1102 } /* else drop to NVs below. */
1104 /* One operand is large, 1 small */
1107 /* swap the operands */
1109 bhigh = blow; /* bhigh now the temp var for the swap */
1113 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1114 multiplies can't overflow. shift can, add can, -ve can. */
1115 product_middle = ahigh * blow;
1116 if (!(product_middle & topmask)) {
1117 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1119 product_middle <<= (4 * sizeof (UV));
1120 product_low = alow * blow;
1122 /* as for pp_add, UV + something mustn't get smaller.
1123 IIRC ANSI mandates this wrapping *behaviour* for
1124 unsigned whatever the actual representation*/
1125 product_low += product_middle;
1126 if (product_low >= product_middle) {
1127 /* didn't overflow */
1128 if (auvok == buvok) {
1129 /* -ve * -ve or +ve * +ve gives a +ve result. */
1131 SETu( product_low );
1133 } else if (product_low <= (UV)IV_MIN) {
1134 /* 2s complement assumption again */
1135 /* -ve result, which could overflow an IV */
1137 SETi( -(IV)product_low );
1139 } /* else drop to NVs below. */
1141 } /* product_middle too large */
1142 } /* ahigh && bhigh */
1143 } /* SvIOK(TOPm1s) */
1148 SETn( left * right );
1155 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1156 /* Only try to do UV divide first
1157 if ((SLOPPYDIVIDE is true) or
1158 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1160 The assumption is that it is better to use floating point divide
1161 whenever possible, only doing integer divide first if we can't be sure.
1162 If NV_PRESERVES_UV is true then we know at compile time that no UV
1163 can be too large to preserve, so don't need to compile the code to
1164 test the size of UVs. */
1167 # define PERL_TRY_UV_DIVIDE
1168 /* ensure that 20./5. == 4. */
1170 # ifdef PERL_PRESERVE_IVUV
1171 # ifndef NV_PRESERVES_UV
1172 # define PERL_TRY_UV_DIVIDE
1177 #ifdef PERL_TRY_UV_DIVIDE
1180 SvIV_please(TOPm1s);
1181 if (SvIOK(TOPm1s)) {
1182 bool left_non_neg = SvUOK(TOPm1s);
1183 bool right_non_neg = SvUOK(TOPs);
1187 if (right_non_neg) {
1188 right = SvUVX(TOPs);
1191 IV biv = SvIVX(TOPs);
1194 right_non_neg = TRUE; /* effectively it's a UV now */
1200 /* historically undef()/0 gives a "Use of uninitialized value"
1201 warning before dieing, hence this test goes here.
1202 If it were immediately before the second SvIV_please, then
1203 DIE() would be invoked before left was even inspected, so
1204 no inpsection would give no warning. */
1206 DIE(aTHX_ "Illegal division by zero");
1209 left = SvUVX(TOPm1s);
1212 IV aiv = SvIVX(TOPm1s);
1215 left_non_neg = TRUE; /* effectively it's a UV now */
1224 /* For sloppy divide we always attempt integer division. */
1226 /* Otherwise we only attempt it if either or both operands
1227 would not be preserved by an NV. If both fit in NVs
1228 we fall through to the NV divide code below. However,
1229 as left >= right to ensure integer result here, we know that
1230 we can skip the test on the right operand - right big
1231 enough not to be preserved can't get here unless left is
1234 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1237 /* Integer division can't overflow, but it can be imprecise. */
1238 UV result = left / right;
1239 if (result * right == left) {
1240 SP--; /* result is valid */
1241 if (left_non_neg == right_non_neg) {
1242 /* signs identical, result is positive. */
1246 /* 2s complement assumption */
1247 if (result <= (UV)IV_MIN)
1248 SETi( -(IV)result );
1250 /* It's exact but too negative for IV. */
1251 SETn( -(NV)result );
1254 } /* tried integer divide but it was not an integer result */
1255 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1256 } /* left wasn't SvIOK */
1257 } /* right wasn't SvIOK */
1258 #endif /* PERL_TRY_UV_DIVIDE */
1262 DIE(aTHX_ "Illegal division by zero");
1263 PUSHn( left / right );
1270 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1274 bool left_neg = FALSE;
1275 bool right_neg = FALSE;
1276 bool use_double = FALSE;
1277 bool dright_valid = FALSE;
1283 right_neg = !SvUOK(TOPs);
1285 right = SvUVX(POPs);
1287 IV biv = SvIVX(POPs);
1290 right_neg = FALSE; /* effectively it's a UV now */
1298 right_neg = dright < 0;
1301 if (dright < UV_MAX_P1) {
1302 right = U_V(dright);
1303 dright_valid = TRUE; /* In case we need to use double below. */
1309 /* At this point use_double is only true if right is out of range for
1310 a UV. In range NV has been rounded down to nearest UV and
1311 use_double false. */
1313 if (!use_double && SvIOK(TOPs)) {
1315 left_neg = !SvUOK(TOPs);
1319 IV aiv = SvIVX(POPs);
1322 left_neg = FALSE; /* effectively it's a UV now */
1331 left_neg = dleft < 0;
1335 /* This should be exactly the 5.6 behaviour - if left and right are
1336 both in range for UV then use U_V() rather than floor. */
1338 if (dleft < UV_MAX_P1) {
1339 /* right was in range, so is dleft, so use UVs not double.
1343 /* left is out of range for UV, right was in range, so promote
1344 right (back) to double. */
1346 /* The +0.5 is used in 5.6 even though it is not strictly
1347 consistent with the implicit +0 floor in the U_V()
1348 inside the #if 1. */
1349 dleft = Perl_floor(dleft + 0.5);
1352 dright = Perl_floor(dright + 0.5);
1362 DIE(aTHX_ "Illegal modulus zero");
1364 dans = Perl_fmod(dleft, dright);
1365 if ((left_neg != right_neg) && dans)
1366 dans = dright - dans;
1369 sv_setnv(TARG, dans);
1375 DIE(aTHX_ "Illegal modulus zero");
1378 if ((left_neg != right_neg) && ans)
1381 /* XXX may warn: unary minus operator applied to unsigned type */
1382 /* could change -foo to be (~foo)+1 instead */
1383 if (ans <= ~((UV)IV_MAX)+1)
1384 sv_setiv(TARG, ~ans+1);
1386 sv_setnv(TARG, -(NV)ans);
1389 sv_setuv(TARG, ans);
1398 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1408 count = IV_MAX; /* The best we can do? */
1419 else if (SvNOKp(sv)) {
1428 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1430 I32 items = SP - MARK;
1432 static const char oom_list_extend[] =
1433 "Out of memory during list extend";
1435 max = items * count;
1436 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1437 /* Did the max computation overflow? */
1438 if (items > 0 && max > 0 && (max < items || max < count))
1439 Perl_croak(aTHX_ oom_list_extend);
1444 /* This code was intended to fix 20010809.028:
1447 for (($x =~ /./g) x 2) {
1448 print chop; # "abcdabcd" expected as output.
1451 * but that change (#11635) broke this code:
1453 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1455 * I can't think of a better fix that doesn't introduce
1456 * an efficiency hit by copying the SVs. The stack isn't
1457 * refcounted, and mortalisation obviously doesn't
1458 * Do The Right Thing when the stack has more than
1459 * one pointer to the same mortal value.
1463 *SP = sv_2mortal(newSVsv(*SP));
1473 repeatcpy((char*)(MARK + items), (char*)MARK,
1474 items * sizeof(SV*), count - 1);
1477 else if (count <= 0)
1480 else { /* Note: mark already snarfed by pp_list */
1484 static const char oom_string_extend[] =
1485 "Out of memory during string extend";
1487 SvSetSV(TARG, tmpstr);
1488 SvPV_force(TARG, len);
1489 isutf = DO_UTF8(TARG);
1494 STRLEN max = (UV)count * len;
1495 if (len > ((MEM_SIZE)~0)/count)
1496 Perl_croak(aTHX_ oom_string_extend);
1497 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1498 SvGROW(TARG, max + 1);
1499 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1500 SvCUR_set(TARG, SvCUR(TARG) * count);
1502 *SvEND(TARG) = '\0';
1505 (void)SvPOK_only_UTF8(TARG);
1507 (void)SvPOK_only(TARG);
1509 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1510 /* The parser saw this as a list repeat, and there
1511 are probably several items on the stack. But we're
1512 in scalar context, and there's no pp_list to save us
1513 now. So drop the rest of the items -- robin@kitsite.com
1526 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1527 useleft = USE_LEFT(TOPm1s);
1528 #ifdef PERL_PRESERVE_IVUV
1529 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1530 "bad things" happen if you rely on signed integers wrapping. */
1533 /* Unless the left argument is integer in range we are going to have to
1534 use NV maths. Hence only attempt to coerce the right argument if
1535 we know the left is integer. */
1536 register UV auv = 0;
1542 a_valid = auvok = 1;
1543 /* left operand is undef, treat as zero. */
1545 /* Left operand is defined, so is it IV? */
1546 SvIV_please(TOPm1s);
1547 if (SvIOK(TOPm1s)) {
1548 if ((auvok = SvUOK(TOPm1s)))
1549 auv = SvUVX(TOPm1s);
1551 register IV aiv = SvIVX(TOPm1s);
1554 auvok = 1; /* Now acting as a sign flag. */
1555 } else { /* 2s complement assumption for IV_MIN */
1563 bool result_good = 0;
1566 bool buvok = SvUOK(TOPs);
1571 register IV biv = SvIVX(TOPs);
1578 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1579 else "IV" now, independent of how it came in.
1580 if a, b represents positive, A, B negative, a maps to -A etc
1585 all UV maths. negate result if A negative.
1586 subtract if signs same, add if signs differ. */
1588 if (auvok ^ buvok) {
1597 /* Must get smaller */
1602 if (result <= buv) {
1603 /* result really should be -(auv-buv). as its negation
1604 of true value, need to swap our result flag */
1616 if (result <= (UV)IV_MIN)
1617 SETi( -(IV)result );
1619 /* result valid, but out of range for IV. */
1620 SETn( -(NV)result );
1624 } /* Overflow, drop through to NVs. */
1628 useleft = USE_LEFT(TOPm1s);
1632 /* left operand is undef, treat as zero - value */
1636 SETn( TOPn - value );
1643 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1646 if (PL_op->op_private & HINT_INTEGER) {
1660 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1663 if (PL_op->op_private & HINT_INTEGER) {
1677 dSP; tryAMAGICbinSET(lt,0);
1678 #ifdef PERL_PRESERVE_IVUV
1681 SvIV_please(TOPm1s);
1682 if (SvIOK(TOPm1s)) {
1683 bool auvok = SvUOK(TOPm1s);
1684 bool buvok = SvUOK(TOPs);
1686 if (!auvok && !buvok) { /* ## IV < IV ## */
1687 IV aiv = SvIVX(TOPm1s);
1688 IV biv = SvIVX(TOPs);
1691 SETs(boolSV(aiv < biv));
1694 if (auvok && buvok) { /* ## UV < UV ## */
1695 UV auv = SvUVX(TOPm1s);
1696 UV buv = SvUVX(TOPs);
1699 SETs(boolSV(auv < buv));
1702 if (auvok) { /* ## UV < IV ## */
1709 /* As (a) is a UV, it's >=0, so it cannot be < */
1714 SETs(boolSV(auv < (UV)biv));
1717 { /* ## IV < UV ## */
1721 aiv = SvIVX(TOPm1s);
1723 /* As (b) is a UV, it's >=0, so it must be < */
1730 SETs(boolSV((UV)aiv < buv));
1736 #ifndef NV_PRESERVES_UV
1737 #ifdef PERL_PRESERVE_IVUV
1740 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1742 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1748 SETs(boolSV(TOPn < value));
1755 dSP; tryAMAGICbinSET(gt,0);
1756 #ifdef PERL_PRESERVE_IVUV
1759 SvIV_please(TOPm1s);
1760 if (SvIOK(TOPm1s)) {
1761 bool auvok = SvUOK(TOPm1s);
1762 bool buvok = SvUOK(TOPs);
1764 if (!auvok && !buvok) { /* ## IV > IV ## */
1765 IV aiv = SvIVX(TOPm1s);
1766 IV biv = SvIVX(TOPs);
1769 SETs(boolSV(aiv > biv));
1772 if (auvok && buvok) { /* ## UV > UV ## */
1773 UV auv = SvUVX(TOPm1s);
1774 UV buv = SvUVX(TOPs);
1777 SETs(boolSV(auv > buv));
1780 if (auvok) { /* ## UV > IV ## */
1787 /* As (a) is a UV, it's >=0, so it must be > */
1792 SETs(boolSV(auv > (UV)biv));
1795 { /* ## IV > UV ## */
1799 aiv = SvIVX(TOPm1s);
1801 /* As (b) is a UV, it's >=0, so it cannot be > */
1808 SETs(boolSV((UV)aiv > buv));
1814 #ifndef NV_PRESERVES_UV
1815 #ifdef PERL_PRESERVE_IVUV
1818 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1820 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1826 SETs(boolSV(TOPn > value));
1833 dSP; tryAMAGICbinSET(le,0);
1834 #ifdef PERL_PRESERVE_IVUV
1837 SvIV_please(TOPm1s);
1838 if (SvIOK(TOPm1s)) {
1839 bool auvok = SvUOK(TOPm1s);
1840 bool buvok = SvUOK(TOPs);
1842 if (!auvok && !buvok) { /* ## IV <= IV ## */
1843 IV aiv = SvIVX(TOPm1s);
1844 IV biv = SvIVX(TOPs);
1847 SETs(boolSV(aiv <= biv));
1850 if (auvok && buvok) { /* ## UV <= UV ## */
1851 UV auv = SvUVX(TOPm1s);
1852 UV buv = SvUVX(TOPs);
1855 SETs(boolSV(auv <= buv));
1858 if (auvok) { /* ## UV <= IV ## */
1865 /* As (a) is a UV, it's >=0, so a cannot be <= */
1870 SETs(boolSV(auv <= (UV)biv));
1873 { /* ## IV <= UV ## */
1877 aiv = SvIVX(TOPm1s);
1879 /* As (b) is a UV, it's >=0, so a must be <= */
1886 SETs(boolSV((UV)aiv <= buv));
1892 #ifndef NV_PRESERVES_UV
1893 #ifdef PERL_PRESERVE_IVUV
1896 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1898 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1904 SETs(boolSV(TOPn <= value));
1911 dSP; tryAMAGICbinSET(ge,0);
1912 #ifdef PERL_PRESERVE_IVUV
1915 SvIV_please(TOPm1s);
1916 if (SvIOK(TOPm1s)) {
1917 bool auvok = SvUOK(TOPm1s);
1918 bool buvok = SvUOK(TOPs);
1920 if (!auvok && !buvok) { /* ## IV >= IV ## */
1921 IV aiv = SvIVX(TOPm1s);
1922 IV biv = SvIVX(TOPs);
1925 SETs(boolSV(aiv >= biv));
1928 if (auvok && buvok) { /* ## UV >= UV ## */
1929 UV auv = SvUVX(TOPm1s);
1930 UV buv = SvUVX(TOPs);
1933 SETs(boolSV(auv >= buv));
1936 if (auvok) { /* ## UV >= IV ## */
1943 /* As (a) is a UV, it's >=0, so it must be >= */
1948 SETs(boolSV(auv >= (UV)biv));
1951 { /* ## IV >= UV ## */
1955 aiv = SvIVX(TOPm1s);
1957 /* As (b) is a UV, it's >=0, so a cannot be >= */
1964 SETs(boolSV((UV)aiv >= buv));
1970 #ifndef NV_PRESERVES_UV
1971 #ifdef PERL_PRESERVE_IVUV
1974 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1976 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1982 SETs(boolSV(TOPn >= value));
1989 dSP; tryAMAGICbinSET(ne,0);
1990 #ifndef NV_PRESERVES_UV
1991 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1993 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1997 #ifdef PERL_PRESERVE_IVUV
2000 SvIV_please(TOPm1s);
2001 if (SvIOK(TOPm1s)) {
2002 bool auvok = SvUOK(TOPm1s);
2003 bool buvok = SvUOK(TOPs);
2005 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2006 /* Casting IV to UV before comparison isn't going to matter
2007 on 2s complement. On 1s complement or sign&magnitude
2008 (if we have any of them) it could make negative zero
2009 differ from normal zero. As I understand it. (Need to
2010 check - is negative zero implementation defined behaviour
2012 UV buv = SvUVX(POPs);
2013 UV auv = SvUVX(TOPs);
2015 SETs(boolSV(auv != buv));
2018 { /* ## Mixed IV,UV ## */
2022 /* != is commutative so swap if needed (save code) */
2024 /* swap. top of stack (b) is the iv */
2028 /* As (a) is a UV, it's >0, so it cannot be == */
2037 /* As (b) is a UV, it's >0, so it cannot be == */
2041 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2043 SETs(boolSV((UV)iv != uv));
2051 SETs(boolSV(TOPn != value));
2058 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2059 #ifndef NV_PRESERVES_UV
2060 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2061 UV right = PTR2UV(SvRV(POPs));
2062 UV left = PTR2UV(SvRV(TOPs));
2063 SETi((left > right) - (left < right));
2067 #ifdef PERL_PRESERVE_IVUV
2068 /* Fortunately it seems NaN isn't IOK */
2071 SvIV_please(TOPm1s);
2072 if (SvIOK(TOPm1s)) {
2073 bool leftuvok = SvUOK(TOPm1s);
2074 bool rightuvok = SvUOK(TOPs);
2076 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2077 IV leftiv = SvIVX(TOPm1s);
2078 IV rightiv = SvIVX(TOPs);
2080 if (leftiv > rightiv)
2082 else if (leftiv < rightiv)
2086 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2087 UV leftuv = SvUVX(TOPm1s);
2088 UV rightuv = SvUVX(TOPs);
2090 if (leftuv > rightuv)
2092 else if (leftuv < rightuv)
2096 } else if (leftuvok) { /* ## UV <=> IV ## */
2100 rightiv = SvIVX(TOPs);
2102 /* As (a) is a UV, it's >=0, so it cannot be < */
2105 leftuv = SvUVX(TOPm1s);
2106 if (leftuv > (UV)rightiv) {
2108 } else if (leftuv < (UV)rightiv) {
2114 } else { /* ## IV <=> UV ## */
2118 leftiv = SvIVX(TOPm1s);
2120 /* As (b) is a UV, it's >=0, so it must be < */
2123 rightuv = SvUVX(TOPs);
2124 if ((UV)leftiv > rightuv) {
2126 } else if ((UV)leftiv < rightuv) {
2144 if (Perl_isnan(left) || Perl_isnan(right)) {
2148 value = (left > right) - (left < right);
2152 else if (left < right)
2154 else if (left > right)
2168 dSP; tryAMAGICbinSET(slt,0);
2171 int cmp = (IN_LOCALE_RUNTIME
2172 ? sv_cmp_locale(left, right)
2173 : sv_cmp(left, right));
2174 SETs(boolSV(cmp < 0));
2181 dSP; tryAMAGICbinSET(sgt,0);
2184 int cmp = (IN_LOCALE_RUNTIME
2185 ? sv_cmp_locale(left, right)
2186 : sv_cmp(left, right));
2187 SETs(boolSV(cmp > 0));
2194 dSP; tryAMAGICbinSET(sle,0);
2197 int cmp = (IN_LOCALE_RUNTIME
2198 ? sv_cmp_locale(left, right)
2199 : sv_cmp(left, right));
2200 SETs(boolSV(cmp <= 0));
2207 dSP; tryAMAGICbinSET(sge,0);
2210 int cmp = (IN_LOCALE_RUNTIME
2211 ? sv_cmp_locale(left, right)
2212 : sv_cmp(left, right));
2213 SETs(boolSV(cmp >= 0));
2220 dSP; tryAMAGICbinSET(seq,0);
2223 SETs(boolSV(sv_eq(left, right)));
2230 dSP; tryAMAGICbinSET(sne,0);
2233 SETs(boolSV(!sv_eq(left, right)));
2240 dSP; dTARGET; tryAMAGICbin(scmp,0);
2243 int cmp = (IN_LOCALE_RUNTIME
2244 ? sv_cmp_locale(left, right)
2245 : sv_cmp(left, right));
2253 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2256 if (SvGMAGICAL(left)) mg_get(left);
2257 if (SvGMAGICAL(right)) mg_get(right);
2258 if (SvNIOKp(left) || SvNIOKp(right)) {
2259 if (PL_op->op_private & HINT_INTEGER) {
2260 IV i = SvIV_nomg(left) & SvIV_nomg(right);
2264 UV u = SvUV_nomg(left) & SvUV_nomg(right);
2269 do_vop(PL_op->op_type, TARG, left, right);
2278 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2281 if (SvGMAGICAL(left)) mg_get(left);
2282 if (SvGMAGICAL(right)) mg_get(right);
2283 if (SvNIOKp(left) || SvNIOKp(right)) {
2284 if (PL_op->op_private & HINT_INTEGER) {
2285 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2289 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2294 do_vop(PL_op->op_type, TARG, left, right);
2303 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2306 if (SvGMAGICAL(left)) mg_get(left);
2307 if (SvGMAGICAL(right)) mg_get(right);
2308 if (SvNIOKp(left) || SvNIOKp(right)) {
2309 if (PL_op->op_private & HINT_INTEGER) {
2310 IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2314 UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2319 do_vop(PL_op->op_type, TARG, left, right);
2328 dSP; dTARGET; tryAMAGICun(neg);
2331 int flags = SvFLAGS(sv);
2334 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2335 /* It's publicly an integer, or privately an integer-not-float */
2338 if (SvIVX(sv) == IV_MIN) {
2339 /* 2s complement assumption. */
2340 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2343 else if (SvUVX(sv) <= IV_MAX) {
2348 else if (SvIVX(sv) != IV_MIN) {
2352 #ifdef PERL_PRESERVE_IVUV
2361 else if (SvPOKp(sv)) {
2363 char *s = SvPV(sv, len);
2364 if (isIDFIRST(*s)) {
2365 sv_setpvn(TARG, "-", 1);
2368 else if (*s == '+' || *s == '-') {
2370 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2372 else if (DO_UTF8(sv)) {
2375 goto oops_its_an_int;
2377 sv_setnv(TARG, -SvNV(sv));
2379 sv_setpvn(TARG, "-", 1);
2386 goto oops_its_an_int;
2387 sv_setnv(TARG, -SvNV(sv));
2399 dSP; tryAMAGICunSET(not);
2400 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2406 dSP; dTARGET; tryAMAGICun(compl);
2412 if (PL_op->op_private & HINT_INTEGER) {
2413 IV i = ~SvIV_nomg(sv);
2417 UV u = ~SvUV_nomg(sv);
2426 (void)SvPV_nomg(sv,len); /* force check for uninit var */
2427 sv_setsv_nomg(TARG, sv);
2428 tmps = (U8*)SvPV_force(TARG, len);
2431 /* Calculate exact length, let's not estimate. */
2440 while (tmps < send) {
2441 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2442 tmps += UTF8SKIP(tmps);
2443 targlen += UNISKIP(~c);
2449 /* Now rewind strings and write them. */
2453 Newz(0, result, targlen + 1, U8);
2454 while (tmps < send) {
2455 UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2456 tmps += UTF8SKIP(tmps);
2457 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2461 sv_setpvn(TARG, (char*)result, targlen);
2465 Newz(0, result, nchar + 1, U8);
2466 while (tmps < send) {
2467 U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2468 tmps += UTF8SKIP(tmps);
2473 sv_setpvn(TARG, (char*)result, nchar);
2482 register long *tmpl;
2483 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2486 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2491 for ( ; anum > 0; anum--, tmps++)
2500 /* integer versions of some of the above */
2504 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2507 SETi( left * right );
2514 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2518 DIE(aTHX_ "Illegal division by zero");
2519 value = POPi / value;
2528 /* This is the vanilla old i_modulo. */
2529 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2533 DIE(aTHX_ "Illegal modulus zero");
2534 SETi( left % right );
2539 #if defined(__GLIBC__) && IVSIZE == 8
2543 /* This is the i_modulo with the workaround for the _moddi3 bug
2544 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2545 * See below for pp_i_modulo. */
2546 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2550 DIE(aTHX_ "Illegal modulus zero");
2551 SETi( left % PERL_ABS(right) );
2559 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2563 DIE(aTHX_ "Illegal modulus zero");
2564 /* The assumption is to use hereafter the old vanilla version... */
2566 PL_ppaddr[OP_I_MODULO] =
2567 &Perl_pp_i_modulo_0;
2568 /* .. but if we have glibc, we might have a buggy _moddi3
2569 * (at least glicb 2.2.5 is known to have this bug), in other
2570 * words our integer modulus with negative quad as the second
2571 * argument might be broken. Test for this and re-patch the
2572 * opcode dispatch table if that is the case, remembering to
2573 * also apply the workaround so that this first round works
2574 * right, too. See [perl #9402] for more information. */
2575 #if defined(__GLIBC__) && IVSIZE == 8
2579 /* Cannot do this check with inlined IV constants since
2580 * that seems to work correctly even with the buggy glibc. */
2582 /* Yikes, we have the bug.
2583 * Patch in the workaround version. */
2585 PL_ppaddr[OP_I_MODULO] =
2586 &Perl_pp_i_modulo_1;
2587 /* Make certain we work right this time, too. */
2588 right = PERL_ABS(right);
2592 SETi( left % right );
2599 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2602 SETi( left + right );
2609 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2612 SETi( left - right );
2619 dSP; tryAMAGICbinSET(lt,0);
2622 SETs(boolSV(left < right));
2629 dSP; tryAMAGICbinSET(gt,0);
2632 SETs(boolSV(left > right));
2639 dSP; tryAMAGICbinSET(le,0);
2642 SETs(boolSV(left <= right));
2649 dSP; tryAMAGICbinSET(ge,0);
2652 SETs(boolSV(left >= right));
2659 dSP; tryAMAGICbinSET(eq,0);
2662 SETs(boolSV(left == right));
2669 dSP; tryAMAGICbinSET(ne,0);
2672 SETs(boolSV(left != right));
2679 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2686 else if (left < right)
2697 dSP; dTARGET; tryAMAGICun(neg);
2702 /* High falutin' math. */
2706 dSP; dTARGET; tryAMAGICbin(atan2,0);
2709 SETn(Perl_atan2(left, right));
2716 dSP; dTARGET; tryAMAGICun(sin);
2720 value = Perl_sin(value);
2728 dSP; dTARGET; tryAMAGICun(cos);
2732 value = Perl_cos(value);
2738 /* Support Configure command-line overrides for rand() functions.
2739 After 5.005, perhaps we should replace this by Configure support
2740 for drand48(), random(), or rand(). For 5.005, though, maintain
2741 compatibility by calling rand() but allow the user to override it.
2742 See INSTALL for details. --Andy Dougherty 15 July 1998
2744 /* Now it's after 5.005, and Configure supports drand48() and random(),
2745 in addition to rand(). So the overrides should not be needed any more.
2746 --Jarkko Hietaniemi 27 September 1998
2749 #ifndef HAS_DRAND48_PROTO
2750 extern double drand48 (void);
2763 if (!PL_srand_called) {
2764 (void)seedDrand01((Rand_seed_t)seed());
2765 PL_srand_called = TRUE;
2780 (void)seedDrand01((Rand_seed_t)anum);
2781 PL_srand_called = TRUE;
2788 dSP; dTARGET; tryAMAGICun(exp);
2792 value = Perl_exp(value);
2800 dSP; dTARGET; tryAMAGICun(log);
2805 SET_NUMERIC_STANDARD();
2806 DIE(aTHX_ "Can't take log of %"NVgf, value);
2808 value = Perl_log(value);
2816 dSP; dTARGET; tryAMAGICun(sqrt);
2821 SET_NUMERIC_STANDARD();
2822 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2824 value = Perl_sqrt(value);
2832 dSP; dTARGET; tryAMAGICun(int);
2835 IV iv = TOPi; /* attempt to convert to IV if possible. */
2836 /* XXX it's arguable that compiler casting to IV might be subtly
2837 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2838 else preferring IV has introduced a subtle behaviour change bug. OTOH
2839 relying on floating point to be accurate is a bug. */
2843 else if (SvIOK(TOPs)) {
2852 if (value < (NV)UV_MAX + 0.5) {
2855 SETn(Perl_floor(value));
2859 if (value > (NV)IV_MIN - 0.5) {
2862 SETn(Perl_ceil(value));
2872 dSP; dTARGET; tryAMAGICun(abs);
2874 /* This will cache the NV value if string isn't actually integer */
2879 else if (SvIOK(TOPs)) {
2880 /* IVX is precise */
2882 SETu(TOPu); /* force it to be numeric only */
2890 /* 2s complement assumption. Also, not really needed as
2891 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2911 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2917 tmps = (SvPVx(sv, len));
2919 /* If Unicode, try to downgrade
2920 * If not possible, croak. */
2921 SV* tsv = sv_2mortal(newSVsv(sv));
2924 sv_utf8_downgrade(tsv, FALSE);
2927 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2928 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2941 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2947 tmps = (SvPVx(sv, len));
2949 /* If Unicode, try to downgrade
2950 * If not possible, croak. */
2951 SV* tsv = sv_2mortal(newSVsv(sv));
2954 sv_utf8_downgrade(tsv, FALSE);
2957 while (*tmps && len && isSPACE(*tmps))
2962 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2963 else if (*tmps == 'b')
2964 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2966 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2968 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2985 SETi(sv_len_utf8(sv));
3001 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3003 const I32 arybase = PL_curcop->cop_arybase;
3005 const char *repl = 0;
3007 int num_args = PL_op->op_private & 7;
3008 bool repl_need_utf8_upgrade = FALSE;
3009 bool repl_is_utf8 = FALSE;
3011 SvTAINTED_off(TARG); /* decontaminate */
3012 SvUTF8_off(TARG); /* decontaminate */
3016 repl = SvPV(repl_sv, repl_len);
3017 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3027 sv_utf8_upgrade(sv);
3029 else if (DO_UTF8(sv))
3030 repl_need_utf8_upgrade = TRUE;
3032 tmps = SvPV(sv, curlen);
3034 utf8_curlen = sv_len_utf8(sv);
3035 if (utf8_curlen == curlen)
3038 curlen = utf8_curlen;
3043 if (pos >= arybase) {
3061 else if (len >= 0) {
3063 if (rem > (I32)curlen)
3078 Perl_croak(aTHX_ "substr outside of string");
3079 if (ckWARN(WARN_SUBSTR))
3080 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3087 sv_pos_u2b(sv, &pos, &rem);
3089 /* we either return a PV or an LV. If the TARG hasn't been used
3090 * before, or is of that type, reuse it; otherwise use a mortal
3091 * instead. Note that LVs can have an extended lifetime, so also
3092 * dont reuse if refcount > 1 (bug #20933) */
3093 if (SvTYPE(TARG) > SVt_NULL) {
3094 if ( (SvTYPE(TARG) == SVt_PVLV)
3095 ? (!lvalue || SvREFCNT(TARG) > 1)
3098 TARG = sv_newmortal();
3102 sv_setpvn(TARG, tmps, rem);
3103 #ifdef USE_LOCALE_COLLATE
3104 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3109 SV* repl_sv_copy = NULL;
3111 if (repl_need_utf8_upgrade) {
3112 repl_sv_copy = newSVsv(repl_sv);
3113 sv_utf8_upgrade(repl_sv_copy);
3114 repl = SvPV(repl_sv_copy, repl_len);
3115 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3117 sv_insert(sv, pos, rem, repl, repl_len);
3121 SvREFCNT_dec(repl_sv_copy);
3123 else if (lvalue) { /* it's an lvalue! */
3124 if (!SvGMAGICAL(sv)) {
3128 if (ckWARN(WARN_SUBSTR))
3129 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3130 "Attempt to use reference as lvalue in substr");
3132 if (SvOK(sv)) /* is it defined ? */
3133 (void)SvPOK_only_UTF8(sv);
3135 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3138 if (SvTYPE(TARG) < SVt_PVLV) {
3139 sv_upgrade(TARG, SVt_PVLV);
3140 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3146 if (LvTARG(TARG) != sv) {
3148 SvREFCNT_dec(LvTARG(TARG));
3149 LvTARG(TARG) = SvREFCNT_inc(sv);
3151 LvTARGOFF(TARG) = upos;
3152 LvTARGLEN(TARG) = urem;
3156 PUSHs(TARG); /* avoid SvSETMAGIC here */
3163 register IV size = POPi;
3164 register IV offset = POPi;
3165 register SV *src = POPs;
3166 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3168 SvTAINTED_off(TARG); /* decontaminate */
3169 if (lvalue) { /* it's an lvalue! */
3170 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3171 TARG = sv_newmortal();
3172 if (SvTYPE(TARG) < SVt_PVLV) {
3173 sv_upgrade(TARG, SVt_PVLV);
3174 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3177 if (LvTARG(TARG) != src) {
3179 SvREFCNT_dec(LvTARG(TARG));
3180 LvTARG(TARG) = SvREFCNT_inc(src);
3182 LvTARGOFF(TARG) = offset;
3183 LvTARGLEN(TARG) = size;
3186 sv_setuv(TARG, do_vecget(src, offset, size));
3202 I32 arybase = PL_curcop->cop_arybase;
3209 offset = POPi - arybase;
3212 big_utf8 = DO_UTF8(big);
3213 little_utf8 = DO_UTF8(little);
3214 if (big_utf8 ^ little_utf8) {
3215 /* One needs to be upgraded. */
3216 SV *bytes = little_utf8 ? big : little;
3218 char *p = SvPV(bytes, len);
3220 temp = newSVpvn(p, len);
3223 sv_recode_to_utf8(temp, PL_encoding);
3225 sv_utf8_upgrade(temp);
3234 if (big_utf8 && offset > 0)
3235 sv_pos_u2b(big, &offset, 0);
3236 tmps = SvPV(big, biglen);
3239 else if (offset > (I32)biglen)
3241 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3242 (unsigned char*)tmps + biglen, little, 0)))
3245 retval = tmps2 - tmps;
3246 if (retval > 0 && big_utf8)
3247 sv_pos_b2u(big, &retval);
3250 PUSHi(retval + arybase);
3266 I32 arybase = PL_curcop->cop_arybase;
3274 big_utf8 = DO_UTF8(big);
3275 little_utf8 = DO_UTF8(little);
3276 if (big_utf8 ^ little_utf8) {
3277 /* One needs to be upgraded. */
3278 SV *bytes = little_utf8 ? big : little;
3280 char *p = SvPV(bytes, len);
3282 temp = newSVpvn(p, len);
3285 sv_recode_to_utf8(temp, PL_encoding);
3287 sv_utf8_upgrade(temp);
3296 tmps2 = SvPV(little, llen);
3297 tmps = SvPV(big, blen);
3302 if (offset > 0 && big_utf8)
3303 sv_pos_u2b(big, &offset, 0);
3304 offset = offset - arybase + llen;
3308 else if (offset > (I32)blen)
3310 if (!(tmps2 = rninstr(tmps, tmps + offset,
3311 tmps2, tmps2 + llen)))
3314 retval = tmps2 - tmps;
3315 if (retval > 0 && big_utf8)
3316 sv_pos_b2u(big, &retval);
3319 PUSHi(retval + arybase);
3325 dSP; dMARK; dORIGMARK; dTARGET;
3326 do_sprintf(TARG, SP-MARK, MARK+1);
3327 TAINT_IF(SvTAINTED(TARG));
3328 if (DO_UTF8(*(MARK+1)))
3340 U8 *s = (U8*)SvPVx(argsv, len);
3343 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3344 tmpsv = sv_2mortal(newSVsv(argsv));
3345 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3349 XPUSHu(DO_UTF8(argsv) ?
3350 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3362 (void)SvUPGRADE(TARG,SVt_PV);
3364 if (value > 255 && !IN_BYTES) {
3365 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3366 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3367 SvCUR_set(TARG, tmps - SvPVX(TARG));
3369 (void)SvPOK_only(TARG);
3378 *tmps++ = (char)value;
3380 (void)SvPOK_only(TARG);
3381 if (PL_encoding && !IN_BYTES) {
3382 sv_recode_to_utf8(TARG, PL_encoding);
3384 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3385 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3389 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3390 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3406 char *tmps = SvPV(left, len);
3408 if (DO_UTF8(left)) {
3409 /* If Unicode, try to downgrade.
3410 * If not possible, croak.
3411 * Yes, we made this up. */
3412 SV* tsv = sv_2mortal(newSVsv(left));
3415 sv_utf8_downgrade(tsv, FALSE);
3418 # ifdef USE_ITHREADS
3420 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3421 /* This should be threadsafe because in ithreads there is only
3422 * one thread per interpreter. If this would not be true,
3423 * we would need a mutex to protect this malloc. */
3424 PL_reentrant_buffer->_crypt_struct_buffer =
3425 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3426 #if defined(__GLIBC__) || defined(__EMX__)
3427 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3428 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3429 /* work around glibc-2.2.5 bug */
3430 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3434 # endif /* HAS_CRYPT_R */
3435 # endif /* USE_ITHREADS */
3437 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
3439 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
3445 "The crypt() function is unimplemented due to excessive paranoia.");
3458 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3459 UTF8_IS_START(*s)) {
3460 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3464 utf8_to_uvchr(s, &ulen);
3465 toTITLE_utf8(s, tmpbuf, &tculen);
3466 utf8_to_uvchr(tmpbuf, 0);
3468 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3470 /* slen is the byte length of the whole SV.
3471 * ulen is the byte length of the original Unicode character
3472 * stored as UTF-8 at s.
3473 * tculen is the byte length of the freshly titlecased
3474 * Unicode character stored as UTF-8 at tmpbuf.
3475 * We first set the result to be the titlecased character,
3476 * and then append the rest of the SV data. */
3477 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3479 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3484 s = (U8*)SvPV_force_nomg(sv, slen);
3485 Copy(tmpbuf, s, tculen, U8);
3489 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3491 SvUTF8_off(TARG); /* decontaminate */
3492 sv_setsv_nomg(TARG, sv);
3496 s = (U8*)SvPV_force_nomg(sv, slen);
3498 if (IN_LOCALE_RUNTIME) {
3501 *s = toUPPER_LC(*s);
3520 (s = (U8*)SvPV_nomg(sv, slen)) && slen &&
3521 UTF8_IS_START(*s)) {
3523 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3527 toLOWER_utf8(s, tmpbuf, &ulen);
3528 uv = utf8_to_uvchr(tmpbuf, 0);
3529 tend = uvchr_to_utf8(tmpbuf, uv);
3531 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3533 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3535 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3540 s = (U8*)SvPV_force_nomg(sv, slen);
3541 Copy(tmpbuf, s, ulen, U8);
3545 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3547 SvUTF8_off(TARG); /* decontaminate */
3548 sv_setsv_nomg(TARG, sv);
3552 s = (U8*)SvPV_force_nomg(sv, slen);
3554 if (IN_LOCALE_RUNTIME) {
3557 *s = toLOWER_LC(*s);
3580 U8 tmpbuf[UTF8_MAXBYTES+1];
3582 s = (U8*)SvPV_nomg(sv,len);
3584 SvUTF8_off(TARG); /* decontaminate */
3585 sv_setpvn(TARG, "", 0);
3589 STRLEN min = len + 1;
3591 (void)SvUPGRADE(TARG, SVt_PV);
3593 (void)SvPOK_only(TARG);
3594 d = (U8*)SvPVX(TARG);
3597 STRLEN u = UTF8SKIP(s);
3599 toUPPER_utf8(s, tmpbuf, &ulen);
3600 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3601 /* If the eventually required minimum size outgrows
3602 * the available space, we need to grow. */
3603 UV o = d - (U8*)SvPVX(TARG);
3605 /* If someone uppercases one million U+03B0s we
3606 * SvGROW() one million times. Or we could try
3607 * guessing how much to allocate without allocating
3608 * too much. Such is life. */
3610 d = (U8*)SvPVX(TARG) + o;
3612 Copy(tmpbuf, d, ulen, U8);
3618 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3623 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3625 SvUTF8_off(TARG); /* decontaminate */
3626 sv_setsv_nomg(TARG, sv);
3630 s = (U8*)SvPV_force_nomg(sv, len);
3632 register U8 *send = s + len;
3634 if (IN_LOCALE_RUNTIME) {
3637 for (; s < send; s++)
3638 *s = toUPPER_LC(*s);
3641 for (; s < send; s++)
3663 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3665 s = (U8*)SvPV_nomg(sv,len);
3667 SvUTF8_off(TARG); /* decontaminate */
3668 sv_setpvn(TARG, "", 0);
3672 STRLEN min = len + 1;
3674 (void)SvUPGRADE(TARG, SVt_PV);
3676 (void)SvPOK_only(TARG);
3677 d = (U8*)SvPVX(TARG);
3680 STRLEN u = UTF8SKIP(s);
3681 UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3683 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3684 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3686 * Now if the sigma is NOT followed by
3687 * /$ignorable_sequence$cased_letter/;
3688 * and it IS preceded by
3689 * /$cased_letter$ignorable_sequence/;
3690 * where $ignorable_sequence is
3691 * [\x{2010}\x{AD}\p{Mn}]*
3692 * and $cased_letter is
3693 * [\p{Ll}\p{Lo}\p{Lt}]
3694 * then it should be mapped to 0x03C2,
3695 * (GREEK SMALL LETTER FINAL SIGMA),
3696 * instead of staying 0x03A3.
3697 * "should be": in other words,
3698 * this is not implemented yet.
3699 * See lib/unicore/SpecialCasing.txt.
3702 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3703 /* If the eventually required minimum size outgrows
3704 * the available space, we need to grow. */
3705 UV o = d - (U8*)SvPVX(TARG);
3707 /* If someone lowercases one million U+0130s we
3708 * SvGROW() one million times. Or we could try
3709 * guessing how much to allocate without allocating.
3710 * too much. Such is life. */
3712 d = (U8*)SvPVX(TARG) + o;
3714 Copy(tmpbuf, d, ulen, U8);
3720 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
3725 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3727 SvUTF8_off(TARG); /* decontaminate */
3728 sv_setsv_nomg(TARG, sv);
3733 s = (U8*)SvPV_force_nomg(sv, len);
3735 register U8 *send = s + len;
3737 if (IN_LOCALE_RUNTIME) {
3740 for (; s < send; s++)
3741 *s = toLOWER_LC(*s);
3744 for (; s < send; s++)
3758 register char *s = SvPV(sv,len);
3761 SvUTF8_off(TARG); /* decontaminate */
3763 (void)SvUPGRADE(TARG, SVt_PV);
3764 SvGROW(TARG, (len * 2) + 1);
3768 if (UTF8_IS_CONTINUED(*s)) {
3769 STRLEN ulen = UTF8SKIP(s);
3793 SvCUR_set(TARG, d - SvPVX(TARG));
3794 (void)SvPOK_only_UTF8(TARG);
3797 sv_setpvn(TARG, s, len);
3799 if (SvSMAGICAL(TARG))
3808 dSP; dMARK; dORIGMARK;
3810 register AV* av = (AV*)POPs;
3811 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3812 I32 arybase = PL_curcop->cop_arybase;
3815 if (SvTYPE(av) == SVt_PVAV) {
3816 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3818 for (svp = MARK + 1; svp <= SP; svp++) {
3823 if (max > AvMAX(av))
3826 while (++MARK <= SP) {
3827 elem = SvIVx(*MARK);
3831 svp = av_fetch(av, elem, lval);
3833 if (!svp || *svp == &PL_sv_undef)
3834 DIE(aTHX_ PL_no_aelem, elem);
3835 if (PL_op->op_private & OPpLVAL_INTRO)
3836 save_aelem(av, elem, svp);
3838 *MARK = svp ? *svp : &PL_sv_undef;
3841 if (GIMME != G_ARRAY) {
3843 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3849 /* Associative arrays. */
3854 HV *hash = (HV*)POPs;
3856 const I32 gimme = GIMME_V;
3859 /* might clobber stack_sp */
3860 entry = hv_iternext(hash);
3865 SV* sv = hv_iterkeysv(entry);
3866 PUSHs(sv); /* won't clobber stack_sp */
3867 if (gimme == G_ARRAY) {
3870 /* might clobber stack_sp */
3871 val = hv_iterval(hash, entry);
3876 else if (gimme == G_SCALAR)
3895 const I32 gimme = GIMME_V;
3896 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3900 if (PL_op->op_private & OPpSLICE) {
3904 hvtype = SvTYPE(hv);
3905 if (hvtype == SVt_PVHV) { /* hash element */
3906 while (++MARK <= SP) {
3907 sv = hv_delete_ent(hv, *MARK, discard, 0);
3908 *MARK = sv ? sv : &PL_sv_undef;
3911 else if (hvtype == SVt_PVAV) { /* array element */
3912 if (PL_op->op_flags & OPf_SPECIAL) {
3913 while (++MARK <= SP) {
3914 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3915 *MARK = sv ? sv : &PL_sv_undef;
3920 DIE(aTHX_ "Not a HASH reference");
3923 else if (gimme == G_SCALAR) {
3928 *++MARK = &PL_sv_undef;
3935 if (SvTYPE(hv) == SVt_PVHV)
3936 sv = hv_delete_ent(hv, keysv, discard, 0);
3937 else if (SvTYPE(hv) == SVt_PVAV) {
3938 if (PL_op->op_flags & OPf_SPECIAL)
3939 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3941 DIE(aTHX_ "panic: avhv_delete no longer supported");
3944 DIE(aTHX_ "Not a HASH reference");
3959 if (PL_op->op_private & OPpEXISTS_SUB) {
3963 cv = sv_2cv(sv, &hv, &gv, FALSE);
3966 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3972 if (SvTYPE(hv) == SVt_PVHV) {
3973 if (hv_exists_ent(hv, tmpsv, 0))
3976 else if (SvTYPE(hv) == SVt_PVAV) {
3977 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3978 if (av_exists((AV*)hv, SvIV(tmpsv)))
3983 DIE(aTHX_ "Not a HASH reference");
3990 dSP; dMARK; dORIGMARK;
3991 register HV *hv = (HV*)POPs;
3992 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3993 bool localizing = PL_op->op_private & OPpLVAL_INTRO ? TRUE : FALSE;
3994 bool other_magic = FALSE;
4000 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
4001 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
4002 /* Try to preserve the existenceness of a tied hash
4003 * element by using EXISTS and DELETE if possible.
4004 * Fallback to FETCH and STORE otherwise */
4005 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
4006 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
4007 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
4010 while (++MARK <= SP) {
4014 bool preeminent = FALSE;
4017 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
4018 hv_exists_ent(hv, keysv, 0);
4021 he = hv_fetch_ent(hv, keysv, lval, 0);
4022 svp = he ? &HeVAL(he) : 0;
4025 if (!svp || *svp == &PL_sv_undef) {
4026 DIE(aTHX_ PL_no_helem_sv, keysv);
4030 save_helem(hv, keysv, svp);
4033 char *key = SvPV(keysv, keylen);
4034 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4038 *MARK = svp ? *svp : &PL_sv_undef;
4040 if (GIMME != G_ARRAY) {
4042 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4048 /* List operators. */
4053 if (GIMME != G_ARRAY) {
4055 *MARK = *SP; /* unwanted list, return last item */
4057 *MARK = &PL_sv_undef;
4066 SV **lastrelem = PL_stack_sp;
4067 SV **lastlelem = PL_stack_base + POPMARK;
4068 SV **firstlelem = PL_stack_base + POPMARK + 1;
4069 register SV **firstrelem = lastlelem + 1;
4070 I32 arybase = PL_curcop->cop_arybase;
4071 I32 lval = PL_op->op_flags & OPf_MOD;
4072 I32 is_something_there = lval;
4074 register I32 max = lastrelem - lastlelem;
4075 register SV **lelem;
4078 if (GIMME != G_ARRAY) {
4079 ix = SvIVx(*lastlelem);
4084 if (ix < 0 || ix >= max)
4085 *firstlelem = &PL_sv_undef;
4087 *firstlelem = firstrelem[ix];
4093 SP = firstlelem - 1;
4097 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4103 if (ix < 0 || ix >= max)
4104 *lelem = &PL_sv_undef;
4106 is_something_there = TRUE;
4107 if (!(*lelem = firstrelem[ix]))
4108 *lelem = &PL_sv_undef;
4111 if (is_something_there)
4114 SP = firstlelem - 1;
4120 dSP; dMARK; dORIGMARK;
4121 I32 items = SP - MARK;
4122 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
4123 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4130 dSP; dMARK; dORIGMARK;
4131 HV* hv = (HV*)sv_2mortal((SV*)newHV());
4135 SV *val = NEWSV(46, 0);
4137 sv_setsv(val, *++MARK);
4138 else if (ckWARN(WARN_MISC))
4139 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4140 (void)hv_store_ent(hv,key,val,0);
4149 dVAR; dSP; dMARK; dORIGMARK;
4150 register AV *ary = (AV*)*++MARK;
4154 register I32 offset;
4155 register I32 length;
4162 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4163 *MARK-- = SvTIED_obj((SV*)ary, mg);
4167 call_method("SPLICE",GIMME_V);
4176 offset = i = SvIVx(*MARK);
4178 offset += AvFILLp(ary) + 1;
4180 offset -= PL_curcop->cop_arybase;
4182 DIE(aTHX_ PL_no_aelem, i);
4184 length = SvIVx(*MARK++);
4186 length += AvFILLp(ary) - offset + 1;
4192 length = AvMAX(ary) + 1; /* close enough to infinity */
4196 length = AvMAX(ary) + 1;
4198 if (offset > AvFILLp(ary) + 1) {
4199 if (ckWARN(WARN_MISC))
4200 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4201 offset = AvFILLp(ary) + 1;
4203 after = AvFILLp(ary) + 1 - (offset + length);
4204 if (after < 0) { /* not that much array */
4205 length += after; /* offset+length now in array */
4211 /* At this point, MARK .. SP-1 is our new LIST */
4214 diff = newlen - length;
4215 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4218 /* make new elements SVs now: avoid problems if they're from the array */
4219 for (dst = MARK, i = newlen; i; i--) {
4221 *dst++ = newSVsv(h);
4224 if (diff < 0) { /* shrinking the area */
4226 New(451, tmparyval, newlen, SV*); /* so remember insertion */
4227 Copy(MARK, tmparyval, newlen, SV*);
4230 MARK = ORIGMARK + 1;
4231 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4232 MEXTEND(MARK, length);
4233 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4235 EXTEND_MORTAL(length);
4236 for (i = length, dst = MARK; i; i--) {
4237 sv_2mortal(*dst); /* free them eventualy */
4244 *MARK = AvARRAY(ary)[offset+length-1];
4247 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4248 SvREFCNT_dec(*dst++); /* free them now */
4251 AvFILLp(ary) += diff;
4253 /* pull up or down? */
4255 if (offset < after) { /* easier to pull up */
4256 if (offset) { /* esp. if nothing to pull */
4257 src = &AvARRAY(ary)[offset-1];
4258 dst = src - diff; /* diff is negative */
4259 for (i = offset; i > 0; i--) /* can't trust Copy */
4263 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4267 if (after) { /* anything to pull down? */
4268 src = AvARRAY(ary) + offset + length;
4269 dst = src + diff; /* diff is negative */
4270 Move(src, dst, after, SV*);
4272 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4273 /* avoid later double free */
4277 dst[--i] = &PL_sv_undef;
4280 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4281 Safefree(tmparyval);
4284 else { /* no, expanding (or same) */
4286 New(452, tmparyval, length, SV*); /* so remember deletion */
4287 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4290 if (diff > 0) { /* expanding */
4292 /* push up or down? */
4294 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4298 Move(src, dst, offset, SV*);
4300 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4302 AvFILLp(ary) += diff;
4305 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4306 av_extend(ary, AvFILLp(ary) + diff);
4307 AvFILLp(ary) += diff;
4310 dst = AvARRAY(ary) + AvFILLp(ary);
4312 for (i = after; i; i--) {
4320 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4323 MARK = ORIGMARK + 1;
4324 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4326 Copy(tmparyval, MARK, length, SV*);
4328 EXTEND_MORTAL(length);
4329 for (i = length, dst = MARK; i; i--) {
4330 sv_2mortal(*dst); /* free them eventualy */
4334 Safefree(tmparyval);
4338 else if (length--) {
4339 *MARK = tmparyval[length];
4342 while (length-- > 0)
4343 SvREFCNT_dec(tmparyval[length]);
4345 Safefree(tmparyval);
4348 *MARK = &PL_sv_undef;
4356 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4357 register AV *ary = (AV*)*++MARK;
4358 register SV *sv = &PL_sv_undef;
4361 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4362 *MARK-- = SvTIED_obj((SV*)ary, mg);
4366 call_method("PUSH",G_SCALAR|G_DISCARD);
4371 /* Why no pre-extend of ary here ? */
4372 for (++MARK; MARK <= SP; MARK++) {
4375 sv_setsv(sv, *MARK);
4380 PUSHi( AvFILL(ary) + 1 );
4388 SV *sv = av_pop(av);
4390 (void)sv_2mortal(sv);
4399 SV *sv = av_shift(av);
4404 (void)sv_2mortal(sv);
4411 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4412 register AV *ary = (AV*)*++MARK;
4417 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4418 *MARK-- = SvTIED_obj((SV*)ary, mg);
4422 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4427 av_unshift(ary, SP - MARK);
4429 sv = newSVsv(*++MARK);
4430 (void)av_store(ary, i++, sv);
4434 PUSHi( AvFILL(ary) + 1 );
4444 if (GIMME == G_ARRAY) {
4451 /* safe as long as stack cannot get extended in the above */
4456 register char *down;
4462 SvUTF8_off(TARG); /* decontaminate */
4464 do_join(TARG, &PL_sv_no, MARK, SP);
4466 sv_setsv(TARG, (SP > MARK)
4468 : (padoff_du = find_rundefsvoffset(),
4469 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4470 ? DEFSV : PAD_SVl(padoff_du)));
4471 up = SvPV_force(TARG, len);
4473 if (DO_UTF8(TARG)) { /* first reverse each character */
4474 U8* s = (U8*)SvPVX(TARG);
4475 U8* send = (U8*)(s + len);
4477 if (UTF8_IS_INVARIANT(*s)) {
4482 if (!utf8_to_uvchr(s, 0))
4486 down = (char*)(s - 1);
4487 /* reverse this character */
4491 *down-- = (char)tmp;
4497 down = SvPVX(TARG) + len - 1;
4501 *down-- = (char)tmp;
4503 (void)SvPOK_only_UTF8(TARG);
4515 register IV limit = POPi; /* note, negative is forever */
4518 register char *s = SvPV(sv, len);
4519 bool do_utf8 = DO_UTF8(sv);
4520 char *strend = s + len;
4522 register REGEXP *rx;
4526 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4527 I32 maxiters = slen + 10;
4530 I32 origlimit = limit;
4533 const I32 gimme = GIMME_V;
4534 const I32 oldsave = PL_savestack_ix;
4535 I32 make_mortal = 1;
4537 MAGIC *mg = (MAGIC *) NULL;
4540 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4545 DIE(aTHX_ "panic: pp_split");
4548 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4549 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4551 RX_MATCH_UTF8_set(rx, do_utf8);
4553 if (pm->op_pmreplroot) {
4555 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4557 ary = GvAVn((GV*)pm->op_pmreplroot);
4560 else if (gimme != G_ARRAY)
4561 ary = GvAVn(PL_defgv);
4564 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4570 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4572 XPUSHs(SvTIED_obj((SV*)ary, mg));
4578 for (i = AvFILLp(ary); i >= 0; i--)
4579 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4581 /* temporarily switch stacks */
4582 SAVESWITCHSTACK(PL_curstack, ary);
4586 base = SP - PL_stack_base;
4588 if (pm->op_pmflags & PMf_SKIPWHITE) {
4589 if (pm->op_pmflags & PMf_LOCALE) {
4590 while (isSPACE_LC(*s))
4598 if (pm->op_pmflags & PMf_MULTILINE) {
4603 limit = maxiters + 2;
4604 if (pm->op_pmflags & PMf_WHITE) {
4607 while (m < strend &&
4608 !((pm->op_pmflags & PMf_LOCALE)
4609 ? isSPACE_LC(*m) : isSPACE(*m)))
4614 dstr = newSVpvn(s, m-s);
4618 (void)SvUTF8_on(dstr);
4622 while (s < strend &&
4623 ((pm->op_pmflags & PMf_LOCALE)
4624 ? isSPACE_LC(*s) : isSPACE(*s)))
4628 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4631 for (m = s; m < strend && *m != '\n'; m++) ;
4635 dstr = newSVpvn(s, m-s);
4639 (void)SvUTF8_on(dstr);
4644 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4645 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4646 && (rx->reganch & ROPT_CHECK_ALL)
4647 && !(rx->reganch & ROPT_ANCH)) {
4648 int tail = (rx->reganch & RE_INTUIT_TAIL);
4649 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4652 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4654 char c = *SvPV(csv, n_a);
4657 for (m = s; m < strend && *m != c; m++) ;
4660 dstr = newSVpvn(s, m-s);
4664 (void)SvUTF8_on(dstr);
4666 /* The rx->minlen is in characters but we want to step
4667 * s ahead by bytes. */
4669 s = (char*)utf8_hop((U8*)m, len);
4671 s = m + len; /* Fake \n at the end */
4675 while (s < strend && --limit &&
4676 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4677 csv, multiline ? FBMrf_MULTILINE : 0)) )
4679 dstr = newSVpvn(s, m-s);
4683 (void)SvUTF8_on(dstr);
4685 /* The rx->minlen is in characters but we want to step
4686 * s ahead by bytes. */
4688 s = (char*)utf8_hop((U8*)m, len);
4690 s = m + len; /* Fake \n at the end */
4695 maxiters += slen * rx->nparens;
4696 while (s < strend && --limit)
4699 i = CALLREGEXEC(aTHX_ rx, s, strend, orig, 1 , sv, NULL, 0);
4703 TAINT_IF(RX_MATCH_TAINTED(rx));
4704 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4709 strend = s + (strend - m);
4711 m = rx->startp[0] + orig;
4712 dstr = newSVpvn(s, m-s);
4716 (void)SvUTF8_on(dstr);
4719 for (i = 1; i <= (I32)rx->nparens; i++) {
4720 s = rx->startp[i] + orig;
4721 m = rx->endp[i] + orig;
4723 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4724 parens that didn't match -- they should be set to
4725 undef, not the empty string */
4726 if (m >= orig && s >= orig) {
4727 dstr = newSVpvn(s, m-s);
4730 dstr = &PL_sv_undef; /* undef, not "" */
4734 (void)SvUTF8_on(dstr);
4738 s = rx->endp[0] + orig;
4742 iters = (SP - PL_stack_base) - base;
4743 if (iters > maxiters)
4744 DIE(aTHX_ "Split loop");
4746 /* keep field after final delim? */
4747 if (s < strend || (iters && origlimit)) {
4748 STRLEN l = strend - s;
4749 dstr = newSVpvn(s, l);
4753 (void)SvUTF8_on(dstr);
4757 else if (!origlimit) {
4758 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4759 if (TOPs && !make_mortal)
4762 *SP-- = &PL_sv_undef;
4767 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4771 if (SvSMAGICAL(ary)) {
4776 if (gimme == G_ARRAY) {
4778 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4786 call_method("PUSH",G_SCALAR|G_DISCARD);
4789 if (gimme == G_ARRAY) {
4790 /* EXTEND should not be needed - we just popped them */
4792 for (i=0; i < iters; i++) {
4793 SV **svp = av_fetch(ary, i, FALSE);
4794 PUSHs((svp) ? *svp : &PL_sv_undef);
4801 if (gimme == G_ARRAY)
4816 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4817 || SvTYPE(retsv) == SVt_PVCV) {
4818 retsv = refto(retsv);
4826 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
4831 * c-indentation-style: bsd
4833 * indent-tabs-mode: t
4836 * ex: set ts=8 sts=4 sw=4 noet: